view release on metacpan or  search on metacpan

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

        if ( keys %$args ) {
            _croak( 'unknown options passed to ', __PACKAGE__, '::import: ', join( ', ', keys %$args ) );
        }
    }

    return @return;
}

sub _build_class {    ## no critic(ExcessComplexity)
    my ( $target, $name, $attr ) = @_;

    # in case we're called inside a recursion and the recurse count
    # has hit zero, default behavior is no recurse, so remove it so
    # the attr signature computed below isn't contaminated by a
    # useless -recurse => 0 attribute.
    if ( exists $attr->{-recurse} ) {
        _croak( '-recurse must be a number' )
          unless Scalar::Util::looks_like_number( $attr->{-recurse} );
        delete $attr->{-recurse} if $attr->{-recurse} == 0;
    }

    if ( !defined $attr->{-class} ) {

        ## no critic (ComplexMappings)
        my @class = map {
            ( my $key = $_ ) =~ s/-//;
            ( $key, defined $attr->{$_} ? $attr->{$_} : '<undef>' )
        } sort keys %$attr;

        $attr->{-class} = join q{::}, 'Hash::Wrap::Class', Digest::MD5::md5_hex( @class );
    }

    elsif ( $attr->{-class} eq '-target' || $attr->{-class} eq '-caller' ) {
        _croak( "can't set -class => '@{[ $attr->{-class} ]}' if '-as' is not a plain string" )
          if ref $name;
        $attr->{-class} = $target . q{::} . $name;
    }

    my $class = $attr->{-class};

    return $class if defined $REGISTRY{$class};
    my $rentry = $REGISTRY{$class} = { methods => {} };

    my %closures;
    my @BODY;
    my %dict = (
        class                 => $class,
        signature             => q{},
        body                  => \@BODY,
        autoload_attr         => q{},
        validate_inline       => 'exists $self->{\<<KEY>>}',
        validate_method       => 'exists $self->{$key}',
        set                   => '$self->{q[\<<KEY>>]} = $_[0] if @_;',
        return_value          => '$self->{q[\<<KEY>>]}',
        recursion_constructor => q{},
        predicate_template    => q{},
    );

    if ( $attr->{-lvalue} ) {
        if ( $] lt '5.016000' ) {
            _croak( 'lvalue accessors require Perl 5.16 or later' )
              if $attr->{-lvalue} < 0;
        }
        else {
            $dict{autoload_attr} = q[: lvalue];
            $dict{signature}     = q[: lvalue];
        }
    }

    if ( $attr->{-undef} ) {
        $dict{validate_method} = q[ 1 ];
        $dict{validate_inline} = q[ 1 ];
    }

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

    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>>;