our
$VERSION
=
'0.733'
;
our
@EXPORT_OK
=
qw< identify log_helper read_file tubify >
;
sub
identify {
my
(
$args
,
$opts
) =
@_
;
$args
//= {};
$opts
//=
$args
->{identification} // {};
my
$name
=
$args
->{name};
$name
=
'*unknown*'
unless
defined
$name
;
my
@caller_fields
=
qw<
package
filename
line
subroutine
hasargs
wantarray
evaltext
is_require
hints
bitmask
hintsh
>
;
my
%caller
;
if
(
exists
$opts
->{
caller
}) {
@caller
{
@caller_fields
} = @{
$opts
->{
caller
}};
}
else
{
my
$level
=
$opts
->{level};
$level
= 1
unless
defined
$level
;
@caller
{
@caller_fields
} =
caller
(
$level
);
}
my
$message
=
$opts
->{message};
$message
=
'building [% name %] as [% subroutine %]'
unless
defined
$message
;
my
$tp
= Template::Perlish->new(%{
$opts
->{tp_opts} || {}});
$message
=
$tp
->process(
$message
,
{
%caller
,
name
=>
$name
,
args
=>
$args
,
opts
=>
$opts
,
}
);
my
$loglevel
=
$opts
->{loglevel};
$loglevel
=
$DEBUG
unless
defined
$loglevel
;
get_logger->
log
(
$loglevel
,
$message
);
return
;
}
sub
log_helper {
my
(
$args
,
$opts
) =
@_
;
$opts
//=
$args
->{logger};
return
unless
$opts
;
return
$opts
if
ref
(
$opts
) eq
'CODE'
;
my
$name
=
$args
->{name};
$name
=
'*unknown*'
unless
defined
$name
;
my
$message
=
$opts
->{message};
$message
=
'==> [% args.name %]'
unless
defined
$message
;
my
$tp
= Template::Perlish->new(%{
$opts
->{tp_opts} || {}});
$message
=
$tp
->compile(
$message
);
my
$logger
= get_logger();
my
$loglevel
=
$opts
->{loglevel};
$loglevel
=
$DEBUG
unless
defined
$loglevel
;
return
sub
{
my
$level
=
$logger
->level();
return
if
$level
<
$loglevel
;
my
$record
=
shift
;
my
$rendered
=
$tp
->evaluate(
$message
,
{
record
=>
$record
,
args
=>
$args
,
opts
=>
$opts
});
$logger
->
log
(
$loglevel
,
$rendered
);
};
}
sub
tubify {
map
{
my
$ref
=
ref
$_
;
(
$ref
eq
'CODE'
)
?
$_
: tube((
$ref
eq
'ARRAY'
) ?
@$_
:
$_
)
}
grep
{
$_
}
@_
;
}
1;