File Coverage

blib/lib/Data/Tubes/Plugin/Util.pm
Criterion Covered Total %
statement 55 72 76.3
branch 15 32 46.8
condition 7 13 53.8
subroutine 11 12 91.6
pod 3 3 100.0
total 91 132 68.9


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   207 use strict;
  30         55  
  30         896  
6 30     30   138 use warnings;
  30         59  
  30         838  
7 30     30   140 use English qw< -no_match_vars >;
  30         58  
  30         179  
8 30     30   11607 use Data::Dumper;
  30         6996  
  30         2031  
9             our $VERSION = '0.737';
10              
11 30     30   14780 use Template::Perlish;
  30         114937  
  30         178  
12 30     30   1371 use Log::Log4perl::Tiny qw< :easy :dead_if_first get_logger >;
  30         84  
  30         260  
13 30     30   12288 use Data::Tubes::Util qw< normalize_args read_file tube >;
  30         74  
  30         1912  
14              
15 30     30   188 use Exporter qw< import >;
  30         61  
  30         17730  
16             our @EXPORT_OK = qw< identify log_helper read_file tubify >;
17              
18             sub identify {
19 198     198 1 697 my ($args, $opts) = @_;
20 198   50     518 $args //= {};
21 198   100     1457 $opts //= $args->{identification} // {};
      33        
22              
23 198         384 my $name = $args->{name};
24 198 100       513 $name = '*unknown*' unless defined $name;
25              
26 198         745 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         295 my %caller;
40              
41 198 100       461 if (exists $opts->{caller}) {
42 5         9 @caller{@caller_fields} = @{$opts->{caller}};
  5         34  
43             }
44             else {
45 193         434 my $level = $opts->{level};
46 193 50       520 $level = 1 unless defined $level;
47 193         2012 @caller{@caller_fields} = caller($level);
48             }
49              
50 198         2106 my $message = $opts->{message};
51 198 50       540 $message = 'building [% name %] as [% subroutine %]'
52             unless defined $message;
53              
54 198 50       374 my $tp = Template::Perlish->new(%{$opts->{tp_opts} || {}});
  198         1678  
55 198         7164 $message = $tp->process(
56             $message,
57             {
58             %caller,
59             name => $name,
60             args => $args,
61             opts => $opts,
62             }
63             );
64              
65 198         660012 my $loglevel = $opts->{loglevel};
66 198 50       820 $loglevel = $DEBUG unless defined $loglevel;
67 198         944 get_logger->log($loglevel, $message);
68              
69 198         3425 return;
70             } ## end sub identify
71              
72             sub log_helper {
73 17     17 1 46 my ($args, $opts) = @_;
74 17   33     91 $opts //= $args->{logger};
75 17 50       56 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 4427 my $opts = {};
105 52 100 66     348 $opts = shift(@_) if (@_ && ref($_[0]) eq 'HASH');
106             map {
107 101         185 my $ref = ref $_;
108 101 100       419 ($ref eq 'CODE')
    100          
109             ? $_
110             : tube($opts, ($ref eq 'ARRAY') ? @$_ : $_)
111 52         128 } grep { $_ } @_;
  103         209  
112             } ## end sub tubify
113              
114             1;