File Coverage

blib/lib/Hash/Wrap.pm

Criterion	Covered	Total	%
statement	425	452	94.0
branch	181	234	77.3
condition	45	81	55.5
subroutine	84	95	88.4
pod			n/a
total	735	862	85.2

package Hash::Wrap;

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

use 5.01000;

use strict;
use warnings;

## no critic(ValuesAndExpressions::ProhibitAccessOfPrivateData)

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

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

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)
    no strict 'refs';
    return *{$method}{CODE}
      || Hash::Wrap::_generate_accessor( $CLASS, $class, $key );
}

sub import {
    shift;
    my $caller = caller;

    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;

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

        elsif ( 'HASH' ne ref $args ) {
            _croak(
                "argument to ",
                __PACKAGE__,
                "::import must be string or hash"
            ) unless grep { /$args/ } @EXPORT;
        }
        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};

        $args->{-as} = 'wrap_hash' unless exists $args->{-as};
        my $name = delete $args->{-as};

        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( "don't use -as => -return with -base" )
              if $args->{-as_return};
            $args->{-class} = $caller;
            $args->{-new}   = 1 unless !!$args->{-new};
            _build_class( $caller, $name, $args );
        }

        else {
            _build_class( $caller, $name, $args );
            if ( defined $name ) {
                my $sub = _build_constructor( $caller, $name, $args );
                push @return, $sub if $args->{-as_return};
            }
        }

        # clean out known attributes
        delete @{$args}{
            qw[ -as -as_return -as_scalar_ref -base -class -clone
              -copy -defined -exists -immutable -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 {
    my ( $caller, $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} ) {

        my @class = map {
            ( my $key = $_ ) =~ s/-//;
            ( $key, defined $attr->{$_} ? $attr->{$_} : "" )
        } sort keys %$attr;

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

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

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

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

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

    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 @{ $dict{body} }, q[ sub <> { exists $_[0]->{$_[1] } } ];
        $rentry->{methods}{$dict{exists}} = undef;
    }

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

    if ( $attr->{-immutable} ) {
        $dict{set} = <<'END';
if ( @_ ) {
  require Carp;
  Carp::croak( q[Modification of a read-only value attempted])
}
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{return_value} = <<'END';
return 'HASH' eq (Scalar::Util::reftype( $self->{q[\<>]} ) // '')
        && ! Scalar::Util::blessed( $self->{q[\<>]} )
      ? $<>::recurse_into_hash->( $self->{q[\<>]} )
      : $self->{q[\<>]};
END

        # 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 $meta = { <> };

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, \%closures )
      or _croak_about_code( \$class_template, "class $class" );

    if ( !!$attr->{-new} ) {
        my $name = $attr->{-new} =~ PerlIdentifier ? $1 : 'new';
        _build_constructor( $class, $name, { %$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 {
    my ( $package, $name, $args ) = @_;

    # closure for user provided clone sub
    my $clone;

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

    my %dict = (
        package              => $package,
        constructor_name     => $name,
        use                  => [],
        package_return_value => '1;',
    );

    $dict{class} = do {
        if ( $args->{-as_method} ) {
            'shift;';
        }
        else {

            'q[' . $args->{-class} . '];';
        }
    };

    $dict{copy} = do {
        if ( $args->{-copy} ) {
            '$hash = { %{ $hash } };';
        }

        elsif ( exists $args->{-clone} ) {
            if ( 'CODE' eq ref $args->{-clone} ) {
                $clone = $args->{-clone};
                '$hash = $clone->($hash);';
            }
            else {
                push @{ $dict{use} }, q[use Storable ();];
                '$hash = Storable::dclone $hash;';
            }
        }
    };

    $dict{lock} = do {
        if ( $args->{-immutable} ) {
            push @{ $dict{use} }, q[use Hash::Util ();];
            'Hash::Util::lock_hash(%$hash)';
        }
        elsif ( defined $args->{-lockkeys} ) {

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

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

    # 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} ) {
        $dict{package_return_value} = '';
        $dict{constructor_name}     = '';
    }

    #<<< no tidy
    my $code = q[
    package <>;
    <>
    <>
    use Scalar::Util ();

    no warnings 'redefine';

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

      if ( 'HASH' ne Scalar::Util::reftype($hash) ) {
         require Carp;
         Carp::croak( "argument to <>::<> must be a hashref" )
      }
      <>
      bless $hash, $class;
      <>
    }
    <>
    ];
    #>>>

    my $result = _compile_from_tpl( \$code, \%dict, { '$clone' => $clone } )
      || _croak(
        "error generating constructor (as $name) subroutine: $@\n$code" );

    # 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 ) = @_;
    my $error = $@;
    _line_number_code( $code );
    _croak( qq[error compiling $what: $error\n$$code] );
}

sub _line_number_code {
    my ( $code ) = @_;
    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) {
        $dict->{closures}
          = join( "\n", map { "my $_ = \$closures->{'$_'};" } keys %$closures );
    }

    _interpolate( $code, $dict );

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


    eval( $$code );    ## no critic (ProhibitStringyEval)
}

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 {
                        '';
                    }
                }
              }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__