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