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