# (X)Emacs mode: -*- cperl -*-

package Class::MethodMaker;

=head1 NAME

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.

To override any generated methods, it is sufficient to ensure that the
overriding method is defined when Class::MethodMaker is called.  Note
that the C<use> keyword introduces a C<BEGIN> block, so you may need to
define (or at least declare) your overriding method in a C<BEGIN> block.

Some new facilities may be marked as EXPERIMENTAL in the documentation.
These facilities are being trialled, and whilst it is hoped that they
will become mainstream code, no promises are made.  They may change or
disappear at any time.  Caveat Emptor.  The maintainer would be
delighted to hear any feedback particularly regarding such facilities,
be it good or bad, so long as it is constructive.

Some old facilities may be marked as COMPATIBILITY in the documentation.
These facilities are being maintained purely for compatibility with old
versions of this module, but will ultimately disappear.  They are
normally replaced by alternatives that are thought preferable for some
completely arbitrary raisin.  Please avoid using them, and consider
amending any existing code that does use them not to.  If you believe
that their removal will cast an unacceptable pall over your life, please
contact the maintainer, or get a new life: whichever is easier.

=cut

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

# Pragmas -----------------------------

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

# Inheritance -------------------------

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

# Utility -----------------------------

use Carp qw( carp cluck croak );

use vars qw( $VERSION $PACKAGE );
$VERSION = '1.12';
$PACKAGE = 'Class-MethodMaker';

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

# 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) = @_;

  # XXX Deprecated 25.v.00 ---------

  # This code is dangerous (pollutes
  # external namespace) and deprecated.  Use at your peril.  It is not
  # supported, and will disappear at or after 25.v.01
  if (defined $args[0] and $args[0] eq '-sugar') {
    shift @args;
    *methods:: = *Class::MethodMaker::;
  }
  # XXX Deprecated 25.v.00 ---------

  @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) eq 'ARRAY' ? @$arg : ($arg);
    $method_maker_class->$meta_method(@args);
  }

  return;
}

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

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.)
    my $reftype = ref $code;
    if ( $reftype eq 'CODE' ) {
      *{"$package$name"} = $code unless defined *{"$package$name"}{CODE};
    } elsif ( ! $reftype ) {
      my $coderef = eval $code;
      croak "Code:\n$code\n\ndid not compile: $@\n"
	if $@;
      croak "String:\n$code\n\ndid not eval to a code ref: $coderef\n"
	unless ref $coderef eq 'CODE';
      *{"$package$name"} = $coderef unless defined *{"$package$name"}{CODE};
    } else {
      croak "What do you expect me to do with this?: $code\n";
    }
  }
}

1; # keep require happy

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

__END__

# AutoLoaded Methods

=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 simple method that creates and
returns an object of the appropriate class.


This method may be called as a class method, as usual, or as in instance
method, in which case a new object of the same class as the instance
will be created.  I<Note that C<new_hash_init> works slightly
differently with regard to being called on an instance.>

=cut

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

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

=head2 new_with_init

Creates a basic constructor which calls a method named C<init> after
instantiating the object. The C<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 simple method that creates an
object of the appropriate class, calls C<init> on that object
propagating all arguments, before returning the object.

This method may be called as a class method, as usual, or as in instance
method, in which case a new object of the same class as the instance
will be created.  I<Note that C<new_hash_init> works slightly
differently with regard to being called on an instance.>

=cut

sub new_with_init {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    my $field = $_;
    $methods{$field} = sub {
      my $class = shift;
      $class = ref $class || $class;
      my $self = {};
      bless $self, $class;
      $self->init (@_);
      $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.

I<Note that the operation with regard to action on an instance differs
to that of C<new> and C<new_with_init> differently with regard to being
called on an instance.>

You may want to work with this to support default values.  The following
snippet is one way of doing this (adapted from code supplied by
Kevin J. Rice):

  package Simple;

  use Class::MethodMaker
    get_set       => [qw(a b)],
    new_with_init => 'new';
    new_hash_init => 'hash_init';

  use constant INSTANCE_DEFAULTS => (a => 7, b => 'default') ;

  sub init  {
    my $self   = shift;
    my %values = (INSTANCE_DEFAULTS, @_);
    $self->hash_init(%values);
    return;
  }

Now, back at the farm...

  use Simple;
  my $test = Simple->new;             # now a==7, b==default
  my $test = Simple->new(a=>1);       # now a==1, b==default.
  my $test = Simple->new(a=>1, b=>2); # now a==1, b==2.

=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) {
        if ( my $setter = $class->can(" __CMM__ $_") ) {
          $setter->($self, $args{$_});
        } else {
          $self->$_($args{$_});
        }
      }
      $self;
    };
  }
  $class->install_methods(%methods);
}

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

=head2 new_hash_with_init

