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   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;