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
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>.
It will first, check if an equivalent entry of the routine name that was called exist in
the hash reference of the object. If there is and that more than one argument were
passed to this non existing routine, those arguments will be stored as a reference to an
array as a value of the key in the object. Otherwise the single argument will simply be stored
( run in 1.655 second using v1.01-cache-2.11-cpan-5b529ec07f3 )