File Coverage

blib/lib/Syntax/Keyword/Try/Deparse.pm
Criterion Covered Total %
statement 33 34 97.0
branch 7 8 87.5
condition 4 6 66.6
subroutine 8 8 100.0
pod 0 2 0.0
total 52 58 89.6


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
5              
6             package Syntax::Keyword::Try::Deparse 0.28;
7              
8 1     1   439 use v5.14;
  1         4  
9 1     1   5 use warnings;
  1         2  
  1         29  
10              
11 1     1   5 use B qw( opnumber );
  1         2  
  1         123  
12              
13             require B::Deparse;
14              
15             use constant {
16 1         163 OP_CUSTOM => opnumber('custom'),
17             OP_ENTER => opnumber('enter'),
18             OP_LINESEQ => opnumber('lineseq'),
19 1     1   7 };
  1         2  
20              
21             =head1 NAME
22              
23             C - L support for L
24              
25             =head1 DESCRIPTION
26              
27             Loading this module will apply some hacks onto L that attempts to
28             provide deparse support for code which uses the syntax provided by
29             L.
30              
31             =cut
32              
33             my $orig_pp_leave;
34             {
35 1     1   7 no warnings 'redefine';
  1         2  
  1         68  
36 1     1   6 no strict 'refs';
  1         2  
  1         474  
37             $orig_pp_leave = *{"B::Deparse::pp_leave"}{CODE};
38             *{"B::Deparse::pp_leave"} = \&pp_leave;
39             }
40              
41             sub pp_leave
42             {
43 7     7 0 5076 my $self = shift;
44 7         17 my ( $op ) = @_;
45              
46 7         25 my $enter = $op->first;
47 7 100       1116 $enter->type == OP_ENTER or
48             return $self->$orig_pp_leave( @_ );
49              
50 4         14 my $body = $enter->sibling;
51 4         16 my $first = $body->first;
52              
53 4         8 my $finally = "";
54              
55 4 100 66     44 if( $body->type == OP_LINESEQ and $first->name eq "pushfinally" ) {
56             my $finally_cv = $first->sv;
57             $finally = "\nfinally " . $self->deparse_sub( $finally_cv ) . "\cK";
58              
59             $first = $first->sibling;
60             $first = $first->sibling while $first and $first->name eq "lineseq";
61              
62             # Jump over a scope op
63             if( $first->type == 0 ) {
64             $body = $first;
65             $first = $first->first;
66             }
67             }
68              
69 4 100 66     47 if( $first->type == OP_CUSTOM and $first->name eq "catch" ) {
    50          
70             # This is a try/catch block
71             shift;
72             return $self->deparse( $body, @_ ) . $finally;
73             }
74             elsif( length $finally ) {
75             # Body is the remaining siblings. We'll have to do them all together
76             my $try = B::Deparse::scopeop( 1, $self, $body, 0 );
77              
78             return "try {\n\t$try\n\b}" . $finally;
79             }
80              
81 0         0 return $orig_pp_leave->($self, @_);
82             }
83              
84             sub B::Deparse::pp_catch
85             {
86 3     3 0 8 my $self = shift;
87 3         6 my ( $op ) = @_;
88              
89 3         12 my $tryop = $op->first;
90 3         14 my $catchop = $op->first->sibling;
91              
92 3         12 my $try = $self->pp_leave($tryop, 0);
93              
94             # skip the OP_SCOPE and dive into the OP_LINESEQ inside
95             #
96             # TODO: Try to detect the `catch my $e` variable, though that will be hard
97             # to dishtinguish from actual code that really does that
98 3         1059 my $catch = $self->deparse($catchop->first, 0);
99              
100 3         360 return "try {\n\t$try\n\b}\ncatch {\n\t$catch\n\b}\cK";
101             }
102              
103             =head1 TODO
104              
105             Correctly handle typed dispatch cases
106             (C, C)
107              
108             =cut
109              
110             =head1 AUTHOR
111              
112             Paul Evans
113              
114             =cut
115              
116             0x55AA;