This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add perlport.pod v1.23 from Chris Nandor <pudge@pobox.com>
[perl5.git] / ext / B / B / Deparse.pm
CommitLineData
6e90668e
SM
1# B::Deparse.pm
2# Copyright (c) 1998 Stephen McCamant. All rights reserved.
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;
6e90668e
SM
10use Carp 'cluck';
11use B qw(class main_root main_start main_cv svref_2object);
f6f9bdb7 12$VERSION = 0.52;
a798dbf2 13use strict;
a798dbf2 14
6e90668e
SM
15# Changes between 0.50 and 0.51:
16# - fixed nulled leave with live enter in sort { }
17# - fixed reference constants (\"str")
18# - handle empty programs gracefully
19# - handle infinte loops (for (;;) {}, while (1) {})
20# - differentiate between `for my $x ...' and `my $x; for $x ...'
21# - various minor cleanups
22# - moved globals into an object
23# - added `-u', like B::C
24# - package declarations using cop_stash
25# - subs, formats and code sorted by cop_seq
f6f9bdb7
SM
26# Changes between 0.51 and 0.52:
27# - added pp_threadsv (special variables under USE_THREADS)
28# - added documentation
6e90668e
SM
29
30# Todo:
31# - eliminate superfluous parentheses
32# - 'EXPR1 && EXPR2;' => 'EXPR2 if EXPR1;'
6e90668e
SM
33# - style options
34# - '&&' => 'and'?
35# - ',' => '=>' (auto-unquote?)
36# - break long lines ("\r" as discretionary break?)
37# - version using op_next instead of op_first/sibling?
38# - avoid string copies (pass arrays, one big join?)
39# - auto-apply `-u'?
6e90668e
SM
40
41# The following OPs don't have functions:
42
6e90668e
SM
43# pp_padany -- does not exist after parsing
44# pp_rcatline -- does not exist
45
46# pp_leavesub -- see deparse_sub
47# pp_leavewrite -- see deparse_format
48# pp_method -- see entersub
49# pp_regcmaybe -- see regcomp
50# pp_substcont -- see subst
51# pp_grepstart -- see grepwhile
52# pp_mapstart -- see mapwhile
53# pp_flip -- see flop
54# pp_iter -- see leaveloop
f6f9bdb7 55# pp_enteriter -- see leaveloop
6e90668e
SM
56# pp_enterloop -- see leaveloop
57# pp_leaveeval -- see entereval
58# pp_entertry -- see leavetry
59
60# Object fields (were globals):
61#
62# avoid_local:
63# (local($a), local($b)) and local($a, $b) have the same internal
64# representation but the short form looks better. We notice we can
65# use a large-scale local when checking the list, but need to prevent
66# individual locals too. This hash holds the addresses of OPs that
67# have already had their local-ness accounted for. The same thing
68# is done with my().
69#
70# curcv:
71# CV for current sub (or main program) being deparsed
72#
73# curstash:
74# name of the current package for deparsed code
75#
76# subs_todo:
77# array of [cop_seq, GV, is_format?] for subs and formats we still
78# want to deparse
79#
80# subs_done, forms_done:
81# keys are addresses of GVs for subs and formats we've already
82# deparsed (or at least put into subs_todo)
83
84sub null {
85 my $op = shift;
86 return class($op) eq "NULL";
87}
88
89sub todo {
90 my $self = shift;
91 my($gv, $cv, $is_form) = @_;
92 my $seq;
93 if (!null($cv->START) and is_state($cv->START)) {
94 $seq = $cv->START->cop_seq;
95 } else {
96 $seq = 0;
97 }
98 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
99}
100
101sub next_todo {
102 my $self = shift;
103 my $ent = shift @{$self->{'subs_todo'}};
104 my $name = $self->gv_name($ent->[1]);
105 if ($ent->[2]) {
106 return "format $name =\n"
107 . $self->deparse_format($ent->[1]->FORM). "\n";
108 } else {
109 return "sub $name " .
110 $self->deparse_sub($ent->[1]->CV);
111 }
112}
113
114sub OPf_KIDS () { 4 }
115
116sub walk_tree {
117 my($op, $sub) = @_;
118 $sub->($op);
119 if ($op->flags & OPf_KIDS) {
120 my $kid;
121 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
122 walk_tree($kid, $sub);
123 }
124 }
125}
126
127sub walk_sub {
128 my $self = shift;
129 my $cv = shift;
130 my $op = $cv->ROOT;
131 $op = shift if null $op;
132 return if !$op or null $op;
133 walk_tree($op, sub {
134 my $op = shift;
135 if ($op->ppaddr eq "pp_gv") {
136 if ($op->next->ppaddr eq "pp_entersub") {
137 next if $self->{'subs_done'}{$ {$op->gv}}++;
138 next if class($op->gv->CV) eq "SPECIAL";
139 $self->todo($op->gv, $op->gv->CV, 0);
140 $self->walk_sub($op->gv->CV);
141 } elsif ($op->next->ppaddr eq "pp_enterwrite"
142 or ($op->next->ppaddr eq "pp_rv2gv"
143 and $op->next->next->ppaddr eq "pp_enterwrite")) {
144 next if $self->{'forms_done'}{$ {$op->gv}}++;
145 next if class($op->gv->FORM) eq "SPECIAL";
146 $self->todo($op->gv, $op->gv->FORM, 1);
147 $self->walk_sub($op->gv->FORM);
148 }
149 }
150 });
151}
152
153sub stash_subs {
154 my $self = shift;
155 my $pack = shift;
156 my(%stash, @ret);
157 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
158 my($key, $val);
159 while (($key, $val) = each %stash) {
160 next unless class($val) eq "GV";
161 if (class($val->CV) ne "SPECIAL") {
162 next if $self->{'subs_done'}{$$val}++;
163 $self->todo($val, $val->CV, 0);
164 $self->walk_sub($val->CV);
165 }
166 if (class($val->FORM) ne "SPECIAL") {
167 next if $self->{'forms_done'}{$$val}++;
168 $self->todo($val, $val->FORM, 1);
169 $self->walk_sub($val->FORM);
170 }
171 }
172}
a798dbf2
MB
173
174sub compile {
6e90668e
SM
175 my(@args) = @_;
176 return sub {
177 my $self = bless {};
178 my $arg;
179 $self->{'subs_todo'} = [];
180 $self->stash_subs("main");
181 $self->{'curcv'} = main_cv;
182 $self->{'curstash'} = "main";
183 while ($arg = shift @args) {
184 if (substr($arg, 0, 2) eq "-u") {
185 $self->stash_subs(substr($arg, 2));
186 }
187 }
188 $self->walk_sub(main_cv, main_start);
189 @{$self->{'subs_todo'}} =
190 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
191 print indent($self->deparse(main_root)), "\n" unless null main_root;
192 my @text;
193 while (scalar(@{$self->{'subs_todo'}})) {
194 push @text, $self->next_todo;
195 }
196 print indent(join("", @text)), "\n" if @text;
a798dbf2 197 }
a798dbf2
MB
198}
199
6e90668e
SM
200sub deparse {
201 my $self = shift;
a798dbf2 202 my $op = shift;
6e90668e
SM
203# cluck unless ref $op;
204 my $meth = $op->ppaddr;
205 return $self->$meth($op);
a798dbf2
MB
206}
207
6e90668e
SM
208sub indent {
209 my $txt = shift;
210 my @lines = split(/\n/, $txt);
211 my $leader = "";
212 my $line;
213 for $line (@lines) {
214 if (substr($line, 0, 1) eq "\t") {
215 $leader = $leader . " ";
216 $line = substr($line, 1);
217 } elsif (substr($line, 0, 1) eq "\b") {
218 $leader = substr($leader, 0, length($leader) - 4);
219 $line = substr($line, 1);
220 }
221 $line = $leader . $line;
222 }
223 return join("\n", @lines);
224}
225
226sub SVf_POK () {0x40000}
227
228sub deparse_sub {
229 my $self = shift;
230 my $cv = shift;
231 my $proto = "";
232 if ($cv->FLAGS & SVf_POK) {
233 $proto = "(". $cv->PV . ") ";
234 }
235 local($self->{'curcv'}) = $cv;
236 local($self->{'curstash'}) = $self->{'curstash'};
237 if (not null $cv->ROOT) {
238 # skip leavesub
239 return $proto . "{\n\t" .
240 $self->deparse($cv->ROOT->first) . "\n\b}\n";
241 } else { # XSUB?
242 return $proto . "{}\n";
243 }
244}
245
246sub deparse_format {
247 my $self = shift;
248 my $form = shift;
249 my @text;
250 local($self->{'curcv'}) = $form;
251 local($self->{'curstash'}) = $self->{'curstash'};
252 my $op = $form->ROOT;
253 my $kid;
254 $op = $op->first->first; # skip leavewrite, lineseq
255 while (not null $op) {
256 $op = $op->sibling; # skip nextstate
257 my @exprs;
258 $kid = $op->first->sibling; # skip pushmark
259 push @text, $kid->sv->PV;
260 $kid = $kid->sibling;
261 for (; not null $kid; $kid = $kid->sibling) {
262 push @exprs, $self->deparse($kid);
263 }
264 push @text, join(", ", @exprs)."\n" if @exprs;
265 $op = $op->sibling;
266 }
267 return join("", @text) . ".";
268}
269
270# the aassign in-common check messes up SvCUR (always setting it
271# to a value >= 100), but it's probably safe to assume there
272# won't be any NULs in the names of my() variables. (with
273# stash variables, I wouldn't be so sure)
274sub padname_fix {
275 my $str = shift;
276 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
277 return $str;
278}
279
280sub is_scope {
a798dbf2 281 my $op = shift;
6e90668e
SM
282 return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
283 || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
284 && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
285}
286
287sub is_state {
288 my $name = $_[0]->ppaddr;
289 return $name eq "pp_nextstate" || $name eq "pp_dbstate";
290}
291
292sub is_miniwhile { # check for one-line loop (`foo() while $y--')
293 my $op = shift;
294 return (!null($op) and null($op->sibling)
295 and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
296 and (($op->first->ppaddr =~ /^pp_(and|or)$/
297 and $op->first->first->sibling->ppaddr eq "pp_lineseq")
298 or ($op->first->ppaddr eq "pp_lineseq"
299 and not null $op->first->first->sibling
300 and $op->first->first->sibling->ppaddr eq "pp_unstack")
301 ));
302}
303
304sub is_scalar {
305 my $op = shift;
306 return ($op->ppaddr eq "pp_rv2sv" or
307 $op->ppaddr eq "pp_padsv" or
308 $op->ppaddr eq "pp_gv" or # only in array/hash constructs
309 !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
310}
311
312sub OPp_LVAL_INTRO () { 128 }
313
314sub maybe_local {
315 my $self = shift;
316 my($op, $text) = @_;
317 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
318 return "local(" . $text . ")";
319 } else {
320 return $text;
a798dbf2 321 }
a798dbf2
MB
322}
323
6e90668e
SM
324sub padname_sv {
325 my $self = shift;
326 my $targ = shift;
327 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
328}
329
330sub maybe_my {
331 my $self = shift;
332 my($op, $text) = @_;
333 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
334 return "my(" . $text . ")";
335 } else {
336 return $text;
337 }
338}
339
340sub pp_enter {cluck "unexpected OP_ENTER"; ""} # see also leave
341
342# leave, scope, and lineseq should probably share code
a798dbf2 343sub pp_leave {
6e90668e
SM
344 my $self = shift;
345 my $op = shift;
346 my ($kid, $expr);
347 my @exprs;
348 local($self->{'curstash'}) = $self->{'curstash'};
349 $kid = $op->first->sibling; # skip enter
350 if (is_miniwhile($kid)) {
351 my $top = $kid->first;
352 my $name = $top->ppaddr;
353 if ($name eq "pp_and") {
354 $name = "while";
355 } elsif ($name eq "pp_or") {
356 $name = "until";
357 } else { # no conditional -> while 1 or until 0
358 return $self->deparse($top->first) . " while 1";
359 }
360 my $cond = $top->first;
361 my $body = $cond->sibling;
362 $cond = $self->deparse($cond);
363 $body = $self->deparse($body);
364 return "$body $name $cond";
365 }
366 for (; !null($kid); $kid = $kid->sibling) {
367 $expr = "";
368 if (is_state $kid) {
369 $expr = $self->deparse($kid);
370 $kid = $kid->sibling;
371 last if null $kid;
372 }
373 $expr .= $self->deparse($kid);
374 if (is_scope($kid) and not is_miniwhile($kid->first->sibling)) {
375 $expr = "do {$expr}";
376 }
377 push @exprs, $expr if $expr;
378 }
379 return join(";\n", @exprs);
380}
381
382sub pp_scope {
383 my $self = shift;
384 my $op = shift;
385 my ($kid, $expr);
386 my @exprs;
387 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
388 $expr = "";
389 if (is_state $kid) {
390 $expr = $self->deparse($kid);
391 $kid = $kid->sibling;
392 last if null $kid;
393 }
394 $expr .= $self->deparse($kid);
395 if (is_scope($kid)) {
396 $expr = "do {$expr}";
397 }
398 push @exprs, $expr if $expr;
399 }
400 return join("; ", @exprs);
401}
402
403sub pp_lineseq {
404 my $self = shift;
a798dbf2 405 my $op = shift;
6e90668e
SM
406 my ($kid, $expr);
407 my @exprs;
408 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
409 $expr = "";
410 if (is_state $kid) {
411 $expr = $self->deparse($kid);
412 $kid = $kid->sibling;
413 last if null $kid;
414 }
415 $expr .= $self->deparse($kid);
416 if (is_scope($kid) and not is_miniwhile($kid->first->sibling)) {
417 $expr = "do {$expr}";
418 }
419 push @exprs, $expr if $expr;
420 }
421 return join(";\n", @exprs);
422}
423
424# The BEGIN {} is used here because otherwise this code isn't executed
425# when you run B::Deparse on itself.
426my %globalnames;
427BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
428 "ENV", "ARGV", "ARGVOUT", "_"); }
429
430sub gv_name {
431 my $self = shift;
432 my $gv = shift;
433 my $stash = $gv->STASH->NAME;
434 my $name = $gv->NAME;
435 if ($stash eq $self->{'curstash'} or $globalnames{$name}) {
436 $stash = "";
437 } else {
438 $stash = $stash . "::";
a798dbf2 439 }
6e90668e
SM
440 if ($name =~ /^([\cA-\cZ])$/) {
441 $name = "^" . chr(64 + ord($1));
442 }
443 return $stash . $name;
a798dbf2
MB
444}
445
6e90668e
SM
446# Notice how subs and formats are inserted between statements here
447sub pp_nextstate {
448 my $self = shift;
449 my $op = shift;
450 my @text;
451 @text = $op->label . ": " if $op->label;
452 my $seq = $op->cop_seq;
453 while (scalar(@{$self->{'subs_todo'}})
454 and $seq > $self->{'subs_todo'}[0][0]) {
455 push @text, $self->next_todo;
456 }
457 my $stash = $op->stash->NAME;
458 if ($stash ne $self->{'curstash'}) {
459 push @text, "package $stash;\n";
460 $self->{'curstash'} = $stash;
461 }
462 return join("", @text);
463}
464
465sub pp_dbstate { pp_nextstate(@_) }
466
467sub pp_unstack { return "" } # see also leaveloop
468
469sub baseop {
470 my $self = shift;
471 my($op, $name) = @_;
472 return $name;
473}
474
475sub pp_stub { baseop(@_, "()") }
476sub pp_wantarray { baseop(@_, "wantarray") }
477sub pp_fork { baseop(@_, "fork") }
478sub pp_wait { baseop(@_, "wait") }
479sub pp_getppid { baseop(@_, "getppid") }
480sub pp_time { baseop(@_, "time") }
481sub pp_tms { baseop(@_, "times") }
482sub pp_ghostent { baseop(@_, "gethostent") }
483sub pp_gnetent { baseop(@_, "getnetent") }
484sub pp_gprotoent { baseop(@_, "getprotoent") }
485sub pp_gservent { baseop(@_, "getservent") }
486sub pp_ehostent { baseop(@_, "endhostent") }
487sub pp_enetent { baseop(@_, "endnetent") }
488sub pp_eprotoent { baseop(@_, "endprotoent") }
489sub pp_eservent { baseop(@_, "endservent") }
490sub pp_gpwent { baseop(@_, "getpwent") }
491sub pp_spwent { baseop(@_, "setpwent") }
492sub pp_epwent { baseop(@_, "endpwent") }
493sub pp_ggrent { baseop(@_, "getgrent") }
494sub pp_sgrent { baseop(@_, "setgrent") }
495sub pp_egrent { baseop(@_, "endgrent") }
496sub pp_getlogin { baseop(@_, "getlogin") }
497
498sub POSTFIX () { 1 }
499
500sub OPf_SPECIAL () { 128 }
501
502sub unop {
503 my $self = shift;
504 my($op, $name, $flags) = (@_, 0);
505 my $kid;
506 if (class($op) eq "UNOP") {
507 $kid = $op->first;
508 $kid = "(" . $self->deparse($kid) . ")";
509 } else {
510 $kid = ($op->flags & OPf_SPECIAL ? "()" : "");
511 }
512 return ($flags & POSTFIX) ? "$kid$name" : "$name$kid";
513}
514
515sub pp_preinc { unop(@_, "++") }
516sub pp_predec { unop(@_, "--") }
517sub pp_postinc { unop(@_, "++", POSTFIX) }
518sub pp_postdec { unop(@_, "--", POSTFIX) }
519sub pp_i_preinc { unop(@_, "++") }
520sub pp_i_predec { unop(@_, "--") }
521sub pp_i_postinc { unop(@_, "++", POSTFIX) }
522sub pp_i_postdec { unop(@_, "--", POSTFIX) }
523sub pp_negate { unop(@_, "-") }
524sub pp_i_negate { unop(@_, "-") }
525sub pp_not { unop(@_, "!") }
526sub pp_complement { unop(@_, "~") }
527
528sub pp_chop { unop(@_, "chop") }
529sub pp_chomp { unop(@_, "chomp") }
530sub pp_schop { unop(@_, "chop") }
531sub pp_schomp { unop(@_, "chomp") }
532sub pp_defined { unop(@_, "defined") }
533sub pp_undef { unop(@_, "undef") }
534sub pp_study { unop(@_, "study") }
535sub pp_scalar { unop(@_, "scalar") }
536sub pp_ref { unop(@_, "ref") }
537sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
538
539sub pp_sin { unop(@_, "sin") }
540sub pp_cos { unop(@_, "cos") }
541sub pp_rand { unop(@_, "rand") }
542sub pp_srand { unop(@_, "srand") }
543sub pp_exp { unop(@_, "exp") }
544sub pp_log { unop(@_, "log") }
545sub pp_sqrt { unop(@_, "sqrt") }
546sub pp_int { unop(@_, "int") }
547sub pp_hex { unop(@_, "hex") }
548sub pp_oct { unop(@_, "oct") }
549sub pp_abs { unop(@_, "abs") }
550
551sub pp_length { unop(@_, "length") }
552sub pp_ord { unop(@_, "ord") }
553sub pp_chr { unop(@_, "chr") }
554sub pp_ucfirst { unop(@_, "ucfirst") }
555sub pp_lcfirst { unop(@_, "lcfirst") }
556sub pp_uc { unop(@_, "uc") }
557sub pp_lc { unop(@_, "lc") }
558sub pp_quotemeta { unop(@_, "quotemeta") }
559
560sub pp_each { unop(@_, "each") }
561sub pp_values { unop(@_, "values") }
562sub pp_keys { unop(@_, "keys") }
563sub pp_pop { unop(@_, "pop") }
564sub pp_shift { unop(@_, "shift") }
565
566sub pp_caller { unop(@_, "caller") }
567sub pp_reset { unop(@_, "reset") }
568sub pp_exit { unop(@_, "exit") }
569sub pp_prototype { unop(@_, "prototype") }
570
571sub pp_close { unop(@_, "close") }
572sub pp_fileno { unop(@_, "fileno") }
573sub pp_umask { unop(@_, "umask") }
574sub pp_binmode { unop(@_, "binmode") }
575sub pp_untie { unop(@_, "untie") }
576sub pp_tied { unop(@_, "tied") }
577sub pp_dbmclose { unop(@_, "dbmclose") }
578sub pp_getc { unop(@_, "getc") }
579sub pp_eof { unop(@_, "eof") }
580sub pp_tell { unop(@_, "tell") }
581sub pp_getsockname { unop(@_, "getsockname") }
582sub pp_getpeername { unop(@_, "getpeername") }
583
584sub pp_chdir { unop(@_, "chdir") }
585sub pp_chroot { unop(@_, "chroot") }
586sub pp_readlink { unop(@_, "readlink") }
587sub pp_rmdir { unop(@_, "rmdir") }
588sub pp_readdir { unop(@_, "readdir") }
589sub pp_telldir { unop(@_, "telldir") }
590sub pp_rewinddir { unop(@_, "rewinddir") }
591sub pp_closedir { unop(@_, "closedir") }
592sub pp_getpgrp { unop(@_, "getpgrp") }
593sub pp_localtime { unop(@_, "localtime") }
594sub pp_gmtime { unop(@_, "gmtime") }
595sub pp_alarm { unop(@_, "alarm") }
596sub pp_sleep { unop(@_, "sleep") }
597
598sub pp_dofile { unop(@_, "do") }
599sub pp_entereval { unop(@_, "eval") }
600
601sub pp_ghbyname { unop(@_, "gethostbyname") }
602sub pp_gnbyname { unop(@_, "getnetbyname") }
603sub pp_gpbyname { unop(@_, "getprotobyname") }
604sub pp_shostent { unop(@_, "sethostent") }
605sub pp_snetent { unop(@_, "setnetent") }
606sub pp_sprotoent { unop(@_, "setprotoent") }
607sub pp_sservent { unop(@_, "setservent") }
608sub pp_gpwnam { unop(@_, "getpwnam") }
609sub pp_gpwuid { unop(@_, "getpwuid") }
610sub pp_ggrnam { unop(@_, "getgrnam") }
611sub pp_ggrgid { unop(@_, "getgrgid") }
612
613sub pp_lock { unop(@_, "lock") }
614
615sub pp_exists {
616 my $self = shift;
617 my $op = shift;
618 return "exists(" . $self->pp_helem($op->first) . ")";
619}
620
621sub OPpSLICE () { 64 }
622
623sub pp_delete {
624 my $self = shift;
625 my $op = shift;
626 my $arg;
627 if ($op->private & OPpSLICE) {
628 $arg = $self->pp_hslice($op->first);
629 } else {
630 $arg = $self->pp_helem($op->first);
631 }
632 return "delete($arg)";
633}
634
635sub OPp_CONST_BARE () { 64 }
636
637sub pp_require {
638 my $self = shift;
639 my $op = shift;
640 if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
641 and $op->first->private & OPp_CONST_BARE)
642 {
643 my $name = $op->first->sv->PV;
644 $name =~ s[/][::]g;
645 $name =~ s/\.pm//g;
646 return "require($name)";
647 } else {
648 $self->unop($op, "require");
649 }
650}
651
652sub padval {
653 my $self = shift;
654 my $targ = shift;
655 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
656}
657
658sub pp_refgen {
659 my $self = shift;
660 my $op = shift;
661 my $kid = $op->first;
662 if ($kid->ppaddr eq "pp_null") {
663 $kid = $kid->first;
664 if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
665 my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
666 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
667 my($expr, @exprs);
668 $kid = $kid->first->sibling; # skip pushmark
669 for (; !null($kid); $kid = $kid->sibling) {
670 $expr = $self->deparse($kid);
671 push @exprs, $expr;
672 }
673 return $pre . join(", ", @exprs) . $post;
674 } elsif (!null($kid->sibling) and
675 $kid->sibling->ppaddr eq "pp_anoncode") {
676 return "sub " .
677 $self->deparse_sub($self->padval($kid->sibling->targ));
678 }
679 }
680 $self->unop($op, "\\");
681}
682
683sub pp_srefgen { pp_refgen(@_) }
684
685sub pp_readline {
686 my $self = shift;
687 my $op = shift;
688 my $kid = $op->first;
689 $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
690 if ($kid->ppaddr eq "pp_rv2gv") {
691 $kid = $kid->first;
692 }
693 return "<" . $self->deparse($kid) . ">";
694}
695
696sub loopex {
697 my $self = shift;
698 my ($op, $name) = @_;
699 my $kid;
700 if (class($op) eq "PVOP") {
701 $kid = " " . $op->pv;
702 } elsif (class($op) eq "BASEOP") {
703 $kid = "";
704 } elsif (class($op) eq "UNOP") {
705 $kid = "(" . $self->deparse($op->first) . ")";
706 }
707 return "$name$kid";
708}
709
710sub pp_last { loopex(@_, "last") }
711sub pp_next { loopex(@_, "next") }
712sub pp_redo { loopex(@_, "redo") }
713sub pp_goto { loopex(@_, "goto") }
714sub pp_dump { loopex(@_, "dump") }
715
716sub ftst {
717 my $self = shift;
718 my($op, $name) = @_;
719 my $kid;
720 if (class($op) eq "UNOP") {
721 $kid = $op->first;
722 $kid = "(" . $self->deparse($kid) . ")";
723 } elsif (class($op) eq "GVOP") {
724 $kid = "(" . $self->pp_gv($op) . ")";
725 } else { # I don't think baseop filetests ever survive ck_ftst, but...
726 $kid = "";
727 }
728 return "$name$kid";
729}
730
731sub pp_lstat { ftst(@_, "lstat") }
732sub pp_stat { ftst(@_, "stat") }
733sub pp_ftrread { ftst(@_, "-R") }
734sub pp_ftrwrite { ftst(@_, "-W") }
735sub pp_ftrexec { ftst(@_, "-X") }
736sub pp_fteread { ftst(@_, "-r") }
737sub pp_ftewrite { ftst(@_, "-r") }
738sub pp_fteexec { ftst(@_, "-r") }
739sub pp_ftis { ftst(@_, "-e") }
740sub pp_fteowned { ftst(@_, "-O") }
741sub pp_ftrowned { ftst(@_, "-o") }
742sub pp_ftzero { ftst(@_, "-z") }
743sub pp_ftsize { ftst(@_, "-s") }
744sub pp_ftmtime { ftst(@_, "-M") }
745sub pp_ftatime { ftst(@_, "-A") }
746sub pp_ftctime { ftst(@_, "-C") }
747sub pp_ftsock { ftst(@_, "-S") }
748sub pp_ftchr { ftst(@_, "-c") }
749sub pp_ftblk { ftst(@_, "-b") }
750sub pp_ftfile { ftst(@_, "-f") }
751sub pp_ftdir { ftst(@_, "-d") }
752sub pp_ftpipe { ftst(@_, "-p") }
753sub pp_ftlink { ftst(@_, "-l") }
754sub pp_ftsuid { ftst(@_, "-u") }
755sub pp_ftsgid { ftst(@_, "-g") }
756sub pp_ftsvtx { ftst(@_, "-k") }
757sub pp_fttty { ftst(@_, "-t") }
758sub pp_fttext { ftst(@_, "-T") }
759sub pp_ftbinary { ftst(@_, "-B") }
760
a798dbf2 761sub SWAP_CHILDREN () { 1 }
6e90668e
SM
762sub ASSIGN () { 2 } # has OP= variant
763
764sub OPf_STACKED () { 64 }
a798dbf2
MB
765
766sub binop {
6e90668e
SM
767 my $self = shift;
768 my ($op, $opname, $flags) = (@_, 0);
a798dbf2
MB
769 my $left = $op->first;
770 my $right = $op->last;
6e90668e 771 my $eq = ($op->flags & OPf_STACKED && $flags & ASSIGN) ? "=" : "";
a798dbf2
MB
772 if ($flags & SWAP_CHILDREN) {
773 ($left, $right) = ($right, $left);
774 }
6e90668e
SM
775 $left = $self->deparse($left);
776 $right = $self->deparse($right);
777 return "($left $opname$eq $right)";
778}
779
780sub pp_add { binop(@_, "+", ASSIGN) }
781sub pp_multiply { binop(@_, "*", ASSIGN) }
782sub pp_subtract { binop(@_, "-", ASSIGN) }
783sub pp_divide { binop(@_, "/", ASSIGN) }
784sub pp_modulo { binop(@_, "%", ASSIGN) }
785sub pp_i_add { binop(@_, "+", ASSIGN) }
786sub pp_i_multiply { binop(@_, "*", ASSIGN) }
787sub pp_i_subtract { binop(@_, "-", ASSIGN) }
788sub pp_i_divide { binop(@_, "/", ASSIGN) }
789sub pp_i_modulo { binop(@_, "%", ASSIGN) }
790sub pp_pow { binop(@_, "**", ASSIGN) }
791
792sub pp_left_shift { binop(@_, "<<", ASSIGN) }
793sub pp_right_shift { binop(@_, ">>", ASSIGN) }
794sub pp_bit_and { binop(@_, "&", ASSIGN) }
795sub pp_bit_or { binop(@_, "|", ASSIGN) }
796sub pp_bit_xor { binop(@_, "^", ASSIGN) }
797
798sub pp_eq { binop(@_, "==") }
799sub pp_ne { binop(@_, "!=") }
800sub pp_lt { binop(@_, "<") }
801sub pp_gt { binop(@_, ">") }
802sub pp_ge { binop(@_, ">=") }
803sub pp_le { binop(@_, "<=") }
804sub pp_ncmp { binop(@_, "<=>") }
805sub pp_i_eq { binop(@_, "==") }
806sub pp_i_ne { binop(@_, "!=") }
807sub pp_i_lt { binop(@_, "<") }
808sub pp_i_gt { binop(@_, ">") }
809sub pp_i_ge { binop(@_, ">=") }
810sub pp_i_le { binop(@_, "<=") }
811sub pp_i_ncmp { binop(@_, "<=>") }
812
813sub pp_seq { binop(@_, "eq") }
814sub pp_sne { binop(@_, "ne") }
815sub pp_slt { binop(@_, "lt") }
816sub pp_sgt { binop(@_, "gt") }
817sub pp_sge { binop(@_, "ge") }
818sub pp_sle { binop(@_, "le") }
819sub pp_scmp { binop(@_, "cmp") }
820
821sub pp_sassign { binop(@_, "=", SWAP_CHILDREN) }
822sub pp_aassign { binop(@_, "=", SWAP_CHILDREN) }
823
824# `.' is special because concats-of-concats are optimized to save copying
825# by making all but the first concat stacked. The effect is as if the
826# programmer had written `($a . $b) .= $c', except legal.
827sub pp_concat {
828 my $self = shift;
829 my $op = shift;
830 my $left = $op->first;
831 my $right = $op->last;
832 my $eq = "";
833 if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
834 $eq = "=";
835 }
836 $left = $self->deparse($left);
837 $right = $self->deparse($right);
838 return "($left .$eq $right)";
839}
840
841# `x' is weird when the left arg is a list
842sub pp_repeat {
843 my $self = shift;
844 my $op = shift;
845 my $left = $op->first;
846 my $right = $op->last;
847 my $eq = ($op->flags & OPf_STACKED) ? "=" : "";
848 if (null($right)) { # list repeat; count is inside left-side ex-list
849 my $kid = $left->first->sibling; # skip pushmark
850 my @exprs;
851 for (; !null($kid->sibling); $kid = $kid->sibling) {
852 push @exprs, $self->deparse($kid);
853 }
854 $right = $kid;
855 $left = "(" . join(", ", @exprs). ")";
856 } else {
857 $left = $self->deparse($left);
858 }
859 $right = $self->deparse($right);
860 return "($left x$eq $right)";
861}
862
863sub range {
864 my $self = shift;
865 my ($op, $type) = @_;
866 my $left = $op->first;
867 my $right = $left->sibling;
868 $left = $self->deparse($left);
869 $right = $self->deparse($right);
870 return "($left " . $type . " $right)";
871}
872
873sub pp_flop {
874 my $self = shift;
875 my $op = shift;
876 my $flip = $op->first;
877 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
878 return $self->range($flip->first, $type);
879}
880
881# one-line while/until is handled in pp_leave
882
883sub logop {
884 my $self = shift;
885 my ($op, $opname, $blockname) = @_;
886 my $left = $op->first;
887 my $right = $op->first->sibling;
888 $left = $self->deparse($left);
889 my $scope = is_scope($right);
890 $right = $self->deparse($right);
891 if ($scope) {
892 return "$blockname ($left) {\n\t$right\n\b}";
893 } else {
894 return "($left $opname $right)";
895 }
896}
897
898sub pp_and { logop(@_, "&&", "if") }
899sub pp_or { logop(@_, "||", "unless") }
900sub pp_xor { logop(@_, "xor", "n/a") }
901
902sub logassignop {
903 my $self = shift;
904 my ($op, $opname) = @_;
905 my $left = $op->first;
906 my $right = $op->first->sibling->first; # skip sassign
907 $left = $self->deparse($left);
908 $right = $self->deparse($right);
a798dbf2
MB
909 return "($left $opname $right)";
910}
911
6e90668e
SM
912sub pp_andassign { logassignop(@_, "&&=") }
913sub pp_orassign { logassignop(@_, "||=") }
914
915sub listop {
916 my $self = shift;
917 my($op, $name) = @_;
918 my($kid, $expr, @exprs);
919 for ($kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
920 $expr = $self->deparse($kid);
921 push @exprs, $expr;
922 }
923 return "$name(" . join(", ", @exprs) . ")";
924}
a798dbf2 925
6e90668e
SM
926sub pp_bless { listop(@_, "bless") }
927sub pp_atan2 { listop(@_, "atan2") }
928sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
929sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
930sub pp_index { listop(@_, "index") }
931sub pp_rindex { listop(@_, "rindex") }
932sub pp_sprintf { listop(@_, "sprintf") }
933sub pp_formline { listop(@_, "formline") } # see also deparse_format
934sub pp_crypt { listop(@_, "crypt") }
935sub pp_unpack { listop(@_, "unpack") }
936sub pp_pack { listop(@_, "pack") }
937sub pp_join { listop(@_, "join") }
938sub pp_splice { listop(@_, "splice") }
939sub pp_push { listop(@_, "push") }
940sub pp_unshift { listop(@_, "unshift") }
941sub pp_reverse { listop(@_, "reverse") }
942sub pp_warn { listop(@_, "warn") }
943sub pp_die { listop(@_, "die") }
944sub pp_return { listop(@_, "return") }
945sub pp_open { listop(@_, "open") }
946sub pp_pipe_op { listop(@_, "pipe") }
947sub pp_tie { listop(@_, "tie") }
948sub pp_dbmopen { listop(@_, "dbmopen") }
949sub pp_sselect { listop(@_, "select") }
950sub pp_select { listop(@_, "select") }
951sub pp_read { listop(@_, "read") }
952sub pp_sysopen { listop(@_, "sysopen") }
953sub pp_sysseek { listop(@_, "sysseek") }
954sub pp_sysread { listop(@_, "sysread") }
955sub pp_syswrite { listop(@_, "syswrite") }
956sub pp_send { listop(@_, "send") }
957sub pp_recv { listop(@_, "recv") }
958sub pp_seek { listop(@_, "seek") }
959sub pp_truncate { listop(@_, "truncate") }
960sub pp_fcntl { listop(@_, "fcntl") }
961sub pp_ioctl { listop(@_, "ioctl") }
962sub pp_flock { listop(@_, "flock") }
963sub pp_socket { listop(@_, "socket") }
964sub pp_sockpair { listop(@_, "sockpair") }
965sub pp_bind { listop(@_, "bind") }
966sub pp_connect { listop(@_, "connect") }
967sub pp_listen { listop(@_, "listen") }
968sub pp_accept { listop(@_, "accept") }
969sub pp_shutdown { listop(@_, "shutdown") }
970sub pp_gsockopt { listop(@_, "getsockopt") }
971sub pp_ssockopt { listop(@_, "setsockopt") }
972sub pp_chown { listop(@_, "chown") }
973sub pp_unlink { listop(@_, "unlink") }
974sub pp_chmod { listop(@_, "chmod") }
975sub pp_utime { listop(@_, "utime") }
976sub pp_rename { listop(@_, "rename") }
977sub pp_link { listop(@_, "link") }
978sub pp_symlink { listop(@_, "symlink") }
979sub pp_mkdir { listop(@_, "mkdir") }
980sub pp_open_dir { listop(@_, "opendir") }
981sub pp_seekdir { listop(@_, "seekdir") }
982sub pp_waitpid { listop(@_, "waitpid") }
983sub pp_system { listop(@_, "system") }
984sub pp_exec { listop(@_, "exec") }
985sub pp_kill { listop(@_, "kill") }
986sub pp_setpgrp { listop(@_, "setpgrp") }
987sub pp_getpriority { listop(@_, "getpriority") }
988sub pp_setpriority { listop(@_, "setpriority") }
989sub pp_shmget { listop(@_, "shmget") }
990sub pp_shmctl { listop(@_, "shmctl") }
991sub pp_shmread { listop(@_, "shmread") }
992sub pp_shmwrite { listop(@_, "shmwrite") }
993sub pp_msgget { listop(@_, "msgget") }
994sub pp_msgctl { listop(@_, "msgctl") }
995sub pp_msgsnd { listop(@_, "msgsnd") }
996sub pp_msgrcv { listop(@_, "msgrcv") }
997sub pp_semget { listop(@_, "semget") }
998sub pp_semctl { listop(@_, "semctl") }
999sub pp_semop { listop(@_, "semop") }
1000sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1001sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1002sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1003sub pp_gsbyname { listop(@_, "getservbyname") }
1004sub pp_gsbyport { listop(@_, "getservbyport") }
1005sub pp_syscall { listop(@_, "syscall") }
1006
1007sub pp_glob {
1008 my $self = shift;
1009 my $op = shift;
1010 my $text = $self->dq($op->first->sibling); # skip pushmark
1011 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1012 or $text =~ /[<>]/) {
1013 return 'glob(' . single_delim('qq', '"', $text) . ')';
1014 } else {
1015 return '<' . $text . '>';
1016 }
1017}
1018
1019sub indirop {
1020 my $self = shift;
1021 my($op, $name) = (@_, 0);
1022 my($expr, @exprs);
1023 my $kid = $op->first->sibling;
1024 my $indir = "";
1025 if ($op->flags & OPf_STACKED) {
1026 $indir = $kid;
1027 $indir = $indir->first; # skip rv2gv
1028 if (is_scope($indir)) {
1029 $indir = "{" . $self->deparse($indir) . "}";
1030 } else {
1031 $indir = $self->deparse($indir);
1032 }
1033 $indir = $indir . " ";
1034 $kid = $kid->sibling;
1035 }
1036 for (; !null($kid); $kid = $kid->sibling) {
1037 $expr = $self->deparse($kid);
1038 push @exprs, $expr;
1039 }
1040 return "$name($indir" . join(", ", @exprs) . ")";
1041}
1042
1043sub pp_prtf { indirop(@_, "printf") }
1044sub pp_print { indirop(@_, "print") }
1045sub pp_sort { indirop(@_, "sort") }
1046
1047sub mapop {
1048 my $self = shift;
1049 my($op, $name) = @_;
1050 my($expr, @exprs);
1051 my $kid = $op->first; # this is the (map|grep)start
1052 $kid = $kid->first->sibling; # skip a pushmark
1053 my $code = $kid->first; # skip a null
1054 if (is_scope $code) {
1055 $code = "{" . $self->deparse($code) . "} ";
1056 } else {
1057 $code = $self->deparse($code) . ", ";
1058 }
1059 $kid = $kid->sibling;
1060 for (; !null($kid); $kid = $kid->sibling) {
1061 $expr = $self->deparse($kid);
1062 push @exprs, $expr if $expr;
1063 }
1064 return "$name($code" . join(", ", @exprs) . ")";
1065}
1066
1067sub pp_mapwhile { mapop(@_, "map") }
1068sub pp_grepwhile { mapop(@_, "grep") }
1069
1070sub pp_list {
1071 my $self = shift;
1072 my $op = shift;
1073 my($expr, @exprs);
1074 my $kid = $op->first->sibling; # skip pushmark
1075 my $lop;
1076 my $local = "either"; # could be local(...) or my(...)
1077 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1078 # This assumes that no other private flags equal 128, and that
1079 # OPs that store things other than flags in their op_private,
1080 # like OP_AELEMFAST, won't be immediate children of a list.
1081 unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
1082 {
1083 $local = ""; # or not
1084 last;
1085 }
1086 if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1087 ($local = "", last) if $local eq "local";
1088 $local = "my";
1089 } elsif ($lop->ppaddr ne "pp_undef") { # local()
1090 ($local = "", last) if $local eq "my";
1091 $local = "local";
1092 }
1093 }
1094 $local = "" if $local eq "either"; # no point if it's all undefs
1095 for (; !null($kid); $kid = $kid->sibling) {
1096 if ($local) {
1097 if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1098 $lop = $kid->first;
1099 } else {
1100 $lop = $kid;
1101 }
1102 $self->{'avoid_local'}{$$lop}++;
1103 $expr = $self->deparse($kid);
1104 delete $self->{'avoid_local'}{$$lop};
1105 } else {
1106 $expr = $self->deparse($kid);
1107 }
1108 push @exprs, $expr;
1109 }
1110 return "$local(" . join(", ", @exprs) . ")";
1111}
1112
1113sub pp_cond_expr {
1114 my $self = shift;
1115 my $op = shift;
1116 my $cond = $op->first;
1117 my $true = $cond->sibling;
1118 my $false = $true->sibling;
1119 my $braces = 0;
1120 $cond = $self->deparse($cond);
1121 $braces = 1 if is_scope($true) or is_scope($false);
1122 $true = $self->deparse($true);
1123 if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1124 my $head = "if ($cond) {\n\t$true\n\b}";
1125 my @elsifs;
1126 while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1127 my $newop = $false->first->sibling->first;
1128 my $newcond = $newop->first;
1129 my $newtrue = $newcond->sibling;
1130 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1131 $newcond = $self->deparse($newcond);
1132 $newtrue = $self->deparse($newtrue);
1133 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1134 }
1135 if (!null($false)) {
1136 $false = "\nelse {\n\t" . $self->deparse($false) . "\n\b}";
1137 } else {
1138 $false = "";
1139 }
1140 return $head . join("\n", "", @elsifs) . $false;
1141 }
1142 $false = $self->deparse($false);
1143 if ($braces) {
1144 return "if ($cond) {\n\t$true\n\b}\nelse {\n\t$false\n\b}";
1145 } else {
1146 return "($cond ? $true : $false)";
1147 }
1148}
1149
1150sub pp_leaveloop {
1151 my $self = shift;
1152 my $op = shift;
1153 my $enter = $op->first;
1154 my $kid = $enter->sibling;
1155 local($self->{'curstash'}) = $self->{'curstash'};
1156 my $head = "";
1157 if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1158 if (is_state $kid->last) { # infinite
1159 $head = "for (;;) "; # shorter than while (1)
1160 }
1161 } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1162 my $ary = $enter->first->sibling; # first was pushmark
1163 my $var = $ary->sibling;
1164 $ary = $self->deparse($ary);
1165 if (null $var) {
f6f9bdb7
SM
1166 if ($enter->flags & OPf_SPECIAL) { # thread special var
1167 $var = $self->pp_threadsv($enter);
1168 } else { # regular my() variable
1169 $var = $self->pp_padsv($enter);
1170 if ($self->padname_sv($enter->targ)->IVX ==
1171 $kid->first->first->sibling->last->cop_seq)
1172 {
1173 # If the scope of this variable closes at the last
1174 # statement of the loop, it must have been
1175 # declared here.
1176 $var = "my " . $var;
1177 }
6e90668e
SM
1178 }
1179 } elsif ($var->ppaddr eq "pp_rv2gv") {
1180 $var = $self->pp_rv2sv($var);
1181 } elsif ($var->ppaddr eq "pp_gv") {
1182 $var = "\$" . $self->deparse($var);
1183 }
1184 $head = "foreach $var $ary ";
1185 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1186 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1187 $kid = $kid->first;
1188 my $name = {"pp_and" => "while", "pp_or" => "until"}
1189 ->{$kid->ppaddr};
1190 $head = "$name (" . $self->deparse($kid->first) . ") ";
1191 $kid = $kid->first->sibling;
1192 }
1193 # The third-to-last kid is the continue block if the pointer used
1194 # by `next BLOCK' points to its nulled-out nextstate, which is its
1195 # first or second kid depending on whether the block was optimized
1196 # to a OP_SCOPE.
1197 my $cont = $kid;
1198 unless ($kid->ppaddr eq "pp_stub") { # empty bare loop
1199 $cont = $kid->first;
1200 unless (null $cont->sibling->sibling) {
1201 while (!null($cont->sibling->sibling->sibling)) {
1202 $cont = $cont->sibling;
1203 }
1204 }
1205 }
1206 if (is_scope($cont)
1207 and $ {$enter->nextop} == $ {$cont->first}
1208 || $ {$enter->nextop} == $ {$cont->first->sibling})
1209 {
1210 my $state = $kid->first;
1211 my($expr, @exprs);
1212 for (; $$state != $$cont; $state = $state->sibling) {
1213 $expr = "";
1214 if (is_state $state) {
1215 $expr = $self->deparse($state);
1216 $state = $state->sibling;
1217 last if null $kid;
1218 }
1219 $expr .= $self->deparse($state);
1220 push @exprs, $expr if $expr;
1221 }
1222 $kid = join(";\n", @exprs);
1223 $cont = " continue {\n\t" . $self->deparse($cont) . "\n\b}\n";
1224 } else {
1225 $cont = "";
1226 $kid = $self->deparse($kid);
1227 }
1228 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1229}
1230
1231sub pp_leavetry {
1232 my $self = shift;
1233 return "eval {\n\t" . $self->pp_leave($_[0]) . "\n\b}";
1234}
1235
1236sub OP_CONST () { 5 }
1237sub OP_STRINGIFY () { 65 }
a798dbf2
MB
1238
1239sub pp_null {
6e90668e 1240 my $self = shift;
a798dbf2 1241 my $op = shift;
6e90668e
SM
1242 if (class($op) eq "OP") {
1243 return "'???'" if $op->targ == OP_CONST; # old value is lost
1244 } elsif ($op->first->ppaddr eq "pp_pushmark") {
1245 return $self->pp_list($op);
1246 } elsif ($op->first->ppaddr eq "pp_enter") {
1247 return $self->pp_leave($op);
1248 } elsif ($op->targ == OP_STRINGIFY) {
1249 return $self->dquote($op);
1250 } elsif (!null($op->first->sibling) and
1251 $op->first->sibling->ppaddr eq "pp_readline" and
1252 $op->first->sibling->flags & OPf_STACKED) {
1253 return "(" . $self->deparse($op->first) . " = "
1254 . $self->deparse($op->first->sibling) . ")";
1255 } elsif (!null($op->first->sibling) and
1256 $op->first->sibling->ppaddr eq "pp_trans" and
1257 $op->first->sibling->flags & OPf_STACKED) {
1258 return "(" . $self->deparse($op->first) . " =~ "
1259 . $self->deparse($op->first->sibling) . ")";
1260 } else {
1261 return $self->deparse($op->first);
1262 }
a798dbf2
MB
1263}
1264
6e90668e
SM
1265sub padname {
1266 my $self = shift;
1267 my $targ = shift;
1268 my $str = $self->padname_sv($targ)->PV;
1269 return padname_fix($str);
1270}
1271
1272sub padany {
1273 my $self = shift;
1274 my $op = shift;
1275 return substr($self->padname($op->targ), 1); # skip $/@/%
1276}
1277
1278sub pp_padsv {
1279 my $self = shift;
1280 my $op = shift;
1281 return $self->maybe_my($op, $self->padname($op->targ));
1282}
1283
1284sub pp_padav { pp_padsv(@_) }
1285sub pp_padhv { pp_padsv(@_) }
1286
f6f9bdb7
SM
1287my @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1288 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1289 "^", "-", "%", "=", "|", "~", ":", "^A", "^E", "!", "@");
1290
1291sub pp_threadsv {
1292 my $self = shift;
1293 my $op = shift;
1294 return $self->maybe_local($op, "\$" . $threadsv_names[$op->targ]);
1295}
1296
6e90668e
SM
1297sub pp_gvsv {
1298 my $self = shift;
1299 my $op = shift;
1300 return $self->maybe_local($op, "\$" . $self->gv_name($op->gv));
1301}
1302
1303sub pp_gv {
1304 my $self = shift;
1305 my $op = shift;
1306 return $self->gv_name($op->gv);
1307}
1308
1309sub pp_aelemfast {
1310 my $self = shift;
1311 my $op = shift;
1312 my $gv = $op->gv;
1313 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1314}
1315
1316sub rv2x {
1317 my $self = shift;
1318 my($op, $type) = @_;
1319 my $kid = $op->first;
1320 my $scope = is_scope($kid);
1321 $kid = $self->deparse($kid);
1322 return $type . ($scope ? "{$kid}" : $kid);
1323}
1324
1325sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1326sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1327sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1328
1329# skip rv2av
1330sub pp_av2arylen {
1331 my $self = shift;
1332 my $op = shift;
1333 if ($op->first->ppaddr eq "pp_padav") {
1334 return $self->maybe_local($op, '$#' . $self->padany($op->first));
1335 } else {
1336 return $self->maybe_local($op, $self->rv2x($op->first, '$#'));
1337 }
1338}
1339
1340# skip down to the old, ex-rv2cv
1341sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, "&") }
1342
1343sub pp_rv2av {
1344 my $self = shift;
1345 my $op = shift;
1346 my $kid = $op->first;
1347 if ($kid->ppaddr eq "pp_const") { # constant list
1348 my $av = $kid->sv;
1349 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1350 } else {
1351 return $self->maybe_local($op, $self->rv2x($op, "\@"));
1352 }
1353 }
1354
1355
1356sub elem {
1357 my $self = shift;
1358 my ($op, $left, $right, $padname) = @_;
1359 my($array, $idx) = ($op->first, $op->first->sibling);
1360 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1361 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1362 }
1363 if ($array->ppaddr eq $padname) {
1364 $array = $self->padany($array);
1365 } elsif (is_scope($array)) { # ${expr}[0]
1366 $array = "{" . $self->deparse($array) . "}";
1367 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1368 $array = $self->deparse($array);
1369 } else {
1370 # $x[20][3]{hi} or expr->[20]
1371 my $arrow;
1372 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
1373 return $self->deparse($array) . $arrow .
1374 $left . $self->deparse($idx) . $right;
1375 }
1376 $idx = $self->deparse($idx);
1377 return "\$" . $array . $left . $idx . $right;
1378}
1379
1380sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1381sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1382
1383sub pp_gelem {
1384 my $self = shift;
1385 my $op = shift;
1386 my($glob, $part) = ($op->first, $op->last);
1387 $glob = $glob->first; # skip rv2gv
1388 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
1389 my $scope = (is_scope($glob));
1390 $glob = $self->deparse($glob);
1391 $part = $self->deparse($part);
1392 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1393}
1394
1395sub slice {
1396 my $self = shift;
1397 my ($op, $left, $right, $regname, $padname) = @_;
1398 my $last;
1399 my(@elems, $kid, $array, $list);
1400 if (class($op) eq "LISTOP") {
1401 $last = $op->last;
1402 } else { # ex-hslice inside delete()
1403 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1404 $last = $kid;
1405 }
1406 $array = $last;
1407 $array = $array->first
1408 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1409 if (is_scope($array)) {
1410 $array = "{" . $self->deparse($array) . "}";
1411 } elsif ($array->ppaddr eq $padname) {
1412 $array = $self->padany($array);
1413 } else {
1414 $array = $self->deparse($array);
1415 }
1416 $kid = $op->first->sibling; # skip pushmark
1417 if ($kid->ppaddr eq "pp_list") {
1418 $kid = $kid->first->sibling; # skip list, pushmark
1419 for (; !null $kid; $kid = $kid->sibling) {
1420 push @elems, $self->deparse($kid);
1421 }
1422 $list = join(", ", @elems);
1423 } else {
1424 $list = $self->deparse($kid);
1425 }
1426 return "\@" . $array . $left . $list . $right;
1427}
1428
1429sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1430 "pp_rv2av", "pp_padav")) }
1431sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1432 "pp_rv2hv", "pp_padhv")) }
1433
1434sub pp_lslice {
1435 my $self = shift;
1436 my $op = shift;
1437 my $idx = $op->first;
1438 my $list = $op->last;
1439 my(@elems, $kid);
1440 $list = $self->deparse($list); # will always have parens
1441 $idx = $self->deparse($idx);
1442 return $list . "[$idx]";
1443}
1444
1445sub OPpENTERSUB_AMPER () { 8 }
1446
1447sub OPf_WANT () { 3 }
1448sub OPf_WANT_VOID () { 1 }
1449sub OPf_WANT_SCALAR () { 2 }
1450sub OPf_WANT_LIST () { 2 }
1451
1452sub want_scalar {
1453 my $op = shift;
1454 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1455}
1456
1457sub pp_entersub {
1458 my $self = shift;
a798dbf2 1459 my $op = shift;
6e90668e
SM
1460 my $prefix = "";
1461 my $amper = "";
1462 my $proto = undef;
1463 my($kid, $args, @exprs);
1464 if ($op->flags & OPf_SPECIAL) {
1465 $prefix = "do ";
1466 } elsif ($op->private & OPpENTERSUB_AMPER) {
1467 $amper = "&";
1468 }
1469 if (not null $op->first->sibling) {
1470 $kid = $op->first->sibling; # skip pushmark
1471 my $obj = $self->deparse($kid);
1472 $kid = $kid->sibling;
1473 for (; not null $kid->sibling; $kid = $kid->sibling) {
1474 push @exprs, $self->deparse($kid);
1475 }
1476 my $meth = $kid->first;
1477 if ($meth->ppaddr eq "pp_const") {
1478 $meth = $meth->sv->PV; # needs to be bare
1479 } else {
1480 $meth = $self->deparse($meth);
1481 }
1482 $prefix = "";
1483 $args = join(", ", @exprs);
1484 $kid = $obj . "->" . $meth;
1485 } else {
1486 $kid = $op->first;
1487 $kid = $kid->first->sibling; # skip ex-list, pushmark
1488 for (; not null $kid->sibling; $kid = $kid->sibling) {
1489 push @exprs, $kid;
1490 }
1491 if (is_scope($kid)) {
1492 $kid = "{" . $self->deparse($kid) . "}";
1493 } elsif ($kid->first->ppaddr eq "pp_gv") {
1494 my $gv = $kid->first->gv;
1495 if (class($gv->CV) ne "SPECIAL") {
1496 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1497 }
1498 $kid = $self->deparse($kid);
1499 } elsif (is_scalar $kid->first) {
1500 $amper = "&";
1501 $kid = $self->deparse($kid);
1502 } else {
1503 $prefix = "";
1504 $kid = $self->deparse($kid) . "->";
1505 }
1506 if (defined $proto and not $amper) {
1507 my($arg, $real);
1508 my $doneok = 0;
1509 my @args = @exprs;
1510 my @reals;
1511 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1512 while ($proto) {
1513 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
1514 my $chr = $1;
1515 if ($chr eq "") {
1516 undef $proto if @args;
1517 } elsif ($chr eq ";") {
1518 $doneok = 1;
1519 } elsif ($chr eq "@" or $chr eq "%") {
1520 push @reals, map($self->deparse($_), @args);
1521 @args = ();
1522 } else {
1523 $arg = shift @args;
1524 undef $proto, last unless $arg;
1525 if ($chr eq "\$") {
1526 if (want_scalar $arg) {
1527 push @reals, $self->deparse($arg);
1528 } else {
1529 undef $proto;
1530 }
1531 } elsif ($chr eq "&") {
1532 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
1533 push @reals, $self->deparse($arg);
1534 } else {
1535 undef $proto;
1536 }
1537 } elsif ($chr eq "*") {
1538 if ($arg->ppaddr =~ /^pp_s?refgen$/
1539 and $arg->first->first->ppaddr eq "pp_rv2gv")
1540 {
1541 $real = $arg->first->first; # skip refgen, null
1542 if ($real->first->ppaddr eq "pp_gv") {
1543 push @reals, $self->deparse($real);
1544 } else {
1545 push @reals, $self->deparse($real->first);
1546 }
1547 } else {
1548 undef $proto;
1549 }
1550 } elsif (substr($chr, 0, 1) eq "\\") {
1551 $chr = substr($chr, 1);
1552 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
1553 !null($real = $arg->first) and
1554 ($chr eq "\$" && is_scalar($real->first)
1555 or ($chr eq "\@"
1556 && $real->first->sibling->ppaddr
1557 =~ /^pp_(rv2|pad)av$/)
1558 or ($chr eq "%"
1559 && $real->first->sibling->ppaddr
1560 =~ /^pp_(rv2|pad)hv$/)
1561 #or ($chr eq "&" # This doesn't work
1562 # && $real->first->ppaddr eq "pp_rv2cv")
1563 or ($chr eq "*"
1564 && $real->first->ppaddr eq "pp_rv2gv")))
1565 {
1566 push @reals, $self->deparse($real);
1567 } else {
1568 undef $proto;
1569 }
1570 }
1571 }
1572 }
1573 undef $proto if $proto and !$doneok;
1574 undef $proto if @args;
1575 $args = join(", ", @reals);
1576 $amper = "";
1577 unless (defined $proto) {
1578 $amper = "&";
1579 $args = join(", ", map($self->deparse($_), @exprs));
1580 }
1581 } else {
1582 $args = join(", ", map($self->deparse($_), @exprs));
1583 }
1584 }
1585 if ($op->flags & OPf_STACKED) {
1586 return $prefix . $amper . $kid . "(" . $args . ")";
1587 } else {
1588 return $prefix . $amper. $kid;
1589 }
1590}
1591
1592sub pp_enterwrite { unop(@_, "write") }
1593
1594# escape things that cause interpolation in double quotes,
1595# but not character escapes
1596sub uninterp {
1597 my($str) = @_;
1598 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/;
1599 return $str;
1600}
1601
1602# character escapes, but not delimiters that might need to be escaped
1603sub escape_str { # ASCII
1604 my($str) = @_;
1605 $str =~ s/\\/\\\\/g;
1606 $str =~ s/\a/\\a/g;
1607# $str =~ s/\cH/\\b/g; # \b means someting different in a regex
1608 $str =~ s/\t/\\t/g;
1609 $str =~ s/\n/\\n/g;
1610 $str =~ s/\e/\\e/g;
1611 $str =~ s/\f/\\f/g;
1612 $str =~ s/\r/\\r/g;
1613 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
1614 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
1615 return $str;
1616}
1617
1618sub balanced_delim {
1619 my($str) = @_;
1620 my @str = split //, $str;
1621 my($ar, $open, $close, $fail, $c, $cnt);
1622 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
1623 ($open, $close) = @$ar;
1624 $fail = 0; $cnt = 0;
1625 for $c (@str) {
1626 if ($c eq $open) {
1627 $cnt++;
1628 } elsif ($c eq $close) {
1629 $cnt--;
1630 if ($cnt < 0) {
1631 $fail = 1;
1632 last;
1633 }
1634 }
1635 }
1636 $fail = 1 if $cnt != 0;
1637 return ($open, "$open$str$close") if not $fail;
1638 }
1639 return ("", $str);
1640}
1641
1642sub single_delim {
1643 my($q, $default, $str) = @_;
1644 return "$default$str$default" if index($str, $default) == -1;
1645 my($succeed, $delim);
1646 ($succeed, $str) = balanced_delim($str);
1647 return "$q$str" if $succeed;
1648 for $delim ('/', '"', '#') {
1649 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
1650 }
1651 $str =~ s/$default/\\$default/g;
1652 return "$default$str$default";
1653}
1654
1655sub SVf_IOK () {0x10000}
1656sub SVf_NOK () {0x20000}
1657sub SVf_ROK () {0x80000}
1658
1659sub const {
1660 my $sv = shift;
1661 if (class($sv) eq "SPECIAL") {
1662 return ('undef', '1', '+0')[$$sv-1];
1663 } elsif ($sv->FLAGS & SVf_IOK) {
a798dbf2 1664 return $sv->IV;
6e90668e
SM
1665 } elsif ($sv->FLAGS & SVf_NOK) {
1666 return "0.0" unless $sv->NV;
a798dbf2 1667 return $sv->NV;
6e90668e
SM
1668 } elsif ($sv->FLAGS & SVf_ROK) {
1669 return "\\(" . const($sv->RV) . ")"; # constant folded
a798dbf2 1670 } else {
6e90668e
SM
1671 my $str = $sv->PV;
1672 if ($str =~ /[^ -~]/) { # ASCII
1673 return single_delim("qq", '"', uninterp(escape_str($str)));
1674 } else {
1675 $str =~ s/\\/\\\\/g;
1676 return single_delim("q", "'", $str);
1677 }
a798dbf2
MB
1678 }
1679}
1680
6e90668e
SM
1681sub pp_const {
1682 my $self = shift;
a798dbf2 1683 my $op = shift;
6e90668e
SM
1684# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
1685# return $op->sv->PV;
1686# }
1687 return const($op->sv);
1688}
1689
1690sub dq {
1691 my $self = shift;
1692 my $op = shift;
1693 my $type = $op->ppaddr;
1694 if ($type eq "pp_const") {
1695 return uninterp(escape_str($op->sv->PV));
1696 } elsif ($type eq "pp_concat") {
1697 return $self->dq($op->first) . $self->dq($op->last);
1698 } elsif ($type eq "pp_uc") {
1699 return '\U' . $self->dq($op->first->sibling) . '\E';
1700 } elsif ($type eq "pp_lc") {
1701 return '\L' . $self->dq($op->first->sibling) . '\E';
1702 } elsif ($type eq "pp_ucfirst") {
1703 return '\u' . $self->dq($op->first->sibling);
1704 } elsif ($type eq "pp_lcfirst") {
1705 return '\l' . $self->dq($op->first->sibling);
1706 } elsif ($type eq "pp_quotemeta") {
1707 return '\Q' . $self->dq($op->first->sibling) . '\E';
1708 } elsif ($type eq "pp_join") {
1709 return $self->deparse($op->last); # was join($", @ary)
a798dbf2 1710 } else {
6e90668e
SM
1711 return $self->deparse($op);
1712 }
1713}
1714
1715sub pp_backtick {
1716 my $self = shift;
1717 my $op = shift;
1718 # skip pushmark
1719 return single_delim("qx", '`', $self->dq($op->first->sibling));
1720}
1721
1722sub dquote {
1723 my $self = shift;
1724 my $op = shift;
1725 # skip ex-stringify, pushmark
1726 return single_delim("qq", '"', $self->dq($op->first->sibling));
1727}
1728
1729# OP_STRINGIFY is a listop, but it only ever has one arg (?)
1730sub pp_stringify { dquote(@_) }
1731
1732# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
1733# note that tr(from)/to/ is OK, but not tr/from/(to)
1734sub double_delim {
1735 my($from, $to) = @_;
1736 my($succeed, $delim);
1737 if ($from !~ m[/] and $to !~ m[/]) {
1738 return "/$from/$to/";
1739 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
1740 if (($succeed, $to) = balanced_delim($to) and $succeed) {
1741 return "$from$to";
1742 } else {
1743 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
1744 return "$from$delim$to$delim" if index($to, $delim) == -1;
1745 }
1746 $to =~ s[/][\\/]g;
1747 return "$from/$to/";
1748 }
1749 } else {
1750 for $delim ('/', '"', '#') { # note no '
1751 return "$delim$from$delim$to$delim"
1752 if index($to . $from, $delim) == -1;
1753 }
1754 $from =~ s[/][\\/]g;
1755 $to =~ s[/][\\/]g;
1756 return "/$from/$to/";
1757 }
1758}
1759
1760sub pchr { # ASCII
1761 my($n) = @_;
1762 if ($n == ord '\\') {
1763 return '\\\\';
1764 } elsif ($n >= ord(' ') and $n <= ord('~')) {
1765 return chr($n);
1766 } elsif ($n == ord "\a") {
1767 return '\\a';
1768 } elsif ($n == ord "\b") {
1769 return '\\b';
1770 } elsif ($n == ord "\t") {
1771 return '\\t';
1772 } elsif ($n == ord "\n") {
1773 return '\\n';
1774 } elsif ($n == ord "\e") {
1775 return '\\e';
1776 } elsif ($n == ord "\f") {
1777 return '\\f';
1778 } elsif ($n == ord "\r") {
1779 return '\\r';
1780 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
1781 return '\\c' . chr(ord("@") + $n);
1782 } else {
1783# return '\x' . sprintf("%02x", $n);
1784 return '\\' . sprintf("%03o", $n);
1785 }
1786}
1787
1788sub collapse {
1789 my(@chars) = @_;
1790 my($c, $str, $tr);
1791 for ($c = 0; $c < @chars; $c++) {
1792 $tr = $chars[$c];
1793 $str .= pchr($tr);
1794 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
1795 $chars[$c + 2] == $tr + 2)
1796 {
1797 for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
1798 $str .= "-";
1799 $str .= pchr($chars[$c]);
1800 }
1801 }
1802 return $str;
1803}
1804
1805sub OPpTRANS_SQUASH () { 16 }
1806sub OPpTRANS_DELETE () { 32 }
1807sub OPpTRANS_COMPLEMENT () { 64 }
1808
1809sub pp_trans {
1810 my $self = shift;
1811 my $op = shift;
1812 my(@table) = unpack("s256", $op->pv);
1813 my($c, $tr, @from, @to, @delfrom, $delhyphen);
1814 if ($table[ord "-"] != -1 and
1815 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
1816 {
1817 $tr = $table[ord "-"];
1818 $table[ord "-"] = -1;
1819 if ($tr >= 0) {
1820 @from = ord("-");
1821 @to = $tr;
1822 } else { # -2 ==> delete
1823 $delhyphen = 1;
1824 }
1825 }
1826 for ($c = 0; $c < 256; $c++) {
1827 $tr = $table[$c];
1828 if ($tr >= 0) {
1829 push @from, $c; push @to, $tr;
1830 } elsif ($tr == -2) {
1831 push @delfrom, $c;
1832 }
1833 }
1834 my $flags;
1835 @from = (@from, @delfrom);
1836 if ($op->private & OPpTRANS_COMPLEMENT) {
1837 $flags .= "c";
1838 my @newfrom = ();
1839 my %from;
1840 @from{@from} = (1) x @from;
1841 for ($c = 0; $c < 256; $c++) {
1842 push @newfrom, $c unless $from{$c};
1843 }
1844 @from = @newfrom;
1845 }
1846 if ($op->private & OPpTRANS_DELETE) {
1847 $flags .= "d";
1848 } else {
1849 pop @to while $#to and $to[$#to] == $to[$#to -1];
1850 }
1851 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
1852 my($from, $to);
1853 $from = collapse(@from);
1854 $to = collapse(@to);
1855 $from .= "-" if $delhyphen;
1856 return "tr" . double_delim($from, $to) . $flags;
1857}
1858
1859# Like dq(), but different
1860sub re_dq {
1861 my $self = shift;
1862 my $op = shift;
1863 my $type = $op->ppaddr;
1864 if ($type eq "pp_const") {
1865 return uninterp($op->sv->PV);
1866 } elsif ($type eq "pp_concat") {
1867 return $self->re_dq($op->first) . $self->re_dq($op->last);
1868 } elsif ($type eq "pp_uc") {
1869 return '\U' . $self->re_dq($op->first->sibling) . '\E';
1870 } elsif ($type eq "pp_lc") {
1871 return '\L' . $self->re_dq($op->first->sibling) . '\E';
1872 } elsif ($type eq "pp_ucfirst") {
1873 return '\u' . $self->re_dq($op->first->sibling);
1874 } elsif ($type eq "pp_lcfirst") {
1875 return '\l' . $self->re_dq($op->first->sibling);
1876 } elsif ($type eq "pp_quotemeta") {
1877 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
1878 } elsif ($type eq "pp_join") {
1879 return $self->deparse($op->last); # was join($", @ary)
1880 } else {
1881 return $self->deparse($op);
1882 }
1883}
1884
1885sub pp_regcomp {
1886 my $self = shift;
1887 my $op = shift;
1888 my $kid = $op->first;
1889 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
1890 return $self->re_dq($kid);
1891}
1892
1893sub OPp_RUNTIME () { 64 }
1894
1895sub PMf_ONCE () { 0x2 }
1896sub PMf_SKIPWHITE () { 0x10 }
1897sub PMf_FOLD () { 0x20 }
1898sub PMf_CONST () { 0x40 }
1899sub PMf_KEEP () { 0x80 }
1900sub PMf_GLOBAL () { 0x100 }
1901sub PMf_CONTINUE () { 0x200 }
1902sub PMf_EVAL () { 0x400 }
1903sub PMf_MULTILINE () { 0x1000 }
1904sub PMf_SINGLELINE () { 0x2000 }
1905sub PMf_LOCALE () { 0x4000 }
1906sub PMf_EXTENDED () { 0x8000 }
1907
1908# osmic acid -- see osmium tetroxide
1909
1910my %matchwords;
1911map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
1912 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
1913 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
1914
1915sub pp_match {
1916 my $self = shift;
1917 my $op = shift;
1918 my $kid = $op->first;
1919 my ($pre, $post, $re) = ("", "", "");
1920 if ($op->flags & OPf_STACKED) {
1921 $pre = "(" . $self->deparse($kid) . " =~ ";
1922 $post = ")";
1923 $kid = $kid->sibling;
1924 }
1925 if (null $kid) {
1926 $re = uninterp(escape_str($op->precomp));
1927 } else {
1928 $re = $self->deparse($kid);
1929 }
1930 my $flags = "";
1931 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
1932 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
1933 $flags .= "i" if $op->pmflags & PMf_FOLD;
1934 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
1935 $flags .= "o" if $op->pmflags & PMf_KEEP;
1936 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
1937 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
1938 $flags = $matchwords{$flags} if $matchwords{$flags};
1939 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
1940 $re =~ s/\?/\\?/g;
1941 return "$pre?$re?$flags$post";
1942 }
1943 return $pre . single_delim("m", "/", $re) . "$flags$post";
1944}
1945
1946sub pp_pushre { pp_match(@_) }
1947
1948sub pp_split {
1949 my $self = shift;
1950 my $op = shift;
1951 my($kid, @exprs, $ary, $expr);
1952 $kid = $op->first;
1953 if ($ {$kid->pmreplroot}) {
1954 $ary = '@' . $self->gv_name($kid->pmreplroot);
1955 }
1956 for (; !null($kid); $kid = $kid->sibling) {
1957 push @exprs, $self->deparse($kid);
1958 }
1959 $expr = "split(" . join(", ", @exprs) . ")";
1960 if ($ary) {
1961 return "(" . $ary . " = " . $expr . ")";
1962 } else {
1963 return $expr;
1964 }
1965}
1966
1967# oxime -- any of various compounds obtained chiefly by the action of
1968# hydroxylamine on aldehydes and ketones and characterized by the
1969# bivalent grouping C=NOH [Webster's Tenth]
1970
1971my %substwords;
1972map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
1973 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
1974 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
1975 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
1976
1977sub pp_subst {
1978 my $self = shift;
1979 my $op = shift;
1980 my $kid = $op->first;
1981 my($pre, $post, $re, $repl) = ("", "", "", "");
1982 if ($op->flags & OPf_STACKED) {
1983 $pre = "(" . $self->deparse($kid) . " =~ ";
1984 $post = ")";
1985 $kid = $kid->sibling;
1986 }
1987 my $flags = "";
1988 if (null($op->pmreplroot)) {
1989 $repl = $self->dq($kid);
1990 $kid = $kid->sibling;
1991 } else {
1992 $repl = $op->pmreplroot->first; # skip substcont
1993 while ($repl->ppaddr eq "pp_entereval") {
1994 $repl = $repl->first;
1995 $flags .= "e";
1996 }
1997 $repl = $self->deparse($repl);
1998 }
1999 if (null $kid) {
2000 $re = uninterp(escape_str($op->precomp));
2001 } else {
2002 $re = $self->deparse($kid);
a798dbf2 2003 }
6e90668e
SM
2004 $flags .= "e" if $op->pmflags & PMf_EVAL;
2005 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2006 $flags .= "i" if $op->pmflags & PMf_FOLD;
2007 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2008 $flags .= "o" if $op->pmflags & PMf_KEEP;
2009 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2010 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2011 $flags = $substwords{$flags} if $substwords{$flags};
2012 return $pre . "s". double_delim($re, $repl) . "$flags$post";
a798dbf2
MB
2013}
2014
20151;
f6f9bdb7
SM
2016__END__
2017
2018=head1 NAME
2019
2020B::Deparse - Perl compiler backend to produce perl code
2021
2022=head1 SYNOPSIS
2023
2024 perl -MO=Deparse[,-uPACKAGE] prog.pl >prog2.pl
2025
2026=head1 DESCRIPTION
2027
2028B::Deparse is a backend module for the Perl compiler that generates
2029perl source code, based on the internal compiled structure that perl
2030itself creates after parsing a program. The output of B::Deparse won't
2031be exactly the same as the original source, since perl doesn't keep
2032track of comments or whitespace, and there isn't a one-to-one
2033correspondence between perl's syntactical constructions and their
2034compiled form, but it will often be close. One feature of the output
2035is that it includes parentheses even when they are not required for
2036by precedence, which can make it easy to see if perl is parsing your
2037expressions the way you intended.
2038
2039Please note that this module is mainly new and untested code and is
2040still under development, so it may change in the future.
2041
2042=head1 OPTIONS
2043
2044There is currently only one option; as with all compiler options, it
2045must follow directly after the '-MO=Deparse', separated by a comma but
2046not any white space.
2047
2048=over 4
2049
2050=item B<-uPACKAGE>
2051
2052Normally, B::Deparse deparses the main code of a program, all the subs
2053called by the main program (and all the subs called by them,
2054recursively), and any other subs in the main:: package. To include
2055subs in other packages that aren't called directly, such as AUTOLOAD,
2056DESTROY, other subs called automatically by perl, and methods, which
2057aren't resolved to subs until runtime, use the B<-u> option. The
2058argument to B<-u> is the name of a package, and should follow directly
2059after the 'u'. Multiple B<-u> options may be given, separated by
2060commas. Note that unlike some other backends, B::Deparse doesn't
2061(yet) try to guess automatically when B<-u> is needed -- you must
2062invoke it yourself.
2063
2064=back
2065
2066=head1 BUGS
2067
2068See the 'to do' list at the beginning of the module file.
2069
2070=head1 AUTHOR
2071
2072Stephen McCamant <alias@mcs.com>, based on an earlier version by
2073Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
2074
2075=cut