This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
misplaced braces
[perl5.git] / ext / B / B / Deparse.pm
CommitLineData
6e90668e 1# B::Deparse.pm
3ed82cfc 2# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved.
6e90668e
SM
3# This module is free software; you can redistribute and/or modify
4# it under the same terms as Perl itself.
5
6# This is based on the module of the same name by Malcolm Beattie,
7# but essentially none of his code remains.
8
a798dbf2 9package B::Deparse;
f4a44678 10use Carp 'cluck', 'croak';
4c1f658f 11use B qw(class main_root main_start main_cv svref_2object opnumber
bd0865ec
GS
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
14 OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
3ed82cfc 15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
bd0865ec
GS
16 SVf_IOK SVf_NOK SVf_ROK SVf_POK
17 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
18 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
3ed82cfc 19$VERSION = 0.59;
a798dbf2 20use strict;
a798dbf2 21
6e90668e
SM
22# Changes between 0.50 and 0.51:
23# - fixed nulled leave with live enter in sort { }
24# - fixed reference constants (\"str")
25# - handle empty programs gracefully
26# - handle infinte loops (for (;;) {}, while (1) {})
27# - differentiate between `for my $x ...' and `my $x; for $x ...'
28# - various minor cleanups
29# - moved globals into an object
30# - added `-u', like B::C
31# - package declarations using cop_stash
32# - subs, formats and code sorted by cop_seq
f6f9bdb7
SM
33# Changes between 0.51 and 0.52:
34# - added pp_threadsv (special variables under USE_THREADS)
35# - added documentation
bd0865ec 36# Changes between 0.52 and 0.53:
9d2c6865
SM
37# - many changes adding precedence contexts and associativity
38# - added `-p' and `-s' output style options
39# - various other minor fixes
bd0865ec 40# Changes between 0.53 and 0.54:
d7f5b6da
SM
41# - added support for new `for (1..100)' optimization,
42# thanks to Gisle Aas
bd0865ec 43# Changes between 0.54 and 0.55:
90be192f
SM
44# - added support for new qr// construct
45# - added support for new pp_regcreset OP
bd0865ec 46# Changes between 0.55 and 0.56:
f5aa8f4e
SM
47# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
48# - fixed $# on non-lexicals broken in last big rewrite
49# - added temporary fix for change in opcode of OP_STRINGIFY
50# - fixed problem in 0.54's for() patch in `for (@ary)'
51# - fixed precedence in conditional of ?:
52# - tweaked list paren elimination in `my($x) = @_'
53# - made continue-block detection trickier wrt. null ops
54# - fixed various prototype problems in pp_entersub
55# - added support for sub prototypes that never get GVs
56# - added unquoting for special filehandle first arg in truncate
57# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
58# - added semicolons at the ends of blocks
59# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
bd0865ec
GS
60# Changes between 0.56 and 0.561:
61# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
62# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
63# Changes between 0.561 and 0.57:
64# - stylistic changes to symbolic constant stuff
65# - handled scope in s///e replacement code
66# - added unquote option for expanding "" into concats, etc.
67# - split method and proto parts of pp_entersub into separate functions
68# - various minor cleanups
f4a44678
SM
69# Changes after 0.57:
70# - added parens in \&foo (patch by Albert Dvornik)
71# Changes between 0.57 and 0.58:
72# - fixed `0' statements that weren't being printed
73# - added methods for use from other programs
74# (based on patches from James Duncan and Hugo van der Sanden)
75# - added -si and -sT to control indenting (also based on a patch from Hugo)
76# - added -sv to print something else instead of '???'
77# - preliminary version of utf8 tr/// handling
3ed82cfc
GS
78# Changes after 0.58:
79# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
80# - added support for Hugo's new OP_SETSTATE (like nextstate)
81# Changes between 0.58 and 0.59
82# - added support for Chip's OP_METHOD_NAMED
83# - added support for Ilya's OPpTARGET_MY optimization
84# - elided arrows before `()' subscripts when possible
6e90668e
SM
85
86# Todo:
f4a44678
SM
87# - finish tr/// changes
88# - add option for even more parens (generalize \&foo change)
9d2c6865 89# - {} around variables in strings ("${var}letters")
f5aa8f4e
SM
90# base/lex.t 25-27
91# comp/term.t 11
90be192f 92# - left/right context
bd0865ec 93# - recognize `use utf8', `use integer', etc
f4a44678
SM
94# - treat top-level block specially for incremental output
95# - interpret in high bit chars in string as utf8 \x{...} (when?)
3ed82cfc 96# - copy comments (look at real text with $^P?)
f5aa8f4e 97# - avoid semis in one-statement blocks
9d2c6865 98# - associativity of &&=, ||=, ?:
6e90668e
SM
99# - ',' => '=>' (auto-unquote?)
100# - break long lines ("\r" as discretionary break?)
f4a44678
SM
101# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
102# - more style options: brace style, hex vs. octal, quotes, ...
103# - print big ints as hex/octal instead of decimal (heuristic?)
3ed82cfc 104# - handle `my $x if 0'?
f5aa8f4e
SM
105# - include values of variables (e.g. set in BEGIN)
106# - coordinate with Data::Dumper (both directions? see previous)
6e90668e
SM
107# - version using op_next instead of op_first/sibling?
108# - avoid string copies (pass arrays, one big join?)
109# - auto-apply `-u'?
9d2c6865
SM
110# - while{} with one-statement continue => for(; XXX; XXX) {}?
111# - -uPackage:: descend recursively?
112# - here-docs?
113# - <DATA>?
6e90668e 114
f5aa8f4e
SM
115# Tests that will always fail:
116# comp/redef.t -- all (redefinition happens at compile time)
117
6e90668e
SM
118# Object fields (were globals):
119#
120# avoid_local:
121# (local($a), local($b)) and local($a, $b) have the same internal
122# representation but the short form looks better. We notice we can
123# use a large-scale local when checking the list, but need to prevent
124# individual locals too. This hash holds the addresses of OPs that
125# have already had their local-ness accounted for. The same thing
126# is done with my().
127#
128# curcv:
129# CV for current sub (or main program) being deparsed
130#
131# curstash:
132# name of the current package for deparsed code
133#
134# subs_todo:
135# array of [cop_seq, GV, is_format?] for subs and formats we still
136# want to deparse
137#
f5aa8f4e
SM
138# protos_todo:
139# as above, but [name, prototype] for subs that never got a GV
140#
6e90668e
SM
141# subs_done, forms_done:
142# keys are addresses of GVs for subs and formats we've already
143# deparsed (or at least put into subs_todo)
9d2c6865
SM
144#
145# parens: -p
f5aa8f4e 146# linenums: -l
bd0865ec 147# unquote: -q
9d2c6865 148# cuddle: ` ' or `\n', depending on -sC
f4a44678
SM
149# indent_size: -si
150# use_tabs: -sT
151# ex_const: -sv
9d2c6865
SM
152
153# A little explanation of how precedence contexts and associativity
154# work:
155#
156# deparse() calls each per-op subroutine with an argument $cx (short
157# for context, but not the same as the cx* in the perl core), which is
158# a number describing the op's parents in terms of precedence, whether
f5aa8f4e 159# they're inside an expression or at statement level, etc. (see
9d2c6865
SM
160# chart below). When ops with children call deparse on them, they pass
161# along their precedence. Fractional values are used to implement
162# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
163# parentheses hacks. The major disadvantage of this scheme is that
164# it doesn't know about right sides and left sides, so say if you
165# assign a listop to a variable, it can't tell it's allowed to leave
166# the parens off the listop.
167
168# Precedences:
169# 26 [TODO] inside interpolation context ("")
170# 25 left terms and list operators (leftward)
171# 24 left ->
172# 23 nonassoc ++ --
173# 22 right **
174# 21 right ! ~ \ and unary + and -
175# 20 left =~ !~
176# 19 left * / % x
177# 18 left + - .
178# 17 left << >>
179# 16 nonassoc named unary operators
180# 15 nonassoc < > <= >= lt gt le ge
181# 14 nonassoc == != <=> eq ne cmp
182# 13 left &
183# 12 left | ^
184# 11 left &&
185# 10 left ||
186# 9 nonassoc .. ...
187# 8 right ?:
188# 7 right = += -= *= etc.
189# 6 left , =>
190# 5 nonassoc list operators (rightward)
191# 4 right not
192# 3 left and
193# 2 left or xor
194# 1 statement modifiers
195# 0 statement level
196
197# Nonprinting characters with special meaning:
198# \cS - steal parens (see maybe_parens_unop)
199# \n - newline and indent
200# \t - increase indent
201# \b - decrease indent (`outdent')
f5aa8f4e 202# \f - flush left (no indent)
9d2c6865 203# \cK - kill following semicolon, if any
6e90668e
SM
204
205sub null {
206 my $op = shift;
207 return class($op) eq "NULL";
208}
209
210sub todo {
211 my $self = shift;
212 my($gv, $cv, $is_form) = @_;
213 my $seq;
214 if (!null($cv->START) and is_state($cv->START)) {
215 $seq = $cv->START->cop_seq;
216 } else {
217 $seq = 0;
218 }
219 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
220}
221
222sub next_todo {
223 my $self = shift;
224 my $ent = shift @{$self->{'subs_todo'}};
225 my $name = $self->gv_name($ent->[1]);
226 if ($ent->[2]) {
227 return "format $name =\n"
228 . $self->deparse_format($ent->[1]->FORM). "\n";
229 } else {
3ed82cfc 230 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
6e90668e
SM
231 }
232}
233
6e90668e
SM
234sub walk_tree {
235 my($op, $sub) = @_;
236 $sub->($op);
237 if ($op->flags & OPf_KIDS) {
238 my $kid;
239 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
240 walk_tree($kid, $sub);
241 }
242 }
243}
244
245sub walk_sub {
246 my $self = shift;
247 my $cv = shift;
248 my $op = $cv->ROOT;
249 $op = shift if null $op;
250 return if !$op or null $op;
251 walk_tree($op, sub {
252 my $op = shift;
3f872cb9
GS
253 if ($op->name eq "gv") {
254 if ($op->next->name eq "entersub") {
6e90668e
SM
255 next if $self->{'subs_done'}{$ {$op->gv}}++;
256 next if class($op->gv->CV) eq "SPECIAL";
257 $self->todo($op->gv, $op->gv->CV, 0);
258 $self->walk_sub($op->gv->CV);
3f872cb9
GS
259 } elsif ($op->next->name eq "enterwrite"
260 or ($op->next->name eq "rv2gv"
261 and $op->next->next->name eq "enterwrite")) {
6e90668e
SM
262 next if $self->{'forms_done'}{$ {$op->gv}}++;
263 next if class($op->gv->FORM) eq "SPECIAL";
264 $self->todo($op->gv, $op->gv->FORM, 1);
265 $self->walk_sub($op->gv->FORM);
266 }
267 }
268 });
269}
270
271sub stash_subs {
272 my $self = shift;
273 my $pack = shift;
274 my(%stash, @ret);
275 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
f5aa8f4e
SM
276 if ($pack eq "main") {
277 $pack = "";
278 } else {
279 $pack = $pack . "::";
280 }
6e90668e
SM
281 my($key, $val);
282 while (($key, $val) = each %stash) {
f5aa8f4e
SM
283 my $class = class($val);
284 if ($class eq "PV") {
285 # Just a prototype
286 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
287 } elsif ($class eq "IV") {
288 # Just a name
289 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
290 } elsif ($class eq "GV") {
291 if (class($val->CV) ne "SPECIAL") {
292 next if $self->{'subs_done'}{$$val}++;
293 $self->todo($val, $val->CV, 0);
294 $self->walk_sub($val->CV);
295 }
296 if (class($val->FORM) ne "SPECIAL") {
297 next if $self->{'forms_done'}{$$val}++;
298 $self->todo($val, $val->FORM, 1);
299 $self->walk_sub($val->FORM);
300 }
6e90668e
SM
301 }
302 }
303}
a798dbf2 304
f5aa8f4e
SM
305sub print_protos {
306 my $self = shift;
307 my $ar;
308 my @ret;
309 foreach $ar (@{$self->{'protos_todo'}}) {
310 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
311 push @ret, "sub " . $ar->[0] . "$proto;\n";
312 }
313 delete $self->{'protos_todo'};
314 return @ret;
315}
316
9d2c6865
SM
317sub style_opts {
318 my $self = shift;
319 my $opts = shift;
320 my $opt;
321 while (length($opt = substr($opts, 0, 1))) {
322 if ($opt eq "C") {
323 $self->{'cuddle'} = " ";
f4a44678
SM
324 $opts = substr($opts, 1);
325 } elsif ($opt eq "i") {
326 $opts =~ s/^i(\d+)//;
327 $self->{'indent_size'} = $1;
328 } elsif ($opt eq "T") {
329 $self->{'use_tabs'} = 1;
330 $opts = substr($opts, 1);
331 } elsif ($opt eq "v") {
332 $opts =~ s/^v([^.]*)(.|$)//;
333 $self->{'ex_const'} = $1;
9d2c6865 334 }
9d2c6865
SM
335 }
336}
337
f4a44678
SM
338sub new {
339 my $class = shift;
340 my $self = bless {}, $class;
341 $self->{'subs_todo'} = [];
342 $self->{'curstash'} = "main";
343 $self->{'cuddle'} = "\n";
344 $self->{'indent_size'} = 4;
345 $self->{'use_tabs'} = 0;
346 $self->{'ex_const'} = "'???'";
347 while (my $arg = shift @_) {
348 if (substr($arg, 0, 2) eq "-u") {
349 $self->stash_subs(substr($arg, 2));
350 } elsif ($arg eq "-p") {
351 $self->{'parens'} = 1;
352 } elsif ($arg eq "-l") {
353 $self->{'linenums'} = 1;
354 } elsif ($arg eq "-q") {
355 $self->{'unquote'} = 1;
356 } elsif (substr($arg, 0, 2) eq "-s") {
357 $self->style_opts(substr $arg, 2);
358 }
359 }
360 return $self;
361}
362
a798dbf2 363sub compile {
6e90668e
SM
364 my(@args) = @_;
365 return sub {
f4a44678 366 my $self = B::Deparse->new(@args);
6e90668e
SM
367 $self->stash_subs("main");
368 $self->{'curcv'} = main_cv;
6e90668e 369 $self->walk_sub(main_cv, main_start);
f5aa8f4e 370 print $self->print_protos;
6e90668e 371 @{$self->{'subs_todo'}} =
f4a44678
SM
372 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
373 print $self->indent($self->deparse(main_root, 0)), "\n"
374 unless null main_root;
6e90668e
SM
375 my @text;
376 while (scalar(@{$self->{'subs_todo'}})) {
377 push @text, $self->next_todo;
378 }
379 print indent(join("", @text)), "\n" if @text;
a798dbf2 380 }
a798dbf2
MB
381}
382
f4a44678
SM
383sub coderef2text {
384 my $self = shift;
385 my $sub = shift;
386 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
387 return $self->indent($self->deparse_sub(svref_2object($sub)));
388}
389
6e90668e
SM
390sub deparse {
391 my $self = shift;
9d2c6865
SM
392 my($op, $cx) = @_;
393# cluck if class($op) eq "NULL";
3f872cb9
GS
394# return $self->$ {\("pp_" . $op->name)}($op, $cx);
395 my $meth = "pp_" . $op->name;
9d2c6865 396 return $self->$meth($op, $cx);
a798dbf2
MB
397}
398
6e90668e 399sub indent {
f4a44678 400 my $self = shift;
6e90668e
SM
401 my $txt = shift;
402 my @lines = split(/\n/, $txt);
403 my $leader = "";
f4a44678 404 my $level = 0;
6e90668e
SM
405 my $line;
406 for $line (@lines) {
f4a44678
SM
407 my $cmd = substr($line, 0, 1);
408 if ($cmd eq "\t" or $cmd eq "\b") {
409 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
410 if ($self->{'use_tabs'}) {
411 $leader = "\t" x ($level / 8) . " " x ($level % 8);
412 } else {
413 $leader = " " x $level;
414 }
6e90668e
SM
415 $line = substr($line, 1);
416 }
f5aa8f4e
SM
417 if (substr($line, 0, 1) eq "\f") {
418 $line = substr($line, 1); # no indent
419 } else {
420 $line = $leader . $line;
421 }
9d2c6865 422 $line =~ s/\cK;?//g;
6e90668e
SM
423 }
424 return join("\n", @lines);
425}
426
6e90668e
SM
427sub deparse_sub {
428 my $self = shift;
429 my $cv = shift;
430 my $proto = "";
431 if ($cv->FLAGS & SVf_POK) {
432 $proto = "(". $cv->PV . ") ";
433 }
434 local($self->{'curcv'}) = $cv;
435 local($self->{'curstash'}) = $self->{'curstash'};
436 if (not null $cv->ROOT) {
437 # skip leavesub
438 return $proto . "{\n\t" .
9d2c6865 439 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
6e90668e
SM
440 } else { # XSUB?
441 return $proto . "{}\n";
442 }
443}
444
445sub deparse_format {
446 my $self = shift;
447 my $form = shift;
448 my @text;
449 local($self->{'curcv'}) = $form;
450 local($self->{'curstash'}) = $self->{'curstash'};
451 my $op = $form->ROOT;
452 my $kid;
453 $op = $op->first->first; # skip leavewrite, lineseq
454 while (not null $op) {
455 $op = $op->sibling; # skip nextstate
456 my @exprs;
457 $kid = $op->first->sibling; # skip pushmark
458 push @text, $kid->sv->PV;
459 $kid = $kid->sibling;
460 for (; not null $kid; $kid = $kid->sibling) {
9d2c6865 461 push @exprs, $self->deparse($kid, 0);
6e90668e
SM
462 }
463 push @text, join(", ", @exprs)."\n" if @exprs;
464 $op = $op->sibling;
465 }
466 return join("", @text) . ".";
467}
468
6e90668e 469sub is_scope {
a798dbf2 470 my $op = shift;
3f872cb9
GS
471 return $op->name eq "leave" || $op->name eq "scope"
472 || $op->name eq "lineseq"
473 || ($op->name eq "null" && class($op) eq "UNOP"
474 && (is_scope($op->first) || $op->first->name eq "enter"));
6e90668e
SM
475}
476
477sub is_state {
3f872cb9
GS
478 my $name = $_[0]->name;
479 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
6e90668e
SM
480}
481
482sub is_miniwhile { # check for one-line loop (`foo() while $y--')
483 my $op = shift;
484 return (!null($op) and null($op->sibling)
3f872cb9
GS
485 and $op->name eq "null" and class($op) eq "UNOP"
486 and (($op->first->name =~ /^(and|or)$/
487 and $op->first->first->sibling->name eq "lineseq")
488 or ($op->first->name eq "lineseq"
6e90668e 489 and not null $op->first->first->sibling
3f872cb9 490 and $op->first->first->sibling->name eq "unstack")
6e90668e
SM
491 ));
492}
493
494sub is_scalar {
495 my $op = shift;
3f872cb9
GS
496 return ($op->name eq "rv2sv" or
497 $op->name eq "padsv" or
498 $op->name eq "gv" or # only in array/hash constructs
bd0865ec 499 $op->flags & OPf_KIDS && !null($op->first)
3f872cb9 500 && $op->first->name eq "gvsv");
6e90668e
SM
501}
502
9d2c6865
SM
503sub maybe_parens {
504 my $self = shift;
505 my($text, $cx, $prec) = @_;
506 if ($prec < $cx # unary ops nest just fine
507 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
508 or $self->{'parens'})
509 {
510 $text = "($text)";
511 # In a unop, let parent reuse our parens; see maybe_parens_unop
512 $text = "\cS" . $text if $cx == 16;
513 return $text;
514 } else {
515 return $text;
516 }
517}
518
519# same as above, but get around the `if it looks like a function' rule
520sub maybe_parens_unop {
521 my $self = shift;
522 my($name, $kid, $cx) = @_;
523 if ($cx > 16 or $self->{'parens'}) {
524 return "$name(" . $self->deparse($kid, 1) . ")";
525 } else {
526 $kid = $self->deparse($kid, 16);
527 if (substr($kid, 0, 1) eq "\cS") {
528 # use kid's parens
529 return $name . substr($kid, 1);
530 } elsif (substr($kid, 0, 1) eq "(") {
531 # avoid looks-like-a-function trap with extra parens
532 # (`+' can lead to ambiguities)
533 return "$name(" . $kid . ")";
534 } else {
535 return "$name $kid";
536 }
537 }
538}
539
540sub maybe_parens_func {
541 my $self = shift;
542 my($func, $text, $cx, $prec) = @_;
543 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
544 return "$func($text)";
545 } else {
546 return "$func $text";
547 }
548}
549
6e90668e
SM
550sub maybe_local {
551 my $self = shift;
9d2c6865 552 my($op, $cx, $text) = @_;
4c1f658f 553 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
9d2c6865 554 return $self->maybe_parens_func("local", $text, $cx, 16);
6e90668e
SM
555 } else {
556 return $text;
a798dbf2 557 }
a798dbf2
MB
558}
559
3ed82cfc
GS
560sub maybe_targmy {
561 my $self = shift;
562 my($op, $cx, $func, @args) = @_;
563 if ($op->private & OPpTARGET_MY) {
564 my $var = $self->padname($op->targ);
565 my $val = $func->($self, $op, 7, @args);
566 return $self->maybe_parens("$var = $val", $cx, 7);
567 } else {
568 return $func->($self, $op, $cx, @args);
569 }
570}
571
6e90668e
SM
572sub padname_sv {
573 my $self = shift;
574 my $targ = shift;
575 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
576}
577
578sub maybe_my {
579 my $self = shift;
9d2c6865 580 my($op, $cx, $text) = @_;
4c1f658f 581 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
9d2c6865 582 return $self->maybe_parens_func("my", $text, $cx, 16);
6e90668e
SM
583 } else {
584 return $text;
585 }
586}
587
9d2c6865
SM
588# The following OPs don't have functions:
589
590# pp_padany -- does not exist after parsing
591# pp_rcatline -- does not exist
592
593sub pp_enter { # see also leave
594 cluck "unexpected OP_ENTER";
595 return "XXX";
596}
597
598sub pp_pushmark { # see also list
599 cluck "unexpected OP_PUSHMARK";
600 return "XXX";
601}
602
603sub pp_leavesub { # see also deparse_sub
604 cluck "unexpected OP_LEAVESUB";
605 return "XXX";
606}
607
608sub pp_leavewrite { # see also deparse_format
609 cluck "unexpected OP_LEAVEWRITE";
610 return "XXX";
611}
612
613sub pp_method { # see also entersub
614 cluck "unexpected OP_METHOD";
615 return "XXX";
616}
617
618sub pp_regcmaybe { # see also regcomp
619 cluck "unexpected OP_REGCMAYBE";
620 return "XXX";
621}
622
90be192f
SM
623sub pp_regcreset { # see also regcomp
624 cluck "unexpected OP_REGCRESET";
625 return "XXX";
626}
627
9d2c6865
SM
628sub pp_substcont { # see also subst
629 cluck "unexpected OP_SUBSTCONT";
630 return "XXX";
631}
632
633sub pp_grepstart { # see also grepwhile
634 cluck "unexpected OP_GREPSTART";
635 return "XXX";
636}
637
638sub pp_mapstart { # see also mapwhile
639 cluck "unexpected OP_MAPSTART";
640 return "XXX";
641}
642
643sub pp_flip { # see also flop
644 cluck "unexpected OP_FLIP";
645 return "XXX";
646}
647
648sub pp_iter { # see also leaveloop
649 cluck "unexpected OP_ITER";
650 return "XXX";
651}
652
653sub pp_enteriter { # see also leaveloop
654 cluck "unexpected OP_ENTERITER";
655 return "XXX";
656}
657
658sub pp_enterloop { # see also leaveloop
659 cluck "unexpected OP_ENTERLOOP";
660 return "XXX";
661}
662
663sub pp_leaveeval { # see also entereval
664 cluck "unexpected OP_LEAVEEVAL";
665 return "XXX";
666}
667
668sub pp_entertry { # see also leavetry
669 cluck "unexpected OP_ENTERTRY";
670 return "XXX";
671}
6e90668e 672
9d2c6865 673# leave and scope/lineseq should probably share code
a798dbf2 674sub pp_leave {
6e90668e 675 my $self = shift;
9d2c6865 676 my($op, $cx) = @_;
6e90668e
SM
677 my ($kid, $expr);
678 my @exprs;
679 local($self->{'curstash'}) = $self->{'curstash'};
680 $kid = $op->first->sibling; # skip enter
681 if (is_miniwhile($kid)) {
682 my $top = $kid->first;
3f872cb9
GS
683 my $name = $top->name;
684 if ($name eq "and") {
6e90668e 685 $name = "while";
3f872cb9 686 } elsif ($name eq "or") {
6e90668e
SM
687 $name = "until";
688 } else { # no conditional -> while 1 or until 0
9d2c6865 689 return $self->deparse($top->first, 1) . " while 1";
6e90668e
SM
690 }
691 my $cond = $top->first;
9d2c6865
SM
692 my $body = $cond->sibling->first; # skip lineseq
693 $cond = $self->deparse($cond, 1);
694 $body = $self->deparse($body, 1);
6e90668e
SM
695 return "$body $name $cond";
696 }
697 for (; !null($kid); $kid = $kid->sibling) {
698 $expr = "";
699 if (is_state $kid) {
9d2c6865 700 $expr = $self->deparse($kid, 0);
6e90668e
SM
701 $kid = $kid->sibling;
702 last if null $kid;
703 }
9d2c6865 704 $expr .= $self->deparse($kid, 0);
f4a44678 705 push @exprs, $expr if length $expr;
6e90668e 706 }
9d2c6865
SM
707 if ($cx > 0) { # inside an expression
708 return "do { " . join(";\n", @exprs) . " }";
709 } else {
f5aa8f4e 710 return join(";\n", @exprs) . ";";
9d2c6865 711 }
6e90668e
SM
712}
713
714sub pp_scope {
715 my $self = shift;
9d2c6865 716 my($op, $cx) = @_;
6e90668e
SM
717 my ($kid, $expr);
718 my @exprs;
719 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
720 $expr = "";
721 if (is_state $kid) {
9d2c6865 722 $expr = $self->deparse($kid, 0);
6e90668e
SM
723 $kid = $kid->sibling;
724 last if null $kid;
725 }
9d2c6865 726 $expr .= $self->deparse($kid, 0);
f4a44678 727 push @exprs, $expr if length $expr;
6e90668e 728 }
9d2c6865
SM
729 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
730 return "do { " . join(";\n", @exprs) . " }";
731 } else {
f5aa8f4e 732 return join(";\n", @exprs) . ";";
6e90668e 733 }
6e90668e
SM
734}
735
9d2c6865
SM
736sub pp_lineseq { pp_scope(@_) }
737
6e90668e
SM
738# The BEGIN {} is used here because otherwise this code isn't executed
739# when you run B::Deparse on itself.
740my %globalnames;
741BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
742 "ENV", "ARGV", "ARGVOUT", "_"); }
743
744sub gv_name {
745 my $self = shift;
746 my $gv = shift;
747 my $stash = $gv->STASH->NAME;
748 my $name = $gv->NAME;
9d2c6865
SM
749 if ($stash eq $self->{'curstash'} or $globalnames{$name}
750 or $name =~ /^[^A-Za-z_]/)
751 {
6e90668e
SM
752 $stash = "";
753 } else {
754 $stash = $stash . "::";
a798dbf2 755 }
6e90668e
SM
756 if ($name =~ /^([\cA-\cZ])$/) {
757 $name = "^" . chr(64 + ord($1));
758 }
759 return $stash . $name;
a798dbf2
MB
760}
761
6e90668e
SM
762# Notice how subs and formats are inserted between statements here
763sub pp_nextstate {
764 my $self = shift;
9d2c6865 765 my($op, $cx) = @_;
6e90668e
SM
766 my @text;
767 @text = $op->label . ": " if $op->label;
768 my $seq = $op->cop_seq;
769 while (scalar(@{$self->{'subs_todo'}})
770 and $seq > $self->{'subs_todo'}[0][0]) {
771 push @text, $self->next_todo;
772 }
11faa288 773 my $stash = $op->stashpv;
6e90668e
SM
774 if ($stash ne $self->{'curstash'}) {
775 push @text, "package $stash;\n";
776 $self->{'curstash'} = $stash;
777 }
f5aa8f4e
SM
778 if ($self->{'linenums'}) {
779 push @text, "\f#line " . $op->line .
57843af0 780 ' "' . $op->file, qq'"\n';
f5aa8f4e 781 }
6e90668e
SM
782 return join("", @text);
783}
784
785sub pp_dbstate { pp_nextstate(@_) }
3f872cb9 786sub pp_setstate { pp_nextstate(@_) }
6e90668e
SM
787
788sub pp_unstack { return "" } # see also leaveloop
789
790sub baseop {
791 my $self = shift;
9d2c6865 792 my($op, $cx, $name) = @_;
6e90668e
SM
793 return $name;
794}
795
796sub pp_stub { baseop(@_, "()") }
797sub pp_wantarray { baseop(@_, "wantarray") }
798sub pp_fork { baseop(@_, "fork") }
3ed82cfc
GS
799sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
800sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
801sub pp_time { maybe_targmy(@_, \&baseop, "time") }
6e90668e
SM
802sub pp_tms { baseop(@_, "times") }
803sub pp_ghostent { baseop(@_, "gethostent") }
804sub pp_gnetent { baseop(@_, "getnetent") }
805sub pp_gprotoent { baseop(@_, "getprotoent") }
806sub pp_gservent { baseop(@_, "getservent") }
807sub pp_ehostent { baseop(@_, "endhostent") }
808sub pp_enetent { baseop(@_, "endnetent") }
809sub pp_eprotoent { baseop(@_, "endprotoent") }
810sub pp_eservent { baseop(@_, "endservent") }
811sub pp_gpwent { baseop(@_, "getpwent") }
812sub pp_spwent { baseop(@_, "setpwent") }
813sub pp_epwent { baseop(@_, "endpwent") }
814sub pp_ggrent { baseop(@_, "getgrent") }
815sub pp_sgrent { baseop(@_, "setgrent") }
816sub pp_egrent { baseop(@_, "endgrent") }
817sub pp_getlogin { baseop(@_, "getlogin") }
818
819sub POSTFIX () { 1 }
820
9d2c6865
SM
821# I couldn't think of a good short name, but this is the category of
822# symbolic unary operators with interesting precedence
823
824sub pfixop {
825 my $self = shift;
826 my($op, $cx, $name, $prec, $flags) = (@_, 0);
827 my $kid = $op->first;
828 $kid = $self->deparse($kid, $prec);
829 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
830 $cx, $prec);
831}
832
833sub pp_preinc { pfixop(@_, "++", 23) }
834sub pp_predec { pfixop(@_, "--", 23) }
3ed82cfc
GS
835sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
836sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
9d2c6865
SM
837sub pp_i_preinc { pfixop(@_, "++", 23) }
838sub pp_i_predec { pfixop(@_, "--", 23) }
3ed82cfc
GS
839sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
840sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
841sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) }
9d2c6865 842
3ed82cfc
GS
843sub pp_negate { maybe_targmy(@_, \&real_negate) }
844sub real_negate {
9d2c6865
SM
845 my $self = shift;
846 my($op, $cx) = @_;
3f872cb9 847 if ($op->first->name =~ /^(i_)?negate$/) {
9d2c6865
SM
848 # avoid --$x
849 $self->pfixop($op, $cx, "-", 21.5);
850 } else {
851 $self->pfixop($op, $cx, "-", 21);
852 }
853}
854sub pp_i_negate { pp_negate(@_) }
855
856sub pp_not {
857 my $self = shift;
858 my($op, $cx) = @_;
859 if ($cx <= 4) {
860 $self->pfixop($op, $cx, "not ", 4);
861 } else {
862 $self->pfixop($op, $cx, "!", 21);
863 }
864}
865
6e90668e
SM
866sub unop {
867 my $self = shift;
f4a44678 868 my($op, $cx, $name) = @_;
6e90668e 869 my $kid;
9d2c6865 870 if ($op->flags & OPf_KIDS) {
6e90668e 871 $kid = $op->first;
9d2c6865 872 return $self->maybe_parens_unop($name, $kid, $cx);
6e90668e 873 } else {
9d2c6865 874 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
6e90668e 875 }
6e90668e
SM
876}
877
3ed82cfc
GS
878sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
879sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
880sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
881sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
6e90668e
SM
882sub pp_defined { unop(@_, "defined") }
883sub pp_undef { unop(@_, "undef") }
884sub pp_study { unop(@_, "study") }
6e90668e
SM
885sub pp_ref { unop(@_, "ref") }
886sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
887
3ed82cfc
GS
888sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
889sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
890sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
6e90668e 891sub pp_srand { unop(@_, "srand") }
3ed82cfc
GS
892sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
893sub pp_log { maybe_targmy(@_, \&unop, "log") }
894sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
895sub pp_int { maybe_targmy(@_, \&unop, "int") }
896sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
897sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
898sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
899
900sub pp_length { maybe_targmy(@_, \&unop, "length") }
901sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
902sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
6e90668e
SM
903
904sub pp_each { unop(@_, "each") }
905sub pp_values { unop(@_, "values") }
906sub pp_keys { unop(@_, "keys") }
907sub pp_pop { unop(@_, "pop") }
908sub pp_shift { unop(@_, "shift") }
909
910sub pp_caller { unop(@_, "caller") }
911sub pp_reset { unop(@_, "reset") }
912sub pp_exit { unop(@_, "exit") }
913sub pp_prototype { unop(@_, "prototype") }
914
915sub pp_close { unop(@_, "close") }
916sub pp_fileno { unop(@_, "fileno") }
917sub pp_umask { unop(@_, "umask") }
918sub pp_binmode { unop(@_, "binmode") }
919sub pp_untie { unop(@_, "untie") }
920sub pp_tied { unop(@_, "tied") }
921sub pp_dbmclose { unop(@_, "dbmclose") }
922sub pp_getc { unop(@_, "getc") }
923sub pp_eof { unop(@_, "eof") }
924sub pp_tell { unop(@_, "tell") }
925sub pp_getsockname { unop(@_, "getsockname") }
926sub pp_getpeername { unop(@_, "getpeername") }
927
3ed82cfc
GS
928sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
929sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
6e90668e 930sub pp_readlink { unop(@_, "readlink") }
3ed82cfc 931sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
6e90668e
SM
932sub pp_readdir { unop(@_, "readdir") }
933sub pp_telldir { unop(@_, "telldir") }
934sub pp_rewinddir { unop(@_, "rewinddir") }
935sub pp_closedir { unop(@_, "closedir") }
3ed82cfc 936sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
6e90668e
SM
937sub pp_localtime { unop(@_, "localtime") }
938sub pp_gmtime { unop(@_, "gmtime") }
939sub pp_alarm { unop(@_, "alarm") }
3ed82cfc 940sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
6e90668e
SM
941
942sub pp_dofile { unop(@_, "do") }
943sub pp_entereval { unop(@_, "eval") }
944
945sub pp_ghbyname { unop(@_, "gethostbyname") }
946sub pp_gnbyname { unop(@_, "getnetbyname") }
947sub pp_gpbyname { unop(@_, "getprotobyname") }
948sub pp_shostent { unop(@_, "sethostent") }
949sub pp_snetent { unop(@_, "setnetent") }
950sub pp_sprotoent { unop(@_, "setprotoent") }
951sub pp_sservent { unop(@_, "setservent") }
952sub pp_gpwnam { unop(@_, "getpwnam") }
953sub pp_gpwuid { unop(@_, "getpwuid") }
954sub pp_ggrnam { unop(@_, "getgrnam") }
955sub pp_ggrgid { unop(@_, "getgrgid") }
956
957sub pp_lock { unop(@_, "lock") }
958
959sub pp_exists {
960 my $self = shift;
9d2c6865
SM
961 my($op, $cx) = @_;
962 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
963 $cx, 16);
6e90668e
SM
964}
965
6e90668e
SM
966sub pp_delete {
967 my $self = shift;
9d2c6865 968 my($op, $cx) = @_;
6e90668e
SM
969 my $arg;
970 if ($op->private & OPpSLICE) {
9d2c6865
SM
971 return $self->maybe_parens_func("delete",
972 $self->pp_hslice($op->first, 16),
973 $cx, 16);
6e90668e 974 } else {
9d2c6865
SM
975 return $self->maybe_parens_func("delete",
976 $self->pp_helem($op->first, 16),
977 $cx, 16);
6e90668e 978 }
6e90668e
SM
979}
980
6e90668e
SM
981sub pp_require {
982 my $self = shift;
9d2c6865 983 my($op, $cx) = @_;
3f872cb9 984 if (class($op) eq "UNOP" and $op->first->name eq "const"
4c1f658f 985 and $op->first->private & OPpCONST_BARE)
6e90668e
SM
986 {
987 my $name = $op->first->sv->PV;
988 $name =~ s[/][::]g;
989 $name =~ s/\.pm//g;
990 return "require($name)";
991 } else {
9d2c6865 992 $self->unop($op, $cx, "require");
6e90668e
SM
993 }
994}
995
9d2c6865
SM
996sub pp_scalar {
997 my $self = shift;
998 my($op, $cv) = @_;
999 my $kid = $op->first;
1000 if (not null $kid->sibling) {
1001 # XXX Was a here-doc
1002 return $self->dquote($op);
1003 }
1004 $self->unop(@_, "scalar");
1005}
1006
1007
6e90668e
SM
1008sub padval {
1009 my $self = shift;
1010 my $targ = shift;
1011 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1012}
1013
1014sub pp_refgen {
1015 my $self = shift;
9d2c6865 1016 my($op, $cx) = @_;
6e90668e 1017 my $kid = $op->first;
3f872cb9 1018 if ($kid->name eq "null") {
6e90668e 1019 $kid = $kid->first;
3f872cb9
GS
1020 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1021 my($pre, $post) = @{{"anonlist" => ["[","]"],
1022 "anonhash" => ["{","}"]}->{$kid->name}};
6e90668e
SM
1023 my($expr, @exprs);
1024 $kid = $kid->first->sibling; # skip pushmark
1025 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 1026 $expr = $self->deparse($kid, 6);
6e90668e
SM
1027 push @exprs, $expr;
1028 }
1029 return $pre . join(", ", @exprs) . $post;
1030 } elsif (!null($kid->sibling) and
3f872cb9 1031 $kid->sibling->name eq "anoncode") {
6e90668e
SM
1032 return "sub " .
1033 $self->deparse_sub($self->padval($kid->sibling->targ));
3f872cb9
GS
1034 } elsif ($kid->name eq "pushmark") {
1035 my $sib_name = $kid->sibling->name;
1036 if ($sib_name =~ /^(pad|rv2)[ah]v$/
c8c62db7
AD
1037 and not $kid->sibling->flags & OPf_REF)
1038 {
1039 # The @a in \(@a) isn't in ref context, but only when the
1040 # parens are there.
1041 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
3f872cb9 1042 } elsif ($sib_name eq 'entersub') {
c8c62db7
AD
1043 my $text = $self->deparse($kid->sibling, 1);
1044 # Always show parens for \(&func()), but only with -p otherwise
1045 $text = "($text)" if $self->{'parens'}
1046 or $kid->sibling->private & OPpENTERSUB_AMPER;
1047 return "\\$text";
1048 }
1049 }
6e90668e 1050 }
9d2c6865 1051 $self->pfixop($op, $cx, "\\", 20);
6e90668e
SM
1052}
1053
1054sub pp_srefgen { pp_refgen(@_) }
1055
1056sub pp_readline {
1057 my $self = shift;
9d2c6865 1058 my($op, $cx) = @_;
6e90668e 1059 my $kid = $op->first;
3f872cb9 1060 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
9d2c6865 1061 return "<" . $self->deparse($kid, 1) . ">";
6e90668e
SM
1062}
1063
bd0865ec
GS
1064# Unary operators that can occur as pseudo-listops inside double quotes
1065sub dq_unop {
1066 my $self = shift;
1067 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1068 my $kid;
1069 if ($op->flags & OPf_KIDS) {
1070 $kid = $op->first;
1071 # If there's more than one kid, the first is an ex-pushmark.
1072 $kid = $kid->sibling if not null $kid->sibling;
1073 return $self->maybe_parens_unop($name, $kid, $cx);
1074 } else {
1075 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1076 }
1077}
1078
1079sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1080sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1081sub pp_uc { dq_unop(@_, "uc") }
1082sub pp_lc { dq_unop(@_, "lc") }
3ed82cfc 1083sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
bd0865ec 1084
6e90668e
SM
1085sub loopex {
1086 my $self = shift;
9d2c6865 1087 my ($op, $cx, $name) = @_;
6e90668e 1088 if (class($op) eq "PVOP") {
9d2c6865
SM
1089 return "$name " . $op->pv;
1090 } elsif (class($op) eq "OP") {
1091 return $name;
6e90668e 1092 } elsif (class($op) eq "UNOP") {
9d2c6865
SM
1093 # Note -- loop exits are actually exempt from the
1094 # looks-like-a-func rule, but a few extra parens won't hurt
1095 return $self->maybe_parens_unop($name, $op->first, $cx);
6e90668e 1096 }
6e90668e
SM
1097}
1098
1099sub pp_last { loopex(@_, "last") }
1100sub pp_next { loopex(@_, "next") }
1101sub pp_redo { loopex(@_, "redo") }
1102sub pp_goto { loopex(@_, "goto") }
1103sub pp_dump { loopex(@_, "dump") }
1104
1105sub ftst {
1106 my $self = shift;
9d2c6865 1107 my($op, $cx, $name) = @_;
6e90668e 1108 if (class($op) eq "UNOP") {
9d2c6865
SM
1109 # Genuine `-X' filetests are exempt from the LLAFR, but not
1110 # l?stat(); for the sake of clarity, give'em all parens
1111 return $self->maybe_parens_unop($name, $op->first, $cx);
7934575e 1112 } elsif (class($op) eq "SVOP") {
9d2c6865 1113 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
6e90668e 1114 } else { # I don't think baseop filetests ever survive ck_ftst, but...
9d2c6865 1115 return $name;
6e90668e 1116 }
6e90668e
SM
1117}
1118
1119sub pp_lstat { ftst(@_, "lstat") }
1120sub pp_stat { ftst(@_, "stat") }
1121sub pp_ftrread { ftst(@_, "-R") }
1122sub pp_ftrwrite { ftst(@_, "-W") }
1123sub pp_ftrexec { ftst(@_, "-X") }
1124sub pp_fteread { ftst(@_, "-r") }
1125sub pp_ftewrite { ftst(@_, "-r") }
1126sub pp_fteexec { ftst(@_, "-r") }
1127sub pp_ftis { ftst(@_, "-e") }
1128sub pp_fteowned { ftst(@_, "-O") }
1129sub pp_ftrowned { ftst(@_, "-o") }
1130sub pp_ftzero { ftst(@_, "-z") }
1131sub pp_ftsize { ftst(@_, "-s") }
1132sub pp_ftmtime { ftst(@_, "-M") }
1133sub pp_ftatime { ftst(@_, "-A") }
1134sub pp_ftctime { ftst(@_, "-C") }
1135sub pp_ftsock { ftst(@_, "-S") }
1136sub pp_ftchr { ftst(@_, "-c") }
1137sub pp_ftblk { ftst(@_, "-b") }
1138sub pp_ftfile { ftst(@_, "-f") }
1139sub pp_ftdir { ftst(@_, "-d") }
1140sub pp_ftpipe { ftst(@_, "-p") }
1141sub pp_ftlink { ftst(@_, "-l") }
1142sub pp_ftsuid { ftst(@_, "-u") }
1143sub pp_ftsgid { ftst(@_, "-g") }
1144sub pp_ftsvtx { ftst(@_, "-k") }
1145sub pp_fttty { ftst(@_, "-t") }
1146sub pp_fttext { ftst(@_, "-T") }
1147sub pp_ftbinary { ftst(@_, "-B") }
1148
a798dbf2 1149sub SWAP_CHILDREN () { 1 }
6e90668e
SM
1150sub ASSIGN () { 2 } # has OP= variant
1151
9d2c6865
SM
1152my(%left, %right);
1153
1154sub assoc_class {
1155 my $op = shift;
3f872cb9
GS
1156 my $name = $op->name;
1157 if ($name eq "concat" and $op->first->name eq "concat") {
9d2c6865 1158 # avoid spurious `=' -- see comment in pp_concat
3f872cb9 1159 return "concat";
9d2c6865 1160 }
3f872cb9
GS
1161 if ($name eq "null" and class($op) eq "UNOP"
1162 and $op->first->name =~ /^(and|x?or)$/
9d2c6865
SM
1163 and null $op->first->sibling)
1164 {
1165 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1166 # with a null that's used as the common end point of the two
1167 # flows of control. For precedence purposes, ignore it.
1168 # (COND_EXPRs have these too, but we don't bother with
1169 # their associativity).
1170 return assoc_class($op->first);
1171 }
1172 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1173}
1174
1175# Left associative operators, like `+', for which
1176# $a + $b + $c is equivalent to ($a + $b) + $c
1177
1178BEGIN {
3f872cb9
GS
1179 %left = ('multiply' => 19, 'i_multiply' => 19,
1180 'divide' => 19, 'i_divide' => 19,
1181 'modulo' => 19, 'i_modulo' => 19,
1182 'repeat' => 19,
1183 'add' => 18, 'i_add' => 18,
1184 'subtract' => 18, 'i_subtract' => 18,
1185 'concat' => 18,
1186 'left_shift' => 17, 'right_shift' => 17,
1187 'bit_and' => 13,
1188 'bit_or' => 12, 'bit_xor' => 12,
1189 'and' => 3,
1190 'or' => 2, 'xor' => 2,
9d2c6865
SM
1191 );
1192}
1193
1194sub deparse_binop_left {
1195 my $self = shift;
1196 my($op, $left, $prec) = @_;
58231d39 1197 if ($left{assoc_class($op)} && $left{assoc_class($left)}
9d2c6865
SM
1198 and $left{assoc_class($op)} == $left{assoc_class($left)})
1199 {
1200 return $self->deparse($left, $prec - .00001);
1201 } else {
1202 return $self->deparse($left, $prec);
1203 }
1204}
1205
1206# Right associative operators, like `=', for which
1207# $a = $b = $c is equivalent to $a = ($b = $c)
1208
1209BEGIN {
3f872cb9
GS
1210 %right = ('pow' => 22,
1211 'sassign=' => 7, 'aassign=' => 7,
1212 'multiply=' => 7, 'i_multiply=' => 7,
1213 'divide=' => 7, 'i_divide=' => 7,
1214 'modulo=' => 7, 'i_modulo=' => 7,
1215 'repeat=' => 7,
1216 'add=' => 7, 'i_add=' => 7,
1217 'subtract=' => 7, 'i_subtract=' => 7,
1218 'concat=' => 7,
1219 'left_shift=' => 7, 'right_shift=' => 7,
1220 'bit_and=' => 7,
1221 'bit_or=' => 7, 'bit_xor=' => 7,
1222 'andassign' => 7,
1223 'orassign' => 7,
9d2c6865
SM
1224 );
1225}
1226
1227sub deparse_binop_right {
1228 my $self = shift;
1229 my($op, $right, $prec) = @_;
58231d39 1230 if ($right{assoc_class($op)} && $right{assoc_class($right)}
9d2c6865
SM
1231 and $right{assoc_class($op)} == $right{assoc_class($right)})
1232 {
1233 return $self->deparse($right, $prec - .00001);
1234 } else {
1235 return $self->deparse($right, $prec);
1236 }
1237}
1238
a798dbf2 1239sub binop {
6e90668e 1240 my $self = shift;
9d2c6865 1241 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
a798dbf2
MB
1242 my $left = $op->first;
1243 my $right = $op->last;
9d2c6865
SM
1244 my $eq = "";
1245 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1246 $eq = "=";
1247 $prec = 7;
1248 }
a798dbf2
MB
1249 if ($flags & SWAP_CHILDREN) {
1250 ($left, $right) = ($right, $left);
1251 }
9d2c6865
SM
1252 $left = $self->deparse_binop_left($op, $left, $prec);
1253 $right = $self->deparse_binop_right($op, $right, $prec);
1254 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1255}
1256
3ed82cfc
GS
1257sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1258sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1259sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1260sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1261sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1262sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1263sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1264sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1265sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1266sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1267sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1268
1269sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1270sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1271sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1272sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1273sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
9d2c6865
SM
1274
1275sub pp_eq { binop(@_, "==", 14) }
1276sub pp_ne { binop(@_, "!=", 14) }
1277sub pp_lt { binop(@_, "<", 15) }
1278sub pp_gt { binop(@_, ">", 15) }
1279sub pp_ge { binop(@_, ">=", 15) }
1280sub pp_le { binop(@_, "<=", 15) }
1281sub pp_ncmp { binop(@_, "<=>", 14) }
1282sub pp_i_eq { binop(@_, "==", 14) }
1283sub pp_i_ne { binop(@_, "!=", 14) }
1284sub pp_i_lt { binop(@_, "<", 15) }
1285sub pp_i_gt { binop(@_, ">", 15) }
1286sub pp_i_ge { binop(@_, ">=", 15) }
1287sub pp_i_le { binop(@_, "<=", 15) }
1288sub pp_i_ncmp { binop(@_, "<=>", 14) }
1289
1290sub pp_seq { binop(@_, "eq", 14) }
1291sub pp_sne { binop(@_, "ne", 14) }
1292sub pp_slt { binop(@_, "lt", 15) }
1293sub pp_sgt { binop(@_, "gt", 15) }
1294sub pp_sge { binop(@_, "ge", 15) }
1295sub pp_sle { binop(@_, "le", 15) }
1296sub pp_scmp { binop(@_, "cmp", 14) }
1297
1298sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1299sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
6e90668e
SM
1300
1301# `.' is special because concats-of-concats are optimized to save copying
1302# by making all but the first concat stacked. The effect is as if the
1303# programmer had written `($a . $b) .= $c', except legal.
3ed82cfc
GS
1304sub pp_concat { maybe_targmy(@_, \&real_concat) }
1305sub real_concat {
6e90668e 1306 my $self = shift;
9d2c6865 1307 my($op, $cx) = @_;
6e90668e
SM
1308 my $left = $op->first;
1309 my $right = $op->last;
1310 my $eq = "";
9d2c6865 1311 my $prec = 18;
3f872cb9 1312 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
6e90668e 1313 $eq = "=";
9d2c6865 1314 $prec = 7;
6e90668e 1315 }
9d2c6865
SM
1316 $left = $self->deparse_binop_left($op, $left, $prec);
1317 $right = $self->deparse_binop_right($op, $right, $prec);
1318 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
6e90668e
SM
1319}
1320
1321# `x' is weird when the left arg is a list
1322sub pp_repeat {
1323 my $self = shift;
9d2c6865 1324 my($op, $cx) = @_;
6e90668e
SM
1325 my $left = $op->first;
1326 my $right = $op->last;
9d2c6865
SM
1327 my $eq = "";
1328 my $prec = 19;
1329 if ($op->flags & OPf_STACKED) {
1330 $eq = "=";
1331 $prec = 7;
1332 }
6e90668e
SM
1333 if (null($right)) { # list repeat; count is inside left-side ex-list
1334 my $kid = $left->first->sibling; # skip pushmark
1335 my @exprs;
1336 for (; !null($kid->sibling); $kid = $kid->sibling) {
9d2c6865 1337 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
1338 }
1339 $right = $kid;
1340 $left = "(" . join(", ", @exprs). ")";
1341 } else {
9d2c6865 1342 $left = $self->deparse_binop_left($op, $left, $prec);
6e90668e 1343 }
9d2c6865
SM
1344 $right = $self->deparse_binop_right($op, $right, $prec);
1345 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
6e90668e
SM
1346}
1347
1348sub range {
1349 my $self = shift;
9d2c6865 1350 my ($op, $cx, $type) = @_;
6e90668e
SM
1351 my $left = $op->first;
1352 my $right = $left->sibling;
9d2c6865
SM
1353 $left = $self->deparse($left, 9);
1354 $right = $self->deparse($right, 9);
1355 return $self->maybe_parens("$left $type $right", $cx, 9);
6e90668e
SM
1356}
1357
1358sub pp_flop {
1359 my $self = shift;
9d2c6865 1360 my($op, $cx) = @_;
6e90668e
SM
1361 my $flip = $op->first;
1362 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
9d2c6865 1363 return $self->range($flip->first, $cx, $type);
6e90668e
SM
1364}
1365
1366# one-line while/until is handled in pp_leave
1367
1368sub logop {
1369 my $self = shift;
9d2c6865 1370 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
6e90668e
SM
1371 my $left = $op->first;
1372 my $right = $op->first->sibling;
9d2c6865
SM
1373 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1374 $left = $self->deparse($left, 1);
1375 $right = $self->deparse($right, 0);
1376 return "$blockname ($left) {\n\t$right\n\b}\cK";
1377 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1378 $right = $self->deparse($right, 1);
1379 $left = $self->deparse($left, 1);
1380 return "$right $blockname $left";
1381 } elsif ($cx > $lowprec and $highop) { # $a && $b
1382 $left = $self->deparse_binop_left($op, $left, $highprec);
1383 $right = $self->deparse_binop_right($op, $right, $highprec);
1384 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1385 } else { # $a and $b
1386 $left = $self->deparse_binop_left($op, $left, $lowprec);
1387 $right = $self->deparse_binop_right($op, $right, $lowprec);
1388 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1389 }
1390}
1391
1392sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
f4a44678 1393sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
3ed82cfc
GS
1394
1395# xor is syntactically a logop, but it's really a binop (contrary to
1396# old versions of opcode.pl). Syntax is what matters here.
9d2c6865 1397sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
6e90668e
SM
1398
1399sub logassignop {
1400 my $self = shift;
9d2c6865 1401 my ($op, $cx, $opname) = @_;
6e90668e
SM
1402 my $left = $op->first;
1403 my $right = $op->first->sibling->first; # skip sassign
9d2c6865
SM
1404 $left = $self->deparse($left, 7);
1405 $right = $self->deparse($right, 7);
1406 return $self->maybe_parens("$left $opname $right", $cx, 7);
a798dbf2
MB
1407}
1408
6e90668e
SM
1409sub pp_andassign { logassignop(@_, "&&=") }
1410sub pp_orassign { logassignop(@_, "||=") }
1411
1412sub listop {
1413 my $self = shift;
9d2c6865
SM
1414 my($op, $cx, $name) = @_;
1415 my(@exprs);
1416 my $parens = ($cx >= 5) || $self->{'parens'};
1417 my $kid = $op->first->sibling;
1418 return $name if null $kid;
1419 my $first = $self->deparse($kid, 6);
1420 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1421 push @exprs, $first;
1422 $kid = $kid->sibling;
1423 for (; !null($kid); $kid = $kid->sibling) {
1424 push @exprs, $self->deparse($kid, 6);
1425 }
1426 if ($parens) {
1427 return "$name(" . join(", ", @exprs) . ")";
1428 } else {
1429 return "$name " . join(", ", @exprs);
6e90668e 1430 }
6e90668e 1431}
a798dbf2 1432
6e90668e 1433sub pp_bless { listop(@_, "bless") }
3ed82cfc 1434sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
6e90668e
SM
1435sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1436sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
3ed82cfc
GS
1437sub pp_index { maybe_targmy(@_, \&listop, "index") }
1438sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1439sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
6e90668e 1440sub pp_formline { listop(@_, "formline") } # see also deparse_format
3ed82cfc 1441sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
6e90668e
SM
1442sub pp_unpack { listop(@_, "unpack") }
1443sub pp_pack { listop(@_, "pack") }
3ed82cfc 1444sub pp_join { maybe_targmy(@_, \&listop, "join") }
6e90668e 1445sub pp_splice { listop(@_, "splice") }
3ed82cfc
GS
1446sub pp_push { maybe_targmy(@_, \&listop, "push") }
1447sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
6e90668e
SM
1448sub pp_reverse { listop(@_, "reverse") }
1449sub pp_warn { listop(@_, "warn") }
1450sub pp_die { listop(@_, "die") }
9d2c6865
SM
1451# Actually, return is exempt from the LLAFR (see examples in this very
1452# module!), but for consistency's sake, ignore that fact
6e90668e
SM
1453sub pp_return { listop(@_, "return") }
1454sub pp_open { listop(@_, "open") }
1455sub pp_pipe_op { listop(@_, "pipe") }
1456sub pp_tie { listop(@_, "tie") }
1457sub pp_dbmopen { listop(@_, "dbmopen") }
1458sub pp_sselect { listop(@_, "select") }
1459sub pp_select { listop(@_, "select") }
1460sub pp_read { listop(@_, "read") }
1461sub pp_sysopen { listop(@_, "sysopen") }
1462sub pp_sysseek { listop(@_, "sysseek") }
1463sub pp_sysread { listop(@_, "sysread") }
1464sub pp_syswrite { listop(@_, "syswrite") }
1465sub pp_send { listop(@_, "send") }
1466sub pp_recv { listop(@_, "recv") }
1467sub pp_seek { listop(@_, "seek") }
6e90668e
SM
1468sub pp_fcntl { listop(@_, "fcntl") }
1469sub pp_ioctl { listop(@_, "ioctl") }
3ed82cfc 1470sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
6e90668e
SM
1471sub pp_socket { listop(@_, "socket") }
1472sub pp_sockpair { listop(@_, "sockpair") }
1473sub pp_bind { listop(@_, "bind") }
1474sub pp_connect { listop(@_, "connect") }
1475sub pp_listen { listop(@_, "listen") }
1476sub pp_accept { listop(@_, "accept") }
1477sub pp_shutdown { listop(@_, "shutdown") }
1478sub pp_gsockopt { listop(@_, "getsockopt") }
1479sub pp_ssockopt { listop(@_, "setsockopt") }
3ed82cfc
GS
1480sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1481sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1482sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1483sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1484sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1485sub pp_link { maybe_targmy(@_, \&listop, "link") }
1486sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1487sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
6e90668e
SM
1488sub pp_open_dir { listop(@_, "opendir") }
1489sub pp_seekdir { listop(@_, "seekdir") }
3ed82cfc
GS
1490sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1491sub pp_system { maybe_targmy(@_, \&listop, "system") }
1492sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1493sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1494sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1495sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1496sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
6e90668e
SM
1497sub pp_shmget { listop(@_, "shmget") }
1498sub pp_shmctl { listop(@_, "shmctl") }
1499sub pp_shmread { listop(@_, "shmread") }
1500sub pp_shmwrite { listop(@_, "shmwrite") }
1501sub pp_msgget { listop(@_, "msgget") }
1502sub pp_msgctl { listop(@_, "msgctl") }
1503sub pp_msgsnd { listop(@_, "msgsnd") }
1504sub pp_msgrcv { listop(@_, "msgrcv") }
1505sub pp_semget { listop(@_, "semget") }
1506sub pp_semctl { listop(@_, "semctl") }
1507sub pp_semop { listop(@_, "semop") }
1508sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1509sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1510sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1511sub pp_gsbyname { listop(@_, "getservbyname") }
1512sub pp_gsbyport { listop(@_, "getservbyport") }
1513sub pp_syscall { listop(@_, "syscall") }
1514
1515sub pp_glob {
1516 my $self = shift;
9d2c6865 1517 my($op, $cx) = @_;
6e90668e
SM
1518 my $text = $self->dq($op->first->sibling); # skip pushmark
1519 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1520 or $text =~ /[<>]/) {
1521 return 'glob(' . single_delim('qq', '"', $text) . ')';
1522 } else {
1523 return '<' . $text . '>';
1524 }
1525}
1526
f5aa8f4e
SM
1527# Truncate is special because OPf_SPECIAL makes a bareword first arg
1528# be a filehandle. This could probably be better fixed in the core
1529# by moving the GV lookup into ck_truc.
1530
1531sub pp_truncate {
1532 my $self = shift;
1533 my($op, $cx) = @_;
1534 my(@exprs);
1535 my $parens = ($cx >= 5) || $self->{'parens'};
1536 my $kid = $op->first->sibling;
acba1d67 1537 my $fh;
f5aa8f4e
SM
1538 if ($op->flags & OPf_SPECIAL) {
1539 # $kid is an OP_CONST
1540 $fh = $kid->sv->PV;
1541 } else {
1542 $fh = $self->deparse($kid, 6);
1543 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1544 }
1545 my $len = $self->deparse($kid->sibling, 6);
1546 if ($parens) {
1547 return "truncate($fh, $len)";
1548 } else {
1549 return "truncate $fh, $len";
1550 }
f5aa8f4e
SM
1551}
1552
6e90668e
SM
1553sub indirop {
1554 my $self = shift;
9d2c6865 1555 my($op, $cx, $name) = @_;
6e90668e
SM
1556 my($expr, @exprs);
1557 my $kid = $op->first->sibling;
1558 my $indir = "";
1559 if ($op->flags & OPf_STACKED) {
1560 $indir = $kid;
1561 $indir = $indir->first; # skip rv2gv
1562 if (is_scope($indir)) {
9d2c6865 1563 $indir = "{" . $self->deparse($indir, 0) . "}";
6e90668e 1564 } else {
9d2c6865 1565 $indir = $self->deparse($indir, 24);
6e90668e
SM
1566 }
1567 $indir = $indir . " ";
1568 $kid = $kid->sibling;
1569 }
1570 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 1571 $expr = $self->deparse($kid, 6);
6e90668e
SM
1572 push @exprs, $expr;
1573 }
3ed82cfc 1574 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
9d2c6865 1575 $cx, 5);
6e90668e
SM
1576}
1577
1578sub pp_prtf { indirop(@_, "printf") }
1579sub pp_print { indirop(@_, "print") }
1580sub pp_sort { indirop(@_, "sort") }
1581
1582sub mapop {
1583 my $self = shift;
9d2c6865 1584 my($op, $cx, $name) = @_;
6e90668e
SM
1585 my($expr, @exprs);
1586 my $kid = $op->first; # this is the (map|grep)start
1587 $kid = $kid->first->sibling; # skip a pushmark
1588 my $code = $kid->first; # skip a null
1589 if (is_scope $code) {
f4a44678 1590 $code = "{" . $self->deparse($code, 0) . "} ";
6e90668e 1591 } else {
9d2c6865 1592 $code = $self->deparse($code, 24) . ", ";
6e90668e
SM
1593 }
1594 $kid = $kid->sibling;
1595 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 1596 $expr = $self->deparse($kid, 6);
6e90668e
SM
1597 push @exprs, $expr if $expr;
1598 }
9d2c6865 1599 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
6e90668e
SM
1600}
1601
1602sub pp_mapwhile { mapop(@_, "map") }
1603sub pp_grepwhile { mapop(@_, "grep") }
1604
1605sub pp_list {
1606 my $self = shift;
9d2c6865 1607 my($op, $cx) = @_;
6e90668e
SM
1608 my($expr, @exprs);
1609 my $kid = $op->first->sibling; # skip pushmark
1610 my $lop;
1611 my $local = "either"; # could be local(...) or my(...)
1612 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1613 # This assumes that no other private flags equal 128, and that
1614 # OPs that store things other than flags in their op_private,
1615 # like OP_AELEMFAST, won't be immediate children of a list.
3f872cb9 1616 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
6e90668e
SM
1617 {
1618 $local = ""; # or not
1619 last;
1620 }
3f872cb9 1621 if ($lop->name =~ /^pad[ash]v$/) { # my()
6e90668e
SM
1622 ($local = "", last) if $local eq "local";
1623 $local = "my";
3f872cb9 1624 } elsif ($lop->name ne "undef") { # local()
6e90668e
SM
1625 ($local = "", last) if $local eq "my";
1626 $local = "local";
1627 }
1628 }
1629 $local = "" if $local eq "either"; # no point if it's all undefs
f5aa8f4e 1630 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
6e90668e
SM
1631 for (; !null($kid); $kid = $kid->sibling) {
1632 if ($local) {
3f872cb9 1633 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
6e90668e
SM
1634 $lop = $kid->first;
1635 } else {
1636 $lop = $kid;
1637 }
1638 $self->{'avoid_local'}{$$lop}++;
9d2c6865 1639 $expr = $self->deparse($kid, 6);
6e90668e
SM
1640 delete $self->{'avoid_local'}{$$lop};
1641 } else {
9d2c6865 1642 $expr = $self->deparse($kid, 6);
6e90668e
SM
1643 }
1644 push @exprs, $expr;
1645 }
9d2c6865
SM
1646 if ($local) {
1647 return "$local(" . join(", ", @exprs) . ")";
1648 } else {
1649 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1650 }
6e90668e
SM
1651}
1652
1653sub pp_cond_expr {
1654 my $self = shift;
9d2c6865 1655 my($op, $cx) = @_;
6e90668e
SM
1656 my $cond = $op->first;
1657 my $true = $cond->sibling;
1658 my $false = $true->sibling;
9d2c6865 1659 my $cuddle = $self->{'cuddle'};
9d2c6865 1660 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
f5aa8f4e 1661 $cond = $self->deparse($cond, 8);
9d2c6865
SM
1662 $true = $self->deparse($true, 8);
1663 $false = $self->deparse($false, 8);
1664 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1665 }
f5aa8f4e 1666 $cond = $self->deparse($cond, 1);
9d2c6865 1667 $true = $self->deparse($true, 0);
3f872cb9 1668 if ($false->name eq "lineseq") { # braces w/o scope => elsif
6e90668e
SM
1669 my $head = "if ($cond) {\n\t$true\n\b}";
1670 my @elsifs;
3f872cb9 1671 while (!null($false) and $false->name eq "lineseq") {
6e90668e
SM
1672 my $newop = $false->first->sibling->first;
1673 my $newcond = $newop->first;
1674 my $newtrue = $newcond->sibling;
1675 $false = $newtrue->sibling; # last in chain is OP_AND => no else
9d2c6865
SM
1676 $newcond = $self->deparse($newcond, 1);
1677 $newtrue = $self->deparse($newtrue, 0);
6e90668e
SM
1678 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1679 }
1680 if (!null($false)) {
9d2c6865
SM
1681 $false = $cuddle . "else {\n\t" .
1682 $self->deparse($false, 0) . "\n\b}\cK";
6e90668e 1683 } else {
9d2c6865 1684 $false = "\cK";
6e90668e 1685 }
9d2c6865 1686 return $head . join($cuddle, "", @elsifs) . $false;
6e90668e 1687 }
9d2c6865
SM
1688 $false = $self->deparse($false, 0);
1689 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
6e90668e
SM
1690}
1691
1692sub pp_leaveloop {
1693 my $self = shift;
9d2c6865 1694 my($op, $cx) = @_;
6e90668e
SM
1695 my $enter = $op->first;
1696 my $kid = $enter->sibling;
1697 local($self->{'curstash'}) = $self->{'curstash'};
1698 my $head = "";
9d2c6865 1699 my $bare = 0;
3f872cb9 1700 if ($kid->name eq "lineseq") { # bare or infinite loop
6e90668e
SM
1701 if (is_state $kid->last) { # infinite
1702 $head = "for (;;) "; # shorter than while (1)
9d2c6865
SM
1703 } else {
1704 $bare = 1;
6e90668e 1705 }
3f872cb9 1706 } elsif ($enter->name eq "enteriter") { # foreach
6e90668e
SM
1707 my $ary = $enter->first->sibling; # first was pushmark
1708 my $var = $ary->sibling;
f5aa8f4e
SM
1709 if ($enter->flags & OPf_STACKED
1710 and not null $ary->first->sibling->sibling)
1711 {
d7f5b6da
SM
1712 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1713 $self->deparse($ary->first->sibling->sibling, 9);
d8d95777
GA
1714 } else {
1715 $ary = $self->deparse($ary, 1);
1716 }
6e90668e 1717 if (null $var) {
f6f9bdb7 1718 if ($enter->flags & OPf_SPECIAL) { # thread special var
9d2c6865 1719 $var = $self->pp_threadsv($enter, 1);
f6f9bdb7 1720 } else { # regular my() variable
9d2c6865 1721 $var = $self->pp_padsv($enter, 1);
f6f9bdb7
SM
1722 if ($self->padname_sv($enter->targ)->IVX ==
1723 $kid->first->first->sibling->last->cop_seq)
1724 {
1725 # If the scope of this variable closes at the last
1726 # statement of the loop, it must have been
1727 # declared here.
1728 $var = "my " . $var;
1729 }
6e90668e 1730 }
3f872cb9 1731 } elsif ($var->name eq "rv2gv") {
9d2c6865 1732 $var = $self->pp_rv2sv($var, 1);
3f872cb9 1733 } elsif ($var->name eq "gv") {
9d2c6865 1734 $var = "\$" . $self->deparse($var, 1);
6e90668e 1735 }
9d2c6865 1736 $head = "foreach $var ($ary) ";
6e90668e 1737 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3f872cb9 1738 } elsif ($kid->name eq "null") { # while/until
6e90668e 1739 $kid = $kid->first;
3f872cb9
GS
1740 my $name = {"and" => "while", "or" => "until"}
1741 ->{$kid->name};
9d2c6865 1742 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
6e90668e 1743 $kid = $kid->first->sibling;
3f872cb9 1744 } elsif ($kid->name eq "stub") { # bare and empty
9d2c6865 1745 return "{;}"; # {} could be a hashref
6e90668e
SM
1746 }
1747 # The third-to-last kid is the continue block if the pointer used
9d2c6865
SM
1748 # by `next BLOCK' points to its first OP, which happens to be the
1749 # the op_next of the head of the _previous_ statement.
1750 # Unless it's a bare loop, in which case it's last, since there's
1751 # no unstack or extra nextstate.
f5aa8f4e
SM
1752 # Except if the previous head isn't null but the first kid is
1753 # (because it's a nulled out nextstate in a scope), in which
1754 # case the head's next is advanced past the null but the nextop's
1755 # isn't, so we need to try nextop->next.
bd0865ec
GS
1756 my $precont;
1757 my $cont = $kid->first;
9d2c6865 1758 if ($bare) {
9d2c6865
SM
1759 while (!null($cont->sibling)) {
1760 $precont = $cont;
1761 $cont = $cont->sibling;
1762 }
1763 } else {
9d2c6865
SM
1764 while (!null($cont->sibling->sibling->sibling)) {
1765 $precont = $cont;
1766 $cont = $cont->sibling;
6e90668e
SM
1767 }
1768 }
f5aa8f4e
SM
1769 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1770 || $ {$precont->next} == $ {$enter->nextop->next} )
1771 {
1772 my $state = $kid->first;
1773 my $cuddle = $self->{'cuddle'};
1774 my($expr, @exprs);
1775 for (; $$state != $$cont; $state = $state->sibling) {
1776 $expr = "";
1777 if (is_state $state) {
1778 $expr = $self->deparse($state, 0);
1779 $state = $state->sibling;
1780 last if null $kid;
1781 }
1782 $expr .= $self->deparse($state, 0);
1783 push @exprs, $expr if $expr;
1784 }
1785 $kid = join(";\n", @exprs);
1786 $cont = $cuddle . "continue {\n\t" .
1787 $self->deparse($cont, 0) . "\n\b}\cK";
6e90668e 1788 } else {
9d2c6865
SM
1789 $cont = "\cK";
1790 $kid = $self->deparse($kid, 0);
6e90668e
SM
1791 }
1792 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1793}
1794
1795sub pp_leavetry {
1796 my $self = shift;
9d2c6865 1797 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
bd0865ec 1798}
6e90668e 1799
bd0865ec
GS
1800BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1801BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
f5aa8f4e 1802
a798dbf2 1803sub pp_null {
6e90668e 1804 my $self = shift;
9d2c6865 1805 my($op, $cx) = @_;
6e90668e 1806 if (class($op) eq "OP") {
f4a44678
SM
1807 # old value is lost
1808 return $self->{'ex_const'} if $op->targ == OP_CONST;
3f872cb9 1809 } elsif ($op->first->name eq "pushmark") {
9d2c6865 1810 return $self->pp_list($op, $cx);
3f872cb9 1811 } elsif ($op->first->name eq "enter") {
9d2c6865 1812 return $self->pp_leave($op, $cx);
bd0865ec 1813 } elsif ($op->targ == OP_STRINGIFY) {
6e90668e
SM
1814 return $self->dquote($op);
1815 } elsif (!null($op->first->sibling) and
3f872cb9 1816 $op->first->sibling->name eq "readline" and
6e90668e 1817 $op->first->sibling->flags & OPf_STACKED) {
9d2c6865
SM
1818 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1819 . $self->deparse($op->first->sibling, 7),
1820 $cx, 7);
6e90668e 1821 } elsif (!null($op->first->sibling) and
3f872cb9 1822 $op->first->sibling->name eq "trans" and
6e90668e 1823 $op->first->sibling->flags & OPf_STACKED) {
9d2c6865
SM
1824 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1825 . $self->deparse($op->first->sibling, 20),
1826 $cx, 20);
6e90668e 1827 } else {
9d2c6865 1828 return $self->deparse($op->first, $cx);
6e90668e 1829 }
a798dbf2
MB
1830}
1831
bd0865ec
GS
1832# the aassign in-common check messes up SvCUR (always setting it
1833# to a value >= 100), but it's probably safe to assume there
1834# won't be any NULs in the names of my() variables. (with
1835# stash variables, I wouldn't be so sure)
1836sub padname_fix {
1837 my $str = shift;
1838 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1839 return $str;
1840}
1841
6e90668e
SM
1842sub padname {
1843 my $self = shift;
1844 my $targ = shift;
1845 my $str = $self->padname_sv($targ)->PV;
1846 return padname_fix($str);
1847}
1848
1849sub padany {
1850 my $self = shift;
1851 my $op = shift;
1852 return substr($self->padname($op->targ), 1); # skip $/@/%
1853}
1854
1855sub pp_padsv {
1856 my $self = shift;
9d2c6865
SM
1857 my($op, $cx) = @_;
1858 return $self->maybe_my($op, $cx, $self->padname($op->targ));
6e90668e
SM
1859}
1860
1861sub pp_padav { pp_padsv(@_) }
1862sub pp_padhv { pp_padsv(@_) }
1863
9d2c6865
SM
1864my @threadsv_names;
1865
1866BEGIN {
1867 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1868 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1869 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1870 "!", "@");
1871}
f6f9bdb7
SM
1872
1873sub pp_threadsv {
1874 my $self = shift;
9d2c6865
SM
1875 my($op, $cx) = @_;
1876 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
f6f9bdb7
SM
1877}
1878
6e90668e
SM
1879sub pp_gvsv {
1880 my $self = shift;
9d2c6865
SM
1881 my($op, $cx) = @_;
1882 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
6e90668e
SM
1883}
1884
1885sub pp_gv {
1886 my $self = shift;
9d2c6865 1887 my($op, $cx) = @_;
6e90668e
SM
1888 return $self->gv_name($op->gv);
1889}
1890
1891sub pp_aelemfast {
1892 my $self = shift;
9d2c6865 1893 my($op, $cx) = @_;
6e90668e
SM
1894 my $gv = $op->gv;
1895 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1896}
1897
1898sub rv2x {
1899 my $self = shift;
9d2c6865 1900 my($op, $cx, $type) = @_;
6e90668e 1901 my $kid = $op->first;
f5aa8f4e
SM
1902 my $str = $self->deparse($kid, 0);
1903 return $type . (is_scalar($kid) ? $str : "{$str}");
6e90668e
SM
1904}
1905
1906sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1907sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1908sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1909
1910# skip rv2av
1911sub pp_av2arylen {
1912 my $self = shift;
9d2c6865 1913 my($op, $cx) = @_;
3f872cb9 1914 if ($op->first->name eq "padav") {
9d2c6865 1915 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
6e90668e 1916 } else {
f5aa8f4e
SM
1917 return $self->maybe_local($op, $cx,
1918 $self->rv2x($op->first, $cx, '$#'));
6e90668e
SM
1919 }
1920}
1921
1922# skip down to the old, ex-rv2cv
9d2c6865 1923sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
6e90668e
SM
1924
1925sub pp_rv2av {
1926 my $self = shift;
9d2c6865 1927 my($op, $cx) = @_;
6e90668e 1928 my $kid = $op->first;
3f872cb9 1929 if ($kid->name eq "const") { # constant list
6e90668e
SM
1930 my $av = $kid->sv;
1931 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1932 } else {
9d2c6865 1933 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
6e90668e
SM
1934 }
1935 }
1936
3ed82cfc
GS
1937sub is_subscriptable {
1938 my $op = shift;
1939 if ($op->name =~ /^[ahg]elem/) {
1940 return 1;
1941 } elsif ($op->name eq "entersub") {
1942 my $kid = $op->first;
1943 return 0 unless null $kid->sibling;
1944 $kid = $kid->first;
1945 $kid = $kid->sibling until null $kid->sibling;
1946 return 0 if is_scope($kid);
1947 $kid = $kid->first;
1948 return 0 if $kid->name eq "gv";
1949 return 0 if is_scalar($kid);
1950 return is_subscriptable($kid);
1951 } else {
1952 return 0;
1953 }
1954}
6e90668e
SM
1955
1956sub elem {
1957 my $self = shift;
9d2c6865 1958 my ($op, $cx, $left, $right, $padname) = @_;
6e90668e 1959 my($array, $idx) = ($op->first, $op->first->sibling);
3f872cb9 1960 unless ($array->name eq $padname) { # Maybe this has been fixed
6e90668e
SM
1961 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1962 }
3f872cb9 1963 if ($array->name eq $padname) {
6e90668e
SM
1964 $array = $self->padany($array);
1965 } elsif (is_scope($array)) { # ${expr}[0]
9d2c6865 1966 $array = "{" . $self->deparse($array, 0) . "}";
6e90668e 1967 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
9d2c6865 1968 $array = $self->deparse($array, 24);
6e90668e
SM
1969 } else {
1970 # $x[20][3]{hi} or expr->[20]
3ed82cfc 1971 my $arrow = is_subscriptable($array) ? "" : "->";
9d2c6865
SM
1972 return $self->deparse($array, 24) . $arrow .
1973 $left . $self->deparse($idx, 1) . $right;
6e90668e 1974 }
9d2c6865 1975 $idx = $self->deparse($idx, 1);
6e90668e
SM
1976 return "\$" . $array . $left . $idx . $right;
1977}
1978
3f872cb9
GS
1979sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
1980sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
6e90668e
SM
1981
1982sub pp_gelem {
1983 my $self = shift;
9d2c6865 1984 my($op, $cx) = @_;
6e90668e
SM
1985 my($glob, $part) = ($op->first, $op->last);
1986 $glob = $glob->first; # skip rv2gv
3f872cb9 1987 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
9d2c6865
SM
1988 my $scope = is_scope($glob);
1989 $glob = $self->deparse($glob, 0);
1990 $part = $self->deparse($part, 1);
6e90668e
SM
1991 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1992}
1993
1994sub slice {
1995 my $self = shift;
9d2c6865 1996 my ($op, $cx, $left, $right, $regname, $padname) = @_;
6e90668e
SM
1997 my $last;
1998 my(@elems, $kid, $array, $list);
1999 if (class($op) eq "LISTOP") {
2000 $last = $op->last;
2001 } else { # ex-hslice inside delete()
2002 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2003 $last = $kid;
2004 }
2005 $array = $last;
2006 $array = $array->first
3f872cb9 2007 if $array->name eq $regname or $array->name eq "null";
6e90668e 2008 if (is_scope($array)) {
9d2c6865 2009 $array = "{" . $self->deparse($array, 0) . "}";
3f872cb9 2010 } elsif ($array->name eq $padname) {
6e90668e
SM
2011 $array = $self->padany($array);
2012 } else {
9d2c6865 2013 $array = $self->deparse($array, 24);
6e90668e
SM
2014 }
2015 $kid = $op->first->sibling; # skip pushmark
3f872cb9 2016 if ($kid->name eq "list") {
6e90668e
SM
2017 $kid = $kid->first->sibling; # skip list, pushmark
2018 for (; !null $kid; $kid = $kid->sibling) {
9d2c6865 2019 push @elems, $self->deparse($kid, 6);
6e90668e
SM
2020 }
2021 $list = join(", ", @elems);
2022 } else {
9d2c6865 2023 $list = $self->deparse($kid, 1);
6e90668e
SM
2024 }
2025 return "\@" . $array . $left . $list . $right;
2026}
2027
3ed82cfc
GS
2028sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2029sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
6e90668e
SM
2030
2031sub pp_lslice {
2032 my $self = shift;
9d2c6865 2033 my($op, $cx) = @_;
6e90668e
SM
2034 my $idx = $op->first;
2035 my $list = $op->last;
2036 my(@elems, $kid);
9d2c6865
SM
2037 $list = $self->deparse($list, 1);
2038 $idx = $self->deparse($idx, 1);
2039 return "($list)" . "[$idx]";
6e90668e
SM
2040}
2041
6e90668e
SM
2042sub want_scalar {
2043 my $op = shift;
2044 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2045}
2046
bd0865ec
GS
2047sub want_list {
2048 my $op = shift;
2049 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2050}
2051
2052sub method {
6e90668e 2053 my $self = shift;
9d2c6865 2054 my($op, $cx) = @_;
bd0865ec
GS
2055 my $kid = $op->first->sibling; # skip pushmark
2056 my($meth, $obj, @exprs);
3f872cb9 2057 if ($kid->name eq "list" and want_list $kid) {
bd0865ec
GS
2058 # When an indirect object isn't a bareword but the args are in
2059 # parens, the parens aren't part of the method syntax (the LLAFR
2060 # doesn't apply), but they make a list with OPf_PARENS set that
2061 # doesn't get flattened by the append_elem that adds the method,
2062 # making a (object, arg1, arg2, ...) list where the object
2063 # usually is. This can be distinguished from
2064 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2065 # object) because in the later the list is in scalar context
2066 # as the left side of -> always is, while in the former
2067 # the list is in list context as method arguments always are.
2068 # (Good thing there aren't method prototypes!)
3ed82cfc 2069 $meth = $kid->sibling;
bd0865ec
GS
2070 $kid = $kid->first->sibling; # skip pushmark
2071 $obj = $kid;
6e90668e 2072 $kid = $kid->sibling;
bd0865ec 2073 for (; not null $kid; $kid = $kid->sibling) {
9d2c6865 2074 push @exprs, $self->deparse($kid, 6);
6e90668e 2075 }
bd0865ec
GS
2076 } else {
2077 $obj = $kid;
2078 $kid = $kid->sibling;
2079 for (; not null $kid->sibling; $kid = $kid->sibling) {
2080 push @exprs, $self->deparse($kid, 6);
6e90668e 2081 }
3ed82cfc 2082 $meth = $kid;
bd0865ec
GS
2083 }
2084 $obj = $self->deparse($obj, 24);
3ed82cfc
GS
2085 if ($meth->name eq "method_named") {
2086 $meth = $meth->sv->PV;
bd0865ec 2087 } else {
3ed82cfc
GS
2088 $meth = $meth->first;
2089 if ($meth->name eq "const") {
2090 # As of 5.005_58, this case is probably obsoleted by the
2091 # method_named case above
2092 $meth = $meth->sv->PV; # needs to be bare
2093 } else {
2094 $meth = $self->deparse($meth, 1);
2095 }
bd0865ec
GS
2096 }
2097 my $args = join(", ", @exprs);
2098 $kid = $obj . "->" . $meth;
2099 if ($args) {
2100 return $kid . "(" . $args . ")"; # parens mandatory
2101 } else {
2102 return $kid;
2103 }
2104}
2105
2106# returns "&" if the prototype doesn't match the args,
2107# or ("", $args_after_prototype_demunging) if it does.
2108sub check_proto {
2109 my $self = shift;
2110 my($proto, @args) = @_;
2111 my($arg, $real);
2112 my $doneok = 0;
2113 my @reals;
2114 # An unbackslashed @ or % gobbles up the rest of the args
2115 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2116 while ($proto) {
2117 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2118 my $chr = $1;
2119 if ($chr eq "") {
2120 return "&" if @args;
2121 } elsif ($chr eq ";") {
2122 $doneok = 1;
2123 } elsif ($chr eq "@" or $chr eq "%") {
2124 push @reals, map($self->deparse($_, 6), @args);
2125 @args = ();
6e90668e 2126 } else {
bd0865ec
GS
2127 $arg = shift @args;
2128 last unless $arg;
2129 if ($chr eq "\$") {
2130 if (want_scalar $arg) {
2131 push @reals, $self->deparse($arg, 6);
2132 } else {
2133 return "&";
2134 }
2135 } elsif ($chr eq "&") {
3f872cb9 2136 if ($arg->name =~ /^(s?refgen|undef)$/) {
bd0865ec
GS
2137 push @reals, $self->deparse($arg, 6);
2138 } else {
2139 return "&";
2140 }
2141 } elsif ($chr eq "*") {
3f872cb9
GS
2142 if ($arg->name =~ /^s?refgen$/
2143 and $arg->first->first->name eq "rv2gv")
bd0865ec
GS
2144 {
2145 $real = $arg->first->first; # skip refgen, null
3f872cb9 2146 if ($real->first->name eq "gv") {
bd0865ec
GS
2147 push @reals, $self->deparse($real, 6);
2148 } else {
2149 push @reals, $self->deparse($real->first, 6);
2150 }
2151 } else {
2152 return "&";
2153 }
2154 } elsif (substr($chr, 0, 1) eq "\\") {
2155 $chr = substr($chr, 1);
3f872cb9 2156 if ($arg->name =~ /^s?refgen$/ and
bd0865ec
GS
2157 !null($real = $arg->first) and
2158 ($chr eq "\$" && is_scalar($real->first)
2159 or ($chr eq "\@"
3f872cb9
GS
2160 && $real->first->sibling->name
2161 =~ /^(rv2|pad)av$/)
bd0865ec 2162 or ($chr eq "%"
3f872cb9
GS
2163 && $real->first->sibling->name
2164 =~ /^(rv2|pad)hv$/)
bd0865ec 2165 #or ($chr eq "&" # This doesn't work
3f872cb9 2166 # && $real->first->name eq "rv2cv")
bd0865ec 2167 or ($chr eq "*"
3f872cb9 2168 && $real->first->name eq "rv2gv")))
bd0865ec
GS
2169 {
2170 push @reals, $self->deparse($real, 6);
2171 } else {
2172 return "&";
2173 }
2174 }
2175 }
9d2c6865 2176 }
bd0865ec
GS
2177 return "&" if $proto and !$doneok; # too few args and no `;'
2178 return "&" if @args; # too many args
2179 return ("", join ", ", @reals);
2180}
2181
2182sub pp_entersub {
2183 my $self = shift;
2184 my($op, $cx) = @_;
2185 return $self->method($op, $cx) unless null $op->first->sibling;
2186 my $prefix = "";
2187 my $amper = "";
2188 my($kid, @exprs);
9d2c6865
SM
2189 if ($op->flags & OPf_SPECIAL) {
2190 $prefix = "do ";
2191 } elsif ($op->private & OPpENTERSUB_AMPER) {
2192 $amper = "&";
2193 }
2194 $kid = $op->first;
2195 $kid = $kid->first->sibling; # skip ex-list, pushmark
2196 for (; not null $kid->sibling; $kid = $kid->sibling) {
2197 push @exprs, $kid;
2198 }
bd0865ec
GS
2199 my $simple = 0;
2200 my $proto = undef;
9d2c6865
SM
2201 if (is_scope($kid)) {
2202 $amper = "&";
2203 $kid = "{" . $self->deparse($kid, 0) . "}";
3f872cb9 2204 } elsif ($kid->first->name eq "gv") {
9d2c6865
SM
2205 my $gv = $kid->first->gv;
2206 if (class($gv->CV) ne "SPECIAL") {
2207 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2208 }
bd0865ec 2209 $simple = 1; # only calls of named functions can be prototyped
9d2c6865
SM
2210 $kid = $self->deparse($kid, 24);
2211 } elsif (is_scalar $kid->first) {
2212 $amper = "&";
2213 $kid = $self->deparse($kid, 24);
2214 } else {
2215 $prefix = "";
3ed82cfc
GS
2216 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2217 $kid = $self->deparse($kid, 24) . $arrow;
9d2c6865 2218 }
bd0865ec 2219 my $args;
9d2c6865 2220 if (defined $proto and not $amper) {
bd0865ec
GS
2221 ($amper, $args) = $self->check_proto($proto, @exprs);
2222 if ($amper eq "&") {
9d2c6865
SM
2223 $args = join(", ", map($self->deparse($_, 6), @exprs));
2224 }
2225 } else {
2226 $args = join(", ", map($self->deparse($_, 6), @exprs));
6e90668e 2227 }
9d2c6865
SM
2228 if ($prefix or $amper) {
2229 if ($op->flags & OPf_STACKED) {
2230 return $prefix . $amper . $kid . "(" . $args . ")";
2231 } else {
2232 return $prefix . $amper. $kid;
2233 }
6e90668e 2234 } else {
9d2c6865
SM
2235 if (defined $proto and $proto eq "") {
2236 return $kid;
2237 } elsif ($proto eq "\$") {
2238 return $self->maybe_parens_func($kid, $args, $cx, 16);
2239 } elsif ($proto or $simple) {
2240 return $self->maybe_parens_func($kid, $args, $cx, 5);
2241 } else {
2242 return "$kid(" . $args . ")";
2243 }
6e90668e
SM
2244 }
2245}
2246
2247sub pp_enterwrite { unop(@_, "write") }
2248
2249# escape things that cause interpolation in double quotes,
2250# but not character escapes
2251sub uninterp {
2252 my($str) = @_;
9d2c6865
SM
2253 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2254 return $str;
2255}
2256
2257# the same, but treat $|, $), and $ at the end of the string differently
2258sub re_uninterp {
2259 my($str) = @_;
2260 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2261 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
6e90668e
SM
2262 return $str;
2263}
2264
2265# character escapes, but not delimiters that might need to be escaped
2266sub escape_str { # ASCII
2267 my($str) = @_;
6e90668e
SM
2268 $str =~ s/\a/\\a/g;
2269# $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2270 $str =~ s/\t/\\t/g;
2271 $str =~ s/\n/\\n/g;
2272 $str =~ s/\e/\\e/g;
2273 $str =~ s/\f/\\f/g;
2274 $str =~ s/\r/\\r/g;
2275 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2276 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2277 return $str;
2278}
2279
9d2c6865
SM
2280# Don't do this for regexen
2281sub unback {
2282 my($str) = @_;
2283 $str =~ s/\\/\\\\/g;
2284 return $str;
2285}
2286
6e90668e
SM
2287sub balanced_delim {
2288 my($str) = @_;
2289 my @str = split //, $str;
2290 my($ar, $open, $close, $fail, $c, $cnt);
2291 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2292 ($open, $close) = @$ar;
2293 $fail = 0; $cnt = 0;
2294 for $c (@str) {
2295 if ($c eq $open) {
2296 $cnt++;
2297 } elsif ($c eq $close) {
2298 $cnt--;
2299 if ($cnt < 0) {
bd0865ec 2300 # qq()() isn't ")("
6e90668e
SM
2301 $fail = 1;
2302 last;
2303 }
2304 }
2305 }
2306 $fail = 1 if $cnt != 0;
2307 return ($open, "$open$str$close") if not $fail;
2308 }
2309 return ("", $str);
2310}
2311
2312sub single_delim {
2313 my($q, $default, $str) = @_;
90be192f 2314 return "$default$str$default" if $default and index($str, $default) == -1;
6e90668e
SM
2315 my($succeed, $delim);
2316 ($succeed, $str) = balanced_delim($str);
2317 return "$q$str" if $succeed;
2318 for $delim ('/', '"', '#') {
2319 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2320 }
90be192f
SM
2321 if ($default) {
2322 $str =~ s/$default/\\$default/g;
2323 return "$default$str$default";
2324 } else {
2325 $str =~ s[/][\\/]g;
2326 return "$q/$str/";
2327 }
6e90668e
SM
2328}
2329
6e90668e
SM
2330sub const {
2331 my $sv = shift;
2332 if (class($sv) eq "SPECIAL") {
bd0865ec 2333 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
6e90668e 2334 } elsif ($sv->FLAGS & SVf_IOK) {
a798dbf2 2335 return $sv->IV;
6e90668e 2336 } elsif ($sv->FLAGS & SVf_NOK) {
a798dbf2 2337 return $sv->NV;
6e90668e
SM
2338 } elsif ($sv->FLAGS & SVf_ROK) {
2339 return "\\(" . const($sv->RV) . ")"; # constant folded
a798dbf2 2340 } else {
6e90668e 2341 my $str = $sv->PV;
bd0865ec 2342 if ($str =~ /[^ -~]/) { # ASCII for non-printing
9d2c6865 2343 return single_delim("qq", '"', uninterp escape_str unback $str);
6e90668e 2344 } else {
bd0865ec 2345 return single_delim("q", "'", unback $str);
6e90668e 2346 }
a798dbf2
MB
2347 }
2348}
2349
6e90668e
SM
2350sub pp_const {
2351 my $self = shift;
9d2c6865 2352 my($op, $cx) = @_;
4c1f658f 2353# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
6e90668e
SM
2354# return $op->sv->PV;
2355# }
2356 return const($op->sv);
2357}
2358
2359sub dq {
2360 my $self = shift;
2361 my $op = shift;
3f872cb9
GS
2362 my $type = $op->name;
2363 if ($type eq "const") {
9d2c6865 2364 return uninterp(escape_str(unback($op->sv->PV)));
3f872cb9 2365 } elsif ($type eq "concat") {
6e90668e 2366 return $self->dq($op->first) . $self->dq($op->last);
3f872cb9 2367 } elsif ($type eq "uc") {
6e90668e 2368 return '\U' . $self->dq($op->first->sibling) . '\E';
3f872cb9 2369 } elsif ($type eq "lc") {
6e90668e 2370 return '\L' . $self->dq($op->first->sibling) . '\E';
3f872cb9 2371 } elsif ($type eq "ucfirst") {
6e90668e 2372 return '\u' . $self->dq($op->first->sibling);
3f872cb9 2373 } elsif ($type eq "lcfirst") {
6e90668e 2374 return '\l' . $self->dq($op->first->sibling);
3f872cb9 2375 } elsif ($type eq "quotemeta") {
6e90668e 2376 return '\Q' . $self->dq($op->first->sibling) . '\E';
3f872cb9 2377 } elsif ($type eq "join") {
9d2c6865 2378 return $self->deparse($op->last, 26); # was join($", @ary)
a798dbf2 2379 } else {
9d2c6865 2380 return $self->deparse($op, 26);
6e90668e
SM
2381 }
2382}
2383
2384sub pp_backtick {
2385 my $self = shift;
9d2c6865 2386 my($op, $cx) = @_;
6e90668e
SM
2387 # skip pushmark
2388 return single_delim("qx", '`', $self->dq($op->first->sibling));
2389}
2390
2391sub dquote {
2392 my $self = shift;
bd0865ec 2393 my($op, $cx) = shift;
3ed82cfc
GS
2394 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2395 return $self->deparse($kid, $cx) if $self->{'unquote'};
2396 $self->maybe_targmy($kid, $cx,
2397 sub {single_delim("qq", '"', $self->dq($_[1]))});
6e90668e
SM
2398}
2399
bd0865ec 2400# OP_STRINGIFY is a listop, but it only ever has one arg
3ed82cfc 2401sub pp_stringify { maybe_targmy(@_, \&dquote) }
6e90668e
SM
2402
2403# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2404# note that tr(from)/to/ is OK, but not tr/from/(to)
2405sub double_delim {
2406 my($from, $to) = @_;
2407 my($succeed, $delim);
2408 if ($from !~ m[/] and $to !~ m[/]) {
2409 return "/$from/$to/";
2410 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2411 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2412 return "$from$to";
2413 } else {
2414 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2415 return "$from$delim$to$delim" if index($to, $delim) == -1;
2416 }
2417 $to =~ s[/][\\/]g;
2418 return "$from/$to/";
2419 }
2420 } else {
2421 for $delim ('/', '"', '#') { # note no '
2422 return "$delim$from$delim$to$delim"
2423 if index($to . $from, $delim) == -1;
2424 }
2425 $from =~ s[/][\\/]g;
2426 $to =~ s[/][\\/]g;
2427 return "/$from/$to/";
2428 }
2429}
2430
2431sub pchr { # ASCII
2432 my($n) = @_;
2433 if ($n == ord '\\') {
2434 return '\\\\';
2435 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2436 return chr($n);
2437 } elsif ($n == ord "\a") {
2438 return '\\a';
2439 } elsif ($n == ord "\b") {
2440 return '\\b';
2441 } elsif ($n == ord "\t") {
2442 return '\\t';
2443 } elsif ($n == ord "\n") {
2444 return '\\n';
2445 } elsif ($n == ord "\e") {
2446 return '\\e';
2447 } elsif ($n == ord "\f") {
2448 return '\\f';
2449 } elsif ($n == ord "\r") {
2450 return '\\r';
2451 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2452 return '\\c' . chr(ord("@") + $n);
2453 } else {
2454# return '\x' . sprintf("%02x", $n);
2455 return '\\' . sprintf("%03o", $n);
2456 }
2457}
2458
2459sub collapse {
2460 my(@chars) = @_;
2461 my($c, $str, $tr);
2462 for ($c = 0; $c < @chars; $c++) {
2463 $tr = $chars[$c];
2464 $str .= pchr($tr);
2465 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2466 $chars[$c + 2] == $tr + 2)
2467 {
f4a44678
SM
2468 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2469 {}
6e90668e
SM
2470 $str .= "-";
2471 $str .= pchr($chars[$c]);
2472 }
2473 }
2474 return $str;
2475}
2476
f4a44678
SM
2477# XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2478# and backslashes.
2479
2480sub tr_decode_byte {
2481 my($table, $flags) = @_;
2482 my(@table) = unpack("s256", $table);
6e90668e
SM
2483 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2484 if ($table[ord "-"] != -1 and
2485 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2486 {
2487 $tr = $table[ord "-"];
2488 $table[ord "-"] = -1;
2489 if ($tr >= 0) {
2490 @from = ord("-");
2491 @to = $tr;
2492 } else { # -2 ==> delete
2493 $delhyphen = 1;
2494 }
2495 }
2496 for ($c = 0; $c < 256; $c++) {
2497 $tr = $table[$c];
2498 if ($tr >= 0) {
2499 push @from, $c; push @to, $tr;
2500 } elsif ($tr == -2) {
2501 push @delfrom, $c;
2502 }
2503 }
6e90668e 2504 @from = (@from, @delfrom);
f4a44678 2505 if ($flags & OPpTRANS_COMPLEMENT) {
6e90668e
SM
2506 my @newfrom = ();
2507 my %from;
2508 @from{@from} = (1) x @from;
2509 for ($c = 0; $c < 256; $c++) {
2510 push @newfrom, $c unless $from{$c};
2511 }
2512 @from = @newfrom;
2513 }
f4a44678 2514 unless ($flags & OPpTRANS_DELETE) {
6e90668e
SM
2515 pop @to while $#to and $to[$#to] == $to[$#to -1];
2516 }
6e90668e
SM
2517 my($from, $to);
2518 $from = collapse(@from);
2519 $to = collapse(@to);
2520 $from .= "-" if $delhyphen;
f4a44678
SM
2521 return ($from, $to);
2522}
2523
2524sub tr_chr {
2525 my $x = shift;
2526 if ($x == ord "-") {
2527 return "\\-";
2528 } else {
2529 return chr $x;
2530 }
2531}
2532
2533# XXX This doesn't yet handle all cases correctly either
2534
2535sub tr_decode_utf8 {
2536 my($swash_hv, $flags) = @_;
2537 my %swash = $swash_hv->ARRAY;
2538 my $final = undef;
2539 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2540 my $none = $swash{"NONE"}->IV;
2541 my $extra = $none + 1;
2542 my(@from, @delfrom, @to);
2543 my $line;
2544 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2545 my($min, $max, $result) = split(/\t/, $line);
2546 $min = hex $min;
2547 if (length $max) {
2548 $max = hex $max;
2549 } else {
2550 $max = $min;
2551 }
2552 $result = hex $result;
2553 if ($result == $extra) {
2554 push @delfrom, [$min, $max];
2555 } else {
2556 push @from, [$min, $max];
2557 push @to, [$result, $result + $max - $min];
2558 }
2559 }
2560 for my $i (0 .. $#from) {
2561 if ($from[$i][0] == ord '-') {
2562 unshift @from, splice(@from, $i, 1);
2563 unshift @to, splice(@to, $i, 1);
2564 last;
2565 } elsif ($from[$i][1] == ord '-') {
2566 $from[$i][1]--;
2567 $to[$i][1]--;
2568 unshift @from, ord '-';
2569 unshift @to, ord '-';
2570 last;
2571 }
2572 }
2573 for my $i (0 .. $#delfrom) {
2574 if ($delfrom[$i][0] == ord '-') {
2575 push @delfrom, splice(@delfrom, $i, 1);
2576 last;
2577 } elsif ($delfrom[$i][1] == ord '-') {
2578 $delfrom[$i][1]--;
2579 push @delfrom, ord '-';
2580 last;
2581 }
2582 }
2583 if (defined $final and $to[$#to][1] != $final) {
2584 push @to, [$final, $final];
2585 }
2586 push @from, @delfrom;
2587 if ($flags & OPpTRANS_COMPLEMENT) {
2588 my @newfrom;
2589 my $next = 0;
2590 for my $i (0 .. $#from) {
2591 push @newfrom, [$next, $from[$i][0] - 1];
2592 $next = $from[$i][1] + 1;
2593 }
2594 @from = ();
2595 for my $range (@newfrom) {
2596 if ($range->[0] <= $range->[1]) {
2597 push @from, $range;
2598 }
2599 }
2600 }
2601 my($from, $to, $diff);
2602 for my $chunk (@from) {
2603 $diff = $chunk->[1] - $chunk->[0];
2604 if ($diff > 1) {
2605 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2606 } elsif ($diff == 1) {
2607 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2608 } else {
2609 $from .= tr_chr($chunk->[0]);
2610 }
2611 }
2612 for my $chunk (@to) {
2613 $diff = $chunk->[1] - $chunk->[0];
2614 if ($diff > 1) {
2615 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2616 } elsif ($diff == 1) {
2617 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2618 } else {
2619 $to .= tr_chr($chunk->[0]);
2620 }
2621 }
2622 #$final = sprintf("%04x", $final) if defined $final;
2623 #$none = sprintf("%04x", $none) if defined $none;
2624 #$extra = sprintf("%04x", $extra) if defined $extra;
2625 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2626 #print STDERR $swash{'LIST'}->PV;
2627 return (escape_str($from), escape_str($to));
2628}
2629
2630sub pp_trans {
2631 my $self = shift;
2632 my($op, $cx) = @_;
2633 my($from, $to);
2634 if (class($op) eq "PVOP") {
2635 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2636 } else { # class($op) eq "SVOP"
2637 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2638 }
2639 my $flags = "";
2640 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2641 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2642 $to = "" if $from eq $to and $flags eq "";
2643 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
6e90668e
SM
2644 return "tr" . double_delim($from, $to) . $flags;
2645}
2646
2647# Like dq(), but different
2648sub re_dq {
2649 my $self = shift;
2650 my $op = shift;
3f872cb9
GS
2651 my $type = $op->name;
2652 if ($type eq "const") {
6e90668e 2653 return uninterp($op->sv->PV);
3f872cb9 2654 } elsif ($type eq "concat") {
6e90668e 2655 return $self->re_dq($op->first) . $self->re_dq($op->last);
3f872cb9 2656 } elsif ($type eq "uc") {
6e90668e 2657 return '\U' . $self->re_dq($op->first->sibling) . '\E';
3f872cb9 2658 } elsif ($type eq "lc") {
6e90668e 2659 return '\L' . $self->re_dq($op->first->sibling) . '\E';
3f872cb9 2660 } elsif ($type eq "ucfirst") {
6e90668e 2661 return '\u' . $self->re_dq($op->first->sibling);
3f872cb9 2662 } elsif ($type eq "lcfirst") {
6e90668e 2663 return '\l' . $self->re_dq($op->first->sibling);
3f872cb9 2664 } elsif ($type eq "quotemeta") {
6e90668e 2665 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3f872cb9 2666 } elsif ($type eq "join") {
9d2c6865 2667 return $self->deparse($op->last, 26); # was join($", @ary)
6e90668e 2668 } else {
9d2c6865 2669 return $self->deparse($op, 26);
6e90668e
SM
2670 }
2671}
2672
2673sub pp_regcomp {
2674 my $self = shift;
9d2c6865 2675 my($op, $cx) = @_;
6e90668e 2676 my $kid = $op->first;
3f872cb9
GS
2677 $kid = $kid->first if $kid->name eq "regcmaybe";
2678 $kid = $kid->first if $kid->name eq "regcreset";
6e90668e
SM
2679 return $self->re_dq($kid);
2680}
2681
6e90668e
SM
2682# osmic acid -- see osmium tetroxide
2683
2684my %matchwords;
2685map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2686 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2687 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2688
90be192f 2689sub matchop {
6e90668e 2690 my $self = shift;
90be192f 2691 my($op, $cx, $name, $delim) = @_;
6e90668e 2692 my $kid = $op->first;
9d2c6865 2693 my ($binop, $var, $re) = ("", "", "");
6e90668e 2694 if ($op->flags & OPf_STACKED) {
9d2c6865
SM
2695 $binop = 1;
2696 $var = $self->deparse($kid, 20);
6e90668e
SM
2697 $kid = $kid->sibling;
2698 }
2699 if (null $kid) {
9d2c6865 2700 $re = re_uninterp(escape_str($op->precomp));
6e90668e 2701 } else {
9d2c6865 2702 $re = $self->deparse($kid, 1);
6e90668e
SM
2703 }
2704 my $flags = "";
2705 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2706 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2707 $flags .= "i" if $op->pmflags & PMf_FOLD;
2708 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2709 $flags .= "o" if $op->pmflags & PMf_KEEP;
2710 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2711 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2712 $flags = $matchwords{$flags} if $matchwords{$flags};
2713 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2714 $re =~ s/\?/\\?/g;
9d2c6865
SM
2715 $re = "?$re?";
2716 } else {
90be192f 2717 $re = single_delim($name, $delim, $re);
9d2c6865
SM
2718 }
2719 $re = $re . $flags;
2720 if ($binop) {
2721 return $self->maybe_parens("$var =~ $re", $cx, 20);
2722 } else {
2723 return $re;
6e90668e 2724 }
6e90668e
SM
2725}
2726
90be192f
SM
2727sub pp_match { matchop(@_, "m", "/") }
2728sub pp_pushre { matchop(@_, "m", "/") }
2729sub pp_qr { matchop(@_, "qr", "") }
6e90668e
SM
2730
2731sub pp_split {
2732 my $self = shift;
9d2c6865 2733 my($op, $cx) = @_;
6e90668e
SM
2734 my($kid, @exprs, $ary, $expr);
2735 $kid = $op->first;
2736 if ($ {$kid->pmreplroot}) {
2737 $ary = '@' . $self->gv_name($kid->pmreplroot);
2738 }
2739 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 2740 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
2741 }
2742 $expr = "split(" . join(", ", @exprs) . ")";
2743 if ($ary) {
9d2c6865 2744 return $self->maybe_parens("$ary = $expr", $cx, 7);
6e90668e
SM
2745 } else {
2746 return $expr;
2747 }
2748}
2749
2750# oxime -- any of various compounds obtained chiefly by the action of
2751# hydroxylamine on aldehydes and ketones and characterized by the
2752# bivalent grouping C=NOH [Webster's Tenth]
2753
2754my %substwords;
2755map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2756 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2757 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2758 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2759
2760sub pp_subst {
2761 my $self = shift;
9d2c6865 2762 my($op, $cx) = @_;
6e90668e 2763 my $kid = $op->first;
9d2c6865 2764 my($binop, $var, $re, $repl) = ("", "", "", "");
6e90668e 2765 if ($op->flags & OPf_STACKED) {
9d2c6865
SM
2766 $binop = 1;
2767 $var = $self->deparse($kid, 20);
6e90668e
SM
2768 $kid = $kid->sibling;
2769 }
2770 my $flags = "";
2771 if (null($op->pmreplroot)) {
2772 $repl = $self->dq($kid);
2773 $kid = $kid->sibling;
2774 } else {
2775 $repl = $op->pmreplroot->first; # skip substcont
3f872cb9 2776 while ($repl->name eq "entereval") {
6e90668e
SM
2777 $repl = $repl->first;
2778 $flags .= "e";
2779 }
bd0865ec
GS
2780 if ($op->pmflags & PMf_EVAL) {
2781 $repl = $self->deparse($repl, 0);
2782 } else {
2783 $repl = $self->dq($repl);
2784 }
6e90668e
SM
2785 }
2786 if (null $kid) {
9d2c6865 2787 $re = re_uninterp(escape_str($op->precomp));
6e90668e 2788 } else {
9d2c6865 2789 $re = $self->deparse($kid, 1);
a798dbf2 2790 }
6e90668e
SM
2791 $flags .= "e" if $op->pmflags & PMf_EVAL;
2792 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2793 $flags .= "i" if $op->pmflags & PMf_FOLD;
2794 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2795 $flags .= "o" if $op->pmflags & PMf_KEEP;
2796 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2797 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2798 $flags = $substwords{$flags} if $substwords{$flags};
9d2c6865
SM
2799 if ($binop) {
2800 return $self->maybe_parens("$var =~ s"
2801 . double_delim($re, $repl) . $flags,
2802 $cx, 20);
2803 } else {
2804 return "s". double_delim($re, $repl) . $flags;
2805 }
a798dbf2
MB
2806}
2807
28081;
f6f9bdb7
SM
2809__END__
2810
2811=head1 NAME
2812
2813B::Deparse - Perl compiler backend to produce perl code
2814
2815=head1 SYNOPSIS
2816
f4a44678
SM
2817B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2818 I<prog.pl>
f6f9bdb7
SM
2819
2820=head1 DESCRIPTION
2821
2822B::Deparse is a backend module for the Perl compiler that generates
2823perl source code, based on the internal compiled structure that perl
2824itself creates after parsing a program. The output of B::Deparse won't
2825be exactly the same as the original source, since perl doesn't keep
2826track of comments or whitespace, and there isn't a one-to-one
2827correspondence between perl's syntactical constructions and their
9d2c6865
SM
2828compiled form, but it will often be close. When you use the B<-p>
2829option, the output also includes parentheses even when they are not
2830required by precedence, which can make it easy to see if perl is
2831parsing your expressions the way you intended.
f6f9bdb7
SM
2832
2833Please note that this module is mainly new and untested code and is
2834still under development, so it may change in the future.
2835
2836=head1 OPTIONS
2837
9d2c6865
SM
2838As with all compiler backend options, these must follow directly after
2839the '-MO=Deparse', separated by a comma but not any white space.
f6f9bdb7
SM
2840
2841=over 4
2842
bd0865ec
GS
2843=item B<-l>
2844
2845Add '#line' declarations to the output based on the line and file
2846locations of the original code.
2847
9d2c6865
SM
2848=item B<-p>
2849
2850Print extra parentheses. Without this option, B::Deparse includes
2851parentheses in its output only when they are needed, based on the
2852structure of your program. With B<-p>, it uses parentheses (almost)
2853whenever they would be legal. This can be useful if you are used to
2854LISP, or if you want to see how perl parses your input. If you say
2855
2856 if ($var & 0x7f == 65) {print "Gimme an A!"}
2857 print ($which ? $a : $b), "\n";
2858 $name = $ENV{USER} or "Bob";
2859
2860C<B::Deparse,-p> will print
2861
2862 if (($var & 0)) {
2863 print('Gimme an A!')
2864 };
2865 (print(($which ? $a : $b)), '???');
2866 (($name = $ENV{'USER'}) or '???')
2867
2868which probably isn't what you intended (the C<'???'> is a sign that
2869perl optimized away a constant value).
2870
bd0865ec
GS
2871=item B<-q>
2872
2873Expand double-quoted strings into the corresponding combinations of
2874concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2875instance, print
2876
2877 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2878
2879as
2880
2881 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2882 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2883
2884Note that the expanded form represents the way perl handles such
2885constructions internally -- this option actually turns off the reverse
2886translation that B::Deparse usually does. On the other hand, note that
2887C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2888of $y into a string before doing the assignment.
2889
9d2c6865 2890=item B<-u>I<PACKAGE>
f6f9bdb7
SM
2891
2892Normally, B::Deparse deparses the main code of a program, all the subs
2893called by the main program (and all the subs called by them,
2894recursively), and any other subs in the main:: package. To include
2895subs in other packages that aren't called directly, such as AUTOLOAD,
f4a44678
SM
2896DESTROY, other subs called automatically by perl, and methods (which
2897aren't resolved to subs until runtime), use the B<-u> option. The
f6f9bdb7
SM
2898argument to B<-u> is the name of a package, and should follow directly
2899after the 'u'. Multiple B<-u> options may be given, separated by
2900commas. Note that unlike some other backends, B::Deparse doesn't
2901(yet) try to guess automatically when B<-u> is needed -- you must
2902invoke it yourself.
2903
9d2c6865
SM
2904=item B<-s>I<LETTERS>
2905
f4a44678
SM
2906Tweak the style of B::Deparse's output. The letters should follow
2907directly after the 's', with no space or punctuation. The following
2908options are available:
9d2c6865
SM
2909
2910=over 4
2911
2912=item B<C>
2913
2914Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2915
2916 if (...) {
2917 ...
2918 } else {
2919 ...
2920 }
2921
2922instead of
2923
2924 if (...) {
2925 ...
2926 }
2927 else {
2928 ...
2929 }
2930
2931The default is not to cuddle.
2932
f4a44678
SM
2933=item B<i>I<NUMBER>
2934
2935Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2936
2937=item B<T>
2938
2939Use tabs for each 8 columns of indent. The default is to use only spaces.
2940For instance, if the style options are B<-si4T>, a line that's indented
29413 times will be preceded by one tab and four spaces; if the options were
2942B<-si8T>, the same line would be preceded by three tabs.
2943
2944=item B<v>I<STRING>B<.>
2945
2946Print I<STRING> for the value of a constant that can't be determined
2947because it was optimized away (mnemonic: this happens when a constant
2948is used in B<v>oid context). The end of the string is marked by a period.
2949The string should be a valid perl expression, generally a constant.
2950Note that unless it's a number, it probably needs to be quoted, and on
2951a command line quotes need to be protected from the shell. Some
2952conventional values include 0, 1, 42, '', 'foo', and
2953'Useless use of constant omitted' (which may need to be
2954B<-sv"'Useless use of constant omitted'.">
2955or something similar depending on your shell). The default is '???'.
2956If you're using B::Deparse on a module or other file that's require'd,
2957you shouldn't use a value that evaluates to false, since the customary
2958true constant at the end of a module will be in void context when the
2959file is compiled as a main program.
2960
9d2c6865
SM
2961=back
2962
f6f9bdb7
SM
2963=back
2964
f4a44678
SM
2965=head1 USING B::Deparse AS A MODULE
2966
2967=head2 Synopsis
2968
2969 use B::Deparse;
2970 $deparse = B::Deparse->new("-p", "-sC");
2971 $body = $deparse->coderef2text(\&func);
2972 eval "sub func $body"; # the inverse operation
2973
2974=head2 Description
2975
2976B::Deparse can also be used on a sub-by-sub basis from other perl
2977programs.
2978
2979=head2 new
2980
2981 $deparse = B::Deparse->new(OPTIONS)
2982
2983Create an object to store the state of a deparsing operation and any
2984options. The options are the same as those that can be given on the
2985command line (see L</OPTIONS>); options that are separated by commas
2986after B<-MO=Deparse> should be given as separate strings. Some
2987options, like B<-u>, don't make sense for a single subroutine, so
2988don't pass them.
2989
2990=head2 coderef2text
2991
2992 $body = $deparse->coderef2text(\&func)
2993 $body = $deparse->coderef2text(sub ($$) { ... })
2994
2995Return source code for the body of a subroutine (a block, optionally
2996preceded by a prototype in parens), given a reference to the
2997sub. Because a subroutine can have no names, or more than one name,
2998this method doesn't return a complete subroutine definition -- if you
2999want to eval the result, you should prepend "sub subname ", or "sub "
3000for an anonymous function constructor. Unless the sub was defined in
3001the main:: package, the code will include a package declaration.
3002
f6f9bdb7
SM
3003=head1 BUGS
3004
3005See the 'to do' list at the beginning of the module file.
3006
3007=head1 AUTHOR
3008
bd0865ec 3009Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
f4a44678
SM
3010version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3011contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3012der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
f6f9bdb7
SM
3013
3014=cut