Combines new_hash_init with new_with_init; arguments passed in are first
passed to assignment methods as with new_hash_init, and then the class method
'init' (which must be defined by the client is called, with those arguments.
Note that unlike L<new_with_init|new_with_init>, the arguments are pre-munged
--- if a single argument is a hashref is passed in, it is expanded out, the
the key/value pairs (whether originally as a hash ref or a list) may be
reordered as typically occurs with perl hashes.

=cut

sub new_hash_with_init {
  my ($self, @args) = @_;
  my %methods;

  foreach (@args) {
    $methods{$_} = sub {
      my $class = shift;
      my $self = ref ($class) ? $class : bless {}, $class;
      my %args = (scalar @_ == 1 and ref($_[0]) eq 'HASH') ? %{ $_[0] } : @_;

      foreach (keys %args) {
        if ( my $setter = $self->can(" __CMM__ $_") ) {
          $setter->($self, $args{$_});
        } else {
          $self->$_($args{$_});
        }
      }

      $self->init(%args);
      $self;
    };
  }

  $self->install_methods(%methods);
}

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

=head2 singleton

Creates a basic constructor which only ever returns a single instance of the
class: i.e., after the first call, repeated calls to this constructor return
the I<same> instance.  Note that the instance is instantiated at the time of
the first call, not before.

Any arguments are treated as for new_hash_init.

Naturally, C<init> and any initializer methods are called only by the first
invocation of this method.

This method should be called only as a class method.

=cut

sub singleton {
  my ($self, @args) = @_;
  my %methods;

  my $singleton;
  foreach (@args) {
    $methods{$_} = sub {
      return $singleton
        if defined $singleton;
      my $class = shift;
      $singleton = bless {}, $class;

      my %args = (scalar @_ == 1 and ref($_[0]) eq 'HASH') ? %{ $_[0] } : @_;
      foreach (keys %args) {
        if ( my $setter = $singleton->can(" __CMM__ $_") ) {
          $setter->($singleton, $args{$_});
        } else {
          $singleton->$_($args{$_});
        }
      }
      $singleton->init(%args);
      return $singleton;
    };
  }
  $self->install_methods(%methods);
}

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

=head2 EXPERIMENTAL: new_with_args

Creates a basic constructor.

Takes a single string or a reference to an array of strings as its
argument.  For each string creates a simple method that creates and
returns an object of the appropriate class.

This method may be called as a class method, as usual, or as in instance
method, in which case a new object of the same class as the instance
will be created.  I<Note that C<new_hash_init> works slightly
differently with regard to being called on an instance.>

Constructor arguments will be stored as a key, value pairs in the
object. No check is done regarding the consistencies of the data
passed to the constructor and the accessor methods created.

=cut

# added by Dominique Dumont (22.i.02)
sub new_with_args {
  my ($class, @args) = @_;
  my %methods;
  foreach (@args) {
    $methods{$_} = sub {
      my $class = shift;
      my @c_args = @_ ;
      $class = ref $class || $class;
      my $self = { @c_args };
      bless $self, $class;
    };
  }
  $class->install_methods(%methods);
}

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

=head2 get_set

Takes a single string or a reference to an array of strings as its
argument.  Each string specifies a slot, for which accessor methods are
created.  The accessor methods are, by default:

=over 4

=item   x

If an argument is provided, sets a new value for x.  This is true even
if the argument is undef (cf. no argument, which does not set.)

Returns (new) value.

Value defaults to undef.

=item   clear_x

Sets value to undef.  This is exactly equivalent to

  $foo->x (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.

=head2	EXPERIMENTAL: Options

There are several options available for controlling the names and types
of methods created.

The following options affect the type of methods created:

=over 4

=item	-static

The methods will refer to a class-specific, rather than
instance-specific store.  I.e., these scalars are shared across all
instances of your object in your process.

=item   -set_once

=item   -set_once_or_SUBNAME

=item   -set_once_or_ignore

Please note that the -set_once options are EXPERIMENTAL, as noted above.  In
particular, they will not be available in initial versions of V2.  V1 will
continue to be maintained after V2 is released, but you will not be able to
upgrade to V2 initially if you use these options.

The methods will allow the value to be set only once.  If a caller attempts to
set the value a second time, then SUBNAME will be called (default is to die). The subroutine
SUBNAME will be called as SUBNAME( $CLASS, $ERRMSG, @ARGS ), where $CLASS is
the first parameter passed to the set method, $ERRMSG is a human-readable
message, and @ARGS are the remaining parameters passed to the set method.

If SUBNAME is croak, carp, cluck, or confess, then the Carp module is automatically used.

-set_once is shorthand for -set_once_or_die.

-set_once_or_ignore  means that any subsequent attempts to set the value will be silently ignored.

Example:

  package Person;
  use Class::MethodMaker
      new => 'new',
      get_set => [qw/ -set_once  Name /],
      get_set => [qw/ -set_once_or_report  Address /],
      get_set => [qw/ -set_once_or_ignore  ID /];

  package main;

  my $p = new Person;
  $p->Name('John');
  $p->Address('Philadelphia');
  $p->ID(43);

  $p->Name('Martyn');    # die! Attempt to set Person::Name twice.
  $p->Address('Surrey'); # Calls $p->report("Error...", 'Surrey')
  $p->ID(44);            # returns 43.
  
=back

The following options affect the methods created as detailed:

=over 4

=item	-java

Creates getx and setx methods, which return the value, and set the
value (no return), respectively.

Note the absence of underscores in the method names.  This is to accomodate
the java-style StudlyCaps naming scheme.

Example:

  package Person;

  use Class::MethodMaker
    new_hash_init =>	'new' ,
    get_set       => [qw/ -java Status Size Name /];

  package main;

  my $p = Person->new( Name   => 'Homer',
                       Size   => '54',
                       Status => 'Comical Moron',
                     );

=item	-eiffel

Creates x and set_x methods, analogous to -java getx and setx respectively.

Example:

  package Person;

  use Class::MethodMaker
    new_hash_init =>	'new' ,
    get_set       => [qw/ -eiffel status size name /];

  package main;

  my $p = Person->new( name   => 'Homer',
                       size   => '54',
                       status => 'Comical Moron',
                     );


=item	-compatibility

Creates x (as per the default), and clear_x, which resets the slot value
to undef.  Use this to ensure backward compatibility.

=item	-noclear

Creates x (as per the default) only.

=back

Alternatively, an arrayref specifying a template for method names may be
supplied.  Each name must contain a '*' character, which will be
replaced by the slot name, and no two patterns may be the same.  undef
may be supplied for methods that you do not want created.  Currently,
the first 4 members of such an arrayref may be used:

=over 4

=item	0

Creates a method that if supplied an argument, sets the slot to the
value of that argument; the value of the slot (after setting, if
relevant) is returned.

=item	1

Creates a method that takes no arguments, sets the slot value to
undefined, and makes no return.

=item	2

Creates a method that takes no arguments, and returns the value of the
slot.

=item	3

Creates a method that takes one argument, and sets the value of the slot
to that value.  Given undef as that argument, the value is set to undef.
If called with no arguments, the slot value is set to undef.

=back

See the examples.

=head2	Examples

Creates methods a, b, c which can be used for both getting and setting
the named slots:

  use Class::MethodMaker
    get_set => 'a',
    get_set => [qw/ b c /];

Creates get_d which returns the value in slot d (takes no arguments),
and set_d, which sets the value in slot d (no return):

  use Class::MethodMaker
    get_set => [ -java => d ];

Creates e_clear, e_get, e_set, f_clear, f_get, f_set methods:

  use Class::MethodMaker
    get_set => [[undef, '*_clear', '*_get', '*_set'] => qw/e f/ ];

These options may be combined, using order sensitivity.  E.g.,

  use Class::MethodMaker
    get_set => [qw/ -java Status -eiffel size name /];

will instantiate the C<Status> component as a java style (with C<getStatus>,
C<setStatus> methods), and the C<size> & C<name> components as eiffel style
(with C<size>, C<set_size>, C<name>, C<set_name> methods).

=cut

sub _make_get_set {
  my $class = shift;
  my ($slot, $template, $opts) = @_; # $opts is a hashref

  # Older subclasses might pass a boolean instead of an href,
  # expecting to set the "-static" option.
  $opts = +{ '-static' => ($opts ? 1 : 0) } unless ref($opts) eq 'HASH';

  my %methods;

  my @method_names = @$template;
  my $method_name;
  for $method_name (@method_names) {
    if ( defined $method_name ) {
      $method_name =~ s/\*/$slot/g
        or carp "Method name template must include \* character.";
    }
  }

  my $pgsetter;
  if ( $opts->{'-static'} ) {
    my $store;
    $pgsetter = sub {
      return $store if @_ == 1;
      return $store = $_[1];
    };
  } else {
    $pgsetter = sub {
      return $_[0]->{$slot} if @_ == 1;
      return $_[0]->{$slot} = $_[1];
    };
  }

  # -set_once  wrapper
  if ( defined ( my $action_sub = $opts->{'-set_once'}) ) {
      my $once_name = " __CMM__ $slot once ";
      my $inner_pgsetter = $pgsetter;

      if ( $opts->{'-static'}) {
          my $already_set;
          $pgsetter = sub {
              if ( @_ > 1 ) {
                if ( $already_set ){
                    my $class = ref($_[0]) || $_[0];
                    $action_sub->($_[0], "Attempt to set static $class\:\:$slot more than once.", @_[1..$#_]);
                    return $inner_pgsetter->($_[0]);
                }
                else{
                    $already_set = 1;
                }
              }
              # call the old pgsetter
              $inner_pgsetter->(@_);
            };
      }
      else {
          $pgsetter = sub {
              if ( @_ > 1 ) {
                if ( exists $_[0]->{$once_name} ){
                    my $class = ref($_[0]) || $_[0];
                    $action_sub->($_[0], "Attempt to set $class\:\:$slot more than once.",@_[1..$#_]);
                    return $inner_pgsetter->($_[0]);
                }else{
                    $_[0]->{$once_name} = 1;
                }
              }
              # call the old pgsetter
              $inner_pgsetter->(@_);
            };
      }
  }

  my @methods =
    (
     '$pgsetter',
     'sub { $pgsetter->($_[0], undef); return }',
     'sub { return $pgsetter->($_[0]); }',
     'sub { $pgsetter->($_[0], $_[1]); return }',
    );

  my $i;
  for ($i = 0; $i < @methods; $i++) {
    $methods{$method_names[$i]} = eval $methods[$i]
      if defined $method_names[$i];
  }

  $methods{" __CMM__ $slot"} = $pgsetter;

  return %methods;
}

use constant GS_PATTERN_MAP =>
  {
   java          => [ undef, undef, 'get*', 'set*' ],
   eiffel        => [ undef, undef, '*', 'set_*' ],
   compatibility => [ '*', 'clear_*', undef, undef ],
   noclear       => [ '*', undef, undef, undef ],
  };
use constant GS_PATTERN_SPEC => join '|', keys %{GS_PATTERN_MAP()};

# Regex for -set_once. The action, if any, is in $1
use constant CMM_SET_ONCE_OPTION => qr/^-(?:set_once(?:_or_(\w+))?)/x;

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

  # @template is a list of pattern names for the methods.
  # Postions are perl:get/set, clear, get, set
  my $template = ${GS_PATTERN_MAP()}{'compatibility'};
  my %opts = ( '-static' => 0 );

  my $arg;
  foreach $arg (@args) {
    if ( my $ref = ref $arg ) {
      if ( $ref eq 'ARRAY' ) {
	$template = $arg;
	# Check for duplicate patterns.
	my %patterns;
	for (grep defined, @$template) {
	  croak "Duplicate pattern: $_"
	    if $patterns{$_};
	  $patterns{$_}++;
	}
      } else {
	croak "get_set does not handle this ref type: $ref";
      }
    } elsif ( substr ($arg, 0, 1) eq '-' ) {
      my $opt_name = substr ($arg, 1);
      if ( exists ${GS_PATTERN_MAP()}{$opt_name} ) {
	$template = ${GS_PATTERN_MAP()}{$opt_name};
      }
      elsif ( $opt_name eq 'static' ){
	$opts{ $arg } = 1;
      }
      elsif ( $arg =~ CMM_SET_ONCE_OPTION ){
         $class->_process_set_once($arg, \%opts);
      }
      else {
	croak "Unrecognised option: $arg to get_set";
      }
    } else {
      push @methods, $class->_make_get_set ($arg, $template, \%opts);
    }
  }

  $class->install_methods (@methods);
}

# Process option '-set_once' or '-set_once_or_FOO'.
# Return: none, but \%opts is modified.
sub _process_set_once {
    my ($class, $option, $opts) = @_;

    return unless $option =~ CMM_SET_ONCE_OPTION;
    my $action_name = $1 || 'die';
    my $use = '';

    if ($action_name eq 'ignore') {
        $opts->{'-set_once'} = sub { };
    }
    elsif ($action_name =~ /(carp|cluck|croak|confess)|die|warn/){
        $use = defined($1) && length($1) ? "use Carp qw($action_name);" : '';
        $opts->{'-set_once'} = eval "sub { $use $action_name(\@_) }";
    }else {
        $opts->{'-set_once'} = eval "sub { \$_[0]->$action_name(\@_[1..\$#_]) }";
    }
    return;
}

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

=head2 static_get_set

Like L<get_set|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

The difference between this and  L<get_set> is that these scalars are
shared across all instances of your object in your process.

This is now a wrapper around get_set (-static => @args).

=cut

sub static_get_set {
  return $_[0]->get_set (-static => @_[1..$#_]);
}


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

=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.

The argument taken may be a hashref, in which the keys C<name> and
C<join> are recognized; C<name> being the slot name, join being a join
string t glue any given strings.

Example:

  use Class::MethodMaker
    get_concat => { name => 'words', join => "\t" };

Will, each time an argument is supplied to the C<x> method, glue this
argument onto any existing value with tab separator.  Like the C<join>
operator, the join field is applied I<between> values, not prior to the
first or after the last.

=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 string or 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 slot C<x>, with forwarding methods C<y> and C<z>, the following
methods are created:

=over 4

=item	x

A get/set method.

If supplied with an object of an appropriate type, will set set the slot
to that value.

Else, if the slot has no value, then an object is created by calling new
on the appropriate class, passing in any supplied arguments.

The stored object is then returned.

=item	y

Forwarded onto the object in slot C<x>, which is auto-created via C<new>
if necessary.  The C<new>, if called, is called without arguments.

=item	z

As for C<y>.

=back

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 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) {
    # DD: changed to $obj_class to avoid clobberring the $class declared 4
    # line above
    my $obj_class = shift @args;
    my $list = shift @args or die "No slot names for $obj_class";

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

    my $obj_def;
    foreach $obj_def (@list) {
      my $type = $obj_class;

      # Hmmm. We have to do this for the closure to work. I.e. using
      # $obj_class in the closure dosen't work. Someday I'll actually
      # understand scoping in Perl. [ Uh, is this true? 11/11/96 -PBS ]

      # DD (22.1.2002): That's because the closure keeps a 'reference' to the
      # unique storage area hidden behind $obj_class. Its value changes at
      # each iteration of the 'while' loop. On the other hand, a new $type
      # variable (i.e. storage area) is created at each iteration of the
      # loop. Hence the value stored in each $type variable is not clobeered.

      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($_, $obj_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};
      };

      $class->_add_list_methods(\%methods, $name);

      #
      # Deprecated in line with list, v0.95 (1.vi.00)
      #
      $methods{"ref_$name"} = sub {
        my ($self) = @_;
        $self->{$name};
      };

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

  $class->install_methods(%methods);
}

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

=head2 object_tie_list

Functions like C<tie_list>, but maintains an array of referenced objects
in each slot.

 object_tie_list =>
  [
    {
      slot => xxx, # or [ ... , ... ]
      tie_array => [ 'ArrayName', args ,...] ,
      class => ['ObjName', constructor_args ]
    },
    ...
  ]

When xxx is called with one or several arguments,
Each argument is:

=over

=item *

Stored in the array if the argument is an object of the class 'ObjName'.

=item *

Used to create a new object of the class 'ObjName' if the argument is
an array ref. The elements of the array ref are passed to the
constructor *after* the default constructor arguments.

=item *

Discarded if any other case. A new object is created using the default
constructor arguments and stored in the array.

=back

=cut

# no support for forwarded methods (may not make sense)

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

  while (@args) {
    my $obj_tie_ref = shift @args;
    my $obj_class_ref = $obj_tie_ref->{class}
      or croak "No class passed to object_tie_list";
    my $tie_array_ref = $obj_tie_ref->{tie_array}
      or croak "No tied array name passed to object_tie_list";

    my $list = $obj_tie_ref->{slot}
      or croak "No slot names passef to object_tie_list";

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

    #    my $composites = $obj_tie_ref->{'comp_mthds'};
    #    my @composites = ref($composites) eq 'ARRAY' ? @$composites
    #      : defined $composites ? ($composites) : ();

    my $obj_class = shift @$obj_class_ref;

    foreach my $obj_def (@slot_list) {
      my $new_meth = 'new';
      my $name = $obj_def; # kept for closures

      $methods{$name} = sub {
        my ($self, @list) = @_;

        if ( ! defined $self->{$name} )
          {
            my ($tie_class, @c_args) = @$tie_array_ref ;
            # second args of tie is forced into a scalar context.
            tie my (@array), $tie_class, @c_args;
            $self->{$name} = \@array;
          }

        @{$self->{$name}} =
          map {
            (ref $_ and UNIVERSAL::isa($_, $obj_class)) ? $_ :
              ref $_ eq 'ARRAY' ? $obj_class->$new_meth(@$_) :
                $obj_class->$new_meth(@$obj_class_ref)
            } @list if scalar @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};
      };

      $class->_add_list_methods(\%methods, $name);

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

  $class->install_methods(%methods);
}

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

=head2 object_tie_hash

Functions like C<tie_hash>, but maintains an array of referenced objects
in each slot.

 object_tie_hash =>
  [
    {
      slot => xxx, # or [ ... , ... ]
      tie_hash => [ 'HashName', args ,...] ,
      class => ['ObjName', @constructor_args ]
    },
    ...
  ]

When xxx is called with more than one argument, xxx is treated as the key.
If the second argument is a:

=over

=item *

An object of the class 'ObjName' then the object is the new value of
the key 'xxx'.

=item *

An array ref. A new object of the class 'ObjName' is created and
stored in the hash. The elements of the array ref are passed to the
constructor *after* the default constructor arguments.

=item *

Anything else: A new object is created using the default constructor
arguments.

=back

Example, if the default constructor arguments are @c_args :

 xxx(
     # xxx[0] = $obj->isa('ObjName') ? $obj : ObjName->new(@c_args)
     $obj,
     # xxx[1] = ObjName->new(@c_args, arg => 'bar')
     [ arg => 'bar'],
     # xxx[2 to 8] = ObjName->new(@constructor_arg)
      1 .. 6
    )

=cut

# no support for forwarded methods (may not make sense)

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

  while (@args) {
    my $obj_tie_ref = shift @args;
    my $obj_class_ref = $obj_tie_ref->{class}
      or croak "No class passed to object_tie_hash";
    my $tie_hash_ref = $obj_tie_ref->{tie_hash}
      or croak "No tied hash name passed to object_tie_hash";

    my $hash = $obj_tie_ref->{slot}
      or croak "No slot names passef to object_tie_hash";

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

    #    my $composites = $obj_tie_ref->{'comp_mthds'};
    #    my @composites = ref($composites) eq 'ARRAY' ? @$composites
    #      : defined $composites ? ($composites) : ();

    my $obj_class = shift @$obj_class_ref;

    foreach my $obj_def (@slot_hash) {
      my $new_meth = 'new';
      my $name = $obj_def; # kept for closures

      $methods{$name} = sub {
        my ($self, @list) = @_;
        # when creating : key => [ constructor args ] , key => ...
        # or  key => obj , key => obj ...

        if ( ! defined $self->{$name} ) {
          my ($tie_class, @c_args) = @$tie_hash_ref ;
          # second args of tie is forced into a scalar context.
          tie my (%hash), $tie_class, @c_args;
          $self->{$name} = \%hash;
        }

        if (scalar @list == 1) {
          my $key = shift @list;

          if (ref $key eq 'ARRAY') {
            return @{$self->{$name}}{@$key};
          } else {
            return $self->{$name}->{$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->{$name}->{$key} =
              (ref $value and UNIVERSAL::isa($value, $obj_class))
                ? $value
                  : ref $value eq 'ARRAY'
                    ? $obj_class->$new_meth(@$obj_class_ref,@$value)
                      : $obj_class->$new_meth(@$obj_class_ref) ;
          }
        }
        wantarray ? %{$self->{$name}} : $self->{$name};
      };

      $class->_add_hash_methods(\%methods, $name) ;

    }
  }
  $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 _ancestry {
  my $class = shift;
  my ($target_class) = @_;
  return map { $_, $class->_ancestry ($_) } @{"${target_class}::ISA"};
}

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

  my $TargetClass = $class->find_target_class;

  my $bstore = join '__', $TargetClass, 'boolean';

  my $boolean_fields =
    $BooleanFields{$TargetClass};

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

  $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->{$bstore} or $self->{$bstore} = "";
        if (defined $on_off) {
          vec($self->{$bstore}, $bfp, 1) = $on_off ? 1 : 0;
        }
        vec($self->{$bstore}, $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.  If any arguments
are provided to this method, they I<replace> the current list contents.  In an
array context it returns the values as an array and in a scalar context as a
reference to the array.  Note that this reference is currently a direct
reference to the storage; changes to the storage will affect the contents of
the reference, and vice-versa.  This behaviour is not guaranteed; caveat
emptor.

=item x_push

=item x_pop

=item x_shift

=item x_unshift

=item x_splice

=item x_clear

=item x_count

Returns the number of elements in x.

=item x_index

Takes a list of indices, returns a list of the corresponding values.

=item x_set

Takes a list, treated as pairs of index => value; each given index is
set to the corresponding value.  No return.

=back

=cut

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

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

    $methods{$field} =
      sub {
        my ($self, @list) = @_;
        defined $self->{$field} or $self->{$field} = [];

        # Maintain any existing reference (avoid replacing)
        @{$self->{$field}} = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @list
          if @list;

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

    $class->_add_list_methods(\%methods, $field);

    #
    # Deprecated. v0.95 1.vi.00
    #
    $methods{"${field}_ref"} =
      sub {
        my ($self) = @_;
        $self->{$field};
      };

  }
  $class->install_methods(%methods);
}

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

=head2 static_list

As for L<list|list>, but the value of the component is shared across all
instances of your object in your process.

=cut

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

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

    $methods{$field} =
      sub {
        my $class = shift;
        my @list = @_;
        @storage =  map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @list
          if @list;
        return wantarray ? @storage : \@storage;
      };


  $methods{"${field}_pop"} =
      sub {
        pop @storage;
      };

  $methods{"${field}_push"} =
      sub {
        push @storage, @_[1..$#_];
      };

  $methods{"${field}_shift"} =
      sub {
        shift @storage;
      };

  $methods{"${field}_unshift"} =
      sub {
        my $class = shift;
        my @values = @_;
        unshift @storage, @values;
      };

  $methods{"${field}_splice"} =
      sub {
        my $class = shift;
        my ($offset, $len, @list) = @_;
        splice(@storage, $offset, $len, @list);
      };

  $methods{"${field}_clear"} =
      sub {
        @storage = ();
      };

  $methods{"${field}_count"} =
      sub {
        return scalar @storage;
      };

  $methods{"${field}_index"} =
      sub {
        my $class = shift;
        my (@indices) = @_;
        my @Result;
        push @Result, $storage[$_]
          for @indices;
        return $Result[0] if @_ == 1;
        return wantarray ? @Result : \@Result;
      };

  foreach my $method_name ("${field}_set") {
    $methods{$method_name} =
      sub {
        my $class = shift;
        my @args = @_;
        croak "$method_name expects an even number of fields\n"
          if @args % 2;
        while ( my ($index, $value) = splice @args, 0, 2 ) {
          $storage[$index] = $value;
        }
        return @_ / 2;          # required for object_list
      };
  }


    #
    # Deprecated. v0.95 1.vi.00
    #
    $methods{"${field}_ref"} =
      sub {
        my ($class) = @_;
        \@storage;
      };

  }
  $class->install_methods(%methods);
}

# ----------------------------------------------------------------------
# added by Dominique Dumont (22.i.02)

=head2 tie_list

Much like list, but can use a tied list instead.

Takes a list of pairs, where the first is the name of the component,
the second is an array reference.  The array reference takes the usual
tie parameters.

For instance if Array_A and ArrayB are tied arrays, you can have:

  tie_list =>
  [
   foo => [ 'Array_A',   foo => 'x', bar => 'B' ],
   baz => [ 'ArrayB',    baz => 0]
  ],

=cut

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

    while ( my ($fieldr, $tie_args) = splice (@args, 0, 2))
      {
        my $field;
        my ($tie_class,@c_args)= @$tie_args ;

        foreach $field (ref $fieldr ? @$fieldr : $fieldr)
          {
            $methods{$field} =
              sub
                {
                  my $self = shift;
                  # my @list = @_;

                  if ( ! defined $self->{$field} )
                    {
                      # second args of tie is forced into a scalar context.
                      tie my (@array), $tie_class, @c_args;
                      $self->{$field} = \@array;
                    }

                  @{$self->{$field}} =  @_ if scalar @_ ;

                  return wantarray ? @{$self->{$field}} : $self->{$field};
                };
            $class->_add_list_methods(\%methods, $field);
          }

        $class->install_methods(%methods);
      }
  }

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

# added by Dominique Dumont (22.i.02)
sub _add_list_methods {
  my ($class,$methods, $field) = @_;

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

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

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

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

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

  $methods->{"${field}_clear"} =
    $methods->{"clear_$field"} =
      sub {
        my ($self) = @_;
        # this code may clobbed references passed by the user
        # $self->{$field} = [];
        @{$self->{$field}} = () ;
      };

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

  $methods->{"${field}_index"} =
    $methods->{"index_$field"} =
      sub {
        my $self = shift;
        my (@indices) = @_;
        my @Result;
        push @Result, $self->{$field}->[$_]
          for @indices;
        return $Result[0] if @_ == 1;
        return wantarray ? @Result : \@Result;
      };

  foreach my $method_name (("${field}_set" ,"set_$field")) {
    $methods->{$method_name} =
      sub {
        my $self = shift;
        my @args = @_;
        croak "$method_name expects an even number of fields\n"
          if @args % 2;
        while ( my ($index, $value) = splice @args, 0, 2 ) {
          $self->{$field}->[$index] = $value;
        }
        return @_ / 2;          # required for object_list
      };
  }
}

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

=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 simple scalar argument it treats the argument as a key
and returns the value stored under that key.

Called with one array (list) reference argument, the array elements
are considered to be be keys of the hash. x returns the list of values
stored under those keys (also known as a I<hash slice>.)

Called with one hash reference argument, the keys and values of the
hash are added to the hash.

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.

=item	x_clear

Resets hash to empty.

=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) = @list;

          if ( my $type = ref $key ) {
            if ( $type eq 'ARRAY' ) {
              return @{$self->{$field}}{@$key};
            } elsif ( $type eq 'HASH' ) {
              while (my ($subkey, $value) = each %$key ) {
                $self->{$field}->{$subkey} = $value;
              }
              return wantarray ? %{$self->{$field}} : $self->{$field};
            } else {
              cluck "Not a recognized ref type for hash method: $type.";
            }
          } else { # $key is simple scalar
              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;
          }
          return wantarray ? %{$self->{$field}} : $self->{$field};
        }
      };

    $class->_add_hash_methods(\%methods, $field) ;

    $methods{$field . "_clear"} =
      sub {
	my $self = shift;
	$self->{$field} = {};
      };
  }
  $class->install_methods(%methods);
}

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

