package Class::MethodMaker;

#
# $Id: MethodMaker.pm,v 1.21 2000/03/23 19:38:25 recoil Exp $
#

# Copyright (c) 1996 Organic Online. All rights reserved. This program is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.

## TODO:
# Use Pseudohashes ?
# Prefix internal names with '__' ?
# Is struct still useful ?
# Add caching values (scalar, list, etc.)
# Add hash of lists
# Autoexpansion of array refs in list basic method is a gotcha if you're
# trying to insert arrayrefs into the list
## From M. Simon Cavallet
# - Note that none of the new methods here depend on the object being
#   based on a hash; all of the base MethodMaker methods do except for
#   abstract. (I really should double-check this claim...)
#
# - It would be good to create new_... methods which accepted prototype
#   objects to clone with Ref::copyref, which enables nice defaults
#   management and allows use with non-hash-based classes.
#
# - There's some cruft from the original object meta-method that can
#   probably be stripped out, as long as reasonable effort is invested
#   in maintaining compatibility over a range of Perl versions.

=head1 NAME

B<Class::MethodMaker> - a module for creating generic methods

=head1 SYNOPSIS

use Class::MethodMaker
  new_with_init => 'new',
  get_set       => [ qw /foo bar baz / ];

=head1 DESCRIPTION

