File Coverage

blib/lib/Devel/DollarAt.pm
Criterion Covered Total %
statement 50 79 63.2
branch 10 26 38.4
condition 3 15 20.0
subroutine 11 16 68.7
pod 3 3 100.0
total 77 139 55.4


line stmt bran cond sub pod time code
1             package Devel::DollarAt;
2 1     1   14245 use strict;
  1         2  
  1         23  
3 1     1   3 use warnings;
  1         1  
  1         24  
4 1     1   3 use base qw(Class::Accessor::Fast);
  1         1  
  1         447  
5 1     1   2415 use Devel::Backtrace;
  1         2  
  1         50  
6              
7             our $VERSION = '0.02';
8              
9             __PACKAGE__->mk_accessors(
10             qw(backtrace err propagated inputline inputhandle filename line)
11             );
12              
13             # Note that to_string also internally called if an exception isn't catched by
14             # any eval and the error must be printed to STDERR.
15 1     1   6 use overload '""' => \&to_string;
  1         2  
  1         7  
16              
17             $SIG{__DIE__} = \&_diehandler;
18              
19             our $FRAME;
20              
21             # This will be called every time the code says "die". However it won't be
22             # called for other errors, such as division by zero. So we still have to use
23             # $SIG{__DIE__}.
24             *CORE::GLOBAL::die = sub (@) {
25 0     0   0 my $text = '';
26 0   0     0 defined and $text .= $_ for @_;
27              
28 0         0 my $err = $@;
29              
30 0 0 0     0 if (defined($err) && length($err) && !length $text) {
      0        
31             # In this case, perl would pass "$@\t...propagated at foo line bar.\n"
32             # to the __DIE__ handler. Because we don't want to parse that, we make
33             # perl think $text is not empty.
34              
35             # We have to store $err in our NullMessage because perl will cleanse $@
36             # before calling the __DIE__ handler. This is very strange, because it
37             # won't get cleansed if we don't override *CORE::GLOBAL::die.
38 0         0 $text = Devel::DollarAt::NullMessage->_new(propagated=>$err);
39             }
40              
41 0         0 CORE::die($text);
42             };
43              
44             sub _diehandler {
45 3     3   62 my ($err) = @_;
46              
47 3         5 my $propagated = $@;
48              
49 3 50 33     10 if (ref($err) && $err->isa('Devel::DollarAt::NullMessage')) {
50 0         0 $propagated = $err->{propagated};
51 0         0 $err = '';
52             }
53              
54 3         16 my $backtrace = Devel::Backtrace->new(1);
55 3         9 my $skip = $backtrace->skipmysubs(); # skips this handler plus our overridden
56             # CORE::GLOBAL::die if possible
57 3 50       11 CORE::die "Strange:\n$backtrace" unless $skip;
58              
59 3         5 my ($inputhandle, $inputline);
60 3 50       37 if ($err =~ s/^(.*) at .*?(?:<(.*)> line (\d+)|)\.\n\z/$1/s) {
61 3         6 ($inputhandle, $inputline) = ($2, $3);
62             }
63              
64 3         8 my $dollarat = __PACKAGE__->_new({
65             backtrace => $backtrace,
66             err => $err,
67             filename => $skip->filename,
68             line => $skip->line,
69             }
70             );
71              
72 3 50       9 if (defined $inputline) {
73 0         0 $dollarat->inputline($inputline);
74 0         0 $dollarat->inputhandle($inputhandle);
75             }
76              
77 3 100 66     14 if (defined $propagated and length $propagated) {
78 1         2 $dollarat->propagated($propagated);
79             }
80              
81 3         67 CORE::die($dollarat);
82             }
83              
84             # Try to appear exactly like the normal $@
85             sub to_string {
86 3     3 1 10 my $this = shift;
87              
88 3         7 my $text = $this->err;
89              
90 3 50       13 if (defined ($this->propagated)) {
91 0 0       0 if (!length($text)) {
92 0         0 $text = $this->propagated . "\t...propagated";
93             }
94             }
95              
96 3 50       16 unless ($text =~ /\n\z/) {
97 3         8 $text .= ' at ' . $this->filename . ' line ' . $this->line;
98 3 50       24 if (defined $this->inputline) {
99 0         0 $text .= ', <'.$this->inputhandle . '> line ' . $this->inputline;
100             }
101             }
102              
103 3         11 $text .= '.';
104 3 50       5 $text = "[[$text]]" if $FRAME;
105 3         4 $text .= "\n";
106              
107 3         22 return $text;
108             }
109              
110             sub _new {
111 3     3   26 my $class = shift;
112 3         13 my $this = $class->SUPER::new(@_);
113              
114 3         20 return $this;
115             }
116              
117             sub import {
118 1     1   7 my $class = shift;
119 1         1021 for (@_) {
120 0 0         if ('frame' eq $_) {
121 0           $FRAME = 1;
122             } else {
123 0           die 'Unknown parameter for '.__PACKAGE__.": $_";
124             }
125             };
126             }
127              
128             sub redie {
129 0     0 1   my $this = shift;
130 0           my ($package, $filename, $line) = caller;
131 0           push @{$this->{redispatch_points}}, Devel::DollarAt::RedispatchPoint->new({
  0            
132             package => $package,
133             filename => $filename,
134             line => $line,
135             }
136             );
137 0           local $SIG{__DIE__};
138 0           CORE::die($this);
139             }
140              
141             sub redispatch_points {
142 0     0 1   my $this = shift;
143 0 0         return @{$this->{redispatch_points} || []};
  0            
144             }
145              
146             package # hide from pause
147             Devel::DollarAt::NullMessage;
148             #use overload '""' => sub {''};
149 0     0     sub _new { shift; bless {@_}; }
  0            
150              
151             package # hide from pause
152             Devel::DollarAt::RedispatchPoint;
153 1     1   569 use base qw(Class::Accessor::Fast);
  1         1  
  1         129  
154             __PACKAGE__->mk_ro_accessors(qw(package filename line));
155              
156             use overload '""' => sub {
157 0     0   0 my $this = shift;
158              
159 0         0 return 'redispatched from '.$this->package.' at '
160             .$this->filename.':'.$this->line."\n";
161 1     1   4 };
  1         2  
  1         14  
162              
163             1
164             __END__