BEGIN
{
use
vars
qw( $DEBUG $ERROR $ERRORS )
;
'""'
=>
'as_string'
,
'.='
=>
sub
{
my
(
$self
,
$other
,
$swap
) =
@_
;
no
warnings
'uninitialized'
;
if
( !CORE::
defined
(
$$self
) )
{
return
(
$other
);
}
elsif
( !CORE::
defined
(
$other
) )
{
return
(
$$self
);
}
my
$expr
;
if
(
$swap
)
{
$expr
=
"\$other .= \$$self"
;
return
(
$other
);
}
else
{
$$self
.=
$other
;
return
(
$self
);
}
},
'x'
=>
sub
{
my
(
$self
,
$other
,
$swap
) =
@_
;
no
warnings
'uninitialized'
;
my
$expr
=
$swap
?
"\"$other"
x \
"$$self\""
:
"\"$$self\" x \"$other\""
;
local
$@;
my
$res
=
eval
(
$expr
);
if
( $@ )
{
CORE::
warn
( $@ );
return
;
}
return
(
$self
->new(
$res
) );
},
'eq'
=>
sub
{
my
(
$self
,
$other
,
$swap
) =
@_
;
no
warnings
'uninitialized'
;
if
( Scalar::Util::blessed(
$other
) &&
ref
(
$other
) eq
ref
(
$self
) )
{
return
(
$$self
eq
$$other
);
}
else
{
return
(
$$self
eq
"$other"
);
}
},
fallback
=> 1,
);
$DEBUG
= 0;
$ERRORS
= {};
our
$VERSION
=
'v1.3.4'
;
};
no
warnings
'redefine'
;
sub
new
{
my
$this
=
shift
(
@_
);
my
$class
=
ref
(
$this
) ||
$this
;
my
$init
=
''
;
if
(
ref
(
$_
[0] ) eq
'SCALAR'
|| UNIVERSAL::isa(
$_
[0],
'SCALAR'
) )
{
$init
= ${
$_
[0]};
}
elsif
(
ref
(
$_
[0] ) eq
'ARRAY'
|| UNIVERSAL::isa(
$_
[0],
'ARRAY'
) )
{
$init
= CORE::
join
(
''
, @{
$_
[0]} );
}
elsif
(
ref
(
$_
[0] ) )
{
return
(
$this
->error(
"I do not know what to do with \""
, overload::StrVal(
$_
[0] ),
"\". ${class} only suport string, scalar reference or array reference."
) );
}
elsif
(
@_
)
{
$init
=
$_
[0];
}
else
{
$init
=
undef
();
}
return
(
bless
( \
$init
=> (
ref
(
$this
) ||
$this
) ) );
}
sub
append { ${
$_
[0]} .= ( ( Scalar::Util::reftype(
$_
[1] ) //
''
) eq
'SCALAR'
? ${
$_
[1]} :
$_
[1] );
return
(
$_
[0] ); }
sub
as_array {
return
( Module::Generic::Array->new( [ ${
$_
[0]} ] ) ); }
sub
as_boolean {
return
( Module::Generic::Boolean->new( ${
$_
[0]} ? 1 : 0 ) ); }
sub
as_number {
return
(
$_
[0]->_number( ${
$_
[0]} ) ); }
sub
as_string {
return
( ${
$_
[0]} ); }
sub
callback
{
my
$self
= CORE::
shift
(
@_
);
my
(
$what
,
$code
) =
@_
;
if
( !
defined
(
$what
) )
{
return
(
$self
->error(
"No callback type was provided."
) );
}
elsif
(
$what
ne
'add'
&&
$what
ne
'remove'
)
{
return
(
$self
->error(
"Callback type provided ($what) is unsupported. Use 'add' or 'remove'."
) );
}
elsif
(
scalar
(
@_
) == 1 )
{
return
(
$self
->error(
"No callback code was provided. Provide an anonymous subroutine, or reference to existing subroutine."
) );
}
elsif
(
defined
(
$code
) &&
ref
(
$code
) ne
'CODE'
)
{
return
(
$self
->error(
"Callback provided is not a code reference. Provide an anonymous subroutine, or reference to existing subroutine."
) );
}
if
( !
defined
(
$code
) )
{
if
(
scalar
(
@_
) >= 2 )
{
my
$tie
=
tied
(
$$self
);
return
(1)
if
( !
$tie
);
my
$rv
=
$tie
->unset_callback(
$what
);
if
( !
$tie
->has_callback )
{
undef
(
$tie
);
untie
(
$$self
);
}
return
(
$rv
);
}
else
{
my
$tie
=
tied
(
$$self
);
return
if
( !
$tie
);
return
(
$tie
->get_callback(
$what
) );
}
}
else
{
my
$tie
=
tied
(
$$self
);
if
( !
$tie
)
{
$tie
=
tie
(
$$self
=>
'Module::Generic::Scalar::Tie'
,
{
data
=>
$self
,
debug
=>
$DEBUG
,
$what
=>
$code
,
}) ||
return
;
return
(1);
}
$tie
->set_callback(
$what
=>
$code
) ||
return
;
return
(1);
}
}
sub
capitalise
{
my
$self
= CORE::
shift
(
@_
);
my
@small_words
=
qw( (?<!q&)
a an and as at(?!
&t
) but by en
for
if
in of on or the to v[.]? via vs[.]? );
my
$small_re
= CORE::
join
(
'|'
,
@small_words
);
my
$apos
=
qr/ (?: ['’] [[:lower:]]* )? /
x;
my
$copy
=
$$self
;
return
(
$self
->_new(
$copy
) )
if
( !CORE::
defined
(
$copy
) );
$copy
=~ s{\A\s+}{};
$copy
=~ s{\s+\z}{};
$copy
= CORE::
lc
(
$copy
)
if
(
$copy
!~ /[[:lower:]]/ );
$copy
=~ s{
\b (_*) (?:
( (?<=[ ][/\\]) [[:alpha:]]+ [-_[:alpha:]/\\]+ |
[-_[:alpha:]]+ [@.:] [-_[:alpha:]@.:/]+
$apos
)
|
( (?i:
$small_re
)
$apos
)
|
( [[:alpha:]] [[:lower:]'’()\[\]{}]*
$apos
)
|
( [[:alpha:]] [[:alpha:]'’()\[\]{}]*
$apos
)
) (_*) \b
}{
$1 . (
defined
$2 ? $2
:
defined
$3 ?
"\L$3"
:
defined
$4 ?
"\u\L$4"
: $5
) . $6
}xeg;
$copy
=~ s{
( \A [[:punct:]]*
| [:.;?!][ ]+
| [ ]['"“‘(\[][ ]* )
(
$small_re
) \b
}{$1\u\L$2}xig;
$copy
=~ s{
\b (
$small_re
)
(?= [[:punct:]]* \Z
| ['"’”)\]] [ ] )
}{\u\L$1}xig;
$copy
=~ s{
\b
(?<! -)
(
$small_re
)
(?= -[[:alpha:]]+)
}{\u\L$1}xig;
$copy
=~ s{
\b
(?<!…)
( [[:alpha:]]+- )
(
$small_re
)
(?! - )
}{$1\u$2}xig;
return
(
$self
->_new(
$copy
) );
}
sub
chomp
{
no
warnings
'uninitialized'
;
return
( CORE::
chomp
( ${
$_
[0]} ) ); }
sub
chop
{
no
warnings
'uninitialized'
;
return
( CORE::
chop
( ${
$_
[0]} ) ); }
sub
clone
{
my
$self
=
shift
(
@_
);
if
(
@_
)
{
return
(
$self
->_new(
@_
) );
}
else
{
return
(
$self
->_new( ${
$self
} ) );
}
}
sub
crypt
{
return
( __PACKAGE__->_new( CORE::
crypt
( ${
$_
[0]},
$_
[1] ) ) ); }
sub
defined
{
return
( CORE::
defined
( ${
$_
[0]} ) ); }
sub
empty {
return
(
shift
->
reset
(
@_
) ); }
sub
error
{
my
$self
= CORE::
shift
(
@_
);
my
$addr
= Scalar::Util::refaddr(
$self
) ||
$self
;
my
$class
=
ref
(
$self
) ||
$self
;
my
$o
;
no
strict
'refs'
;
if
(
@_
)
{
my
$args
= {};
if
( ( Scalar::Util::blessed(
$_
[0] ) &&
$_
[0]->isa(
'Module::Generic::Exception'
) ) ||
Scalar::Util::blessed(
$_
[0] ) )
{
$o
= CORE::
shift
(
@_
);
}
elsif
(
ref
(
$_
[0] ) eq
'HASH'
)
{
$args
= CORE::
shift
(
@_
);
}
else
{
$args
->{message} = CORE::
join
(
''
, CORE::
map
(
ref
(
$_
) eq
'CODE'
?
$_
->() :
$_
,
@_
) );
}
$args
->{class} //=
''
;
my
$ex_class
= CORE::
length
(
$args
->{class} )
?
$args
->{class}
: (
defined
( ${
"${class}\::EXCEPTION_CLASS"
} ) && CORE::
length
( ${
"${class}\::EXCEPTION_CLASS"
} ) )
? ${
"${class}\::EXCEPTION_CLASS"
}
:
'Module::Generic::Exception'
;
unless
( CORE::
scalar
( CORE::
keys
( %{
"${ex_class}\::"
} ) ) )
{
my
$pl
=
"use $ex_class;"
;
local
$SIG
{__DIE__} =
sub
{};
local
$@;
eval
(
$pl
);
die
(
"${class}\::error() is unable to load exception class \"$ex_class\": $@"
)
if
( $@ );
}
$o
=
$ERRORS
->{
$addr
} =
$ERROR
=
$ex_class
->new(
$args
);
local
$@;
my
$enc_str
=
eval
{
Encode::encode(
'UTF-8'
,
"$o"
, Encode::FB_CROAK );
};
warn
( $@ ?
$o
:
$enc_str
)
if
(
$self
->_warnings_is_enabled );
if
( !
$args
->{no_return_null_object} && want(
'OBJECT'
) )
{
my
$null
= Module::Generic::Null->new(
$o
, {
debug
=>
$DEBUG
,
has_error
=> 1 });
rreturn(
$null
);
}
return
;
}
if
( !
$ERRORS
->{
$addr
} && want(
'OBJECT'
) )
{
my
$null
= Module::Generic::Null->new(
$o
, {
debug
=>
$DEBUG
,
wants
=>
'object'
});
rreturn(
$null
);
}
return
(
$ERRORS
->{
$addr
} );
}
sub
fc {
return
( CORE::fc( ${
$_
[0]} ) eq CORE::fc(
$_
[1] ) ); }
sub
hex
{
return
(
$_
[0]->_number( CORE::
hex
( ${
$_
[0]} ) ) ); }
sub
index
{
my
$self
=
shift
(
@_
);
my
(
$substr
,
$pos
) =
@_
;
return
(
$self
->_number( CORE::
index
( ${
$self
},
$substr
,
$pos
) ) )
if
( CORE::
defined
(
$pos
) );
return
(
$self
->_number( CORE::
index
( ${
$self
},
$substr
) ) );
}
sub
is_alpha {
return
( CORE::
defined
( ${
$_
[0]} ) && ${
$_
[0]} =~ /^[[:alpha:]]+$/ ); }
sub
is_alpha_numeric {
return
( CORE::
defined
( ${
$_
[0]} ) && ${
$_
[0]} =~ /^[[:alnum:]]+$/ ); }
sub
is_empty {
return
( CORE::
length
( ${
$_
[0]} //
''
) == 0 ); }
sub
is_lower {
return
( CORE::
defined
( ${
$_
[0]} ) && ${
$_
[0]} =~ /^[[:lower:]]+$/ ); }
sub
is_numeric {
return
( Scalar::Util::looks_like_number( ${
$_
[0]} ) ); }
sub
is_upper {
return
( CORE::
defined
( ${
$_
[0]} ) && ${
$_
[0]} =~ /^[[:upper:]]+$/ ); }
sub
join
{
return
( __PACKAGE__->new( CORE::
join
( CORE::
splice
(
@_
, 1, 1 ), ${
shift
(
@_
) },
@_
) ) ); }
sub
lc
{
no
warnings
'uninitialized'
;
return
( __PACKAGE__->_new( CORE::
lc
( ${
$_
[0]} ) ) ); }
sub
lcfirst
{
no
warnings
'uninitialized'
;
return
( __PACKAGE__->_new( CORE::
lcfirst
( ${
$_
[0]} ) ) ); }
sub
left {
no
warnings
'uninitialized'
;
return
(
$_
[0]->_new( CORE::
substr
( ${
$_
[0]}, 0, CORE::
int
(
$_
[1] ) ) ) ); }
sub
length
{
no
warnings
'uninitialized'
;
return
(
$_
[0]->_number( CORE::
length
( ${
$_
[0]} ) ) ); }
sub
like
{
my
$self
=
shift
(
@_
);
my
$str
=
shift
(
@_
);
my
@matches
= ();
my
@rv
= ();
no
warnings
'uninitialized'
;
$str
= CORE::
defined
(
$str
)
? (
ref
(
$str
) eq
'Regexp'
||
ref
(
$str
) eq
'Regexp::Common'
)
?
$str
:
qr/(?:\Q$str\E)+/
:
qr/[[:blank:]\r\n]*/
;
@rv
=
$$self
=~ /
$str
/;
if
(
scalar
( @{^CAPTURE} ) )
{
for
(
my
$i
= 0;
$i
<
scalar
( @{^CAPTURE} );
$i
++ )
{
push
(
@matches
, ${^CAPTURE}[
$i
] );
}
}
my
$names
= { %+ };
unless
( want(
'OBJECT'
) || want(
'SCALAR'
) || want(
'LIST'
) ||
scalar
(
@matches
) )
{
return
(0);
}
return
( Module::Generic::RegexpCapture->new(
result
=> \
@rv
,
capture
=> \
@matches
,
name
=>
$names
) );
}
sub
lower {
return
(
shift
->
lc
); }
sub
ltrim
{
my
$self
=
shift
(
@_
);
my
$str
=
shift
(
@_
);
no
warnings
'uninitialized'
;
$str
= CORE::
defined
(
$str
)
? (
ref
(
$str
) eq
'Regexp'
||
ref
(
$str
) eq
'Regexp::Common'
)
?
$str
:
qr/(?:\Q$str\E)+/
:
qr/[[:blank:]\r\n]*/
;
$$self
=~ s/^
$str
//g;
return
(
$self
);
}
sub
match
{
my
(
$self
,
$re
) =
@_
;
my
@matches
= ();
my
@rv
= ();
no
warnings
'uninitialized'
;
$re
= CORE::
defined
(
$re
)
? (
ref
(
$re
) eq
'Regexp'
||
ref
(
$re
) eq
'Regexp::Common'
)
?
$re
:
qr/(?:\Q$re\E)+/
:
$re
;
@rv
=
$$self
=~ /
$re
/;
if
(
scalar
( @{^CAPTURE} ) )
{
for
(
my
$i
= 0;
$i
<
scalar
( @{^CAPTURE} );
$i
++ )
{
push
(
@matches
, ${^CAPTURE}[
$i
] );
}
}
my
$names
= { %+ };
unless
( want(
'OBJECT'
) || want(
'SCALAR'
) || want(
'LIST'
) ||
scalar
(
@matches
) )
{
return
(0);
}
return
( Module::Generic::RegexpCapture->new(
result
=> \
@rv
,
capture
=> \
@matches
,
name
=>
$names
) );
}
sub
object {
return
(
$_
[0] ); }
sub
open
{
my
$self
=
shift
(
@_
);
my
$io
= Module::Generic::Scalar::IO->new(
$self
,
@_
) ||
return
(
$self
->pass_error( Module::Generic::Scalar::IO->error ) );
return
(
$io
);
}
sub
ord
{
return
(
$_
[0]->_number( CORE::
ord
( ${
$_
[0]} ) ) ); }
sub
pack
{
return
( __PACKAGE__->_new( CORE::
pack
(
$_
[1], ${
$_
[0]} ) ) ); }
sub
pad
{
my
$self
=
shift
(
@_
);
my
(
$n
,
$str
) =
@_
;
$str
//=
' '
;
if
( !CORE::
length
(
$n
) )
{
warn
(
"No number provided to pad the string object.\n"
)
if
(
$self
->_warnings_is_enabled );
}
elsif
(
$n
!~ /^\-?\d+$/ )
{
warn
(
"Number provided \"$n\" to pad string is not an integer.\n"
)
if
(
$self
->_warnings_is_enabled );
}
if
(
$n
< 0 )
{
$$self
.= (
"$str"
x CORE::
abs
(
$n
) );
}
else
{
CORE::
substr
(
$$self
, 0, 0 ) = (
"$str"
x
$n
);
}
return
(
$self
);
}
sub
pass_error
{
my
$self
= CORE::
shift
(
@_
);
my
$addr
= Scalar::Util::refaddr(
$self
) ||
$self
;
my
$opts
= {};
my
$err
;
my
$class
;
no
strict
'refs'
;
if
(
scalar
(
@_
) )
{
if
( CORE::
scalar
(
@_
) == 1 &&
ref
(
$_
[0] ) eq
'HASH'
)
{
$opts
=
$_
[0];
}
else
{
if
( CORE::
scalar
(
@_
) > 1 &&
ref
(
$_
[-1] ) eq
'HASH'
)
{
$opts
= CORE::
pop
(
@_
);
}
$err
=
$_
[0];
}
}
$class
= CORE::
delete
(
$opts
->{class} )
if
( CORE::
scalar
( CORE::
keys
(
%$opts
) ) == 1 && [CORE::
keys
(
%$opts
)]->[0] eq
'class'
);
if
( !CORE::
defined
(
$err
) && ( !CORE::
scalar
(
@_
) || CORE::
defined
(
$class
) ) )
{
if
( !CORE::
defined
(
$ERRORS
->{
$addr
} ) )
{
warnings::warnif(
"No error object provided and no previous error set either! It seems the previous method call returned a simple undef\n"
);
}
else
{
$err
= ( CORE::
defined
(
$class
) ?
bless
(
$ERRORS
->{
$addr
} =>
$class
) :
$ERRORS
->{
$addr
} );
}
}
elsif
( CORE::
defined
(
$err
) &&
Scalar::Util::blessed(
$err
) &&
( CORE::
scalar
(
@_
) == 1 ||
( CORE::
scalar
(
@_
) == 2 && CORE::
defined
(
$class
) )
) )
{
$ERRORS
->{
$addr
} =
$ERROR
= ( CORE::
defined
(
$class
) ?
bless
(
$err
=>
$class
) :
$err
);
}
else
{
return
(
$self
->error(
@_
) );
}
if
( want(
'OBJECT'
) )
{
my
$null
= Module::Generic::Null->new(
$err
, {
debug
=>
$ERRORS
->{
$addr
},
has_error
=> 1 });
rreturn(
$null
);
}
return
;
}
sub
pos
{
return
(
$_
[0]->_number(
@_
> 1 ? ( CORE::
pos
( ${
$_
[0]} ) =
$_
[1] ) : CORE::
pos
( ${
$_
[0]} ) ) ); }
sub
prepend {
return
(
shift
->
substr
( 0, 0, ( ( Scalar::Util::reftype(
$_
[0] ) //
''
) eq
'SCALAR'
? ${
$_
[0]} :
$_
[0] ) ) ); }
sub
quotemeta
{
return
( __PACKAGE__->_new( CORE::
quotemeta
( ${
$_
[0]} ) ) ); }
sub
right {
return
(
$_
[0]->_new( CORE::
substr
( ${
$_
[0]}, ( CORE::
int
(
$_
[1] ) * -1 ) ) ) ); }
sub
replace
{
my
(
$self
,
$re
,
$replacement
) =
@_
;
my
@matches
= ();
my
@rv
= ();
$re
= CORE::
defined
(
$re
)
? (
ref
(
$re
) eq
'Regexp'
||
ref
(
$re
) eq
'Regexp::Common'
)
?
$re
:
qr/(?:\Q$re\E)+/
:
$re
;
@rv
=
$$self
=~ s/
$re
/
$replacement
/gs;
if
(
scalar
( @{^CAPTURE} ) )
{
for
(
my
$i
= 0;
$i
<
scalar
( @{^CAPTURE} );
$i
++ )
{
push
(
@matches
, ${^CAPTURE}[
$i
] );
}
}
my
$names
= { %+ };
unless
( want(
'OBJECT'
) || want(
'SCALAR'
) || want(
'LIST'
) ||
scalar
(
@matches
) )
{
return
(0);
}
return
( Module::Generic::RegexpCapture->new(
result
=> \
@rv
,
capture
=> \
@matches
,
name
=>
$names
) );
}
sub
reset
{ ${
$_
[0]} =
''
;
return
(
$_
[0] ); }
sub
reverse
{
return
( __PACKAGE__->_new( CORE::
scalar
( CORE::
reverse
( ${
$_
[0]} ) ) ) ); }
sub
rindex
{
my
$self
=
shift
(
@_
);
my
(
$substr
,
$pos
) =
@_
;
return
(
$self
->_number( CORE::
rindex
( ${
$self
},
$substr
,
$pos
) ) )
if
( CORE::
defined
(
$pos
) );
return
(
$self
->_number( CORE::
rindex
( ${
$self
},
$substr
) ) );
}
sub
rtrim
{
my
$self
=
shift
(
@_
);
my
$str
=
shift
(
@_
);
$str
= CORE::
defined
(
$str
)
? (
ref
(
$str
) eq
'Regexp'
||
ref
(
$str
) eq
'Regexp::Common'
)
?
$str
:
qr/(?:\Q$str\E)+/
:
qr/[[:blank:]\r\n]*/
;
$$self
=~ s/${str}$//g;
return
(
$self
);
}
sub
scalar
{
return
(
shift
->as_string ); }
sub
set
{
my
$self
= CORE::
shift
(
@_
);
if
(
@_
)
{
my
$init
;
my
$type
= Scalar::Util::reftype(
$_
[0] ) //
''
;
if
(
$type
eq
'SCALAR'
)
{
$init
= ${
$_
[0]};
}
elsif
(
$type
eq
'ARRAY'
)
{
$init
= CORE::
join
(
''
, @{
$_
[0]} );
}
elsif
(
ref
(
$_
[0] ) )
{
warn
(
"I do not know what to do with \""
,
$_
[0],
"\" ("
, overload::StrVal(
$_
[0] ),
")\n"
)
if
(
$self
->_warnings_is_enabled );
return
;
}
else
{
$init
=
shift
(
@_
);
}
$$self
=
$init
;
}
return
(
$self
);
}
sub
split
{
my
$self
= CORE::
shift
(
@_
);
my
(
$expr
,
$limit
) =
@_
;
if
( !
scalar
(
@_
) )
{
CORE::
warn
(
"No argument was provided to split string in Module::Generic::Scalar::split\n"
)
if
(
$self
->_warnings_is_enabled );
$expr
=
' '
;
}
unless
(
ref
(
$expr
) eq
'Regexp'
||
ref
(
$expr
) eq
'Regexp::Common'
)
{
if
(
ref
(
$expr
) )
{
CORE::
warn
(
"Expression provided is a reference of type '"
,
ref
(
$expr
),
"', but I was expecting either a regular expression or a simple string.\n"
);
return
;
}
$expr
=
qr/\Q$expr\E/
;
}
my
$ref
;
$limit
=
"$limit"
if
( CORE::
defined
(
$limit
) );
if
( CORE::
defined
(
$limit
) &&
$limit
=~ /^\d+$/ )
{
$ref
= [ CORE::
split
(
$expr
,
$$self
,
$limit
) ];
}
else
{
$ref
= [ CORE::
split
(
$expr
,
$$self
) ];
}
if
( Want::want(
'OBJECT'
) ||
Want::want(
'SCALAR'
) )
{
rreturn(
$self
->_array(
$ref
) );
}
elsif
( Want::want(
'LIST'
) )
{
rreturn(
@$ref
);
}
return
;
}
sub
sprintf
{
return
( __PACKAGE__->_new( CORE::
sprintf
( ${
$_
[0]},
@_
[1..
$#_
] ) ) ); }
sub
substr
{
my
$self
= CORE::
shift
(
@_
);
my
(
$offset
,
$length
,
$replacement
) =
@_
;
return
( __PACKAGE__->_new( CORE::
substr
( ${
$self
},
$offset
,
$length
,
$replacement
) ) )
if
( CORE::
defined
(
$length
) && CORE::
defined
(
$replacement
) );
return
( __PACKAGE__->_new( CORE::
substr
( ${
$self
},
$offset
,
$length
) ) )
if
( CORE::
defined
(
$length
) );
return
( __PACKAGE__->_new( CORE::
substr
( ${
$self
},
$offset
) ) );
}
sub
tr
{
my
$self
= CORE::
shift
(
@_
);
my
(
$search
,
$replace
,
$opts
) =
@_
;
$opts
//=
''
;
local
$@;
eval
(
"\$\$self =~ CORE::tr/$search/$replace/$opts"
);
return
(
$self
);
}
sub
trim
{
my
$self
=
shift
(
@_
);
my
$str
=
shift
(
@_
);
$str
= CORE::
defined
(
$str
) ? CORE::
quotemeta
(
$str
) :
qr/[[:blank:]\r\n]*/
;
$$self
=~ s/^
$str
|
$str
$//gs;
return
(
$self
);
}
sub
uc
{
return
( __PACKAGE__->_new( CORE::
uc
( ${
$_
[0]} ) ) ); }
sub
ucfirst
{
return
( __PACKAGE__->_new( CORE::
ucfirst
( ${
$_
[0]} ) ) ); }
sub
undef
{
my
$self
=
shift
(
@_
);
$$self
=
undef
;
return
(
$self
);
}
sub
unpack
{
my
(
$self
,
$tmpl
) =
@_
;
my
$ref
= [CORE::
unpack
(
$tmpl
,
$$self
)];
if
( Want::want(
'OBJECT'
) )
{
rreturn(
$self
->_array(
$ref
) );
}
elsif
( Want::want(
'LIST'
) )
{
rreturn(
@$ref
);
}
elsif
( Want::want(
'SCALAR'
) )
{
rreturn(
$ref
->[0] );
}
return
;
}
sub
upper {
return
(
shift
->
uc
); }
sub
_array
{
my
$self
=
shift
(
@_
);
my
$arr
=
shift
(
@_
);
if
( !
defined
(
$arr
) )
{
if
( Want::want(
'OBJECT'
) )
{
return
( Module::Generic::Null->new(
wants
=>
'OBJECT'
) );
}
else
{
return
;
}
}
return
(
$arr
)
if
( ( Scalar::Util::reftype(
$arr
) //
''
) ne
'ARRAY'
);
return
( Module::Generic::Array->new(
$arr
) );
}
sub
_number
{
my
$self
=
shift
(
@_
);
my
$num
=
shift
(
@_
);
if
( !
defined
(
$num
) )
{
if
( Want::want(
'OBJECT'
) )
{
return
( Module::Generic::Null->new(
wants
=>
'OBJECT'
) );
}
else
{
return
;
}
}
return
(
$num
)
if
( !CORE::
length
(
$num
) );
return
( Module::Generic::Number->new(
$num
) );
}
sub
_new {
return
(
shift
->Module::Generic::Scalar::new(
@_
) ); }
sub
_warnings_is_enabled
{
my
$self
=
shift
(
@_
);
die
(
"Object provided is undef!\n"
)
if
(
@_
&& !
defined
(
$_
[0] ) );
my
$obj
=
@_
?
shift
(
@_
) :
$self
;
return
(0)
if
( !
$self
->_warnings_is_registered(
$obj
) );
return
( warnings::enabled(
ref
(
$obj
) ||
$obj
) );
}
sub
_warnings_is_registered
{
my
$self
=
shift
(
@_
);
die
(
"Object provided is undef!\n"
)
if
(
@_
&& !
defined
(
$_
[0] ) );
my
$obj
=
@_
?
shift
(
@_
) :
$self
;
return
(1)
if
(
defined
(
$warnings::Bits
{
ref
(
$obj
) ||
$obj
} ) );
return
(0);
}
sub
DESTROY
{
local
( $., $@, $!, $^E, $? );
my
$self
=
shift
(
@_
);
my
$addr
= Scalar::Util::refaddr(
$self
);
CORE::
delete
(
$ERRORS
->{
$addr
} );
};
sub
FREEZE
{
my
$self
= CORE::
shift
(
@_
);
my
$serialiser
= CORE::
shift
(
@_
) //
''
;
my
$class
= CORE::
ref
(
$self
) ||
$self
;
CORE::
return
( [
$class
,
$$self
] )
if
(
$serialiser
eq
'Sereal'
&& Sereal::Encoder->VERSION <= version->parse(
'4.023'
) );
CORE::
return
(
$$self
);
}
sub
STORABLE_freeze { CORE::
return
( CORE::
shift
->FREEZE(
@_
) ); }
sub
STORABLE_thaw { CORE::
return
( CORE::
shift
->THAW(
@_
) ); }
sub
THAW
{
my
(
$self
,
undef
,
@args
) =
@_
;
my
(
$class
,
$str
);
if
( CORE::
scalar
(
@args
) == 1 && CORE::
ref
(
$args
[0] ) eq
'ARRAY'
)
{
(
$class
,
$str
) = @{
$args
[0]};
}
else
{
$class
= CORE::
ref
(
$self
) ||
$self
;
$str
= CORE::
shift
(
@args
);
}
my
$new
;
if
( CORE::
ref
(
$self
) )
{
$$self
=
$str
;
$new
=
$self
;
}
else
{
$new
= CORE::
return
(
$class
->new(
$str
) );
}
CORE::
return
(
$new
);
}
sub
TO_JSON { CORE::
return
( ${
$_
[0]} ); }
{
package
Module::Generic::RegexpCapture;
BEGIN
{
use
vars
qw( $ERROR $VERSION )
;
'""'
=>
sub
{
$_
[0]->matched },
'0+'
=>
sub
{
$_
[0]->matched },
fallback
=> 1,
);
our
$ERROR
=
''
;
our
$VERSION
=
'v0.1.1'
;
};
sub
init
{
my
$self
=
shift
(
@_
);
$self
->{capture} = [];
$self
->{name} = {};
$self
->{result} = 0;
$self
->{_init_strict_use_sub} = 1;
return
(
$self
->SUPER::init(
@_
) );
}
sub
capture {
return
(
shift
->_set_get_array_as_object(
'capture'
,
@_
) ); }
sub
matched
{
my
$res
=
shift
->result;
return
(
$res
->
length
->
scalar
)
if
(
$res
->
length
&&
length
(
$res
->get(0) ) );
return
(0);
}
sub
name {
return
(
shift
->_set_get_hash_as_object(
'name'
,
@_
) ); }
sub
result {
return
(
shift
->_set_get_array_as_object(
'result'
,
@_
) ); }
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 {
return
(
shift
->FREEZE(
@_
) ); }
sub
STORABLE_thaw {
return
(
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
);
}
}
{
package
Module::Generic::Scalar::Tie;
BEGIN
{
};
our
$dummy_callback
=
sub
{1};
sub
TIESCALAR
{
my
(
$class
,
$opts
) =
@_
;
$opts
//= {};
if
( ( Scalar::Util::reftype(
$opts
) //
''
) ne
'HASH'
)
{
warn
(
"Options provided ("
, overload::StrVal(
$opts
),
") is not an hash reference\n"
);
$opts
= {};
}
$opts
->{data} //=
''
;
$opts
->{debug} //= 0;
if
( CORE::
length
(
$opts
->{add} ) &&
ref
(
$opts
->{add} ) ne
'CODE'
)
{
warnings::
warn
(
"Code provided for the scalar add callback is not a code reference.\n"
)
if
( warnings::enabled(
'Module::Generic::Sscalar'
) ||
$opts
->{debug} );
return
;
}
if
( CORE::
length
(
$opts
->{remove} ) &&
ref
(
$opts
->{remove} ) ne
'CODE'
)
{
warnings::
warn
(
"Code provided for the scalar remove callback is not a code reference.\n"
)
if
( warnings::enabled(
'Module::Generic::Sscalar'
) ||
$opts
->{debug} );
return
;
}
my
$ref
=
{
callback_add
=>
$opts
->{add},
callback_remove
=>
$opts
->{remove},
data
=> ( ( Scalar::Util::reftype(
$opts
->{data} ) //
''
) eq
'SCALAR'
? \
"${$opts->{data}}"
: \
undef
),
debug
=>
$opts
->{debug},
};
print
( STDERR (
ref
(
$class
) ||
$class
),
"::TIESCALAR: Using "
, CORE::
length
( ${
$ref
->{data}} ),
" bytes of data in scalar vs "
, CORE::
length
( ${
$opts
->{data}} ),
" bytes received via opts->data.\n"
)
if
(
$ref
->{debug} );
return
(
bless
(
$ref
=> (
ref
(
$class
) ||
$class
) ) );
}
sub
FETCH
{
my
$self
=
shift
(
@_
);
return
( ${
$self
->{data}} );
}
sub
STORE
{
my
(
$self
,
$value
) =
@_
;
my
$index
= 0;
my
$rv
;
if
( CORE::
length
(
"$value"
) < CORE::
length
( ${
$self
->{data}} ) )
{
my
$cb
=
$self
->{callback_remove} ||
$dummy_callback
;
if
( !
$cb
)
{
warnings::
warn
(
"No callback remove found. This should not happen.\n"
)
if
( warnings::enabled(
'Module::Generic::Scalar'
) ||
$self
->{debug} );
$rv
= 1;
}
else
{
$rv
=
$cb
->({
type
=>
'remove'
,
removed
=> \
"${$self->{data}}"
,
added
=> \
$value
});
}
}
else
{
my
$cb
=
$self
->{callback_add} ||
$dummy_callback
;
if
( !
$cb
)
{
warnings::
warn
(
"No callback add found. This should not happen.\n"
)
if
( warnings::enabled(
'Module::Generic::Scalar'
) ||
$self
->{debug} );
$rv
= 1;
}
else
{
$rv
=
$cb
->({
type
=>
'add'
,
added
=> \
$value
});
}
}
print
( STDERR
ref
(
$self
),
"::STORE: adding "
, CORE::
length
(
"$value"
),
" bytes of data ($value) at position $index with current data of "
, CORE::
length
( ${
$self
->{data}} ),
" bytes ("
, ${
$self
->{data}},
") -> callback returned "
, (
defined
(
$rv
) ?
'true'
:
'undef'
),
"\n"
)
if
(
$self
->{debug} );
return
if
( !
defined
(
$rv
) );
${
$self
->{data}} =
$value
;
}
sub
has_callback
{
my
$self
=
shift
(
@_
);
return
(1)
if
(
ref
(
$self
->{callback_add} ) eq
'CODE'
||
ref
(
$self
->{callback_remove} ) eq
'CODE'
);
return
(0);
}
sub
set_callback
{
my
(
$self
,
$what
,
$code
) =
@_
;
if
( !
defined
(
$what
) )
{
warn
(
"No callback type was provided. Use \"add\" or \"remove\".\n"
);
return
;
}
elsif
(
$what
ne
'add'
&&
$what
ne
'remove'
)
{
warn
(
"Unknown callback type was provided: '$what'. Use \"add\" or \"remove\".\n"
);
return
;
}
elsif
( !
defined
(
$code
) )
{
warn
(
"No callback anonymous subroutine or subroutine reference was provided.\n"
);
return
;
}
elsif
(
ref
(
$code
) ne
'CODE'
)
{
warn
(
"Callback provided ("
, overload::StrVal(
$code
),
") is not a code reference.\n"
);
return
;
}
$self
->{
"callback_${what}"
} =
$code
;
return
(1);
}
sub
unset_callback
{
my
(
$self
,
$what
) =
@_
;
if
( !
defined
(
$what
) )
{
warn
(
"No callback type was provided. Use \"add\" or \"remove\".\n"
);
return
;
}
elsif
(
$what
ne
'add'
&&
$what
ne
'remove'
)
{
warn
(
"Unknown callback type was provided: '$what'. Use \"add\" or \"remove\".\n"
);
return
;
}
$self
->{
"callback_${what}"
} =
undef
;
return
(1);
}
}
1;