Print
Send Feedback
Fixed Width
Fluid WidthError Buddy
Do you have an error message from your application? Then find the answer with Error Buddy. You can search over 40000 source code files and troubleshooting documents using our beta lucene/nutch search interface or if you prefer, search as normal using google. With LXR technology you can drill right down into the line of source code where it came from with full cross-referencing.
If after searching you didn't get your ideal answer, or you are still unclear what the error means, you can choose to post that question to the community forums following the link included in the search results.
[1.6]001 # B::Deparse.pm 002 # Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved. 003 # This module is free software; you can redistribute and/or modify 004 # it under the same terms as Perl itself. 005 006 # This is based on the module of the same name by Malcolm Beattie, 007 # but essentially none of his code remains. 008 009 package B::Deparse; 010 use Carp; 011 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring 012 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST 013 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD 014 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE 015 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY 016 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER 017 OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED 018 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG 019 CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION 020 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE 021 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); 022 $VERSION = 0.69; 023 use strict; 024 use vars qw/$AUTOLOAD/; 025 use warnings (); 026 027 # Changes between 0.50 and 0.51: 028 # - fixed nulled leave with live enter in sort { } 029 # - fixed reference constants (\"str") 030 # - handle empty programs gracefully 031 # - handle infinte loops (for (;;) {}, while (1) {}) 032 # - differentiate between `for my $x ...' and `my $x; for $x ...' 033 # - various minor cleanups 034 # - moved globals into an object 035 # - added `-u', like B::C 036 # - package declarations using cop_stash 037 # - subs, formats and code sorted by cop_seq 038 # Changes between 0.51 and 0.52: 039 # - added pp_threadsv (special variables under USE_5005THREADS) 040 # - added documentation 041 # Changes between 0.52 and 0.53: 042 # - many changes adding precedence contexts and associativity 043 # - added `-p' and `-s' output style options 044 # - various other minor fixes 045 # Changes between 0.53 and 0.54: 046 # - added support for new `for (1..100)' optimization, 047 # thanks to Gisle Aas 048 # Changes between 0.54 and 0.55: 049 # - added support for new qr// construct 050 # - added support for new pp_regcreset OP 051 # Changes between 0.55 and 0.56: 052 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t 053 # - fixed $# on non-lexicals broken in last big rewrite 054 # - added temporary fix for change in opcode of OP_STRINGIFY 055 # - fixed problem in 0.54's for() patch in `for (@ary)' 056 # - fixed precedence in conditional of ?: 057 # - tweaked list paren elimination in `my($x) = @_' 058 # - made continue-block detection trickier wrt. null ops 059 # - fixed various prototype problems in pp_entersub 060 # - added support for sub prototypes that never get GVs 061 # - added unquoting for special filehandle first arg in truncate 062 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' 063 # - added semicolons at the ends of blocks 064 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 065 # Changes between 0.56 and 0.561: 066 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) 067 # - used new B.pm symbolic constants (done by Nick Ing-Simmons) 068 # Changes between 0.561 and 0.57: 069 # - stylistic changes to symbolic constant stuff 070 # - handled scope in s///e replacement code 071 # - added unquote option for expanding "" into concats, etc. 072 # - split method and proto parts of pp_entersub into separate functions 073 # - various minor cleanups 074 # Changes after 0.57: 075 # - added parens in \&foo (patch by Albert Dvornik) 076 # Changes between 0.57 and 0.58: 077 # - fixed `0' statements that weren't being printed 078 # - added methods for use from other programs 079 # (based on patches from James Duncan and Hugo van der Sanden) 080 # - added -si and -sT to control indenting (also based on a patch from Hugo) 081 # - added -sv to print something else instead of '???' 082 # - preliminary version of utf8 tr/// handling 083 # Changes after 0.58: 084 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy) 085 # - added support for Hugo's new OP_SETSTATE (like nextstate) 086 # Changes between 0.58 and 0.59 087 # - added support for Chip's OP_METHOD_NAMED 088 # - added support for Ilya's OPpTARGET_MY optimization 089 # - elided arrows before `()' subscripts when possible 090 # Changes between 0.59 and 0.60 091 # - support for method attribues was added 092 # - some warnings fixed 093 # - separate recognition of constant subs 094 # - rewrote continue block handling, now recoginizing for loops 095 # - added more control of expanding control structures 096 # Changes between 0.60 and 0.61 (mostly by Robin Houston) 097 # - many bug-fixes 098 # - support for pragmas and 'use' 099 # - support for the little-used $[ variable 100 # - support for __DATA__ sections 101 # - UTF8 support 102 # - BEGIN, CHECK, INIT and END blocks 103 # - scoping of subroutine declarations fixed 104 # - compile-time output from the input program can be suppressed, so that the 105 # output is just the deparsed code. (a change to O.pm in fact) 106 # - our() declarations 107 # - *all* the known bugs are now listed in the BUGS section 108 # - comprehensive test mechanism (TEST -deparse) 109 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) 110 # - bug-fixes 111 # - new switch -P 112 # - support for command-line switches (-l, -0, etc.) 113 # Changes between 0.63 and 0.64 114 # - support for //, CHECK blocks, and assertions 115 # - improved handling of foreach loops and lexicals 116 # - option to use Data::Dumper for constants 117 # - more bug fixes 118 # - discovered lots more bugs not yet fixed 119 120 # Todo: 121 # (See also BUGS section at the end of this file) 122 # 123 # - finish tr/// changes 124 # - add option for even more parens (generalize \&foo change) 125 # - left/right context 126 # - copy comments (look at real text with $^P?) 127 # - avoid semis in one-statement blocks 128 # - associativity of &&=, ||=, ?: 129 # - ',' => '=>' (auto-unquote?) 130 # - break long lines ("\r" as discretionary break?) 131 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc. 132 # - more style options: brace style, hex vs. octal, quotes, ... 133 # - print big ints as hex/octal instead of decimal (heuristic?) 134 # - handle `my $x if 0'? 135 # - version using op_next instead of op_first/sibling? 136 # - avoid string copies (pass arrays, one big join?) 137 # - here-docs? 138 139 # Current test.deparse failures 140 # comp/assertions 38 - disabled assertions should be like "my($x) if 0" 141 # 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}' 142 # comp/hints 6 - location of BEGIN blocks wrt. block openings 143 # run/switchI 1 - missing -I switches entirely 144 # perl -Ifoo -e 'print @INC' 145 # op/caller 2 - warning mask propagates backwards before warnings::register 146 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' 147 # op/getpid 2 - can't assign to shared my() declaration (threads only) 148 # 'my $x : shared = 5' 149 # op/override 7 - parens on overriden require change v-string interpretation 150 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' 151 # c.f. 'BEGIN { *f = sub {0} }; f 2' 152 # op/pat 774 - losing Unicode-ness of Latin1-only strings 153 # 'use charnames ":short"; $x="\N{latin:a with acute}"' 154 # op/recurse 12 - missing parens on recursive call makes it look like method 155 # 'sub f { f($x) }' 156 # op/subst 90 - inconsistent handling of utf8 under "use utf8" 157 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open 158 # op/tiehandle compile - "use strict" deparsed in the wrong place 159 # uni/tr_ several 160 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs 161 # ext/Data/Dumper/t/dumper compile 162 # ext/DB_file/several 163 # ext/Encode/several 164 # ext/Ernno/Errno warnings 165 # ext/IO/lib/IO/t/io_sel 23 166 # ext/PerlIO/t/encoding compile 167 # ext/POSIX/t/posix 6 168 # ext/Socket/Socket 8 169 # ext/Storable/t/croak compile 170 # lib/Attribute/Handlers/t/multi compile 171 # lib/bignum/ several 172 # lib/charnames 35 173 # lib/constant 32 174 # lib/English 40 175 # lib/ExtUtils/t/bytes 4 176 # lib/File/DosGlob compile 177 # lib/Filter/Simple/t/data 1 178 # lib/Math/BigInt/t/constant 1 179 # lib/Net/t/config Deparse-warning 180 # lib/overload compile 181 # lib/Switch/ several 182 # lib/Symbol 4 183 # lib/Test/Simple several 184 # lib/Term/Complete 185 # lib/Tie/File/t/29_downcopy 5 186 # lib/vars 22 187 188 # Object fields (were globals): 189 # 190 # avoid_local: 191 # (local($a), local($b)) and local($a, $b) have the same internal 192 # representation but the short form looks better. We notice we can 193 # use a large-scale local when checking the list, but need to prevent 194 # individual locals too. This hash holds the addresses of OPs that 195 # have already had their local-ness accounted for. The same thing 196 # is done with my(). 197 # 198 # curcv: 199 # CV for current sub (or main program) being deparsed 200 # 201 # curcvlex: 202 # Cached hash of lexical variables for curcv: keys are names, 203 # each value is an array of pairs, indicating the cop_seq of scopes 204 # in which a var of that name is valid. 205 # 206 # curcop: 207 # COP for statement being deparsed 208 # 209 # curstash: 210 # name of the current package for deparsed code 211 # 212 # subs_todo: 213 # array of [cop_seq, CV, is_format?] for subs and formats we still 214 # want to deparse 215 # 216 # protos_todo: 217 # as above, but [name, prototype] for subs that never got a GV 218 # 219 # subs_done, forms_done: 220 # keys are addresses of GVs for subs and formats we've already 221 # deparsed (or at least put into subs_todo) 222 # 223 # subs_declared 224 # keys are names of subs for which we've printed declarations. 225 # That means we can omit parentheses from the arguments. 226 # 227 # subs_deparsed 228 # Keeps track of fully qualified names of all deparsed subs. 229 # 230 # parens: -p 231 # linenums: -l 232 # unquote: -q 233 # cuddle: ` ' or `\n', depending on -sC 234 # indent_size: -si 235 # use_tabs: -sT 236 # ex_const: -sv 237 238 # A little explanation of how precedence contexts and associativity 239 # work: 240 # 241 # deparse() calls each per-op subroutine with an argument $cx (short 242 # for context, but not the same as the cx* in the perl core), which is 243 # a number describing the op's parents in terms of precedence, whether 244 # they're inside an expression or at statement level, etc. (see 245 # chart below). When ops with children call deparse on them, they pass 246 # along their precedence. Fractional values are used to implement 247 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related 248 # parentheses hacks. The major disadvantage of this scheme is that 249 # it doesn't know about right sides and left sides, so say if you 250 # assign a listop to a variable, it can't tell it's allowed to leave 251 # the parens off the listop. 252 253 # Precedences: 254 # 26 [TODO] inside interpolation context ("") 255 # 25 left terms and list operators (leftward) 256 # 24 left -> 257 # 23 nonassoc ++ -- 258 # 22 right ** 259 # 21 right ! ~ \ and unary + and - 260 # 20 left =~ !~ 261 # 19 left * / % x 262 # 18 left + - . 263 # 17 left << >> 264 # 16 nonassoc named unary operators 265 # 15 nonassoc < > <= >= lt gt le ge 266 # 14 nonassoc == != <=> eq ne cmp 267 # 13 left & 268 # 12 left | ^ 269 # 11 left && 270 # 10 left || 271 # 9 nonassoc .. ... 272 # 8 right ?: 273 # 7 right = += -= *= etc. 274 # 6 left , => 275 # 5 nonassoc list operators (rightward) 276 # 4 right not 277 # 3 left and 278 # 2 left or xor 279 # 1 statement modifiers 280 # 0.5 statements, but still print scopes as do { ... } 281 # 0 statement level 282 283 # Nonprinting characters with special meaning: 284 # \cS - steal parens (see maybe_parens_unop) 285 # \n - newline and indent 286 # \t - increase indent 287 # \b - decrease indent (`outdent') 288 # \f - flush left (no indent) 289 # \cK - kill following semicolon, if any 290 291 sub null { 292 my $op = shift; 293 return class($op) eq "NULL"; 294 } 295 296 sub todo { 297 my $self = shift; 298 my($cv, $is_form) = @_; 299 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE}); 300 my $seq; 301 if ($cv->OUTSIDE_SEQ) { 302 $seq = $cv->OUTSIDE_SEQ; 303 } elsif (!null($cv->START) and is_state($cv->START)) { 304 $seq = $cv->START->cop_seq; 305 } else { 306 $seq = 0; 307 } 308 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form]; 309 unless ($is_form || class($cv->STASH) eq 'SPECIAL') { 310 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1; 311 } 312 } 313 314 sub next_todo { 315 my $self = shift; 316 my $ent = shift @{$self->{'subs_todo'}}; 317 my $cv = $ent->[1]; 318 my $gv = $cv->GV; 319 my $name = $self->gv_name($gv); 320 if ($ent->[2]) { 321 return "format $name =\n" 322 . $self->deparse_format($ent->[1]). "\n"; 323 } else { 324 $self->{'subs_declared'}{$name} = 1; 325 if ($name eq "BEGIN") { 326 my $use_dec = $self->begin_is_use($cv); 327 if (defined ($use_dec) and $self->{'expand'} < 5) { 328 return () if 0 == length($use_dec); 329 return $use_dec; 330 } 331 } 332 my $l = ''; 333 if ($self->{'linenums'}) { 334 my $line = $gv->LINE; 335 my $file = $gv->FILE; 336 $l = "\n\f#line $line \"$file\"\n"; 337 } 338 my $p = ''; 339 if (class($cv->STASH) ne "SPECIAL") { 340 my $stash = $cv->STASH->NAME; 341 if ($stash ne $self->{'curstash'}) { 342 $p = "package $stash;\n"; 343 $name = "$self->{'curstash'}::$name" unless $name =~ /::/; 344 $self->{'curstash'} = $stash; 345 } 346 $name =~ s/^\Q$stash\E:://; 347 } 348 return "${p}${l}sub $name " . $self->deparse_sub($cv); 349 } 350 } 351 352 # Return a "use" declaration for this BEGIN block, if appropriate 353 sub begin_is_use { 354 my ($self, $cv) = @_; 355 my $root = $cv->ROOT; 356 local @$self{qw'curcv curcvlex'} = ($cv); 357 #require B::Debug; 358 #B::walkoptree($cv->ROOT, "debug"); 359 my $lineseq = $root->first; 360 return if $lineseq->name ne "lineseq"; 361 362 my $req_op = $lineseq->first->sibling; 363 return if $req_op->name ne "require"; 364 365 my $module; 366 if ($req_op->first->private & OPpCONST_BARE) { 367 # Actually it should always be a bareword 368 $module = $self->const_sv($req_op->first)->PV; 369 $module =~ s[/][::]g; 370 $module =~ s/.pm$//; 371 } 372 else { 373 $module = $self->const($self->const_sv($req_op->first), 6); 374 } 375 376 my $version; 377 my $version_op = $req_op->sibling; 378 return if class($version_op) eq "NULL"; 379 if ($version_op->name eq "lineseq") { 380 # We have a version parameter; skip nextstate & pushmark 381 my $constop = $version_op->first->next->next; 382 383 return unless $self->const_sv($constop)->PV eq $module; 384 $constop = $constop->sibling; 385 $version = $self->const_sv($constop); 386 if (class($version) eq "IV") { 387 $version = $version->int_value; 388 } elsif (class($version) eq "NV") { 389 $version = $version->NV; 390 } elsif (class($version) ne "PVMG") { 391 # Includes PVIV and PVNV 392 $version = $version->PV; 393 } else { 394 # version specified as a v-string 395 $version = 'v'.join '.', map ord, split //, $version->PV; 396 } 397 $constop = $constop->sibling; 398 return if $constop->name ne "method_named"; 399 return if $self->const_sv($constop)->PV ne "VERSION"; 400 } 401 402 $lineseq = $version_op->sibling; 403 return if $lineseq->name ne "lineseq"; 404 my $entersub = $lineseq->first->sibling; 405 if ($entersub->name eq "stub") { 406 return "use $module $version ();\n" if defined $version; 407 return "use $module ();\n"; 408 } 409 return if $entersub->name ne "entersub"; 410 411 # See if there are import arguments 412 my $args = ''; 413 414 my $svop = $entersub->first->sibling; # Skip over pushmark 415 return unless $self->const_sv($svop)->PV eq $module; 416 417 # Pull out the arguments 418 for ($svop=$svop->sibling; $svop->name ne "method_named"; 419 $svop = $svop->sibling) { 420 $args .= ", " if length($args); 421 $args .= $self->deparse($svop, 6); 422 } 423 424 my $use = 'use'; 425 my $method_named = $svop; 426 return if $method_named->name ne "method_named"; 427 my $method_name = $self->const_sv($method_named)->PV; 428 429 if ($method_name eq "unimport") { 430 $use = 'no'; 431 } 432 433 # Certain pragmas are dealt with using hint bits, 434 # so we ignore them here 435 if ($module eq 'strict' || $module eq 'integer' 436 || $module eq 'bytes' || $module eq 'warnings') { 437 return ""; 438 } 439 440 if (defined $version && length $args) { 441 return "$use $module $version ($args);\n"; 442 } elsif (defined $version) { 443 return "$use $module $version;\n"; 444 } elsif (length $args) { 445 return "$use $module ($args);\n"; 446 } else { 447 return "$use $module;\n"; 448 } 449 } 450 451 sub stash_subs { 452 my ($self, $pack) = @_; 453 my (@ret, $stash); 454 if (!defined $pack) { 455 $pack = ''; 456 $stash = \%::; 457 } 458 else { 459 $pack =~ s/(::)?$/::/; 460 no strict 'refs'; 461 $stash = \%$pack; 462 } 463 my %stash = svref_2object($stash)->ARRAY; 464 while (my ($key, $val) = each %stash) { 465 next if $key eq 'main::'; # avoid infinite recursion 466 my $class = class($val); 467 if ($class eq "PV") { 468 # Just a prototype. As an ugly but fairly effective way 469 # to find out if it belongs here is to see if the AUTOLOAD 470 # (if any) for the stash was defined in one of our files. 471 my $A = $stash{"AUTOLOAD"}; 472 if (defined ($A) && class($A) eq "GV" && defined($A->CV) 473 && class($A->CV) eq "CV") { 474 my $AF = $A->FILE; 475 next unless $AF eq $0 || exists $self->{'files'}{$AF}; 476 } 477 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; 478 } elsif ($class eq "IV") { 479 # Just a name. As above. 480 my $A = $stash{"AUTOLOAD"}; 481 if (defined ($A) && class($A) eq "GV" && defined($A->CV) 482 && class($A->CV) eq "CV") { 483 my $AF = $A->FILE; 484 next unless $AF eq $0 || exists $self->{'files'}{$AF}; 485 } 486 push @{$self->{'protos_todo'}}, [$pack . $key, undef]; 487 } elsif ($class eq "GV") { 488 if (class(my $cv = $val->CV) ne "SPECIAL") { 489 next if $self->{'subs_done'}{$$val}++; 490 next if $$val != ${$cv->GV}; # Ignore imposters 491 $self->todo($cv, 0); 492 } 493 if (class(my $cv = $val->FORM) ne "SPECIAL") { 494 next if $self->{'forms_done'}{$$val}++; 495 next if $$val != ${$cv->GV}; # Ignore imposters 496 $self->todo($cv, 1); 497 } 498 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { 499 $self->stash_subs($pack . $key); 500 } 501 } 502 } 503 } 504 505 sub print_protos { 506 my $self = shift; 507 my $ar; 508 my @ret; 509 foreach $ar (@{$self->{'protos_todo'}}) { 510 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); 511 push @ret, "sub " . $ar->[0] . "$proto;\n"; 512 } 513 delete $self->{'protos_todo'}; 514 return @ret; 515 } 516 517 sub style_opts { 518 my $self = shift; 519 my $opts = shift; 520 my $opt; 521 while (length($opt = substr($opts, 0, 1))) { 522 if ($opt eq "C") { 523 $self->{'cuddle'} = " "; 524 $opts = substr($opts, 1); 525 } elsif ($opt eq "i") { 526 $opts =~ s/^i(\d+)//; 527 $self->{'indent_size'} = $1; 528 } elsif ($opt eq "T") { 529 $self->{'use_tabs'} = 1; 530 $opts = substr($opts, 1); 531 } elsif ($opt eq "v") { 532 $opts =~ s/^v([^.]*)(.|$)//; 533 $self->{'ex_const'} = $1; 534 } 535 } 536 } 537 538 sub new { 539 my $class = shift; 540 my $self = bless {}, $class; 541 $self->{'cuddle'} = "\n"; 542 $self->{'curcop'} = undef; 543 $self->{'curstash'} = "main"; 544 $self->{'ex_const'} = "'???'"; 545 $self->{'expand'} = 0; 546 $self->{'files'} = {}; 547 $self->{'indent_size'} = 4; 548 $self->{'linenums'} = 0; 549 $self->{'parens'} = 0; 550 $self->{'subs_todo'} = []; 551 $self->{'unquote'} = 0; 552 $self->{'use_dumper'} = 0; 553 $self->{'use_tabs'} = 0; 554 555 $self->{'ambient_arybase'} = 0; 556 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings 557 $self->{'ambient_hints'} = 0; 558 $self->init(); 559 560 while (my $arg = shift @_) { 561 if ($arg eq "-d") { 562 $self->{'use_dumper'} = 1; 563 require Data::Dumper; 564 } elsif ($arg =~ /^-f(.*)/) { 565 $self->{'files'}{$1} = 1; 566 } elsif ($arg eq "-l") { 567 $self->{'linenums'} = 1; 568 } elsif ($arg eq "-p") { 569 $self->{'parens'} = 1; 570 } elsif ($arg eq "-P") { 571 $self->{'noproto'} = 1; 572 } elsif ($arg eq "-q") { 573 $self->{'unquote'} = 1; 574 } elsif (substr($arg, 0, 2) eq "-s") { 575 $self->style_opts(substr $arg, 2); 576 } elsif ($arg =~ /^-x(\d)$/) { 577 $self->{'expand'} = $1; 578 } 579 } 580 return $self; 581 } 582 583 { 584 # Mask out the bits that L<warnings::register> uses 585 my $WARN_MASK; 586 BEGIN { 587 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; 588 } 589 sub WARN_MASK () { 590 return $WARN_MASK; 591 } 592 } 593 594 # Initialise the contextual information, either from 595 # defaults provided with the ambient_pragmas method, 596 # or from perl's own defaults otherwise. 597 sub init { 598 my $self = shift; 599 600 $self->{'arybase'} = $self->{'ambient_arybase'}; 601 $self->{'warnings'} = defined ($self->{'ambient_warnings'}) 602 ? $self->{'ambient_warnings'} & WARN_MASK 603 : undef; 604 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF; 605 606 # also a convenient place to clear out subs_declared 607 delete $self->{'subs_declared'}; 608 } 609 610 sub compile { 611 my(@args) = @_; 612 return sub { 613 my $self = B::Deparse->new(@args); 614 # First deparse command-line args 615 if (defined $^I) { # deparse -i 616 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); 617 } 618 if ($^W) { # deparse -w 619 print qq(BEGIN { \$^W = $^W; }\n); 620 } 621 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 622 my $fs = perlstring($/) || 'undef'; 623 my $bs = perlstring($O::savebackslash) || 'undef'; 624 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); 625 } 626 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); 627 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); 628 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); 629 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); 630 for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) { 631 $self->todo($block, 0); 632 } 633 $self->stash_subs(); 634 local($SIG{"__DIE__"}) = 635 sub { 636 if ($self->{'curcop'}) { 637 my $cop = $self->{'curcop'}; 638 my($line, $file) = ($cop->line, $cop->file); 639 print STDERR "While deparsing $file near line $line,\n"; 640 } 641 }; 642 $self->{'curcv'} = main_cv; 643 $self->{'curcvlex'} = undef; 644 print $self->print_protos; 645 @{$self->{'subs_todo'}} = 646 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; 647 print $self->indent($self->deparse_root(main_root)), "\n" 648 unless null main_root; 649 my @text; 650 while (scalar(@{$self->{'subs_todo'}})) { 651 push @text, $self->next_todo; 652 } 653 print $self->indent(join("", @text)), "\n" if @text; 654 655 # Print __DATA__ section, if necessary 656 no strict 'refs'; 657 my $laststash = defined $self->{'curcop'} 658 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; 659 if (defined *{$laststash."::DATA"}{IO}) { 660 print "package $laststash;\n" 661 unless $laststash eq $self->{'curstash'}; 662 print "__DATA__\n"; 663 print readline(*{$laststash."::DATA"}); 664 } 665 } 666 } 667 668 sub coderef2text { 669 my $self = shift; 670 my $sub = shift; 671 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); 672 673 $self->init(); 674 return $self->indent($self->deparse_sub(svref_2object($sub))); 675 } 676 677 sub ambient_pragmas { 678 my $self = shift; 679 my ($arybase, $hint_bits, $warning_bits) = (0, 0); 680 681 while (@_ > 1) { 682 my $name = shift(); 683 my $val = shift(); 684 685 if ($name eq 'strict') { 686 require strict; 687 688 if ($val eq 'none') { 689 $hint_bits &= ~strict::bits(qw/refs subs vars/); 690 next(); 691 } 692 693 my @names; 694 if ($val eq "all") { 695 @names = qw/refs subs vars/; 696 } 697 elsif (ref $val) { 698 @names = @$val; 699 } 700 else { 701 @names = split' ', $val; 702 } 703 $hint_bits |= strict::bits(@names); 704 } 705 706 elsif ($name eq '$[') { 707 $arybase = $val; 708 } 709 710 elsif ($name eq 'integer' 711 || $name eq 'bytes' 712 || $name eq 'utf8') { 713 require "$name.pm"; 714 if ($val) { 715 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; 716 } 717 else { 718 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; 719 } 720 } 721 722 elsif ($name eq 're') { 723 require re; 724 if ($val eq 'none') { 725 $hint_bits &= ~re::bits(qw/taint eval/); 726 next(); 727 } 728 729 my @names; 730 if ($val eq 'all') { 731 @names = qw/taint eval/; 732 } 733 elsif (ref $val) { 734 @names = @$val; 735 } 736 else { 737 @names = split' ',$val; 738 } 739 $hint_bits |= re::bits(@names); 740 } 741 742 elsif ($name eq 'warnings') { 743 if ($val eq 'none') { 744 $warning_bits = $warnings::NONE; 745 next(); 746 } 747 748 my @names; 749 if (ref $val) { 750 @names = @$val; 751 } 752 else { 753 @names = split/\s+/, $val; 754 } 755 756 $warning_bits = $warnings::NONE if !defined ($warning_bits); 757 $warning_bits |= warnings::bits(@names); 758 } 759 760 elsif ($name eq 'warning_bits') { 761 $warning_bits = $val; 762 } 763 764 elsif ($name eq 'hint_bits') { 765 $hint_bits = $val; 766 } 767 768 else { 769 croak "Unknown pragma type: $name"; 770 } 771 } 772 if (@_) { 773 croak "The ambient_pragmas method expects an even number of args"; 774 } 775 776 $self->{'ambient_arybase'} = $arybase; 777 $self->{'ambient_warnings'} = $warning_bits; 778 $self->{'ambient_hints'} = $hint_bits; 779 } 780 781 # This method is the inner loop, so try to keep it simple 782 sub deparse { 783 my $self = shift; 784 my($op, $cx) = @_; 785 786 Carp::confess("Null op in deparse") if !defined($op) 787 || class($op) eq "NULL"; 788 my $meth = "pp_" . $op->name; 789 return $self->$meth($op, $cx); 790 } 791 792 sub indent { 793 my $self = shift; 794 my $txt = shift; 795 my @lines = split(/\n/, $txt); 796 my $leader = ""; 797 my $level = 0; 798 my $line; 799 for $line (@lines) { 800 my $cmd = substr($line, 0, 1); 801 if ($cmd eq "\t" or $cmd eq "\b") { 802 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; 803 if ($self->{'use_tabs'}) { 804 $leader = "\t" x ($level / 8) . " " x ($level % 8); 805 } else { 806 $leader = " " x $level; 807 } 808 $line = substr($line, 1); 809 } 810 if (substr($line, 0, 1) eq "\f") { 811 $line = substr($line, 1); # no indent 812 } else { 813 $line = $leader . $line; 814 } 815 $line =~ s/\cK;?//g; 816 } 817 return join("\n", @lines); 818 } 819 820 sub deparse_sub { 821 my $self = shift; 822 my $cv = shift; 823 my $proto = ""; 824 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); 825 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); 826 local $self->{'curcop'} = $self->{'curcop'}; 827 if ($cv->FLAGS & SVf_POK) { 828 $proto = "(". $cv->PV . ") "; 829 } 830 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) { 831 $proto .= ": "; 832 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; 833 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; 834 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; 835 $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION; 836 } 837 838 local($self->{'curcv'}) = $cv; 839 local($self->{'curcvlex'}); 840 local(@$self{qw'curstash warnings hints'}) 841 = @$self{qw'curstash warnings hints'}; 842 my $body; 843 if (not null $cv->ROOT) { 844 my $lineseq = $cv->ROOT->first; 845 if ($lineseq->name eq "lineseq") { 846 my @ops; 847 for(my$o=$lineseq->first; $$o; $o=$o->sibling) { 848 push @ops, $o; 849 } 850 $body = $self->lineseq(undef, @ops).";"; 851 my $scope_en = $self->find_scope_en($lineseq); 852 if (defined $scope_en) { 853 my $subs = join"", $self->seq_subs($scope_en); 854 $body .= ";\n$subs" if length($subs); 855 } 856 } 857 else { 858 $body = $self->deparse($cv->ROOT->first, 0); 859 } 860 } 861 else { 862 my $sv = $cv->const_sv; 863 if ($$sv) { 864 # uh-oh. inlinable sub... format it differently 865 return $proto . "{ " . $self->const($sv, 0) . " }\n"; 866 } else { # XSUB? (or just a declaration) 867 return "$proto;\n"; 868 } 869 } 870 return $proto ."{\n\t$body\n\b}" ."\n"; 871 } 872 873 sub deparse_format { 874 my $self = shift; 875 my $form = shift; 876 my @text; 877 local($self->{'curcv'}) = $form; 878 local($self->{'curcvlex'}); 879 local($self->{'in_format'}) = 1; 880 local(@$self{qw'curstash warnings hints'}) 881 = @$self{qw'curstash warnings hints'}; 882 my $op = $form->ROOT; 883 my $kid; 884 return "\f." if $op->first->name eq 'stub' 885 || $op->first->name eq 'nextstate'; 886 $op = $op->first->first; # skip leavewrite, lineseq 887 while (not null $op) { 888 $op = $op->sibling; # skip nextstate 889 my @exprs; 890 $kid = $op->first->sibling; # skip pushmark 891 push @text, "\f".$self->const_sv($kid)->PV; 892 $kid = $kid->sibling; 893 for (; not null $kid; $kid = $kid->sibling) { 894 push @exprs, $self->deparse($kid, 0); 895 } 896 push @text, "\f".join(", ", @exprs)."\n" if @exprs; 897 $op = $op->sibling; 898 } 899 return join("", @text) . "\f."; 900 } 901 902 sub is_scope { 903 my $op = shift; 904 return $op->name eq "leave" || $op->name eq "scope" 905 || $op->name eq "lineseq" 906 || ($op->name eq "null" && class($op) eq "UNOP" 907 && (is_scope($op->first) || $op->first->name eq "enter")); 908 } 909 910 sub is_state { 911 my $name = $_[0]->name; 912 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; 913 } 914 915 sub is_miniwhile { # check for one-line loop (`foo() while $y--') 916 my $op = shift; 917 return (!null($op) and null($op->sibling) 918 and $op->name eq "null" and class($op) eq "UNOP" 919 and (($op->first->name =~ /^(and|or)$/ 920 and $op->first->first->sibling->name eq "lineseq") 921 or ($op->first->name eq "lineseq" 922 and not null $op->first->first->sibling 923 and $op->first->first->sibling->name eq "unstack") 924 )); 925 } 926 927 # Check if the op and its sibling are the initialization and the rest of a 928 # for (..;..;..) { ... } loop 929 sub is_for_loop { 930 my $op = shift; 931 # This OP might be almost anything, though it won't be a 932 # nextstate. (It's the initialization, so in the canonical case it 933 # will be an sassign.) The sibling is a lineseq whose first child 934 # is a nextstate and whose second is a leaveloop. 935 my $lseq = $op->sibling; 936 if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") { 937 if ($lseq->first && !null($lseq->first) && is_state($lseq->first) 938 && (my $sib = $lseq->first->sibling)) { 939 return (!null($sib) && $sib->name eq "leaveloop"); 940 } 941 } 942 return 0; 943 } 944 945 sub is_scalar { 946 my $op = shift; 947 return ($op->name eq "rv2sv" or 948 $op->name eq "padsv" or 949 $op->name eq "gv" or # only in array/hash constructs 950 $op->flags & OPf_KIDS && !null($op->first) 951 && $op->first->name eq "gvsv"); 952 } 953 954 sub maybe_parens { 955 my $self = shift; 956 my($text, $cx, $prec) = @_; 957 if ($prec < $cx # unary ops nest just fine 958 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 959 or $self->{'parens'}) 960 { 961 $text = "($text)"; 962 # In a unop, let parent reuse our parens; see maybe_parens_unop 963 $text = "\cS" . $text if $cx == 16; 964 return $text; 965 } else { 966 return $text; 967 } 968 } 969 970 # same as above, but get around the `if it looks like a function' rule 971 sub maybe_parens_unop { 972 my $self = shift; 973 my($name, $kid, $cx) = @_; 974 if ($cx > 16 or $self->{'parens'}) { 975 $kid = $self->deparse($kid, 1); 976 if ($name eq "umask" && $kid =~ /^\d+$/) { 977 $kid = sprintf("%#o", $kid); 978 } 979 return "$name($kid)"; 980 } else { 981 $kid = $self->deparse($kid, 16); 982 if ($name eq "umask" && $kid =~ /^\d+$/) { 983 $kid = sprintf("%#o", $kid); 984 } 985 if (substr($kid, 0, 1) eq "\cS") { 986 # use kid's parens 987 return $name . substr($kid, 1); 988 } elsif (substr($kid, 0, 1) eq "(") { 989 # avoid looks-like-a-function trap with extra parens 990 # (`+' can lead to ambiguities) 991 return "$name(" . $kid . ")"; 992 } else { 993 return "$name $kid"; 994 } 995 } 996 } 997 998 sub maybe_parens_func { 999 my $self = shift; 1000 my($func, $text, $cx, $prec) = @_; 1001 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { 1002 return "$func($text)"; 1003 } else { 1004 return "$func $text"; 1005 } 1006 } 1007 1008 sub maybe_local { 1009 my $self = shift; 1010 my($op, $cx, $text) = @_; 1011 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; 1012 if ($op->private & (OPpLVAL_INTRO|$our_intro) 1013 and not $self->{'avoid_local'}{$$op}) { 1014 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; 1015 if( $our_local eq 'our' ) { 1016 # XXX This assertion fails code with non-ASCII identifiers, 1017 # like ./ext/Encode/t/jperl.t 1018 die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/; 1019 $text =~ s/(\w+::)+//; 1020 } 1021 if (want_scalar($op)) { 1022 return "$our_local $text"; 1023 } else { 1024 return $self->maybe_parens_func("$our_local", $text, $cx, 16); 1025 } 1026 } else { 1027 return $text; 1028 } 1029 } 1030 1031 sub maybe_targmy { 1032 my $self = shift; 1033 my($op, $cx, $func, @args) = @_; 1034 if ($op->private & OPpTARGET_MY) { 1035 my $var = $self->padname($op->targ); 1036 my $val = $func->($self, $op, 7, @args); 1037 return $self->maybe_parens("$var = $val", $cx, 7); 1038 } else { 1039 return $func->($self, $op, $cx, @args); 1040 } 1041 } 1042 1043 sub padname_sv { 1044 my $self = shift; 1045 my $targ = shift; 1046 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); 1047 } 1048 1049 sub maybe_my { 1050 my $self = shift; 1051 my($op, $cx, $text) = @_; 1052 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { 1053 if (want_scalar($op)) { 1054 return "my $text"; 1055 } else { 1056 return $self->maybe_parens_func("my", $text, $cx, 16); 1057 } 1058 } else { 1059 return $text; 1060 } 1061 } 1062 1063 # The following OPs don't have functions: 1064 1065 # pp_padany -- does not exist after parsing 1066 1067 sub AUTOLOAD { 1068 if ($AUTOLOAD =~ s/^.*::pp_//) { 1069 warn "unexpected OP_".uc $AUTOLOAD; 1070 return "XXX"; 1071 } else { 1072 die "Undefined subroutine $AUTOLOAD called"; 1073 } 1074 } 1075 1076 sub DESTROY {} # Do not AUTOLOAD 1077 1078 # $root should be the op which represents the root of whatever 1079 # we're sequencing here. If it's undefined, then we don't append 1080 # any subroutine declarations to the deparsed ops, otherwise we 1081 # append appropriate declarations. 1082 sub lineseq { 1083 my($self, $root, @ops) = @_; 1084 my($expr, @exprs); 1085 1086 my $out_cop = $self->{'curcop'}; 1087 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; 1088 my $limit_seq; 1089 if (defined $root) { 1090 $limit_seq = $out_seq; 1091 my $nseq; 1092 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; 1093 $limit_seq = $nseq if !defined($limit_seq) 1094 or defined($nseq) && $nseq < $limit_seq; 1095 } 1096 $limit_seq = $self->{'limit_seq'} 1097 if defined($self->{'limit_seq'}) 1098 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); 1099 local $self->{'limit_seq'} = $limit_seq; 1100 for (my $i = 0; $i < @ops; $i++) { 1101 $expr = ""; 1102 if (is_state $ops[$i]) { 1103 $expr = $self->deparse($ops[$i], 0); 1104 $i++; 1105 if ($i > $#ops) { 1106 push @exprs, $expr; 1107 last; 1108 } 1109 } 1110 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and 1111 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq") 1112 { 1113 if ($ls->first && !null($ls->first) && is_state($ls->first) 1114 && (my $sib = $ls->first->sibling)) { 1115 if (!null($sib) && $sib->name eq "leaveloop") { 1116 push @exprs, $expr . $self->for_loop($ops[$i], 0); 1117 $i++; 1118 next; 1119 } 1120 } 1121 } 1122 $expr .= $self->deparse($ops[$i], (@ops != 1)/2); 1123 $expr =~ s/;\n?\z//; 1124 push @exprs, $expr; 1125 } 1126 my $body = join(";\n", grep {length} @exprs); 1127 my $subs = ""; 1128 if (defined $root && defined $limit_seq && !$self->{'in_format'}) { 1129 $subs = join "\n", $self->seq_subs($limit_seq); 1130 } 1131 return join(";\n", grep {length} $body, $subs); 1132 } 1133 1134 sub scopeop { 1135 my($real_block, $self, $op, $cx) = @_; 1136 my $kid; 1137 my @kids; 1138 1139 local(@$self{qw'curstash warnings hints'}) 1140 = @$self{qw'curstash warnings hints'} if $real_block; 1141 if ($real_block) { 1142 $kid = $op->first->sibling; # skip enter 1143 if (is_miniwhile($kid)) { 1144 my $top = $kid->first; 1145 my $name = $top->name; 1146 if ($name eq "and") { 1147 $name = "while"; 1148 } elsif ($name eq "or") { 1149 $name = "until"; 1150 } else { # no conditional -> while 1 or until 0 1151 return $self->deparse($top->first, 1) . " while 1"; 1152 } 1153 my $cond = $top->first; 1154 my $body = $cond->sibling->first; # skip lineseq 1155 $cond = $self->deparse($cond, 1); 1156 $body = $self->deparse($body, 1); 1157 return "$body $name $cond"; 1158 } 1159 } else { 1160 $kid = $op->first; 1161 } 1162 for (; !null($kid); $kid = $kid->sibling) { 1163 push @kids, $kid; 1164 } 1165 if ($cx > 0) { # inside an expression, (a do {} while for lineseq) 1166 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}"; 1167 } else { 1168 my $lineseq = $self->lineseq($op, @kids); 1169 return (length ($lineseq) ? "$lineseq;" : ""); 1170 } 1171 } 1172 1173 sub pp_scope { scopeop(0, @_); } 1174 sub pp_lineseq { scopeop(0, @_); } 1175 sub pp_leave { scopeop(1, @_); } 1176 1177 # This is a special case of scopeop and lineseq, for the case of the 1178 # main_root. The difference is that we print the output statements as 1179 # soon as we get them, for the sake of impatient users. 1180 sub deparse_root { 1181 my $self = shift; 1182 my($op) = @_; 1183 local(@$self{qw'curstash warnings hints'}) 1184 = @$self{qw'curstash warnings hints'}; 1185 my @kids; 1186 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { 1187 push @kids, $kid; 1188 } 1189 for (my $i = 0; $i < @kids; $i++) { 1190 my $expr = ""; 1191 if (is_state $kids[$i]) { 1192 $expr = $self->deparse($kids[$i], 0); 1193 $i++; 1194 if ($i > $#kids) { 1195 print $self->indent($expr); 1196 last; 1197 } 1198 } 1199 if (is_for_loop($kids[$i])) { 1200 $expr .= $self->for_loop($kids[$i], 0); 1201 $expr .= ";\n" unless $i == $#kids; 1202 print $self->indent($expr); 1203 $i++; 1204 next; 1205 } 1206 $expr .= $self->deparse($kids[$i], (@kids != 1)/2); 1207 $expr =~ s/;\n?\z//; 1208 $expr .= ";"; 1209 print $self->indent($expr); 1210 print "\n" unless $i == $#kids; 1211 } 1212 } 1213 1214 # The BEGIN {} is used here because otherwise this code isn't executed 1215 # when you run B::Deparse on itself. 1216 my %globalnames; 1217 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", 1218 "ENV", "ARGV", "ARGVOUT", "_"); } 1219 1220 sub gv_name { 1221 my $self = shift; 1222 my $gv = shift; 1223 Carp::confess() unless ref($gv) eq "B::GV"; 1224 my $stash = $gv->STASH->NAME; 1225 my $name = $gv->SAFENAME; 1226 if (($stash eq 'main' && $globalnames{$name}) 1227 or ($stash eq $self->{'curstash'} && !$globalnames{$name}) 1228 or $name =~ /^[^A-Za-z_]/) 1229 { 1230 $stash = ""; 1231 } else { 1232 $stash = $stash . "::"; 1233 } 1234 if ($name =~ /^(\^..|{)/) { 1235 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ 1236 } 1237 return $stash . $name; 1238 } 1239 1240 # Return the name to use for a stash variable. 1241 # If a lexical with the same name is in scope, it may need to be 1242 # fully-qualified. 1243 sub stash_variable { 1244 my ($self, $prefix, $name) = @_; 1245 1246 return "$prefix$name" if $name =~ /::/; 1247 1248 unless ($prefix eq '$' || $prefix eq '@' || #' 1249 $prefix eq '%' || $prefix eq '$#') { 1250 return "$prefix$name"; 1251 } 1252 1253 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; 1254 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v); 1255 return "$prefix$name"; 1256 } 1257 1258 sub lex_in_scope { 1259 my ($self, $name) = @_; 1260 $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 1261 1262 return 0 if !defined($self->{'curcop'}); 1263 my $seq = $self->{'curcop'}->cop_seq; 1264 return 0 if !exists $self->{'curcvlex'}{$name}; 1265 for my $a (@{$self->{'curcvlex'}{$name}}) { 1266 my ($st, $en) = @$a; 1267 return 1 if $seq > $st && $seq <= $en; 1268 } 1269 return 0; 1270 } 1271 1272 sub populate_curcvlex { 1273 my $self = shift; 1274 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { 1275 my $padlist = $cv->PADLIST; 1276 # an undef CV still in lexical chain 1277 next if class($padlist) eq "SPECIAL"; 1278 my @padlist = $padlist->ARRAY; 1279 my @ns = $padlist[0]->ARRAY; 1280 1281 for (my $i=0; $i<@ns; ++$i) { 1282 next if class($ns[$i]) eq "SPECIAL"; 1283 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars 1284 if (class($ns[$i]) eq "PV") { 1285 # Probably that pesky lexical @_ 1286 next; 1287 } 1288 my $name = $ns[$i]->PVX; 1289 my ($seq_st, $seq_en) = 1290 ($ns[$i]->FLAGS & SVf_FAKE) 1291 ? (0, 999999) 1292 : ($ns[$i]->NVX, $ns[$i]->IVX); 1293 1294 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en]; 1295 } 1296 } 1297 } 1298 1299 sub find_scope_st { ((find_scope(@_))[0]); } 1300 sub find_scope_en { ((find_scope(@_))[1]); } 1301 1302 # Recurses down the tree, looking for pad variable introductions and COPs 1303 sub find_scope { 1304 my ($self, $op, $scope_st, $scope_en) = @_; 1305 carp("Undefined op in find_scope") if !defined $op; 1306 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; 1307 1308 for (my $o=$op->first; $$o; $o=$o->sibling) { 1309 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { 1310 my $s = int($self->padname_sv($o->targ)->NVX); 1311 my $e = $self->padname_sv($o->targ)->IVX; 1312 $scope_st = $s if !defined($scope_st) || $s < $scope_st; 1313 $scope_en = $e if !defined($scope_en) || $e > $scope_en; 1314 } 1315 elsif (is_state($o)) { 1316 my $c = $o->cop_seq; 1317 $scope_st = $c if !defined($scope_st) || $c < $scope_st; 1318 $scope_en = $c if !defined($scope_en) || $c > $scope_en; 1319 } 1320 elsif ($o->flags & OPf_KIDS) { 1321 ($scope_st, $scope_en) = 1322 $self->find_scope($o, $scope_st, $scope_en) 1323 } 1324 } 1325 1326 return ($scope_st, $scope_en); 1327 } 1328 1329 # Returns a list of subs which should be inserted before the COP 1330 sub cop_subs { 1331 my ($self, $op, $out_seq) = @_; 1332 my $seq = $op->cop_seq; 1333 # If we have nephews, then our sequence number indicates 1334 # the cop_seq of the end of some sort of scope. 1335 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS 1336 and my $nseq = $self->find_scope_st($op->sibling) ) { 1337 $seq = $nseq; 1338 } 1339 $seq = $out_seq if defined($out_seq) && $out_seq < $seq; 1340 return $self->seq_subs($seq); 1341 } 1342 1343 sub seq_subs { 1344 my ($self, $seq) = @_; 1345 my @text; 1346 #push @text, "# ($seq)\n"; 1347 1348 return "" if !defined $seq; 1349 while (scalar(@{$self->{'subs_todo'}}) 1350 and $seq > $self->{'subs_todo'}[0][0]) { 1351 push @text, $self->next_todo; 1352 } 1353 return @text; 1354 } 1355 1356 # Notice how subs and formats are inserted between statements here; 1357 # also $[ assignments and pragmas. 1358 sub pp_nextstate { 1359 my $self = shift; 1360 my($op, $cx) = @_; 1361 $self->{'curcop'} = $op; 1362 my @text; 1363 push @text, $self->cop_subs($op); 1364 push @text, $op->label . ": " if $op->label; 1365 my $stash = $op->stashpv; 1366 if ($stash ne $self->{'curstash'}) { 1367 push @text, "package $stash;\n"; 1368 $self->{'curstash'} = $stash; 1369 } 1370 1371 if ($self->{'arybase'} != $op->arybase) { 1372 push @text, '$[ = '. $op->arybase .";\n"; 1373 $self->{'arybase'} = $op->arybase; 1374 } 1375 1376 my $warnings = $op->warnings; 1377 my $warning_bits; 1378 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { 1379 $warning_bits = $warnings::Bits{"all"} & WARN_MASK; 1380 } 1381 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { 1382 $warning_bits = $warnings::NONE; 1383 } 1384 elsif ($warnings->isa("B::SPECIAL")) { 1385 $warning_bits = undef; 1386 } 1387 else { 1388 $warning_bits = $warnings->PV & WARN_MASK; 1389 } 1390 1391 if (defined ($warning_bits) and 1392 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { 1393 push @text, declare_warnings($self->{'warnings'}, $warning_bits); 1394 $self->{'warnings'} = $warning_bits; 1395 } 1396 1397 if ($self->{'hints'} != $op->private) { 1398 push @text, declare_hints($self->{'hints'}, $op->private); 1399 $self->{'hints'} = $op->private; 1400 } 1401 1402 # This should go after of any branches that add statements, to 1403 # increase the chances that it refers to the same line it did in 1404 # the original program. 1405 if ($self->{'linenums'}) { 1406 push @text, "\f#line " . $op->line . 1407 ' "' . $op->file, qq'"\n'; 1408 } 1409 1410 return join("", @text); 1411 } 1412 1413 sub declare_warnings { 1414 my ($from, $to) = @_; 1415 if (($to & WARN_MASK) eq warnings::bits("all")) { 1416 return "use warnings;\n"; 1417 } 1418 elsif (($to & WARN_MASK) eq "\0"x length($to)) { 1419 return "no warnings;\n"; 1420 } 1421 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n"; 1422 } 1423 1424 sub declare_hints { 1425 my ($from, $to) = @_; 1426 my $use = $to & ~$from; 1427 my $no = $from & ~$to; 1428 my $decls = ""; 1429 for my $pragma (hint_pragmas($use)) { 1430 $decls .= "use $pragma;\n"; 1431 } 1432 for my $pragma (hint_pragmas($no)) { 1433 $decls .= "no $pragma;\n"; 1434 } 1435 return $decls; 1436 } 1437 1438 sub hint_pragmas { 1439 my ($bits) = @_; 1440 my @pragmas; 1441 push @pragmas, "integer" if $bits & 0x1; 1442 push @pragmas, "strict 'refs'" if $bits & 0x2; 1443 push @pragmas, "bytes" if $bits & 0x8; 1444 return @pragmas; 1445 } 1446 1447 sub pp_dbstate { pp_nextstate(@_) } 1448 sub pp_setstate { pp_nextstate(@_) } 1449 1450 sub pp_unstack { return "" } # see also leaveloop 1451 1452 sub baseop { 1453 my $self = shift; 1454 my($op, $cx, $name) = @_; 1455 return $name; 1456 } 1457 1458 sub pp_stub { 1459 my $self = shift; 1460 my($op, $cx, $name) = @_; 1461 if ($cx >= 1) { 1462 return "()"; 1463 } 1464 else { 1465 return "();"; 1466 } 1467 } 1468 sub pp_wantarray { baseop(@_, "wantarray") } 1469 sub pp_fork { baseop(@_, "fork") } 1470 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } 1471 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } 1472 sub pp_time { maybe_targmy(@_, \&baseop, "time") } 1473 sub pp_tms { baseop(@_, "times") } 1474 sub pp_ghostent { baseop(@_, "gethostent") } 1475 sub pp_gnetent { baseop(@_, "getnetent") } 1476 sub pp_gprotoent { baseop(@_, "getprotoent") } 1477 sub pp_gservent { baseop(@_, "getservent") } 1478 sub pp_ehostent { baseop(@_, "endhostent") } 1479 sub pp_enetent { baseop(@_, "endnetent") } 1480 sub pp_eprotoent { baseop(@_, "endprotoent") } 1481 sub pp_eservent { baseop(@_, "endservent") } 1482 sub pp_gpwent { baseop(@_, "getpwent") } 1483 sub pp_spwent { baseop(@_, "setpwent") } 1484 sub pp_epwent { baseop(@_, "endpwent") } 1485 sub pp_ggrent { baseop(@_, "getgrent") } 1486 sub pp_sgrent { baseop(@_, "setgrent") } 1487 sub pp_egrent { baseop(@_, "endgrent") } 1488 sub pp_getlogin { baseop(@_, "getlogin") } 1489 1490 sub POSTFIX () { 1 } 1491 1492 # I couldn't think of a good short name, but this is the category of 1493 # symbolic unary operators with interesting precedence 1494 1495 sub pfixop { 1496 my $self = shift; 1497 my($op, $cx, $name, $prec, $flags) = (@_, 0); 1498 my $kid = $op->first; 1499 $kid = $self->deparse($kid, $prec); 1500 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid", 1501 $cx, $prec); 1502 } 1503 1504 sub pp_preinc { pfixop(@_, "++", 23) } 1505 sub pp_predec { pfixop(@_, "--", 23) } 1506 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 1507 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 1508 sub pp_i_preinc { pfixop(@_, "++", 23) } 1509 sub pp_i_predec { pfixop(@_, "--", 23) } 1510 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 1511 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 1512 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } 1513 1514 sub pp_negate { maybe_targmy(@_, \&real_negate) } 1515 sub real_negate { 1516 my $self = shift; 1517 my($op, $cx) = @_; 1518 if ($op->first->name =~ /^(i_)?negate$/) { 1519 # avoid --$x 1520 $self->pfixop($op, $cx, "-", 21.5); 1521 } else { 1522 $self->pfixop($op, $cx, "-", 21); 1523 } 1524 } 1525 sub pp_i_negate { pp_negate(@_) } 1526 1527 sub pp_not { 1528 my $self = shift; 1529 my($op, $cx) = @_; 1530 if ($cx <= 4) { 1531 $self->pfixop($op, $cx, "not ", 4); 1532 } else { 1533 $self->pfixop($op, $cx, "!", 21); 1534 } 1535 } 1536 1537 sub unop { 1538 my $self = shift; 1539 my($op, $cx, $name) = @_; 1540 my $kid; 1541 if ($op->flags & OPf_KIDS) { 1542 $kid = $op->first; 1543 if (defined prototype("CORE::$name") 1544 && prototype("CORE::$name") =~ /^;?\*/ 1545 && $kid->name eq "rv2gv") { 1546 $kid = $kid->first; 1547 } 1548 1549 return $self->maybe_parens_unop($name, $kid, $cx); 1550 } else { 1551 return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); 1552 } 1553 } 1554 1555 sub pp_chop { maybe_targmy(@_, \&unop, "chop") } 1556 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } 1557 sub pp_schop { maybe_targmy(@_, \&unop, "chop") } 1558 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } 1559 sub pp_defined { unop(@_, "defined") } 1560 sub pp_undef { unop(@_, "undef") } 1561 sub pp_study { unop(@_, "study") } 1562 sub pp_ref { unop(@_, "ref") } 1563 sub pp_pos { maybe_local(@_, unop(@_, "pos")) } 1564 1565 sub pp_sin { maybe_targmy(@_, \&unop, "sin") } 1566 sub pp_cos { maybe_targmy(@_, \&unop, "cos") } 1567 sub pp_rand { maybe_targmy(@_, \&unop, "rand") } 1568 sub pp_srand { unop(@_, "srand") } 1569 sub pp_exp { maybe_targmy(@_, \&unop, "exp") } 1570 sub pp_log { maybe_targmy(@_, \&unop, "log") } 1571 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } 1572 sub pp_int { maybe_targmy(@_, \&unop, "int") } 1573 sub pp_hex { maybe_targmy(@_, \&unop, "hex") } 1574 sub pp_oct { maybe_targmy(@_, \&unop, "oct") } 1575 sub pp_abs { maybe_targmy(@_, \&unop, "abs") } 1576 1577 sub pp_length { maybe_targmy(@_, \&unop, "length") } 1578 sub pp_ord { maybe_targmy(@_, \&unop, "ord") } 1579 sub pp_chr { maybe_targmy(@_, \&unop, "chr") } 1580 1581 sub pp_each { unop(@_, "each") } 1582 sub pp_values { unop(@_, "values") } 1583 sub pp_keys { unop(@_, "keys") } 1584 sub pp_pop { unop(@_, "pop") } 1585 sub pp_shift { unop(@_, "shift") } 1586 1587 sub pp_caller { unop(@_, "caller") } 1588 sub pp_reset { unop(@_, "reset") } 1589 sub pp_exit { unop(@_, "exit") } 1590 sub pp_prototype { unop(@_, "prototype") } 1591 1592 sub pp_close { unop(@_, "close") } 1593 sub pp_fileno { unop(@_, "fileno") } 1594 sub pp_umask { unop(@_, "umask") } 1595 sub pp_untie { unop(@_, "untie") } 1596 sub pp_tied { unop(@_, "tied") } 1597 sub pp_dbmclose { unop(@_, "dbmclose") } 1598 sub pp_getc { unop(@_, "getc") } 1599 sub pp_eof { unop(@_, "eof") } 1600 sub pp_tell { unop(@_, "tell") } 1601 sub pp_getsockname { unop(@_, "getsockname") } 1602 sub pp_getpeername { unop(@_, "getpeername") } 1603 1604 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } 1605 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } 1606 sub pp_readlink { unop(@_, "readlink") } 1607 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } 1608 sub pp_readdir { unop(@_, "readdir") } 1609 sub pp_telldir { unop(@_, "telldir") } 1610 sub pp_rewinddir { unop(@_, "rewinddir") } 1611 sub pp_closedir { unop(@_, "closedir") } 1612 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } 1613 sub pp_localtime { unop(@_, "localtime") } 1614 sub pp_gmtime { unop(@_, "gmtime") } 1615 sub pp_alarm { unop(@_, "alarm") } 1616 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } 1617 1618 sub pp_dofile { unop(@_, "do") } 1619 sub pp_entereval { unop(@_, "eval") } 1620 1621 sub pp_ghbyname { unop(@_, "gethostbyname") } 1622 sub pp_gnbyname { unop(@_, "getnetbyname") } 1623 sub pp_gpbyname { unop(@_, "getprotobyname") } 1624 sub pp_shostent { unop(@_, "sethostent") } 1625 sub pp_snetent { unop(@_, "setnetent") } 1626 sub pp_sprotoent { unop(@_, "setprotoent") } 1627 sub pp_sservent { unop(@_, "setservent") } 1628 sub pp_gpwnam { unop(@_, "getpwnam") } 1629 sub pp_gpwuid { unop(@_, "getpwuid") } 1630 sub pp_ggrnam { unop(@_, "getgrnam") } 1631 sub pp_ggrgid { unop(@_, "getgrgid") } 1632 1633 sub pp_lock { unop(@_, "lock") } 1634 1635 sub pp_exists { 1636 my $self = shift; 1637 my($op, $cx) = @_; 1638 my $arg; 1639 if ($op->private & OPpEXISTS_SUB) { 1640 # Checking for the existence of a subroutine 1641 return $self->maybe_parens_func("exists", 1642 $self->pp_rv2cv($op->first, 16), $cx, 16); 1643 } 1644 if ($op->flags & OPf_SPECIAL) { 1645 # Array element, not hash element 1646 return $self->maybe_parens_func("exists", 1647 $self->pp_aelem($op->first, 16), $cx, 16); 1648 } 1649 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16), 1650 $cx, 16); 1651 } 1652 1653 sub pp_delete { 1654 my $self = shift; 1655 my($op, $cx) = @_; 1656 my $arg; 1657 if ($op->private & OPpSLICE) { 1658 if ($op->flags & OPf_SPECIAL) { 1659 # Deleting from an array, not a hash 1660 return $self->maybe_parens_func("delete", 1661 $self->pp_aslice($op->first, 16), 1662 $cx, 16); 1663 } 1664 return $self->maybe_parens_func("delete", 1665 $self->pp_hslice($op->first, 16), 1666 $cx, 16); 1667 } else { 1668 if ($op->flags & OPf_SPECIAL) { 1669 # Deleting from an array, not a hash 1670 return $self->maybe_parens_func("delete", 1671 $self->pp_aelem($op->first, 16), 1672 $cx, 16); 1673 } 1674 return $self->maybe_parens_func("delete", 1675 $self->pp_helem($op->first, 16), 1676 $cx, 16); 1677 } 1678 } 1679 1680 sub pp_require { 1681 my $self = shift; 1682 my($op, $cx) = @_; 1683 if (class($op) eq "UNOP" and $op->first->name eq "const" 1684 and $op->first->private & OPpCONST_BARE) 1685 { 1686 my $name = $self->const_sv($op->first)->PV; 1687 $name =~ s[/][::]g; 1688 $name =~ s/\.pm//g; 1689 return "require $name"; 1690 } else { 1691 $self->unop($op, $cx, "require"); 1692 } 1693 } 1694 1695 sub pp_scalar { 1696 my $self = shift; 1697 my($op, $cv) = @_; 1698 my $kid = $op->first; 1699 if (not null $kid->sibling) { 1700 # XXX Was a here-doc 1701 return $self->dquote($op); 1702 } 1703 $self->unop(@_, "scalar"); 1704 } 1705 1706 1707 sub padval { 1708 my $self = shift; 1709 my $targ = shift; 1710 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); 1711 } 1712 1713 sub pp_refgen { 1714 my $self = shift; 1715 my($op, $cx) = @_; 1716 my $kid = $op->first; 1717 if ($kid->name eq "null") { 1718 $kid = $kid->first; 1719 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { 1720 my($pre, $post) = @{{"anonlist" => ["[","]"], 1721 "anonhash" => ["{","}"]}->{$kid->name}}; 1722 my($expr, @exprs); 1723 $kid = $kid->first->sibling; # skip pushmark 1724 for (; !null($kid); $kid = $kid->sibling) { 1725 $expr = $self->deparse($kid, 6); 1726 push @exprs, $expr; 1727 } 1728 return $pre . join(", ", @exprs) . $post; 1729 } elsif (!null($kid->sibling) and 1730 $kid->sibling->name eq "anoncode") { 1731 return "sub " . 1732 $self->deparse_sub($self->padval($kid->sibling->targ)); 1733 } elsif ($kid->name eq "pushmark") { 1734 my $sib_name = $kid->sibling->name; 1735 if ($sib_name =~ /^(pad|rv2)[ah]v$/ 1736 and not $kid->sibling->flags & OPf_REF) 1737 { 1738 # The @a in \(@a) isn't in ref context, but only when the 1739 # parens are there. 1740 return "\\(" . $self->pp_list($op->first) . ")"; 1741 } elsif ($sib_name eq 'entersub') { 1742 my $text = $self->deparse($kid->sibling, 1); 1743 # Always show parens for \(&func()), but only with -p otherwise 1744 $text = "($text)" if $self->{'parens'} 1745 or $kid->sibling->private & OPpENTERSUB_AMPER; 1746 return "\\$text"; 1747 } 1748 } 1749 } 1750 $self->pfixop($op, $cx, "\\", 20); 1751 } 1752 1753 sub pp_srefgen { pp_refgen(@_) } 1754 1755 sub pp_readline { 1756 my $self = shift; 1757 my($op, $cx) = @_; 1758 my $kid = $op->first; 1759 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> 1760 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid); 1761 return $self->unop($op, $cx, "readline"); 1762 } 1763 1764 sub pp_rcatline { 1765 my $self = shift; 1766 my($op) = @_; 1767 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; 1768 } 1769 1770 # Unary operators that can occur as pseudo-listops inside double quotes 1771 sub dq_unop { 1772 my $self = shift; 1773 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); 1774 my $kid; 1775 if ($op->flags & OPf_KIDS) { 1776 $kid = $op->first; 1777 # If there's more than one kid, the first is an ex-pushmark. 1778 $kid = $kid->sibling if not null $kid->sibling; 1779 return $self->maybe_parens_unop($name, $kid, $cx); 1780 } else { 1781 return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); 1782 } 1783 } 1784 1785 sub pp_ucfirst { dq_unop(@_, "ucfirst") } 1786 sub pp_lcfirst { dq_unop(@_, "lcfirst") } 1787 sub pp_uc { dq_unop(@_, "uc") } 1788 sub pp_lc { dq_unop(@_, "lc") } 1789 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } 1790 1791 sub loopex { 1792 my $self = shift; 1793 my ($op, $cx, $name) = @_; 1794 if (class($op) eq "PVOP") { 1795 return "$name " . $op->pv; 1796 } elsif (class($op) eq "OP") { 1797 return $name; 1798 } elsif (class($op) eq "UNOP") { 1799 # Note -- loop exits are actually exempt from the 1800 # looks-like-a-func rule, but a few extra parens won't hurt 1801 return $self->maybe_parens_unop($name, $op->first, $cx); 1802 } 1803 } 1804 1805 sub pp_last { loopex(@_, "last") } 1806 sub pp_next { loopex(@_, "next") } 1807 sub pp_redo { loopex(@_, "redo") } 1808 sub pp_goto { loopex(@_, "goto") } 1809 sub pp_dump { loopex(@_, "dump") } 1810 1811 sub ftst { 1812 my $self = shift; 1813 my($op, $cx, $name) = @_; 1814 if (class($op) eq "UNOP") { 1815 # Genuine `-X' filetests are exempt from the LLAFR, but not 1816 # l?stat(); for the sake of clarity, give'em all parens 1817 return $self->maybe_parens_unop($name, $op->first, $cx); 1818 } elsif (class($op) =~ /^(SV|PAD)OP$/) { 1819 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); 1820 } else { # I don't think baseop filetests ever survive ck_ftst, but... 1821 return $name; 1822 } 1823 } 1824 1825 sub pp_lstat { ftst(@_, "lstat") } 1826 sub pp_stat { ftst(@_, "stat") } 1827 sub pp_ftrread { ftst(@_, "-R") } 1828 sub pp_ftrwrite { ftst(@_, "-W") } 1829 sub pp_ftrexec { ftst(@_, "-X") } 1830 sub pp_fteread { ftst(@_, "-r") } 1831 sub pp_ftewrite { ftst(@_, "-w") } 1832 sub pp_fteexec { ftst(@_, "-x") } 1833 sub pp_ftis { ftst(@_, "-e") } 1834 sub pp_fteowned { ftst(@_, "-O") } 1835 sub pp_ftrowned { ftst(@_, "-o") } 1836 sub pp_ftzero { ftst(@_, "-z") } 1837 sub pp_ftsize { ftst(@_, "-s") } 1838 sub pp_ftmtime { ftst(@_, "-M") } 1839 sub pp_ftatime { ftst(@_, "-A") } 1840 sub pp_ftctime { ftst(@_, "-C") } 1841 sub pp_ftsock { ftst(@_, "-S") } 1842 sub pp_ftchr { ftst(@_, "-c") } 1843 sub pp_ftblk { ftst(@_, "-b") } 1844 sub pp_ftfile { ftst(@_, "-f") } 1845 sub pp_ftdir { ftst(@_, "-d") } 1846 sub pp_ftpipe { ftst(@_, "-p") } 1847 sub pp_ftlink { ftst(@_, "-l") } 1848 sub pp_ftsuid { ftst(@_, "-u") } 1849 sub pp_ftsgid { ftst(@_, "-g") } 1850 sub pp_ftsvtx { ftst(@_, "-k") } 1851 sub pp_fttty { ftst(@_, "-t") } 1852 sub pp_fttext { ftst(@_, "-T") } 1853 sub pp_ftbinary { ftst(@_, "-B") } 1854 1855 sub SWAP_CHILDREN () { 1 } 1856 sub ASSIGN () { 2 } # has OP= variant 1857 sub LIST_CONTEXT () { 4 } # Assignment is in list context 1858 1859 my(%left, %right); 1860 1861 sub assoc_class { 1862 my $op = shift; 1863 my $name = $op->name; 1864 if ($name eq "concat" and $op->first->name eq "concat") { 1865 # avoid spurious `=' -- see comment in pp_concat 1866 return "concat"; 1867 } 1868 if ($name eq "null" and class($op) eq "UNOP" 1869 and $op->first->name =~ /^(and|x?or)$/ 1870 and null $op->first->sibling) 1871 { 1872 # Like all conditional constructs, OP_ANDs and OP_ORs are topped 1873 # with a null that's used as the common end point of the two 1874 # flows of control. For precedence purposes, ignore it. 1875 # (COND_EXPRs have these too, but we don't bother with 1876 # their associativity). 1877 return assoc_class($op->first); 1878 } 1879 return $name . ($op->flags & OPf_STACKED ? "=" : ""); 1880 } 1881 1882 # Left associative operators, like `+', for which 1883 # $a + $b + $c is equivalent to ($a + $b) + $c 1884 1885 BEGIN { 1886 %left = ('multiply' => 19, 'i_multiply' => 19, 1887 'divide' => 19, 'i_divide' => 19, 1888 'modulo' => 19, 'i_modulo' => 19, 1889 'repeat' => 19, 1890 'add' => 18, 'i_add' => 18, 1891 'subtract' => 18, 'i_subtract' => 18, 1892 'concat' => 18, 1893 'left_shift' => 17, 'right_shift' => 17, 1894 'bit_and' => 13, 1895 'bit_or' => 12, 'bit_xor' => 12, 1896 'and' => 3, 1897 'or' => 2, 'xor' => 2, 1898 ); 1899 } 1900 1901 sub deparse_binop_left { 1902 my $self = shift; 1903 my($op, $left, $prec) = @_; 1904 if ($left{assoc_class($op)} && $left{assoc_class($left)} 1905 and $left{assoc_class($op)} == $left{assoc_class($left)}) 1906 { 1907 return $self->deparse($left, $prec - .00001); 1908 } else { 1909 return $self->deparse($left, $prec); 1910 } 1911 } 1912 1913 # Right associative operators, like `=', for which 1914 # $a = $b = $c is equivalent to $a = ($b = $c) 1915 1916 BEGIN { 1917 %right = ('pow' => 22, 1918 'sassign=' => 7, 'aassign=' => 7, 1919 'multiply=' => 7, 'i_multiply=' => 7, 1920 'divide=' => 7, 'i_divide=' => 7, 1921 'modulo=' => 7, 'i_modulo=' => 7, 1922 'repeat=' => 7, 1923 'add=' => 7, 'i_add=' => 7, 1924 'subtract=' => 7, 'i_subtract=' => 7, 1925 'concat=' => 7, 1926 'left_shift=' => 7, 'right_shift=' => 7, 1927 'bit_and=' => 7, 1928 'bit_or=' => 7, 'bit_xor=' => 7, 1929 'andassign' => 7, 1930 'orassign' => 7, 1931 ); 1932 } 1933 1934 sub deparse_binop_right { 1935 my $self = shift; 1936 my($op, $right, $prec) = @_; 1937 if ($right{assoc_class($op)} && $right{assoc_class($right)} 1938 and $right{assoc_class($op)} == $right{assoc_class($right)}) 1939 { 1940 return $self->deparse($right, $prec - .00001); 1941 } else { 1942 return $self->deparse($right, $prec); 1943 } 1944 } 1945 1946 sub binop { 1947 my $self = shift; 1948 my ($op, $cx, $opname, $prec, $flags) = (@_, 0); 1949 my $left = $op->first; 1950 my $right = $op->last; 1951 my $eq = ""; 1952 if ($op->flags & OPf_STACKED && $flags & ASSIGN) { 1953 $eq = "="; 1954 $prec = 7; 1955 } 1956 if ($flags & SWAP_CHILDREN) { 1957 ($left, $right) = ($right, $left); 1958 } 1959 $left = $self->deparse_binop_left($op, $left, $prec); 1960 $left = "($left)" if $flags & LIST_CONTEXT 1961 && $left !~ /^(my|our|local|)[\@\(]/; 1962 $right = $self->deparse_binop_right($op, $right, $prec); 1963 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); 1964 } 1965 1966 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 1967 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 1968 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } 1969 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 1970 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 1971 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 1972 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 1973 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } 1974 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 1975 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 1976 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } 1977 1978 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } 1979 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } 1980 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } 1981 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } 1982 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } 1983 1984 sub pp_eq { binop(@_, "==", 14) } 1985 sub pp_ne { binop(@_, "!=", 14) } 1986 sub pp_lt { binop(@_, "<", 15) } 1987 sub pp_gt { binop(@_, ">", 15) } 1988 sub pp_ge { binop(@_, ">=", 15) } 1989 sub pp_le { binop(@_, "<=", 15) } 1990 sub pp_ncmp { binop(@_, "<=>", 14) } 1991 sub pp_i_eq { binop(@_, "==", 14) } 1992 sub pp_i_ne { binop(@_, "!=", 14) } 1993 sub pp_i_lt { binop(@_, "<", 15) } 1994 sub pp_i_gt { binop(@_, ">", 15) } 1995 sub pp_i_ge { binop(@_, ">=", 15) } 1996 sub pp_i_le { binop(@_, "<=", 15) } 1997 sub pp_i_ncmp { binop(@_, "<=>", 14) } 1998 1999 sub pp_seq { binop(@_, "eq", 14) } 2000 sub pp_sne { binop(@_, "ne", 14) } 2001 sub pp_slt { binop(@_, "lt", 15) } 2002 sub pp_sgt { binop(@_, "gt", 15) } 2003 sub pp_sge { binop(@_, "ge", 15) } 2004 sub pp_sle { binop(@_, "le", 15) } 2005 sub pp_scmp { binop(@_, "cmp", 14) } 2006 2007 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } 2008 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } 2009 2010 # `.' is special because concats-of-concats are optimized to save copying 2011 # by making all but the first concat stacked. The effect is as if the 2012 # programmer had written `($a . $b) .= $c', except legal. 2013 sub pp_concat { maybe_targmy(@_, \&real_concat) } 2014 sub real_concat { 2015 my $self = shift; 2016 my($op, $cx) = @_; 2017 my $left = $op->first; 2018 my $right = $op->last; 2019 my $eq = ""; 2020 my $prec = 18; 2021 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { 2022 $eq = "="; 2023 $prec = 7; 2024 } 2025 $left = $self->deparse_binop_left($op, $left, $prec); 2026 $right = $self->deparse_binop_right($op, $right, $prec); 2027 return $self->maybe_parens("$left .$eq $right", $cx, $prec); 2028 } 2029 2030 # `x' is weird when the left arg is a list 2031 sub pp_repeat { 2032 my $self = shift; 2033 my($op, $cx) = @_; 2034 my $left = $op->first; 2035 my $right = $op->last; 2036 my $eq = ""; 2037 my $prec = 19; 2038 if ($op->flags & OPf_STACKED) { 2039 $eq = "="; 2040 $prec = 7; 2041 } 2042 if (null($right)) { # list repeat; count is inside left-side ex-list 2043 my $kid = $left->first->sibling; # skip pushmark 2044 my @exprs; 2045 for (; !null($kid->sibling); $kid = $kid->sibling) { 2046 push @exprs, $self->deparse($kid, 6); 2047 } 2048 $right = $kid; 2049 $left = "(" . join(", ", @exprs). ")"; 2050 } else { 2051 $left = $self->deparse_binop_left($op, $left, $prec); 2052 } 2053 $right = $self->deparse_binop_right($op, $right, $prec); 2054 return $self->maybe_parens("$left x$eq $right", $cx, $prec); 2055 } 2056 2057 sub range { 2058 my $self = shift; 2059 my ($op, $cx, $type) = @_; 2060 my $left = $op->first; 2061 my $right = $left->sibling; 2062 $left = $self->deparse($left, 9); 2063 $right = $self->deparse($right, 9); 2064 return $self->maybe_parens("$left $type $right", $cx, 9); 2065 } 2066 2067 sub pp_flop { 2068 my $self = shift; 2069 my($op, $cx) = @_; 2070 my $flip = $op->first; 2071 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; 2072 return $self->range($flip->first, $cx, $type); 2073 } 2074 2075 # one-line while/until is handled in pp_leave 2076 2077 sub logop { 2078 my $self = shift; 2079 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; 2080 my $left = $op->first; 2081 my $right = $op->first->sibling; 2082 if ($cx < 1 and is_scope($right) and $blockname 2083 and $self->{'expand'} < 7) 2084 { # if ($a) {$b} 2085 $left = $self->deparse($left, 1); 2086 $right = $self->deparse($right, 0); 2087 return "$blockname ($left) {\n\t$right\n\b}\cK"; 2088 } elsif ($cx < 1 and $blockname and not $self->{'parens'} 2089 and $self->{'expand'} < 7) { # $b if $a 2090 $right = $self->deparse($right, 1); 2091 $left = $self->deparse($left, 1); 2092 return "$right $blockname $left"; 2093 } elsif ($cx > $lowprec and $highop) { # $a && $b 2094 $left = $self->deparse_binop_left($op, $left, $highprec); 2095 $right = $self->deparse_binop_right($op, $right, $highprec); 2096 return $self->maybe_parens("$left $highop $right", $cx, $highprec); 2097 } else { # $a and $b 2098 $left = $self->deparse_binop_left($op, $left, $lowprec); 2099 $right = $self->deparse_binop_right($op, $right, $lowprec); 2100 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); 2101 } 2102 } 2103 2104 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } 2105 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } 2106 sub pp_dor { logop(@_, "err", 2, "//", 10, "") } 2107 2108 # xor is syntactically a logop, but it's really a binop (contrary to 2109 # old versions of opcode.pl). Syntax is what matters here. 2110 sub pp_xor { logop(@_, "xor", 2, "", 0, "") } 2111 2112 sub logassignop { 2113 my $self = shift; 2114 my ($op, $cx, $opname) = @_; 2115 my $left = $op->first; 2116