File Coverage

blib/lib/Hash/Wrap.pm

Criterion	Covered	Total	%
statement	512	533	96.0
branch	201	254	79.1
condition	59	95	62.1
subroutine	110	113	97.3
pod			n/a
total	882	995	88.6

package Hash::Wrap;

# ABSTRACT: create on-the-fly objects from hashes

use 5.01000;

use strict;
use warnings;

use Scalar::Util;
use Digest::MD5;
our $VERSION = '1.09';

our @EXPORT = qw[ wrap_hash ];

our @CARP_NOT = qw( Hash::Wrap );
our $DEBUG    = 0;

# copied from Damian Conway's PPR: PerlIdentifier
use constant PerlIdentifier => qr/\A([^\W\d]\w*+)\z/;

# use builtin::export_lexically if available
use constant HAS_LEXICAL_SUBS => $] >= 5.038;
use if HAS_LEXICAL_SUBS, 'experimental', 'builtin';
use if HAS_LEXICAL_SUBS, 'builtin';

our %REGISTRY;

sub _croak {
    require Carp;
    goto \&Carp::croak;
}

sub _croak_class_method {
    my ( $class, $method ) = @_;
    $class = ref( $class ) || $class;
    _croak( qq[Can't locate class method "$method" via package "$class"] );
}

sub _croak_object_method {
    my ( $object, $method ) = @_;
    my $class = Scalar::Util::blessed( $object ) || ref( $object ) || $object;
    _croak( qq[Can't locate object method "$method" via package "$class"] );
}

sub _find_symbol {
    my ( $package, $symbol, $reftype ) = @_;

    no strict 'refs';    ## no critic (ProhibitNoStrict)
    my $candidate = *{"$package\::$symbol"}{SCALAR};

    return $$candidate
      if defined $candidate
      && 2 == grep { defined $_->[0] && defined $_->[1] ? $_->[0] eq $_->[1] : 1 }
      [ $reftype->[0], Scalar::Util::reftype $candidate ],
      [ $reftype->[1], Scalar::Util::reftype $$candidate ];

    _croak( "Unable to find scalar \$$symbol in class $package" );
}

# this is called only if the method doesn't exist.
sub _generate_accessor {
    my ( $hash_class, $class, $key ) = @_;

    my %dict = (
        key   => $key,
        class => $class,
    );

    my $code    = $REGISTRY{$hash_class}{accessor_template};
    my $coderef = _compile_from_tpl( \$code, \%dict );
    _croak_about_code( \$code, 'accessor' )
      if $@;

    return $coderef;
}

sub _generate_predicate {
    my ( $hash_class, $class, $key ) = @_;

    my %dict = (
        key   => $key,
        class => $class,
    );

    my $code    = $REGISTRY{$hash_class}{predicate_template};
    my $coderef = _compile_from_tpl( \$code, \%dict );
    _croak_about_code( \$code, 'predicate' )
      if $@;

    return $coderef;
}

sub _autoload {
    my ( $hash_class, $method, $object ) = @_;

    my ( $class, $key ) = $method =~ /(.*)::(.*)/;

    _croak_class_method( $object, $key )
      unless Scalar::Util::blessed( $object );

    if ( exists $REGISTRY{$hash_class}{predicate_template}
        && $key =~ /^has_(.*)/ )
    {
        return _generate_predicate( $hash_class, $class, $1 );
    }

    _croak_object_method( $object, $key )
      unless $REGISTRY{$hash_class}{validate}->( $object, $key );

    _generate_accessor( $hash_class, $class, $key );
}

sub _can {
    my ( $self, $key, $CLASS ) = @_;

    my $class = Scalar::Util::blessed( $self );
    return () if !defined $class;

    if ( !exists $self->{$key} ) {

        if ( exists $Hash::Wrap::REGISTRY{$class}{methods}{$key} ) {
            ## no critic (ProhibitNoStrict)
            no strict 'refs';
            my $method = "${class}::$key";
            return *{$method}{CODE};
        }
        return ();
    }

    my $method = "${class}::$key";

    ## no critic (ProhibitNoStrict PrivateSubs)
    no strict 'refs';
    return *{$method}{CODE}
      || Hash::Wrap::_generate_accessor( $CLASS, $class, $key );
}

sub import {    ## no critic(ExcessComplexity)
    shift;

    my @imports = @_;
    push @imports, @EXPORT unless @imports;

    my @return;

    for my $args ( @imports ) {
        if ( !ref $args ) {
            _croak( "$args is not exported by ", __PACKAGE__ )
              unless grep { /$args/ } @EXPORT;    ## no critic (BooleanGrep)

            $args = { -as => $args };
        }

        elsif ( 'HASH' ne ref $args ) {
            _croak( 'argument to ', __PACKAGE__, '::import must be string or hash' )
              unless grep { /$args/ } @EXPORT;    ## no critic (BooleanGrep)
        }
        else {
            # make a copy as it gets modified later on
            $args = {%$args};
        }

        _croak( 'cannot mix -base and -class' )
          if !!$args->{-base} && exists $args->{-class};

        $DEBUG = $ENV{HASH_WRAP_DEBUG} // delete $args->{-debug};

        # -as may be explicitly 'undef' to indicate use in a standalone class
        $args->{-as} = 'wrap_hash' unless exists $args->{-as};
        my $name = delete $args->{-as};

        my $target = delete $args->{-into} // caller;

        if ( defined $name ) {

            if ( defined( my $reftype = Scalar::Util::reftype( $name ) ) ) {
                _croak( '-as must be undefined or a string or a reference to a scalar' )
                  if $reftype ne 'SCALAR'
                  && $reftype ne 'VSTRING'
                  && $reftype ne 'REF'
                  && $reftype ne 'GLOB'
                  && $reftype ne 'LVALUE'
                  && $reftype ne 'REGEXP';

                $args->{-as_scalar_ref} = $name;

            }

            elsif ( $name eq '-return' ) {
                $args->{-as_return} = 1;
            }
        }

        if ( $args->{-base} ) {
            _croak( q{don't use -as => -return with -base} )
              if $args->{-as_return};
            $args->{-class} = $target;
            $args->{-new}   = 1 if !exists $args->{-new};
            _build_class( $target, $name, $args );
        }

        else {
            _build_class( $target, $name, $args );
            if ( defined $name ) {
                my $sub = _build_constructor( $target, $name, $args );
                if ( $args->{-as_return} ) {
                    push @return, $sub;
                }
                elsif ( $args->{-lexical} ) {
                    _croak( "Perl >= v5.38 is required for -lexical; current perl is $^V" )
                      unless HAS_LEXICAL_SUBS;
                    builtin::export_lexically( $name, $sub );
                }
            }
        }

        # clean out known attributes
        delete @{$args}{
            qw[ -as -as_return -as_scalar_ref -base -class -clone
              -copy -defined -exists -immutable -lexical -lockkeys -lvalue
              -methods -new -predicate -recurse -undef ]
        };

        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->{$_} : '' )
        } 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->{\<>}',
        validate_method       => 'exists $self->{$key}',
        set                   => '$self->{q[\<>]} = $_[0] if @_;',
        return_value          => '$self->{q[\<>]}',
        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 $_[0]->{$_[1] } } ];
        $rentry->{methods}{ $dict{exists} } = undef;
    }

    if ( $attr->{-defined} ) {
        $dict{defined} = $attr->{-defined} =~ PerlIdentifier ? $1 : 'defined';
        push @BODY, q[ sub <> { 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[\<>]';
        $dict{hash_value} = '$self->{<>}';

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

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

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

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

        # 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 => <> } );
      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 \<>;

  use Scalar::Util ();

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

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

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

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

  \&has_\<>;
];
END
    }

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

<>

use Scalar::Util ();

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

<>

our $accessor_template = q[
  package \<>;

  use Scalar::Util ();

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

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

    Hash::Wrap::_croak_object_method( $self, '\<>' )
        unless ( <> );

   <>

   return <>;
  }
  \&\<>;
];

<>


<>

our $AUTOLOAD;
sub AUTOLOAD <> {
    goto &{ Hash::Wrap::_autoload( q[<>], $AUTOLOAD, $_[0] ) };
}

sub DESTROY { }

sub can {
    return Hash::Wrap::_can( @_, q[<>] );
}

1;
END

    _compile_from_tpl( \$class_template, \%dict, keys %closures ? \%closures : () )
      or _croak_about_code( \$class_template, "class $class" );

    if ( !!$attr->{-new} ) {
        my $lname = $attr->{-new} =~ PerlIdentifier ? $1 : 'new';
        _build_constructor( $class, $lname, { %$attr, -as_method => 1 } );
    }

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

        my $methods = $attr->{-methods};
        _croak( '-methods option value must be a hashref' )
          unless 'HASH' eq ref $methods;

        for my $mth ( keys %$methods ) {
            _croak( "method name '$mth' is not a valid Perl identifier" )
              if $mth !~ PerlIdentifier;

            my $code = $methods->{$mth};
            _croak( qq{value for method "$mth" must be a coderef} )
              unless 'CODE' eq ref $code;
            no strict 'refs';    ## no critic (ProhibitNoStrict)
            *{"${class}::${mth}"} = $code;
        }

        $rentry->{methods}{$_} = undef for keys %$methods;
    }

    push @CARP_NOT, $class;
    $rentry->{accessor_template}
      = _find_symbol( $class, 'accessor_template', [ 'SCALAR', undef ] );

    if ( $attr->{-predicate} ) {
        $rentry->{predicate_template}
          = _find_symbol( $class, 'predicate_template', [ 'SCALAR', undef ] );
    }

    $rentry->{validate} = _find_symbol( $class, 'validate', [ 'REF', 'CODE' ] );

    Scalar::Util::weaken( $rentry->{validate} );

    return $class;
}

sub _build_constructor {    ## no critic (ExcessComplexity)
    my ( $package, $name, $args ) = @_;

    # closure for user provided clone sub
    my %closures;

    _croak( 'cannot mix -copy and -clone' )
      if exists $args->{-copy} && exists $args->{-clone};

    my @USE;
    my %dict = (
        package              => $package,
        constructor_name     => $name,
        use                  => \@USE,
        package_return_value => '1;',
    );

    $dict{class}
      = $args->{-as_method}
      ? 'shift;'
      : 'q[' . $args->{-class} . '];';

    my @copy = (
        'Hash::Wrap::_croak(q{the argument to <>::<> must not be an object})',
        '  if Scalar::Util::blessed( $hash );',
    );

    if ( $args->{-copy} ) {
        push @copy, '$hash = { %{ $hash } };';
    }

    elsif ( exists $args->{-clone} ) {

        if ( 'CODE' eq ref $args->{-clone} ) {
            $closures{'clone'} = $args->{-clone};
            # overwrite @copy, as the clone sub could take an object.
            @copy = (
                'state $clone = $CLOSURES->{clone};',
                '$hash = $clone->($hash);',
                'Hash::Wrap::_croak(q{the custom clone routine for <> returned an object instead of a plain hash})',
                '  if Scalar::Util::blessed( $hash );',
            );
        }
        else {
            push @USE,  q[use Storable ();];
            push @copy, '$hash = Storable::dclone $hash;';
        }
    }

    $dict{copy} = join "\n", @copy;

    $dict{lock} = do {
        my @eval;

        if ( defined( my $opts = $args->{-immutable} || undef ) ) {

            push @USE, q[use Hash::Util ();];

            if ( 'ARRAY' eq ref $opts ) {
                _croak( "-immutable: attribute name ($_) is not a valid Perl identifier" )
                  for grep { $_ !~ PerlIdentifier } @{$opts};

                push @eval,
                  'Hash::Util::lock_keys_plus(%$hash, qw{ ' . join( q{ }, @{$opts} ) . ' });',
                  '@{$hash}{Hash::Util::hidden_keys(%$hash)} = ();',
                  ;
            }

            push @eval, 'Hash::Util::lock_hash(%$hash)';
        }
        elsif ( defined( $opts = $args->{-lockkeys} || undef ) ) {

            push @USE, q[use Hash::Util ();];

            if ( 'ARRAY' eq ref $args->{-lockkeys} ) {
                _croak( "-lockkeys: attribute name ($_) is not a valid Perl identifier" )
                  for grep { $_ !~ PerlIdentifier } @{ $args->{-lockkeys} };

                push @eval,
                  'Hash::Util::lock_keys_plus(%$hash, qw{ ' . join( q{ }, @{ $args->{-lockkeys} } ) . ' });';
            }
            elsif ( $args->{-lockkeys} ) {

                push @eval, 'Hash::Util::lock_keys(%$hash)';
            }
        }

        join( "\n", @eval );

    };

    # return the constructor sub from the factory and don't insert the
    # name into the package namespace
    if ( $args->{-as_scalar_ref} || $args->{-as_return} || $args->{-lexical} ) {
        $dict{package_return_value} = q{};
        $dict{constructor_name}     = q{};
    }

    #<<< no tidy
    my $code = <<'ENDCODE';
    package <>;

    <>
    use Scalar::Util ();

    no warnings 'redefine';

    sub <> (;$) {
      my $class = <>
      my $hash = shift // {};

      Hash::Wrap::_croak( 'argument to <>::<> must be a hashref' )
        if  'HASH' ne Scalar::Util::reftype($hash);
      <>
      bless $hash, $class;
      <>
    }
    <>

ENDCODE
    #>>>

    my $result = _compile_from_tpl( \$code, \%dict, keys %closures ? \%closures : () )
      || _croak_about_code( \$code, "constructor (as $name) subroutine" );

    # caller asked for a coderef to be stuffed into a scalar
    ${$name} = $result if $args->{-as_scalar_ref};
    return $result;
}

sub _croak_about_code {
    my ( $code, $what, $error ) = @_;
    $error //= $@;
    _line_number_code( $code );
    _croak( qq[error compiling $what: $error\n$$code] );
}

sub _line_number_code {
    my ( $code ) = @_;
    chomp( $$code );
    $$code .= "\n";
    my $space = length( $$code =~ tr/\n// );
    my $line  = 0;
    $$code =~ s/^/sprintf "%${space}d: ", ++$line/emg;
}

sub _compile_from_tpl {
    my ( $code, $dict, $closures ) = @_;

    if ( defined $closures && %$closures ) {

        # add code to create lexicals if the keys begin with a q{$}
        $dict->{closures} = join( "\n",
            map { "my $_ = \$CLOSURES->{'$_'};" }
              grep { substr( $_, 0, 1 ) eq q{$} }
              keys %$closures );
    }

    _interpolate( $code, $dict );

    if ( $DEBUG ) {
        my $lcode = $$code;
        _line_number_code( \$lcode );
        print STDERR $lcode;
    }

    _clean_eval( $code, exists $dict->{closures} ? $closures : () );

}

# eval in a clean lexical space.
sub _clean_eval {
    ## no critic (StringyEval RequireCheckingReturnValueOfEval )
    if ( @_ > 1 ) {
        ## no critic (UnusedVars)
        my $CLOSURES = $_[1];
        eval( ${ $_[0] } );
    }
    else {
        eval( ${ $_[0] } );
    }

}

sub _interpolate {
    my ( $tpl, $dict, $work ) = @_;
    $work = { loop => {} } unless defined $work;

    $$tpl =~ s{(\\)?\<\<(\w+)\>\>
              }{
                  if ( defined $1 ) {
                     "<<$2>>";
                  }
                  else {
                    my $key = lc $2;
                    my $v = $dict->{$key};
                    if ( defined $v ) {
                        $v = join( "\n", @$v )
                          if 'ARRAY' eq ref $v;

                        _croak( "circular interpolation loop detected for $key" )
                          if $work->{loop}{$key}++;
                        _interpolate( \$v, $dict, $work );
                        --$work->{loop}{$key};
                    $v;
                    }
                    else {
                        q{};
                    }
                }
              }gex;
    return;
}

1;

#
# This file is part of Hash-Wrap
#
# This software is Copyright (c) 2017 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__