#!/usr/bin/perl
package Foo;
use Class::FIOC;
use strict;
my $nextid=1;
sub new {
  my $class = shift;
  my %args = @_;
  my $first = $args{first} || "unknown";
  my $surname = $args{surname} || "unknown";
  my $id = $nextid++;
  methods {

    fullname=>sub {
      return "$first $surname";
    },

    surname=>sub{
      if (@_==2) {
        $surname = pop;
      }
      return $surname;
    },

    first=>sub {
      if (@_==2) {
        $first=pop;
      }
      return $first;
    },

    id=>sub{
      return $id;
    },

    debug=>sub{
      print "First = $first\nSurname=$surname\nID=$id\n\n";
    }
  };

}

my $foo = new Foo(first=>"Fred",surname=>"Flintstone");
print $foo->first."\n";
print $foo->surname."\n";
print $foo->id."\n";
print $foo->fullname."\n";
$foo->debug;
$foo = new Foo(first=>"Barney",surname=>"Rubble");
print $foo->first."\n";
print $foo->surname."\n";
print $foo->id."\n";
print $foo->fullname."\n";
$foo->debug;


##</code><code>##

   The "goto-&NAME" form is quite different from the other forms of "goto".  In fact, it isn't a goto in the normal sense at all, and doesn't have the stigma associated with other gotos.

##</code><code>##

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;