File Coverage

blib/lib/Nice/Try.pm
Criterion Covered Total %
statement 665 818 81.3
branch 306 558 54.8
condition 153 264 57.9
subroutine 42 52 80.7
pod 4 7 57.1
total 1170 1699 68.8


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## A real Try Catch Block Implementation Using Perl Filter - ~/lib/Nice/Try.pm
3             ## Version v1.4.0
4             ## Copyright(c) 2025 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest
6             ## Created 2020/05/17
7             ## Modified 2026/04/29
8             ## All rights reserved
9             ##
10             ## This program is free software; you can redistribute it and/or modify it
11             ## under the same terms as Perl itself.
12             ##----------------------------------------------------------------------------
13             package Nice::Try;
14             BEGIN
15             {
16 31     31   338 require 5.16.0;
17 31     31   2771703 use strict;
  31         51  
  31         1109  
18 31     31   237 use warnings;
  31         48  
  31         1434  
19 31     31   154 use warnings::register;
  31         50  
  31         1999  
20 31         3384 use vars qw(
21             $CATCH $DIED $EXCEPTION $FINALLY $HAS_CATCH @RETVAL $SENTINEL $TRY $WANTARRAY
22             $VERSION $ERROR
23 31     31   135 );
  31         59  
24 31     31   14452 use PPI 1.277;
  31         5241135  
  31         1496  
25 31     31   13618 use Filter::Util::Call;
  31         23181  
  31         2197  
26 31     31   201 use Scalar::Util ();
  31         46  
  31         383  
27 31     31   141 use List::Util ();
  31         67  
  31         430  
28 31     31   14075 use Wanted ();
  31         56585  
  31         2114  
29 31         85 our $VERSION = 'v1.4.0';
30 31         35 our $ERROR;
31 31         675 our( $CATCH, $DIED, $EXCEPTION, $FINALLY, $HAS_CATCH, @RETVAL, $SENTINEL, $TRY, $WANTARRAY );
32             }
33              
34 31     31   97 use strict;
  31         37  
  31         550  
35 31     31   99 use warnings;
  31         40  
  31         57757  
