File Coverage

blib/lib/Debug/Filter/PrintExpr.pm
Criterion Covered Total %
statement 77 79 97.4
branch 20 22 90.9
condition 6 7 85.7
subroutine 22 22 100.0
pod n/a
total 125 130 96.1


line stmt bran cond sub pod time code
1             package Debug::Filter::PrintExpr;
2              
3 4     4   104540 use strict;
  4         24  
  4         116  
4 4     4   22 use warnings;
  4         6  
  4         96  
5            
6 4     4   2023 use Exporter::Tiny;
  4         13419  
  4         27  
7              
8 4     4   2752 use Filter::Simple;
  4         98676  
  4         27  
9 4     4   217 use Scalar::Util qw(isdual blessed);
  4         8  
  4         294  
10 4     4   38 use List::Util 'pairs';
  4         8  
  4         330  
11 4     4   2684 use Data::Dumper;
  4         28123  
  4         553  
12              
13             our
14             $VERSION = '0.15';
15              
16             our @EXPORT_OK = qw(isnumeric isstring);
17             our @ISA = qw(Exporter::Tiny);
18             our %EXPORT_TAGS = (
19             debug => [],
20             nofilter => [],
21             all => [qw(isnumeric isstring)],
22             );
23              
24             require XSLoader;
25             XSLoader::load('Debug::Filter::PrintExpr', $VERSION);
26              
27             local ($,, $\);
28              
29             # Make Exporter::Tiny::import ours, so this will be called by Filter::Simple
30 4     4   2424 BEGIN {*import = \&Exporter::Tiny::import;}
31              
32             # variable is exposed and my be overwritten by caller
33             our $handle = *STDERR;
34              
35             # generate a prefix containing line number or custom label
36             # consume first three args, return number of printed chars
37             # if no expression is present
38             sub _genprefix {
39 29     29   82 my ($label, $line, $expr, $pos) = splice @_, 0, 3;
40 29         68 local ($,, $\);
41 29   66     176 printf $handle "%s%n", $label || "L$line:", $pos;
42 29 100       784 print $handle $expr ? " $expr = " : " ";
43 29 100       664 return $expr ? undef : $pos + 1;
44             }
45              
46             # create representation of single value
47             sub _singlevalue {
48 25     25   56 my ($val, $str, $num) = shift;
49 25         64 my $isdual = isdual($val);
50 25         52 my $isnumeric = isnumeric($val);
51 25 100       66 $str = "$val" if defined $val;
52 25 100       55 $num = $val + 0 if $isnumeric;
53 25 100       102 if (!defined $val) {
    50          
    50          
    100          
    100          
54 1         4 return 'undef';
55             } elsif (my $class = blessed($val)) {
56 0         0 return "blessed($class)";
57             } elsif (ref($val)) {
58 0         0 return $val;
59             } elsif ($isdual) {
60 3         14 return "dualvar($num, '$str')";
61             } elsif ($isnumeric) {
62 8         28 return $num;
63             } else {
64 13         56 return "'$str'";
65             }
66             }
67              
68             # print out an expression in scalar context
69             sub _valuescalar {
70 21     21   60 local ($,, $\);
71 21         43 print $handle _singlevalue($_[0]);
72             }
73              
74             # print out an expression in list context
75             sub _valuearray {
76 2     2   7 local ($,, $\);
77             print $handle '(', join(', ',
78 2         6 map({_singlevalue($_)} @_)), ");\n";
  2         4  
79             }
80              
81             # print out an expression as key-value pairs
82             sub _valuehash {
83 2     2   7 local ($,, $\);
84             print $handle '(', join(", ",
85             map(
86 2         20 {"'$_->[0]' => " . _singlevalue($_->[1])}
  2         11  
87             pairs(@_))), ");\n";
88             }
89              
90             # process a scalar debug statement
91             sub _print_scalar {
92 23     23   16394 local ($,, $\);
93 23 100       49 unless (&_genprefix) {
94 21         62 _valuescalar($_[0]);
95 21         501 print $handle ';';
96             }
97 23         440 print $handle "\n";
98             }
99              
100             # process a string scalar debug statement
101             sub _print_str {
102 2     2   1005 my $val = $_[3];
103 2         7 splice @_, 3, 1, "$val";
104 2         8 goto &_print_scalar;
105             }
106              
107             # process a numeric scalar debug statement
108             sub _print_num {
109 4     4   55 no warnings qw(numeric);
  4         8  
  4         2184  
110 2     2   865 my $val = $_[3];
111 2         8 splice @_, 3, 1, $val + 0;
112 2         7 goto &_print_scalar;
113             }
114              
115             # process an array debug statement
116             sub _print_array {
117 2     2   908 &_genprefix;
118 2         8 goto &_valuearray;
119             }
120              
121             # process a hash debug statement
122             sub _print_hash {
123 2     2   905 &_genprefix;
124 2         8 goto &_valuehash;
125             }
126              
127             # process a reference debug statement
128             sub _print_ref {
129 2     2   3888 my $expr = splice @_, 2, 1, undef;
130 2         6 my $skip = &_genprefix;
131 2         7 local ($,, $\);
132 2         9 print $handle "dump($expr);\n";
133 2         60 print $handle
134             Data::Dumper->new([@_], [map("_[$_]", (0 .. $#_))])
135             ->Pad(' ' x $skip)->Dump;
136             }
137              
138             # type classifications: print function suffix + is scalar
139             my %type_defs = (
140             '$' => ['scalar', 1],
141             '"' => ['str', 1],
142             '#' => ['num', 1],
143             '@' => ['array', 0],
144             '%' => ['hash', 0],
145             '\\' => ['ref', 0],
146             );
147              
148             # process a debug statement, runs in filter context
149             sub _gen_print {
150 29   100 29   278 my ($type, $label, $expr) = map $_ // '', @_;
151 29   100     74 my $val = $_[2] // '()';
152 29         39 my ($ptype, $scalar) = @{$type_defs{$type}};
  29         55  
153 29         58 my $print = __PACKAGE__ . "::_print_$ptype";
154 29 100       247 return qq[{$print("$label", __LINE__, q{$expr}, ] .
155             ($scalar ? qq[scalar($val)] : qq[$val]) .
156             q[)}];
157             }
158              
159             # source code processing happens here
160             FILTER {
161             my ($self, @args) = @_;
162             my ($nofilter, $debug);
163             if (ref($_[1]) eq 'HASH') {
164             my $global = $_[1];
165             $debug = $global->{debug};
166             $nofilter = $global->{nofilter};
167             }
168             $debug ||= grep /^-debug$/, @args;
169             $nofilter ||= grep /^-nofilter$/, @args;
170             s/
171             ^\h*+\#
172             (?[%@\$\\#"])
173             \{\h*+
174             (?
175             \h*+
176             (?\V*[^\s])?\h*
177             \}\h*+\r?$
178 4     4   1992 / _gen_print($+{type}, $+{label}, $+{expr}) /gmex
  4         1449  
  4         832  
179             unless $nofilter;
180             print STDERR if $debug;
181             };
182              
183             1;
184              
185             __END__