BEGIN
{
use
vars
qw( $VERSION $DEBUG )
;
our
$DEBUG
= 0;
our
$VERSION
=
'v1.2.4'
;
};
no
warnings
'redefine'
;
sub
new
{
my
$this
=
shift
(
@_
);
my
$class
=
ref
(
$this
) ||
$this
;
my
$self
=
bless
( {} =>
$class
);
my
$data
=
$self
->{_data} = {};
$self
->{_data_repo} =
'_data'
;
my
$hash
= {};
@_
= ()
if
(
scalar
(
@_
) == 1 && !
defined
(
$_
[0] ) );
if
(
scalar
(
@_
) == 1 && ( Scalar::Util::reftype(
$_
[0] ) //
''
) eq
'HASH'
)
{
$hash
=
shift
(
@_
);
$self
->{debug} =
$DEBUG
if
(
$DEBUG
&& !CORE::
exists
(
$hash
->{debug} ) );
}
elsif
(
@_
)
{
CORE::
warn
(
"Parameter provided is not an hash reference: '"
,
join
(
"', '"
,
@_
),
"'\n"
)
if
(
$this
->_warnings_is_enabled );
}
my
$make_class
=
sub
{
my
$k
=
shift
(
@_
);
my
$new_class
=
$k
;
$new_class
=~
tr
/-/_/;
$new_class
=~ s/\_{2,}/_/g;
$new_class
=
join
(
''
,
map
(
ucfirst
(
lc
(
$_
) ),
split
( /\_/,
$new_class
) ) );
$new_class
=
"${class}\::${new_class}"
;
my
$clean_field
=
$k
;
$clean_field
=~
tr
/-/_/;
$clean_field
=~ s/\_{2,}/_/g;
$clean_field
=~ s/[^a-zA-Z0-9\_]+//g;
$clean_field
=~ s/^\d+//g;
my
$perl
=
<<EOT;
package $new_class;
BEGIN
{
use strict;
use Module::Generic;
use parent -norequire, qw( Module::Generic::Dynamic );
};
1;
EOT
local
$@;
my
$rc
=
eval
(
$perl
);
die
(
"Unable to dynamically create module $new_class: $@"
)
if
( $@ );
return
(
$new_class
,
$clean_field
);
};
local
$@;
foreach
my
$k
(
sort
(
keys
(
%$hash
) ) )
{
if
(
ref
(
$hash
->{
$k
} ) eq
'HASH'
)
{
my
(
$new_class
,
$clean_field
) =
$make_class
->(
$k
);
next
unless
(
length
(
$clean_field
) );
eval
(
"sub ${new_class}::${clean_field} { return( shift->_set_get_object( '$clean_field', '$new_class', \@_ ) ); }"
);
die
( $@ )
if
( $@ );
my
$rv
=
$self
->
$clean_field
(
$hash
->{
$k
} );
return
(
$self
->pass_error )
if
( !
defined
(
$rv
) &&
$self
->error );
}
elsif
(
$self
->_is_array(
$hash
->{
$k
} ) )
{
my
(
$new_class
,
$clean_field
) =
$make_class
->(
$k
);
my
$mode
=
lc
(
scalar
( @{
$hash
->{
$k
}} ) ?
ref
(
$hash
->{
$k
}->[0] ) :
''
);
if
(
$mode
eq
'hash'
)
{
my
$all
= [];
foreach
my
$this
( @{
$hash
->{
$k
}} )
{
my
$o
=
$this
->{_looping} ?
$this
->{_looping} :
$new_class
->new(
$this
);
$this
->{_looping} =
$o
;
CORE::
push
(
@$all
,
$o
);
}
eval
(
"sub ${new_class}::${clean_field} { return( shift->_set_get_object_array_object( '$clean_field', '$new_class', \@_ ) ); }"
);
}
else
{
eval
(
"sub ${new_class}::${clean_field} { return( shift->_set_get_array_as_object( '$clean_field', \@_ ) ); }"
);
}
die
( $@ )
if
( $@ );
my
$rv
=
$self
->
$clean_field
(
$hash
->{
$k
} );
return
(
$self
->pass_error )
if
( !
defined
(
$rv
) &&
$self
->error );
}
elsif
( !
ref
(
$hash
->{
$k
} ) )
{
my
$clean_field
=
$k
;
$clean_field
=~
tr
/-/_/;
$clean_field
=~ s/\_{2,}/_/g;
$clean_field
=~ s/[^a-zA-Z0-9\_]+//g;
$clean_field
=~ s/^\d+//g;
next
unless
(
length
(
$clean_field
) );
my
$func_name
=
'_set_get_scalar_as_object'
;
if
(
$clean_field
=~ /(^|\b)date|datetime($|\b)/ )
{
$func_name
=
'_set_get_datetime'
;
}
elsif
(
$clean_field
=~ /(^|\b)(uri|url)($|\b)/ ||
$hash
->{
$k
} =~ /^https?\:\/{2}/ )
{
$func_name
=
'_set_get_uri'
;
}
eval
(
"sub ${class}::${clean_field} { return( shift->${func_name}( '$clean_field', \@_ ) ); }"
);
my
$rv
=
$self
->
$clean_field
(
$hash
->{
$k
} );
return
(
$self
->pass_error )
if
( !
defined
(
$rv
) &&
$self
->error );
}
else
{
my
$clean_field
=
$k
;
$clean_field
=~
tr
/-/_/;
$clean_field
=~ s/\_{2,}/_/g;
$clean_field
=~ s/[^a-zA-Z0-9\_]+//g;
$clean_field
=~ s/^\d+//g;
my
$rv
=
$self
->
$clean_field
(
$hash
->{
$k
} );
return
(
$self
->pass_error )
if
( !
defined
(
$rv
) &&
$self
->error );
}
}
return
(
$self
);
}
sub
FREEZE
{
my
$self
= CORE::
shift
(
@_
);
my
$serialiser
= CORE::
shift
(
@_
) //
''
;
my
$class
= CORE::
ref
(
$self
);
my
%hash
=
%$self
;
CORE::
return
( [
$class
, \
%hash
] )
if
(
$serialiser
eq
'Sereal'
&& Sereal::Encoder->VERSION <= version->parse(
'4.023'
) );
CORE::
return
(
$class
, \
%hash
);
}
sub
STORABLE_freeze { CORE::
return
( CORE::
shift
->FREEZE(
@_
) ); }
sub
STORABLE_thaw { CORE::
return
( CORE::
shift
->THAW(
@_
) ); }
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
$new
;
if
( CORE::
ref
(
$self
) )
{
foreach
( CORE::
keys
(
%$hash
) )
{
$self
->{
$_
} = CORE::
delete
(
$hash
->{
$_
} );
}
$new
=
$self
;
}
else
{
$new
= CORE::
bless
(
$hash
=>
$class
);
}
CORE::
return
(
$new
);
}
sub
TO_JSON
{
my
$self
= CORE::
shift
(
@_
);
my
$ref
= {
%$self
};
CORE::
delete
(
$ref
->{_data} );
CORE::
delete
(
$ref
->{_data_repo} );
CORE::
return
(
$ref
);
}
sub
AUTOLOAD
{
my
(
$method
) =
our
$AUTOLOAD
=~ /([^:]+)$/;
no
overloading;
my
$self
=
shift
(
@_
);
my
@args
=
@_
;
my
$class
=
ref
(
$self
) ||
$self
;
my
$code
;
if
(
$code
=
$self
->can(
$method
) )
{
return
(
$code
->(
@args
) );
}
else
{
my
$ref
=
lc
(
ref
(
$_
[0] ) );
my
$handler
= (
$ref
eq
'scalar'
|| !
$ref
) ?
'_set_get_scalar_as_object'
:
'_set_get_scalar'
;
if
(
$ref
eq
'hash'
||
$ref
eq
'array'
)
{
$handler
=
"_set_get_${ref}_as_object"
;
}
elsif
(
$ref
eq
'json::pp::boolean'
||
$ref
eq
'module::generic::boolean'
||
(
$ref
eq
'scalar'
&& (
$$ref
== 1 ||
$$ref
== 0 ) ) )
{
$handler
=
'_set_get_boolean'
;
}
elsif
(
$ref
eq
'regexp'
)
{
$handler
=
'_set_get_scalar'
;
}
elsif
( !
$ref
&&
$method
=~ /(?<=[^a-zA-Z0-9])(date|datetime)(?!>[^a-zA-Z0-9])/ )
{
$handler
=
'_set_get_datetime'
;
}
elsif
( !
$ref
&& (
$method
=~ /(?<=[^a-zA-Z0-9])(uri|url)(?!>[^a-zA-Z0-9])/ ||
$_
[0] =~ /^https?\:\/{2}/ ) )
{
$handler
=
'_set_get_uri'
;
}
elsif
( !
$ref
&&
$_
[0] =~ /^[a-fA-F0-9]{8}\-[a-fA-F0-9]{4}\-[a-fA-F0-9]{4}\-[a-fA-F0-9]{4}\-[a-fA-F0-9]{12}$/ )
{
$handler
=
'_set_get_uuid'
;
}
eval
(
"sub ${class}::${method} { return( shift->$handler( '$method', \@_ ) ); }"
);
die
( $@ )
if
( $@ );
return
(
$self
->
$method
(
@args
) );
}
};
1;