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