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" } ) )
    {
        require Module::Generic::Tie;
        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( Want::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 = {};
    if( defined( ${ "${class}\::LOG_DEBUG" } ) )
    {
        *$self->{log_debug} = ${ "${class}::LOG_DEBUG" };
    }
    if( Want::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 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( '' );
    }
    # The data provided may be composed only of null bytes, which is the case sometime
    # when retrieved from memory, and in such case, there is no point passing it to 
    # deserialiser. Even worse, CBOR::XS does not deal with extra null padded data in the first 
    # place, and Sereal would not like a string made only of null bytes
    elsif( CORE::exists( $opts->{data} ) && 
           CORE::defined( $opts->{data} ) && 
           $opts->{data} =~ /\x{00}$/ )
    {
        ( my $temp = $opts->{data} ) =~ s/\x{00}+$//gs;
        # There is nothing to do
        return( '' ) if( !length( $temp ) ); 
    }
    
    if( $class eq 'CBOR' || $class eq 'CBOR::XS' )
    {