Module-Generic
view release on metacpan or search on metacpan
lib/Module/Generic.pm view on Meta::CPAN
{
warn( "Could not acquire shared lock on '$f': ", $f->error ) if( $self->_is_warnings_enabled( 'Module::Generic' ) );
}
}
my $data = $f->load( binmode => 'raw' );
$f->unlock if( $opts->{lock} );
return( $self->pass_error( $f->error ) ) if( !defined( $data ) );
# try-catch
local $@;
my $ref = eval
{
if( defined( $base64 ) )
{
my $decoded = $base64->[1]->( $data );
return( CBOR::Free::decode( $decoded ) );
}
else
{
return( CBOR::Free::decode( $data ) );
}
};
if( $@ )
{
return( $self->error( "Error trying to deserialise data with $class: $@" ) );
}
return( $ref );
}
elsif( exists( $opts->{data} ) )
{
return( $self->error( "Data provided to deserialise with $class is empty." ) ) if( !defined( $opts->{data} ) || !length( $opts->{data} ) );
# try-catch
local $@;
my $ref = eval
{
no warnings;
if( defined( $base64 ) )
{
my $decoded = $base64->[1]->( $opts->{data} );
return( CBOR::Free::decode( $decoded ) );
}
else
{
return( CBOR::Free::decode( $opts->{data} ) );
}
};
if( $@ )
{
return( $self->error( "Error trying to deserialise data with $class: $@" ) );
}
return( $ref );
}
else
{
return( $self->error( "No file and no data was provided to deserialise with $class." ) );
}
}
# NOTE: deserialise with JSON
elsif( $class eq 'JSON' )
{
my @options = qw(
allow_blessed allow_nonref allow_unknown allow_tags ascii boolean_values
canonical convert_blessed filter_json_object filter_json_single_key_object
indent latin1 max_depth max_size pretty relaxed space_after space_before utf8
);
my $json = JSON->new;
for( @options )
{
next unless( CORE::exists( $opts->{ $_ } ) );
if( my $code = $json->can( $_ ) )
{
$code->( $json, $opts->{ $_ } );
}
}
if( exists( $opts->{file} ) && $opts->{file} )
{
my $f = $self->new_file( $opts->{file} ) || return( $self->pass_error );
return( $self->error( "File provided \"$opts->{file}\" does not exist." ) ) if( !$f->exists );
return( $self->error( "File provided \"$opts->{file}\" is actually a directory." ) ) if( $f->is_directory );
return( $self->error( "File provided \"$opts->{file}\" to deserialise is empty." ) ) if( $f->is_empty );
if( $opts->{lock} )
{
if( !$f->lock( shared => 1 ) )
{
warn( "Could not acquire shared lock on '$f': ", $f->error ) if( $self->_is_warnings_enabled( 'Module::Generic' ) );
}
}
my $data = $f->load( binmode => 'raw' );
$f->unlock if( $opts->{lock} );
return( $self->pass_error( $f->error ) ) if( !defined( $data ) );
my $ref;
# try-catch
local $@;
eval
{
if( defined( $base64 ) )
{
my $decoded = $base64->[1]->( $data );
( $ref, my $bytes ) = $json->decode_prefix( $decoded );
}
else
{
( $ref, my $bytes ) = $json->decode_prefix( $data );
}
};
if( $@ )
{
return( $self->error( "Error trying to serialise data with $class: $@" ) );
}
return( $ref );
}
elsif( exists( $opts->{data} ) )
{
return( $self->error( "Data provided to deserialise with $class is empty." ) ) if( !defined( $opts->{data} ) || !length( $opts->{data} ) );
my $ref;
# try-catch
local $@;
eval
{
if( defined( $base64 ) )
{
lib/Module/Generic.pm view on Meta::CPAN
);
my $params = {};
for( @options )
{
next unless( CORE::exists( $opts->{ $_ } ) );
$params->{ $_ } = $opts->{ $_ };
}
# try-catch
local $@;
my $serialised = eval
{
CBOR::Free::encode( $data, ( scalar( keys( %$params ) ) ? %$params : () ) );
};
if( $@ )
{
$self->__message( 104, "Error serialising data using $class: $@" );
return( $self->error( "Error trying to serialise data with $class: $@" ) );
}
$self->__message( 104, CORE::length( $serialised ), " bytes of serialised data was produced by $class" );
if( defined( $base64 ) )
{
$serialised = $base64->[0]->( $serialised );
$self->__message( 104, "Serialised data is in base64 and is now ", CORE::length( $serialised ), " bytes." );
}
if( exists( $opts->{file} ) && $opts->{file} )
{
$self->__message( 104, "A file was provided to unload serialised data -> '$opts->{file}'" );
my $f = $self->new_file( $opts->{file} ) || return( $self->pass_error );
my $cache_dir = $f->parent;
# $f->unload( $serialised, { binmode => 'raw' } ) || return( $self->pass_error( $f->error ) );
my $tmp = $self->new_tempfile(
( $cache_dir->can_write ? ( dir => $cache_dir ) : () ),
suffix => 'bin',
) || return( $self->pass_error( $f->error ) );
# Need to open the file to lock it.
$f->open( '>', { binmode => ':raw' } ) || return( $self->pass_error( $f->error ) );
$f->lock( exclusive => 1 ) || return( $self->pass_error( $f->error ) );
if( !$tmp->unload( $serialised, { binmode => 'raw' } ) )
{
$f->unlock;
$tmp->unlink if( $tmp->exists );
return( $self->pass_error( $f->error ) );
}
if( !$tmp->rename( $f, overwrite => 1 ) )
{
$f->unlock;
$tmp->unlink if( $tmp->exists );
return( $self->error( "Could not replace cache file '$f' with '$tmp': ", $tmp->error ) );
}
$f->unlock;
}
return( $serialised );
}
# NOTE: serialise with JSON
elsif( $class eq 'JSON' )
{
my @options = qw(
allow_blessed allow_nonref allow_unknown allow_tags ascii boolean_values
canonical convert_blessed filter_json_object filter_json_single_key_object
indent latin1 max_depth max_size pretty relaxed space_after space_before utf8
);
my $json = JSON->new;
for( @options )
{
next unless( CORE::exists( $opts->{ $_ } ) );
if( my $code = $json->can( $_ ) )
{
$code->( $json, $opts->{ $_ } );
}
}
# try-catch
local $@;
my $serialised = eval
{
$json->encode( $data );
};
if( $@ )
{
$self->__message( 104, "Error serialising data using $class: $@" );
return( $self->error( "Error trying to serialise data with $class: $@" ) );
}
$self->__message( 104, CORE::length( $serialised ), " bytes of serialised data was produced by $class" );
if( defined( $base64 ) )
{
$serialised = $base64->[0]->( $serialised );
$self->__message( 104, "Serialised data is in base64 and is now ", CORE::length( $serialised ), " bytes." );
}
if( exists( $opts->{file} ) && $opts->{file} )
{
$self->__message( 104, "A file was provided to unload serialised data -> '$opts->{file}'" );
my $f = $self->new_file( $opts->{file} ) || return( $self->pass_error );
my $cache_dir = $f->parent;
# $f->unload( $serialised, { binmode => 'raw' } ) || return( $self->pass_error( $f->error ) );
my $tmp = $self->new_tempfile(
( $cache_dir->can_write ? ( dir => $cache_dir ) : () ),
suffix => 'bin',
) || return( $self->pass_error( $f->error ) );
# Need to open the file to lock it.
$f->open( '>', { binmode => ':raw' } ) || return( $self->pass_error( $f->error ) );
$f->lock( exclusive => 1 ) || return( $self->pass_error( $f->error ) );
if( !$tmp->unload( $serialised, { binmode => 'raw' } ) )
{
$f->unlock;
$tmp->unlink if( $tmp->exists );
return( $self->pass_error( $f->error ) );
}
if( !$tmp->rename( $f, overwrite => 1 ) )
{
$f->unlock;
$tmp->unlink if( $tmp->exists );
return( $self->error( "Could not replace cache file '$f' with '$tmp': ", $tmp->error ) );
}
$f->unlock;
}
return( $serialised );
lib/Module/Generic.pm view on Meta::CPAN
=head2 serialise
This method use a specified serialiser class and serialise the given data either by returning it or by saving it directly to a given file.
The serialisers currently supported are: L<CBOR::Free>, L<CBOR::XS>, L<JSON>, L<Sereal> and L<Storable::Improved> (or the legacy version L<Storable>). They are not required by L<Module::Generic>, so you must install them yourself. If the serialiser c...
This method takes some data and an optional hash or hash reference of parameters. It can then:
=over 4
=item * save data directly to File
=item * save data to a file handle (only with L<Storable::Improved> / L<Storable>)
=item * Return the serialised data
=back
The supported parameters are:
=over 4
=item * C<append>
Boolean. If true, the serialised data will be appended to the given file. This works only in conjonction with I<file>
=item * C<base64>
Thise can be set to a true value like C<1>, or to your preferred base64 encoder/decoder, or to an array reference containing 2 code references, the first one for encoding and the second one for decoding.
If this is set simply to a true value, C<serialise> will call L</_has_base64> to find out any installed base64 modules. Currently the ones supported are: L<Crypt::Misc> and L<MIME::Base64>. Of course, you need to have one of those modules installed f...
If this option is set and no appropriate module could be found, C<serialise> will return an error.
=item * C<file>
String. A file path where to store the serialised data.
=item * C<io>
A file handle. This is used when the serialiser is L<Storable::Improved> / L<Storable> to call its function L<Storable::Improved/store_fd> and L<Storable::Improved/fd_retrieve>
=item * C<lock>
Boolean. If true, this will lock the file before writing to it. This works only in conjonction with I<file> and the serialiser L<Storable::Improved>
=item * C<serialiser> or C<serializer>
A string being the class of the serialiser to use. This can be only either L<Sereal> or L<Storable::Improved>
=back
Additionally the following options are supported and passed through directly for each serialiser:
=over 4
=item * L<CBOR::Free>: C<canonical>, C<string_encode_mode>, C<preserve_references>, C<scalar_references>
=item * L<CBOR|CBOR::XS>: C<max_depth>, C<max_size>, C<allow_unknown>, C<allow_sharing>, C<allow_cycles>, C<forbid_objects>, C<pack_strings>, C<text_keys>, C<text_strings>, C<validate_utf8>, C<filter>
=item * L<JSON>: C<allow_blessed> C<allow_nonref> C<allow_unknown> C<allow_tags> C<ascii> C<boolean_values> C<canonical> C<convert_blessed> C<filter_json_object> C<filter_json_single_key_object> C<indent> C<latin1> C<max_depth> C<max_size> C<pretty> ...
=item * L<Sereal::Decoder/encode> if the serialiser is L<Sereal>: C<aliased_dedupe_strings>, C<canonical>, C<canonical_refs>, C<compress>, C<compress_level>, C<compress_threshold>, C<croak_on_bless>, C<dedupe_strings>, C<freeze_callbacks>, C<max_recu...
=item * L<Storable::Improved> / L<Storable>: no option available
=back
If an error occurs, this sets an L<error|Module::Generic/error> and return C<undef>
=head2 serialize
Alias for L</serialise>
=head2 set
B<set>() sets object inner data type and takes arguments in a hash like fashion:
$obj->set( 'verbose' => 1, 'debug' => 0 );
=head2 subclasses
This is an on-demand private method, which means it only exist as a string, and dynamically loaded (via C<eval>) the first time it is called.
This reduces memory footprint when the method is not used.
Provided with a I<CLASS> value, this method try to guess all the existing sub classes of the provided I<CLASS>.
If I<CLASS> is not provided, the class into which was blessed the calling object will
be used instead.
It returns an array of subclasses in list context and a reference to an array of those
subclasses in scalar context.
If an error occured, undef is returned and an error is set accordingly. The latter can
be retrieved using the B<error> method.
=head2 true
Returns a C<true> variable from L<Module::Generic::Boolean>
=head2 false
Returns a C<false> variable from L<Module::Generic::Boolean>
=head2 verbose
Set or get the verbosity level with an integer.
=head2 will
This will try to find out if an object supports a given method call and returns the code reference to it or undef if none is found.
=head2 AUTOLOAD
The special B<AUTOLOAD>() routine is called by perl when no matching routine was found
in the module.
B<AUTOLOAD>() will then try hard to process the request.
For example, let's assue we have a routine B<foo>.
( run in 0.802 second using v1.01-cache-2.11-cpan-0b58ddf2af1 )