line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Data::Tubes::Plugin::Util; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# vim: ts=3 sts=3 sw=3 et ai : |
4
|
|
|
|
|
|
|
|
5
|
30
|
|
|
30
|
|
200
|
use strict; |
|
30
|
|
|
|
|
57
|
|
|
30
|
|
|
|
|
893
|
|
6
|
30
|
|
|
30
|
|
144
|
use warnings; |
|
30
|
|
|
|
|
55
|
|
|
30
|
|
|
|
|
852
|
|
7
|
30
|
|
|
30
|
|
143
|
use English qw< -no_match_vars >; |
|
30
|
|
|
|
|
59
|
|
|
30
|
|
|
|
|
164
|
|
8
|
30
|
|
|
30
|
|
11896
|
use Data::Dumper; |
|
30
|
|
|
|
|
7078
|
|
|
30
|
|
|
|
|
2066
|
|
9
|
|
|
|
|
|
|
our $VERSION = '0.740'; |
10
|
|
|
|
|
|
|
|
11
|
30
|
|
|
30
|
|
14558
|
use Template::Perlish; |
|
30
|
|
|
|
|
113735
|
|
|
30
|
|
|
|
|
179
|
|
12
|
30
|
|
|
30
|
|
1404
|
use Log::Log4perl::Tiny qw< :easy :dead_if_first get_logger >; |
|
30
|
|
|
|
|
70
|
|
|
30
|
|
|
|
|
305
|
|
13
|
30
|
|
|
30
|
|
10743
|
use Data::Tubes::Util qw< normalize_args read_file tube >; |
|
30
|
|
|
|
|
68
|
|
|
30
|
|
|
|
|
1756
|
|
14
|
|
|
|
|
|
|
|
15
|
30
|
|
|
30
|
|
178
|
use Exporter qw< import >; |
|
30
|
|
|
|
|
64
|
|
|
30
|
|
|
|
|
17588
|
|
16
|
|
|
|
|
|
|
our @EXPORT_OK = qw< identify log_helper read_file tubify >; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub identify { |
19
|
198
|
|
|
198
|
1
|
631
|
my ($args, $opts) = @_; |
20
|
198
|
|
50
|
|
|
485
|
$args //= {}; |
21
|
198
|
|
100
|
|
|
1387
|
$opts //= $args->{identification} // {}; |
|
|
|
33
|
|
|
|
|
22
|
|
|
|
|
|
|
|
23
|
198
|
|
|
|
|
368
|
my $name = $args->{name}; |
24
|
198
|
100
|
|
|
|
470
|
$name = '*unknown*' unless defined $name; |
25
|
|
|
|
|
|
|
|
26
|
198
|
|
|
|
|
746
|
my @caller_fields = qw< |
27
|
|
|
|
|
|
|
package |
28
|
|
|
|
|
|
|
filename |
29
|
|
|
|
|
|
|
line |
30
|
|
|
|
|
|
|
subroutine |
31
|
|
|
|
|
|
|
hasargs |
32
|
|
|
|
|
|
|
wantarray |
33
|
|
|
|
|
|
|
evaltext |
34
|
|
|
|
|
|
|
is_require |
35
|
|
|
|
|
|
|
hints |
36
|
|
|
|
|
|
|
bitmask |
37
|
|
|
|
|
|
|
hintsh |
38
|
|
|
|
|
|
|
>; |
39
|
198
|
|
|
|
|
296
|
my %caller; |
40
|
|
|
|
|
|
|
|
41
|
198
|
100
|
|
|
|
447
|
if (exists $opts->{caller}) { |
42
|
5
|
|
|
|
|
7
|
@caller{@caller_fields} = @{$opts->{caller}}; |
|
5
|
|
|
|
|
44
|
|
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
else { |
45
|
193
|
|
|
|
|
411
|
my $level = $opts->{level}; |
46
|
193
|
50
|
|
|
|
561
|
$level = 1 unless defined $level; |
47
|
193
|
|
|
|
|
1825
|
@caller{@caller_fields} = caller($level); |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
198
|
|
|
|
|
2008
|
my $message = $opts->{message}; |
51
|
198
|
50
|
|
|
|
513
|
$message = 'building [% name %] as [% subroutine %]' |
52
|
|
|
|
|
|
|
unless defined $message; |
53
|
|
|
|
|
|
|
|
54
|
198
|
50
|
|
|
|
346
|
my $tp = Template::Perlish->new(%{$opts->{tp_opts} || {}}); |
|
198
|
|
|
|
|
1521
|
|
55
|
198
|
|
|
|
|
6601
|
$message = $tp->process( |
56
|
|
|
|
|
|
|
$message, |
57
|
|
|
|
|
|
|
{ |
58
|
|
|
|
|
|
|
%caller, |
59
|
|
|
|
|
|
|
name => $name, |
60
|
|
|
|
|
|
|
args => $args, |
61
|
|
|
|
|
|
|
opts => $opts, |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
); |
64
|
|
|
|
|
|
|
|
65
|
198
|
|
|
|
|
644320
|
my $loglevel = $opts->{loglevel}; |
66
|
198
|
50
|
|
|
|
755
|
$loglevel = $DEBUG unless defined $loglevel; |
67
|
198
|
|
|
|
|
844
|
get_logger->log($loglevel, $message); |
68
|
|
|
|
|
|
|
|
69
|
198
|
|
|
|
|
3212
|
return; |
70
|
|
|
|
|
|
|
} ## end sub identify |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub log_helper { |
73
|
17
|
|
|
17
|
1
|
48
|
my ($args, $opts) = @_; |
74
|
17
|
|
33
|
|
|
99
|
$opts //= $args->{logger}; |
75
|
17
|
50
|
|
|
|
61
|
return unless $opts; |
76
|
0
|
0
|
|
|
|
0
|
return $opts if ref($opts) eq 'CODE'; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# generate one |
79
|
0
|
|
|
|
|
0
|
my $name = $args->{name}; |
80
|
0
|
0
|
|
|
|
0
|
$name = '*unknown*' unless defined $name; |
81
|
|
|
|
|
|
|
|
82
|
0
|
|
|
|
|
0
|
my $message = $opts->{message}; |
83
|
0
|
0
|
|
|
|
0
|
$message = '==> [% args.name %]' unless defined $message; |
84
|
|
|
|
|
|
|
|
85
|
0
|
0
|
|
|
|
0
|
my $tp = Template::Perlish->new(%{$opts->{tp_opts} || {}}); |
|
0
|
|
|
|
|
0
|
|
86
|
0
|
|
|
|
|
0
|
$message = $tp->compile($message); |
87
|
|
|
|
|
|
|
|
88
|
0
|
|
|
|
|
0
|
my $logger = get_logger(); |
89
|
0
|
|
|
|
|
0
|
my $loglevel = $opts->{loglevel}; |
90
|
0
|
0
|
|
|
|
0
|
$loglevel = $DEBUG unless defined $loglevel; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
return sub { |
93
|
0
|
|
|
0
|
|
0
|
my $level = $logger->level(); |
94
|
0
|
0
|
|
|
|
0
|
return if $level < $loglevel; |
95
|
0
|
|
|
|
|
0
|
my $record = shift; |
96
|
0
|
|
|
|
|
0
|
my $rendered = |
97
|
|
|
|
|
|
|
$tp->evaluate($message, |
98
|
|
|
|
|
|
|
{record => $record, args => $args, opts => $opts}); |
99
|
0
|
|
|
|
|
0
|
$logger->log($loglevel, $rendered); |
100
|
0
|
|
|
|
|
0
|
}; |
101
|
|
|
|
|
|
|
} ## end sub log_helper |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub tubify { |
104
|
52
|
|
|
52
|
1
|
5432
|
my $opts = {}; |
105
|
52
|
100
|
66
|
|
|
331
|
$opts = shift(@_) if (@_ && ref($_[0]) eq 'HASH'); |
106
|
|
|
|
|
|
|
map { |
107
|
101
|
|
|
|
|
192
|
my $ref = ref $_; |
108
|
101
|
100
|
|
|
|
408
|
($ref eq 'CODE') |
|
|
100
|
|
|
|
|
|
109
|
|
|
|
|
|
|
? $_ |
110
|
|
|
|
|
|
|
: tube($opts, ($ref eq 'ARRAY') ? @$_ : $_) |
111
|
52
|
|
|
|
|
129
|
} grep { $_ } @_; |
|
103
|
|
|
|
|
210
|
|
112
|
|
|
|
|
|
|
} ## end sub tubify |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
1; |