# added by Dominique Dumont (22.i.02)
sub _add_hash_methods {
  my ($class,$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->{$field . "_delete"} =
    sub {
      my ($self, @keys) = @_;
      delete @{$self->{$field}}{@keys};
    };
}

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

=head2 hash_of_lists

Creates a group of methods for dealing with list data stored by key in a
slot.

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

=over 4

=item   x

Returns all the values for all the given keys, in order.  If no keys are
given, returns all the values (in an unspecified key order).

The result is returned as an arrayref in scalar context.  This arrayref
is I<not> part of the data structure; messing with it will not affect
the contents directly (even if a single key was provided as argument.)

If any argument is provided which is an arrayref, then the members of
that array are used as keys.  Thus, the trivial empty-key case may be
utilized with an argument of [].

=item   x_keys

Returns the keys of the hash.  As an arrayref in scalar context.

=item   x_exists

Takes a list of keys, and returns whether each key exists in the hash
(i.e., the C<and> of whether the individual keys exist).

=item   x_delete

Takes a list, deletes each key from the hash.

=item   x_push

Takes a key, and some values.  Pushes the values onto the list denoted
by the key.  If the first argument is an arrayref, then each element of
that arrayref is treated as a key and the elements pushed onto each
appropriate list.

=item   x_pop

Takes a list of keys, and pops each one.  Returns the list of popped
elements.  undef is returned in the list for each key that is has an
empty list.

=item	x_last

Like C<x_pop>, but does not actually change any of the lists.

=item   x_unshift

Like push, only the from the other end of the lists.

=item   x_shift

Like pop, only the from the other end of the lists.

=item   x_splice

Takes a key, offset, length, and a values list.  Splices the list named
by the key.  Anything from the offset argument (inclusive) may be
omitted.  See L<perlfunc/splice>.

=item	x_set

Takes a key, and a set of index->value pairs, and sets each specified
index to the corresponding value for the given key.

=item   x_clear

Takes a list of keys.  Resets each named list to empty (but does not
delete the keys.)

=item   x_count

Takes a list of keys.  Returns the sum of the number of elements for
each named list.

=item   x_index

Takes a key, and a list of indices.  Returns a list of each item at the
corresponding index in the list of the given key.  Uses undef for
indices beyond range.

=item   x_remove

Takes a key, and a list of indices.  Removes each corresponding item
from the named list.  The indices are effectively looked up at the point
of call --- thus removing indices 3, 1 from list (a, b, c, d) will
remove (d) and (b).

=item   x_sift

Takes a key, and a set of named arguments, which may be a list or a hash
ref.  Removes list members based on a grep-like approach.

=over 4

=item   filter

The filter function used (as a coderef).  Is passed two arguments, the
value compared against, and the value in the list that is potential for
grepping out.  If returns true, the value is removed.  Default:

  sub { $_[0] == $_[1] }

=item   keys

The list keys to sift through (as an arrayref).  Unknown keys are
ignored.  Default: all the known keys.

=item   values

The values to sift out (as an arrayref).  Default: C<[undef]>

=back

=back

Options:

=over 4

=item	-static

Make the corresponding storage class-specific, rather than
instance-specific.

=back

=cut

sub hash_of_lists {
  my ($class, @args) = @_;
  my $static = 0;

  foreach (@args) {
    if ( substr ($_, 0, 1) eq '-' ) {
      my $option = substr $_, 1;
      if ( $option eq 'static' ) {
	$static = 1;
      } else {
	croak "Unrecognized option to hash_of_lists: $option\n";
      }
    } else {
      my %methods;
      my $field = $_;

      $methods{$field} =
	q{sub {
	  my $self = shift;
	  my @list = @_;
	  my @Result;

	  if ( @list ) {
	    if ( @list == 1 and ref ($list[0]) eq 'ARRAY' ) {
	      @Result = map @$_, @{__STORAGE__}{@{$list[0]}};
	    } else {
	      my @keys =
		map ref ($_) eq 'ARRAY' ? @$_: $_,
		  grep exists __STORAGE__->{$_}, @list;
	      @Result = map @$_, @{__STORAGE__}{@keys};
	    }
	  } else {
	    @Result = map @$_, values %{__STORAGE__};
	  }

	  return wantarray ? @Result : \@Result;
	}};

      $methods{$field . "_keys"} =
	q{sub {
	  my ($self) = shift;
	  my @Result = keys %{__STORAGE__};
	  return wantarray ? @Result : \@Result;
	}};

      $methods{$field . "_exists"} =
	q{sub {
	  my ($self) = shift;
	  my (@keys) = @_;
	  my $found = 1;
	  for (@keys) {
	    $found &&= exists __STORAGE__->{$_};
	  }
	  return $found;
	}};

      $methods{$field . "_delete"} =
	q{sub {
	  my ($self, @keys) = @_;
	  delete @{__STORAGE__}{@keys};
	}};

      $methods{$field . "_push"} =
	q{sub {
	  my ($self, $key, @values) = @_;
	  my @keys = ref ($key) eq 'ARRAY' ? @$key : $key;
	  for (@keys) {
	    push @{__STORAGE__->{$_}}, @values;
	  }
	}};

      $methods{$field . "_unshift"} =
	q{sub {
	  my ($self, $key, @values) = @_;
	  my @keys = ref ($key) eq 'ARRAY' ? @$key : $key;
	  for (@keys) {
	    unshift @{__STORAGE__->{$_}}, @values;
	  }
	}};

      $methods{$field . "_pop"} =
	q{sub {
	  my ($self, @keys) = @_;
	  my @old;
	  for (@keys) {
	    push @old, pop @{__STORAGE__->{$_}};
	  }
	  return @old;
	}};

      $methods{$field . "_last"} =
	q{sub {
	  my ($self, @keys) = @_;
	  my @old;
	  for (@keys) {
	    push @old, __STORAGE__->{$_}->[-1];
	  }
	  return @old;
	}};

      $methods{$field . "_shift"} =
	q{sub {
	  my ($self, @keys) = @_;
	  my @old;
	  for (@keys) {
	    push @old, shift @{__STORAGE__->{$_}};
	  }
	  return @old;
	}};

      $methods{$field . "_splice"} =
	q{sub {
	  my ($self, $key, $offset, $length, @values) = @_;
	  splice @{__STORAGE__->{$key}}, $offset, $length, @values;
	}};

      my $method_name = "${field}_set";
      $methods{$method_name} =
	q{sub{
	    my $self = shift;
	    croak "__METHOD_NAME__ expects a key and then index => " .
	      "value pairs.\n"
		unless @_ % 2;
	    my ($key, @args) = @_;
	    while ( my ($index, $value) = splice @args, 0, 2 ) {
	      __STORAGE__->{$key}->[$index] = $value;
	    }
	    return;
	  }};
      $methods{$method_name} =~ s!__METHOD_NAME__!$method_name!gs;

      $methods{$field . "_clear"} =
	q{sub {
	  my ($self, @keys) = @_;
	  for (@keys) {
	    __STORAGE__->{$_} = [];
	  }
	}};

      $methods{$field . "_count"} =
	q{sub {
	  my ($self, @keys) = @_;
	  my $Result = 0;
	  # Avoid autovivifying additional entries.
	  for (@keys) {
	    $Result +=
	      exists __STORAGE__->{$_} ?
		scalar @{__STORAGE__->{$_}} : 0;
	  }
	  return $Result;
	}};

      $methods{"${field}_index"} =
	q{sub {
	  my ($self, $key_r, @indices) = @_;
	  my (@Result, $index, $key);
	  my @keys = ref ($key_r) eq 'ARRAY' ? @$key_r : $key_r;
	  foreach $key (@keys) {
	    my $ary = __STORAGE__->{$key};
	    foreach $index (@indices) {
	      push @Result,
		( @{$ary} > $index ) ? $ary->[$index] : undef;
	    }
	  }
	  return wantarray ? @Result : \@Result;
	}};

      $methods{"${field}_remove"} =
	q{sub {
	  my ($self, $key_r, @indices) = @_;
	  my ($index, $key);
	  my @keys = ref ($key_r) eq 'ARRAY' ? @$key_r : $key_r;
	  foreach $key (@keys) {
	    my $ary = __STORAGE__->{$key};
	    foreach $index (sort {$b<=>$a} grep $_ < @$ary, @indices) {
	      splice (@$ary, $index, 1);
	    }
	  }
	  return;
	}};

      $methods{"${field}_sift"} =
	q{sub {
	  my $self = shift;
	  my %args;
	  if ( @_ == 1 and ref $_[0] eq 'HASH' ) {
	    %args = %{$_[0]};
	  } else {
	    %args = @_;
	  }
	  my $filter_sr = $args{'filter'}  || sub { $_[0] == $_[1] };
	  my $keys_ar   = $args{'keys'}    || [ keys %{__STORAGE__} ];
	  my $values_ar = $args{'values'}  || [undef];
  # This is harder than it looks; reverse means we want to grep out only
  # if *none* of the values matches.  I guess an evaled block, or closure
  # or somesuch is called for.
  #       my $reverse   = $args{'reverse'} || 0;

	  my ($key, $i, $value);
	KEY:
	  foreach $key (@$keys_ar) {
	    next KEY
	      unless exists __STORAGE__->{$key};
	  INDEX:
	    for ($i = $#{__STORAGE__->{$key}}; $i >= 0; $i--) {
	      foreach $value (@$values_ar) {
		if ( $filter_sr->($value, __STORAGE__->{$key}[$i]) ) {
		  splice @{__STORAGE__->{$key}}, $i, 1;
		  next INDEX;
		}
	      }
	    }
	  }
	}};

      my $replace = $static ? '$store' : "\$self->{$field}";
      foreach (@methods{keys %methods}) {
	s!__STORAGE__!$replace!gm
	  unless ref $_;
	;
      }

      if ( $static ) {
	my $store;
	for (@methods{keys %methods}) {
	  my $code = eval $_;
	  croak "Compilation of \n$_\n failed: $@\n"
	    if $@;
	  croak "Compilation of \n$_\n did not return a coderef: $code\n"
	    unless ref $code eq 'CODE';
	  $_ = $code;
	}
      }

      $class->install_methods (%methods);
    }
  }
}

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

=head2 tie_scalar

Create a get/set method to deal with the tied scalar.

Takes a list of pairs, where the first is the name of the component, the
second is an array reference.  The array reference takes the usual tie
parameters.

For instance if Enum and Boolean are tied scalar that accept default values,
you can have:

  tie_scalar =>
  [
   foo => [ 'Enum',   enum => [qw/A B C/], default => 'B' ],
   bar => [ 'Enum',   enum => [qw/T0 T1/], default => 'T1'],
   baz => ['Boolean', default => 0]
  ],


=cut

# added by Dominique Dumont (22.i.02)
sub tie_scalar {
  my ($class, @args) = @_;
  my %methods;

  while ( my ($fieldr, $tie_args) = splice (@args, 0, 2)) {
    my $field;
    my ($class,@c_args)= @$tie_args ;

    foreach $field (ref $fieldr ? @$fieldr : $fieldr) {
      $methods{$field} =
        sub {
          my ($self, $value) = @_;

          if ( ! defined $self->{$field} ) {
            my $scalar;
            # second args of tie is forced into a scalar context.
            tie ($scalar, $class, @c_args);
            $self->{$field} = \$scalar;
          }

          my $ref = $self->{$field} ;
          $$ref=$value if defined $value;
          return $$ref ;
        };
    }

  }
  $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

The first argument can also be an arrayref, specifying multiple
components to create.

Example:

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


=cut

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

  while ( my ($fieldr, $args) = splice (@args, 0, 2)) {
    my $field;
    foreach $field (ref $fieldr ? @$fieldr : $fieldr) {
      $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};
          }
        };

      $class->_add_hash_methods(\%methods, $field);
    }
  }
  $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) = @list;

          if ( my $type = ref $key ) {
            if ( $type eq 'ARRAY' ) {
              return @hash{@$key};
            } elsif ( $type eq 'HASH' ) {
              while ( my ($subkey, $value) = each %$key ) {
                if ( $^W ) {
                  defined $value
                    or carp "No value for key $subkey of hash $field.";
                }
                $hash{$subkey} = $value;
              }
              return wantarray ? %hash : \%hash;
            } else {
              cluck "Not a recognized ref type for static hash: $type.";
            }
          } 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;
          }
          wantarray ? %hash : \%hash;
        }
      };

    $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;
      };
  }
  $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 its first argument. Basically, you are 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);
}

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

