package Class::FIOC; require Exporter; use strict; our @ISA = qw(Exporter); our @EXPORT = qw(methods); our %Classes; our $DEBUG=0; sub methods { my $class = caller(); my %method_map = %{+shift}; # any old ref will work, one day maybe the user can choose the ref my $self = bless [],$class; # see if we already have seen this class before if (my $method_names=$Classes{$class}) { while (my ($name,$ref)=each(%method_map)) { # validate reference refers to CODE if (ref($ref) ne "CODE") { die "values passed to 'methods' hash must be CODE references!\n"; } # validate that this is not a new method name # maybe new method names should be allowed? I don't know if (my $hash=$method_names->{$name}) { $hash->{$self}=$ref; }else { die "Cannot add new method '$name' to class $class!\n"; } } } else { my %method_names; while (my($name,$ref)=each(%method_map)) { my $public = $name=~s/^\+//; my %hash; # validate name is legal identifier if ($name!~/^[A-Za-z_]\w+/) { die "'$name' is not a valid identifier!\n"; } # validate reference refers to CODE if (ref($ref) ne "CODE") { die "values passed to 'methods' hash must be CODE references!\n"; } # create method my $eval = "sub $class\:\:$name { goto \$hash{\$_[0]}}\n"; eval $eval; # save the hash for later so we can store other instance methods in it $method_names{$name}=\%hash; $hash{$self}=$ref; } $Classes{$class}=\%method_names; no strict 'refs'; *{"$class\:\:DESTROY"} = sub { my $self = shift; while (my($name,$method)=each(%method_names)) { delete $method->{$self}; if ($DEBUG) { print "Destroying '$name' method for $self\n"; } } } } return $self; } 1;