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: _subinfo()
        _subinfo => <<'PERL',
# Credits: Inspired from Sub::Identify
# Usage:
# my $name = $self->_subinfo();         # auto-detect (best for named subs)
# my $name = $self->_subinfo(__SUB__);  # explicit (works with closures/anon)
# my @info = $self->_subinfo(__SUB__);  # list context = full info
sub _subinfo
{
    my $self = shift( @_ );
    my $coderef;
    if( @_ )
    {
        # Something was provided to us, but not suitable.
        $coderef = shift( @_ ) ||
            return( $self->error( 'No subroutine code reference was provided. Call it like this: \$self->_subinfo(__SUB__)' ) );
    }
    # Auto-detect via caller if no argument was passed
    else
    {
        my( $pkg, $file, $line, $subname ) = caller(1);
        if( $subname )
        {
            # works well for named subs
            $coderef = \&{ $subname };
        }
        else
        {
            return( $self->error( "Could not auto-detect current subroutine" ) );
        }