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