36              
37             # Taken from Try::Harder version 0.005
38             our $SENTINEL = bless( {} => __PACKAGE__ . '::SENTINEL' );
39              
40             sub import
41             {
42 32     32   515 my( $this, @arguments ) = @_ ;
43 32         76 my $class = CORE::caller();
44 32         60 my $hash = { @arguments };
45 32 50       181 $hash->{debug} = 0 if( !CORE::exists( $hash->{debug} ) );
46 32 50       93 $hash->{no_filter} = 0 if( !CORE::exists( $hash->{no_filter} ) );
47 32 50       84 $hash->{debug_code} = 0 if( !CORE::exists( $hash->{debug_code} ) );
48 32 50       80 $hash->{debug_dump} = 0 if( !CORE::exists( $hash->{debug_dump} ) );
49 32 50       82 $hash->{dont_want} = 0 if( !CORE::exists( $hash->{dont_want} ) );
50             # We use the $class to process the __DATA__ or __END__ token section
51 32         71 $hash->{class} = $class;
52             # We check if we are running under tie and if so we cannot use Wanted features,
53             # because they would trigger a segmentation fault.
54 32         54 $hash->{is_tied} = 0;
55 32 50 33     661 if( $class->can( 'TIESCALAR' ) || $class->can( 'TIEHASH' ) || $class->can( 'TIEARRAY' ) )
      33        
56             {
57 0         0 $hash->{is_tied} = 1;
58             }
59 32         153 require overload;
60 32 50       156 $hash->{is_overloaded} = overload::Overloaded( $class ) ? 1 : 0;
61 32         1748 $hash->{no_context} = 0;
62             # 2021-05-17 (Jacques): the following was a bad idea as it was indiscriminate and
63             # would also affect use of caller outside of try-catch blocks
64             # *{"${class}::caller"} = \&{"Nice::Try::caller"};
65 32   33     226 filter_add( bless( $hash => ( ref( $this ) || $this ) ) );
66             }
67              
68             sub unimport
69             {
70 0     0   0 filter_del();
71             }
72              
73             sub caller($;$)
74             {
75 6     6 1 16 my $where = shift( @_ );
76 6         13 my $n = shift( @_ );
77             # Offsetting our internal call frames
78 6         24 my $map =
79             {
80             try => 3,
81             catch => 3,
82             finally => 5,
83             };
84 6 100       56 my @info = defined( $n ) ? CORE::caller( int( $n ) + $map->{ $where } ) : CORE::caller( 1 + $map->{ $where } );
85 6         48 return( @info );
86             }
87              
88 3     3 0 179476 sub caller_try { return( &Nice::Try::caller( try => @_ ) ); }
89              
90 1     1 0 1716 sub caller_catch { return( &Nice::Try::caller( catch => @_ ) ); }
91              
92 2     2 0 13 sub caller_finally { return( &Nice::Try::caller( finally => @_ ) ); }
93              
94             sub filter
95             {
96 49     49 1 113540 my( $self ) = @_ ;
97 49         79 my( $status, $last_line );
98 49         67 my $line = 0;
99 49         80 my $code = '';
100 49 50       305 if( $self->{no_filter} )
101             {
102 0         0 filter_del();
103 0         0 $status = 1;
104 0 0       0 $self->_message( 3, "Skiping filtering." ) if( $self->{debug} >= 3 );
105 0         0 return( $status );
106             }
107 49         394 while( $status = filter_read() )
108             {
109             # Error
110 3033 50       3194 if( $status < 0 )
111             {
112 0 0       0 $self->_message( 3, "An error occurred in fiilter, aborting." ) if( $self->{debug} >= 3 );
113 0         0 return( $status );
114             }
115 3033         2533 $line++;
116 3033         2646 $code .= $_;
117 3033         4487 $_ = '';
118             }
119 49 100       36433 return( $line ) if( !$line );
120 32 50       101 unless( $status < 0 )
121             {
122             # 2021-06-05 (Jacques): fixes the issue No. 3
123             # Make sure there is at least a space at the beginning
124 32         74 $code = ' ' . $code;
125 32 100       130 if( index( $code, 'try' ) != -1 )
126             {
127 28 50       84 $self->_message( 4, "Processing $line lines of code." ) if( $self->{debug} >= 4 );
128 28 50       67 $self->_message( 4, "Processing code:\n${code}" ) if( $self->{debug} >= 5 );
129 28   50     245 my $doc = PPI::Document->new( \$code, readonly => 1 ) || die( "Unable to parse: ", PPI::Document->errstr, "\n$code\n" );
130             # Remove pod
131             # $doc->prune('PPI::Token::Pod');
132 28 50       2087906 $self->_browse( $doc ) if( $self->{debug_dump} );
133             # It is easy for us to do a simple check as to whether there is potentially a __DATA__ or a __END__ token,
134             # so we avoid wasting resources and time checking it using PPI::Element::find()
135 28 100 100     415 if( $doc = $self->_parse( $doc,
    50          
136             {
137             has_data => ( ( CORE::index( $code, '__DATA__' ) != -1 || CORE::index( $code, '__END__' ) != -1 ) ? 1 : 0 ),
138             }) )
139             {
140 28         404 $_ = $doc->serialize;
141             # $doc->save( "./dev/debug-parsed.pl" );
142             # $status = 1;
143             }
144             # Rollback
145             else
146             {
147 0         0 $_ = $code;
148             # $status = -1;
149             # filter_del();
150             }
151             }
152             else
153             {
154 4 50       9 $self->_message( 4, "There does not seem to be any try block in this code, so skipping." ) if( $self->{debug} >= 4 );
155 4         7 $_ = $code;
156             }
157            
158 32 50       104400 if( CORE::length( $last_line ) )
159             {
160 0         0 $_ .= $last_line;
161             }
162             }
163 32 50       62162 unless( $status <= 0 )
164             {
165 0         0 while( $status = filter_read() )
166             {
167 0 0       0 $self->_message( 4, "Reading more line: $_" ) if( $self->{debug} >= 4 );
168 0 0       0 return( $status ) if( $status < 0 );
169 0         0 $line++;
170             }
171             }
172             # $self->_message( 4, "Resulting code:\n${_}" ) if( $self->{debug} >= 5 );
173 32 50       173 if( $self->{debug_file} )
174             {
175 0 0       0 if( open( my $fh, ">$self->{debug_file}" ) )
176             {
177 0         0 binmode( $fh, ':utf8' );
178 0         0 print( $fh $_ );
179 0         0 close( $fh );
180             }
181             }
182 32         15852 return( $line );
183             }
184              
185             sub implement
186             {
187 2     2 1 311705 my $self = shift( @_ );
188 2         5 my $code = shift( @_ );
189 2 50 33     15 return( $code ) if( !CORE::defined( $code ) || !CORE::length( $code ) );
190 2 50       4 unless( ref( $self ) )
191             {
192 2 0 33     10 my $opts = ( !@_ || !defined( $_[0] ) )
    0          
    50          
193             ? {}
194             : ref( $_[0] ) eq 'HASH'
195             ? shift( @_ )
196             : !( @_ % 2 )
197             ? { @_ }
198             : {};
199 2         4 for( qw( debug no_context no_filter debug_code debug_dump debug_file dont_want is_tied is_overloaded ) )
200             {
201 18   50     47 $opts->{ $_ } //= 0;
202             }
203 2         5 $self = bless( $opts => $self );
204             }
205             # 2021-06-05 (Jacques): fixes the issue No. 3
206             # Make sure there is at least a space at the beginning
207 2         4 $code = ' ' . $code;
208 2 50       11 $self->_message( 4, "Processing ", CORE::length( $code ), " bytes of code." ) if( $self->{debug} >= 4 );
209 2   50     26 my $doc = PPI::Document->new( \$code, readonly => 1 ) || die( "Unable to parse: ", PPI::Document->errstr, "\n$code\n" );
210 2 50       19099 $self->_browse( $doc ) if( $self->{debug_dump} );
211 2 50       11 if( $doc = $self->_parse( $doc ) )
212             {
213 2         8 $code = $doc->serialize;
214             }
215 2         824 return( $code );
216             }
217              
218             sub _browse
219             {
220 0     0   0 my $self = shift( @_ );
221 0         0 my $elem = shift( @_ );
222 0   0     0 my $level = shift( @_ ) || 0;
223 0 0       0 if( $self->{debug} >= 4 )
224             {
225 0 0       0 $self->_message( 4, "Checking code: ", $self->_serialize( $elem ) ) if( $self->{debug} >= 4 );
226 0 0       0 $self->_messagef( 4, "PPI element of class %s has children property '%s'.", $elem->class, $elem->{children} ) if( $self->{debug} >= 4 );
227             }
228 0 0       0 return if( !$elem->children );
229 0         0 foreach my $e ( $elem->elements )
230             {
231 0   0     0 printf( STDERR "%sElement: [%d] class %s, value %s\n", ( '.' x $level ), ( $e->line_number // 'undef' ), ( $e->class // 'undef' ), ( $e->content // 'undef' ) );
      0        
      0        
232 0 0 0     0 if( $e->can('children') && $e->children )
233             {
234 0         0 $self->_browse( $e, $level + 1 );
235             }
236             }
237             }
238              
239             sub _error
240             {
241 0     0   0 my $self = shift( @_ );
242 0 0       0 if( @_ )
243             {
244 0 0       0 my $txt = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
245 0         0 $txt =~ s/[\015\012]+$//g;
246 0         0 $ERROR = $txt;
247 0 0       0 CORE::warn( "$txt\n" ) if( warnings::enabled );
248 0         0 return;
249             }
250 0         0 return( $ERROR );
251             }
252              
253             sub _message
254             {
255 78     78   141 my $self = shift( @_ );
256 78 50       248 my $level = $_[0] =~ /^\d+$/ ? shift( @_ ) : 0;
257 78 50       147 return if( $self->{debug} < $level );
258 0         0 my @data = @_;
259 0         0 my $stackFrame = 0;
260 0         0 my( $pkg, $file, $line, @otherInfo ) = CORE::caller( $stackFrame );
261 0         0 my $sub = ( CORE::caller( $stackFrame + 1 ) )[3];
262 0         0 my $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
263 0 0       0 my $txt = "${pkg}::${sub2}( $self ) [$line]: " . join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @data ) );
264 0         0 $txt =~ s/\n$//gs;
265 0         0 $txt = '## ' . join( "\n## ", split( /\n/, $txt ) );
266 0         0 CORE::print( STDERR $txt, "\n" );
267             }
268              
269             sub _messagef
270             {
271 0     0   0 my $self = shift( @_ );
272 0 0       0 my $level = $_[0] =~ /^\d+$/ ? shift( @_ ) : 0;
273 0 0       0 return if( $self->{debug} < $level );
274 0         0 my @data = @_;
275 0         0 my $stackFrame = 0;
276 0         0 my $fmt = shift( @data );
277 0         0 my( $pkg, $file, $line, @otherInfo ) = CORE::caller( $stackFrame );
278 0         0 my $sub = ( CORE::caller( $stackFrame + 1 ) )[3];
279 0         0 my $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
280 0         0 for( @data )
281             {
282 0 0       0 next if( ref( $_ ) );
283 0         0 s/\b\%/\x{025}/g;
284             }
285 0 0       0 my $txt = "${pkg}::${sub2}( $self ) [$line]: " . sprintf( $fmt, map( ref( $_ ) eq 'CODE' ? $_->() : $_, @data ) );
286 0         0 $txt =~ s/\n$//gs;
287 0         0 $txt = '## ' . join( "\n## ", split( /\n/, $txt ) );
288 0         0 CORE::print( STDERR $txt, "\n" );
289             }
290              
291             sub _parse
292             {
293 300     300   412 my $self = shift( @_ );
294 300         358 my $elem = shift( @_ );
295 300         368 my $opts = shift( @_ );
296 31     31   222 no warnings 'uninitialized';
  31         42  
  31         173979  
297 300 50 33     1444 if( !Scalar::Util::blessed( $elem ) || !$elem->isa( 'PPI::Node' ) )
298             {
299 0         0 return( $self->_error( "Element provided to parse is not a PPI::Node object" ) );
300             }
301              
302 300         310 my $check_consecutive_blocks;
303             $check_consecutive_blocks = sub
304             {
305 304     304   371 my $top_elem = shift( @_ );
306 304         321 my $level = shift( @_ );
307             my $ref = $top_elem->find(sub
308             {
309 28993         336299 my( $top, $this ) = @_;
310 28993 100 100     35849 return( $this->class eq 'PPI::Statement' && substr( $this->content, 0, 3 ) eq 'try' ? 1 : 0 );
311 304         1662 });
312 304 50       4300 return( $self->_error( "Failed to find any try-catch clause: $@" ) ) if( !defined( $ref ) );
313 304 50 66     872 $self->_messagef( 4, "[blocks check level ${level}] Found %d match(es) for try statement", scalar( @$ref ) ) if( $ref && ref( $ref ) && $self->{debug} >= 4 );
      66        
314 304 100 66     839 return if( !$ref || !scalar( @$ref ) );
315             # We will store the additional blocks here, and we will dig deeper into them recursively.
316 34         77 my $has_additional_blocks = 0;
317            
318             # NOTE: Checking for consecutive try-catch block statements
319             # 2020-09-13: PPI will return 2 or more consecutive try-catch block as 1 statement
320             # It does not tell them apart, so we need to post process the result to effectively search within for possible for other try-catch blocks and update the @$ref array consequently
321             # Array to contain the new version of the $ref array.
322 34         71 my $alt_ref = [];
323 34 50       142 $self->_message( 3, "[blocks check level ${level}] Checking for consecutive try-catch blocks in ", scalar( @$ref ), " results found by PPI" ) if( $self->{debug} >= 3 );
324 34         104 foreach my $this ( @$ref )
325             {
326 132 50       1436 $self->_message( 3, "[blocks check level ${level}] Getting children from object '", overload::StrVal( $this ), "'" ) if( $self->{debug} >= 3 );
327 132 50       239 $self->_message( 3, "[blocks check level ${level}] Checking if following code has children" ) if( $self->{debug} >= 3 );
328             # my( @block_children ) = ( exists( $this->{children} ) && ref( $this->{children} // '' ) eq 'ARRAY' ) ? $this->children : ();
329             # Stringifying forces PPI to set the object children somehow
330 132         290 my $ct = "$this";
331 132         30048 my( @block_children ) = $this->children;
332 132 50       696 next if( !scalar( @block_children ) );
333 132         163 my $tmp_ref = [];
334             ## to contain all the nodes to move
335 132         176 my $tmp_nodes = [];
336 132         151 my $prev_sib = $block_children[0];
337 132         186 push( @$tmp_nodes, $prev_sib );
338 132         142 my $sib;
339 132         396 while( $sib = $prev_sib->next_sibling )
340             {
341             # We found a try-catch block. Move the buffer to $alt_ref
342 1715 100 100     25324 if( $sib->class eq 'PPI::Token::Word' && $sib->content eq 'try' )
343             {
344             # Look ahead for a block...
345 2         22 my $next = $sib->snext_sibling;
346 2 50 33     44 if( $next && $next->class eq 'PPI::Structure::Block' )
347             {
348 2         11 $has_additional_blocks++;
349 2 50       6 $self->_messagef( 3, "[blocks check level ${level}] Found consecutive try-block at line %d.", $sib->line_number ) if( $self->{debug} >= 3 );
350             # Push the previous statement $st to the stack $alt_ref
351 2 50       4 $self->_messagef( 3, "[blocks check level ${level}] Saving previous %d nodes collected.", scalar( @$tmp_nodes ) ) if( $self->{debug} >= 3 );
352 2         4 push( @$tmp_ref, $tmp_nodes );
353 2         3 $tmp_nodes = [];
354             }
355             }
356 1715         5202 push( @$tmp_nodes, $sib );
357 1715         2428 $prev_sib = $sib;
358             }
359 132 50       2054 $self->_messagef( 3, "[blocks check level ${level}] Saving last %d nodes collected.", scalar( @$tmp_nodes ) ) if( $self->{debug} >= 3 );
360 132         196 push( @$tmp_ref, $tmp_nodes );
361 132 50       242 $self->_messagef( 3, "[blocks check level ${level}] Found %d try-catch block(s) in initial PPI result.", scalar( @$tmp_ref ) ) if( $self->{debug} >= 3 );
362             # If we did find consecutive try-catch blocks, we add each of them after the nominal one and remove the nominal one after. The nominal one should be empty by then
363 132 100       303 if( scalar( @$tmp_ref ) > 1 )
364             {
365 2         2 my $last_obj = $this;
366 2         4 my $spaces = [];
367 2         3 foreach my $arr ( @$tmp_ref )
368             {
369 4 50       55 $self->_message( 3, "[blocks check level ${level}] Adding statement block with ", scalar( @$arr ), " children after one at line ", $last_obj->line_number, ": '", substr( $last_obj, 0, 255 ), "'" ) if( $self->{debug} >= 3 );
370             # 2021-06-05 (Jacques): Fixing issue No. 2:
371             # Find the last block that belongs to us
372 4 50       16 $self->_message( 4, "[blocks check level ${level}] Checking first level objects collected." ) if( $self->{debug} >= 4 );
373 4         5 my $last_control = '';
374 4         4 my $last_block;
375 4         5 my $last = {};
376 4         4 foreach my $o ( @$arr )
377             {
378 57 100 100     159 if( $o->class eq 'PPI::Structure::Block' && $last_control )
    100          
379             {
380 8         34 $last->{block} = $o;
381 8         9 $last->{control} = $last_control;
382 8         11 $last_control = '';
383             }
384             elsif( $o->class eq 'PPI::Token::Word' )
385             {
386 11         52 my $ct = $o->content;
387 11 100 100     57 if( $ct eq 'try' || $ct eq 'catch' || $ct eq 'finally' )
      66        
388             {
389 8         12 $last_control = $o;
390             }
391             }
392             }
393            
394             # Get the trailing insignificant elements at the end of the statement and move them out of the statement
395 4         16 my $insignificants = [];
396 4         8 while( scalar( @$arr ) > 0 )
397             {
398 25         564 my $o = $arr->[-1];
399             # 2021-06-05 (Jacques): We don't just look for the last block, because
400             # that was making a bad assumption that the last trailing block would be our
401             # try-catch block.
402             # Following issue No. 2 reported with a trailing anonymous subroutine,
403             # We remove everything up until our known last block that belongs to us.
404 25 100 100     38 last if( $o->class eq 'PPI::Structure::Block' && Scalar::Util::refaddr( $o ) eq Scalar::Util::refaddr( $last->{block} ) );
405 21         82 unshift( @$insignificants, pop( @$arr )->remove );
406             }
407 4 50       26 $self->_messagef( 3, "[blocks check level ${level}] %d insignificant objects found.", scalar( @$insignificants ) ) if( $self->{debug} >= 3 );
408            
409 4         12 my $new_code = join( '', map( "$_", @$arr ) );
410 4 50       482 $self->_message( 3, "[blocks check level ${level}] Parsing new code to extract statement:\n${new_code}" ) if( $self->{debug} >= 3 );
411             # 2021-06-05 (Jacques): It is unfortunately difficult to simply add a new PPI::Statement object
412             # Instead, we have PPI parse our new code and we grab what we need.
413 4         16 my $new_block = PPI::Document->new( \$new_code, readonly => 1 );
414             # my $st = $new_block->{children}->[0]->remove;
415 4         14892 my $st;
416 4         8 for( my $i = 0; $i < scalar( @{$new_block->{children}} ); $i++ )
  4         13  
417             {
418 4 50 33     24 if( Scalar::Util::blessed( $new_block->{children}->[$i] ) &&
419             $new_block->{children}->[$i]->isa( 'PPI::Statement' ) )
420             {
421 4         16 $st = $new_block->{children}->[$i]->remove;
422 4         159 last;
423             }
424             }
425            
426 4         42 foreach my $o ( @$arr )
427             {
428             # We remove the object from its parent, now that it has become useless
429 36   50     1093 my $old = $o->remove || die( "Unable to remove element '$o'\n" );
430             }
431 4         124 my $err = '';
432 4 0       15 $self->_messagef( 3, "[blocks check level ${level}] Adding the statement object after last object '%s' of class '%s' with parent with class '%s'.", Scalar::Util::refaddr( $last_obj ), ( defined( $last_obj ) ? $last_obj->class : 'undefined class' ), ( defined( $last_obj ) ? $last_obj->parent->class : 'undefined parent class' ) ) if( $self->{debug} >= 3 );
    0          
    50          
433             # my $rc = $last_obj->insert_after( $st );
434 4         6 my $rc;
435 4 100       9 if( $last_obj->class eq 'PPI::Token::Whitespace' )
    50          
436             {
437 2         13 $rc = $last_obj->__insert_after( $st );
438             }
439             elsif( $last_obj->class eq 'PPI::Token::Comment' )
440             {
441             # $rc = $last_obj->parent->__insert_after_child( $last_obj, $st );
442 0         0 $rc = $last_obj->__insert_after( $st );
443             }
444             else
445             {
446 2         17 $rc = $last_obj->insert_after( $st );
447             }
448            
449 4 50       162 if( !defined( $rc ) )
    50          
450             {
451 0         0 $err = sprintf( 'Object to be added after last try-block statement must be a PPI::Element. Class provided is \"%s\".', $st->class );
452             }
453             elsif( !$rc )
454             {
455 0         0 my $requires;
456 0 0 0     0 if( $last_obj->isa( 'PPI::Structure' ) ||
    0          
457             $last_obj->isa( 'PPI::Token' ) )
458             {
459 0         0 $requires = 'PPI::Structure or PPI::Token';
460             }
461             elsif( $last_obj->isa( 'PPI::Statement' ) )
462             {
463 0         0 $requires = 'PPI::Statement or PPI::Token';
464             }
465 0         0 $err = sprintf( "Object of class \"%s\" could not be added after object with address '%s' and of class '%s' with parent '%s' with class '%s': '$last_obj'. The object of class '%s' must be a ${requires} object.", $st->class, Scalar::Util::refaddr( $last_obj ), $last_obj->class, Scalar::Util::refaddr( $last_obj->parent ), $last_obj->parent->class, $st->class );
466             }
467             else
468             {
469 4         5 $last_obj = $st;
470 4 50       7 if( scalar( @$insignificants ) )
471             {
472 4 50       10 $self->_messagef( 4, "[blocks check level ${level}] Adding %d trailing insignificant objects after last element of class '%s'", scalar( @$insignificants ), $last_obj->class ) if( $self->{debug} >= 4 );
473 4         13 foreach my $o ( @$insignificants )
474             {
475 21 50       32 $self->_messagef( 4, "[blocks check level ${level}] Adding trailing insignificant object of class '%s' after last element of class '%s'", $o->class, $last_obj->class ) if( $self->{debug} >= 4 );
476             # printf( STDERR "Inserting object '%s' (%s) of type '%s' after object '%s' (%s) of type %s who has parent '%s' of type '%s'\n", overload::StrVal( $o ), Scalar::Util::refaddr( $o ), ref( $o ), overload::StrVal( $last_obj), Scalar::Util::refaddr( $last_obj ), ref( $last_obj ), overload::StrVal( $last_obj->parent ), ref( $last_obj->parent ) );
477             CORE::eval
478 21         22 {
479             $rc = $last_obj->insert_after( $o ) ||
480             do
481 21   33     81 {
482             warn( "Failed to insert object of class '", $o->class, "' before last object of class '", $st->class, "'\n" ) if( $self->{debug} );
483             };
484             };
485 21 50       825 if( $@ )
    50          
    50          
486             {
487 0 0       0 if( ref( $o ) )
488             {
489 0 0       0 warn( "Failed to insert object of class '", $o->class, "' before last object of class '", $st->class, "': $@\n" ) if( $self->{debug} );
490             }
491             else
492             {
493 0 0       0 warn( "Was expecting an object to insert before last object of class '", $st->class, "', but instead got '$o': $@\n" ) if( $self->{debug} );
494             }
495             }
496             elsif( !defined( $rc ) )
497             {
498 0 0       0 warn( sprintf( 'Object to be added after last try-block statement must be a PPI::Element. Class provided is \"%s\".', $o->class ) ) if( $self->{debug} );
499             }
500             elsif( !$rc )
501             {
502 0 0       0 warn( sprintf( "Object of class \"%s\" could not be added after object of class '%s': '$last_obj'.", $o->class, $last_obj->class ) ) if( $self->{debug} );
503             }
504             # printf( STDERR "Object inserted '%s' (%s) of class '%s' now has parent '%s' (%s) of class '%s'\n", overload::StrVal( $o ), Scalar::Util::refaddr( $o ), ref( $o ), overload::StrVal( $o->parent ), Scalar::Util::refaddr( $o->parent ), ref( $o->parent ) );
505 21 50       34 $o->parent( $last_obj->parent ) if( !$o->parent );
506 21         93 $last_obj = $o;
507             }
508             }
509             }
510 4 50       10 die( $err ) if( length( $err ) );
511 4         19 push( @$alt_ref, $st );
512             }
513 2         54 my $parent = $this->parent;
514             # Completely destroy it; it is now replaced by our updated code
515 2         17 $this->delete;
516             }
517             else
518             {
519 130         420 push( @$alt_ref, $this );
520             }
521             }
522 34 50       321 $self->_messagef( 3, "[blocks check level ${level}] Results found increased from %d to %d results.", scalar( @$ref ), scalar( @$alt_ref ) ) if( $self->{debug} >= 3 );
523              
524 34 100       107 if( $has_additional_blocks )
525             {
526 1 50       3 $self->_message( 3, "[blocks check level ${level}] Consecutive block search now found ", scalar( @$alt_ref ), " try blocks." ) if( $self->{debug} >= 3 );
527 1         2 my $more = [];
528 1         3 foreach my $el ( @$alt_ref )
529             {
530 4         6 push( @$more, $el );
531 4         26 my $rv = $check_consecutive_blocks->( $el, ( $level + 1 ) );
532 4 0 50     9 if( ref( $rv ) && scalar( @$rv ) )
533             {
534 0         0 push( @$more, @$rv );
535             }
536             }
537 1         3 return( $more );
538             }
539             else
540             {
541 33         92 return( $ref );
542             }
543 300         4927 };
544 300         582 my $ref = $check_consecutive_blocks->( $elem => 0 );
545 300 100 66     1250 return if( !$ref || !scalar( @$ref ) );
546            
547 34 50       140 $self->_messagef( 3, "Implementing try-catch for %d try-catch blocks.", scalar( @$ref ) ) if( $self->{debug} >= 3 );
548             # NOTE: processing implementation of our try-catch
549 34         100 foreach my $this ( @$ref )
550             {
551 134 50       16547 $self->_browse( $this ) if( $self->{debug} >= 5 );
552 134         489 my $element_before_try = $this->previous_sibling;
553 134         3414 my $try_block_ref = [];
554             # Contains the finally block reference
555 134         161 my $fin_block_ref = [];
556 134         162 my $nodes_to_replace = [];
557 134         147 my $catch_def = [];
558             # Replacement data
559 134         157 my $repl = [];
560 134         167 my $catch_repl = [];
561            
562             # There is a weird bug in PPI that I have searched but could not find
563             # If I don't attempt to stringify, I may end up with a PPI::Statement object that has no children as an array reference
564 134         247 my $ct = "$this";
565 134         30106 my( @block_children ) = $this->children;
566 134 100       838 next if( !scalar( @block_children ) );
567 129         168 my $prev_sib = $block_children[0];
568 129         235 push( @$nodes_to_replace, $prev_sib );
569 129         161 my( $inside_catch, $inside_finally );
570 129         171 my $temp = {};
571             # Buffer of nodes found in between blocks
572 129         130 my $buff = [];
573             # Temporary new line counter between try-catch block so we can reproduce it and ensure proper reporting of error line
574 129         137 my $nl_counter = 0;
575 129         149 my $sib;
576 129         296 while( $sib = $prev_sib->next_sibling )
577             {
578 1632 100 100     23719 if( !scalar( @$try_block_ref ) )
    100 100        
    100 100        
    100          
    100          
    100          
579             {
580 335 100 66     518 if( $sib->class eq 'PPI::Structure::Block' &&
    100 66        
      100        
581             substr( "$sib", 0, 1 ) eq "\{" &&
582             substr( "$sib", -1, 1 ) eq "\}" )
583             {
584 127         23959 $temp->{block} = $sib;
585 127         222 push( @$try_block_ref, $temp );
586 127         380 $temp = {};
587 127 50       337 if( scalar( @$buff ) )
588             {
589 127         228 push( @$nodes_to_replace, @$buff );
590 127         415 $buff = [];
591             }
592 127         355 push( @$nodes_to_replace, $sib );
593             }
594             elsif( $sib->class eq 'PPI::Token::Whitespace' && $sib->content =~ /[\015\012]+/ )
595             {
596 79         1211 $temp->{open_curly_nl}++;
597 79         178 push( @$buff, $sib );
598             }
599             # We skip anything else until we find that try block
600             else
601             {
602 129         1263 push( @$buff, $sib );
603 129         156 $prev_sib = $sib;
604 129         274 next;
605             }
606             }
607             elsif( $sib->class eq 'PPI::Token::Word' && $sib->content eq 'catch' )
608             {
609 143         804 $inside_catch++;
610 143 100       246 if( scalar( @$buff ) )
611             {
612 139         260 push( @$nodes_to_replace, @$buff );
613 139         169 $buff = [];
614             }
615 143         227 push( @$nodes_to_replace, $sib );
616             }
617             elsif( $inside_catch )
618             {
619             # This is the catch list as in catch( $e ) or catch( Exception $e )
620 501 100 66     1576 if( $sib->class eq 'PPI::Structure::List' )
    100          
    100          
621             {
622 109         352 $temp->{var} = $sib;
623 109         166 push( @$nodes_to_replace, $sib );
624             }
625             elsif( $sib->class eq 'PPI::Structure::Block' )
626             {
627 143         607 $temp->{block} = $sib;
628 143 100       226 if( scalar( @$catch_def ) )
629             {
630 24         32 $catch_def->[-1]->{close_curly_nl} = $nl_counter;
631             }
632             else
633             {
634 119         200 $try_block_ref->[-1]->{close_curly_nl} = $nl_counter;
635             }
636 143         158 $nl_counter = 0;
637 143         195 push( @$catch_def, $temp );
638 143         171 $temp = {};
639 143         165 $inside_catch = 0;
640 143         229 push( @$nodes_to_replace, $sib );
641             }
642             elsif( $sib->class eq 'PPI::Token::Whitespace' && $sib->content =~ /[\015\012]+/ )
643             {
644 98         1054 $temp->{open_curly_nl}++;
645 98         165 push( @$nodes_to_replace, $sib );
646             }
647             else
648             {
649 151         1336 push( @$nodes_to_replace, $sib );
650             }
651             }
652             elsif( $sib->class eq 'PPI::Token::Word' && $sib->content eq 'finally' )
653             {
654 13         155 $inside_finally++;
655 13 50       23 if( scalar( @$buff ) )
656             {
657 13         44 push( @$nodes_to_replace, @$buff );
658 13         16 $buff = [];
659             }
660 13         27 push( @$nodes_to_replace, $sib );
661             }
662             elsif( $inside_finally )
663             {
664             # We could ignore it, but it is best to let the developer know in case he/she counts on it somehow
665 27 50 66     203 if( $sib->class eq 'PPI::Structure::List' )
    100          
    100          
666             {
667 0         0 die( sprintf( "the finally block does not accept any list parameters at line %d\n", $sib->line_number ) );
668             }
669             elsif( $sib->class eq 'PPI::Structure::Block' )
670             {
671 13         64 $temp->{block} = $sib;
672 13 50       40 if( scalar( @$fin_block_ref ) )
    100          
673             {
674 0         0 die( sprintf( "There can only be one finally block at line %d\n", $sib->line_number ) );
675             }
676             elsif( scalar( @$catch_def ) )
677             {
678 7         10 $catch_def->[-1]->{close_curly_nl} = $nl_counter;
679             }
680             else
681             {
682 6         12 $try_block_ref->[-1]->{close_curly_nl} = $nl_counter;
683             }
684 13         23 $nl_counter = 0;
685 13         17 push( @$fin_block_ref, $temp );
686 13         16 $temp = {};
687 13         12 $inside_finally = 0;
688 13         19 push( @$nodes_to_replace, $sib );
689             }
690             elsif( $sib->class eq 'PPI::Token::Whitespace' && $sib->content =~ /[\015\012]+/ )
691             {
692 1         15 $temp->{open_curly_nl}++;
693 1         2 push( @$nodes_to_replace, $sib );
694             }
695             else
696             {
697 13         157 push( @$nodes_to_replace, $sib );
698             }
699             }
700             # Check for new lines after closing blocks. The ones before, we can account for them in each section above
701             # We could have } catch {
702             # or
703             # }
704             # catch {
705             # etc.
706             # This could also be new lines following the last catch block
707             elsif( $sib->class eq 'PPI::Token::Whitespace' && $sib->content =~ /[\015\012]+/ )
708             {
709 211         2863 $nl_counter++;
710 211         290 push( @$buff, $sib );
711             }
712             else
713             {
714 402         3456 push( @$buff, $sib );
715             }
716 1503         2641 $prev_sib = $sib;
717             }
718            
719 129 100       2066 my $has_catch_clause = scalar( @$catch_def ) > 0 ? 1 : 0;
720            
721             # NOTE: processing finally block
722             # Prepare the finally block, if any, and add it below at the appropriate place
723 129         188 my $fin_block = '';
724 129 100       285 if( scalar( @$fin_block_ref ) )
725             {
726 13         19 my $fin_def = $fin_block_ref->[0];
727 13         57 $self->_process_sub_token( $fin_def->{block} );
728 13         41 $self->_process_caller( finally => $fin_def->{block} );
729             ## my $finally_block = $fin_def->{block}->content;
730 13         52 my $finally_block = $self->_serialize( $fin_def->{block} );
731 13         166 $finally_block =~ s/^\{[[:blank:]]*|[[:blank:]]*\}$//gs;
732 13         23 $fin_block = <
733             CORE::local \$Nice::Try::FINALLY = Nice\::Try\::ScopeGuard->_new(sub __FINALLY_OPEN_NL__{ __BLOCK_PLACEHOLDER__ __FINALLY__CLOSE_NL__}, [\@_], \$Nice::Try::CATCH_DIED);
734             EOT
735 13 50       74 $fin_block =~ s/\n/ /gs unless( $self->{debug_code} );
736 13         41 $fin_block =~ s/__BLOCK_PLACEHOLDER__/$finally_block/gs;
737 13 100       36 if( $fin_def->{open_curly_nl} )
738             {
739 1         3 $fin_block =~ s/__FINALLY_OPEN_NL__/"\n" x $fin_def->{open_curly_nl}/gex;
  1         5  
740             }
741             else
742             {
743 12         58 $fin_block =~ s/__FINALLY_OPEN_NL__//gs;
744             }
745 13 50       37 if( $fin_def->{close_curly_nl} )
746             {
747 0         0 $fin_block =~ s/__FINALLY__CLOSE_NL__/"\n" x $fin_def->{close_curly_nl}/gex;
  0         0  
748             }
749             else
750             {
751 13         41 $fin_block =~ s/__FINALLY__CLOSE_NL__//gs;
752             }
753             }
754              
755             # NOTE: processing try blocks
756             # Found any try block at all?
757 129 100       237 if( scalar( @$try_block_ref ) )
758             {
759 127         174 my $try_def = $try_block_ref->[0];
760            
761             # Checking for embedded try-catch
762 127 100       1276 if( my $emb = $self->_parse( $try_def->{block} ) )
763             {
764 3         8 $try_def->{block} = $emb;
765             }
766            
767 127         447 $self->_process_loop_breaks( $try_def->{block} );
768             # NOTE: process, in try block, __SUB__ which reference current sub since perl v5.16
769 127         985 $self->_process_sub_token( $try_def->{block} );
770 127         349 $self->_process_caller( try => $try_def->{block} );
771            
772             # my $try_block = $try_def->{block}->content;
773 127         336 my $try_block = $self->_serialize( $try_def->{block} );
774 127         12235 $try_block =~ s/^\{[[:blank:]]*|[[:blank:]]*\}$//gs;
775            
776 127         291 my $try_sub = <
777             CORE::local \$Nice::Try::THREADED;
778             if( \$INC{'threads.pm'} && !CORE::exists( \$INC{'forks.pm'} ) )
779             {
780             \$Nice::Try::THREADED = threads->tid;
781             }
782             CORE::local \$Nice::Try::WANT;
783             CORE::local ( \$Nice::Try::EXCEPTION, \$Nice::Try::DIED, \$Nice::Try::CATCH_DIED, \@Nice::Try::RETVAL, \@Nice::Try::VOID, \$Nice::Try::RETURN );
784             CORE::local \$Nice::Try::WANTARRAY = CORE::wantarray;
785             CORE::local \$Nice::Try::RETURN = sub
786             {
787             \$Nice::Try::NEED_TO_RETURN++;
788             return( wantarray() ? \@_ : \$_[0] );
789             };
790             EOT
791 127 50 33     812 if( !$self->{is_tied} && !$self->{dont_want} && !$self->{is_overloaded} )
      33        
792             {
793 127         484 $try_sub .= <
794             CORE::local \$Nice::Try::NOOP = sub
795             {
796             my \$ref = CORE::shift( \@_ );
797             CORE::return(sub{ CORE::return( \$ref ) });
798             };
799             if( CORE::defined( \$Nice::Try::WANTARRAY ) && !\$Nice::Try::THREADED && !( !CORE::length( [CORE::caller]->[1] ) && [CORE::caller(1)]->[3] eq '(eval)' ) )
800             {
801             CORE::eval "\\\$Nice::Try::WANT = Wanted::want( 'LIST' )
802             ? 'LIST'
803             : Wanted::want( 'HASH' )
804             ? 'HASH'
805             : Wanted::want( 'ARRAY' )
806             ? 'ARRAY'
807             : Wanted::want( 'OBJECT' )
808             ? 'OBJECT'
809             : Wanted::want( 'CODE' )
810             ? 'CODE'
811             : Wanted::want( 'REFSCALAR' )
812             ? 'REFSCALAR'
813             : Wanted::want( 'BOOL' )
814             ? 'BOOLEAN'
815             : Wanted::want( 'GLOB' )
816             ? 'GLOB'
817             : Wanted::want( 'SCALAR' )
818             ? 'SCALAR'
819             : Wanted::want( 'VOID' )
820             ? 'VOID'
821             : '';";
822             undef( \$Nice::Try::WANT ) if( \$\@ );
823             }
824             EOT
825             }
826 127         805 $try_sub .= <
827             CORE::local \$Nice::Try::TRY = CORE::sub
828             {
829             \@Nice::Try::LAST_VAL = CORE::do __TRY_OPEN_NL__{ __BLOCK_PLACEHOLDER__ };__TRY__CLOSE_NL__
830             CORE::return( \@Nice::Try::LAST_VAL ) if( !CORE::defined( \$Nice::Try::WANTARRAY ) && CORE::scalar( \@Nice::Try::LAST_VAL ) );
831             \$Nice::Try::VOID[0] = \$Nice::Try::SENTINEL;
832             if( CORE::defined( \$Nice::Try::WANT ) && CORE::length( \$Nice::Try::WANT ) )
833             {
834             if( \$Nice::Try::WANT eq 'OBJECT' )
835             {
836             CORE::return( Nice::Try::ObjectContext->new( sub{ \$Nice::Try::VOID[0] } )->callback() );
837             }
838             elsif( \$Nice::Try::WANT eq 'CODE' )
839             {
840             CORE::return( sub{ \$Nice::Try::VOID[0] } );
841             }
842             elsif( \$Nice::Try::WANT eq 'HASH' )
843             {
844             CORE::return( { dummy => \$Nice::Try::VOID[0] } );
845             }
846             elsif( \$Nice::Try::WANT eq 'ARRAY' )
847             {
848             CORE::return( [ \$Nice::Try::VOID[0] ] );
849             }
850             elsif( \$Nice::Try::WANT eq 'REFSCALAR' )
851             {
852             CORE::return( \\\$Nice::Try::VOID[0] );
853             }
854             elsif( \$Nice::Try::WANT eq 'GLOB' )
855             {
856             CORE::return( \*{ \$Nice::Try::VOID[0] } );
857             }
858             elsif( \$Nice::Try::WANT eq 'LIST' )
859             {
860             CORE::return( \$Nice::Try::VOID[0] );
861             }
862             elsif( \$Nice::Try::WANT eq 'BOOLEAN' )
863             {
864             CORE::return( \$Nice::Try::VOID[0] );
865             }
866             elsif( \$Nice::Try::WANT eq 'VOID' )
867             {
868             CORE::return( \$Nice::Try::VOID[0] );
869             }
870             elsif( \$Nice::Try::WANT eq 'SCALAR' )
871             {
872             CORE::return( \$Nice::Try::VOID[0] );
873             }
874             }
875             else
876             {
877             if( \$Nice::Try::WANTARRAY )
878             {
879             CORE::return( \$Nice::Try::VOID[0] );
880             }
881             elsif( defined( \$Nice::Try::WANTARRAY ) )
882             {
883             CORE::return( \$Nice::Try::VOID[0] );
884             }
885             else
886             {
887             CORE::return( \$Nice::Try::VOID[0] );
888             }
889             }
890             };
891             __FINALLY_BLOCK__ CORE::local \$Nice::Try::HAS_CATCH = $has_catch_clause;
892             EOT
893 127         349 $try_sub .= <
894             {
895             CORE::local \$\@;
896             CORE::eval
897             {
898             EOT
899 127 50       290 if( $] >= 5.036000 )
900             {
901 127         192 $try_sub .= <
902             no warnings 'experimental::args_array_with_signatures';
903             EOT
904             }
905              
906 127         360 $try_sub .= <
907             if( CORE::defined( \$Nice::Try::WANT ) && CORE::length( \$Nice::Try::WANT ) )
908             {
909             if( \$Nice::Try::WANT eq 'OBJECT' )
910             {
911             \$Nice::Try::RETVAL[0] = Nice::Try::ObjectContext->new( &\$Nice::Try::TRY )->callback();
912             }
913             elsif( \$Nice::Try::WANT eq 'CODE' )
914             {
915             \$Nice::Try::RETVAL[0] = \$Nice::Try::NOOP->( &\$Nice::Try::TRY )->();
916             }
917             elsif( \$Nice::Try::WANT eq 'HASH' )
918             {
919             \@Nice::Try::RETVAL = \%{ &\$Nice::Try::TRY };
920             }
921             elsif( \$Nice::Try::WANT eq 'ARRAY' )
922             {
923             \@Nice::Try::RETVAL = \@{ &\$Nice::Try::TRY };
924             }
925             elsif( \$Nice::Try::WANT eq 'REFSCALAR' )
926             {
927             \$Nice::Try::RETVAL[0] = \${&\$Nice::Try::TRY};
928             }
929             elsif( \$Nice::Try::WANT eq 'GLOB' )
930             {
931             \$Nice::Try::RETVAL[0] = \*{ &\$Nice::Try::TRY };
932             }
933             elsif( \$Nice::Try::WANT eq 'LIST' )
934             {
935             \@Nice::Try::RETVAL = &\$Nice::Try::TRY;
936             }
937             elsif( \$Nice::Try::WANT eq 'BOOLEAN' )
938             {
939             \$Nice::Try::RETVAL[0] = &\$Nice::Try::TRY ? 1 : 0;
940             \$Nice::Try::RETVAL[0] = \$Nice::Try::VOID[0] if( scalar( \@Nice::Try::VOID ) );
941             }
942             elsif( \$Nice::Try::WANT eq 'VOID' )
943             {
944             \@Nice::Try::VOID = &\$Nice::Try::TRY;
945             }
946             elsif( \$Nice::Try::WANT eq 'SCALAR' )
947             {
948             \$Nice::Try::RETVAL[0] = &\$Nice::Try::TRY;
949             }
950             }
951             else
952             {
953             if( \$Nice::Try::WANTARRAY )
954             {
955             \@Nice::Try::RETVAL = &\$Nice::Try::TRY;
956             }
957             elsif( defined( \$Nice::Try::WANTARRAY ) )
958             {
959             \$Nice::Try::RETVAL[0] = &\$Nice::Try::TRY;
960             }
961             else
962             {
963             &\$Nice::Try::TRY;
964             \$Nice::Try::RETVAL[0] = \$Nice::Try::LAST_VAL if( CORE::defined( \$Nice::Try::LAST_VAL ) );
965             }
966             }
967             };
968             \$Nice::Try::DIED = CORE::length( \$\@ ) ? 1 : 0;
969             \$\@ =~ s/[\\015\\012]+\$//g unless( Scalar::Util::blessed( \$\@ ) );
970             \$Nice::Try::EXCEPTION = \$\@;
971             };
972              
973             EOT
974 127 50       4921 $try_sub =~ s/\n/ /gs unless( $self->{debug_code} );
975 127         1005 $try_sub =~ s/__BLOCK_PLACEHOLDER__/$try_block/gs;
976 127 100       326 if( $try_def->{open_curly_nl} )
977             {
978 79         387 $try_sub =~ s/__TRY_OPEN_NL__/"\n" x $try_def->{open_curly_nl}/gex;
  79         529  
979             }
980             else
981             {
982 48         394 $try_sub =~ s/__TRY_OPEN_NL__//gs;
983             }
984 127 100       271 if( $try_def->{close_curly_nl} )
985             {
986 115         531 $try_sub =~ s/__TRY__CLOSE_NL__/"\n" x $try_def->{close_curly_nl}/gex;
  115         672  
987             }
988             else
989             {
990 12         108 $try_sub =~ s/__TRY__CLOSE_NL__//gs;
991             }
992            
993             # Add the final block if there is no catch block, otherwise the final block comes at the end below
994 127 100       262 if( !$has_catch_clause )
995             {
996 8         52 $try_sub =~ s/__FINALLY_BLOCK__/$fin_block/gs;
997             }
998             # If it should not be here, remove the placeholder
999             else
1000             {
1001 119         805 $try_sub =~ s/__FINALLY_BLOCK__//gs;
1002             }
1003 127         492 push( @$repl, $try_sub );
1004             }
1005             else
1006             {
1007 2         6 next;
1008             }
1009            
1010             # NOTE: processing catch block
1011 127         204 my $if_start = <
1012             if( \$Nice::Try::DIED )
1013             {
1014             if( \$Nice::Try::HAS_CATCH )
1015             {
1016             EOT
1017 127 50       272 if( $] >= 5.036000 )
1018             {
1019 127         219 $if_start .= <
1020             no warnings 'experimental::args_array_with_signatures';
1021             EOT
1022             }
1023 127 50       734 $if_start =~ s/\n/ /gs unless( $self->{debug_code} );
1024 127         228 push( @$catch_repl, $if_start );
1025 127 100       261 if( scalar( @$catch_def ) )
1026             {
1027 119         158 my $total_catch = scalar( @$catch_def );
1028             # To count how many times we have else's – obviously we should not have more than 1
1029 119         135 my $else = 0;
1030 119         293 for( my $i = 0; $i < $total_catch; $i++ )
1031             {
1032 143         202 my $cdef = $catch_def->[$i];
1033             # Checking for embedded try-catch
1034 143 100       413 if( my $emb = $self->_parse( $cdef->{block} ) )
1035             {
1036 1         2 $cdef->{block} = $emb;
1037             }
1038             # NOTE: process, in catch block, __SUB__ which reference current sub since perl v5.16
1039 143         442 $self->_process_sub_token( $cdef->{block} );
1040            
1041 143 100       336 if( $cdef->{var} )
1042             {
1043 109         391 $cdef->{var}->prune( 'PPI::Token::Comment' );
1044 109         30063 $cdef->{var}->prune( 'PPI::Token::Pod' );
1045 109 50       25318 $self->_messagef( 3, "Catch assignment is: '%s'", $cdef->{var}->content ) if( $self->{debug} >= 3 );
1046             # my $str = $cdef->{var}->content;
1047 109         294 my $str = $self->_serialize( $cdef->{var} );
1048 109         837 $str =~ s/^\([[:blank:]\h\v]*|[[:blank:]]*\)$//g;
1049             # My::Exception $e
1050 109 100       610 if( $str =~ /^(\S+)[[:blank:]\h\v]+(\$\S+)$/ )
    100          
    100          
    100          
    100          
1051             {
1052 15         99 @$cdef{qw( class var )} = ( $1, $2 );
1053             }
1054             elsif( $str =~ /^(\S+)[[:blank:]\h\v]+(\$\S+)[[:blank:]\h\v]+where[[:blank:]\h\v]+\{(.*?)\}$/ )
1055             {
1056 4         43 @$cdef{qw( class var where )} = ( $1, $2, $3 );
1057             }
1058             elsif( $str =~ /^(\$\S+)[[:blank:]\h\v]+where[[:blank:]\h\v]+\{(.*?)\}$/ )
1059             {
1060 1         5 @$cdef{qw( var where )} = ( $1, $2 );
1061             }
1062             elsif( $str =~ /^(\$\S+)[[:blank:]\h\v]+isa[[:blank:]\h\v]+(\S+)(?:[[:blank:]\h\v]+where[[:blank:]\h\v]+\{(.*?)\})?$/ )
1063             {
1064 9         50 @$cdef{qw( var class where )} = ( $1, $2, $3 );
1065             }
1066             elsif( $str =~ /^(?\$\S+)[[:blank:]\h\v]+isa[[:blank:]\h\v]*\([[:blank:]\h\v]*(?["'])?(?[^[:blank:]\h\v\'\"\)]+)\k{quote}[[:blank:]\h\v]*\)(?:[[:blank:]\h\v]+where[[:blank:]\h\v]+\{(?.*?)\})?$/ )
1067             {
1068 2         26 @$cdef{qw( var class where )} = ( $+{var}, $+{class}, $+{where} );
1069             }
1070             else
1071             {
1072 78         164 $cdef->{var} = $str;
1073             }
1074             }
1075             else
1076             {
1077             # $self->_message( 3, "No Catch assignment found" ) if( $self->{debug} >= 3 );
1078             }
1079            
1080 143 50       410 if( $cdef->{block} )
1081             {
1082             # $self->_messagef( 3, "Catch block is:\n%s", $cdef->{block}->content ) if( $self->{debug} >= 3 );
1083             }
1084             else
1085             {
1086             # $self->_message( 3, "No catch block found!" ) if( $self->{debug} >= 3 );
1087 0         0 next;
1088             }
1089 143         167 my $cond;
1090 143 100       265 if( $i == 0 )
    100          
1091             {
1092 119         180 $cond = 'if';
1093             }
1094             elsif( $i == ( $total_catch - 1 ) )
1095             {
1096             $cond = $total_catch == 1
1097             ? 'if'
1098             : $cdef->{class}
1099 11 100       35 ? 'elsif'
    50          
1100             : 'else';
1101             }
1102             else
1103             {
1104 13         16 $cond = 'elsif';
1105             }
1106             # my $block = $cdef->{block}->content;
1107 143         372 $self->_process_loop_breaks( $cdef->{block} );
1108 143         1347 $self->_process_sub_token( $cdef->{block} );
1109 143         422 $self->_process_caller( catch => $cdef->{block} );
1110 143         334 my $block = $self->_serialize( $cdef->{block} );
1111 143         4056 $block =~ s/^\{[[:blank:]]*|[[:blank:]]*\}$//gs;
1112 143         226 my $catch_section = '';
1113 143         358 my $catch_code = <
1114             CORE::local \$Nice::Try::CATCH = CORE::sub
1115             {
1116             \@Nice::Try::LAST_VAL = CORE::do __CATCH_OPEN_NL__{ __BLOCK_PLACEHOLDER__ }; __CATCH__CLOSE_NL__
1117             CORE::return( \@Nice::Try::LAST_VAL ) if( !CORE::defined( \$Nice::Try::WANTARRAY ) && CORE::scalar( \@Nice::Try::LAST_VAL ) );
1118             CORE::return \$Nice::Try::SENTINEL;
1119             };
1120            
1121             eval
1122             {
1123             local \$\@ = \$Nice::Try::EXCEPTION;
1124             if( CORE::defined( \$Nice::Try::WANT ) && CORE::length( \$Nice::Try::WANT ) )
1125             {
1126             if( \$Nice::Try::WANT eq 'OBJECT' )
1127             {
1128             \$Nice::Try::RETVAL[0] = Nice::Try::ObjectContext->new( \&\$Nice::Try::CATCH )->callback();
1129             }
1130             elsif( \$Nice::Try::WANT eq 'CODE' )
1131             {
1132             \$Nice::Try::RETVAL[0] = \$Nice::Try::NOOP->( \&\$Nice::Try::CATCH )->();
1133             }
1134             elsif( \$Nice::Try::WANT eq 'HASH' )
1135             {
1136             \@Nice::Try::RETVAL = \%{ \&\$Nice::Try::CATCH };
1137             }
1138             elsif( \$Nice::Try::WANT eq 'ARRAY' )
1139             {
1140             \@Nice::Try::RETVAL = \@{ \&\$Nice::Try::CATCH };
1141             }
1142             elsif( \$Nice::Try::WANT eq 'REFSCALAR' )
1143             {
1144             \$Nice::Try::RETVAL[0] = \${\&\$Nice::Try::CATCH};
1145             }
1146             elsif( \$Nice::Try::WANT eq 'GLOB' )
1147             {
1148             \$Nice::Try::RETVAL[0] = \*{ \&\$Nice::Try::CATCH };
1149             }
1150             elsif( \$Nice::Try::WANT eq 'LIST' )
1151             {
1152             \@Nice::Try::RETVAL = \&\$Nice::Try::CATCH;
1153             }
1154             elsif( \$Nice::Try::WANT eq 'BOOLEAN' )
1155             {
1156             my \$this = \&\$Nice::Try::CATCH ? 1 : 0;
1157             \$Nice::Try::RETVAL[0] = \$Nice::Try::VOID[0] if( scalar( \@Nice::Try::VOID ) );
1158             }
1159             elsif( \$Nice::Try::WANT eq 'VOID' )
1160             {
1161             \@Nice::Try::VOID = \&\$Nice::Try::CATCH;
1162             }
1163             elsif( \$Nice::Try::WANT eq 'SCALAR' )
1164             {
1165             \$Nice::Try::RETVAL[0] = \&\$Nice::Try::CATCH;
1166             }
1167             }
1168             else
1169             {
1170             if( \$Nice::Try::WANTARRAY )
1171             {
1172             \@Nice::Try::RETVAL = \&\$Nice::Try::CATCH;
1173             }
1174             elsif( defined( \$Nice::Try::WANTARRAY ) )
1175             {
1176             \$Nice::Try::RETVAL[0] = \&\$Nice::Try::CATCH;
1177             }
1178             else
1179             {
1180             \&\$Nice::Try::CATCH;
1181             }
1182             }
1183             };
1184             \$Nice::Try::CATCH_DIED = \$\@ if( \$\@ );
1185             EOT
1186 143 100       306 if( $cdef->{var} )
1187             {
1188 109         170 my $ex_var = $cdef->{var};
1189 109 100 100     497 if( $cdef->{class} && $cdef->{where} )
    100          
    100          
1190             {
1191 12         18 my $ex_class = $cdef->{class};
1192 12         16 my $eval = "q{CORE::local \$_ = \$Nice::Try::EXCEPTION; my $ex_var = \$Nice::Try::EXCEPTION; CORE::local \$\@ = \$Nice::Try::EXCEPTION; $cdef->{where}}";
1193 12         66 $catch_section = <
1194             ${cond}( Scalar::Util::blessed( \$Nice::Try::EXCEPTION ) && \$Nice::Try::EXCEPTION->isa( '$ex_class' ) && CORE::eval( $eval ) )
1195             {
1196             CORE::local \$\@ = \$Nice::Try::EXCEPTION;
1197             my $ex_var = \$Nice::Try::EXCEPTION;
1198             $catch_code
1199             }
1200             EOT
1201             }
1202             elsif( $cdef->{class} )
1203             {
1204 18         25 my $ex_class = $cdef->{class};
1205             # Tilmann Haeberle (TH) 2021-03-25: Fix: properly test for exception class inheritance via ->isa
1206 18         99 $catch_section = <
1207             ${cond}( Scalar::Util::blessed( \$Nice::Try::EXCEPTION ) && \$Nice::Try::EXCEPTION->isa( '$ex_class' ) )
1208             {
1209             CORE::local \$\@ = \$Nice::Try::EXCEPTION;
1210             my $ex_var = \$Nice::Try::EXCEPTION;
1211             $catch_code
1212             }
1213             EOT
1214             }
1215             elsif( $cdef->{where} )
1216             {
1217 1         2 my $eval = "q{CORE::local \$_ = \$Nice::Try::EXCEPTION; my $ex_var = \$Nice::Try::EXCEPTION; CORE::local \$\@ = \$Nice::Try::EXCEPTION; $cdef->{where}}";
1218 1         6 $catch_section = <
1219             ${cond}( CORE::eval( $eval ) )
1220             {
1221             CORE::local \$\@ = \$Nice::Try::EXCEPTION;
1222             my $ex_var = \$Nice::Try::EXCEPTION;
1223             $catch_code
1224             }
1225             EOT
1226             }
1227             # No class, just variable assignment like $e or something
1228             else
1229             {
1230 78 50       183 if( ++$else > 1 )
1231             {
1232             # CORE::warn( "Cannot have more than one falllback catch clause for block: ", $cdef->{block}->content, "\n" ) if( warnings::enabled );
1233 0 0       0 CORE::warn( "Cannot have more than one falllback catch clause for block: ", $self->_serialize( $cdef->{block} ), "\n" ) if( warnings::enabled );
1234             # Skip, not die. Not fatal, just ignored
1235 0         0 next;
1236             }
1237 78 100 66     276 $cond = "${cond}( 1 )" if( $cond eq 'if' || $cond eq 'elsif' );
1238 78         442 $catch_section = <
1239             ${cond}
1240             {
1241             CORE::local \$\@ = \$Nice::Try::EXCEPTION;
1242             my $ex_var = \$Nice::Try::EXCEPTION;
1243             $catch_code
1244             }
1245             EOT
1246             }
1247             }
1248             # No variable assignment like $e
1249             else
1250             {
1251 34 50 33     127 $cond = "${cond}( 1 )" if( $cond eq 'if' || $cond eq 'elsif' );
1252 34         175 $catch_section = <
1253             ${cond}
1254             {
1255             CORE::local \$\@ = \$Nice::Try::EXCEPTION;
1256             $catch_code
1257             }
1258             EOT
1259             }
1260 143 50       3275 $catch_section =~ s/\n/ /gs unless( $self->{debug_code} );
1261 143         746 $catch_section =~ s/__BLOCK_PLACEHOLDER__/$block/gs;
1262 143 100       281 if( $cdef->{open_curly_nl} )
1263             {
1264 98         342 $catch_section =~ s/__CATCH_OPEN_NL__/"\n" x $cdef->{open_curly_nl}/gex;
  98         525  
1265             }
1266             else
1267             {
1268 45         223 $catch_section =~ s/__CATCH_OPEN_NL__//gs;
1269             }
1270 143 100       327 if( $cdef->{close_curly_nl} )
1271             {
1272 27         85 $catch_section =~ s/__CATCH__CLOSE_NL__/"\n" x $cdef->{close_curly_nl}/gex;
  27         90  
1273             }
1274             else
1275             {
1276 116         598 $catch_section =~ s/__CATCH__CLOSE_NL__//gs;
1277             }
1278 143         646 push( @$catch_repl, $catch_section );
1279             }
1280             # End catch loop
1281             # Tilmann Haeberle (TH) 2021-03-25: Fix: put an else at the end to avoid 'fall_through' issue unless an else exists already
1282 119         146 my $if_end;
1283 119 100       360 if( $else )
1284             {
1285 78         117 $if_end = <
1286             }
1287             EOT
1288             }
1289             else
1290             {
1291 41         53 $if_end = <
1292             else
1293             {
1294             die( \$Nice::Try::EXCEPTION );
1295             }
1296             }
1297             EOT
1298             }
1299 119 50       425 $if_end =~ s/\n/ /g unless( $self->{debug_code} );
1300 119         213 push( @$catch_repl, $if_end );
1301             }
1302             # No catch clause
1303             else
1304             {
1305             # If the try-catch block is called inside an eval, propagate the exception
1306             # Otherwise, we just make the $@ available
1307 8         14 my $catch_else = <
1308             }
1309             else
1310             {
1311             if( CORE::defined( (CORE::caller(0))[3] ) && (CORE::caller(0))[3] eq '(eval)' )
1312             {
1313             CORE::die( \$Nice::Try::EXCEPTION );
1314             }
1315             else
1316             {
1317             \$\@ = \$Nice::Try::EXCEPTION;
1318             }
1319             }
1320             EOT
1321 8 50       55 $catch_else =~ s/\n/ /g unless( $self->{debug_code} );
1322 8         14 push( @$catch_repl, $catch_else );
1323             }
1324            
1325             # Add
1326 127 50       1020 my $catch_res = scalar( @$catch_repl ) ? join( '', @$catch_repl ) : '';
1327 127 50       330 push( @$repl, $catch_res ) if( $catch_res );
1328             # Closing the If DIED condition
1329 127         215 push( @$repl, "\};" );
1330              
1331             # If there is a catch clause, we put the final block here, if any
1332 127 100 100     439 if( $has_catch_clause && CORE::length( $fin_block ) )
1333             {
1334 7         7 push( @$repl, $fin_block );
1335             }
1336            
1337             # After the finally block has been registered, we will die if catch had a fatal error
1338 127         175 my $catch_dies = <
1339             if( defined( \$Nice::Try::CATCH_DIED ) )
1340             {
1341             die( \$Nice::Try::CATCH_DIED );
1342             }
1343             EOT
1344 127 50       493 $catch_dies =~ s/\n/ /gs unless( $self->{debug_code} );
1345 127         181 push( @$repl, $catch_dies );
1346            
1347 127         202 my $last_return_block = <
1348             if( ( CORE::defined( \$Nice::Try::WANTARRAY ) || ( defined( \$Nice::Try::BREAK ) && \$Nice::Try::BREAK eq 'return' ) ) and
1349             (
1350             !Scalar::Util::blessed( \$Nice::Try::RETVAL[0] ) or
1351             ( Scalar::Util::blessed( \$Nice::Try::RETVAL[0] ) && !\$Nice::Try::RETVAL[0]->isa( 'Nice::Try::SENTINEL' ) )
1352             ) )
1353             {
1354             \$Nice::Try::NEED_TO_RETURN++ if( defined( \$Nice::Try::BREAK ) && \$Nice::Try::BREAK eq 'return' );
1355             no warnings 'void';
1356             EOT
1357 127 50 33     605 if( CORE::scalar( CORE::keys( %warnings:: ) ) &&
1358             CORE::exists( $warnings::Bits{args_array_with_signatures} ) )
1359             {
1360 0         0 $last_return_block .= <
1361             no warnings 'experimental::args_array_with_signatures';
1362             EOT
1363             }
1364 127         410 $last_return_block .= <
1365             if( !CORE::defined( \$Nice::Try::BREAK ) || \$Nice::Try::BREAK eq 'return' )
1366             {
1367             if( CORE::defined( \$Nice::Try::WANT ) && CORE::length( \$Nice::Try::WANT ) )
1368             {
1369             if( \$Nice::Try::WANT eq 'LIST' )
1370             {
1371             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \@Nice::Try::RETVAL ) : \@Nice::Try::RETVAL;
1372             }
1373             elsif( \$Nice::Try::WANT eq 'VOID' )
1374             {
1375             if( CORE::defined( \$Nice::Try::RETVAL[0] ) && \$Nice::Try::RETVAL[0] eq '__NEXT__' )
1376             {
1377             \$Nice::Try::BREAK = 'next';
1378             }
1379             elsif( CORE::defined( \$Nice::Try::RETVAL[0] ) && \$Nice::Try::RETVAL[0] eq '__LAST__' )
1380             {
1381             \$Nice::Try::BREAK = 'last';
1382             }
1383             elsif( CORE::defined( \$Nice::Try::RETVAL[0] ) && \$Nice::Try::RETVAL[0] eq '__REDO__' )
1384             {
1385             \$Nice::Try::BREAK = 'redo';
1386             }
1387             elsif( defined( \$Nice::Try::BREAK ) && \$Nice::Try::BREAK eq 'return' )
1388             {
1389             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::RETVAL[0] ) : \$Nice::Try::RETVAL[0];
1390             }
1391             }
1392             elsif( \$Nice::Try::WANT eq 'OBJECT' )
1393             {
1394             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::RETVAL[0] ) : \$Nice::Try::RETVAL[0];
1395             }
1396             elsif( \$Nice::Try::WANT eq 'REFSCALAR' )
1397             {
1398             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \\\$Nice::Try::RETVAL[0] ) : \\\$Nice::Try::RETVAL[0];
1399             }
1400             elsif( \$Nice::Try::WANT eq 'SCALAR' )
1401             {
1402             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::RETVAL[0] ) : \$Nice::Try::RETVAL[0];
1403             }
1404             elsif( \$Nice::Try::WANT eq 'BOOLEAN' )
1405             {
1406             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::RETVAL[0] ) : \$Nice::Try::RETVAL[0];
1407             }
1408             elsif( \$Nice::Try::WANT eq 'CODE' )
1409             {
1410             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::RETVAL[0] ) : \$Nice::Try::RETVAL[0];
1411             }
1412             elsif( \$Nice::Try::WANT eq 'HASH' )
1413             {
1414             \$Nice::Try::NEED_TO_RETURN ? CORE::return( { \@Nice::Try::RETVAL } ) : { \@Nice::Try::RETVAL };
1415             }
1416             elsif( \$Nice::Try::WANT eq 'ARRAY' )
1417             {
1418             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \\\@Nice::Try::RETVAL ) : \\\@Nice::Try::RETVAL;
1419             }
1420             elsif( \$Nice::Try::WANT eq 'GLOB' )
1421             {
1422             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::RETVAL[0] ) : \$Nice::Try::RETVAL[0];
1423             }
1424             }
1425             else
1426             {
1427             \$Nice::Try::NEED_TO_RETURN ? CORE::return( \$Nice::Try::WANTARRAY ? \@Nice::Try::RETVAL : \$Nice::Try::RETVAL[0] ) : \$Nice::Try::WANTARRAY ? \@Nice::Try::RETVAL : \$Nice::Try::RETVAL[0];
1428             }
1429             }
1430             }
1431             elsif( scalar( \@Nice::Try::VOID ) && ( !Scalar::Util::blessed( \$Nice::Try::VOID[0] ) || ( Scalar::Util::blessed( \$Nice::Try::VOID[0] ) && !\$Nice::Try::VOID[0]->isa( 'Nice::Try::SENTINEL' ) ) ) )
1432             {
1433             no warnings 'void';
1434             scalar( \@Nice::Try::VOID ) > 1 ? \@Nice::Try::VOID : \$Nice::Try::VOID[0];
1435             }
1436             EOT
1437 127 50       2479 $last_return_block =~ s/\n/ /gs unless( $self->{debug_code} );
1438 127         661 push( @$repl, $last_return_block );
1439 127         2526 my $try_catch_code = join( '', @$repl );
1440             # my $token = PPI::Token->new( "; \{ $try_catch_code \}" ) || die( "Unable to create token" );
1441             # NOTE: 2021-05-11 (Jacques): Need to remove blocks so that next or last statements can be effective.
1442 127         234 my $envelop = <
1443             ; CORE::local( \$Nice::Try::BREAK, \@Nice::Try::LAST_VAL ); local \$Nice::Try::NEED_TO_RETURN = 0 unless( defined( \$Nice::Try::NEED_TO_RETURN ) );
1444             \{
1445             __TRY_CATCH_CODE__
1446             \}
1447             if( CORE::defined( \$Nice::Try::BREAK ) )
1448             {
1449             if( \$Nice::Try::BREAK eq 'next' )
1450             {
1451             CORE::next;
1452             }
1453             elsif( \$Nice::Try::BREAK eq 'last' )
1454             {
1455             CORE::last;
1456             }
1457             elsif( \$Nice::Try::BREAK eq 'redo' )
1458             {
1459             CORE::redo;
1460             }
1461             }
1462             no warnings 'void';
1463             CORE::scalar( \@Nice::Try::LAST_VAL ) > 1 ? \@Nice::Try::LAST_VAL : \$Nice::Try::LAST_VAL[0];
1464             EOT
1465 127 50       996 $envelop =~ s/\n/ /gs unless( $self->{debug_code} );
1466 127         2014 $envelop =~ s/__TRY_CATCH_CODE__/$try_catch_code/;
1467 127   50     584 my $token = PPI::Token->new( $envelop ) || die( "Unable to create token" );
1468 127         4291 $token->set_class( 'Structure' );
1469 127   50     2098 my $struct = PPI::Structure->new( $token ) || die( "Unable to create PPI::Structure element" );
1470 127         3856 my $orig_try_catch_block = join( '', @$nodes_to_replace );
1471 127         26729 my $rc;
1472 127 50       463 if( !( $rc = $element_before_try->insert_after( $token ) ) )
1473             {
1474 0         0 $self->_error( "Failed to add replacement code of class '", $token->class, "' after '$element_before_try'" );
1475 0         0 next;
1476             }
1477 127 0       5992 $self->_message( 3, "Return code is defined? ", defined( $rc ) ? "yes" : "no" ) if( $self->{debug} >= 3 );
    50          
