view release on metacpan or  search on metacpan

lib/Module/Generic.pm  view on Meta::CPAN

    };
    my( $name, $sigil, $type );
    if( CORE::exists( $opts->{type} ) &&
        defined( $opts->{type} ) &&
        CORE::exists( $defaults->{uc( $opts->{type} )} ) )
    {
        $sigil = substr( $name = $var, 0, 1, '' );
        $type = $opts->{type};
    }
    elsif( exists( $map->{ substr( $var, 0, 1 ) } ) )
    {
        $sigil = substr( $name = $var, 0, 1, '' );
        $type = $map->{ $sigil };
    }
    else
    {
        # $type = $map->{ '' };
        return( $self->error( "Unsupported variable ${var}. You can only set array, hash, scalar, code or glob" ) );
    }

    my $value;
    if( CORE::exists( $opts->{value} ) &&
        defined( $opts->{value} ) )
    {
        my $refval = ( Scalar::Util::reftype( $opts->{value} ) // '' );
        if( $type eq 'SCALAR' &&
            ( $refval eq 'HASH' || $refval eq 'ARRAY' || $refval eq 'CODE' ) )
        {
            $type = $refval;
            $value = \$opts->{value};
        }
        else
        {
            $value = $opts->{value};
        }

        if( $type eq 'ARRAY' ||
              $type eq 'CODE' ||
              $type eq 'HASH' ||
              $type eq 'GLOB' )
        {
            return( $self->error( "Value of type ${refval} provided for ${var} is incompatible." ) ) if( $refval ne $type );
        }
        elsif( $refval ne 'SCALAR' &&
            $refval ne 'REF' &&
            $refval ne 'LVALUE' &&
            $refval ne 'REGEXP' &&
            $refval ne 'VSTRING' )
        {
            return( $self->error( "Value of type ${refval} provided for ${var} cannot be used." ) );
        }

        # cheap fail-fast check for PERLDBf_SUBLINE and '&'
        if( $^P && 
            ( $^P & 0x10 ) && 
            $sigil eq '&' )
        {
            no warnings 'once';
            my $filename = $opts->{filename};
            my $start_line = $opts->{start_line};
            ( $filename, $start_line ) = (caller)[1,2] if( !defined( $filename ) );
            my $end_line = $opts->{end_line} || ( $start_line ||= 0 );
            # <http://perldoc.perl.org/perldebguts.html#Debugger-Internals>
            $DB::sub{ $class . '::' . $name } = "${filename}:${start_line}-${end_line}";
        }
    }

    if( defined( $value ) )
    {
        no strict 'refs';
        no warnings 'redefine';
        *{ $class . '::' . $name } = ref( $value )
            ? $value
            : \$value;
    }
    else
    {
        no strict 'refs';
        # Broken ISA assignment
        if( $] < 5.012 && 
            $name eq 'ISA' )
        {
            *{ $class . '::' . $name };
        }
        else
        {
            *{ $class . '::' . $name } = $defaults->{ $type };
        }
    }
}
PERL
        # NOTE: as_hash()
        as_hash => <<'PERL',
sub as_hash
{
    my $self = shift( @_ );
    my $p = $self->_get_args_as_hash( @_ );
    # $p = shift( @_ ) if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' );
    $p->{convert_array} //= 1;
    my $me = $self->_obj2h;
    my $seen = $p->{seen} || {};
    my $levels = $p->{levels} || [];
    my $keys = $p->{fields} || [];

    my $added_subs = CORE::exists( $me->{_added_method} ) && ref( $me->{_added_method} ) eq 'HASH'
        ? $me->{_added_method}
        : {};
    
    my $crawl;
    $crawl = sub
    {
        my $this = shift( @_ );
        my $rval = ref( $this ) ? $this : \$this;
        my( $dataref, $class, $type, $id );
        my $strval = $dataref = $self->_str_val( $rval // 'undef' );
        # Parse $strval without using regexps, in order not to clobber $1, $2,...
        if( ( my $i = rindex( $dataref, '=' ) ) >= 0 )
        {
            $class = substr( $dataref, 0, $i );
            $dataref = substr( $dataref, $i + 1 );
        }