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