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