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