=head2  counter

Create components containing simple counters that may be read,
incremented, or reset.  For value x, the methods are:

=over 4

=item   x

(accepts argument to set),

=item   x_incr

(accepts argument for increment size),

=item   x_reset

The counter is implicitly initialized to zero.

=back

=cut

sub counter {
  my $class = shift;
  my (@names) = @_;

  my %methods;

  my $name;
  foreach $name (@names) {

    $methods{$name} =
      sub {
        my $self = shift;
        $self->{$name} = $_[0]
          if @_;
        $self->{$name} = 0
          unless exists $self->{$name};
        return $self->{$name};
      };

    $methods{"${name}_incr"} =
      sub {
        my $self = shift;
        $self->{$name} = 0
          unless exists $self->{$name};
        $self->{$name} += @_ ? $_[0] : 1;
      };

    $methods{"${name}_reset"} =
      sub {
        my $self = shift;
        $self->{$name} = 0;
      }

  }

  $class->install_methods (%methods);
}

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

=head2 copy

Produce a copy of self.  The copy is a *shallow* copy; any references
will be shared by the instance upon which the method is called and the
returned newborn.

=cut

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

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

    $methods{$name} = sub {
      my $self = shift; my $class = ref $self;
      return bless { %$self }, $class;
    };
  }

  $class->install_methods(%methods);
}

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