1478            
1479 127         352 for( my $k = 0; $k < scalar( @$nodes_to_replace ); $k++ )
1480             {
1481 1438         77843 my $e = $nodes_to_replace->[$k];
1482 1438 50       2318 $e->delete || warn( "Could not remove node No $k: '$e'\n" );
1483             }
1484             }
1485             # End foreach catch found
1486              
1487             # NOTE: Do we have a __DATA__ or __END__ token ?
1488 34 100       8176 if( $opts->{has_data} )
1489             {
1490             my $ref = $elem->find(sub
1491             {
1492 7720     7720   72844 my( $top, $this ) = @_;
1493 7720 100 100     8684 return( ( $this->class eq 'PPI::Statement::Data' || $this->class eq 'PPI::Statement::End' ) ? 1 : 0 );
1494 13         131 });
1495 13 50 33     252 warn( "Warning only: Failed to find any __DATA__ or __END__ token." ) if( !defined( $ref ) && warnings::enabled() );
1496 13         40 my $class = $self->{class};
1497 13         21 my $name = 'DATA';
1498 13         68 $self->_message( 4, "Found ", scalar( @$ref ), " DATA tokens." );
1499             # There must be only one: either __DATA__ or __END__, so we process it, and exit the loop.
1500 13         23 foreach my $this ( @$ref )
1501             {
1502 13         34 $self->_message( 4, "DATA or END token found." );
1503 13 50       35 $self->_browse( $this ) if( $self->{debug} >= 5 );
1504             my $tokens = $this->find(sub
1505             {
1506 39     39   535 my( $top, $this ) = @_;
1507             # PPI::Token::End
1508 39 100 100     67 return( ( $this->class eq 'PPI::Token::Data' || $this->class eq 'PPI::Token::End' ) ? 1 : 0 );
1509 13         127 });
1510 13 100 33     257 next if( !$tokens || ( defined( $tokens ) && ref( $tokens ) && !scalar( @$tokens ) ) );
      33        
      66        
1511 12         24 my $token = $tokens->[0];
1512 12         29 my $token_name_ref = $this->find( 'PPI::Token::Separator' );
1513 12         2409 my $token_name;
1514 12 50 33     129 if( $token_name_ref && ref( $token_name_ref ) eq 'ARRAY' && scalar( @$token_name_ref ) )
      50        
1515             {
1516 12         51 $token_name = $token_name_ref->[0]->content;
1517             }
1518             else
1519             {
1520 0 0       0 warn( "Could not find the __END__ or __DATA__ separator." ) if( warnings::enabled() );
1521 0         0 last;
1522             }
1523            
1524             # my $io = $token->handle;
1525 12         57 my $raw_data_str = $token->content;
1526 12         62 $self->_message( 5, "Found DATA to be:\n${raw_data_str}" );
1527              
1528             # Create a new string that holds only non-POD data
1529 12         16 my $filtered_data_str = '';
1530              
1531 12 100       37 if( $raw_data_str =~ /\S+/ )
1532             {
1533             # Parse the data as a PPI document to filter POD content
1534 4         9 $self->_message( 5, "Parsing the DATA, and check for POD to skip." );
1535             # Force it to be __END__ so PPI can handle properly the POD data
1536             # FYI, PPI only handles POD data when the token is __END__, and not when it is __DATA__
1537 4 100       7 if( $token_name eq '__DATA__' )
1538             {
1539 2         2 my $data_str = "__END__\n" . $raw_data_str;
1540 2         13 require PPI::Tokenizer;
1541 2         10 my $tokenizer = PPI::Tokenizer->new( \$data_str );
1542 2         360 my $tokens = $tokenizer->all_tokens;
1543 2         1474 foreach my $token ( @$tokens )
1544             {
1545 7 100       33 $filtered_data_str .= "${token}" if( $token->class eq 'PPI::Token::End' );
1546             }
1547             }
1548             else
1549             {
1550 2         2 $filtered_data_str = $raw_data_str;
1551             }
1552             }
1553            
1554             # Now $filtered_data_str holds only the non-POD data content
1555 12         76 $self->_message( 5, "Creating BEGIN block to set DATA with value:\n${filtered_data_str}" );
1556            
1557             # Define the BEGIN block code with the filtered data
1558 12         35 my $begin_block_code = <<"END_CODE";
1559             {
1560             no warnings;
1561             CHECK
1562             {
1563             my \$nice_try_data_block_str = <<'END_OF_DATA';
1564             ${filtered_data_str}
1565             END_OF_DATA
1566              
1567             require Symbol;
1568             my \$fh = Symbol::geniosym();
1569             open( \$fh, '<:scalar', \\\$nice_try_data_block_str ) || die( \$! );
1570             no strict 'refs';
1571             no warnings 'redefine';
1572             *{ __PACKAGE__ . '::DATA' } = \$fh;
1573             };
1574             }
1575              
1576             END_CODE
1577 12 100       33 if( $this->class eq 'PPI::Statement::End' )
1578             {
1579 10         96 $begin_block_code .= "1;\n";
1580             }
1581 12         49 $self->_message( 5, "BEGIN block is:\n${begin_block_code}" );
1582 12   50     41 my $begin_block = PPI::Token->new( $begin_block_code ) || die( "Unable to create token" );
1583 12         127 $self->_message( 5, "Inserting BEGIN element object '", overload::StrVal( $begin_block ), "', before '", overload::StrVal( $this ), "'" );
1584 12         80 my $rv = $this->__insert_before( $begin_block );
1585 12 50       741 if( !defined( $rv ) )
    50          
1586             {
1587 0 0       0 warn( "BEGIN block object (", overload::StrVal( $begin_block ), ") to be inserted before the DATA token is not a valid object." ) if( warnings::enabled() );
1588 0         0 last;
1589             }
1590             elsif( !$rv )
1591             {
1592 0 0       0 warn( "Somehow, the BEGIN block object (", overload::StrVal( $begin_block ), ") could not be inserted before the DATA token." ) if( warnings::enabled() );
1593 0         0 last;
1594             }
1595             # $self->_message( 5, "BEGIN block object (", overload::StrVal( $begin_block ), ") was successfully inserted." );
1596             # We end here, because there can be only one __DATA__ or __END__ token
1597 12         41 last;
1598             }
1599             }
1600              
1601             # $self->_message( 5, "Code now is: $elem" );
1602 34         180 return( $elem );
1603             }
1604              
1605             # .Element: [11] class PPI::Token::Word, value caller
1606             # .Element: [11] class PPI::Structure::List, value (1)
1607             #
1608             # ..Element: [12] class PPI::Token::Word, value caller
1609             # ..Element: [12] class PPI::Token::Structure, value ;
1610              
1611             sub _process_caller
1612             {
1613 1569     1569   1566 my $self = shift( @_ );
1614 1569         1557 my $where = shift( @_ );
1615 1569   50     2741 my $elem = shift( @_ ) || return( '' );
1616 31     31   250 no warnings 'uninitialized';
  31         45  
  31         6515  
1617 1569 100       2285 return( $elem ) if( !$elem->children );
1618 1558         5694 foreach my $e ( $elem->elements )
1619             {
1620 7744   50     15500 my $content = $e->content // '';
1621 7744         54217 my $class = $e->class;
1622 7744 100 100     17970 if( $class eq 'PPI::Token::Word' && $content =~ /^(?:CORE\::)?(?:GLOBAL\::)?caller$/ )
1623             {
1624 5         14 $e->set_content( 'Nice::Try::caller_' . $where );
1625             }
1626            
1627 7744 100 100     15795 if( $e->can('elements') && $e->elements )
1628             {
1629 1286         7462 $self->_process_caller( $where => $e );
1630             }
1631             }
1632 1558         2165 return( $elem );
1633             }
1634              
1635             sub _process_loop_breaks
1636             {
1637 456     456   519 my $self = shift( @_ );
1638 456   50     1012 my $elem = shift( @_ ) || return( '' );
1639 31     31   258 no warnings 'uninitialized';
  31         89  
  31         40303  
1640 456 100       908 return( $elem ) if( !$elem->children );
1641 450         2119 my $ct = "$elem";
1642             # There is nothing to do
1643 450 100 100     34451 if( index( $ct, 'last' ) == -1 &&
      100        
      100        
      100        
1644             index( $ct, 'next' ) == -1 &&
1645             index( $ct, 'redo' ) == -1 &&
1646             index( $ct, 'goto' ) == -1 &&
1647             index( $ct, 'return' ) == -1 )
1648             {
1649 321 50       624 $self->_message( 4, "There is nothing to be done. Key words last, next, redo or goto are not found." ) if( $self->{debug} >= 4 );
1650 321         496 return( '' );
1651             }
1652 129 50       279 $self->_message( 5, "Checking loop breaks in ", scalar( $elem->elements ), " elements for '$elem'" ) if( $self->{debug} >= 5 );
1653 129         251 foreach my $e ( $elem->elements )
1654             {
1655 1270   50     3963 my $content = $e->content // '';
1656 1270 0       17048 $self->_messagef( 6, "Checking element: [%d] class %s with %d children and value '%s'\n", $e->line_number, $e->class, ( $e->can('elements') ? scalar( $e->elements ) : 0 ), $content ) if( $self->{debug} >= 6 );
    50          
1657 1270         1595 my $class = $e->class;
1658             # We found a for, foreach or while loops and we skip, because if there are any break words (next, last, redo) inside, it is not our problem.
1659 1270 50 66     6394 if( $class eq 'PPI::Structure::For' ||
    50 66        
    100 33        
    100 66        
      50        
      100        
      66        
      66        
1660             ( $class eq 'PPI::Statement::Compound' &&
1661             CORE::defined( $e->first_element->content ) &&
1662             $e->first_element->content =~ /^(for|foreach|while)$/ ) )
1663             {
1664 0         0 next;
1665             }
1666             elsif( $class eq 'PPI::Token::Word' && $content =~ /^(?:CORE\::)?(?:GLOBAL\::)?(next|last|redo)$/ )
1667             {
1668 0 0       0 $self->_message( 5, "Found loop keyword '$content'." ) if( $self->{debug} >= 5 );
1669             # $e->set_content( qq{CORE::return( '__} . uc( $1 ) . qq{__' )} );
1670             # $e->set_content( q{$Nice::Try::BREAK='__} . uc( $1 ) . qq{__' ); return;} );
1671 0         0 my $break_code = q{$Nice::Try::BREAK='} . $1 . qq{', return;};
1672 0         0 my $break_doc = PPI::Document->new( \$break_code, readonly => 1 );
1673 0         0 my $new_elem = $break_doc->first_element;
1674 0         0 $new_elem->remove;
1675 0 0   0   0 $self->_message( 5, "New element is object '", sub{ overload::StrVal( $new_elem ) }, "' -> $new_elem" ) if( $self->{debug} >= 5 );
  0         0  
1676             # Not yet implemented as of 2021-05-11 dixit PPI, so we use a hack to make it available anyhow
1677 0         0 $e->replace( $new_elem );
1678 0 0       0 $self->_message( 5, "Loop keyword now replaced with '$e'." ) if( $self->{debug} >= 5 );
1679             }
1680             elsif( $class eq 'PPI::Statement::Break' )
1681             {
1682 86         183 my $words = $e->find( 'PPI::Token::Word' );
1683 86 50       21581 $self->_messagef( 5, "Found %d word elements inside break element.", scalar( @$words ) ) if( $self->{debug} >= 5 );
1684 86 50 50     290 my $word1 = ( scalar( @$words ) ? $words->[0]->content // '' : '' );
1685 86 100 50     365 my $word2 = ( scalar( @$words ) > 1 ? $words->[1]->content // '' : '' );
1686 86 50       211 $self->_message( 5, "Word 1 -> ", $word1 ) if( $self->{debug} >= 5 );
1687 86 50 33     169 $self->_message( 5, "Word 2 -> ", $word2 ) if( $self->{debug} >= 5 && scalar( @$words ) > 1 );
1688             # If we found a break word without a label, i.e. next, last, redo,
1689             # we replace it with a special return statement
1690 86 50 100     723 if( (
      66        
      100        
1691             scalar( @$words ) == 1 ||
1692             ( scalar( @$words ) > 1 && $word2 =~ /^(for|foreach|given|if|unless|until|while)$/ ) ||
1693             $word1 eq 'return'
1694             ) &&
1695             (
1696             $word1 eq 'next' ||
1697             $word1 eq 'last' ||
1698             $word1 eq 'redo' ||
1699             $word1 eq 'return'
1700             ) )
1701             {
1702             # We add our special return value. Notice that we use 'return' and not
1703             # 'CORE::return'. See below why.
1704             # my $break_code = qq{return( '__} . uc( $word1 ) . qq{__' )};
1705 74 100       226 my $break_code = q{$Nice::Try::BREAK='} . $word1 . ( $word1 eq 'return' ? "', $e" : qq{', return} );
1706             # e.g. next if( $i == 2 );
1707             # next and if are both treated as 'word' by PPI
1708 74 100       1393 if( scalar( @$words ) > 1 )
1709             {
1710 10         22 ( my $ct = $e->content ) =~ s/^(next|last|redo)//;
1711 10         510 $break_code .= $ct;
1712             }
1713             else
1714             {
1715 64         92 $break_code .= ';'
1716             }
1717 74 50       142 $self->_message( 5, "Replacing this node with: $break_code" ) if( $self->{debug} >= 5 );
1718            
1719 74         352 my $break_doc = PPI::Document->new( \$break_code, readonly => 1 );
1720 74         114340 my $new_elem = $break_doc->first_element;
1721 74         357 $new_elem->remove;
1722 74 50   0   2627 $self->_message( 5, "New element is object '", sub{ overload::StrVal( $new_elem ) }, "' -> $new_elem" ) if( $self->{debug} >= 5 );
  0         0  
1723             # Not yet implemented as of 2021-05-11 dixit PPI, so we use a hack to make it available anyhow
1724 74 50       166 $self->_message( 5, "Updated element now is '$e' for class '", $e->class, "' and parent class '", $e->parent->class, "'." ) if( $self->{debug} >= 5 );
1725 74         239 $e->replace( $new_elem );
1726             # 2021-05-12 (Jacques): I have to do this workaround, because weirdly enough
1727             # PPI (at least with PPI::Node version 1.270) will refuse to add our element
1728             # if the 'return' word is 'CORE::return' so, we add it without and change it after
1729             # $new_elem->first_element->set_content( 'CORE::return' );
1730             }
1731 86         2424 next;
1732             }
1733             elsif( $class eq 'PPI::Token::Word' &&
1734             ( $e->content // '' ) eq 'return' &&
1735             $e->sprevious_sibling &&
1736             # Should be enough
1737             $e->sprevious_sibling->class eq 'PPI::Token::Operator' )
1738             # $e->sprevious_sibling->class eq 'PPI::Token::Operator' &&
1739             # ( $e->sprevious_sibling->content // '' ) =~ /^$/ )
1740             {
1741 3         161 my $break_code;
1742             my @to_remove;
1743             # return( # something );
1744 3 100 66     20 if( $e->snext_sibling &&
    50 33        
    0 0        
      0        
1745             $e->snext_sibling->class eq 'PPI::Structure::List' )
1746             {
1747 2         65 my $list = $e->snext_sibling;
1748 2         27 push( @to_remove, $list );
1749 2         5 $break_code = "return( \$Nice::Try::RETURN->${list} )";
1750             }
1751             # return( "" ) or return( '' )
1752             elsif( $e->snext_sibling &&
1753             $e->snext_sibling->isa( 'PPI::Token::Quote' ) )
1754             {
1755 1         66 my $list = $e->snext_sibling;
1756 1         14 push( @to_remove, $list );
1757 1         3 $break_code = "return( \$Nice::Try::RETURN->(${list}) );";
1758             }
1759             # return;
1760             elsif( $e->snext_sibling &&
1761             $e->snext_sibling->class eq 'PPI::Token::Structure' &&
1762             $e->snext_sibling->content eq ';' )
1763             {
1764 0         0 $break_code = "return( \$Nice::Try::RETURN->() );";
1765             }
1766             else
1767             {
1768 0         0 my $list = '';
1769 0         0 my $next_elem;
1770 0         0 my $prev_elem = $e;
1771 0         0 while( $next_elem = $prev_elem->snext_sibling )
1772             {
1773 0 0       0 last if( $next_elem->content eq ';' );
1774 0         0 $list .= $next_elem->content;
1775 0         0 push( @to_remove, $next_elem );
1776 0         0 $prev_elem = $next_elem;
1777             }
1778 0         0 $break_code = "return( \$Nice::Try::RETURN->(${list}) );";
1779             }
1780 3         57 my $break_doc = PPI::Document->new( \$break_code, readonly => 1 );
1781 3         4968 my $new_elem = $break_doc->first_element;
1782 3         17 $new_elem->remove;
1783 3 50   0   94 $self->_message( 5, "New element is object '", sub{ overload::StrVal( $new_elem ) }, "' -> $new_elem" ) if( $self->{debug} >= 5 );
  0         0  
1784             # Not yet implemented as of 2021-05-11 dixit PPI, so we use a hack to make it available anyhow
1785 3         9 $e->replace( $new_elem );
1786 3         15 $_->remove for( @to_remove );
1787             }
1788            
1789 1184 100 100     3080 if( $e->can('elements') && $e->elements )
1790             {
1791 186         1387 $self->_process_loop_breaks( $e );
1792             }
1793             }
1794 129         689 return( $elem );
1795             }
1796              
1797             sub _process_sub_token
1798             {
1799 426     426   513 my $self = shift( @_ );
1800 426   50     1038 my $elem = shift( @_ ) || return( '' );
1801             # token __SUB__ is only available since perl v5.16
1802 426 50       799 return( '' ) unless( $] >= 5.016000 );
1803 426 100       727 if( index( "$elem", '__SUB__' ) == -1 )
1804             {
1805 424 50       30357 $self->_message( 5, "No __SUB__ token found in ", scalar( $elem->elements ), " elements for '$elem'" ) if( $self->{debug} >= 5 );
1806 424         552 return( '' );
1807             }
1808 31     31   218 no warnings 'uninitialized';
  31         39  
  31         26709  
1809 2 50       264 return( $elem ) if( !$elem->children );
1810 2 50       10 $self->_message( 5, "Checking __SUB__ token in ", scalar( $elem->elements ), " elements for '$elem'" ) if( $self->{debug} >= 5 );
1811             # Look for parent, and if we can find a sub, or an anonymous sub
1812             # my $sub = sub{} -> PPI::Token::Word 'sub', PPI::Structure::Block '{'
1813             # sub mysub {} -> PPI::Statement::Sub -> PPI::Token::Word 'sub', PPI::Token::Word 'mysub', PPI::Structure::Block '{'
1814 2         2 my $find_closest_sub;
1815             $find_closest_sub = sub
1816             {
1817 2     2   2 my $e = shift( @_ );
1818 2 50       4 return if( !defined( $e ) );
1819 2         18 my $parent = $e->parent;
1820 2 50       9 return if( !$parent );
1821             # Keep going up until we find a block
1822 2         5 while( $parent )
1823             {
1824 4 50       11 $self->_message( 5, "Checking parent element of class ", $parent->class, " and value $parent" ) if( $self->{debug} >= 5 );
1825 4 100       5 if( $parent->class eq 'PPI::Structure::Block' )
1826             {
1827 2         6 my $sub_name;
1828 2         7 my $prev = $parent->sprevious_sibling;
1829 2         83 while( $prev )
1830             {
1831 6 100       64 if( $prev->content eq 'sub' )
1832             {
1833 2         12 return({ element => $parent, name => $sub_name });
1834             }
1835            
1836 4 100       26 if( $prev->class eq 'PPI::Token::Word' )
1837             {
1838 1 50       4 if( CORE::defined( $sub_name ) )
1839             {
1840 0 0       0 warn( "Found some redefinition of a subroutine's name at line ", $prev->line_number, " for subroutine '${sub_name}'\n" ) if( warnings::enabled() );
1841             }
1842 1         2 $sub_name = $prev->content;
1843             }
1844 4         19 $prev = $prev->sprevious_sibling;
1845             }
1846             }
1847 2         8 $parent = $parent->parent;
1848             }
1849 0         0 return;
1850 2         10 };
1851 2         5 my $def = $find_closest_sub->( $elem );
1852 2 50       3 if( $def )
1853             {
1854 2         5 my $block = $def->{element};
1855 2 50 0     8 $self->_message( 5, "Found a sub block at line ", $block->line_number, " of class ", $block->class, " with name '", ( $def->{name} // 'anonymous' ), "'" ) if( $self->{debug} >= 5 );
1856 2         3 my $sub_token_code = <<'PERL';
1857             CORE::local $Nice::Try::SUB_TOKEN;
1858             {
1859             use feature 'current_sub';
1860             no warnings 'experimental';
1861             $Nice::Try::SUB_TOKEN = __SUB__;
1862             }
1863             PERL
1864 2         11 $sub_token_code =~ s/\n//gs;
1865             # $sub_token_code .= $block;
1866 2         9 my $sub_token_doc = PPI::Document->new( \$sub_token_code, readonly => 1 );
1867 2         6480 my @new_elems = $sub_token_doc->elements;
1868             # my $new_elem = $sub_token_doc;
1869             # $new_elem->remove;
1870 2         18 $_->remove for( @new_elems );
1871 2 50   0   122 $self->_message( 5, "New elements is object '", sub{ join( ', ', map( overload::StrVal( $_ ), @new_elems ) ) }, "' -> $_" ) if( $self->{debug} >= 5 );
  0         0  
1872             # $block->replace( $new_elem );
1873             # Not yet implemented as of 2021-05-11 dixit PPI, so we use a hack to make it available anyhow
1874 2         3 my $rv;
1875 2         4 my @children = $block->children;
1876 2 50       11 if( scalar( @children ) )
1877             {
1878 2         2 my $last = $children[0];
1879 2         5 for( reverse( @new_elems ) )
1880             {
1881 4         13 $rv = $last->__insert_before( $_ );
1882 4 0       88 $self->_message( 5, "Element successfully inserted? ", ( defined( $rv ) ? ( $rv ? 'yes' : 'no' ) : 'no. element provided was not an PPI::Element.' ) ) if( $self->{debug} >= 5 );
    0          
    50          
1883 4         4 $last = $_;
1884             }
1885             }
1886             else
1887             {
1888 0         0 for( @new_elems )
1889             {
1890 0         0 $rv = $block->add_element( $_ );
1891 0 0       0 $self->_message( 5, "Element successfully inserted? ", ( defined( $rv ) ? ( ref( $rv ) eq 'PPI::Element' ? 'ok' : 'returned value is not an PPI::Element (' . ref( $rv ) . ')' ) : 'no' ) ) if( $self->{debug} >= 5 );
    0          
    0          
1892             }
1893             }
1894 2 50       9 $self->_message( 5, "Updated block now is '$block' for class '", $block->class, "'." ) if( $self->{debug} >= 5 );
1895             }
1896             else
1897             {
1898 0 0       0 $self->_message( 5, "No subroutine found! This is a try-catch block outside of a subroutine." ) if( $self->{debug} >= 5 );
1899             }
1900            
1901 2         34 my $crawl;
1902             $crawl = sub
1903             {
1904 10     10   10 my $this = shift( @_ );
1905 10         26 foreach my $e ( $this->elements )
1906             {
1907 67 50       660 $self->_message( 5, "Checking element ", overload::StrVal( $e ), " of class ", $e->class, " for token __SUB__" ) if( $self->{debug} >= 5 );
1908 67 100 100     78 if( $e->content eq '__SUB__' )
    100 66        
1909             {
1910 4 50       16 $self->_message( 5, "Found token __SUB__" ) if( $self->{debug} >= 5 );
1911 4         15 my $new_ct = '$Nice::Try::SUB_TOKEN';
1912 4         12 my $new_ct_doc = PPI::Document->new( \$new_ct, readonly => 1 );
1913 4         2160 my $new_token = $new_ct_doc->first_element;
1914 4         13 $new_token->remove;
1915 4         124 $e->replace( $new_token );
1916             }
1917             elsif( $e->can( 'elements' ) &&
1918             scalar( $e->elements ) &&
1919             index( "$e", '__SUB__' ) != -1 )
1920             {
1921 8         586 $crawl->( $e );
1922             }
1923             }
1924 2         9 };
1925 2         5 $crawl->( $elem );
1926 2 50       10 $self->_message( 5, "After processing __SUB__ tokens, try-catch block is now:\n$elem" ) if( $self->{debug} >= 5 );
1927 2         18 return( $elem );
1928             }
1929              
1930             # Taken from PPI::Document
1931             sub _serialize
1932             {
1933 392     392   533 my $self = shift( @_ );
1934 392   50     969 my $ppi = shift( @_ ) || return( '' );
1935 31     31   212 no warnings 'uninitialized';
  31         59  
  31         18802  
1936 392         863 my @tokens = $ppi->tokens;
1937              
1938             # The here-doc content buffer
1939 392         22241 my $heredoc = '';
1940              
1941             # Start the main loop
1942 392         467 my $output = '';
1943 392         877 foreach my $i ( 0 .. $#tokens ) {
1944 7386         6450 my $Token = $tokens[$i];
1945              
1946             # Handle normal tokens
1947 7386 50       22743 unless ( $Token->isa('PPI::Token::HereDoc') ) {
1948 7386         8755 my $content = $Token->content;
1949              
1950             # Handle the trivial cases
1951 7386 50 33     17723 unless ( $heredoc ne '' and $content =~ /\n/ ) {
1952 7386         6834 $output .= $content;
1953 7386         7491 next;
1954             }
1955              
1956             # We have pending here-doc content that needs to be
1957             # inserted just after the first newline in the content.
1958 0 0       0 if ( $content eq "\n" ) {
1959             # Shortcut the most common case for speed
1960 0         0 $output .= $content . $heredoc;
1961             } else {
1962             # Slower and more general version
1963 0         0 $content =~ s/\n/\n$heredoc/;
1964 0         0 $output .= $content;
1965             }
1966              
1967 0         0 $heredoc = '';
1968 0         0 next;
1969             }
1970              
1971             # This token is a HereDoc.
1972             # First, add the token content as normal, which in this
1973             # case will definitely not contain a newline.
1974 0         0 $output .= $Token->content;
1975              
1976             # Now add all of the here-doc content to the heredoc buffer.
1977 0         0 foreach my $line ( $Token->heredoc ) {
1978 0         0 $heredoc .= $line;
1979             }
1980              
1981 0 0       0 if ( $Token->{_damaged} ) {
1982             # Special Case:
1983             # There are a couple of warning/bug situations
1984             # that can occur when a HereDoc content was read in
1985             # from the end of a file that we silently allow.
1986             #
1987             # When writing back out to the file we have to
1988             # auto-repair these problems if we aren't going back
1989             # on to the end of the file.
1990              
1991             # When calculating $last_line, ignore the final token if
1992             # and only if it has a single newline at the end.
1993 0         0 my $last_index = $#tokens;
1994 0 0       0 if ( $tokens[$last_index]->{content} =~ /^[^\n]*\n$/ ) {
1995 0         0 $last_index--;
1996             }
1997              
1998             # This is a two part test.
1999             # First, are we on the last line of the
2000             # content part of the file
2001             my $last_line = List::Util::none {
2002 0 0   0   0 $tokens[$_] and $tokens[$_]->{content} =~ /\n/
2003 0         0 } (($i + 1) .. $last_index);
2004 0 0       0 if ( ! defined $last_line ) {
2005             # Handles the null list case
2006 0         0 $last_line = 1;
2007             }
2008              
2009             # Secondly, are their any more here-docs after us,
2010             # (with content or a terminator)
2011             my $any_after = List::Util::any {
2012             $tokens[$_]->isa('PPI::Token::HereDoc')
2013             and (
2014 0         0 scalar(@{$tokens[$_]->{_heredoc}})
2015             or
2016             defined $tokens[$_]->{_terminator_line}
2017             )
2018 0 0 0 0   0 } (($i + 1) .. $#tokens);
  0         0  
2019 0 0       0 if ( ! defined $any_after ) {
2020             # Handles the null list case
2021 0         0 $any_after = '';
2022             }
2023              
2024             # We don't need to repair the last here-doc on the
2025             # last line. But we do need to repair anything else.
2026 0 0 0     0 unless ( $last_line and ! $any_after ) {
2027             # Add a terminating string if it didn't have one
2028 0 0       0 unless ( defined $Token->{_terminator_line} ) {
2029 0         0 $Token->{_terminator_line} = $Token->{_terminator};
2030             }
2031              
2032             # Add a trailing newline to the terminating
2033             # string if it didn't have one.
2034 0 0       0 unless ( $Token->{_terminator_line} =~ /\n$/ ) {
2035 0         0 $Token->{_terminator_line} .= "\n";
2036             }
2037             }
2038             }
2039              
2040             # Now add the termination line to the heredoc buffer
2041 0 0       0 if ( defined $Token->{_terminator_line} ) {
2042 0         0 $heredoc .= $Token->{_terminator_line};
2043             }
2044             }
2045              
2046             # End of tokens
2047              
2048 392 50       589 if ( $heredoc ne '' ) {
2049             # If the file doesn't end in a newline, we need to add one
2050             # so that the here-doc content starts on the next line.
2051 0 0       0 unless ( $output =~ /\n$/ ) {
2052 0         0 $output .= "\n";
2053             }
2054              
2055             # Now we add the remaining here-doc content
2056             # to the end of the file.
2057 0         0 $output .= $heredoc;
2058             }
2059              
2060 392         926 $output;
2061             }
2062              
2063              
2064             {
2065             # NOTE: Nice::Try::ScopeGuard class
2066             package # hide from PAUSE
2067             Nice::Try::ScopeGuard;
2068              
2069             # older versions of perl have an issue with $@ during global destruction
2070 31 50   31   207 use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;
  31         50  
  31         14591  
2071              
2072             sub _new
2073             {
2074 14     14   600461 my $this = shift( @_ );
2075 14   33     135 return( bless( [ @_ ] => ( ref( $this ) || $this ) ) );
2076             }
2077              
2078             sub DESTROY
2079             {
2080 14     14   381 my( $code, $args, $catch_err ) = @{ $_[0] };
  14         51  
2081             # save the current exception to make it available in the finally sub,
2082             # and to restore it after the eval
2083 14 50       65 my $err = defined( $catch_err ) ? $catch_err : $@;
2084 14         18 local $@ if( UNSTABLE_DOLLARAT );
2085 14 50       33 $@ = $catch_err if( defined( $catch_err ) );
2086             CORE::eval
2087             {
2088 14         20 $@ = $err;
2089 14         37 $code->( @$args );
2090 13         1951 1;
2091             }
2092             or do
2093 14 100       18 {
2094 1 50       20 CORE::warn
2095             "Execution of finally() block $code resulted in an exception, which "
2096             . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
2097             . 'Your program will continue as if this event never took place. '
2098             . "Original exception text follows:\n\n"
2099             . (defined $@ ? $@ : '$@ left undefined...')
2100             . "\n"
2101             ;
2102             };
2103             # maybe unnecessary?
2104 14         307 $@ = $err;
2105             }
2106             }
2107              
2108             {
2109             # NOTE: Nice::Try::ObjectContext
2110             package
2111             Nice::Try::ObjectContext;
2112              
2113             sub new
2114             {
2115 2     2   164524 my $that = shift( @_ );
2116 2   33     17 return( bless( { val => [@_] } => ( ref( $that ) || $that ) ) );
2117             }
2118              
2119             sub callback
2120             {
2121 2     2   5 my $self = shift( @_ );
2122 2         13 return( $self->{val}->[0] );
2123             }
2124             }
2125              
2126             {
2127             # NOTE: PPI::Element
2128             package
2129             PPI::Element;
2130            
2131 31     31   253 no warnings 'redefine';
  31         52  
  31         4414  
2132             sub replace {
2133 81 50   81 1 174 my $self = ref $_[0] ? shift : return undef;
2134             # If our object and the other are not of the same class, PPI refuses to replace
2135             # to avoid damages to perl code
2136             # my $other = _INSTANCE(shift, ref $self) or return undef;
2137 81         85 my $other = shift;
2138             # die "The ->replace method has not yet been implemented";
2139 81         158 $self->parent->__replace_child( $self, $other );
2140 81         2516 1;
2141             }
2142             }
2143              
2144             1;
2145              
2146             # NOTE POD
2147             __END__