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