=head2 deep_copy

Produce a copy of self.  The copy is a *deep* copy; any references will be
recursively copied value-by-value from the instance upon which the method is
called into the returned newborn.  Note that this copying does not support the
copying of coderefs, ties or XS-based objects.

=cut

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

  eval 'use Storable;';
  eval 'use Data::Dumper;' if $@;

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

    $methods{$name} = sub {
      my $self = shift; my $class = ref $self;

      if ( Storable->VERSION ) {
        return Storable::dclone $self;
      } else {
        my $copy;
        eval Data::Dumper->Dump([$self],['copy']);
        return $copy;
      }
    };
  }

  $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 generates a hash of
method_name/code-reference pairs, and then calls the class method
C<install_methods> on them.  If the coderef is in fact a string, then
that string will be C<eval>led in the hope of getting a coderef to use.

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 base qw( Class::MethodMaker );

  sub upper_case_get_set {
    my $class = shift;
    my ($name) = @_;
    my %methods;
    $methods{$name} =
      sub {
        my ($self, $new) = @_;
        defined $new and $self->{$name} = uc $new;
        $self->{$name};
      };
    $class->install_methods (%methods);
  }

  1;

Alternatively, rather than a coderef, the values of the hash passed to
install_methods may be strings, which will be evaled in the hope of
returning a coderef to use.  If the eval fails, or anything other than a
coderef is returned, then C::MM croaks.

