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