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} = '';
# $self->__message( 6, "Are we running under threads, switching to shared data ? ", ( $rv ? 'yes' : 'no' ) );
$self->__message( 106, "Are we running under threads, switching to shared data ? ", ( HAS_THREADS ? 'yes' : 'no' ) );
my $repo = Module::Generic::Global->new( 'errors' => $class, key => $err_key ) ||
die( Module::Generic::Global->error );
$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} ) ) &&
lib/Module/Generic.pm view on Meta::CPAN
my $hash_str = Data::Dump::dump( $this_def );
CORE::push( @$code_lines, "sub ${f} { return( shift->${func}( '${f}', ${hash_str}, \@_ ) ); }" );
}
else
{
CORE::push( @$code_lines, "sub ${f} { return( shift->${func}( '${f}', \@_ ) ); }" );
}
}
CORE::push( @$code_lines, "sub _fields { return( shift->_set_get_array_as_object( '_fields', \@_ ) ); }" );
$perl .= join( "\n\n", @$code_lines );
$perl .= <<'EOT';
# NOTE: For CBOR and Sereal
sub FREEZE
{
my $self = CORE::shift( @_ );
my $serialiser = CORE::shift( @_ ) // '';
my $class = CORE::ref( $self );
my @props = grep( /^\w+/, keys( %$self ) );
my $hash = {};
foreach my $prop ( @props )
{
if( CORE::exists( $self->{ $prop } ) &&
defined( $self->{ $prop } ) &&
CORE::ref( $self->{ $prop } ) ne 'CODE' )
{
$hash->{ $prop } = $self->{ $prop };
}
}
# 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.
if( $serialiser eq 'Sereal' )
{
require Sereal::Encoder;
require version;
if( version->parse( Sereal::Encoder->VERSION ) <= version->parse( '4.023' ) )
{
CORE::return( [$class, $hash] );
}
}
# But Storable wants a list with the first element being the serialised element
CORE::return( $class, $hash );
}
sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }
sub STORABLE_thaw { return( shift->THAW( @_ ) ); }
sub STORABLE_thaw_post_processing
{
my $obj = shift( @_ );
my @keys = %$obj;
my $class = ref( $obj );
my $hash = {};
@$hash{ @keys } = @$obj{ @keys };
my $self = bless( $hash => $class );
return( $self );
}
sub THAW
{
# 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 );
}
EOT
$perl .= <<EOT;
sub TO_JSON { return( shift->as_hash ); }
1;
EOT
$self->__message( 112, "Evaluating code -> $perl" );
local $@;
my $rc = eval( $perl );
die( "Unable to dynamically create module $class: $@" ) if( $@ );
}
return( $class );
}
PERL
# NOTE: _can_overload
_can_overload => <<'PERL',
sub _can_overload
{
my $self = shift( @_ );
no overloading;
# Nothing provided
return if( !scalar( @_ ) );
return if( !defined( $_[0] ) );
return if( !Scalar::Util::blessed( $_[0] ) );
if( $self->_is_array( $_[1] ) )
{
foreach my $op ( @{$_[1]} )
{
return(0) unless( overload::Method( $_[0] => $op ) );
}
return(1);
}
else
{
return( overload::Method( $_[0] => $_[1] ) );
}
}
PERL
# NOTE: _get_args_as_array
_get_args_as_array => <<'PERL',
# NOTE: sub _get_args_as_array() is now a XS method
sub _get_args_as_array
{
my $self = shift( @_ );
return( [] ) if( !scalar( @_ ) );
my $ref = [];
if( scalar( @_ ) == 1 && $self->_is_array( $_[0] ) )
{
$ref = shift( @_ );
}
else
{
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_array()
_is_array => <<'PERL',
# NOTE: sub _is_array() is now a XS method
sub _is_array
{
return(0) if( scalar( @_ ) < 2 );
return(0) if( !defined( $_[1] ) );
my $type = Scalar::Util::reftype( $_[1] );
return(0) if( !defined( $type ) );
return( $type eq 'ARRAY' );
}
PERL
# NOTE: _is_code()
_is_code => <<'PERL',
# NOTE: sub _is_code() is now a XS method
sub _is_code
{
return(0) if( scalar( @_ ) < 2 );
return(0) if( !defined( $_[1] ) );
my $type = Scalar::Util::reftype( $_[1] );
return(0) if( !defined( $type ) );
return( $type eq 'CODE' );
}
PERL
# NOTE: _is_empty()
_is_empty => <<'PERL',
sub _is_empty
{
lib/Module/Generic.pm view on Meta::CPAN
# UNC share: \\Server\Share\... (also allow IPv6 host literal \\[fe80::1]\Share)
state $unc_share_re = qr{^\\\\(?:\[[0-9A-Fa-f:]+\]|[^\\\/]+)[\\\/][^\\\/]+};
return(1) if( $_[0] =~ /$unc_share_re/ );
# Unix absolute: /usr/... (including root "/")
# NOTE: Hmmm, not sure about that one. This could lead easily to false positive.
# return(1) if( $_[0] =~ m{^/} );
# Home expansion: ~/something or ~user/something
state $home_expansion_re = qr{^~(?:[A-Za-z0-9._\-]+)?[\\\/]};
return(1) if( $_[0] =~ m{$home_expansion_re} );
# Relative: ./foo, ../bar, .\foo, ..\bar
state $relative_path_re = qr{^\.(?:\.|)[\\\/]};
return(1) if( $_[0] =~ m{$relative_path_re} );
# Env-based: $HOME/foo, %USERPROFILE%\foo
# NOTE: This is actually too hazardous
# return(1) if( $_[0] =~ m{^\$[A-Za-z_]\w*[\\\/]} || $_[0] =~ m{^%[A-Za-z_]\w*%[\\\/]} );
# Lower confidence (needs a separator):
state $separator_re = qr{[\\\/]};
if( $_[0] =~ m{$separator_re} )
{
# Disallow Windows-invalid chars
state $windows_invalid_char_re = qr{[<>\"|?*]};
return(0) if( $_[0] =~ m{$windows_invalid_char_re} );
# No empty trailing segment of spaces
state $no_trailing_space = qr{(?:^|[\\\/])\s*$};
return(0) if( $_[0] =~ m{$no_trailing_space} );
return(1);
}
# Lone filename heuristics (last resort):
# Useful when the *field name* hints it's a file/path and value is just "config.json".
# We keep it conservative: require an extension of up to 4 characters; avoid leading/trailing spaces.
state $lone_filename_re = qr{^[^\s.][^\s]*\.[A-Za-z0-9]{1,4}$};
return(1) if( $_[0] =~ /$lone_filename_re/ );
return(0);
}
PERL
# NOTE: _obj2h()
_obj2h => <<'PERL',
# NOTE: sub _obj2h() is now a XS method
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( {} );
}
}
PERL
# NOTE: _on_error()
_on_error => <<'PERL',
sub _on_error { return( shift->_set_get_code( '_on_error', @_ ) ); }
PERL
# NOTE: _parse_timestamp()
_parse_timestamp => <<'PERL',
# Ref:
# <https://en.wikipedia.org/wiki/Date_format_by_country>
sub _parse_timestamp
{
my $self = shift( @_ );
my $str = shift( @_ );
# No value was actually provided
return if( !length( $str ) );
my $params = $self->_get_args_as_hash( @_ );
$str = "$str";
my $this = $self->_obj2h;
my $class = ref( $self ) || $self;
# Load the regular expressions
$self->_get_datetime_regexp;
$self->_load_class( 'DateTime::Format::Lite' ) || return( $self->pass_error );
# We set this has a distinctive key across all process and threads since this value is ubiquitous
my $repo = Module::Generic::Global->new( 'globals' => $class, key => 'has_local_tz' );
my $HAS_LOCAL_TZ = $repo->get;
my $tz;
# "Cannot determine local time zone"
if( !defined( $HAS_LOCAL_TZ ) )
{
$self->_load_class( 'DateTime::Lite::TimeZone' ) || return( $self->pass_error );
$repo->lock;
# try-catch
local $@;
eval
{
$tz = DateTime::Lite::TimeZone->new( name => 'local' );
lib/Module/Generic.pm view on Meta::CPAN
# 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
if( $serialiser eq 'Sereal' )
{
require Sereal::Encoder;
require version;
if( version->parse( Sereal::Encoder->VERSION ) <= version->parse( '4.023' ) )
{
CORE::return( [$class, \%hash] );
}
}
# 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 );
}
sub VERBOSE
{
my $self = shift( @_ );
my $pkg = ref( $self ) || $self;
my $this = $self->_obj2h;
no strict 'refs';
return( ${ $pkg . '::VERBOSE' } );
}
{
# Credits to the module Sentinel for the idea of using a tied scalar.
# NOTE: Module::Generic::LvalueGuard
package
Module::Generic::LvalueGuard;
use strict;
use warnings;
use vars qw( $LOCK );
use Config;
use Scalar::Util;
use Storable::Improved qw( freeze thaw );
use constant CAN_THREADS => $Config{useithreads};
sub HAS_THREADS { return( $Config{useithreads} && $INC{'threads.pm'} ); };
sub IN_THREAD { return( $Config{useithreads} && $INC{'threads.pm'} && threads->tid != 0 ); };
if( HAS_THREADS )
{
require threads;
require threads::shared;
threads->import();
threads::shared->import();
my $lock :shared;
$LOCK = \$lock;
}
sub TIESCALAR
{
my( $class, %args ) = @_;
if( defined( $args{obj} ) )
{
if( !Scalar::Util::blessed( $args{obj} ) )
{
die( "The object provided (", overload::StrVal( $args{obj} // 'undef' ), ") is not a class object." );
}
elsif( IN_THREAD )
{
$args{obj} = freeze( $args{obj} );
}
}
my $self = bless({
value => $args{value}, # Current value
get => $args{get}, # Getter callback
set => $args{set}, # Setter callback
obj => $args{obj}, # Optional object associated
}, $class );
return( $self );
}
( run in 0.640 second using v1.01-cache-2.11-cpan-39bf76dae61 )