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