This module solves the problem of having to write a bazillion get/set
methods that are all the same. The argument to 'use' is a hash whose keys
are the names of types of generic methods generated by MethodMaker and
whose values tell method maker what methods to make. (More precisely, the
keys are the names of MethodMaker methods (methods that write methods)
and the values are the arguments to those methods.

=cut

use strict;
require 5.00307; # for the ->isa method.
use Carp;

use AutoLoader;
use vars '@ISA';
@ISA = qw ( AutoLoader );

use vars '$VERSION';
$VERSION = "0.93";

# ----------------------------------------------------------------------

# Just to point out the existence of these variables

use vars
 '%BooleanPos',     # A hash of the current index into the bit vector
                    # used in boolean for each class.

 '%BooleanFields',  # A hash of refs to arrays which store the names of
                    # the bit fileds for a given class

 '%StructPos',      # A hash of the current index into the arry used in
                    # struct for each class.

 '%StructFields';   # A hash of refs to arrays which store the names of
                    # the struct fields for a given class

sub ima_method_maker { 1 };

sub find_target_class {
  # Find the class to add the methods to. I'm assuming that it would be
  # the first class in the caller() stack that's not a subsclass of
  # MethodMaker. If for some reason a sub-class of MethodMaker also
  # wanted to use MethodMaker it could redefine ima_method_maker to
  # return a false value and then $class would be set to it.
  my $class;
  my $i = 0;
  while (1) {
    $class = (caller($i))[0];
    ( $class->isa('Class::MethodMaker')
      and
      &{$class->can ('ima_method_maker')} )
      or last;
    $i++;
  }
  return $class;
}

sub import {
  my ($class, @args) = @_;

  @args and $class->make(@args);
}

sub make {
  my ($method_maker_class, @args) = @_;

  my $TargetClass = $method_maker_class->find_target_class;

  # We have to initialize these before we run any of the
  # meta-methods. (At least the anon lists, so they get captured properly
  # in the closures.
  $BooleanPos{$TargetClass} ||= 0;
  $BooleanFields{$TargetClass} ||= [];
  $StructPos{$TargetClass} ||= 0;
  $StructFields{$TargetClass} ||= [];

  # make generic methods. The list passed to import should alternate
  # between the names of the meta-method to call to generate the methods
  # and either a scalar arg or a ARRAY ref to a list of args.

  # Each meta-method is responsible for calling install_methods() to get
  # it's methods installed.
  my ($meta_method, $arg);
  while (1) {
    $meta_method = shift @args or last;
    $arg = shift @args or
      croak "No arg for $meta_method in import of $method_maker_class.\n";

    my @args = ref($arg) ? @$arg : ($arg);
    $method_maker_class->$meta_method(@args);
  }
}

sub install_methods {
  my ($class, %methods) = @_;

  no strict 'refs';
#  print STDERR "CLASS: $class\n";
  my $TargetClass = $class->find_target_class;
  my $package = $TargetClass . "::";

  my ($name, $code);
  while (($name, $code) = each %methods) {
    # add the method unless it's already defined (which should only
    # happen in the case of static methods, I think.)

    *{"$package$name"} = $code unless defined *{"$package$name"}{CODE};
  }
}

1;

__END__


=head1 SUPPORTED METHOD TYPES

=head2 new

Creates a basic constructor.

Takes a single string or a reference to an array of strings as its
argument. For each string creates a method of the form:

    sub <string> {
      my ($class, @args) = @_;
      my $self = {};
      bless $self, $class;
    }

=cut

sub new {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    $methods{$_} = sub {
      my ($class) = @_;
      my $self = {};
      bless $self, $class;
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 new_with_init

Creates a basic constructor which calls a method named init after
instatiating the object. The I<init>() method should be defined in the class
using MethodMaker.

Takes a single string or a reference to an array of strings as its
argument. For each string creates a method of the form listed below.

    sub <string> {
      my ($class, @args) = @_;
      my $self = {};
      bless $self, $class;
      $self->init(@args);
      $self;
    }

=cut

sub new_with_init {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    my $field = $_;
    $methods{$field} = sub {
      my ($class, @args) = @_;
      my $self = {};
      bless $self, $class;
      $self->init(@args);
      $self;
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 new_hash_init

Creates a basic constructor which accepts a hash of slot-name/value
pairs with which to initialize the object.  The slot-names are
interpreted as the names of methods that can be called on the object
after it is created and the values are the arguments to be passed to
those methods.

Takes a single string or a reference to an array of strings as its
argument.  For each string creates a method that takes a list of
arguments that is treated as a set of key-value pairs, with each such
pair causing a call C<$self-E<gt>key ($value)>.

This method may be called as a class method, causing a new instance to
be created, or as an instance method, which will operate on the subject
instance.  This allows it to be combined with new_with_init (see above)
to provide some default values.  For example, declare a new_with_init
method, say 'new' and a new_hash_init method, for example, 'hash_init'
and then in the init method, you can call modify or add to the %args
hash and then call hash_init.

    sub <string> {
      my ($class, %args) = @_;
      my $self = {};
      bless $self, $class;
      foreach (keys %args) {
	$self->$_($args{$_});
      }
      $self;
    }

=cut

sub new_hash_init {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    $methods{$_} = sub {
      my $class = shift;
      my $self = ref ($class) ? $class : bless {}, $class;

      # Accept key-value attr list, or reference to unblessed hash of
      # attr
      my %args =
	(scalar @_ == 1 and ref($_[0]) eq 'HASH') ? %{ $_[0] } : @_;

      foreach (keys %args) {
	$self->$_($args{$_});
      }
      $self;
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 get_set

Takes a single string or a reference to an array of strings as its
argument. For each string, x creates two methods:

=over 4

=item	x

If an argument is provided, sets a new value for x.
Returns (new) value.
Value defaults to undef.

=item	clear_x

Sets value to undef.
No return.

=back

This is your basic get/set method, and can be used for slots containing
any scalar value, including references to non-scalar data. Note, however,
that MethodMaker has meta-methods that define more useful sets of methods
for slots containing references to lists, hashes, and objects.

=cut

sub get_set {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    my $name = $_;
    $methods{$name} = sub {
      my ($self, $new) = @_;
      defined $new and $self->{$name} = $new;
      $self->{$name};
    };

    $methods{"clear_$name"} = sub {
      my ($self) = @_;
      $self->{$name} = undef;
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 get_concat

Like get_set except sets do not clear out the original value, but instead
concatenate the new value to the existing one. Thus these slots are only
good for plain scalars. Also, like get_set, defines clear_foo method.

=cut

sub get_concat {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    my ($name, $join) = ($_, '');
    if ( ref ($name) eq 'HASH' ) {
      die "get_concat requires name field"
	if ! exists $_->{name};
      $name = $_->{name};
      $join = $_->{join} || '';
    }
    $methods{$name} = sub {
      my ($self, $new) = @_;
      if ( defined $new ) {
	if ( defined $self->{$name} ) {
	  $self->{$name} = join $join, $self->{$name}, $new;
	} else {
	  $self->{$name} = $new;
	}
      }
      # If returning undef upsets people, *return* '', but don't set ---
      # setting causes problems where join starts adding join fields
      # at start...
      $self->{$name};
    };

    $methods{"clear_$name"} = sub {
      my ($self) = @_;
      $self->{$name} = undef;
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 grouped_fields

Creates get/set methods like get_set but also defines a method which
returns a list of the slots in the group.

  grouped_fields methods
    some_group => [ qw / field1 field2 field3 / ];

Its argument list is parsed as a hash of group-name => field-list
pairs. Get-set methods are defined for all the fields and a method with
the name of the group is defined which returns the list of fields in the
group.

=cut

sub grouped_fields {
  my ($class, %args) = @_;
  my %methods;
  foreach (keys %args) {
    my @slots = @{$args{$_}};
    $class->get_set(@slots);
    $methods{$_} = sub { @slots };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 object

Creates methods for accessing a slot that contains an object of a given
class as well as methods to automatically pass method calls onto the
object stored in that slot.

    object => [
	       'Foo' => 'phooey',
	       'Bar' => [ qw / bar1 bar2 bar3 / ],
	       'Baz' => {
                         slot => 'foo',
                         comp_mthds => [ qw / bar baz / ]
                        },
	       'Fob' => [
			 {
			  slot => 'dog',
			  comp_mthds => 'bark',
			 },
			 {
			  slot => 'cat',
			  comp_mthds => 'miaow',
			 },
			];
              ];


The main argument should be a reference to an array. The array should
contain pairs of class => sub-argument pairs.
The sub-arguments parsed thus:

=over 4

=item	Hash Reference

See C<Baz> above.  The hash should contain the following keys:

=over 4

=item	slot

The name of the instance attribute (slot).

=item	comp_mthds

A stringor array ref, naming the methods that will be forwarded directly
to the object in the slot.

=back

=item	Array Reference

As for C<String>, for each member of the array.  Also works if each
member is a hash reference (see C<Fob> above).

=item	String

The name of the instance attribute (slot).

=back

For each method definition a get/set method is created that can store
an object of that class. (The get/set method, if called with a reference
to an object of the given class as the first argument, stores it in the
slot. If the slot is not filled yet it creates an object by calling the
given new method of the given class. Any arguments passed to the get/set
method are passed on to new. In all cases the object now stored in the
slot is returned.

So, using the example above, a method, C<foo>, is created in the class
that calls MethodMaker, which can get and set the value of those objects
in hash slot {'foo'}, which will generally contain an object of class
Baz.  Two additional methods are created in the class using MethodMaker,
named 'bar' and 'baz' which result in a call to the 'bar' and 'baz'
methods on the Baz object stored in slot foo.

=cut

sub object {
  my ($class, @args) = @_;
  my %methods;

  while (@args) {
    my $class = shift @args;
    my $list = shift @args or die "No slot names for $class";

    # Allow a list of hashrefs.
    my @list = ( ref($list) eq 'ARRAY' ) ? @$list : ($list);

    my $ref = ref $list;

    my $obj_def;
    foreach $obj_def (@list) {
      my $type = $class; # Hmmm. We have to do this for the closure to
                         # work. I.e. using $class in the closure dosen't
                         # work. Someday I'll actually understand scoping
                         # in Perl. [ Uh, is this true? 11/11/96 -PBS ]
      my ($name, @composites);
      my $new_meth = 'new';
      if ( ! ref $obj_def ) {
        $name = $obj_def;
      } else {
        $name = $obj_def->{'slot'};
	my $composites = $obj_def->{'comp_mthds'};
	@composites = ref($composites) eq 'ARRAY' ? @$composites
			    : defined $composites ? ($composites) : ();
      }

      my $meth;
      foreach $meth (@composites) {
	$methods{$meth} =
	  sub {
	    my ($self, @args) = @_;
	    $self->$name()->$meth(@args);
	  };
      }

      $methods{$name} = sub {
	my ($self, @args) = @_;
	if (ref $args[0] and UNIVERSAL::isa($args[0], $class)) {
	  $self->{$name} = $args[0];
	} else {
	  defined $self->{$name} or $self->{$name} = $type->new(@args);
	}
	$self->{$name};
      };

      $methods{"delete_$name"} = sub {
	my ($self) = @_;
	$self->{$name} = undef;
      };
    }
  }
  $class = $class; # Huh? Without this line the next line doesn't work!
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 object_list

Functions like C<list>, but maintains an array of referenced objects
in each slot. Forwarded methods return a list of the results returned
by C<map>ing the method over each object in the array.

Arguments are like C<object>.

=cut

sub object_list {
  my ($class, @args) = @_;
  my %methods;

  while (@args) {
    my $class = shift @args;
    my $list = shift @args or die "No slot names for $class";

    my @list = ( ref($list) eq 'ARRAY' ) ? @$list : ($list);

    my $obj_def;
    foreach $obj_def (@list) {
      my $type = $class;
	    # Hmmm. We have to do this for the closure to work. I.e. using
	    # $class in the closure dosen't work. Someday I'll actually
	    # understand scoping in Perl. [ Uh, is this true? 11/11/96 -PBS ]

      my ( $name, @composites );
      my $new_meth = 'new';
      if ( ! ref $obj_def ) {
        $name = $obj_def;
      } else {
        $name = $obj_def->{'slot'};
	my $composites = $obj_def->{'comp_mthds'};
	@composites = ref($composites) eq 'ARRAY' ? @$composites
			    : defined $composites ? ($composites) : ();
      }

      $methods{$name} = sub {
	my ($self, @list) = @_;
	defined $self->{$name} or $self->{$name} = [];
	if ( scalar @list == 1 and ref( $list[0] ) eq 'ARRAY' ) {
	  @list = @{ $list[0] };
	}
	push @{$self->{$name}}, map {
	  (ref $_ and UNIVERSAL::isa($_, $class)) ? $_ : $type->$new_meth($_)
	} @list;

	# Use wantarray for consistency with list, which uses it for
	# consistency with its own doco., and the hash impl.

	return wantarray ? @{$self->{$name}} : $self->{$name};
      };

      $methods{"pop_$name"} = sub {
	my ($self) = @_;
	pop @{$self->{$name}}
      };

      $methods{"push_$name"} = sub {
	my ($self, @values) = @_;
	push @{$self->{$name}}, @values;
      };

      $methods{"shift_$name"} = sub {
	my ($self) = @_;
	shift @{$self->{$name}}
      };

      $methods{"unshift_$name"} = sub {
	my ($self, @values) = @_;
	unshift @{$self->{$name}}, @values;
      };

      $methods{"splice_$name"} = sub {
	my ($self, $offset, $len, @list) = @_;
	splice(@{$self->{$name}}, $offset, $len, @list);
      };

      $methods{"clear_$name"} = sub {
	my ($self) = @_;
	$self->{$name} = [];
      };


      $methods{"count_$name"} = sub {
	my ($self) = @_;
	return exists $self->{$name} ? scalar @{$self->{$name}} : 0;
      };

      #
      # Deprecated in line with list
      #
      $methods{"${name}_ref"} = sub {
	my ($self) = @_;
	$self->{$name};
      };

      my $meth;
      foreach $meth (@composites) {
	$methods{$meth} = sub {
	  my ($self, @args) = @_;
	  map { $_->$meth(@args) } $self->$name()
	};
      }
    }
  }
  $class = $class; # Huh? Without this line the next line doesn't work!
  $class->install_methods(%methods);
}


# ----------------------------------------------------------------------

=head2	forward

  forward => [ comp => 'method1', comp2 => 'method2' ]

Define pass-through methods for certain fields.  The above defines that
method C<method1> will be handled by component C<comp>, whilst method
C<method2> will be handled by component C<comp2>.

=cut

sub forward {
  my ($class, %args) = @_;
  my %methods;

  foreach (keys %args) {
    my $slot = $_;
    my @methods = @{$args{$_}};
    foreach (@methods) {
      my $field = $_;
      $methods{$field} = sub {
	my ($self, @args) = @_;
	$self->$slot()->$field(@args);
      };
    }
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 boolean

  boolean => [ qw / foo bar baz / ]

Creates methods for setting, checking and clearing flags. All flags
created with this meta-method are stored in a single vector for space
efficiency. The argument to boolean should be a string or a reference to
an array of strings. For each string x it defines several methods:

=over 4

=item	x

Returns the value of the x-flag.  If called with an argument, it first
sets the x-flag to the truth-value of the argument.

=item	set_x

Equivalent to x(1).

=item	clear_x

Equivalent to x(0).

=back

Additionally, boolean defines three class methods:

=over 4

=item	bits

Returns the vector containing all of the bit fields (remember however
that a vector containing all 0 bits is still true).

=item	boolean_fields

Returns a list of all the flags by name.

=item	bit_dump

Returns a hash of the flag-name/flag-value pairs.

=back

=cut

sub boolean {
  my ($class, @args) = @_;
  my %methods;

  my $TargetClass = $class->find_target_class;

  my $boolean_fields =
    $BooleanFields{$TargetClass};

  $methods{'bits'} =
    sub {
      my ($self, $new) = @_;
      defined $new and $self->{'boolean'} = $new;
      $self->{'boolean'};
    };

  $methods{'bit_fields'} = sub { @$boolean_fields; };

  $methods{'bit_dump'} =
    sub {
      my ($self) = @_;
      map { ($_, $self->$_()) } @$boolean_fields;
    };

  foreach (@args) {
    my $field = $_;
    my $bfp = $BooleanPos{$TargetClass}++;
        # $boolean_pos a global declared at top of file. We need to make
        # a local copy because it will be captured in the closure and if
        # we capture the global version the changes to it will effect all
        # the closures. (Note also that it's value is reset with each
        # call to import_into_class.)
    push @$boolean_fields, $field;
        # $boolean_fields is also declared up above. It is used to store a
        # list of the names of all the bit fields.

    $methods{$field} =
      sub {
	my ($self, $on_off) = @_;
	defined $self->{'boolean'} or $self->{'boolean'} = "";
	if (defined $on_off) {
	  vec($self->{'boolean'}, $bfp, 1) = $on_off ? 1 : 0;
	}
	vec($self->{'boolean'}, $bfp, 1);
      };

    $methods{"set_$field"} =
      sub {
	my ($self) = @_;
	$self->$field(1);
      };

    $methods{"clear_$field"} =
      sub {
	my ($self) = @_;
	$self->$field(0);
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

# Docs removed: is there any real use for struct?

# XXX Candidate for a pseudo-hash?

sub struct {
  my ($class, @args) = @_;
  my %methods;

  my $TargetClass = $class->find_target_class;

  my $struct_fields =
    $StructFields{$TargetClass};

  $methods{'struct_fields'} = sub { @$struct_fields; };

  $methods{'struct'} =
    sub {
      # For filling up the whole structure at once. The values must be
      # provided in the order they were declared.
      my ($self, @values) = @_;
      defined $self->{'struct'} or $self->{'struct'} = [];
      @values and @{$self->{'struct'}} = @values;
      @{$self->{'struct'}};
    };

  $methods{'struct_dump'} =
    sub {
      my ($self) = @_;
      map { ($_, $self->$_()) } @$struct_fields;
    };

  foreach (@args) {
    my $field = $_;
    # $StructPos is a global declared at top of file. We need to make a
    # local copy because it will be captured in the closure and if we
    # capture the global version the changes to it will affect all the
    # closures.
    my $sfp = $StructPos{$TargetClass}++;
    # $struct_fields is also declared up above. It is used to store a
    # list of the names of all the struct fields.
    push @$struct_fields, $field;

    $methods{$field} =
      sub {
	my ($self, $new) = @_;
	defined $self->{'struct'} or $self->{'struct'} = [];
	defined $new and $self->{'struct'}->[$sfp] = $new;
	$self->{'struct'}->[$sfp];
      };

    $methods{"clear_$field"} =
      sub {
	my ($self) = @_;
	defined $self->{'struct'} or $self->{'struct'} = [];
	$self->{'struct'}->[$sfp] = undef;
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 listed_attrib

  listed_attrib => [ qw / foo bar baz / ]

Like I<boolean>, I<listed_attrib> creates x, set_x, and clear_x
methods. However, it also defines a class method x_objects which returns
a list of the objects which presently have the x-flag set to
true. N.B. listed_attrib does not use the same space efficient
implementation as boolean, so boolean should be prefered unless the
x_objects method is actually needed.

=cut

sub listed_attrib {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;

    my %list = ();

    $methods{$field} =
      sub {
	my ($self, $on_off) = @_;
	if (defined $on_off) {
	  if ($on_off) {
	    $list{$self} = $self;
	  } else {
	    delete $list{$self};
	  }
	}
	$list{$self} ? 1 : 0;
      };

    $methods{"set_$field"} =
      sub {
	my ($self) = @_;
	$self->$field(1);
      };

    $methods{"clear_$field"} =
      sub {
	my ($self) = @_;
	$self->$field(0);
      };

    $methods{$field . "_objects"} =
      sub {
	values %list;
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 key_attrib

  key_attrib => [ qw / foo bar baz / ]

Creates get/set methods like get/set but also maintains a hash in which
each object is stored under the value of the field when the slot is
set. If an object has a slot set to a value which another object is
already set to the object currently set to that value has that slot set
to undef and the new object will be put into the hash under that
value. (I.e. only one object can have a given key. The method find_x is
defined which if called with any arguments returns a list of the objects
stored under those values in the hash. Called with no arguments, it
returns a reference to the hash.

=cut

sub key_attrib {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;
    my %list = ();

    $methods{$field} =
      sub {
	my ($self, $new) = @_;
	if (defined $new) {
	  # We need to set the value
	  if (defined $self->{$field}) {
	    # the object must be in the hash under its old value so
	    # that entry needs to be deleted
	    delete $list{$self->{$field}};
	  }
	  my $old;
	  if ($old = $list{$new}) {
	    # There's already an object stored under that value so we
	    # need to unset it's value
	    $old->{$field} = undef;
	  }

	  # Set our value to new
	  $self->{$field} = $new;

	  # Put ourself in the list under that value
	  $list{$new} = $self;
	}
	$self->{$field};
      };

    $methods{"clear_$field"} =
      sub {
	my ($self) = @_;
	delete $list{$self->{$field}};
	$self->{$field} = undef;
      };

    $methods{"find_$field"} =
      sub {
	my ($self, @args) = @_;
	if (scalar @args) {
	  return @list{@args};
	} else {
	  return \%list;
	}
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 key_with_create

  key_with_create => [ qw / foo bar baz / ]

Just like key_attrib except the find_x method is defined to call the new
method to create an object if there is no object already stored under
any of the keys you give as arguments.

=cut

sub key_with_create {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;
    my %list = ();

    $methods{$field} =
      sub {
	my ($self, $new) = @_;
	if (defined $new) {
	  # We need to set the value
	  if (defined $self->{$field}) {
	    # the object must be in the hash under its old value so
	    # that entry needs to be deleted
	    delete $list{$self->{$field}};
	  }
	  my $old;
	  if ($old = $list{$new}) {
	    # There's already an object stored under that value so we
	    # need to unset it's value
	    $old->{$field} = undef;
	  }

	  # Set our value to new
	  $self->{$field} = $new;

	  # Put ourself in the list under that value
	  $list{$new} = $self;
	}
	$self->{$field};
      };

    $methods{"clear_$field"} =
      sub {
	my ($self) = @_;
	delete $list{$self->{$field}};
	$self->{$field} = undef;
      };

    $methods{"find_$field"} =
      sub {
	my ($class, @args) = @_;
	if (scalar @args) {
	  foreach (@args) {
	    $class->new->$field($_) unless defined $list{$_};
	  }
	  return @list{@args};
	} else {
	  return \%list;
	}
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 list

Creates several methods for dealing with slots containing list
data. Takes a string or a reference to an array of strings as its
argument and for each string, x, creates the methods:

=over 4

=item	x

This method returns the list of values stored in the slot. In an array
context it returns them as an array and in a scalar context as a
reference to the array.

=item	push_x

=item	pop_x

=item	shift_x

=item	unshift_x

=item	splice_x

=item	clear_x

=item	count_x

Returns the number of elements in x.

=back

=cut

# *** Any additinal/changed methods must be mirrored in object_list
sub list {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;

    $methods{$field} =
      sub {
	my ($self, @list) = @_;
	defined $self->{$field} or $self->{$field} = [];
	#
	# Push of arguments deprected.
	# Later, we'll use arguments to slice into array.
	#
	push @{$self->{$field}}, map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @list;
	return wantarray ? @{$self->{$field}} : $self->{$field};
      };

    $methods{"pop_$field"} =
      sub {
	my ($self) = @_;
	pop @{$self->{$field}}
      };

    $methods{"push_$field"} =
      sub {
	my ($self, @values) = @_;
	push @{$self->{$field}}, @values;
      };

    $methods{"shift_$field"} =
      sub {
	my ($self) = @_;
	shift @{$self->{$field}}
      };

    $methods{"unshift_$field"} =
      sub {
	my ($self, @values) = @_;
	unshift @{$self->{$field}}, @values;
      };

    $methods{"splice_$field"} =
      sub {
	my ($self, $offset, $len, @list) = @_;
	splice(@{$self->{$field}}, $offset, $len, @list);
      };

    $methods{"clear_$field"} =
      sub {
	my ($self) = @_;
	$self->{$field} = [];
      };

    $methods{"count_$field"} =
      sub {
	my ($self) = @_;
	return exists $self->{$field} ? scalar @{$self->{$field}} : 0;
      };

    #
    # Deprecated.
    #
    $methods{"${field}_ref"} =
      sub {
	my ($self) = @_;
	$self->{$field};
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 hash

Creates a group of methods for dealing with hash data stored in a
slot.

Takes a string or a reference to an array of strings and for each
string, x, creates:

=over 4

=item	x

Called with no arguments returns the hash stored in the slot, as a hash
in a list context or as a reference in a scalar context.

Called with one argument it treats the argument as a key and returns the
value stored under that key, or as a list of keys (if it is a reference
to a list) and returns the list of values stored under those keys.

Called with more than one argument, treats them as a series of key/value
pairs and adds them to the hash.

=item 	x_keys

Returns the keys of the hash.

=item	x_values

Returns the list of values.

=item	x_tally

Takes a list of arguments and for each scalar in the list increments the
value stored in the hash and returns a list of the current (after the
increment) values.

=item	x_exists

Takes a single key, returns whether that key exists in the hash.

=item	x_delete

Takes a list, deletes each key from the hash.

=back

=cut

sub hash {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;

    $methods{$field} =
      sub {
	my ($self, @list) = @_;
	defined $self->{$field} or $self->{$field} = {};
	if (scalar @list == 1) {
	  my $key = shift @list;
	  if (ref $key eq 'ARRAY') {
	    return @{$self->{$field}}{@$key};
	  } else {
	    return $self->{$field}->{$key};
	  }
	} else {
	  while (1) {
	    my $key = shift @list;
	    defined $key or last;
	    my $value = shift @list;
	    defined $value or carp "No value for key $key.";
	    $self->{$field}->{$key} = $value;
	  }
	  wantarray ? %{$self->{$field}} : $self->{$field};
	}
      };

    $methods{$field . "_keys"} =
      sub {
	my ($self) = @_;
	keys %{$self->{$field}};
      };

    $methods{$field . "_values"} =
      sub {
	my ($self) = @_;
	values %{$self->{$field}};
      };

    $methods{$field . "_exists"} =
      sub {
	my ($self) = shift;
	my ($key) = @_;
	return
	  exists $self->{$field} && exists $self->{$field}->{$key};
      };

    $methods{$field . "_tally"} =
      sub {
	my ($self, @list) = @_;
	defined $self->{$field} or $self->{$field} = {};
	map { ++$self->{$field}->{$_} } @list;
      };

    $methods{$field . "_delete"} =
      sub {
	my ($self, @keys) = @_;
	delete @{$self->{$field}}{@keys};
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2	tie_hash

Much like C<hash>, but uses a tied hash instead.

Takes a list of pairs, where the first is the name of the component, the
second is a hash reference.  The hash reference recognizes the following keys:

=over 4

=item	tie

I<Required>.  The name of the class to tie to.
I<Make sure you have C<use>d the required class>.

=item	args

I<Required>.  Additional arguments for the tie, as an array ref.

=back

Example:

   tie_hash	=> [
		    hits	=> {
				    tie	=> qw/ Tie::RefHash /,
				    args => [],
				   },
		   ],


=cut

sub tie_hash {
  my ($class, @args) = @_;
  my %methods;

  while ( my ($field, $args) = splice (@args, 0, 2)) {
    $methods{$field} =
      sub {
	my ($self, @list) = @_;
	if ( ! defined $self->{$field} ) {
	  my %hash;
	  tie %hash, $args->{tie}, @{$args->{args}};
	  $self->{$field} = \%hash;
	}
	if (scalar @list == 1) {
	  my $key = shift @list;
	  if (ref $key eq 'ARRAY') {
	    return @{$self->{$field}}{@$key};
	  } else {
	    return $self->{$field}->{$key};
	  }
	} else {
	  while (1) {
	    my $key = shift @list;
	    defined $key or last;
	    my $value = shift @list;
	    defined $value or carp "No value for key $key.";
	    $self->{$field}->{$key} = $value;
	  }
	  wantarray ? %{$self->{$field}} : $self->{$field};
	}
      };

    $methods{"$ {field}s"} = $methods{$field};

    $methods{$field . "_keys"} =
      sub {
	my ($self) = @_;
	keys %{$self->{$field}};
      };

    $methods{$field . "_values"} =
      sub {
	my ($self) = @_;
	values %{$self->{$field}};
      };

    $methods{$field . "_exists"} =
      sub {
	my ($self) = shift;
	my ($key) = @_;
	return
	  exists $self->{$field} && exists $self->{$field}->{$key};
      };

    $methods{$field . "_tally"} =
      sub {
	my ($self, @list) = @_;
	defined $self->{$field} or $self->{$field} = {};
	map { ++$self->{$field}->{$_} } @list;
      };

    $methods{"add_$field"} =
      sub {
	my ($self, $attrib, $value) = @_;
	$self->{$field}->{$attrib} = $value;
      };

    $methods{"clear_$field"} =
      sub {
	my ($self, $attrib) = @_;
	delete $ {$self->{$field}}{$attrib};
      };

    $methods{"add_$ {field}s"} =
      sub {
	my ($self, %attribs) = @_;
	my ($k, $v);
	while (($k, $v) = each %attribs) {
	  $self->{$field}->{$k} = $v;
	}
      };

    $methods{"clear_$ {field}s"} =
      sub {
	my ($self, @attribs) = @_;
	my $attrib;
	foreach $attrib (@attribs) {
	  delete $ {$self->{$field}}{$attrib};
	}
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2	static_hash

Much like C<hash>, but uses a class-based hash instead.

=cut

sub static_hash {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;
    my %hash;

    $methods{$field} =
      sub {
	my ($class, @list) = @_;
	if (scalar @list == 1) {
	  my $key = shift @list;
	  if (ref $key) { # had better by an array ref
	    return @hash{@$key};
	  } else {
	    return $hash{$key};
	  }
	} else {
	  while (1) {
	    my $key = shift @list;
	    defined $key or last;
	    my $value = shift @list;
	    defined $value or carp "No value for key $key.";
	    $hash{$key} = $value;
	  }
	  %hash;
	}
      };

    $methods{"$ {field}s"} = $methods{$field};

    $methods{$field . "_keys"} =
      sub {
	my ($class) = @_;
	keys %hash;
      };

    $methods{$field . "_values"} =
      sub {
	my ($class) = @_;
	values %hash;
      };

    $methods{$field . "_exists"} =
      sub {
	my ($class) = shift;
	my ($key) = @_;
	return
	  exists $hash{$key};
      };

    $methods{$field . "_tally"} =
      sub {
	my ($class, @list) = @_;
	map { ++$hash{$_} } @list;
      };

    $methods{"add_$field"} =
      sub {
	my ($class, $attrib, $value) = @_;
	$hash{$attrib} = $value;
      };

    $methods{"clear_$field"} =
      sub {
	my ($class, $attrib) = @_;
	delete $hash{$attrib};
      };

    $methods{"add_$ {field}s"} =
      sub {
	my ($class, %attribs) = @_;
	my ($k, $v);
	while (($k, $v) = each %attribs) {
	  $hash{$k} = $v;
	}
      };

    $methods{"clear_$ {field}s"} =
      sub {
	my ($class, @attribs) = @_;
	my $attrib;
	foreach $attrib (@attribs) {
	  delete $hash{$attrib};
	}
      };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 code

  code => [ qw / foo bar baz / ]

Creates a slot that holds a code reference. Takes a string or a reference
to a list of string and for each string, x, creates a method B<x> which
if called with one argument which is a CODE reference, it installs that
code in the slot. Otherwise it runs the code stored in the slot with
whatever arguments (including none) were passed in.

=cut

sub code {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;

    $methods{$field} = sub {
      my ($self, @args) = @_;
      if (ref($args[0]) eq 'CODE') {
	# Set the function
	$self->{$field} = $args[0];
      } else {
	# Run the function on the given arguments
	&{$self->{$field}}(@args)
      }
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 method

  method => [ qw / foo bar baz / ]

Just like B<code>, except the code is called like a method, with $self as
it's first argument. Basically, you're creating a method which can be
different for each object. Which is sort of weird. But perhaps useful.

=cut

sub method {
  my ($class, @args) = @_;
  my %methods;

  foreach (@args) {
    my $field = $_;

    $methods{$field} = sub {
      my ($self, @args) = @_;
      if (ref($args[0]) eq 'CODE') {
	# Set the function
	$self->{$field} = $args[0];
      } else {
	# Run the function on the given arguments
	&{$self->{$field}}($self, @args)
      }
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head2 abstract

  abstract => [ qw / foo bar baz / ]

This creates a number of methods will die if called.  This is intended
to support the use of abstract methods, that must be overidden in a
useful subclass.

=cut

sub abstract {
  my ($class, @args) = @_;
  my %methods;

  my $TargetClass = $class->find_target_class;

  foreach (@args) {
    my $field = $_;
    $methods{$field} = sub {
      my ($self) = @_;
      my $calling_class = ref $self;
      die
	qq#Can't locate abstract method "$field" declared in #.
	qq#"$TargetClass", called from "$calling_class".\n#;
    };
  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------

=head1 ADDDING NEW METHOD TYPES

MethodMaker is a class that can be inherited. A subclass can define new
method types by writing a method that returns a hash of
method_name/code-reference pairs.

For example a simple sub-class that defines a method type
upper_case_get_set might look like this:

  package Class::MethodMakerSubclass;

  use strict;
  use Class::MethodMaker;

  @Class::MethodMakerSubclass::ISA = qw ( Class::MethodMaker );

  sub upper_case_get_set {
    shift; # we don't need the class name
    my ($name) = @_;
    my %results;
    $results{$name} =
      sub {
	my ($self, $new) = @_;
	defined $new and $self->{$name} = uc $new;
	$self->{$name};
      };
    %results;
  }

  1;

=head1 VERSION

Class::MethodMaker v0.93

=cut

## EXPERIMENTAL META-METHODS

sub builtin_class {
  my ($class, $func, $arg) = @_;
  my @list = @$arg;
  my %results = ();
  my $field;

  my $TargetClass = $class->find_target_class;
  my $struct_fields =
    $StructFields{$TargetClass};

  # Cuz neither \&{"CORE::$func"} or $CORE::{$func} work ...  N.B. this
  # only works for core functions that take only one arg. But I can't
  # quite figure out how to pass in the list without it getting evaluated
  # in a scalar context. Hmmm.
  my $corefunc = eval "sub { scalar \@_ ? CORE::$func(shift) : CORE::$func }";

  $results{'new'} = sub {
    my ($class, @args) = @_;
    my $self = [];
    @$self = &$corefunc(@args);
    bless $self, $class;
  };

  $results{'fields'} = sub { @$struct_fields; };

  $results{'dump'} =
    sub {
      my ($self) = @_;
      map { ($_, $self->$_()) } @$struct_fields;
    };

  foreach $field (@list) {
    my $sfp = $StructPos{$TargetClass}++;
        # $struct_pos a global declared at top of file. We need to make
        # a local copy because it will be captured in the closure and if
        # we capture the global version the changes to it will effect all
        # the closures. (Note also that its value is reset with each
        # call to import_into_class.)
    push @$struct_fields, $field;
        # $struct_fields is also declared up above. It is used to store a
        # list of the names of all the struct fields.

    $results{$field} =
      sub {
	my ($self, $new) = @_;
	defined $new and $self->[$sfp] = $new;
	$self->[$sfp];
      };
  }
  $class->install_methods(%results);
}