Any return value from a method (above) that is used to generate methods
will be passed to install_methods --- so in the above, the line

    $class->install_methods (%methods);

could be replaced with

    return %methods

If intend to publish your meta-methods, consider doing so on CPAN, the
Comprehensive Perl Archive Network at http://www.cpan.org .  If your
meta-methods are generic and potentially useful to a large number of other
C::MM users (as distinct from an application-specific subset), please contact
the authour of this module at fluffy@cpan.org to discuss integrating those
methods with this module.

=cut

## EXPERIMENTAL META-METHODS

=head2	EXPERIMENTAL: builtin_class

History: This method was in 0.92, undocumented.  Does anybody use this?
Would anybody use this subject to some enhancement or other?  Let me
know.

Purpose: This class generates a wrapper around some builtin function,
cacheing the results in the object and providing a by-name interface.

Takes a (core) function name, and a arrayref of return position names
(we will call it pos_list).  Creates:

=over 4

=item	new

Calls the core func with any given arguments, stores the result in the
instance.

=item	x

For each member of pos_list, creates a method of the same name which
gets/sets the nth member of the returned list, where n is the position
of x in pos_list.

=item	fields

Returns pos_list, in the given order.

=item	dump

Returns a list item name, item value, in order.

=back

Example Usage:

  package Stat;

  use Class::MethodMaker
    builtin_class => [stat => [qw/ dev ino mode nlink /]],

  package main;

  my $file = "$ENV{HOME}/.profile";
  my $s = Stat->new ($file);
  print "File $file has ", $s->nlink, " links\n";

