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

# This file is preprocessed by cmmg.pl .  Subs are sought, as 'sub name {' (at
# a line begin) until '}' at a line begin.  Optional POD documentation may
# precede, if started with =head (and ended with =cut).  Blank lines &
# comments in between will be silently ignored, and anything else will be
# noisily ignored.

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

=head1 NAME

Class::Method::array - Create methods for handling an array value.

=head1 SYNOPSIS

  use Class::MethodMaker
    [ array => [qw/ x /] ];

  $instance->x;                # empty
  $instance->x(1, 1, 2, 3, 5, 8);
  $instance->x_count == 6;     # true
  $instance->x = (13, 21, 34);
  $instance->x_index(1) == 21; # true

=head1 DESCRIPTION

Creates methods to handle array values in an object.  For a component named
C<x>, by default creates methods C<x>, C<x_reset>, C<x_clear>, C<x_isset>,
C<x_count>, C<x_index>, C<x_push>, C<x_pop>, C<x_unshift>, C<x_shift>,
C<x_splice>.

=cut

# Sentinel value to tell array to clear.  Note that by being a reference,
# reconstructing it elsewhere won't work: so passing in a normal reference to
# 1 will store that reference to one, as expected.  \undef strangely doesn't
# work.

sub array {
  my $SENTINEL_CLEAR = \1;
  my $class  = shift;
  my ($target_class, $name, $options, $global) = @_;

  my %known_options = map {; $_ => 1 } qw( static type forward
                                           default default_ctor
                                           tie_class tie_args
                                           read_cb store_cb
                                           v1_compat );
  if ( my @bad_opt = grep ! exists $known_options{$_}, keys %$options ) {
    my $prefix = 'Option' . (@bad_opt > 1 ? 's' : '');
    croak("$prefix not recognized for attribute type hash: ",
          join(', ', @bad_opt), "\n");
  }

  my $type = $options->{type};
  croak "argument to -type ($type) must be a simple value\n"
    unless ! ref $type;

  my $forward = $options->{forward};
  my @forward;
  if ( defined $forward ) {
    if ( ref $forward ) {
      croak("-forward option can only handle arrayrefs or simple values " .
            "($forward)\n")
        unless UNIVERSAL::isa($forward, 'ARRAY');
      @forward = @$forward;
      print "Value '$_' passed to -forward is not a simple value"
        for grep ref($_), @forward;
    } else {
      @forward = $forward;
    }
  }

  my ($default, $dctor, $default_defined);
  if ( exists $options->{default} ) {
    croak("Cannot specify both default & default_ctor options to array ",
          "(attribute $name\n")
      if exists $options->{default_ctor};
    $default = $options->{default};
    $default_defined = 1;
  } elsif ( exists $options->{default_ctor} ) {
    if ( ! ref $options->{default_ctor} ) {
      my $meth = $options->{default_ctor};
      croak("default_ctor can only be a simple value when -type is in effect",
            " (attribute $name)\n")
        unless defined $type;
      croak("default_ctor must be a valid identifier (or a code ref): $meth ",
            "(attribute $name)\n")
        unless $meth =~ /^[A-Za-z_][A-Za-z0-9_]*/;
      $dctor = sub { $type->$meth(@_) };
    } else {
      $dctor = $options->{default_ctor};
      croak("Argument to default_ctor must be a simple value or a code ref ",
            " (attribute $name)\n")
        if ! UNIVERSAL::isa($dctor, 'CODE');
    }
    $default_defined = 1;
  }

  my ($tie_class, @tie_args);
  if ( exists $options->{tie_class} ) {
    $tie_class =  $options->{tie_class};
    if ( exists $options->{tie_args} ) {
      my $tie_args =  $options->{tie_args};
      @tie_args = ref $tie_args ? @$tie_args : $tie_args;
    }
  } elsif ( exists $options->{tie_args} ) {
    carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
  }

  # callback options
  my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
                        @{$options->{read_cb}}            :
                        $options->{read_cb}
    if exists $options->{read_cb};
  my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
                        @{$options->{store_cb}}             :
                        $options->{store_cb}
    if exists $options->{store_cb};

  %%STORDECL%%

  # Predefine keys for subs we always want to exist (because they're
  # referenced by other subs)
  my %names = map {; $_ => undef } qw( * *_reset *_index );

  return {

=pod

Methods available are:

=head3 C<*>

I<Created by default.> This method returns the list of values stored in the
slot.  If any arguments are provided to this method, they B<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 an array.  Note that this reference
is no longer a direct reference to the storage, in contrast to
Class::MethodMaker v1.  This is to protect encapsulation.  See x_ref if you
need that functionality (and are prepared to take the associated risk.)  This
function no longer auto-expands arrayrefs input as arguments, since that makes
it awkward to set individual values to arrayrefs.  See x_setref for that
functionality.

If a default value is in force, then that value will be auto-vivified (and
therefore set) for each otherwise I<unset> (not I<not defined>) value up to
the array max (so new items will not be appended)

=cut

          '*'        =>
          sub : method {
            my $want = wantarray;
            print STDERR "W: ", $want, ':', join(',',@_),"\n"
              if DEBUG;

            # We also deliberately avoid instantiating storage if not
            # necessary.

            if ( @_ == 1 ) {
              %%DEFAULT_ON%%
              if ( exists %%STORAGE%% ) {
                for (0..$#{%%STORAGE%%}) {
                  %%DEFCHECK@(%%STORAGE%%->[$_])%%;
                }
              }
              %%DEFAULT_OFF%%

              if ( exists %%STORAGE%% ) {
                if ( ! defined $want ) {
                  return;
                } elsif ( $want ) {
                  return @{%%STORAGE%%};
                } else {
                  return [@{%%STORAGE%%}];
                }
              } else {
                if ( ! defined $want ) {
                  return;
                } elsif ( $want ) {
                  return ();
                } else {
                  return [];
                }
              }
            } else {
              {
                no warnings "numeric";
                $#_ = 0
                  if $#_ and defined $_[1] and $_[1] == $SENTINEL_CLEAR;
              }

              my @x;
              %%V1COMPAT_ON%%
              if ( $options->{tie_class} ) {
                @x = @_[1..$#_];
              } else {
                @x = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @_[1..$#_];
              }
              %%V1COMPAT_OFF%%

              %%V2ONLY_ON%%
              @x = @_[1..$#_];
              %%V2ONLY_OFF%%

              %%STORE(\@x, $v)%%
              %%ASGNCHK@(%%IFSTORE(@$v,@x)%%)%%
              if ( ! defined $want ) {
                @{%%STORAGE%%} = %%IFSTORE(@$v,@x)%%;
                return;
              } elsif ( $want ) {
                @{%%STORAGE%%} = %%IFSTORE(@$v,@x)%%;
              } else {
                [@{%%STORAGE%%} = %%IFSTORE(@$v,@x)%%];
              }
            }
          },

=pod

=head3 C<*_reset>

I<Created by default.> Called without an argument, this resets the component
as a whole; deleting any associated storage, and returning the component to
its default state.  Normally, this means that C<*_isset> will return false,
and C<*> will return undef.  If C<-default> is in effect, then the component
will be set to the default value, and C<*_isset> will return true.  If
C<-default_ctor> is in effect, then the default subr will be invoked, and its
return value used to set the value of the component, and C<*_isset> will
return true.

If called with arguments, these arguments are treated as indexes into the
component, and the individual elements thus referenced are reset (their
storage deleted, so that C<*_isset(n)> will return false for appropriate I<n>,
except where C<-default> or C<-default_ctor> are in force, as above).  As with
perl arrays, resetting the highest set value implicitly decreases the count
(but x_reset(n) never unsets the aggregate itself, even if all the elements
are not set).

=cut

          '*_reset'  =>
          sub : method {
            if ( @_ == 1 ) {
              %%RESET@%%
              delete %%STORAGE%%;
            } else {
              delete @{%%STORAGE%%}[@_[1..$#_]];
            }
            return;
          },


=pod

=head3 C<*_clear>

  package MyClass;
  use Class::MethodMaker
    [ scalar => [{'*_clear' => '*_clear'}, 'a'],
      new    => new, ];

  package main;
  my $m = MyClass->new;
  $m->a(5);
  $a = $m->a;       # 5
  $x = $m->a_isset; # true
  $m->a_clear;
  $a = $m->a;       # *undef*
  $x = $m->a_isset; # true

I<Created on request>.  A shorthand for setting to undef.  Note that the
component will be set to undef, not reset, so C<*_isset> will return true.

=cut

          '*_clear'  =>
           sub : method {
             my $x = $names{'*'};
             $_[0]->$x($SENTINEL_CLEAR);
             return;
           },

=pod

=head3 C<*_isset>

I<Created by default.> Whether the component is currently set.  This is
different from being defined; initially, the component is not set (and if
read, will return undef); it can be set to undef (which is a set value, which
also returns undef).  Having been set, the only way to unset the component is
with <*_reset>.

If a default value is in effect, then <*_isset> will always return true.

C<*_isset()> tests the component as a whole.  C<*_isset(a)> tests the element
indexed by I<a>.  C<*_isset(a,b)> tests the elements indexed by I<a>, I<b>,
and returns the logical conjunction (I<and>) of the tests.

=cut

          '*_isset'  =>
          ( $default_defined      ?
            sub : method { 1 }    :
            sub : method {
              if ( @_ == 1 ) {
               exists %%STORAGE%%
             } elsif ( @_ == 2 ) {
               exists %%STORAGE%%->[$_[1]]
             } else {
               return
                 for grep ! exists %%STORAGE%%->[$_], @_[1..$#_];
               return 1;
             }
            }
          ),

=pod

=head3 C<*_count>

I<Created by default.> Returns the number of elements in this component.  This
is not affected by presence (or lack) of a C<default> (or C<default_ctor>).
Returns C<undef> if whole component not set (as per C<*_isset>).

=cut

           '*_count'  =>
           sub : method {
             if ( exists %%STORAGE%% ) {
               return scalar @{%%STORAGE%%};
             } else {
               return;                            %%V2ONLY%%
               return 0;                          %%V1COMPAT%%
             }
           },

=pod

=head3 C<*_index>

I<Created by default.> Takes a list of indices, returns a list of the
corresponding values.

If a default (or a default ctor) is in force, then a lookup by
index will vivify & set to the default the respective elements (and
therefore the aggregate data-structure also, if it's not already).

Beware of a bug in perl 5.6.1 that will sometimes invent values in
previously unset slots of arrays that previously contained a value.
So, vivifying a value (e.g. by x_index(2)) where x_index(1) was
previously unset might cause x_index(1) to be set spuriously.  This
is fixed in 5.8.0.

=cut

           # I did try to do clever things with returning refs if given refs,
           # but that conflicts with the use of lvalues
           '*_index' =>
           ( $default_defined      ?
             sub : method {
               for (@_[1..$#_]) {
                 %%DEFCHECK@(%%STORAGE%%->[$_])%%
               }
               @{%%STORAGE%%}[@_[1..$#_]];
             }                     :
             sub : method {
               @{%%STORAGE%%}[@_[1..$#_]];
             }
           ),

=pod

=head3 C<*_push>

I<Created by default.> Push item(s) onto the end of the list.  No return
value.

=cut

           '*_push' =>
           sub : method {
             %%ASGNCHK@(@_[1..$#_])%%
             push @{%%STORAGE%%}, @_[1..$#_];
             return;                                        %%V2ONLY%%
           },

=pod

=head3 C<*_pop>

I<Created by default.> Given a number, pops that many items off the end of the
list, and returns them (as a ref in scalar context, as a list in list
context).  Without an arg, always returns a single element.  Given a number,
returns them in array order (not in reverse order as multiple pops would).

=cut

           '*_pop' =>
           sub : method {
             if ( @_ == 1 ) {
               pop @{%%STORAGE%%};
             } else {
               return
                 unless defined wantarray;
               ! wantarray ? [splice @{%%STORAGE%%}, -$_[1]] :
                              splice @{%%STORAGE%%}, -$_[1] ;
             }
           },

=pod

=head3 C<*_unshift>

I<Created by default.> Push item(s) onto the start of the list.  No return
value.

=cut

           '*_unshift' =>
           sub : method {
             %%ASGNCHK@(@_[1..$#_])%%
             unshift @{%%STORAGE%%}, @_[1..$#_];
             return;                                        %%V2ONLY%%
           },

=pod

=head3 C<*_shift>

I<Created by default.> Given a number, shifts that many items off the start of
the list, and returns them (as a ref in scalar context, as a list in list
context).  Without an arg, always returns a single element.  Given a number,
returns them in array order.

=cut

           '*_shift' =>
           sub : method {
             if ( @_ == 1 ) {
               shift @{%%STORAGE%%};
             } else {
               splice @{%%STORAGE%%}, 0, $_[1], return
                 unless defined wantarray;
               ! wantarray ? [splice @{%%STORAGE%%}, 0, $_[1]] :
                              splice @{%%STORAGE%%}, 0, $_[1] ;
             }
           },

=pod

=head3 C<*_splice>

I<Created by default.> Arguments as for L<perldoc perlfunc splice|splice>.
Returns an arrayref in scalar context (even if a single item is spliced), and
a list in list context.

=cut

           '*_splice' =>
           sub : method {
             # Disturbing weirdness due to prototype of splice.
             #   splice @{%%STORAGE%%}, @_[1..$#_]
             # doesn't work because the prototype wants a scalar for
             # argument 2, so the @_[1..$#_] gets evaluated in a scalar
             # context, thus counts the elements of @_ (subtract 1).
             # Ripping of the head elements
             #   splice @{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_]
             # almost works, but that the $_[2] if not present presents an
             # undef, which works as a zero, whereas
             #   splice @{%%STORAGE%%}, $_[1]
             # splices to the end of the array

             if ( @_ < 3 ) {
               if ( @_ < 2 ) {
                 $_[1] = 0;
               }
               $_[2] = @{%%STORAGE%%} - $_[1]
             }
             %%ASGNCHK@(@_[3..$#_])%%

             splice(@{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_]), return
               unless defined wantarray;
             ! wantarray ? [splice(@{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_])] :
                            splice(@{%%STORAGE%%}, $_[1], $_[2], @_[3..$#_])  ;
           },

=pod

=head3 C<*_get>

I<Created on request>.  Retrieves the value of the component without setting
(ignores any arguments passed).

=cut

           '!*_get'   =>
           sub : method {
             my $x = $names{'*'};
             return $_[0]->$x();
           },

=pod

=head3 C<*_set>

  @n = $x->a; # (1,2,3)
  $x->a_set(1=>4,3=>7);
  @n = $x->a; # (1,4,3,7)

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

If two arguments are given, of which the first is an arrayref, then it is
treated as a list of indices of which the second argument (which must also be
an arrayref) are the corresponding values.  Thus the following two commands
are equivalent:

  $x->a_set(1=>4,3=>7);
  $x->a_set([1,3],[4,7]);

=cut

           '*_set'   =>
           sub : method {
             if ( @_ == 3 and ref $_[1] eq 'ARRAY' ) {
               %%ASGNCHK@(@{$_[2]})%%
               @{%%STORAGE%%}[@{$_[1]}] = @{$_[2]};
             } else {
               croak
                 sprintf("'%s' requires an even number of args (got %d)\n",
                         $names{'*_set'}, @_-1)
                 unless @_ % 2;
               %%ASGNCHK@(@_[map $_*2,1..($#_/2)])%%
               ${%%STORAGE%%}[$_[$_*2-1]] = $_[$_*2]
                 for 1..($#_/2);
             }
             return;
           },

           #
           # This method is deprecated.  It exists only for v1 compatibility,
           # and may change or go away at any time.  Caveat Emptor.
           #

           '!*_ref'   =>
           sub : method { %%STORAGE%% },

           map({; my $f = $_;
                $_ =>
                  sub : method {
                    my $x = $names{'*'};
                    my @x;
                    my @y = $_[0]->$x();
                    @x = map +(defined $_ ? $_->$f(@_[1..$#_]) : undef), @y;
                    # We don't check for a undefined wantarray here, since
                    # calling this in a void context is a sufficiently
                    # nonsensical thing to do that checking for it is likely
                    # performance hit than the typical saving.
                    ! wantarray ? \@x : @x;
                  }
               } @forward),
         }, \%names;
}