File Coverage

blib/lib/CGI/Ex/Dump.pm
Criterion Covered Total %
statement 14 95 14.7
branch 0 38 0.0
condition 0 22 0.0
subroutine 5 16 31.2
pod 7 10 70.0
total 26 181 14.3


line stmt bran cond sub pod time code
1             package CGI::Ex::Dump;
2              
3             =head1 NAME
4              
5             CGI::Ex::Dump - A debug utility
6              
7             =head1 VERSION
8              
9             version 2.54
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 4     4   58476 use vars qw($CALL_LEVEL $ON $SUB $QR1 $QR2 $full_filename $DEPARSE);
  4         15  
  4         311  
19 4     4   34 use strict;
  4         6  
  4         92  
20 4     4   25 use Exporter qw(import);
  4         6  
  4         1384  
21              
22             our $VERSION = '2.54'; # VERSION
23             our @EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace);
24             our @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug caller_trace);
25              
26             ### is on or off
27 4     4 1 6 sub on { $ON = 1 };
28 0     0 1   sub off { $ON = 0; }
29              
30 0     0 0   sub set_deparse { $DEPARSE = 1 }
31              
32             ###----------------------------------------------------------------###
33              
34             BEGIN {
35 4     4   21 on();
36              
37             $SUB = sub {
38             ### setup the Data::Dumper usage
39 0   0     0 local $Data::Dumper::Deparse = $DEPARSE && eval {require B::Deparse};
40 0         0 local $Data::Dumper::Pad = ' ';
41 0         0 local $Data::Dumper::Sortkeys = 1;
42 0         0 local $Data::Dumper::Useqq = 1;
43 0         0 local $Data::Dumper::Quotekeys = 0;
44              
45 0         0 require Data::Dumper;
46 0         0 return Data::Dumper->Dumpperl(\@_);
47 4         12 };
48              
49             ### how to display or parse the filename
50 4         23 $QR1 = qr{\A(?:/[^/]+){2,}/(?:perl|lib)/(.+)\Z};
51 4         4184 $QR2 = qr{\A.+?([\w\.\-]+/[\w\.\-]+)\Z};
52             }
53              
54             ###----------------------------------------------------------------###
55              
56              
57             ### same as dumper but with more descriptive output and auto-formatting
58             ### for cgi output
59             sub _what_is_this {
60 0 0   0     return if ! $ON;
61             ### figure out which sub we called
62 0   0       my ($pkg, $file, $line_n, $called) = caller(1 + ($CALL_LEVEL || 0));
63 0           substr($called, 0, length(__PACKAGE__) + 2, '');
64              
65             ### get the actual line
66 0           my $line = '';
67 0 0         if (open(IN,$file)) {
68 0           $line = for 1 .. $line_n;
69 0           close IN;
70             }
71              
72             ### get rid of extended filename
73 0 0         if (! $full_filename) {
74 0 0         $file =~ s/$QR1/$1/ || $file =~ s/$QR2/$1/;
75             }
76              
77             ### dump it out
78 0           my @dump = map {&$SUB($_)} @_;
  0            
79 0           my @var = ('$VAR') x ($#dump + 1);
80 0           my $hold;
81 0 0 0       if ($line =~ s/^ .*\b \Q$called\E ( \s* \( \s* | \s+ )//x
      0        
      0        
82             && ($hold = $1)
83             && ( $line =~ s/ \s* \b if \b .* \n? $ //x
84             || $line =~ s/ \s* ; \s* $ //x
85             || $line =~ s/ \s+ $ //x)) {
86 0 0         $line =~ s/ \s*\) $ //x if $hold =~ /^\s*\(/;
87 0 0         my @_var = map {/^[\"\']/ ? 'String' : $_} split (/\s*,\s*/, $line);
  0            
88 0 0         @var = @_var if $#var == $#_var;
89             }
90              
91             ### spit it out
92 0 0 0       if ($called eq 'dex_text'
      0        
93             || $called eq 'dex_warn'
94             || ! $ENV{REQUEST_METHOD}) {
95 0           my $txt = "$called: $file line $line_n\n";
96 0           for (0 .. $#dump) {
97 0           $dump[$_] =~ s|\$VAR1|$var[$_]|g;
98 0           $txt .= $dump[$_];
99             }
100 0 0         if ($called eq 'dex_text') { return $txt }
  0 0          
101 0           elsif ($called eq 'dex_warn') { warn $txt }
102 0           else { print $txt }
103             } else {
104 0           my $html = "
$called: $file line $line_n\n"; 
105 0           for (0 .. $#dump) {
106 0           $dump[$_] =~ s/(?
107 0           $dump[$_] = _html_quote($dump[$_]);
108 0           $dump[$_] =~ s|\$VAR1|$var[$_]|g;
109 0           $html .= $dump[$_];
110             }
111 0           $html .= "\n";
112 0 0         return $html if $called eq 'dex_html';
113 0           require CGI::Ex;
114 0           CGI::Ex::print_content_type();
115 0           print $html;
116             }
117 0           return @_[0..$#_];
118             }
119              
120             ### some aliases
121 0     0 1   sub debug { &_what_is_this }
122 0     0 1   sub dex { &_what_is_this }
123 0     0 1   sub dex_warn { &_what_is_this }
124 0     0 1   sub dex_text { &_what_is_this }
125 0     0 0   sub dex_html { &_what_is_this }
126              
127             sub _html_quote {
128 0     0     my $value = shift;
129 0 0         return '' if ! defined $value;
130 0           $value =~ s/&/&/g;
131 0           $value =~ s/
132 0           $value =~ s/>/>/g;
133             # $value =~ s/\"/"/g;
134 0           return $value;
135             }
136              
137             ### ctrace is intended for work with perl 5.8 or higher's Carp
138             sub ctrace {
139 0     0 1   require 5.8.0;
140 0           require Carp::Heavy;
141 0           local $Carp::MaxArgNums = 3;
142 0           local $Carp::MaxArgLen = 20;
143 0   0       my $i = shift || 0;
144 0           my @i = ();
145 0           my $max1 = 0;
146 0           my $max2 = 0;
147 0           my $max3 = 0;
148 0           while (my %i = Carp::caller_info(++$i)) {
149 0           $i{sub_name} =~ s/\((.*)\)$//;
150 0 0         $i{args} = $i{has_args} ? $1 : "";
151 0           $i{sub_name} =~ s/^.*?([^:]+)$/$1/;
152 0 0         $i{file} =~ s/$QR1/$1/ || $i{file} =~ s/$QR2/$1/;
153 0 0         $max1 = length($i{sub_name}) if length($i{sub_name}) > $max1;
154 0 0         $max2 = length($i{file}) if length($i{file}) > $max2;
155 0 0         $max3 = length($i{line}) if length($i{line}) > $max3;
156 0           push @i, \%i;
157             }
158 0           foreach my $ref (@i) {
159             $ref = sprintf("%-${max1}s at %-${max2}s line %${max3}s", $ref->{sub_name}, $ref->{file}, $ref->{line})
160 0 0         . ($ref->{args} ? " ($ref->{args})" : "");
161             }
162 0           return \@i;
163             }
164              
165             *caller_trace = \&ctrace;
166              
167             sub dex_trace {
168 0     0 0   _what_is_this(ctrace(1));
169             }
170              
171             ###----------------------------------------------------------------###
172              
173             1;
174              
175             __END__