File Coverage

blib/lib/Devel/Chitin/OpTree/UNOP.pm
Criterion Covered Total %
statement 166 172 96.5
branch 62 70 88.5
condition 31 44 70.4
subroutine 39 40 97.5
pod 1 25 4.0
total 299 351 85.1


line stmt bran cond sub pod time code
1             package Devel::Chitin::OpTree::UNOP;
2 35     35   220 use base 'Devel::Chitin::OpTree';
  35         68  
  35         4055  
3              
4             our $VERSION = '0.15';
5              
6 35     35   208 use strict;
  35         52  
  35         837  
7 35     35   175 use warnings;
  35         72  
  35         7747  
8              
9             sub first {
10 1830     1830 1 5277 shift->{children}->[0];
11             }
12              
13             sub pp_leavesub {
14 332     332 0 578 my $self = shift;
15 332         751 $self->first->deparse;
16             }
17              
18             foreach my $d ( [ pp_leavegiven => 'given' ],
19             [ pp_leavewhen => 'when' ],
20             ) {
21             my($pp_name, $perl_name) = @$d;
22             my $sub = sub {
23 5     5   9 my $self = shift;
24 5         9 my $enter = $self->first; # entergiven/enterwhen
25 5 100       12 if ($enter->other) {
26 4         9 my $term = $enter->first->deparse;
27 4         17 $self->_enter_scope;
28 4         10 my $block = $enter->other->deparse;
29 4         14 $self->_leave_scope;
30 4         27 "$perl_name ($term) $block";
31             } else {
32 1         4 'default ' . $enter->first->deparse;
33             }
34             };
35 35     35   298 no strict 'refs';
  35         100  
  35         61133  
36             *$pp_name = $sub;
37             }
38              
39              
40             # Normally, pp_list is a LISTOP, but this happens when a pp_list is turned
41             # into a pp_null by the optimizer, and it has one child
42             sub pp_list {
43 18     18 0 49 my $self = shift;
44 18         37 $self->first->deparse;
45             }
46              
47             sub pp_refgen {
48 26     26 0 45 my $self = shift;
49 26         37 my $first = $self->first;
50 26         33 my $anoncode;
51 26 50 33     48 if ($first->is_null and $first->_ex_name eq 'pp_list') {
52             # Perl 5.22 puts the anoncode OP first, older Perls have a pushmark
53             # then the anoncode
54 26         44 foreach my $op ( @{ $first->children } ) {
  26         66  
55 35 100       72 if ($op->op->name eq 'anoncode') {
56 3         6 $anoncode = $op;
57 3         6 last;
58             }
59             }
60             }
61              
62 26 100 33     79 if ($anoncode) {
    50 66        
      100        
      66        
63 3         9 my $subref = $self->_padval_sv($anoncode->op->targ);
64 3         17 my $deparser = Devel::Chitin::OpTree->build_from_location($subref->object_2svref);
65 3         11 my $deparsed = $deparser->deparse;
66 3 100       22 if ($deparsed =~ m/\n/) {
67 1         9 return join('', 'sub {', $self->_indent_block_text($deparsed), '}');
68             } else {
69 2         16 return join('', 'sub { ', $deparsed, ' }');
70             }
71              
72             } elsif ($first->is_null
73             and $first->_ex_name eq 'pp_list'
74 23         51 and @{$first->children} == 2
75             and $first->children->[-1]->is_array_container
76             and $first->children->[-1]->op->flags & B::OPf_REF
77             ) {
78             # This catches the case of \@list. Falling through to the default
79             # case, it'll deparse as \(@list)
80 0         0 '\\' . $first->children->[-1]->deparse;
81              
82             } else {
83 23         54 '\\' . $first->deparse;
84             }
85             }
86             *pp_srefgen = \&pp_refgen;
87              
88 113     113 0 273 sub pp_rv2sv { '$' . shift->first->deparse }
89 19     19 0 44 sub pp_rv2av { '@' . shift->first->deparse }
90 10     10 0 30 sub pp_rv2hv { '%' . shift->first->deparse }
91             sub pp_rv2cv {
92 36     36 0 62 my $self = shift;
93             # The null case is the most common. not-null happens
94             # with undef(&function::name) and generates this optree:
95             # undef
96             # rv2cv
97             # ex-list
98             # ex-pushmark
99             # ex-rv2cv
100             # gv(*function::name)
101             # We only want the sigil prepended once
102 36 100       75 my $sigil = $self->is_null ? '' : '&';
103 36         93 $sigil . $self->first->deparse;
104             }
105              
106             sub pp_rv2gv {
107 110     110 0 339 my($self, %params) = @_;
108 110 100 100     354 if ($self->op->flags & B::OPf_SPECIAL # happens in syswrite($fh, ...) and other I/O functions
      100        
109             or
110             $self->op->private & B::OPpDEREF_SV # happens in select($fh)
111             or
112             $params{skip_sigil} # this is a hack for "print F ..." to deparse correctly :(
113             ) {
114 50         167 return $self->first->deparse;
115             } else {
116 60         225 return '*' . $self->first->deparse;
117             }
118             }
119              
120             sub pp_entersub {
121 30     30 0 47 my $self = shift;
122              
123 30         53 my @params_ops;
124 30 100 33     73 if ($self->first->op->flags & B::OPf_KIDS) {
    50          
125             # normal sub call
126             # first is a pp_list containing a pushmark, followed by the arg
127             # list, followed by the sub name
128 26         44 (undef, @params_ops) = @{ $self->first->children };
  26         54  
129              
130             } elsif ($self->first->op->name eq 'pushmark'
131             or
132             $self->first->op->name eq 'padrange'
133             ) {
134             # method call
135             # the args are children of $self: a pushmark/padrange, invocant, then args, then method_named() with the method name
136 4         7 (undef, undef, @params_ops) = @{ $self->children };
  4         7  
137              
138             } else {
139 0         0 die "unknown entersub first op " . $self->first->op->name;
140             }
141 30         64 my $sub_name_op = pop @params_ops;
142              
143 30         55 my $prefix = '';
144 30 50       62 if ($self->op->flags & B::OPf_SPECIAL) {
    100          
145 0         0 $prefix = 'do ';
146             } elsif ($self->op->private & B::OPpENTERSUB_AMPER) {
147 3         6 $prefix = '&';
148             }
149              
150 30         54 my $function_args;
151 30 100       60 if ($self->op->flags & B::OPf_STACKED) {
152 29   100     85 $function_args = join(', ', map { $_->deparse } @params_ops) || '';
153             }
154              
155 30         85 my $sub_invocation = $prefix . _deparse_sub_invocation($sub_name_op);
156              
157 30 100       93 if ($sub_name_op->op->private & B::OPpENTERSUB_NOPAREN) {
    100          
158 2 100       11 $function_args
159             ? join(' ', $sub_invocation, $function_args)
160             : $sub_invocation;
161              
162             } elsif (defined $function_args) {
163 27         112 "$sub_invocation($function_args)";
164             } else {
165 1         4 $sub_invocation;
166             }
167             }
168              
169             sub _deparse_sub_invocation {
170 30     30   47 my $op = shift;
171              
172 30         78 my $op_name = $op->op->name;
173 30 100 66     107 if ($op_name eq 'rv2cv'
    50 66        
      66        
174             or
175             ( $op->is_null and $op->_ex_name eq 'pp_rv2cv' )
176             ) {
177             # subroutine call
178              
179 26 100       58 if ($op->first->op->name eq 'gv') {
180             # normal sub call: Some::Sub::named(...)
181 24         61 $op->deparse;
182             } else {
183             # subref call
184 2         6 $op->deparse . '->';
185             }
186              
187             } elsif ($op_name eq 'method_named' or $op_name eq 'method') {
188 4         11 join('->', $op->parent->children->[1]->deparse(skip_quotes => 1), # class
189             $op->deparse(skip_quotes => 1));
190              
191             } else {
192 0         0 die "unknown sub invocation for $op_name";
193             }
194             }
195              
196             sub pp_method {
197 2     2 0 5 my $self = shift;
198 2         6 $self->first->deparse;
199             }
200              
201             sub pp_av2arylen {
202 2     2 0 5 my $self = shift;
203              
204 2         4 substr(my $list_name = $self->first->deparse, 0, 1, ''); # remove sigil
205 2         8 '$#' . $list_name;
206             }
207              
208             sub pp_delete {
209 11     11 0 17 my $self = shift;
210 11 100 66     19 my $local = ($self->op->private & B::OPpLVAL_INTRO
211             || $self->first->op->private & B::OPpLVAL_INTRO)
212             ? 'local '
213             : '';
214 11         25 "delete(${local}" . $self->first->deparse . ')';
215             }
216              
217             sub pp_exists {
218 3     3 0 14 my $self = shift;
219 3         9 my $arg = $self->first->deparse;
220 3 100       8 if ($self->op->private & B::OPpEXISTS_SUB) {
221 1         3 $arg = "&${arg}";
222             }
223 3         12 "exists($arg)";
224             }
225              
226             # goto expr
227             sub pp_goto {
228 3     3 0 7 my $target = shift->first->deparse;
229             # goto &sub will deparse to goto \&sub
230 3         11 $target =~ s/^\\&/&/;
231 3         10 'goto ' . $target;
232             }
233              
234             sub pp_readline {
235 6     6 0 9 my $self = shift;
236 6         13 my $arg = $self->first->deparse;
237 6         15 my $first = $self->first;
238              
239 6         14 my $flags = $self->op->flags;
240 6 100       25 if ($flags & B::OPf_SPECIAL) {
    100          
241 1 50       6 $arg eq 'ARGV'
242             ? '<<>>'
243             : "<${arg}>";
244              
245             } elsif ($self->first->op->name eq 'gv') {
246             #
247 2         8 "<${arg}>"
248              
249             # } elsif ($flags & B::OPf_STACKED) {
250             # # readline(*F)
251             # "readline(${arg})"
252             #
253             # } else {
254             # # readline($fh)
255             # "readline(${arg})";
256             # }
257             } else {
258 3         11 "readline(${arg})";
259             }
260             }
261              
262             sub pp_undef {
263             #'undef(' . shift->first->deparse . ')'
264 6     6 0 10 my $self = shift;
265 6         12 my $arg = $self->first->deparse;
266 6 100       23 if ($arg =~ m/::/) {
267 1         3 $arg = $self->first->deparse;
268             }
269 6         23 "undef($arg)";
270             }
271              
272             # backtick is strange... It's an UNOP, but can have 2 children
273             # seems that if it has one child, it was originally readpipe
274             # if it has 2 (an ex-pushmark, then the real child), it was baskticks or qx//
275             # since UNOPs don't have a last() method, we have to use $self->first->sibling
276             sub pp_backtick {
277 5     5 0 9 my $self = shift;
278 5 100       10 if (my $content_op = $self->first->sibling) {
279 2         8 '`' . $content_op->deparse(skip_quotes => 1) . '`';
280             } else {
281 3         8 'readpipe(' . $self->first->deparse .')';
282             }
283             }
284              
285             # Functions that can operate on $_
286             # OP name Perl fcn targmy?
287             foreach my $a ( [ pp_entereval => 'eval', 0 ],
288             [ pp_schomp => 'chomp', 1 ],
289             [ pp_schop => 'chop', 1 ],
290             [ pp_chr => 'chr', 1 ],
291             [ pp_hex => 'hex', 1 ],
292             [ pp_lc => 'lc', 0 ],
293             [ pp_lcfirst => 'lcfirst', 0 ],
294             [ pp_uc => 'uc', 0 ],
295             [ pp_ucfirst => 'ucfirst', 0 ],
296             [ pp_length => 'length', 1 ],
297             [ pp_oct => 'oct', 1 ],
298             [ pp_ord => 'ord', 1 ],
299             [ pp_abs => 'abs', 1 ],
300             [ pp_cos => 'cos', 1 ],
301             [ pp_sin => 'sin', 1 ],
302             [ pp_exp => 'exp', 1 ],
303             [ pp_int => 'int', 1 ],
304             [ pp_log => 'log', 1 ],
305             [ pp_sqrt => 'sqrt', 1 ],
306             [ pp_quotemeta => 'quotemeta', 1 ],
307             [ pp_chroot => 'chroot', 1 ],
308             [ pp_readlink => 'readlink', 0 ],
309             [ pp_rmdir => 'rmdir', 1 ],
310             [ pp_defined => 'defined', 0 ],
311             [ pp_pos => 'pos', 0 ],
312             [ pp_alarm => 'alarm', 0 ],
313             [ pp_ref => 'ref', 0 ],
314             ) {
315             my($pp_name, $perl_name, $targmy) = @$a;
316             my $sub = sub {
317 82     82   147 my $self = shift;
318 82         195 my $arg = $self->first->deparse;
319              
320 82 100       292 my $target = $targmy ? $self->_maybe_targmy : '';
321 82 100       424 "${target}${perl_name}("
322             . ($arg eq '$_' ? '' : $arg)
323             . ')';
324             };
325 35     35   335 no strict 'refs';
  35         79  
  35         10348  
326             *$pp_name = $sub;
327             }
328              
329             # Functions that don't operate on $_
330             # OP name Perl fcn targmy?
331             foreach my $a ( [ pp_scalar => 'scalar', 0 ],
332             [ pp_rand => 'rand', 1 ],
333             [ pp_srand => 'srand', 1 ],
334             [ pp_each => 'each', 0 ],
335             [ pp_keys => 'keys', 0 ],
336             [ pp_values => 'values', 0 ],
337             [ pp_akeys => 'keys', 0 ],
338             [ pp_avalues => 'values', 0 ],
339             [ pp_aeach => 'each', 0 ],
340             [ pp_reach => 'each', 0 ],
341             [ pp_rkeys => 'keys', 0 ],
342             [ pp_rvalues => 'values', 0 ],
343             [ pp_ggrgid => 'getgrgid', 0 ],
344             [ pp_gpwuid => 'getpwuid', 0 ],
345             [ pp_gpwnam => 'getpwnam', 0 ],
346             [ pp_gpwent => 'getpwent', 0 ],
347             [ pp_ggrnam => 'getgrnam', 0 ],
348             [ pp_close => 'close', 0 ],
349             [ pp_closedir => 'closedir', 0 ],
350             [ pp_dbmclose => 'dbmclose', 0 ],
351             [ pp_eof => 'eof', 0 ],
352             [ pp_fileno => 'fileno', 0 ],
353             [ pp_getc => 'getc', 0 ],
354             [ pp_readdir => 'readdir', 0 ],
355             [ pp_rewinddir => 'rewinddir', 0 ],
356             [ pp_tell => 'tell', 0 ],
357             [ pp_telldir => 'telldir', 0 ],
358             [ pp_enterwrite => 'write', 0 ],
359             [ pp_ghbyname => 'gethostbyname', 0 ],
360             [ pp_gnbyname => 'getnetbyname', 0 ],
361             [ pp_gpbyname => 'getprotobyname', 0 ],
362             [ pp_shostent => 'sethostent', 0 ],
363             [ pp_snetent => 'setnetent', 0 ],
364             [ pp_sprotoent => 'setprotoent', 0 ],
365             [ pp_sservent => 'setservent', 0 ],
366             [ pp_getpgrp => 'getpgrp', 1 ],
367             [ pp_tied => 'tied', 0 ],
368             [ pp_untie => 'untie', 0 ],
369             [ pp_getpeername=> 'getpeername', 0 ],
370             [ pp_getsockname=> 'getsockname', 0 ],
371             [ pp_caller => 'caller', 0 ],
372             [ pp_exit => 'exit', 0 ],
373             ) {
374             my($pp_name, $perl_name, $targmy) = @$a;
375             my $sub = sub {
376 74     74   136 my $self = shift;
377 74         148 my $arg = $self->first->deparse;
378              
379 74 100       209 my $target = $targmy ? $self->_maybe_targmy : '';
380 74         310 "${target}${perl_name}($arg)";
381             };
382 35     35   291 no strict 'refs';
  35         65  
  35         4829  
383             *$pp_name = $sub;
384             }
385              
386             # These look like keywords but take an argument
387             foreach my $a ( [ pp_dump => 'dump' ],
388             [ pp_next => 'next' ],
389             [ pp_last => 'last' ],
390             [ pp_redo => 'redo' ],
391             ) {
392             my($pp_name, $perl_name) = @$a;
393             my $sub = sub {
394 5     5   7 my $self = shift;
395 5         12 my $arg = $self->first->deparse;
396 5         18 "${perl_name} $arg";
397             };
398 35     35   224 no strict 'refs';
  35         58  
  35         21813  
399             *$pp_name = $sub;
400             }
401              
402             sub pp_umask {
403 1     1 0 2 my $self = shift;
404 1         5 'umask(' . $self->_as_octal( $self->first->deparse(skip_quotes => 1) ) . ')';
405             }
406              
407             # Note that there's no way to tell the difference between "!" and "not"
408             sub pp_not {
409 9     9 0 21 my $first = shift->first;
410 9         19 my $first_deparsed = $first->deparse;
411              
412 9 100 66     26 if ($first->op->name eq 'match'
413             and
414             $first->_get_bound_variable_for_match
415             ) {
416 1         3 $first_deparsed; # The match op will turn it into $var !~ m/.../
417             } else {
418 8         29 '!' . $first_deparsed;
419             }
420             }
421              
422             sub pp_flop {
423 2     2 0 5 my $self = shift;
424 2         5 my $flip = $self->first;
425 2 100       6 my $op = ($flip->op->flags & B::OPf_SPECIAL) ? '...' : '..';
426              
427 2         4 my $range = $flip->first;
428 2         4 my $start = $range->first->deparse;
429 2         14 my $end = $range->other->deparse;
430              
431 2         11 "$start $op $end";
432             }
433              
434             sub pp_dofile {
435 2     2 0 7 'do ' . shift->first->deparse;
436             }
437              
438             sub pp_require {
439 4     4 0 9 my $self = shift;
440              
441 4         8 my $first = $self->first;
442 4         9 my $name = $first->deparse;
443 4 100 100     12 if ($first->op->name eq 'const'
444             and
445             $first->op->private & B::OPpCONST_BARE
446             ) {
447 1         5 $name =~ s#/#::#g;
448 1         6 $name =~ s/\.pm$//;
449             }
450              
451 4         14 'require ' . $name;
452             }
453              
454             *pp_aelem = *pp_helem = sub {
455             # This is likely an optimized-out op where ->first is a pp_multideref
456             # that'll do all the work for us
457 9     9   33 shift->first->deparse;
458             };
459              
460             sub pp_sassign {
461 2     2 0 5 my $self = shift;
462             # This is likely an optimized-out assignment where substr is being
463             # used as an lvalue. pp_substr will be our only child and take care of
464             # deparsing the assignment for us
465 2         5 $self->first->deparse;
466             }
467              
468             # 5.12 and earlier Perls used glob as an optimized-out UNOP and looks like
469             # a call to CORE::GLOBAL__glob()
470             # This glob is compiled like this:
471             # ex-pp_glob
472             # entersub
473             # ex-list
474             # pushmark
475             # argument-to-glob
476             # const integer 0
477             # ex-rv2cv
478             # gv *CORE::GLOBAL::glob
479             # 5.14 is wierder - it has the same ex-glob/entersub, but then a real glob OP
480             # inside there
481             # ex-pp_glob
482             # entersub
483             # ex-list
484             # pushmark
485             # glob (listOP)
486             # ex-pushmark
487             # argument-to-glob
488             # const integer 0
489             # ex-rv2cv
490             # gv *CORE::GLOBAL::glob
491             # Newer perls just have the inner LISTOP and encode the params differently.
492             sub pp_glob {
493 0     0 0 0 my $self = shift;
494 0 0       0 ($^V lt v5.14)
495             ? 'glob(' . $self->first->first->children->[1]->deparse . ')'
496             : $self->first->first->children->[1]->deparse;
497             }
498              
499             # Operators
500             # OP name perl op pre? targmy?
501             foreach my $a ( [ pp_preinc => '++', 1, 0 ],
502             [ pp_i_preinc => '++', 1, 0 ],
503             [ pp_postinc => '++', 0, 1 ],
504             [ pp_i_postinc => '++', 0, 1 ],
505             [ pp_predec => '--', 1, 0 ],
506             [ pp_i_predec => '--', 1, 0 ],
507             [ pp_postdec => '--', 0, 1 ],
508             [ pp_i_postdec => '--', 0, 1 ],
509             [ pp_complement => '~', 1, 1 ],
510             [ pp_scomplement => '~.', 1, 1 ],
511             ) {
512             my($pp_name, $op, $is_prefix, $is_targmy) = @$a;
513              
514             my $sub = sub {
515 14     14   32 my $self = shift;
516 14 100       37 my $deparsed = $is_prefix
517             ? ($op . $self->first->deparse)
518             : ($self->first->deparse . $op);
519 14 100       33 if ($is_targmy) {
520 4         15 $deparsed = $self->_maybe_targmy . $deparsed;
521             }
522 14         34 $deparsed;
523             };
524 35     35   266 no strict 'refs';
  35         60  
  35         3310  
525             *$pp_name = $sub;
526             }
527              
528             #sub pp_leavewhereso {
529             # my $self = shift;
530             #
531             # my $enter_op = $self->first;
532             # my $condition_op = $enter_op->first;
533             # my $condition_deparsed = $condition_op->deparse;
534             # my $block_op = $condition_op->sibling;
535             #
536             # my $keyword = $condition_op->op->name eq 'smartmatch'
537             # ? 'whereis'
538             # : 'whereso';
539             #
540             # if ($self->_is_postfix_whereso) {
541             # my $block_deparsed = $block_op->deparse(omit_braces => 1, skip => 0, noindent => 1);
542             # "$block_deparsed $keyword ($condition_deparsed);" # ; because there's no COPs inside given to generate them
543             # } else {
544             # my $block_deparsed = $block_op->deparse(force_multiline => 1);
545             # "$keyword ($condition_deparsed) $block_deparsed";
546             # }
547             #}
548             #
549             ## "regular" whereso has a format like:
550             ## 1-line with braces:
551             ## leavewhereso
552             ## enterwhereso
553             ## condition-op(s)
554             ## scope
555             ## (ex-)nextstate
556             ## block-op(s)
557             ## or multiline with braces:
558             ## leavewhereso
559             ## enterwhereso
560             ## condition-op(s)
561             ## leave
562             ## enter
563             ## block-op(s)
564             ## postfix whereso looks like the first one, but missing the nextstate that's
565             ## the first part of the scope
566             #sub _is_postfix_whereso {
567             # my $self = shift;
568             # my $scope_op = $self->first->first->sibling;
569             # my $scope_name = $scope_op->op->name;
570             #
571             # my $first_in_scope_op = $scope_name eq 'scope' ? $scope_op->first : undef;
572             # return( $scope_name eq 'scope'
573             # and $first_in_scope_op
574             # and ! $first_in_scope_op->is_null
575             # and ! ($first_in_scope_op->_ex_name eq 'pp_nextstate')
576             # );
577             #}
578              
579             1;
580              
581             __END__