view release on metacpan or  search on metacpan

components/hash.m  view on Meta::CPAN

          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 hash ",
          "(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( * *_set *_reset *_index *_each );
  # The newer '*' treats a single +{} differently.  This is needed to ensure
  # that hash_init works for v1 scenarios
  $names{'='} = '*_v1compat' if $options->{v1_compat};

  return {

=pod

Methods available are:

=cut

=pod

=head3 C<*>

I<Created by default>.  This method returns the list of keys and values stored
in the slot (they are returned pairwise, i.e., key, value, key, value; as with
perl hashes, no order of keys is guaranteed).  If any arguments are provided
to this method, they B<replace> the current hash contents.  In an array
context it returns the keys, values as an array and in a scalar context as a
hash-reference.  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.)

If a single argument is provided that is an arrayref or hashref, it is
expanded and its contents used in place of the existing contents.  This is a
more efficient passing mechanism for large numbers of values.

=cut

          '*'        =>
          sub : method {
	    my $z = \@_;   # work around stack problems
            my $want = wantarray;
            print STDERR "W: ", $want, ':', join(',',@_),"\n"
              if DEBUG;
            # We also deliberately avoid instantiating storage if not
            # necessary.
            if ( @_ == 1 ) {
              if ( exists %%STORAGE%% ) {
                return
                  unless defined $want;
                if ( $want ) {
                  %{%%STORAGE%%};
                } else {
                  +{%{%%STORAGE%%}};                        %%V2ONLY%%
                  %%STORAGE%%;                              %%V1COMPAT%%
                }