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 $