The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

PEVANS / Syntax-Keyword-Try-0.30 / lib / Syntax / Keyword / Try / Deparse.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
—
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
—
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116

              
#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
package Syntax::Keyword::Try::Deparse 0.30;
use v5.14;
use warnings;
use B qw( opnumber );
require B::Deparse;
use constant {
   OP_CUSTOM  => opnumber('custom'),
   OP_ENTER   => opnumber('enter'),
   OP_LINESEQ => opnumber('lineseq'),
};
=head1 NAME
C<Syntax::Keyword::Try::Deparse> - L<B::Deparse> support for L<Syntax::Keyword::Try>
=head1 DESCRIPTION
Loading this module will apply some hacks onto L<B::Deparse> that attempts to
provide deparse support for code which uses the syntax provided by
L<Syntax::Keyword::Try>.
=cut
my $orig_pp_leave;
{
   no warnings 'redefine';
   no strict 'refs';
   $orig_pp_leave = *{"B::Deparse::pp_leave"}{CODE};
   *{"B::Deparse::pp_leave"} = \&pp_leave;
}
sub pp_leave
{
   my $self = shift;
   my ( $op ) = @_;
   my $enter = $op->first;
   $enter->type == OP_ENTER or
      return $self->$orig_pp_leave( @_ );
   my $body = $enter->sibling;
   my $first = $body->first;
   my $finally = "";
   if( $body->type == OP_LINESEQ and $first->name eq "pushfinally" ) {
      my $finally_cv = $first->sv;
      $finally = "\nfinally " . $self->deparse_sub( $finally_cv ) . "\cK";
      $first = $first->sibling;
      $first = $first->sibling while $first and $first->name eq "lineseq";
      # Jump over a scope op
      if( $first->type == 0 ) {
         $body  = $first;
         $first = $first->first;
      }
   }
   if( $first->type == OP_CUSTOM and $first->name eq "catch" ) {
      # This is a try/catch block
      shift;
      return $self->deparse( $body, @_ ) . $finally;
   }
   elsif( length $finally ) {
      # Body is the remaining siblings. We'll have to do them all together
      my $try = B::Deparse::scopeop( 1, $self, $body, 0 );
      return "try {\n\t$try\n\b}" . $finally;
   }
   return $orig_pp_leave->($self, @_);
}
sub B::Deparse::pp_catch
{
   my $self = shift;
   my ( $op ) = @_;
   my $tryop   = $op->first;
   my $catchop = $op->first->sibling;
   my $try = $self->pp_leave($tryop, 0);
   # skip the OP_SCOPE and dive into the OP_LINESEQ inside
   #
   # TODO: Try to detect the `catch my $e` variable, though that will be hard
   # to dishtinguish from actual code that really does that
   my $catch = $self->deparse($catchop->first, 0);
   return "try {\n\t$try\n\b}\ncatch {\n\t$catch\n\b}\cK";
}
=head1 TODO
Correctly handle typed dispatch cases
(C<catch($var isa CLASS)>, C<catch($var =~ m/pattern/)>)
=cut
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA;