view release on metacpan or  search on metacpan

lib/Hash/Wrap.pm  view on Meta::CPAN

    }

    if ( $attr->{-defined} ) {
        $dict{defined} = $attr->{-defined} =~ PerlIdentifier ? $1 : 'defined';
        push @BODY, q[ sub <<DEFINED>> { defined $_[0]->{$_[1] } } ];
        $rentry->{methods}{ $dict{defined} } = undef;
    }

    if ( $attr->{-immutable} ) {
        $dict{set} = <<'END';
  Hash::Wrap::_croak( q[Modification of a read-only value attempted])
    if @_;
END
    }

    if ( $attr->{-recurse} ) {

        # decrement recursion limit.  It's infinite recursion if
        # -recurse < 0; always set to -1 so we keep using the same
        # class.  Note that -recurse will never be zero upon entrance
        # of this block, as -recurse => 0 is removed from the
        # attributes way upstream.

        $dict{recurse_limit} = --$attr->{-recurse} < 0 ? -1 : $attr->{-recurse};

        $dict{quoted_key} = 'q[\<<KEY>>]';
        $dict{hash_value} = '$self->{<<QUOTED_KEY>>}';

        $dict{recurse_wrap_hash} = '$<<CLASS>>::recurse_into_hash->( <<HASH_VALUE>> )';

        $dict{return_value} = <<'END';
 'HASH' eq (Scalar::Util::reftype( <<HASH_VALUE>> ) // q{})
        && ! Scalar::Util::blessed( <<HASH_VALUE>> )
      ? <<WRAP_HASH_ENTRY>>
      : <<HASH_VALUE>>;
END
        if ( $attr->{-copy} ) {

            if ( $attr->{-immutable} ) {
                $dict{wrap_hash_entry} = <<'END';
                 do { Hash::Util::unlock_ref_value( $self, <<QUOTED_KEY>> );
                      <<HASH_VALUE>> = <<RECURSE_WRAP_HASH>>;
                      Hash::Util::lock_ref_value( $self, <<QUOTED_KEY>> );
                      <<HASH_VALUE>>;
                    }
END
            }
            else {
                $dict{wrap_hash_entry} = '<<HASH_VALUE>> = <<RECURSE_WRAP_HASH>>';
            }

        }
        else {
            $dict{wrap_hash_entry} = '<<RECURSE_WRAP_HASH>>';
        }

        # do a two-step initialization of the constructor.  If
        # the initialization sub is stored in $recurse_into_hash, and then
        # $recurse_into_hash is set to the actual constructor I worry that
        # Perl may decide to garbage collect the setup subroutine while it's
        # busy setting $recurse_into_hash.  So, store the
        # initialization sub in something other than $recurse_into_hash.

        $dict{recursion_constructor} = <<'END';
our $recurse_into_hash;
our $setup_recurse_into_hash = sub {
      require Hash::Wrap;
      ( $recurse_into_hash ) = Hash::Wrap->import ( { %$attr, -as => '-return',
                                                      -recurse => <<RECURSE_LIMIT>> } );
      goto &$recurse_into_hash;
};
$recurse_into_hash = $setup_recurse_into_hash;
END

        my %attr = ( %$attr, -recurse => --$attr->{-recurse} < 0 ? -1 : $attr->{-recurse}, );
        delete @attr{qw( -as_scalar_ref -class -base -as )};
        $closures{'$attr'} = \%attr;
    }

    if ( $attr->{-predicate} ) {
        $dict{predicate_template} = <<'END';
our $predicate_template = q[
  package \<<CLASS>>;

  use Scalar::Util ();

  sub has_\<<KEY>> {
    my $self = shift;

    Hash::Wrap::_croak_class_method( $self, 'has_\<<KEY>>' )
        unless Scalar::Util::blessed( $self );

   return exists $self->{\<<KEY>>};
  }

  $Hash::Wrap::REGISTRY{methods}{'has_\<<KEY>>'} = undef;

  \&has_\<<KEY>>;
];
END
    }

    my $class_template = <<'END';
package <<CLASS>>;

<<CLOSURES>>

use Scalar::Util ();

our $validate = sub {
    my ( $self, $key ) = @_;
    return <<VALIDATE_METHOD>>;
};

<<RECURSION_CONSTRUCTOR>>

our $accessor_template = q[
  package \<<CLASS>>;

  use Scalar::Util ();