bless.*=> [$]class results from the CPAN

bless.*=> [$]class

Module-Generic

view release on metacpan or search on metacpan

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

            };
        }
        if( $@ )
        {
            CORE::warn( $@ ) unless( $SILENT_AUTOLOAD );
        }
    }
}

sub new
{
    my $that  = shift( @_ );
    my $class = ref( $that ) || $that;
    my $self  = {};
    no strict 'refs';
    if( defined( ${ "${class}\::OBJECT_PERMS" } ) )
    {
        $that->_load_class( 'Module::Generic::Tie' ) || return( $that->pass_error );
        my %hash  = ();
        my $obj   = tie(
            %hash, 
            'Module::Generic::Tie', 
            'pkg'   => [ __PACKAGE__, $class ],
            'perms' => ${ "${class}::OBJECT_PERMS" },
        );
        $self  = \%hash;
    }
    bless( $self, $class );
    if( defined( ${ "${class}\::LOG_DEBUG" } ) )
    {
        $self->{log_debug} = ${ "${class}::LOG_DEBUG" };
    }
    
    if( Wanted::want( 'OBJECT' ) )
    {
        return( $self->init( @_ ) );
    }
    my $new = $self->init( @_ );
    # Returned undef; there was an error potentially
    if( !defined( $new ) )
    {
        # If we are called on an object, we hand it the error so the caller can check it using the object:
        # my $new = $old->new || die( $old->error );
        if( $self->_is_object( $that ) && $that->can( 'pass_error' ) )
        {
            return( $that->pass_error( $self->error ) );
        }
        else
        {
            return( $self->pass_error );
        }
    };
    return( $new );
}

sub new_glob
{
    my $that  = shift( @_ );
    my $class = ref( $that ) || $that;
    no warnings 'once';
    my $self = bless( \do{ local *FH } => $class );
    *$self = {};
    no strict 'refs';
    if( defined( ${ "${class}\::LOG_DEBUG" } ) )
    {
        *$self->{log_debug} = ${ "${class}::LOG_DEBUG" };
    }
    if( Wanted::want( 'OBJECT' ) )
    {
        return( $self->init( @_ ) );
    }
    my $new = $self->init( @_ );
    if( !defined( $new ) )
    {
        # If we are called on an object, we hand it the error so the caller can check it using the object:
        # my $new = $old->new || die( $old->error );
        if( $self->_is_object( $that ) && $that->can( 'pass_error' ) )
        {
            return( $that->pass_error( $self->error ) );
        }
        else
        {
            return( $self->pass_error );
        }
    };
    return( $new );
}

sub clear_error
{
    my $self  = shift( @_ );
    my $class = ref( $self ) || $self;
    my $this  = $self->_obj2h;
    no strict 'refs';
    my $err_key = HAS_THREADS() ? join( ';', $class, $$, threads->tid ) : join( ';', $class, $$ );

    $this->{error} = '';
    my $repo = Module::Generic::Global->new( 'errors' => $class, key => $err_key );
    $repo->remove;
    ${ $class . '::ERROR' } = '';
    return( $self );
}

