File Coverage

blib/lib/Devel/file.pm
Criterion Covered Total %
statement 60 105 57.1
branch 17 70 24.2
condition 5 22 22.7
subroutine 11 17 64.7
pod 0 8 0.0
total 93 222 41.8


line stmt bran cond sub pod time code
1             package Devel::file;
2              
3             =head1 NAME
4              
5             Devel::file - show source lines around errors and warnings
6              
7             =head1 VERSION
8              
9             Version 0.01 - alpha, more of a sketch that a module
10              
11             =cut
12              
13             our $VERSION = '0.01';
14              
15             =head1 SYNOPSIS
16              
17             $ perl -d:file -we 'eval { 12/1 };' -e '/a/;' -e 'die 123'
18             Useless use of a constant in void context at -e line 1.
19             =W= -e:1
20             1=> eval { 12/1 };
21             2: /a/;
22             ...
23             Use of uninitialized value in pattern match (m//) at -e line 2.
24             =W= -e:2
25             1: eval { 12/1 };
26             2=> /a/;
27             3: die 123
28             ...
29             123 at -e line 3.
30             =E= -e:3
31             2: /a/;
32             3=> die 123
33             ...
34              
35             perl -d:file script.pl
36             PERL5OPT='-d:file' script.pl
37             perl -MDevel::file script.pl # run without debugger
38              
39             =head1 DESCRIPTION
40              
41             Devel::file appends source code to warnings and fatal errors
42             as a potential debugging aid. It provides handlers for die and warn
43             in order to do this.
44              
45             This module is still in alpha and is liable to change.
46              
47             =head1 AUTHOR
48              
49             Brad Bowman, C<< >>
50              
51             =head1 BUGS
52              
53             Please report any bugs or feature requests to
54             C, or through the web interface at
55             L.
56             I will be notified, and then you'll automatically be notified of progress on
57             your bug as I make changes.
58              
59             =head1 COPYRIGHT & LICENSE
60              
61             Copyright 2007 Brad Bowman, all rights reserved.
62              
63             This program is free software; you can redistribute it and/or modify it
64             under the same terms as Perl itself.
65              
66             =cut
67 1     1   24641 use strict;
  1         3  
  1         43  
68 1     1   5 use warnings;
  1         2  
  1         34  
69 1     1   5 use Carp qw(carp);
  1         6  
  1         981  
70              
71             my $Verbose = 0;
72             my $Context = 1;
73             my $Debug = 0; # debug this module
74             my $ShowBoth = 0;
75             my $Formatter = \&format_line;
76              
77             my $have_debug_info = 0;
78             my $have_io_all = 0;
79              
80             # What should $Debug do? make development easier
81             sub mywarn {
82 0     0 0 0 print STDERR @_, "\n";
83             }
84              
85             # minimal "debugger" to use -d and gather the precious things, see perlguts
86 0     0 0 0 sub DB::DB {}
87              
88             sub import {
89 1     1   10 my $class = shift;
90              
91 1         4 $class->_process_options(@_);
92 1         3 $class->enable();
93             }
94              
95             sub _process_options {
96 1     1   3 my $class = shift;
97              
98             # short options for -d:file=v style
99 1         7 while ($_ = shift) {
100 0 0       0 if (/^v(erbose)?$/) {
    0          
    0          
    0          
101 0         0 $Verbose = 1;
102             } elsif (/^C(ontext)?(\d+)$/) { # C grep-style (AB?)
103 0         0 $Context = $2;
104             } elsif (/^D(ebug)?$/) { # C grep-style (AB?)
105 0         0 $Debug = 1;
106             } elsif (/^ShowBoth(?:=(\d))?$/) { # just for comparison
107 0 0       0 $ShowBoth = defined ($1) ? $1 : 1;
108             } else {
109 0         0 carp "Unknown option '$_'";
110             }
111             }
112             }
113              
114             my ($old_warn, $old_die);
115             sub enable {
116 1     1 0 2 my $class = shift;
117              
118             # perl -d:file -le 'print $^P' ==> 831
119 1 50       6 if ($^P != 0) { # debugging enabled XXX
120 1         2 $have_debug_info = 1;
121             }
122              
123 1 50 33     9 if ( $ShowBoth || !$have_debug_info ) {
124 0 0 0     0 if ( !$INC{'IO/All.pm'} && !eval 'use IO::All; 1;' ) {
125 0 0       0 mywarn "Can't setup $class, No IO::All $@" if $Verbose;
126 0         0 return;
127             } else {
128 0         0 $have_io_all = 1;
129             }
130             }
131              
132 1 50       4 if ($Debug) {
133 0 0       0 mywarn "$class: using IO::All" if $have_io_all;
134 0 0       0 mywarn "$class: using debugger source" if $have_debug_info;
135             }
136              
137             # XXX Separate for die?
138 1 50 33     6 if ( defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_handler) ) {
139 0 0       0 mywarn "$class: handler already installed" if $Debug;
140 0         0 return;
141             }
142 1 50       6 $old_warn = $SIG{__WARN__} if $SIG{__WARN__};
143 1 50       7 $old_die = $SIG{__DIE__} if $SIG{__DIE__};
144              
145 1         4 $SIG{__WARN__} = \&warn_handler;
146 1         22 $SIG{__DIE__} = \&die_handler;
147             }
148              
149             sub disable {
150 0     0 0 0 my $class = shift;
151              
152 0 0       0 return unless $SIG{__WARN__} eq \&warn_handler;
153 0   0     0 $SIG{__WARN__} = $old_warn || '';
154 0   0     0 $SIG{__DIE__} = $old_die || '';
155 0         0 $old_warn = $old_die = undef;
156             }
157              
158             sub die_handler {
159              
160             # Don't process if this is a die in an eval
161             # (constant folded evals at compile time: eval {1/0})
162 2 50 33 2 0 17 if (defined($^S) && $^S == 1) {
163 0 0       0 mywarn "In eval, calling continuation" if $Debug;
164              
165 0 0       0 $old_die ? goto &$old_die : die @_;
166              
167 0         0 mywarn __PACKAGE__ . "This should never appear";
168             } else {
169 2         16 @_ = handler(1 => @_);
170             }
171              
172             # goto means call stack is cleaner for diagnostics, etc.
173 2 50       29 $old_die ? goto &$old_die : die @_;
174              
175             # $old_die ? $old_die->(@_) : die @_;
176             # goto prevents: perl -Mdiagnostics -MDevel::file -e '12/0'
177             # at /home/bsb/perl-modules/devel-file/lib/Devel/file.pm line 150
178             # Devel::file::die_handler('Illegal division by zero at -e line 1 ...
179             }
180              
181             sub warn_handler {
182 0     0 0 0 local $SIG{__WARN__}; # needed to avoid recursion
183              
184 0         0 @_ = handler(0 => @_);
185              
186 0 0       0 if ($old_warn) {
187 0         0 $old_warn->(@_);
188             } else {
189 0         0 warn @_;
190             }
191             }
192              
193             sub handler {
194 2     2 0 5 my $in_die = shift;
195 1     1   6 no warnings 'uninitialized';
  1         2  
  1         473  
196              
197 2         12 my $e = shift; # $e may be an object,
198             # warn @list is already concatenated
199 2         3 my $c = $Context;
200 2         4 $a = $b = $c; # before and after
201              
202             # t/syn1.pl has two errors on the line, same file, near each other
203             # many errors could overwhelm, only show the first?
204 2         22 my @locations = $e =~ /at (.+?) line (\d+)[.,]/g;
205              
206 2 50       9 mywarn "Original error [[$e]]" if $Debug;
207 2 50       6 mywarn "Found: @locations" if $Debug;
208              
209             # TODO merge multiple locations in one file
210             # how this is handled depends on how things are grouped by perl
211             # all syntax errors for a file together or individually
212             # (we don't gather them and post-process)
213             # I suspect dies come as one extended last gasp, but warns may
214             # one-by-one
215              
216 2 50       6 my $type = ($in_die) ? 'E' : 'W'; # distinguish warn & die?
217              
218 2         11 while ( my ($file, $line) = splice(@locations, 0, 2) ) {
219              
220 3         7 my $target = $line;
221 3         17 my $from = $line - $b;
222 3         5 my $to = $line + $a;
223 3 50       11 $from = 1 if $from < 1; # line numbers are 1 based
224             # can't tell if $to is past the end of file here
225              
226 3 50       8 mywarn "**($file)[$line] $from - $to" if $Debug;
227              
228 3         32 my $lines;
229 3 50       11 if ($have_debug_info) {
230 3         9 $lines = _debugger_get_lines($file,$from,$to,$target);
231             }
232 3 50 33     19 if (($ShowBoth || !$have_debug_info) && $have_io_all) {
      33        
233 0         0 $lines = _ioall_get_lines($file,$from,$to,$target);
234             }
235              
236             # This is caught at enable time, I think... local = ???
237             # if ($Debug && (!$have_debug_info) && !$have_io_all) { }
238              
239 3 50       16 if ($lines) {
240 0         0 $e .= "=$type= $file:$line\n$lines...\n";
241             }
242             }
243              
244 2         6 return $e;
245             }
246              
247             # would be good to be extendable eventually (variable values, ??)
248             # may want access to DB::* info
249             sub format_line {
250 0     0 0 0 my ($line, $number, $is_target) = @_;
251              
252             # choose something rarely at start of lines, and not confusing
253             # eg. >=head
254 0 0       0 my $mark = ( $is_target ) ? '=>' : ': ';
255             # XXX don't need $mark w/o Context
256              
257 0         0 sprintf "% 3d$mark %s", $number, $line;
258             }
259              
260             sub _debugger_get_lines {
261 3     3   7 my ($file, $from, $to, $target) = @_;
262 1     1   8 no strict 'refs';
  1         2  
  1         323  
263 3         5 my $file_sym = "::_<$file";
264              
265             # -d inserts a "use Devel::file;" magically, don't show it
266             # I think it's at line 0 which shouldn't be shown anyway
267             # (See: lib/perl5db.pl line 8802
268             # for ( 1 .. $#{'::_<-e'} ) { # The first line is PERL5DB
269             # )
270             #$from++ if $file_sym->[$from] =~ /^use Devel::file/;
271              
272             # XXX know length of last line number here, 9999 target line
273             # (possible line, defined in loop below knows)
274              
275 3         5 my $lines = '';
276 3         6 for my $n ($from..$to) {
277 3         7 my $line = $file_sym->[$n];
278 3 50       10 last if !defined($line); # window past end
279 0         0 chomp($line);
280              
281 0         0 $lines .= $Formatter->($line, $n, ($n == $target)) . "\n";
282             }
283 3         8 return $lines;
284             }
285              
286             sub _ioall_get_lines {
287 0     0     my ($file, $from, $to, $target) = @_;
288 0 0         return unless -e $file; # -e file test, ie. not -e cmdline
289 0 0         my $io = io($file) or return;
290              
291 0           my $lines = '';
292 0           for my $n ($from..$to) {
293 0           my $line = $io->[$n-1]; # array is 0-based
294 0 0         last if !defined($line); # window past end
295             # no chomp needed
296              
297 0           $lines .= $Formatter->($line, $n, ($n == $target)) . "\n";
298             }
299 0           return $lines;
300             }
301              
302             1;