Note that (a) the new method does not check the return value of the
function called (in the above example, if $file does not exist, you will
silently get an empty object), and (b) if you really want the above
example, see the core File::stat module.   But you get the idea, I hope.

=cut

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 = shift;
	$self->[$sfp] = $_[0]
	  if @_;
        $self->[$sfp];
      };
  }
  $class->install_methods(%results);
}

=head1 EXAMPLES

Z<>

=head1 BUGS

Z<>

=head1 REPORTING BUGS

Email the author.

=head1  AUTHOR

Current Maintainer: Martyn J. Pearce fluffy@cpan.org

Original Author: Peter Seibel (Organic Online)

Contributions from:

  Dominique Dumont (Dominique_Dumont@hp.com)
    Hewlett-Packard Company. http://www.hp.com
  Evolution Online Systems, Inc. http://www.evolution.com
  Matthew Persico
  Yitzchak Scott-Thoennes

=head1 COPYRIGHT

    Copyright (c) 2000, 2001, 2002, 2003 Martyn J. Pearce.  This program is
    free software; you can redistribute it and/or modify it under the same
    terms as Perl itself.

    Copyright (c) 1998, 1999, 2000 Evolution Online Systems, Inc.  You may use
    this software for free under the terms of the MIT License.  More info
    posted at http://www.evolution.com, or contact info@evolution.com

    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.

=head1 SEE ALSO

  C<Class::Struct>, C<Class::MakeMethods>, "Object-Oriented Perl" by Damian
  Conway.

=cut