sub deserialise
{
    my $self = shift( @_ );
    my $data;
    $data = shift( @_ ) if( scalar( @_ ) && ( @_ % 2 ) );
    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{base64} //= '';
    $opts->{data} = $data if( defined( $data ) && length( $data ) );
    my $this  = $self->_obj2h;
    my $class = $opts->{serialiser} || $opts->{serializer} || $SERIALISER;
    return( $self->error( "No serialiser class was provided nor set in \$Module::Generic::SERIALISER" ) ) if( !defined( $class ) || !length( $class ) );

    # Well, nothing to do
    if( ( !defined( $opts->{file} ) || !length( $opts->{file} ) ) && 
        ( !defined( $opts->{io} ) || !length( $opts->{io} ) ) &&
        ( !defined( $opts->{data} ) || !length( $opts->{data} ) ) )
    {
        return( '' );

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

    no strict 'refs';
    if( $this->{verbose} || $this->{debug} || ${ $class . '::DEBUG' } )
    {
        my $level = ( $_[0] =~ /^\d+$/ ? shift( @_ ) : undef() );
        my $opts = {};
        if( scalar( @_ ) > 1 && 
            ref( $_[-1] ) eq 'HASH' && 
            (
                CORE::exists( $_[-1]->{level} ) || 
                CORE::exists( $_[-1]->{type} ) || 
                CORE::exists( $_[-1]->{message} ) || 
                CORE::exists( $_[-1]->{colour} ) 
            ) )
        {
            $opts = pop( @_ );
        }
        $level = $opts->{level} if( !defined( $level ) && CORE::exists( $opts->{level} ) );
        my( $ref, $fmt );
        if( $opts->{message} )
        {
            if( ref( $opts->{message} ) eq 'ARRAY' )
            {
                $ref = $opts->{message};
                $fmt = shift( @$ref );
            }
            else
            {
                $fmt = $opts->{message};
                $ref = \@_;
            }
        }
        else
        {
            $ref = \@_;
            $fmt = shift( @$ref );
        }
        my $txt = sprintf( $fmt, map( ( ref( $_ ) eq 'CODE' && !$this->{_msg_no_exec_sub} ) ? $_->() : $_, @$ref ) );
        $txt = $self->colour_parse( $txt ) if( $opts->{colour} );
        $opts->{message} = $txt;
        $opts->{level} = $level if( defined( $level ) );
        return( $self->_message( ( $level || 0 ), $opts ) );
    }
    return(1);
}

sub _obj2h
{
    my $self = shift( @_ );
    # The method that called message was itself called using the package name like My::Package->some_method
    # We are going to check if global $DEBUG or $VERBOSE variables are set and create the related debug and verbose entry into the hash we return
    no strict 'refs';
    if( !ref( $self ) )
    {
        my $class = $self;
        my $hash =
        {
            debug   => ${ "${class}\::DEBUG" },
            verbose => ${ "${class}\::VERBOSE" },
            error   => ${ "${class}\::ERROR" },
        };
        return( bless( $hash => $class ) );
    }
    elsif( ( Scalar::Util::reftype( $self ) // '' ) eq 'HASH' )
    {
        return( $self );
    }
    elsif( ( Scalar::Util::reftype( $self ) // '' ) eq 'GLOB' )
    {
        if( ref( *$self ) eq 'HASH' )
        {
            return( *$self );
        }
        else
        {
            return( \%{*$self} );
        }
    }
    # Because object may be accessed as My::Package->method or My::Package::method
    # there is not always an object available, so we need to fake it to avoid error
    # This is primarly itended for generic methods error(), errstr() to work under any conditions.
    else
    {
        return( {} );
    }
}

sub _refaddr { return( Scalar::Util::refaddr( $_[1] ) ); }

sub _set_get
{
    my $self  = shift( @_ );
    my $field = shift( @_ );
    my $this  = $self->_obj2h;
    my $data  = $this->{_data_repo} ? $this->{ $this->{_data_repo} } : $this;

    my $callbacks = {};
    my $check;
    my $def = {};
    if( ref( $field ) eq 'HASH' )
    {
        $def = $field;
        if( CORE::exists( $def->{field} ) && 
            defined( $def->{field} ) && 
            CORE::length( $def->{field} ) )
        {
            $field = $def->{field};
        }
        else
        {
            return( $self->error( "No field name was provided." ) );
        }
        $callbacks = $def->{callbacks} if( CORE::exists( $def->{callbacks} ) && ref( $def->{callbacks} ) eq 'HASH' );
        $check = $def->{check} if( CORE::exists( $def->{check} ) && ref( $def->{check} ) eq 'CODE' );
    }

    if( @_ )
    {
        my $val = ( @_ == 1 ) ? shift( @_ ) : [ @_ ];
        if( defined( $check ) )
        {
            # try-catch

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

            return( defined( ${ *{$glob}{$type} } ) ? 1 : 0 );
        }
        else
        {
            return( defined( *{$glob}{$type} ) ? 1 : 0 );
        }
    }
    else
    {
        return( $type eq 'CODE' ? 1 : 0 );
    }
}
PERL
    # NOTE: _implement_freeze_thaw()
    _implement_freeze_thaw => <<'PERL',
sub _implement_freeze_thaw
{
    my $self = shift( @_ );
    my @classes = @_;
    foreach my $class ( @classes )
    {
        unless( defined( &{"${class}\::STORABLE_freeze"} ) )
        {
            no warnings 'once';
            *{"${class}\::STORABLE_freeze"} = sub
            {
                my $self = CORE::shift( @_ );
                my $serialiser = CORE::shift( @_ ) // '';
                my $class = CORE::ref( $self );
                my %hash  = %$self;
                # Return an array reference rather than a list so this works with Sereal and CBOR
                CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' || $serialiser eq 'CBOR' );
                # But Storable/Storable::Improved want a list with the first element being the serialised element
                CORE::return( $class, \%hash );
            };
        }
        
        unless( defined( &{"${class}\::STORABLE_thaw"} ) )
        {
            no warnings 'once';
            *{"${class}\::STORABLE_thaw"} = sub
            {
                # STORABLE_thaw would issue $cloning as the 2nd argument, while CBOR would issue
                # 'CBOR' as the second value.
                my( $self, undef, @args ) = @_;
                my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
                my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
                my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
                my $new;
                # Storable pattern requires to modify the object it created rather than returning a new one
                if( CORE::ref( $self ) )
                {
                    foreach( CORE::keys( %$hash ) )
                    {
                        $self->{ $_ } = CORE::delete( $hash->{ $_ } );
                    }
                    $new = $self;
                }
                else
                {
                    $new = CORE::bless( $hash => $class );
                }
                CORE::return( $new );
            };
        }
        
        unless( defined( &{"${class}\::FREEZE"} ) )
        {
            no warnings 'once';
            *{"${class}::FREEZE"} = sub
            {
                my $self = CORE::shift( @_ );
                my $serialiser = CORE::shift( @_ ) // '';
                my @args = &{"${class}::STORABLE_freeze"}( $self );
                CORE::return( \@args ) if( $serialiser eq 'Sereal' || $serialiser eq 'CBOR' );
                CORE::return( @args );
            };
        }

        unless( defined( &{"${class}::THAW"} ) )
        {
            no warnings 'once';
            *{"${class}::THAW"} = sub
            {
                my( $self, undef, @args ) = @_;
                my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
                $self = bless( {} => $self ) unless( ref( $self ) );
                CORE::return( &{"${class}::STORABLE_thaw"}( $self, undef, @$ref ) );
            };
        }
    }
}
PERL
    # NOTE: _is_empty()
    _is_empty => <<'PERL',
sub _is_empty
{
    my $self = shift( @_ );
    return(1) if( !@_ );
    return(1) if( !defined( $_[0] ) );
    if( (
            ( Scalar::Util::reftype( $_[0] ) // '' ) eq 'SCALAR' && 
            !CORE::length( ${$_[0]} // '' )
        ) || 
        (
            !ref( $_[0] ) &&
            !CORE::length( $_[0] // '' )
        ) )
    {
        return(1);
    }
    elsif( ( Scalar::Util::reftype( $_[0] ) // '' ) eq 'ARRAY' &&
        !scalar( @{$_[0]} ) )
    {
        return(1);
    }
    elsif( ( Scalar::Util::reftype( $_[0] ) // '' ) eq 'HASH' &&
        Scalar::Util::blessed( $_[0] ) && 
        $_[0]->can( 'is_empty' ) && 
        ( $_[0]->is_empty ? 1 : 0 ) )
    {

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


sub DEBUG
{
    my $self = shift( @_ );
    my $pkg  = ref( $self ) || $self;
    my $this = $self->_obj2h;
    no strict 'refs';
    return( ${ $pkg . '::DEBUG' } );
}

# NOTE: Works with CBOR and Sereal <https://metacpan.org/pod/Sereal::Encoder#FREEZE/THAW-CALLBACK-MECHANISM>
sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my $ref = $self->_obj2h;
    my %hash = %$ref;
    $hash{_is_glob} = ( Scalar::Util::reftype( $self ) // '' ) eq 'GLOB' ? 1 : 0;
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, \%hash );
}

# sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }

# sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

# NOTE: Works with CBOR and Sereal <https://metacpan.org/pod/Sereal::Encoder#FREEZE/THAW-CALLBACK-MECHANISM>
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my $is_glob = CORE::delete( $hash->{_is_glob} );
    my $new;
    if( $is_glob )
    {
        $new = CORE::ref( $self ) ? $self : $class->new_glob;
        foreach( CORE::keys( %$hash ) )
        {
            *$new->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
    }
    else
    {
        # Storable pattern requires to modify the object it created rather than returning a new one
        if( CORE::ref( $self ) )
        {
            foreach( CORE::keys( %$hash ) )
            {
                $self->{ $_ } = CORE::delete( $hash->{ $_ } );
            }
            $new = $self;
        }
        else
        {
            $new = bless( $hash => $class );
        }
    }
    CORE::return( $new );
}

# NOTE: class function
# Used internally also in Module::Generic::Exception
sub UNIVERSAL::create_class
{
    my $class = shift( @_ );
    my $self = __PACKAGE__;
    return( $self->error( "No class name was provided." ) ) if( $self->_is_empty( $class ) );
    my $opts = $self->_get_args_as_hash( @_ );
    my $parent = $opts->{extends} || $self;
    my $parents = $self->_is_array( $parent ) ? $parent : [$parent];
    for( my $i = 0; $i < scalar( @$parents ); $i++ )
    {
        my $this = $parents->[$i];
        if( ref( $this ) )
        {
            return( $self->error( "The parent value provided (", overload::StrVal( $this // 'undef' ), ") is a reference, but not an object. You should provide a parent class as a string, or a blessed object." ) ) if( !Scalar::Util::blessed( $this ) ...
            $parents->[$i] = ref( $this );
        }
    }
    my $meths = CORE::delete( $opts->{method} ) // CORE::delete( $opts->{methods} );
    my $is_loaded = $self->_is_class_loaded( $class );
    if( $is_loaded )
    {
        # Make sure the parent is in the ISA
        unless( scalar( grep( ( $_ // '' ) eq $parent, @{"${class}::ISA"} ) ) )
        {
            no strict 'refs';
            unshift( @{"${class}::ISA"}, $parent );
        }
        return( $class );
    }
    my $map =
    {
        array               => '_set_get_array',
        # Alias for 'array_as_object'
        array_object        => '_set_get_array_as_object',
        array_as_object     => '_set_get_array_as_object',
        boolean             => '_set_get_boolean',
        class               => '_set_get_class',
        class_array         => '_set_get_class_array',
        class_array_object  => '_set_get_class_array_object',
        code                => '_set_get_code',
        datetime            => '_set_get_datetime',
        decimal             => '_set_get_number',
        file                => '_set_get_file',
        float               => '_set_get_number',
        glob                => '_set_get_glob',
        hash                => '_set_get_hash',
        hash_as_object      => '_set_get_hash_as_mix_object',
        integer             => '_set_get_number',
        ip                  => '_set_get_ip',
        long                => '_set_get_number',
        number              => '_set_get_number',
        object              => '_set_get_object',
        object_no_init      => '_set_get_object_without_init',

( run in 0.346 second using v1.01-cache-2.11-cpan-0f795438458 )