| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # B::Deparse.pm 2 # Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant. 3 # All rights reserved. 4 # This module is free software; you can redistribute and/or modify 5 # it under the same terms as Perl itself. 6 7 # This is based on the module of the same name by Malcolm Beattie, 8 # but essentially none of his code remains. 9 10 package B::Deparse; 11 use Carp; 12 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring 13 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST 14 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE 15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE 16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY 17 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER 18 OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED 19 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG 20 CVf_METHOD CVf_LOCKED CVf_LVALUE 21 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE 22 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED), 23 ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'); 24 $VERSION = 0.83; 25 use strict; 26 use vars qw/$AUTOLOAD/; 27 use warnings (); 28 29 # Changes between 0.50 and 0.51: 30 # - fixed nulled leave with live enter in sort { } 31 # - fixed reference constants (\"str") 32 # - handle empty programs gracefully 33 # - handle infinte loops (for (;;) {}, while (1) {}) 34 # - differentiate between `for my $x ...' and `my $x; for $x ...' 35 # - various minor cleanups 36 # - moved globals into an object 37 # - added `-u', like B::C 38 # - package declarations using cop_stash 39 # - subs, formats and code sorted by cop_seq 40 # Changes between 0.51 and 0.52: 41 # - added pp_threadsv (special variables under USE_5005THREADS) 42 # - added documentation 43 # Changes between 0.52 and 0.53: 44 # - many changes adding precedence contexts and associativity 45 # - added `-p' and `-s' output style options 46 # - various other minor fixes 47 # Changes between 0.53 and 0.54: 48 # - added support for new `for (1..100)' optimization, 49 # thanks to Gisle Aas 50 # Changes between 0.54 and 0.55: 51 # - added support for new qr// construct 52 # - added support for new pp_regcreset OP 53 # Changes between 0.55 and 0.56: 54 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t 55 # - fixed $# on non-lexicals broken in last big rewrite 56 # - added temporary fix for change in opcode of OP_STRINGIFY 57 # - fixed problem in 0.54's for() patch in `for (@ary)' 58 # - fixed precedence in conditional of ?: 59 # - tweaked list paren elimination in `my($x) = @_' 60 # - made continue-block detection trickier wrt. null ops 61 # - fixed various prototype problems in pp_entersub 62 # - added support for sub prototypes that never get GVs 63 # - added unquoting for special filehandle first arg in truncate 64 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' 65 # - added semicolons at the ends of blocks 66 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 67 # Changes between 0.56 and 0.561: 68 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) 69 # - used new B.pm symbolic constants (done by Nick Ing-Simmons) 70 # Changes between 0.561 and 0.57: 71 # - stylistic changes to symbolic constant stuff 72 # - handled scope in s///e replacement code 73 # - added unquote option for expanding "" into concats, etc. 74 # - split method and proto parts of pp_entersub into separate functions 75 # - various minor cleanups 76 # Changes after 0.57: 77 # - added parens in \&foo (patch by Albert Dvornik) 78 # Changes between 0.57 and 0.58: 79 # - fixed `0' statements that weren't being printed 80 # - added methods for use from other programs 81 # (based on patches from James Duncan and Hugo van der Sanden) 82 # - added -si and -sT to control indenting (also based on a patch from Hugo) 83 # - added -sv to print something else instead of '???' 84 # - preliminary version of utf8 tr/// handling 85 # Changes after 0.58: 86 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy) 87 # - added support for Hugo's new OP_SETSTATE (like nextstate) 88 # Changes between 0.58 and 0.59 89 # - added support for Chip's OP_METHOD_NAMED 90 # - added support for Ilya's OPpTARGET_MY optimization 91 # - elided arrows before `()' subscripts when possible 92 # Changes between 0.59 and 0.60 93 # - support for method attribues was added 94 # - some warnings fixed 95 # - separate recognition of constant subs 96 # - rewrote continue block handling, now recoginizing for loops 97 # - added more control of expanding control structures 98 # Changes between 0.60 and 0.61 (mostly by Robin Houston) 99 # - many bug-fixes 100 # - support for pragmas and 'use' 101 # - support for the little-used $[ variable 102 # - support for __DATA__ sections 103 # - UTF8 support 104 # - BEGIN, CHECK, INIT and END blocks 105 # - scoping of subroutine declarations fixed 106 # - compile-time output from the input program can be suppressed, so that the 107 # output is just the deparsed code. (a change to O.pm in fact) 108 # - our() declarations 109 # - *all* the known bugs are now listed in the BUGS section 110 # - comprehensive test mechanism (TEST -deparse) 111 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) 112 # - bug-fixes 113 # - new switch -P 114 # - support for command-line switches (-l, -0, etc.) 115 # Changes between 0.63 and 0.64 116 # - support for //, CHECK blocks, and assertions 117 # - improved handling of foreach loops and lexicals 118 # - option to use Data::Dumper for constants 119 # - more bug fixes 120 # - discovered lots more bugs not yet fixed 121 # 122 # ... 123 # 124 # Changes between 0.72 and 0.73 125 # - support new switch constructs 126 127 # Todo: 128 # (See also BUGS section at the end of this file) 129 # 130 # - finish tr/// changes 131 # - add option for even more parens (generalize \&foo change) 132 # - left/right context 133 # - copy comments (look at real text with $^P?) 134 # - avoid semis in one-statement blocks 135 # - associativity of &&=, ||=, ?: 136 # - ',' => '=>' (auto-unquote?) 137 # - break long lines ("\r" as discretionary break?) 138 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc. 139 # - more style options: brace style, hex vs. octal, quotes, ... 140 # - print big ints as hex/octal instead of decimal (heuristic?) 141 # - handle `my $x if 0'? 142 # - version using op_next instead of op_first/sibling? 143 # - avoid string copies (pass arrays, one big join?) 144 # - here-docs? 145 146 # Current test.deparse failures 147 # comp/hints 6 - location of BEGIN blocks wrt. block openings 148 # run/switchI 1 - missing -I switches entirely 149 # perl -Ifoo -e 'print @INC' 150 # op/caller 2 - warning mask propagates backwards before warnings::register 151 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' 152 # op/getpid 2 - can't assign to shared my() declaration (threads only) 153 # 'my $x : shared = 5' 154 # op/override 7 - parens on overriden require change v-string interpretation 155 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' 156 # c.f. 'BEGIN { *f = sub {0} }; f 2' 157 # op/pat 774 - losing Unicode-ness of Latin1-only strings 158 # 'use charnames ":short"; $x="\N{latin:a with acute}"' 159 # op/recurse 12 - missing parens on recursive call makes it look like method 160 # 'sub f { f($x) }' 161 # op/subst 90 - inconsistent handling of utf8 under "use utf8" 162 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open 163 # op/tiehandle compile - "use strict" deparsed in the wrong place 164 # uni/tr_ several 165 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs 166 # ext/Data/Dumper/t/dumper compile 167 # ext/DB_file/several 168 # ext/Encode/several 169 # ext/Ernno/Errno warnings 170 # ext/IO/lib/IO/t/io_sel 23 171 # ext/PerlIO/t/encoding compile 172 # ext/POSIX/t/posix 6 173 # ext/Socket/Socket 8 174 # ext/Storable/t/croak compile 175 # lib/Attribute/Handlers/t/multi compile 176 # lib/bignum/ several 177 # lib/charnames 35 178 # lib/constant 32 179 # lib/English 40 180 # lib/ExtUtils/t/bytes 4 181 # lib/File/DosGlob compile 182 # lib/Filter/Simple/t/data 1 183 # lib/Math/BigInt/t/constant 1 184 # lib/Net/t/config Deparse-warning 185 # lib/overload compile 186 # lib/Switch/ several 187 # lib/Symbol 4 188 # lib/Test/Simple several 189 # lib/Term/Complete 190 # lib/Tie/File/t/29_downcopy 5 191 # lib/vars 22 192 193 # Object fields (were globals): 194 # 195 # avoid_local: 196 # (local($a), local($b)) and local($a, $b) have the same internal 197 # representation but the short form looks better. We notice we can 198 # use a large-scale local when checking the list, but need to prevent 199 # individual locals too. This hash holds the addresses of OPs that 200 # have already had their local-ness accounted for. The same thing 201 # is done with my(). 202 # 203 # curcv: 204 # CV for current sub (or main program) being deparsed 205 # 206 # curcvlex: 207 # Cached hash of lexical variables for curcv: keys are names, 208 # each value is an array of pairs, indicating the cop_seq of scopes 209 # in which a var of that name is valid. 210 # 211 # curcop: 212 # COP for statement being deparsed 213 # 214 # curstash: 215 # name of the current package for deparsed code 216 # 217 # subs_todo: 218 # array of [cop_seq, CV, is_format?] for subs and formats we still 219 # want to deparse 220 # 221 # protos_todo: 222 # as above, but [name, prototype] for subs that never got a GV 223 # 224 # subs_done, forms_done: 225 # keys are addresses of GVs for subs and formats we've already 226 # deparsed (or at least put into subs_todo) 227 # 228 # subs_declared 229 # keys are names of subs for which we've printed declarations. 230 # That means we can omit parentheses from the arguments. 231 # 232 # subs_deparsed 233 # Keeps track of fully qualified names of all deparsed subs. 234 # 235 # parens: -p 236 # linenums: -l 237 # unquote: -q 238 # cuddle: ` ' or `\n', depending on -sC 239 # indent_size: -si 240 # use_tabs: -sT 241 # ex_const: -sv 242 243 # A little explanation of how precedence contexts and associativity 244 # work: 245 # 246 # deparse() calls each per-op subroutine with an argument $cx (short 247 # for context, but not the same as the cx* in the perl core), which is 248 # a number describing the op's parents in terms of precedence, whether 249 # they're inside an expression or at statement level, etc. (see 250 # chart below). When ops with children call deparse on them, they pass 251 # along their precedence. Fractional values are used to implement 252 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related 253 # parentheses hacks. The major disadvantage of this scheme is that 254 # it doesn't know about right sides and left sides, so say if you 255 # assign a listop to a variable, it can't tell it's allowed to leave 256 # the parens off the listop. 257 258 # Precedences: 259 # 26 [TODO] inside interpolation context ("") 260 # 25 left terms and list operators (leftward) 261 # 24 left -> 262 # 23 nonassoc ++ -- 263 # 22 right ** 264 # 21 right ! ~ \ and unary + and - 265 # 20 left =~ !~ 266 # 19 left * / % x 267 # 18 left + - . 268 # 17 left << >> 269 # 16 nonassoc named unary operators 270 # 15 nonassoc < > <= >= lt gt le ge 271 # 14 nonassoc == != <=> eq ne cmp 272 # 13 left & 273 # 12 left | ^ 274 # 11 left && 275 # 10 left || 276 # 9 nonassoc .. ... 277 # 8 right ?: 278 # 7 right = += -= *= etc. 279 # 6 left , => 280 # 5 nonassoc list operators (rightward) 281 # 4 right not 282 # 3 left and 283 # 2 left or xor 284 # 1 statement modifiers 285 # 0.5 statements, but still print scopes as do { ... } 286 # 0 statement level 287 288 # Nonprinting characters with special meaning: 289 # \cS - steal parens (see maybe_parens_unop) 290 # \n - newline and indent 291 # \t - increase indent 292 # \b - decrease indent (`outdent') 293 # \f - flush left (no indent) 294 # \cK - kill following semicolon, if any 295 296 sub null { 297 my $op = shift; 298 return class($op) eq "NULL"; 299 } 300 301 sub todo { 302 my $self = shift; 303 my($cv, $is_form) = @_; 304 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE}); 305 my $seq; 306 if ($cv->OUTSIDE_SEQ) { 307 $seq = $cv->OUTSIDE_SEQ; 308 } elsif (!null($cv->START) and is_state($cv->START)) { 309 $seq = $cv->START->cop_seq; 310 } else { 311 $seq = 0; 312 } 313 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form]; 314 unless ($is_form || class($cv->STASH) eq 'SPECIAL') { 315 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1; 316 } 317 } 318 319 sub next_todo { 320 my $self = shift; 321 my $ent = shift @{$self->{'subs_todo'}}; 322 my $cv = $ent->[1]; 323 my $gv = $cv->GV; 324 my $name = $self->gv_name($gv); 325 if ($ent->[2]) { 326 return "format $name =\n" 327 . $self->deparse_format($ent->[1]). "\n"; 328 } else { 329 $self->{'subs_declared'}{$name} = 1; 330 if ($name eq "BEGIN") { 331 my $use_dec = $self->begin_is_use($cv); 332 if (defined ($use_dec) and $self->{'expand'} < 5) { 333 return () if 0 == length($use_dec); 334 return $use_dec; 335 } 336 } 337 my $l = ''; 338 if ($self->{'linenums'}) { 339 my $line = $gv->LINE; 340 my $file = $gv->FILE; 341 $l = "\n\f#line $line \"$file\"\n"; 342 } 343 my $p = ''; 344 if (class($cv->STASH) ne "SPECIAL") { 345 my $stash = $cv->STASH->NAME; 346 if ($stash ne $self->{'curstash'}) { 347 $p = "package $stash;\n"; 348 $name = "$self->{'curstash'}::$name" unless $name =~ /::/; 349 $self->{'curstash'} = $stash; 350 } 351 $name =~ s/^\Q$stash\E::(?!\z|.*::)//; 352 } 353 return "$p}$l}sub $name " . $self->deparse_sub($cv); 354 } 355 } 356 357 # Return a "use" declaration for this BEGIN block, if appropriate 358 sub begin_is_use { 359 my ($self, $cv) = @_; 360 my $root = $cv->ROOT; 361 local @$self{qw'curcv curcvlex'} = ($cv); 362 #require B::Debug; 363 #B::walkoptree($cv->ROOT, "debug"); 364 my $lineseq = $root->first; 365 return if $lineseq->name ne "lineseq"; 366 367 my $req_op = $lineseq->first->sibling; 368 return if $req_op->name ne "require"; 369 370 my $module; 371 if ($req_op->first->private & OPpCONST_BARE) { 372 # Actually it should always be a bareword 373 $module = $self->const_sv($req_op->first)->PV; 374 $module =~ s[/][::]g; 375 $module =~ s/.pm$//; 376 } 377 else { 378 $module = $self->const($self->const_sv($req_op->first), 6); 379 } 380 381 my $version; 382 my $version_op = $req_op->sibling; 383 return if class($version_op) eq "NULL"; 384 if ($version_op->name eq "lineseq") { 385 # We have a version parameter; skip nextstate & pushmark 386 my $constop = $version_op->first->next->next; 387 388 return unless $self->const_sv($constop)->PV eq $module; 389 $constop = $constop->sibling; 390 $version = $self->const_sv($constop); 391 if (class($version) eq "IV") { 392 $version = $version->int_value; 393 } elsif (class($version) eq "NV") { 394 $version = $version->NV; 395 } elsif (class($version) ne "PVMG") { 396 # Includes PVIV and PVNV 397 $version = $version->PV; 398 } else { 399 # version specified as a v-string 400 $version = 'v'.join '.', map ord, split //, $version->PV; 401 } 402 $constop = $constop->sibling; 403 return if $constop->name ne "method_named"; 404 return if $self->const_sv($constop)->PV ne "VERSION"; 405 } 406 407 $lineseq = $version_op->sibling; 408 return if $lineseq->name ne "lineseq"; 409 my $entersub = $lineseq->first->sibling; 410 if ($entersub->name eq "stub") { 411 return "use $module $version ();\n" if defined $version; 412 return "use $module ();\n"; 413 } 414 return if $entersub->name ne "entersub"; 415 416 # See if there are import arguments 417 my $args = ''; 418 419 my $svop = $entersub->first->sibling; # Skip over pushmark 420 return unless $self->const_sv($svop)->PV eq $module; 421 422 # Pull out the arguments 423 for ($svop=$svop->sibling; $svop->name ne "method_named"; 424 $svop = $svop->sibling) { 425 $args .= ", " if length($args); 426 $args .= $self->deparse($svop, 6); 427 } 428 429 my $use = 'use'; 430 my $method_named = $svop; 431 return if $method_named->name ne "method_named"; 432 my $method_name = $self->const_sv($method_named)->PV; 433 434 if ($method_name eq "unimport") { 435 $use = 'no'; 436 } 437 438 # Certain pragmas are dealt with using hint bits, 439 # so we ignore them here 440 if ($module eq 'strict' || $module eq 'integer' 441 || $module eq 'bytes' || $module eq 'warnings' 442 || $module eq 'feature') { 443 return ""; 444 } 445 446 if (defined $version && length $args) { 447 return "$use $module $version ($args);\n"; 448 } elsif (defined $version) { 449 return "$use $module $version;\n"; 450 } elsif (length $args) { 451 return "$use $module ($args);\n"; 452 } else { 453 return "$use $module;\n"; 454 } 455 } 456 457 sub stash_subs { 458 my ($self, $pack) = @_; 459 my (@ret, $stash); 460 if (!defined $pack) { 461 $pack = ''; 462 $stash = \%::; 463 } 464 else { 465 $pack =~ s/(::)?$/::/; 466 no strict 'refs'; 467 $stash = \%$pack; 468 } 469 my %stash = svref_2object($stash)->ARRAY; 470 while (my ($key, $val) = each %stash) { 471 my $class = class($val); 472 if ($class eq "PV") { 473 # Just a prototype. As an ugly but fairly effective way 474 # to find out if it belongs here is to see if the AUTOLOAD 475 # (if any) for the stash was defined in one of our files. 476 my $A = $stash{"AUTOLOAD"}; 477 if (defined ($A) && class($A) eq "GV" && defined($A->CV) 478 && class($A->CV) eq "CV") { 479 my $AF = $A->FILE; 480 next unless $AF eq $0 || exists $self->{'files'}{$AF}; 481 } 482 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; 483 } elsif ($class eq "IV") { 484 # Just a name. As above. 485 my $A = $stash{"AUTOLOAD"}; 486 if (defined ($A) && class($A) eq "GV" && defined($A->CV) 487 && class($A->CV) eq "CV") { 488 my $AF = $A->FILE; 489 next unless $AF eq $0 || exists $self->{'files'}{$AF}; 490 } 491 push @{$self->{'protos_todo'}}, [$pack . $key, undef]; 492 } elsif ($class eq "GV") { 493 if (class(my $cv = $val->CV) ne "SPECIAL") { 494 next if $self->{'subs_done'}{$$val}++; 495 next if $$val != ${$cv->GV}; # Ignore imposters 496 $self->todo($cv, 0); 497 } 498 if (class(my $cv = $val->FORM) ne "SPECIAL") { 499 next if $self->{'forms_done'}{$$val}++; 500 next if $$val != ${$cv->GV}; # Ignore imposters 501 $self->todo($cv, 1); 502 } 503 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { 504 $self->stash_subs($pack . $key) 505 unless $pack eq '' && $key eq 'main::'; 506 # avoid infinite recursion 507 } 508 } 509 } 510 } 511 512 sub print_protos { 513 my $self = shift; 514 my $ar; 515 my @ret; 516 foreach $ar (@{$self->{'protos_todo'}}) { 517 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); 518 push @ret, "sub " . $ar->[0] . "$proto;\n"; 519 } 520 delete $self->{'protos_todo'}; 521 return @ret; 522 } 523 524 sub style_opts { 525 my $self = shift; 526 my $opts = shift; 527 my $opt; 528 while (length($opt = substr($opts, 0, 1))) { 529 if ($opt eq "C") { 530 $self->{'cuddle'} = " "; 531 $opts = substr($opts, 1); 532 } elsif ($opt eq "i") { 533 $opts =~ s/^i(\d+)//; 534 $self->{'indent_size'} = $1; 535 } elsif ($opt eq "T") { 536 $self->{'use_tabs'} = 1; 537 $opts = substr($opts, 1); 538 } elsif ($opt eq "v") { 539 $opts =~ s/^v([^.]*)(.|$)//; 540 $self->{'ex_const'} = $1; 541 } 542 } 543 } 544 545 sub new { 546 my $class = shift; 547 my $self = bless {}, $class; 548 $self->{'cuddle'} = "\n"; 549 $self->{'curcop'} = undef; 550 $self->{'curstash'} = "main"; 551 $self->{'ex_const'} = "'???'"; 552 $self->{'expand'} = 0; 553 $self->{'files'} = {}; 554 $self->{'indent_size'} = 4; 555 $self->{'linenums'} = 0; 556 $self->{'parens'} = 0; 557 $self->{'subs_todo'} = []; 558 $self->{'unquote'} = 0; 559 $self->{'use_dumper'} = 0; 560 $self->{'use_tabs'} = 0; 561 562 $self->{'ambient_arybase'} = 0; 563 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings 564 $self->{'ambient_hints'} = 0; 565 $self->{'ambient_hinthash'} = undef; 566 $self->init(); 567 568 while (my $arg = shift @_) { 569 if ($arg eq "-d") { 570 $self->{'use_dumper'} = 1; 571 require Data::Dumper; 572 } elsif ($arg =~ /^-f(.*)/) { 573 $self->{'files'}{$1} = 1; 574 } elsif ($arg eq "-l") { 575 $self->{'linenums'} = 1; 576 } elsif ($arg eq "-p") { 577 $self->{'parens'} = 1; 578 } elsif ($arg eq "-P") { 579 $self->{'noproto'} = 1; 580 } elsif ($arg eq "-q") { 581 $self->{'unquote'} = 1; 582 } elsif (substr($arg, 0, 2) eq "-s") { 583 $self->style_opts(substr $arg, 2); 584 } elsif ($arg =~ /^-x(\d)$/) { 585 $self->{'expand'} = $1; 586 } 587 } 588 return $self; 589 } 590 591 { 592 # Mask out the bits that L<warnings::register> uses 593 my $WARN_MASK; 594 BEGIN { 595 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; 596 } 597 sub WARN_MASK () { 598 return $WARN_MASK; 599 } 600 } 601 602 # Initialise the contextual information, either from 603 # defaults provided with the ambient_pragmas method, 604 # or from perl's own defaults otherwise. 605 sub init { 606 my $self = shift; 607 608 $self->{'arybase'} = $self->{'ambient_arybase'}; 609 $self->{'warnings'} = defined ($self->{'ambient_warnings'}) 610 ? $self->{'ambient_warnings'} & WARN_MASK 611 : undef; 612 $self->{'hints'} = $self->{'ambient_hints'}; 613 $self->{'hints'} &= 0xFF if $] < 5.009; 614 $self->{'hinthash'} = $self->{'ambient_hinthash'}; 615 616 # also a convenient place to clear out subs_declared 617 delete $self->{'subs_declared'}; 618 } 619 620 sub compile { 621 my(@args) = @_; 622 return sub { 623 my $self = B::Deparse->new(@args); 624 # First deparse command-line args 625 if (defined $^I) { # deparse -i 626 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); 627 } 628 if ($^W) { # deparse -w 629 print qq(BEGIN { \$^W = $^W; }\n); 630 } 631 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 632 my $fs = perlstring($/) || 'undef'; 633 my $bs = perlstring($O::savebackslash) || 'undef'; 634 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); 635 } 636 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); 637 my @UNITCHECKs = B::unitcheck_av->isa("B::AV") 638 ? B::unitcheck_av->ARRAY 639 : (); 640 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); 641 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); 642 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); 643 for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) { 644 $self->todo($block, 0); 645 } 646 $self->stash_subs(); 647 local($SIG{"__DIE__"}) = 648 sub { 649 if ($self->{'curcop'}) { 650 my $cop = $self->{'curcop'}; 651 my($line, $file) = ($cop->line, $cop->file); 652 print STDERR "While deparsing $file near line $line,\n"; 653 } 654 }; 655 $self->{'curcv'} = main_cv; 656 $self->{'curcvlex'} = undef; 657 print $self->print_protos; 658 @{$self->{'subs_todo'}} = 659 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; 660 print $self->indent($self->deparse_root(main_root)), "\n" 661 unless null main_root; 662 my @text; 663 while (scalar(@{$self->{'subs_todo'}})) { 664 push @text, $self->next_todo; 665 } 666 print $self->indent(join("", @text)), "\n" if @text; 667 668 # Print __DATA__ section, if necessary 669 no strict 'refs'; 670 my $laststash = defined $self->{'curcop'} 671 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; 672 if (defined *{$laststash."::DATA"}{IO}) { 673 print "package $laststash;\n" 674 unless $laststash eq $self->{'curstash'}; 675 print "__DATA__\n"; 676 print readline(*{$laststash."::DATA"}); 677 } 678 } 679 } 680 681 sub coderef2text { 682 my $self = shift; 683 my $sub = shift; 684 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); 685 686 $self->init(); 687 return $self->indent($self->deparse_sub(svref_2object($sub))); 688 } 689 690 sub ambient_pragmas { 691 my $self = shift; 692 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0); 693 694 while (@_ > 1) { 695 my $name = shift(); 696 my $val = shift(); 697 698 if ($name eq 'strict') { 699 require strict; 700 701 if ($val eq 'none') { 702 $hint_bits &= ~strict::bits(qw/refs subs vars/); 703 next(); 704 } 705 706 my @names; 707 if ($val eq "all") { 708 @names = qw/refs subs vars/; 709 } 710 elsif (ref $val) { 711 @names = @$val; 712 } 713 else { 714 @names = split' ', $val; 715 } 716 $hint_bits |= strict::bits(@names); 717 } 718 719 elsif ($name eq '$[') { 720 $arybase = $val; 721 } 722 723 elsif ($name eq 'integer' 724 || $name eq 'bytes' 725 || $name eq 'utf8') { 726 require "$name.pm"; 727 if ($val) { 728 $hint_bits |= ${$::{"$name}::"}{"hint_bits"}}; 729 } 730 else { 731 $hint_bits &= ~${$::{"$name}::"}{"hint_bits"}}; 732 } 733 } 734 735 elsif ($name eq 're') { 736 require re; 737 if ($val eq 'none') { 738 $hint_bits &= ~re::bits(qw/taint eval/); 739 next(); 740 } 741 742 my @names; 743 if ($val eq 'all') { 744 @names = qw/taint eval/; 745 } 746 elsif (ref $val) { 747 @names = @$val; 748 } 749 else { 750 @names = split' ',$val; 751 } 752 $hint_bits |= re::bits(@names); 753 } 754 755 elsif ($name eq 'warnings') { 756 if ($val eq 'none') { 757 $warning_bits = $warnings::NONE; 758 next(); 759 } 760 761 my @names; 762 if (ref $val) { 763 @names = @$val; 764 } 765 else { 766 @names = split/\s+/, $val; 767 } 768 769 $warning_bits = $warnings::NONE if !defined ($warning_bits); 770 $warning_bits |= warnings::bits(@names); 771 } 772 773 elsif ($name eq 'warning_bits') { 774 $warning_bits = $val; 775 } 776 777 elsif ($name eq 'hint_bits') { 778 $hint_bits = $val; 779 } 780 781 elsif ($name eq '%^H') { 782 $hinthash = $val; 783 } 784 785 else { 786 croak "Unknown pragma type: $name"; 787 } 788 } 789 if (@_) { 790 croak "The ambient_pragmas method expects an even number of args"; 791 } 792 793 $self->{'ambient_arybase'} = $arybase; 794 $self->{'ambient_warnings'} = $warning_bits; 795 $self->{'ambient_hints'} = $hint_bits; 796 $self->{'ambient_hinthash'} = $hinthash; 797 } 798 799 # This method is the inner loop, so try to keep it simple 800 sub deparse { 801 my $self = shift; 802 my($op, $cx) = @_; 803 804 Carp::confess("Null op in deparse") if !defined($op) 805 || class($op) eq "NULL"; 806 my $meth = "pp_" . $op->name; 807 return $self->$meth($op, $cx); 808 } 809 810 sub indent { 811 my $self = shift; 812 my $txt = shift; 813 my @lines = split(/\n/, $txt); 814 my $leader = ""; 815 my $level = 0; 816 my $line; 817 for $line (@lines) { 818 my $cmd = substr($line, 0, 1); 819 if ($cmd eq "\t" or $cmd eq "\b") { 820 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; 821 if ($self->{'use_tabs'}) { 822 $leader = "\t" x ($level / 8) . " " x ($level % 8); 823 } else { 824 $leader = " " x $level; 825 } 826 $line = substr($line, 1); 827 } 828 if (substr($line, 0, 1) eq "\f") { 829 $line = substr($line, 1); # no indent 830 } else { 831 $line = $leader . $line; 832 } 833 $line =~ s/\cK;?//g; 834 } 835 return join("\n", @lines); 836 } 837 838 sub deparse_sub { 839 my $self = shift; 840 my $cv = shift; 841 my $proto = ""; 842 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); 843 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); 844 local $self->{'curcop'} = $self->{'curcop'}; 845 if ($cv->FLAGS & SVf_POK) { 846 $proto = "(". $cv->PV . ") "; 847 } 848 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { 849 $proto .= ": "; 850 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; 851 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; 852 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; 853 } 854 855 local($self->{'curcv'}) = $cv; 856 local($self->{'curcvlex'}); 857 local(@$self{qw'curstash warnings hints hinthash'}) 858 = @$self{qw'curstash warnings hints hinthash'}; 859 my $body; 860 if (not null $cv->ROOT) { 861 my $lineseq = $cv->ROOT->first; 862 if ($lineseq->name eq "lineseq") { 863 my @ops; 864 for(my$o=$lineseq->first; $$o; $o=$o->sibling) { 865 push @ops, $o; 866 } 867 $body = $self->lineseq(undef, @ops).";"; 868 my $scope_en = $self->find_scope_en($lineseq); 869 if (defined $scope_en) { 870 my $subs = join"", $self->seq_subs($scope_en); 871 $body .= ";\n$subs" if length($subs); 872 } 873 } 874 else { 875 $body = $self->deparse($cv->ROOT->first, 0); 876 } 877 } 878 else { 879 my $sv = $cv->const_sv; 880 if ($$sv) { 881 # uh-oh. inlinable sub... format it differently 882 return $proto . "{ " . $self->const($sv, 0) . " }\n"; 883 } else { # XSUB? (or just a declaration) 884 return "$proto;\n"; 885 } 886 } 887 return $proto ."{\n\t$body\n\b}" ."\n"; 888 } 889 890 sub deparse_format { 891 my $self = shift; 892 my $form = shift; 893 my @text; 894 local($self->{'curcv'}) = $form; 895 local($self->{'curcvlex'}); 896 local($self->{'in_format'}) = 1; 897 local(@$self{qw'curstash warnings hints hinthash'}) 898 = @$self{qw'curstash warnings hints hinthash'}; 899 my $op = $form->ROOT; 900 my $kid; 901 return "\f." if $op->first->name eq 'stub' 902 || $op->first->name eq 'nextstate'; 903 $op = $op->first->first; # skip leavewrite, lineseq 904 while (not null $op) { 905 $op = $op->sibling; # skip nextstate 906 my @exprs; 907 $kid = $op->first->sibling; # skip pushmark 908 push @text, "\f".$self->const_sv($kid)->PV; 909 $kid = $kid->sibling; 910 for (; not null $kid; $kid = $kid->sibling) { 911 push @exprs, $self->deparse($kid, 0); 912 } 913 push @text, "\f".join(", ", @exprs)."\n" if @exprs; 914 $op = $op->sibling; 915 } 916 return join("", @text) . "\f."; 917 } 918 919 sub is_scope { 920 my $op = shift; 921 return $op->name eq "leave" || $op->name eq "scope" 922 || $op->name eq "lineseq" 923 || ($op->name eq "null" && class($op) eq "UNOP" 924 && (is_scope($op->first) || $op->first->name eq "enter")); 925 } 926 927 sub is_state { 928 my $name = $_[0]->name; 929 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; 930 } 931 932 sub is_miniwhile { # check for one-line loop (`foo() while $y--') 933 my $op = shift; 934 return (!null($op) and null($op->sibling) 935 and $op->name eq "null" and class($op) eq "UNOP" 936 and (($op->first->name =~ /^(and|or)$/ 937 and $op->first->first->sibling->name eq "lineseq") 938 or ($op->first->name eq "lineseq" 939 and not null $op->first->first->sibling 940 and $op->first->first->sibling->name eq "unstack") 941 )); 942 } 943 944 # Check if the op and its sibling are the initialization and the rest of a 945 # for (..;..;..) { ... } loop 946 sub is_for_loop { 947 my $op = shift; 948 # This OP might be almost anything, though it won't be a 949 # nextstate. (It's the initialization, so in the canonical case it 950 # will be an sassign.) The sibling is a lineseq whose first child 951 # is a nextstate and whose second is a leaveloop. 952 my $lseq = $op->sibling; 953 if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") { 954 if ($lseq->first && !null($lseq->first) && is_state($lseq->first) 955 && (my $sib = $lseq->first->sibling)) { 956 return (!null($sib) && $sib->name eq "leaveloop"); 957 } 958 } 959 return 0; 960 } 961 962 sub is_scalar { 963 my $op = shift; 964 return ($op->name eq "rv2sv" or 965 $op->name eq "padsv" or 966 $op->name eq "gv" or # only in array/hash constructs 967 $op->flags & OPf_KIDS && !null($op->first) 968 && $op->first->name eq "gvsv"); 969 } 970 971 sub maybe_parens { 972 my $self = shift; 973 my($text, $cx, $prec) = @_; 974 if ($prec < $cx # unary ops nest just fine 975 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 976 or $self->{'parens'}) 977 { 978 $text = "($text)"; 979 # In a unop, let parent reuse our parens; see maybe_parens_unop 980 $text = "\cS" . $text if $cx == 16; 981 return $text; 982 } else { 983 return $text; 984 } 985 } 986 987 # same as above, but get around the `if it looks like a function' rule 988 sub maybe_parens_unop { 989 my $self = shift; 990 my($name, $kid, $cx) = @_; 991 if ($cx > 16 or $self->{'parens'}) { 992 $kid = $self->deparse($kid, 1); 993 if ($name eq "umask" && $kid =~ /^\d+$/) { 994 $kid = sprintf("%#o", $kid); 995 } 996 return "$name($kid)"; 997 } else { 998 $kid = $self->deparse($kid, 16); 999 if ($name eq "umask" && $kid =~ /^\d+$/) { 1000 $kid = sprintf("%#o", $kid); 1001 } 1002 if (substr($kid, 0, 1) eq "\cS") { 1003 # use kid's parens 1004 return $name . substr($kid, 1); 1005 } elsif (substr($kid, 0, 1) eq "(") { 1006 # avoid looks-like-a-function trap with extra parens 1007 # (`+' can lead to ambiguities) 1008 return "$name(" . $kid . ")"; 1009 } else { 1010 return "$name $kid"; 1011 } 1012 } 1013 } 1014 1015 sub maybe_parens_func { 1016 my $self = shift; 1017 my($func, $text, $cx, $prec) = @_; 1018 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { 1019 return "$func($text)"; 1020 } else { 1021 return "$func $text"; 1022 } 1023 } 1024 1025 sub maybe_local { 1026 my $self = shift; 1027 my($op, $cx, $text) = @_; 1028 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; 1029 if ($op->private & (OPpLVAL_INTRO|$our_intro) 1030 and not $self->{'avoid_local'}{$$op}) { 1031 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; 1032 if( $our_local eq 'our' ) { 1033 # XXX This assertion fails code with non-ASCII identifiers, 1034 # like ./ext/Encode/t/jperl.t 1035 die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/; 1036 $text =~ s/(\w+::)+//; 1037 } 1038 if (want_scalar($op)) { 1039 return "$our_local $text"; 1040 } else { 1041 return $self->maybe_parens_func("$our_local", $text, $cx, 16); 1042 } 1043 } else { 1044 return $text; 1045 } 1046 } 1047 1048 sub maybe_targmy { 1049 my $self = shift; 1050 my($op, $cx, $func, @args) = @_; 1051 if ($op->private & OPpTARGET_MY) { 1052 my $var = $self->padname($op->targ); 1053 my $val = $func->($self, $op, 7, @args); 1054 return $self->maybe_parens("$var = $val", $cx, 7); 1055 } else { 1056 return $func->($self, $op, $cx, @args); 1057 } 1058 } 1059 1060 sub padname_sv { 1061 my $self = shift; 1062 my $targ = shift; 1063 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); 1064 } 1065 1066 sub maybe_my { 1067 my $self = shift; 1068 my($op, $cx, $text) = @_; 1069 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { 1070 my $my = $op->private & OPpPAD_STATE ? "state" : "my"; 1071 if (want_scalar($op)) { 1072 return "$my $text"; 1073 } else { 1074 return $self->maybe_parens_func($my, $text, $cx, 16); 1075 } 1076 } else { 1077 return $text; 1078 } 1079 } 1080 1081 # The following OPs don't have functions: 1082 1083 # pp_padany -- does not exist after parsing 1084 1085 sub AUTOLOAD { 1086 if ($AUTOLOAD =~ s/^.*::pp_//) { 1087 warn "unexpected OP_".uc $AUTOLOAD; 1088 return "XXX"; 1089 } else { 1090 die "Undefined subroutine $AUTOLOAD called"; 1091 } 1092 } 1093 1094 sub DESTROY {} # Do not AUTOLOAD 1095 1096 # $root should be the op which represents the root of whatever 1097 # we're sequencing here. If it's undefined, then we don't append 1098 # any subroutine declarations to the deparsed ops, otherwise we 1099 # append appropriate declarations. 1100 sub lineseq { 1101 my($self, $root, @ops) = @_; 1102 my($expr, @exprs); 1103 1104 my $out_cop = $self->{'curcop'}; 1105 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; 1106 my $limit_seq; 1107 if (defined $root) { 1108 $limit_seq = $out_seq; 1109 my $nseq; 1110 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; 1111 $limit_seq = $nseq if !defined($limit_seq) 1112 or defined($nseq) && $nseq < $limit_seq; 1113 } 1114 $limit_seq = $self->{'limit_seq'} 1115 if defined($self->{'limit_seq'}) 1116 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); 1117 local $self->{'limit_seq'} = $limit_seq; 1118 1119 $self->walk_lineseq($root, \@ops, 1120 sub { push @exprs, $_[0]} ); 1121 1122 my $body = join(";\n", grep {length} @exprs); 1123 my $subs = ""; 1124 if (defined $root && defined $limit_seq && !$self->{'in_format'}) { 1125 $subs = join "\n", $self->seq_subs($limit_seq); 1126 } 1127 return join(";\n", grep {length} $body, $subs); 1128 } 1129 1130 sub scopeop { 1131 my($real_block, $self, $op, $cx) = @_; 1132 my $kid; 1133 my @kids; 1134 1135 local(@$self{qw'curstash warnings hints hinthash'}) 1136 = @$self{qw'curstash warnings hints hinthash'} if $real_block; 1137 if ($real_block) { 1138 $kid = $op->first->sibling; # skip enter 1139 if (is_miniwhile($kid)) { 1140 my $top = $kid->first; 1141 my $name = $top->name; 1142 if ($name eq "and") { 1143 $name = "while"; 1144 } elsif ($name eq "or") { 1145 $name = "until"; 1146 } else { # no conditional -> while 1 or until 0 1147 return $self->deparse($top->first, 1) . " while 1"; 1148 } 1149 my $cond = $top->first; 1150 my $body = $cond->sibling->first; # skip lineseq 1151 $cond = $self->deparse($cond, 1); 1152 $body = $self->deparse($body, 1); 1153 return "$body $name $cond"; 1154 } 1155 } else { 1156 $kid = $op->first; 1157 } 1158 for (; !null($kid); $kid = $kid->sibling) { 1159 push @kids, $kid; 1160 } 1161 if ($cx > 0) { # inside an expression, (a do {} while for lineseq) 1162 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}"; 1163 } else { 1164 my $lineseq = $self->lineseq($op, @kids); 1165 return (length ($lineseq) ? "$lineseq;" : ""); 1166 } 1167 } 1168 1169 sub pp_scope { scopeop(0, @_); } 1170 sub pp_lineseq { scopeop(0, @_); } 1171 sub pp_leave { scopeop(1, @_); } 1172 1173 # This is a special case of scopeop and lineseq, for the case of the 1174 # main_root. The difference is that we print the output statements as 1175 # soon as we get them, for the sake of impatient users. 1176 sub deparse_root { 1177 my $self = shift; 1178 my($op) = @_; 1179 local(@$self{qw'curstash warnings hints hinthash'}) 1180 = @$self{qw'curstash warnings hints hinthash'}; 1181 my @kids; 1182 return if null $op->first; # Can happen, e.g., for Bytecode without -k 1183 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { 1184 push @kids, $kid; 1185 } 1186 $self->walk_lineseq($op, \@kids, 1187 sub { print $self->indent($_[0].';'); 1188 print "\n" unless $_[1] == $#kids; 1189 }); 1190 } 1191 1192 sub walk_lineseq { 1193 my ($self, $op, $kids, $callback) = @_; 1194 my @kids = @$kids; 1195 for (my $i = 0; $i < @kids; $i++) { 1196 my $expr = ""; 1197 if (is_state $kids[$i]) { 1198 $expr = $self->deparse($kids[$i++], 0); 1199 if ($i > $#kids) { 1200 $callback->($expr, $i); 1201 last; 1202 } 1203 } 1204 if (is_for_loop($kids[$i])) { 1205 $callback->($expr . $self->for_loop($kids[$i], 0), $i++); 1206 next; 1207 } 1208 $expr .= $self->deparse($kids[$i], (@kids != 1)/2); 1209 $expr =~ s/;\n?\z//; 1210 $callback->($expr, $i); 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' && $name =~ /^::/) { 1227 $stash = '::'; 1228 } 1229 elsif (($stash eq 'main' && $globalnames{$name}) 1230 or ($stash eq $self->{'curstash'} && !$globalnames{$name} 1231 && ($stash eq 'main' || $name !~ /::/)) 1232 or $name =~ /^[^A-Za-z_:]/) 1233 { 1234 $stash = ""; 1235 } else { 1236 $stash = $stash . "::"; 1237 } 1238 if ($name =~ /^(\^..|{)/) { 1239 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ 1240 } 1241 return $stash . $name; 1242 } 1243 1244 # Return the name to use for a stash variable. 1245 # If a lexical with the same name is in scope, it may need to be 1246 # fully-qualified. 1247 sub stash_variable { 1248 my ($self, $prefix, $name) = @_; 1249 1250 return "$prefix$name" if $name =~ /::/; 1251 1252 unless ($prefix eq '$' || $prefix eq '@' || #' 1253 $prefix eq '%' || $prefix eq '$#') { 1254 return "$prefix$name"; 1255 } 1256 1257 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; 1258 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v); 1259 return "$prefix$name"; 1260 } 1261 1262 sub lex_in_scope { 1263 my ($self, $name) = @_; 1264 $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 1265 1266 return 0 if !defined($self->{'curcop'}); 1267 my $seq = $self->{'curcop'}->cop_seq; 1268 return 0 if !exists $self->{'curcvlex'}{$name}; 1269 for my $a (@{$self->{'curcvlex'}{$name}}) { 1270 my ($st, $en) = @$a; 1271 return 1 if $seq > $st && $seq <= $en; 1272 } 1273 return 0; 1274 } 1275 1276 sub populate_curcvlex { 1277 my $self = shift; 1278 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { 1279 my $padlist = $cv->PADLIST; 1280 # an undef CV still in lexical chain 1281 next if class($padlist) eq "SPECIAL"; 1282 my @padlist = $padlist->ARRAY; 1283 my @ns = $padlist[0]->ARRAY; 1284 1285 for (my $i=0; $i<@ns; ++$i) { 1286 next if class($ns[$i]) eq "SPECIAL"; 1287 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars 1288 if (class($ns[$i]) eq "PV") { 1289 # Probably that pesky lexical @_ 1290 next; 1291 } 1292 my $name = $ns[$i]->PVX; 1293 my ($seq_st, $seq_en) = 1294 ($ns[$i]->FLAGS & SVf_FAKE) 1295 ? (0, 999999) 1296 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH); 1297 1298 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en]; 1299 } 1300 } 1301 } 1302 1303 sub find_scope_st { ((find_scope(@_))[0]); } 1304 sub find_scope_en { ((find_scope(@_))[1]); } 1305 1306 # Recurses down the tree, looking for pad variable introductions and COPs 1307 sub find_scope { 1308 my ($self, $op, $scope_st, $scope_en) = @_; 1309 carp("Undefined op in find_scope") if !defined $op; 1310 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; 1311 1312 my @queue = ($op); 1313 while(my $op = shift @queue ) { 1314 for (my $o=$op->first; $$o; $o=$o->sibling) { 1315 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { 1316 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW); 1317 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH; 1318 $scope_st = $s if !defined($scope_st) || $s < $scope_st; 1319 $scope_en = $e if !defined($scope_en) || $e > $scope_en; 1320 return ($scope_st, $scope_en); 1321 } 1322 elsif (is_state($o)) { 1323 my $c = $o->cop_seq; 1324 $scope_st = $c if !defined($scope_st) || $c < $scope_st; 1325 $scope_en = $c if !defined($scope_en) || $c > $scope_en; 1326 return ($scope_st, $scope_en); 1327 } 1328 elsif ($o->flags & OPf_KIDS) { 1329 unshift (@queue, $o); 1330 } 1331 } 1332 } 1333 1334 return ($scope_st, $scope_en); 1335 } 1336 1337 # Returns a list of subs which should be inserted before the COP 1338 sub cop_subs { 1339 my ($self, $op, $out_seq) = @_; 1340 my $seq = $op->cop_seq; 1341 # If we have nephews, then our sequence number indicates 1342 # the cop_seq of the end of some sort of scope. 1343 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS 1344 and my $nseq = $self->find_scope_st($op->sibling) ) { 1345 $seq = $nseq; 1346 } 1347 $seq = $out_seq if defined($out_seq) && $out_seq < $seq; 1348 return $self->seq_subs($seq); 1349 } 1350 1351 sub seq_subs { 1352 my ($self, $seq) = @_; 1353 my @text; 1354 #push @text, "# ($seq)\n"; 1355 1356 return "" if !defined $seq; 1357 while (scalar(@{$self->{'subs_todo'}}) 1358 and $seq > $self->{'subs_todo'}[0][0]) { 1359 push @text, $self->next_todo; 1360 } 1361 return @text; 1362 } 1363 1364 # Notice how subs and formats are inserted between statements here; 1365 # also $[ assignments and pragmas. 1366 sub pp_nextstate { 1367 my $self = shift; 1368 my($op, $cx) = @_; 1369 $self->{'curcop'} = $op; 1370 my @text; 1371 push @text, $self->cop_subs($op); 1372 push @text, $op->label . ": " if $op->label; 1373 my $stash = $op->stashpv; 1374 if ($stash ne $self->{'curstash'}) { 1375 push @text, "package $stash;\n"; 1376 $self->{'curstash'} = $stash; 1377 } 1378 1379 if ($self->{'arybase'} != $op->arybase) { 1380 push @text, '$[ = '. $op->arybase .";\n"; 1381 $self->{'arybase'} = $op->arybase; 1382 } 1383 1384 my $warnings = $op->warnings; 1385 my $warning_bits; 1386 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { 1387 $warning_bits = $warnings::Bits{"all"} & WARN_MASK; 1388 } 1389 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { 1390 $warning_bits = $warnings::NONE; 1391 } 1392 elsif ($warnings->isa("B::SPECIAL")) { 1393 $warning_bits = undef; 1394 } 1395 else { 1396 $warning_bits = $warnings->PV & WARN_MASK; 1397 } 1398 1399 if (defined ($warning_bits) and 1400 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { 1401 push @text, declare_warnings($self->{'warnings'}, $warning_bits); 1402 $self->{'warnings'} = $warning_bits; 1403 } 1404 1405 if ($self->{'hints'} != $op->hints) { 1406 push @text, declare_hints($self->{'hints'}, $op->hints); 1407 $self->{'hints'} = $op->hints; 1408 } 1409 1410 # hack to check that the hint hash hasn't changed 1411 if ($] > 5.009 && 1412 "@{[sort %{$self->{'hinthash'} || {}}]}" 1413 ne "@{[sort %{$op->hints_hash->HASH || {}}]}") { 1414 push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size}); 1415 $self->{'hinthash'} = $op->hints_hash->HASH; 1416 } 1417 1418 # This should go after of any branches that add statements, to 1419 # increase the chances that it refers to the same line it did in 1420 # the original program. 1421 if ($self->{'linenums'}) { 1422 push @text, "\f#line " . $op->line . 1423 ' "' . $op->file, qq'"\n'; 1424 } 1425 1426 return join("", @text); 1427 } 1428 1429 sub declare_warnings { 1430 my ($from, $to) = @_; 1431 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) { 1432 return "use warnings;\n"; 1433 } 1434 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { 1435 return "no warnings;\n"; 1436 } 1437 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n"; 1438 } 1439 1440 sub declare_hints { 1441 my ($from, $to) = @_; 1442 my $use = $to & ~$from; 1443 my $no = $from & ~$to; 1444 my $decls = ""; 1445 for my $pragma (hint_pragmas($use)) { 1446 $decls .= "use $pragma;\n"; 1447 } 1448 for my $pragma (hint_pragmas($no)) { 1449 $decls .= "no $pragma;\n"; 1450 } 1451 return $decls; 1452 } 1453 1454 # Internal implementation hints that the core sets automatically, so don't need 1455 # (or want) to be passed back to the user 1456 my %ignored_hints = ( 1457 'open<' => 1, 1458 'open>' => 1, 1459 'v_string' => 1, 1460 ); 1461 1462 sub declare_hinthash { 1463 my ($from, $to, $indent) = @_; 1464 my @decls; 1465 for my $key (keys %$to) { 1466 next if $ignored_hints{$key}; 1467 if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) { 1468 push @decls, qq(\$^H{'$key'} = q($to->{$key});); 1469 } 1470 } 1471 for my $key (keys %$from) { 1472 next if $ignored_hints{$key}; 1473 if (!exists $to->{$key}) { 1474 push @decls, qq(delete \$^H{'$key'};); 1475 } 1476 } 1477 @decls or return ''; 1478 return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n"; 1479 } 1480 1481 sub hint_pragmas { 1482 my ($bits) = @_; 1483 my @pragmas; 1484 push @pragmas, "integer" if $bits & 0x1; 1485 push @pragmas, "strict 'refs'" if $bits & 0x2; 1486 push @pragmas, "bytes" if $bits & 0x8; 1487 return @pragmas; 1488 } 1489 1490 sub pp_dbstate { pp_nextstate(@_) } 1491 sub pp_setstate { pp_nextstate(@_) } 1492 1493 sub pp_unstack { return "" } # see also leaveloop 1494 1495 sub baseop { 1496 my $self = shift; 1497 my($op, $cx, $name) = @_; 1498 return $name; 1499 } 1500 1501 sub pp_stub { 1502 my $self = shift; 1503 my($op, $cx, $name) = @_; 1504 if ($cx >= 1) { 1505 return "()"; 1506 } 1507 else { 1508 return "();"; 1509 } 1510 } 1511 sub pp_wantarray { baseop(@_, "wantarray") } 1512 sub pp_fork { baseop(@_, "fork") } 1513 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } 1514 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } 1515 sub pp_time { maybe_targmy(@_, \&baseop, "time") } 1516 sub pp_tms { baseop(@_, "times") } 1517 sub pp_ghostent { baseop(@_, "gethostent") } 1518 sub pp_gnetent { baseop(@_, "getnetent") } 1519 sub pp_gprotoent { baseop(@_, "getprotoent") } 1520 sub pp_gservent { baseop(@_, "getservent") } 1521 sub pp_ehostent { baseop(@_, "endhostent") } 1522 sub pp_enetent { baseop(@_, "endnetent") } 1523 sub pp_eprotoent { baseop(@_, "endprotoent") } 1524 sub pp_eservent { baseop(@_, "endservent") } 1525 sub pp_gpwent { baseop(@_, "getpwent") } 1526 sub pp_spwent { baseop(@_, "setpwent") } 1527 sub pp_epwent { baseop(@_, "endpwent") } 1528 sub pp_ggrent { baseop(@_, "getgrent") } 1529 sub pp_sgrent { baseop(@_, "setgrent") } 1530 sub pp_egrent { baseop(@_, "endgrent") } 1531 sub pp_getlogin { baseop(@_, "getlogin") } 1532 1533 sub POSTFIX () { 1 } 1534 1535 # I couldn't think of a good short name, but this is the category of 1536 # symbolic unary operators with interesting precedence 1537 1538 sub pfixop { 1539 my $self = shift; 1540 my($op, $cx, $name, $prec, $flags) = (@_, 0); 1541 my $kid = $op->first; 1542 $kid = $self->deparse($kid, $prec); 1543 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid", 1544 $cx, $prec); 1545 } 1546 1547 sub pp_preinc { pfixop(@_, "++", 23) } 1548 sub pp_predec { pfixop(@_, "--", 23) } 1549 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 1550 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 1551 sub pp_i_preinc { pfixop(@_, "++", 23) } 1552 sub pp_i_predec { pfixop(@_, "--", 23) } 1553 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 1554 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 1555 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } 1556 1557 sub pp_negate { maybe_targmy(@_, \&real_negate) } 1558 sub real_negate { 1559 my $self = shift; 1560 my($op, $cx) = @_; 1561 if ($op->first->name =~ /^(i_)?negate$/) { 1562 # avoid --$x 1563 $self->pfixop($op, $cx, "-", 21.5); 1564 } else { 1565 $self->pfixop($op, $cx, "-", 21); 1566 } 1567 } 1568 sub pp_i_negate { pp_negate(@_) } 1569 1570 sub pp_not { 1571 my $self = shift; 1572 my($op, $cx) = @_; 1573 if ($cx <= 4) { 1574 $self->pfixop($op, $cx, "not ", 4); 1575 } else { 1576 $self->pfixop($op, $cx, "!", 21); 1577 } 1578 } 1579 1580 sub unop { 1581 my $self = shift; 1582 my($op, $cx, $name) = @_; 1583 my $kid; 1584 if ($op->flags & OPf_KIDS) { 1585 $kid = $op->first; 1586 if (defined prototype("CORE::$name") 1587 && prototype("CORE::$name") =~ /^;?\*/ 1588 && $kid->name eq "rv2gv") { 1589 $kid = $kid->first; 1590 } 1591 1592 return $self->maybe_parens_unop($name, $kid, $cx); 1593 } else { 1594 return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); 1595 } 1596 } 1597 1598 sub pp_chop { maybe_targmy(@_, \&unop, "chop") } 1599 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } 1600 sub pp_schop { maybe_targmy(@_, \&unop, "chop") } 1601 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } 1602 sub pp_defined { unop(@_, "defined") } 1603 sub pp_undef { unop(@_, "undef") } 1604 sub pp_study { unop(@_, "study") } 1605 sub pp_ref { unop(@_, "ref") } 1606 sub pp_pos { maybe_local(@_, unop(@_, "pos")) } 1607 1608 sub pp_sin { maybe_targmy(@_, \&unop, "sin") } 1609 sub pp_cos { maybe_targmy(@_, \&unop, "cos") } 1610 sub pp_rand { maybe_targmy(@_, \&unop, "rand") } 1611 sub pp_srand { unop(@_, "srand") } 1612 sub pp_exp { maybe_targmy(@_, \&unop, "exp") } 1613 sub pp_log { maybe_targmy(@_, \&unop, "log") } 1614 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } 1615 sub pp_int { maybe_targmy(@_, \&unop, "int") } 1616 sub pp_hex { maybe_targmy(@_, \&unop, "hex") } 1617 sub pp_oct { maybe_targmy(@_, \&unop, "oct") } 1618 sub pp_abs { maybe_targmy(@_, \&unop, "abs") } 1619 1620 sub pp_length { maybe_targmy(@_, \&unop, "length") } 1621 sub pp_ord { maybe_targmy(@_, \&unop, "ord") } 1622 sub pp_chr { maybe_targmy(@_, \&unop, "chr") } 1623 1624 sub pp_each { unop(@_, "each") } 1625 sub pp_values { unop(@_, "values") } 1626 sub pp_keys { unop(@_, "keys") } 1627 sub pp_pop { unop(@_, "pop") } 1628 sub pp_shift { unop(@_, "shift") } 1629 1630 sub pp_caller { unop(@_, "caller") } 1631 sub pp_reset { unop(@_, "reset") } 1632 sub pp_exit { unop(@_, "exit") } 1633 sub pp_prototype { unop(@_, "prototype") } 1634 1635 sub pp_close { unop(@_, "close") } 1636 sub pp_fileno { unop(@_, "fileno") } 1637 sub pp_umask { unop(@_, "umask") } 1638 sub pp_untie { unop(@_, "untie") } 1639 sub pp_tied { unop(@_, "tied") } 1640 sub pp_dbmclose { unop(@_, "dbmclose") } 1641 sub pp_getc { unop(@_, "getc") } 1642 sub pp_eof { unop(@_, "eof") } 1643 sub pp_tell { unop(@_, "tell") } 1644 sub pp_getsockname { unop(@_, "getsockname") } 1645 sub pp_getpeername { unop(@_, "getpeername") } 1646 1647 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } 1648 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } 1649 sub pp_readlink { unop(@_, "readlink") } 1650 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } 1651 sub pp_readdir { unop(@_, "readdir") } 1652 sub pp_telldir { unop(@_, "telldir") } 1653 sub pp_rewinddir { unop(@_, "rewinddir") } 1654 sub pp_closedir { unop(@_, "closedir") } 1655 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } 1656 sub pp_localtime { unop(@_, "localtime") } 1657 sub pp_gmtime { unop(@_, "gmtime") } 1658 sub pp_alarm { unop(@_, "alarm") } 1659 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } 1660 1661 sub pp_dofile { unop(@_, "do") } 1662 sub pp_entereval { unop(@_, "eval") } 1663 1664 sub pp_ghbyname { unop(@_, "gethostbyname") } 1665 sub pp_gnbyname { unop(@_, "getnetbyname") } 1666 sub pp_gpbyname { unop(@_, "getprotobyname") } 1667 sub pp_shostent { unop(@_, "sethostent") } 1668 sub pp_snetent { unop(@_, "setnetent") } 1669 sub pp_sprotoent { unop(@_, "setprotoent") } 1670 sub pp_sservent { unop(@_, "setservent") } 1671 sub pp_gpwnam { unop(@_, "getpwnam") } 1672 sub pp_gpwuid { unop(@_, "getpwuid") } 1673 sub pp_ggrnam { unop(@_, "getgrnam") } 1674 sub pp_ggrgid { unop(@_, "getgrgid") } 1675 1676 sub pp_lock { unop(@_, "lock") } 1677 1678 sub pp_continue { unop(@_, "continue"); } 1679 sub pp_break { 1680 my ($self, $op) = @_; 1681 return "" if $op->flags & OPf_SPECIAL; 1682 unop(@_, "break"); 1683 } 1684 1685 sub givwhen { 1686 my $self = shift; 1687 my($op, $cx, $givwhen) = @_; 1688 1689 my $enterop = $op->first; 1690 my ($head, $block); 1691 if ($enterop->flags & OPf_SPECIAL) { 1692 $head = "default"; 1693 $block = $self->deparse($enterop->first, 0); 1694 } 1695 else { 1696 my $cond = $enterop->first; 1697 my $cond_str = $self->deparse($cond, 1); 1698 $head = "$givwhen ($cond_str)"; 1699 $block = $self->deparse($cond->sibling, 0); 1700 } 1701 1702 return "$head {\n". 1703 "\t$block\n". 1704 "\b}\cK"; 1705 } 1706 1707 sub pp_leavegiven { givwhen(@_, "given"); } 1708 sub pp_leavewhen { givwhen(@_, "when"); } 1709 1710 sub pp_exists { 1711 my $self = shift; 1712 my($op, $cx) = @_; 1713 my $arg; 1714 if ($op->private & OPpEXISTS_SUB) { 1715 # Checking for the existence of a subroutine 1716 return $self->maybe_parens_func("exists", 1717 $self->pp_rv2cv($op->first, 16), $cx, 16); 1718 } 1719 if ($op->flags & OPf_SPECIAL) { 1720 # Array element, not hash element 1721 return $self->maybe_parens_func("exists", 1722 $self->pp_aelem($op->first, 16), $cx, 16); 1723 } 1724 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16), 1725 $cx, 16); 1726 } 1727 1728 sub pp_delete { 1729 my $self = shift; 1730 my($op, $cx) = @_; 1731 my $arg; 1732 if ($op->private & OPpSLICE) { 1733 if ($op->flags & OPf_SPECIAL) { 1734 # Deleting from an array, not a hash 1735 return $self->maybe_parens_func("delete", 1736 $self->pp_aslice($op->first, 16), 1737 $cx, 16); 1738 } 1739 return $self->maybe_parens_func("delete", 1740 $self->pp_hslice($op->first, 16), 1741 $cx, 16); 1742 } else { 1743 if ($op->flags & OPf_SPECIAL) { 1744 # Deleting from an array, not a hash 1745 return $self->maybe_parens_func("delete", 1746 $self->pp_aelem($op->first, 16), 1747 $cx, 16); 1748 } 1749 return $self->maybe_parens_func("delete", 1750 $self->pp_helem($op->first, 16), 1751 $cx, 16); 1752 } 1753 } 1754 1755 sub pp_require { 1756 my $self = shift; 1757 my($op, $cx) = @_; 1758 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; 1759 if (class($op) eq "UNOP" and $op->first->name eq "const" 1760 and $op->first->private & OPpCONST_BARE) 1761 { 1762 my $name = $self->const_sv($op->first)->PV; 1763 $name =~ s[/][::]g; 1764 $name =~ s/\.pm//g; 1765 return "$opname $name"; 1766 } else { 1767 $self->unop($op, $cx, $opname); 1768 } 1769 } 1770 1771 sub pp_scalar { 1772 my $self = shift; 1773 my($op, $cx) = @_; 1774 my $kid = $op->first; 1775 if (not null $kid->sibling) { 1776 # XXX Was a here-doc 1777 return $self->dquote($op); 1778 } 1779 $self->unop(@_, "scalar"); 1780 } 1781 1782 1783 sub padval { 1784 my $self = shift; 1785 my $targ = shift; 1786 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); 1787 } 1788 1789 sub anon_hash_or_list { 1790 my $self = shift; 1791 my($op, $cx) = @_; 1792 1793 my($pre, $post) = @{{"anonlist" => ["[","]"], 1794 "anonhash" => ["{","}"]}->{$op->name}}; 1795 my($expr, @exprs); 1796 $op = $op->first->sibling; # skip pushmark 1797 for (; !null($op); $op = $op->sibling) { 1798 $expr = $self->deparse($op, 6); 1799 push @exprs, $expr; 1800 } 1801 if ($pre eq "{" and $cx < 1) { 1802 # Disambiguate that it's not a block 1803 $pre = "+{"; 1804 } 1805 return $pre . join(", ", @exprs) . $post; 1806 } 1807 1808 sub pp_anonlist { 1809 my $self = shift; 1810 my ($op, $cx) = @_; 1811 if ($op->flags & OPf_SPECIAL) { 1812 return $self->anon_hash_or_list($op, $cx); 1813 } 1814 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL"; 1815 return 'XXX'; 1816 } 1817 1818 *pp_anonhash = \&pp_anonlist; 1819 1820 sub pp_refgen { 1821 my $self = shift; 1822 my($op, $cx) = @_; 1823 my $kid = $op->first; 1824 if ($kid->name eq "null") { 1825 $kid = $kid->first; 1826 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { 1827 return $self->anon_hash_or_list($op, $cx); 1828 } elsif (!null($kid->sibling) and 1829 $kid->sibling->name eq "anoncode") { 1830 return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) }); 1831 } elsif ($kid->name eq "pushmark") { 1832 my $sib_name = $kid->sibling->name; 1833 if ($sib_name =~ /^(pad|rv2)[ah]v$/ 1834 and not $kid->sibling->flags & OPf_REF) 1835 { 1836 # The @a in \(@a) isn't in ref context, but only when the 1837 # parens are there. 1838 return "\\(" . $self->pp_list($op->first) . ")"; 1839 } elsif ($sib_name eq 'entersub') { 1840 my $text = $self->deparse($kid->sibling, 1); 1841 # Always show parens for \(&func()), but only with -p otherwise 1842 $text = "($text)" if $self->{'parens'} 1843 or $kid->sibling->private & OPpENTERSUB_AMPER; 1844 return "\\$text"; 1845 } 1846 } 1847 } 1848 $self->pfixop($op, $cx, "\\", 20); 1849 } 1850 1851 sub e_anoncode { 1852 my ($self, $info) = @_; 1853 my $text = $self->deparse_sub($info->{code}); 1854 return "sub " . $text; 1855 } 1856 1857 sub pp_srefgen { pp_refgen(@_) } 1858 1859 sub pp_readline { 1860 my $self = shift; 1861 my($op, $cx) = @_; 1862 my $kid = $op->first; 1863 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> 1864 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid); 1865 return $self->unop($op, $cx, "readline"); 1866 } 1867 1868 sub pp_rcatline { 1869 my $self = shift; 1870 my($op) = @_; 1871 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; 1872 } 1873 1874 # Unary operators that can occur as pseudo-listops inside double quotes 1875 sub dq_unop { 1876 my $self = shift; 1877 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); 1878 my $kid; 1879 if ($op->flags & OPf_KIDS) { 1880 $kid = $op->first; 1881 # If there's more than one kid, the first is an ex-pushmark. 1882 $kid = $kid->sibling if not null $kid->sibling; 1883 return $self->maybe_parens_unop($name, $kid, $cx); 1884 } else { 1885 return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); 1886 } 1887 } 1888 1889 sub pp_ucfirst { dq_unop(@_, "ucfirst") } 1890 sub pp_lcfirst { dq_unop(@_, "lcfirst") } 1891 sub pp_uc { dq_unop(@_, "uc") } 1892 sub pp_lc { dq_unop(@_, "lc") } 1893 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } 1894 1895 sub loopex { 1896 my $self = shift; 1897 my ($op, $cx, $name) = @_; 1898 if (class($op) eq "PVOP") { 1899 return "$name " . $op->pv; 1900 } elsif (class($op) eq "OP") { 1901 return $name; 1902 } elsif (class($op) eq "UNOP") { 1903 # Note -- loop exits are actually exempt from the 1904 # looks-like-a-func rule, but a few extra parens won't hurt 1905 return $self->maybe_parens_unop($name, $op->first, $cx); 1906 } 1907 } 1908 1909 sub pp_last { loopex(@_, "last") } 1910 sub pp_next { loopex(@_, "next") } 1911 sub pp_redo { loopex(@_, "redo") } 1912 sub pp_goto { loopex(@_, "goto") } 1913 sub pp_dump { loopex(@_, "dump") } 1914 1915 sub ftst { 1916 my $self = shift; 1917 my($op, $cx, $name) = @_; 1918 if (class($op) eq "UNOP") { 1919 # Genuine `-X' filetests are exempt from the LLAFR, but not 1920 # l?stat(); for the sake of clarity, give'em all parens 1921 return $self->maybe_parens_unop($name, $op->first, $cx); 1922 } elsif (class($op) =~ /^(SV|PAD)OP$/) { 1923 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); 1924 } else { # I don't think baseop filetests ever survive ck_ftst, but... 1925 return $name; 1926 } 1927 } 1928 1929 sub pp_lstat { ftst(@_, "lstat") } 1930 sub pp_stat { ftst(@_, "stat") } 1931 sub pp_ftrread { ftst(@_, "-R") } 1932 sub pp_ftrwrite { ftst(@_, "-W") } 1933 sub pp_ftrexec { ftst(@_, "-X") } 1934 sub pp_fteread { ftst(@_, "-r") } 1935 sub pp_ftewrite { ftst(@_, "-w") } 1936 sub pp_fteexec { ftst(@_, "-x") } 1937 sub pp_ftis { ftst(@_, "-e") } 1938 sub pp_fteowned { ftst(@_, "-O") } 1939 sub pp_ftrowned { ftst(@_, "-o") } 1940 sub pp_ftzero { ftst(@_, "-z") } 1941 sub pp_ftsize { ftst(@_, "-s") } 1942 sub pp_ftmtime { ftst(@_, "-M") } 1943 sub pp_ftatime { ftst(@_, "-A") } 1944 sub pp_ftctime { ftst(@_, "-C") } 1945 sub pp_ftsock { ftst(@_, "-S") } 1946 sub pp_ftchr { ftst(@_, "-c") } 1947 sub pp_ftblk { ftst(@_, "-b") } 1948 sub pp_ftfile { ftst(@_, "-f") } 1949 sub pp_ftdir { ftst(@_, "-d") } 1950 sub pp_ftpipe { ftst(@_, "-p") } 1951 sub pp_ftlink { ftst(@_, "-l") } 1952 sub pp_ftsuid { ftst(@_, "-u") } 1953 sub pp_ftsgid { ftst(@_, "-g") } 1954 sub pp_ftsvtx { ftst(@_, "-k") } 1955 sub pp_fttty { ftst(@_, "-t") } 1956 sub pp_fttext { ftst(@_, "-T") } 1957 sub pp_ftbinary { ftst(@_, "-B") } 1958 1959 sub SWAP_CHILDREN () { 1 } 1960 sub ASSIGN () { 2 } # has OP= variant 1961 sub LIST_CONTEXT () { 4 } # Assignment is in list context 1962 1963 my(%left, %right); 1964 1965 sub assoc_class { 1966 my $op = shift; 1967 my $name = $op->name; 1968 if ($name eq "concat" and $op->first->name eq "concat") { 1969 # avoid spurious `=' -- see comment in pp_concat 1970 return "concat"; 1971 } 1972 if ($name eq "null" and class($op) eq "UNOP" 1973 and $op->first->name =~ /^(and|x?or)$/ 1974 and null $op->first->sibling) 1975 { 1976 # Like all conditional constructs, OP_ANDs and OP_ORs are topped 1977 # with a null that's used as the common end point of the two 1978 # flows of control. For precedence purposes, ignore it. 1979 # (COND_EXPRs have these too, but we don't bother with 1980 # their associativity). 1981 return assoc_class($op->first); 1982 } 1983 return $name . ($op->flags & OPf_STACKED ? "=" : ""); 1984 } 1985 1986 # Left associative operators, like `+', for which 1987 # $a + $b + $c is equivalent to ($a + $b) + $c 1988 1989 BEGIN { 1990 %left = ('multiply' => 19, 'i_multiply' => 19, 1991 'divide' => 19, 'i_divide' => 19, 1992 'modulo' => 19, 'i_modulo' => 19, 1993 'repeat' => 19, 1994 'add' => 18, 'i_add' => 18, 1995 'subtract' => 18, 'i_subtract' => 18, 1996 'concat' => 18, 1997 'left_shift' => 17, 'right_shift' => 17, 1998 'bit_and' => 13, 1999 'bit_or' => 12, 'bit_xor' => 12, 2000 'and' => 3, 2001 'or' => 2, 'xor' => 2, 2002 ); 2003 } 2004 2005 sub deparse_binop_left { 2006 my $self = shift; 2007 my($op, $left, $prec) = @_; 2008 if ($left{assoc_class($op)} && $left{assoc_class($left)} 2009 and $left{assoc_class($op)} == $left{assoc_class($left)}) 2010 { 2011 return $self->deparse($left, $prec - .00001); 2012 } else { 2013 return $self->deparse($left, $prec); 2014 } 2015 } 2016 2017 # Right associative operators, like `=', for which 2018 # $a = $b = $c is equivalent to $a = ($b = $c) 2019 2020 BEGIN { 2021 %right = ('pow' => 22, 2022 'sassign=' => 7, 'aassign=' => 7, 2023 'multiply=' => 7, 'i_multiply=' => 7, 2024 'divide=' => 7, 'i_divide=' => 7, 2025 'modulo=' => 7, 'i_modulo=' => 7, 2026 'repeat=' => 7, 2027 'add=' => 7, 'i_add=' => 7, 2028 'subtract=' => 7, 'i_subtract=' => 7, 2029 'concat=' => 7, 2030 'left_shift=' => 7, 'right_shift=' => 7, 2031 'bit_and=' => 7, 2032 'bit_or=' => 7, 'bit_xor=' => 7, 2033 'andassign' => 7, 2034 'orassign' => 7, 2035 ); 2036 } 2037 2038 sub deparse_binop_right { 2039 my $self = shift; 2040 my($op, $right, $prec) = @_; 2041 if ($right{assoc_class($op)} && $right{assoc_class($right)} 2042 and $right{assoc_class($op)} == $right{assoc_class($right)}) 2043 { 2044 return $self->deparse($right, $prec - .00001); 2045 } else { 2046 return $self->deparse($right, $prec); 2047 } 2048 } 2049 2050 sub binop { 2051 my $self = shift; 2052 my ($op, $cx, $opname, $prec, $flags) = (@_, 0); 2053 my $left = $op->first; 2054 my $right = $op->last; 2055 my $eq = ""; 2056 if ($op->flags & OPf_STACKED && $flags & ASSIGN) { 2057 $eq = "="; 2058 $prec = 7; 2059 } 2060 if ($flags & SWAP_CHILDREN) { 2061 ($left, $right) = ($right, $left); 2062 } 2063 $left = $self->deparse_binop_left($op, $left, $prec); 2064 $left = "($left)" if $flags & LIST_CONTEXT 2065 && $left !~ /^(my|our|local|)[\@\(]/; 2066 $right = $self->deparse_binop_right($op, $right, $prec); 2067 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); 2068 } 2069 2070 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 2071 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 2072 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } 2073 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 2074 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 2075 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 2076 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 2077 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } 2078 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 2079 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 2080 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } 2081 2082 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } 2083 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } 2084 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } 2085 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } 2086 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } 2087 2088 sub pp_eq { binop(@_, "==", 14) } 2089 sub pp_ne { binop(@_, "!=", 14) } 2090 sub pp_lt { binop(@_, "<", 15) } 2091 sub pp_gt { binop(@_, ">", 15) } 2092 sub pp_ge { binop(@_, ">=", 15) } 2093 sub pp_le { binop(@_, "<=", 15) } 2094 sub pp_ncmp { binop(@_, "<=>", 14) } 2095 sub pp_i_eq { binop(@_, "==", 14) } 2096 sub pp_i_ne { binop(@_, "!=", 14) } 2097 sub pp_i_lt { binop(@_, "<", 15) } 2098 sub pp_i_gt { binop(@_, ">", 15) } 2099 sub pp_i_ge { binop(@_, ">=", 15) } 2100 sub pp_i_le { binop(@_, "<=", 15) } 2101 sub pp_i_ncmp { binop(@_, "<=>", 14) } 2102 2103 sub pp_seq { binop(@_, "eq", 14) } 2104 sub pp_sne { binop(@_, "ne", 14) } 2105 sub pp_slt { binop(@_, "lt", 15) } 2106 sub pp_sgt { binop(@_, "gt", 15) } 2107 sub pp_sge { binop(@_, "ge", 15) } 2108 sub pp_sle { binop(@_, "le", 15) } 2109 sub pp_scmp { binop(@_, "cmp", 14) } 2110 2111 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } 2112 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } 2113 2114 sub pp_smartmatch { 2115 my ($self, $op, $cx) = @_; 2116 if ($op->flags & OPf_SPECIAL) { 2117 return $self->deparse($op->first, $cx); 2118 } 2119 else { 2120 binop(@_, "~~", 14); 2121 } 2122 } 2123 2124 # `.' is special because concats-of-concats are optimized to save copying 2125 # by making all but the first concat stacked. The effect is as if the 2126 # programmer had written `($a . $b) .= $c', except legal. 2127 sub pp_concat { maybe_targmy(@_, \&real_concat) } 2128 sub real_concat { 2129 my $self = shift; 2130 my($op, $cx) = @_; 2131 my $left = $op->first; 2132 my $right = $op->last; 2133 my $eq = ""; 2134 my $prec = 18; 2135 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { 2136 $eq = "="; 2137 $prec = 7; 2138 } 2139 $left = $self->deparse_binop_left($op, $left, $prec); 2140 $right = $self->deparse_binop_right($op, $right, $prec); 2141 return $self->maybe_parens("$left .$eq $right", $cx, $prec); 2142 } 2143 2144 # `x' is weird when the left arg is a list 2145 sub pp_repeat { 2146 my $self = shift; 2147 my($op, $cx) = @_; 2148 my $left = $op->first; 2149 my $right = $op->last; 2150 my $eq = ""; 2151 my $prec = 19; 2152 if ($op->flags & OPf_STACKED) { 2153 $eq = "="; 2154 $prec = 7; 2155 } 2156 if (null($right)) { # list repeat; count is inside left-side ex-list 2157 my $kid = $left->first->sibling; # skip pushmark 2158 my @exprs; 2159 for (; !null($kid->sibling); $kid = $kid->sibling) { 2160 push @exprs, $self->deparse($kid, 6); 2161 } 2162 $right = $kid; 2163 $left = "(" . join(", ", @exprs). ")"; 2164 } else { 2165 $left = $self->deparse_binop_left($op, $left, $prec); 2166 } 2167 $right = $self->deparse_binop_right($op, $right, $prec); 2168 return $self->maybe_parens("$left x$eq $right", $cx, $prec); 2169 } 2170 2171 sub range { 2172 my $self = shift; 2173 my ($op, $cx, $type) = @_; 2174 my $left = $op->first; 2175 my $right = $left->sibling; 2176 $left = $self->deparse($left, 9); 2177 $right = $self->deparse($right, 9); 2178 return $self->maybe_parens("$left $type $right", $cx, 9); 2179 } 2180 2181 sub pp_flop { 2182 my $self = shift; 2183 my($op, $cx) = @_; 2184 my $flip = $op->first; 2185 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; 2186 return $self->range($flip->first, $cx, $type); 2187 } 2188 2189 # one-line while/until is handled in pp_leave 2190 2191 sub logop { 2192 my $self = shift; 2193 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; 2194 my $left = $op->first; 2195 my $right = $op->first->sibling; 2196 if ($cx < 1 and is_scope($right) and $blockname 2197 and $self->{'expand'} < 7) 2198 { # if ($a) {$b} 2199 $left = $self->deparse($left, 1); 2200 $right = $self->deparse($right, 0); 2201 return "$blockname ($left) {\n\t$right\n\b}\cK"; 2202 } elsif ($cx < 1 and $blockname and not $self->{'parens'} 2203 and $self->{'expand'} < 7) { # $b if $a 2204 $right = $self->deparse($right, 1); 2205 $left = $self->deparse($left, 1); 2206 return "$right $blockname $left"; 2207 } elsif ($cx > $lowprec and $highop) { # $a && $b 2208 $left = $self->deparse_binop_left($op, $left, $highprec); 2209 $right = $self->deparse_binop_right($op, $right, $highprec); 2210 return $self->maybe_parens("$left $highop $right", $cx, $highprec); 2211 } else { # $a and $b 2212 $left = $self->deparse_binop_left($op, $left, $lowprec); 2213 $right = $self->deparse_binop_right($op, $right, $lowprec); 2214 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); 2215 } 2216 } 2217 2218 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } 2219 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } 2220 sub pp_dor { logop(@_, "err", 2, "//", 10, "") } 2221 2222 # xor is syntactically a logop, but it's really a binop (contrary to 2223 # old versions of opcode.pl). Syntax is what matters here. 2224 sub pp_xor { logop(@_, "xor", 2, "", 0, "") } 2225 2226 sub logassignop { 2227 my $self = shift; 2228 my ($op, $cx, $opname) = @_; 2229 my $left = $op->first; 2230 my $right = $op->first->sibling->first; # skip sassign 2231 $left = $self->deparse($left, 7); 2232 $right = $self->deparse($right, 7); 2233 return $self->maybe_parens("$left $opname $right", $cx, 7); 2234 } 2235 2236 sub pp_andassign { logassignop(@_, "&&=") } 2237 sub pp_orassign { logassignop(@_, "||=") } 2238 sub pp_dorassign { logassignop(@_, "//=") } 2239 2240 sub listop { 2241 my $self = shift; 2242 my($op, $cx, $name) = @_; 2243 my(@exprs); 2244 my $parens = ($cx >= 5) || $self->{'parens'}; 2245 my $kid = $op->first->sibling; 2246 return $name if null $kid; 2247 my $first; 2248 $name = "socketpair" if $name eq "sockpair"; 2249 my $proto = prototype("CORE::$name"); 2250 if (defined $proto 2251 && $proto =~ /^;?\*/ 2252 && $kid->name eq "rv2gv") { 2253 $first = $self->deparse($kid->first, 6); 2254 } 2255 else { 2256 $first = $self->deparse($kid, 6); 2257 } 2258 if ($name eq "chmod" && $first =~ /^\d+$/) { 2259 $first = sprintf("%#o", $first); 2260 } 2261 $first = "+$first" if not $parens and substr($first, 0, 1) eq "("; 2262 push @exprs, $first; 2263 $kid = $kid->sibling; 2264 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") { 2265 push @exprs, $self->deparse($kid->first, 6); 2266 $kid = $kid->sibling; 2267 } 2268 for (; !null($kid); $kid = $kid->sibling) { 2269 push @exprs, $self->deparse($kid, 6); 2270 } 2271 if ($parens) { 2272 return "$name(" . join(", ", @exprs) . ")"; 2273 } else { 2274 return "$name " . join(", ", @exprs); 2275 } 2276 } 2277 2278 sub pp_bless { listop(@_, "bless") } 2279 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } 2280 sub pp_substr { maybe_local(@_, listop(@_, "substr")) } 2281 sub pp_vec { maybe_local(@_, listop(@_, "vec")) } 2282 sub pp_index { maybe_targmy(@_, \&listop, "index") } 2283 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } 2284 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } 2285 sub pp_formline { listop(@_, "formline") } # see also deparse_format 2286 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } 2287 sub pp_unpack { listop(@_, "unpack") } 2288 sub pp_pack { listop(@_, "pack") } 2289 sub pp_join { maybe_targmy(@_, \&listop, "join") } 2290 sub pp_splice { listop(@_, "splice") } 2291 sub pp_push { maybe_targmy(@_, \&listop, "push") } 2292 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } 2293 sub pp_reverse { listop(@_, "reverse") } 2294 sub pp_warn { listop(@_, "warn") } 2295 sub pp_die { listop(@_, "die") } 2296 # Actually, return is exempt from the LLAFR (see examples in this very 2297 # module!), but for consistency's sake, ignore that fact 2298 sub pp_return { listop(@_, "return") } 2299 sub pp_open { listop(@_, "open") } 2300 sub pp_pipe_op { listop(@_, "pipe") } 2301 sub pp_tie { listop(@_, "tie") } 2302 sub pp_binmode { listop(@_, "binmode") } 2303 sub pp_dbmopen { listop(@_, "dbmopen") } 2304 sub pp_sselect { listop(@_, "select") } 2305 sub pp_select { listop(@_, "select") } 2306 sub pp_read { listop(@_, "read") } 2307 sub pp_sysopen { listop(@_, "sysopen") } 2308 sub pp_sysseek { listop(@_, "sysseek") } 2309 sub pp_sysread { listop(@_, "sysread") } 2310 sub pp_syswrite { listop(@_, "syswrite") } 2311 sub pp_send { listop(@_, "send") } 2312 sub pp_recv { listop(@_, "recv") } 2313 sub pp_seek { listop(@_, "seek") } 2314 sub pp_fcntl { listop(@_, "fcntl") } 2315 sub pp_ioctl { listop(@_, "ioctl") } 2316 sub pp_flock { maybe_targmy(@_, \&listop, "flock") } 2317 sub pp_socket { listop(@_, "socket") } 2318 sub pp_sockpair { listop(@_, "sockpair") } 2319 sub pp_bind { listop(@_, "bind") } 2320 sub pp_connect { listop(@_, "connect") } 2321 sub pp_listen { listop(@_, "listen") } 2322 sub pp_accept { listop(@_, "accept") } 2323 sub pp_shutdown { listop(@_, "shutdown") } 2324 sub pp_gsockopt { listop(@_, "getsockopt") } 2325 sub pp_ssockopt { listop(@_, "setsockopt") } 2326 sub pp_chown { maybe_targmy(@_, \&listop, "chown") } 2327 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } 2328 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } 2329 sub pp_utime { maybe_targmy(@_, \&listop, "utime") } 2330 sub pp_rename { maybe_targmy(@_, \&listop, "rename") } 2331 sub pp_link { maybe_targmy(@_, \&listop, "link") } 2332 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } 2333 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } 2334 sub pp_open_dir { listop(@_, "opendir") } 2335 sub pp_seekdir { listop(@_, "seekdir") } 2336 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } 2337 sub pp_system { maybe_targmy(@_, \&listop, "system") } 2338 sub pp_exec { maybe_targmy(@_, \&listop, "exec") } 2339 sub pp_kill { maybe_targmy(@_, \&listop, "kill") } 2340 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } 2341 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } 2342 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } 2343 sub pp_shmget { listop(@_, "shmget") } 2344 sub pp_shmctl { listop(@_, "shmctl") } 2345 sub pp_shmread { listop(@_, "shmread") } 2346 sub pp_shmwrite { listop(@_, "shmwrite") } 2347 sub pp_msgget { listop(@_, "msgget") } 2348 sub pp_msgctl { listop(@_, "msgctl") } 2349 sub pp_msgsnd { listop(@_, "msgsnd") } 2350 sub pp_msgrcv { listop(@_, "msgrcv") } 2351 sub pp_semget { listop(@_, "semget") } 2352 sub pp_semctl { listop(@_, "semctl") } 2353 sub pp_semop { listop(@_, "semop") } 2354 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } 2355 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } 2356 sub pp_gpbynumber { listop(@_, "getprotobynumber") } 2357 sub pp_gsbyname { listop(@_, "getservbyname") } 2358 sub pp_gsbyport { listop(@_, "getservbyport") } 2359 sub pp_syscall { listop(@_, "syscall") } 2360 2361 sub pp_glob { 2362 my $self = shift; 2363 my($op, $cx) = @_; 2364 my $text = $self->dq($op->first->sibling); # skip pushmark 2365 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline 2366 or $text =~ /[<>]/) { 2367 return 'glob(' . single_delim('qq', '"', $text) . ')'; 2368 } else { 2369 return '<' . $text . '>'; 2370 } 2371 } 2372 2373 # Truncate is special because OPf_SPECIAL makes a bareword first arg 2374 # be a filehandle. This could probably be better fixed in the core 2375 # by moving the GV lookup into ck_truc. 2376 2377 sub pp_truncate { 2378 my $self = shift; 2379 my($op, $cx) = @_; 2380 my(@exprs); 2381 my $parens = ($cx >= 5) || $self->{'parens'}; 2382 my $kid = $op->first->sibling; 2383 my $fh; 2384 if ($op->flags & OPf_SPECIAL) { 2385 # $kid is an OP_CONST 2386 $fh = $self->const_sv($kid)->PV; 2387 } else { 2388 $fh = $self->deparse($kid, 6); 2389 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; 2390 } 2391 my $len = $self->deparse($kid->sibling, 6); 2392 if ($parens) { 2393 return "truncate($fh, $len)"; 2394 } else { 2395 return "truncate $fh, $len"; 2396 } 2397 } 2398 2399 sub indirop { 2400 my $self = shift; 2401 my($op, $cx, $name) = @_; 2402 my($expr, @exprs); 2403 my $kid = $op->first->sibling; 2404 my $indir = ""; 2405 if ($op->flags & OPf_STACKED) { 2406 $indir = $kid; 2407 $indir = $indir->first; # skip rv2gv 2408 if (is_scope($indir)) { 2409 $indir = "{" . $self->deparse($indir, 0) . "}"; 2410 $indir = "{;}" if $indir eq "{}"; 2411 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { 2412 $indir = $self->const_sv($indir)->PV; 2413 } else { 2414 $indir = $self->deparse($indir, 24); 2415 } 2416 $indir = $indir . " "; 2417 $kid = $kid->sibling; 2418 } 2419 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { 2420 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' 2421 : '{$a <=> $b} '; 2422 } 2423 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { 2424 $indir = '{$b cmp $a} '; 2425 } 2426 for (; !null($kid); $kid = $kid->sibling) { 2427 $expr = $self->deparse($kid, 6); 2428 push @exprs, $expr; 2429 } 2430 my $name2 = $name; 2431 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { 2432 $name2 = 'reverse sort'; 2433 } 2434 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { 2435 return "$exprs[0] = $name2 $indir $exprs[0]"; 2436 } 2437 2438 my $args = $indir . join(", ", @exprs); 2439 if ($indir ne "" and $name eq "sort") { 2440 # We don't want to say "sort(f 1, 2, 3)", since perl -w will 2441 # give bareword warnings in that case. Therefore if context 2442 # requires, we'll put parens around the outside "(sort f 1, 2, 2443 # 3)". Unfortunately, we'll currently think the parens are 2444 # necessary more often that they really are, because we don't 2445 # distinguish which side of an assignment we're on. 2446 if ($cx >= 5) { 2447 return "($name2 $args)"; 2448 } else { 2449 return "$name2 $args"; 2450 } 2451 } else { 2452 return $self->maybe_parens_func($name2, $args, $cx, 5); 2453 } 2454 2455 } 2456 2457 sub pp_prtf { indirop(@_, "printf") } 2458 sub pp_print { indirop(@_, "print") } 2459 sub pp_say { indirop(@_, "say") } 2460 sub pp_sort { indirop(@_, "sort") } 2461 2462 sub mapop { 2463 my $self = shift; 2464 my($op, $cx, $name) = @_; 2465 my($expr, @exprs); 2466 my $kid = $op->first; # this is the (map|grep)start 2467 $kid = $kid->first->sibling; # skip a pushmark 2468 my $code = $kid->first; # skip a null 2469 if (is_scope $code) { 2470 $code = "{" . $self->deparse($code, 0) . "} "; 2471 } else { 2472 $code = $self->deparse($code, 24) . ", "; 2473 } 2474 $kid = $kid->sibling; 2475 for (; !null($kid); $kid = $kid->sibling) { 2476 $expr = $self->deparse($kid, 6); 2477 push @exprs, $expr if defined $expr; 2478 } 2479 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5); 2480 } 2481 2482 sub pp_mapwhile { mapop(@_, "map") } 2483 sub pp_grepwhile { mapop(@_, "grep") } 2484 sub pp_mapstart { baseop(@_, "map") } 2485 sub pp_grepstart { baseop(@_, "grep") } 2486 2487 sub pp_list { 2488 my $self = shift; 2489 my($op, $cx) = @_; 2490 my($expr, @exprs); 2491 my $kid = $op->first->sibling; # skip pushmark 2492 my $lop; 2493 my $local = "either"; # could be local(...), my(...), state(...) or our(...) 2494 for ($lop = $kid; !null($lop); $lop = $lop->sibling) { 2495 # This assumes that no other private flags equal 128, and that 2496 # OPs that store things other than flags in their op_private, 2497 # like OP_AELEMFAST, won't be immediate children of a list. 2498 # 2499 # OP_ENTERSUB can break this logic, so check for it. 2500 # I suspect that open and exit can too. 2501 2502 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO) 2503 or $lop->name eq "undef") 2504 or $lop->name eq "entersub" 2505 or $lop->name eq "exit" 2506 or $lop->name eq "open") 2507 { 2508 $local = ""; # or not 2509 last; 2510 } 2511 if ($lop->name =~ /^pad[ash]v$/) { 2512 if ($lop->private & OPpPAD_STATE) { # state() 2513 ($local = "", last) if $local =~ /^(?:local|our|my)$/; 2514 $local = "state"; 2515 } else { # my() 2516 ($local = "", last) if $local =~ /^(?:local|our|state)$/; 2517 $local = "my"; 2518 } 2519 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/ 2520 && $lop->private & OPpOUR_INTRO 2521 or $lop->name eq "null" && $lop->first->name eq "gvsv" 2522 && $lop->first->private & OPpOUR_INTRO) { # our() 2523 ($local = "", last) if $local =~ /^(?:my|local|state)$/; 2524 $local = "our"; 2525 } elsif ($lop->name ne "undef" 2526 # specifically avoid the "reverse sort" optimisation, 2527 # where "reverse" is nullified 2528 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE))) 2529 { 2530 # local() 2531 ($local = "", last) if $local =~ /^(?:my|our|state)$/; 2532 $local = "local"; 2533 } 2534 } 2535 $local = "" if $local eq "either"; # no point if it's all undefs 2536 return $self->deparse($kid, $cx) if null $kid->sibling and not $local; 2537 for (; !null($kid); $kid = $kid->sibling) { 2538 if ($local) { 2539 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { 2540 $lop = $kid->first; 2541 } else { 2542 $lop = $kid; 2543 } 2544 $self->{'avoid_local'}{$$lop}++; 2545 $expr = $self->deparse($kid, 6); 2546 delete $self->{'avoid_local'}{$$lop}; 2547 } else { 2548 $expr = $self->deparse($kid, 6); 2549 } 2550 push @exprs, $expr; 2551 } 2552 if ($local) { 2553 return "$local(" . join(", ", @exprs) . ")"; 2554 } else { 2555 return $self->maybe_parens( join(", ", @exprs), $cx, 6); 2556 } 2557 } 2558 2559 sub is_ifelse_cont { 2560 my $op = shift; 2561 return ($op->name eq "null" and class($op) eq "UNOP" 2562 and $op->first->name =~ /^(and|cond_expr)$/ 2563 and is_scope($op->first->first->sibling)); 2564 } 2565 2566 sub pp_cond_expr { 2567 my $self = shift; 2568 my($op, $cx) = @_; 2569 my $cond = $op->first; 2570 my $true = $cond->sibling; 2571 my $false = $true->sibling; 2572 my $cuddle = $self->{'cuddle'}; 2573 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and 2574 (is_scope($false) || is_ifelse_cont($false)) 2575 and $self->{'expand'} < 7) { 2576 $cond = $self->deparse($cond, 8); 2577 $true = $self->deparse($true, 6); 2578 $false = $self->deparse($false, 8); 2579 return $self->maybe_parens("$cond ? $true : $false", $cx, 8); 2580 } 2581 2582 $cond = $self->deparse($cond, 1); 2583 $true = $self->deparse($true, 0); 2584 my $head = "if ($cond) {\n\t$true\n\b}"; 2585 my @elsifs; 2586 while (!null($false) and is_ifelse_cont($false)) { 2587 my $newop = $false->first; 2588 my $newcond = $newop->first; 2589 my $newtrue = $newcond->sibling; 2590 $false = $newtrue->sibling; # last in chain is OP_AND => no else 2591 $newcond = $self->deparse($newcond, 1); 2592 $newtrue = $self->deparse($newtrue, 0); 2593 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; 2594 } 2595 if (!null($false)) { 2596 $false = $cuddle . "else {\n\t" . 2597 $self->deparse($false, 0) . "\n\b}\cK"; 2598 } else { 2599 $false = "\cK"; 2600 } 2601 return $head . join($cuddle, "", @elsifs) . $false; 2602 } 2603 2604 sub pp_once { 2605 my ($self, $op, $cx) = @_; 2606 my $cond = $op->first; 2607 my $true = $cond->sibling; 2608 2609 return $self->deparse($true, $cx); 2610 } 2611 2612 sub loop_common { 2613 my $self = shift; 2614 my($op, $cx, $init) = @_; 2615 my $enter = $op->first; 2616 my $kid = $enter->sibling; 2617 local(@$self{qw'curstash warnings hints hinthash'}) 2618 = @$self{qw'curstash warnings hints hinthash'}; 2619 my $head = ""; 2620 my $bare = 0; 2621 my $body; 2622 my $cond = undef; 2623 if ($kid->name eq "lineseq") { # bare or infinite loop 2624 if ($kid->last->name eq "unstack") { # infinite 2625 $head = "while (1) "; # Can't use for(;;) if there's a continue 2626 $cond = ""; 2627 } else { 2628 $bare = 1; 2629 } 2630 $body = $kid; 2631 } elsif ($enter->name eq "enteriter") { # foreach 2632 my $ary = $enter->first->sibling; # first was pushmark 2633 my $var = $ary->sibling; 2634 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { 2635 # "reverse" was optimised away 2636 $ary = listop($self, $ary->first->sibling, 1, 'reverse'); 2637 } elsif ($enter->flags & OPf_STACKED 2638 and not null $ary->first->sibling->sibling) 2639 { 2640 $ary = $self->deparse($ary->first->sibling, 9) . " .. " . 2641 $self->deparse($ary->first->sibling->sibling, 9); 2642 } else { 2643 $ary = $self->deparse($ary, 1); 2644 } 2645 if (null $var) { 2646 if ($enter->flags & OPf_SPECIAL) { # thread special var 2647 $var = $self->pp_threadsv($enter, 1); 2648 } else { # regular my() variable 2649 $var = $self->pp_padsv($enter, 1); 2650 } 2651 } elsif ($var->name eq "rv2gv") { 2652 $var = $self->pp_rv2sv($var, 1); 2653 if ($enter->private & OPpOUR_INTRO) { 2654 # our declarations don't have package names 2655 $var =~ s/^(.).*::/$1/; 2656 $var = "our $var"; 2657 } 2658 } elsif ($var->name eq "gv") { 2659 $var = "\$" . $self->deparse($var, 1); 2660 } 2661 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER 2662 if (!is_state $body->first and $body->first->name ne "stub") { 2663 confess unless $var eq '$_'; 2664 $body = $body->first; 2665 return $self->deparse($body, 2) . " foreach ($ary)"; 2666 } 2667 $head = "foreach $var ($ary) "; 2668 } elsif ($kid->name eq "null") { # while/until 2669 $kid = $kid->first; 2670 my $name = {"and" => "while", "or" => "until"}->{$kid->name}; 2671 $cond = $self->deparse($kid->first, 1); 2672 $head = "$name ($cond) "; 2673 $body = $kid->first->sibling; 2674 } elsif ($kid->name eq "stub") { # bare and empty 2675 return "{;}"; # {} could be a hashref 2676 } 2677 # If there isn't a continue block, then the next pointer for the loop 2678 # will point to the unstack, which is kid's last child, except 2679 # in a bare loop, when it will point to the leaveloop. When neither of 2680 # these conditions hold, then the second-to-last child is the continue 2681 # block (or the last in a bare loop). 2682 my $cont_start = $enter->nextop; 2683 my $cont; 2684 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { 2685 if ($bare) { 2686 $cont = $body->last; 2687 } else { 2688 $cont = $body->first; 2689 while (!null($cont->sibling->sibling)) { 2690 $cont = $cont->sibling; 2691 } 2692 } 2693 my $state = $body->first; 2694 my $cuddle = $self->{'cuddle'}; 2695 my @states; 2696 for (; $$state != $$cont; $state = $state->sibling) { 2697 push @states, $state; 2698 } 2699 $body = $self->lineseq(undef, @states); 2700 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { 2701 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; 2702 $cont = "\cK"; 2703 } else { 2704 $cont = $cuddle . "continue {\n\t" . 2705 $self->deparse($cont, 0) . "\n\b}\cK"; 2706 } 2707 } else { 2708 return "" if !defined $body; 2709 if (length $init) { 2710 $head = "for ($init; $cond;) "; 2711 } 2712 $cont = "\cK"; 2713 $body = $self->deparse($body, 0); 2714 } 2715 $body =~ s/;?$/;\n/; 2716 2717 return $head . "{\n\t" . $body . "\b}" . $cont; 2718 } 2719 2720 sub pp_leaveloop { shift->loop_common(@_, "") } 2721 2722 sub for_loop { 2723 my $self = shift; 2724 my($op, $cx) = @_; 2725 my $init = $self->deparse($op, 1); 2726 return $self->loop_common($op->sibling->first->sibling, $cx, $init); 2727 } 2728 2729 sub pp_leavetry { 2730 my $self = shift; 2731 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; 2732 } 2733 2734 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } 2735 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } 2736 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" } 2737 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" } 2738 2739 sub pp_null { 2740 my $self = shift; 2741 my($op, $cx) = @_; 2742 if (class($op) eq "OP") { 2743 # old value is lost 2744 return $self->{'ex_const'} if $op->targ == OP_CONST; 2745 } elsif ($op->first->name eq "pushmark") { 2746 return $self->pp_list($op, $cx); 2747 } elsif ($op->first->name eq "enter") { 2748 return $self->pp_leave($op, $cx); 2749 } elsif ($op->first->name eq "leave") { 2750 return $self->pp_leave($op->first, $cx); 2751 } elsif ($op->first->name eq "scope") { 2752 return $self->pp_scope($op->first, $cx); 2753 } elsif ($op->targ == OP_STRINGIFY) { 2754 return $self->dquote($op, $cx); 2755 } elsif (!null($op->first->sibling) and 2756 $op->first->sibling->name eq "readline" and 2757 $op->first->sibling->flags & OPf_STACKED) { 2758 return $self->maybe_parens($self->deparse($op->first, 7) . " = " 2759 . $self->deparse($op->first->sibling, 7), 2760 $cx, 7); 2761 } elsif (!null($op->first->sibling) and 2762 $op->first->sibling->name eq "trans" and 2763 $op->first->sibling->flags & OPf_STACKED) { 2764 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " 2765 . $self->deparse($op->first->sibling, 20), 2766 $cx, 20); 2767 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { 2768 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; 2769 } elsif (!null($op->first->sibling) and 2770 $op->first->sibling->name eq "null" and 2771 class($op->first->sibling) eq "UNOP" and 2772 $op->first->sibling->first->flags & OPf_STACKED and 2773 $op->first->sibling->first->name eq "rcatline") { 2774 return $self->maybe_parens($self->deparse($op->first, 18) . " .= " 2775 . $self->deparse($op->first->sibling, 18), 2776 $cx, 18); 2777 } else { 2778 return $self->deparse($op->first, $cx); 2779 } 2780 } 2781 2782 sub padname { 2783 my $self = shift; 2784 my $targ = shift; 2785 return $self->padname_sv($targ)->PVX; 2786 } 2787 2788 sub padany { 2789 my $self = shift; 2790 my $op = shift; 2791 return substr($self->padname($op->targ), 1); # skip $/@/% 2792 } 2793 2794 sub pp_padsv { 2795 my $self = shift; 2796 my($op, $cx) = @_; 2797 return $self->maybe_my($op, $cx, $self->padname($op->targ)); 2798 } 2799 2800 sub pp_padav { pp_padsv(@_) } 2801 sub pp_padhv { pp_padsv(@_) } 2802 2803 my @threadsv_names; 2804 2805 BEGIN { 2806 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9", 2807 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";", 2808 "^", "-", "%", "=", "|", "~", ":", "^A", "^E", 2809 "!", "@"); 2810 } 2811 2812 sub pp_threadsv { 2813 my $self = shift; 2814 my($op, $cx) = @_; 2815 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); 2816 } 2817 2818 sub gv_or_padgv { 2819 my $self = shift; 2820 my $op = shift; 2821 if (class($op) eq "PADOP") { 2822 return $self->padval($op->padix); 2823 } else { # class($op) eq "SVOP" 2824 return $op->gv; 2825 } 2826 } 2827 2828 sub pp_gvsv { 2829 my $self = shift; 2830 my($op, $cx) = @_; 2831 my $gv = $self->gv_or_padgv($op); 2832 return $self->maybe_local($op, $cx, $self->stash_variable("\$", 2833 $self->gv_name($gv))); 2834 } 2835 2836 sub pp_gv { 2837 my $self = shift; 2838 my($op, $cx) = @_; 2839 my $gv = $self->gv_or_padgv($op); 2840 return $self->gv_name($gv); 2841 } 2842 2843 sub pp_aelemfast { 2844 my $self = shift; 2845 my($op, $cx) = @_; 2846 my $name; 2847 if ($op->flags & OPf_SPECIAL) { # optimised PADAV 2848 $name = $self->padname($op->targ); 2849 $name =~ s/^@/\$/; 2850 } 2851 else { 2852 my $gv = $self->gv_or_padgv($op); 2853 $name = $self->gv_name($gv); 2854 $name = $self->{'curstash'}."::$name" 2855 if $name !~ /::/ && $self->lex_in_scope('@'.$name); 2856 $name = '$' . $name; 2857 } 2858 2859 return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; 2860 } 2861 2862 sub rv2x { 2863 my $self = shift; 2864 my($op, $cx, $type) = @_; 2865 2866 if (class($op) eq 'NULL' || !$op->can("first")) { 2867 carp("Unexpected op in pp_rv2x"); 2868 return 'XXX'; 2869 } 2870 my $kid = $op->first; 2871 if ($kid->name eq "gv") { 2872 return $self->stash_variable($type, $self->deparse($kid, 0)); 2873 } elsif (is_scalar $kid) { 2874 my $str = $self->deparse($kid, 0); 2875 if ($str =~ /^\$([^\w\d])\z/) { 2876 # "$$+" isn't a legal way to write the scalar dereference 2877 # of $+, since the lexer can't tell you aren't trying to 2878 # do something like "$$ + 1" to get one more than your 2879 # PID. Either "${$+}" or "$${+}" are workable 2880 # disambiguations, but if the programmer did the former, 2881 # they'd be in the "else" clause below rather than here. 2882 # It's not clear if this should somehow be unified with 2883 # the code in dq and re_dq that also adds lexer 2884 # disambiguation braces. 2885 $str = '$' . "{$1}"; #' 2886 } 2887 return $type . $str; 2888 } else { 2889 return $type . "{" . $self->deparse($kid, 0) . "}"; 2890 } 2891 } 2892 2893 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } 2894 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } 2895 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } 2896 2897 # skip rv2av 2898 sub pp_av2arylen { 2899 my $self = shift; 2900 my($op, $cx) = @_; 2901 if ($op->first->name eq "padav") { 2902 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); 2903 } else { 2904 return $self->maybe_local($op, $cx, 2905 $self->rv2x($op->first, $cx, '$#')); 2906 } 2907 } 2908 2909 # skip down to the old, ex-rv2cv 2910 sub pp_rv2cv { 2911 my ($self, $op, $cx) = @_; 2912 if (!null($op->first) && $op->first->name eq 'null' && 2913 $op->first->targ eq OP_LIST) 2914 { 2915 return $self->rv2x($op->first->first->sibling, $cx, "&") 2916 } 2917 else { 2918 return $self->rv2x($op, $cx, "") 2919 } 2920 } 2921 2922 sub list_const { 2923 my $self = shift; 2924 my($cx, @list) = @_; 2925 my @a = map $self->const($_, 6), @list; 2926 if (@a == 0) { 2927 return "()"; 2928 } elsif (@a == 1) { 2929 return $a[0]; 2930 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { 2931 # collapse (-1,0,1,2) into (-1..2) 2932 my ($s, $e) = @a[0,-1]; 2933 my $i = $s; 2934 return $self->maybe_parens("$s..$e", $cx, 9) 2935 unless grep $i++ != $_, @a; 2936 } 2937 return $self->maybe_parens(join(", ", @a), $cx, 6); 2938 } 2939 2940 sub pp_rv2av { 2941 my $self = shift; 2942 my($op, $cx) = @_; 2943 my $kid = $op->first; 2944 if ($kid->name eq "const") { # constant list 2945 my $av = $self->const_sv($kid); 2946 return $self->list_const($cx, $av->ARRAY); 2947 } else { 2948 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); 2949 } 2950 } 2951 2952 sub is_subscriptable { 2953 my $op = shift; 2954 if ($op->name =~ /^[ahg]elem/) { 2955 return 1; 2956 } elsif ($op->name eq "entersub") { 2957 my $kid = $op->first; 2958 return 0 unless null $kid->sibling; 2959 $kid = $kid->first; 2960 $kid = $kid->sibling until null $kid->sibling; 2961 return 0 if is_scope($kid); 2962 $kid = $kid->first; 2963 return 0 if $kid->name eq "gv"; 2964 return 0 if is_scalar($kid); 2965 return is_subscriptable($kid); 2966 } else { 2967 return 0; 2968 } 2969 } 2970 2971 sub elem_or_slice_array_name 2972 { 2973 my $self = shift; 2974 my ($array, $left, $padname, $allow_arrow) = @_; 2975 2976 if ($array->name eq $padname) { 2977 return $self->padany($array); 2978 } elsif (is_scope($array)) { # $expr}[0] 2979 return "{" . $self->deparse($array, 0) . "}"; 2980 } elsif ($array->name eq "gv") { 2981 $array = $self->gv_name($self->gv_or_padgv($array)); 2982 if ($array !~ /::/) { 2983 my $prefix = ($left eq '[' ? '@' : '%'); 2984 $array = $self->{curstash}.'::'.$array 2985 if $self->lex_in_scope($prefix . $array); 2986 } 2987 return $array; 2988 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ... 2989 return $self->deparse($array, 24); 2990 } else { 2991 return undef; 2992 } 2993 } 2994 2995 sub elem_or_slice_single_index 2996 { 2997 my $self = shift; 2998 my ($idx) = @_; 2999 3000 $idx = $self->deparse($idx, 1); 3001 3002 # Outer parens in an array index will confuse perl 3003 # if we're interpolating in a regular expression, i.e. 3004 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ 3005 # 3006 # If $self->{parens}, then an initial '(' will 3007 # definitely be paired with a final ')'. If 3008 # !$self->{parens}, the misleading parens won't 3009 # have been added in the first place. 3010 # 3011 # [You might think that we could get "(...)...(...)" 3012 # where the initial and final parens do not match 3013 # each other. But we can't, because the above would 3014 # only happen if there's an infix binop between the 3015 # two pairs of parens, and *that* means that the whole 3016 # expression would be parenthesized as well.] 3017 # 3018 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; 3019 3020 # Hash-element braces will autoquote a bareword inside themselves. 3021 # We need to make sure that C<$hash{warn()}> doesn't come out as 3022 # C<$hash{warn}>, which has a quite different meaning. Currently 3023 # B::Deparse will always quote strings, even if the string was a 3024 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored 3025 # for constant strings.) So we can cheat slightly here - if we see 3026 # a bareword, we know that it is supposed to be a function call. 3027 # 3028 $idx =~ s/^([A-Za-z_]\w*)$/$1()/; 3029 3030 return $idx; 3031 } 3032 3033 sub elem { 3034 my $self = shift; 3035 my ($op, $cx, $left, $right, $padname) = @_; 3036 my($array, $idx) = ($op->first, $op->first->sibling); 3037 3038 $idx = $self->elem_or_slice_single_index($idx); 3039 3040 unless ($array->name eq $padname) { # Maybe this has been fixed 3041 $array = $array->first; # skip rv2av (or ex-rv2av in _53+) 3042 } 3043 if (my $array_name=$self->elem_or_slice_array_name 3044 ($array, $left, $padname, 1)) { 3045 return "\$" . $array_name . $left . $idx . $right; 3046 } else { 3047 # $x[20][3]{hi} or expr->[20] 3048 my $arrow = is_subscriptable($array) ? "" : "->"; 3049 return $self->deparse($array, 24) . $arrow . $left . $idx . $right; 3050 } 3051 3052 } 3053 3054 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } 3055 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } 3056 3057 sub pp_gelem { 3058 my $self = shift; 3059 my($op, $cx) = @_; 3060 my($glob, $part) = ($op->first, $op->last); 3061 $glob = $glob->first; # skip rv2gv 3062 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug 3063 my $scope = is_scope($glob); 3064 $glob = $self->deparse($glob, 0); 3065 $part = $self->deparse($part, 1); 3066 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; 3067 } 3068 3069 sub slice { 3070 my $self = shift; 3071 my ($op, $cx, $left, $right, $regname, $padname) = @_; 3072 my $last; 3073 my(@elems, $kid, $array, $list); 3074 if (class($op) eq "LISTOP") { 3075 $last = $op->last; 3076 } else { # ex-hslice inside delete() 3077 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} 3078 $last = $kid; 3079 } 3080 $array = $last; 3081 $array = $array->first 3082 if $array->name eq $regname or $array->name eq "null"; 3083 $array = $self->elem_or_slice_array_name($array,$left,$padname,0); 3084 $kid = $op->first->sibling; # skip pushmark 3085 if ($kid->name eq "list") { 3086 $kid = $kid->first->sibling; # skip list, pushmark 3087 for (; !null $kid; $kid = $kid->sibling) { 3088 push @elems, $self->deparse($kid, 6); 3089 } 3090 $list = join(", ", @elems); 3091 } else { 3092 $list = $self->elem_or_slice_single_index($kid); 3093 } 3094 return "\@" . $array . $left . $list . $right; 3095 } 3096 3097 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } 3098 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } 3099 3100 sub pp_lslice { 3101 my $self = shift; 3102 my($op, $cx) = @_; 3103 my $idx = $op->first; 3104 my $list = $op->last; 3105 my(@elems, $kid); 3106 $list = $self->deparse($list, 1); 3107 $idx = $self->deparse($idx, 1); 3108 return "($list)" . "[$idx]"; 3109 } 3110 3111 sub want_scalar { 3112 my $op = shift; 3113 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; 3114 } 3115 3116 sub want_list { 3117 my $op = shift; 3118 return ($op->flags & OPf_WANT) == OPf_WANT_LIST; 3119 } 3120 3121 sub _method { 3122 my $self = shift; 3123 my($op, $cx) = @_; 3124 my $kid = $op->first->sibling; # skip pushmark 3125 my($meth, $obj, @exprs); 3126 if ($kid->name eq "list" and want_list $kid) { 3127 # When an indirect object isn't a bareword but the args are in 3128 # parens, the parens aren't part of the method syntax (the LLAFR 3129 # doesn't apply), but they make a list with OPf_PARENS set that 3130 # doesn't get flattened by the append_elem that adds the method, 3131 # making a (object, arg1, arg2, ...) list where the object 3132 # usually is. This can be distinguished from 3133 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an 3134 # object) because in the later the list is in scalar context 3135 # as the left side of -> always is, while in the former 3136 # the list is in list context as method arguments always are. 3137 # (Good thing there aren't method prototypes!) 3138 $meth = $kid->sibling; 3139 $kid = $kid->first->sibling; # skip pushmark 3140 $obj = $kid; 3141 $kid = $kid->sibling; 3142 for (; not null $kid; $kid = $kid->sibling) { 3143 push @exprs, $kid; 3144 } 3145 } else { 3146 $obj = $kid; 3147 $kid = $kid->sibling; 3148 for (; !null ($kid->sibling) && $kid->name ne "method_named"; 3149 $kid = $kid->sibling) { 3150 push @exprs, $kid 3151 } 3152 $meth = $kid; 3153 } 3154 3155 if ($meth->name eq "method_named") { 3156 $meth = $self->const_sv($meth)->PV; 3157 } else { 3158 $meth = $meth->first; 3159 if ($meth->name eq "const") { 3160 # As of 5.005_58, this case is probably obsoleted by the 3161 # method_named case above 3162 $meth = $self->const_sv($meth)->PV; # needs to be bare 3163 } 3164 } 3165 3166 return { method => $meth, variable_method => ref($meth), 3167 object => $obj, args => \@exprs }; 3168 } 3169 3170 # compat function only 3171 sub method { 3172 my $self = shift; 3173 my $info = $self->_method(@_); 3174 return $self->e_method( $self->_method(@_) ); 3175 } 3176 3177 sub e_method { 3178 my ($self, $info) = @_; 3179 my $obj = $self->deparse($info->{object}, 24); 3180 3181 my $meth = $info->{method}; 3182 $meth = $self->deparse($meth, 1) if $info->{variable_method}; 3183 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} ); 3184 my $kid = $obj . "->" . $meth; 3185 if (length $args) { 3186 return $kid . "(" . $args . ")"; # parens mandatory 3187 } else { 3188 return $kid; 3189 } 3190 } 3191 3192 # returns "&" if the prototype doesn't match the args, 3193 # or ("", $args_after_prototype_demunging) if it does. 3194 sub check_proto { 3195 my $self = shift; 3196 return "&" if $self->{'noproto'}; 3197 my($proto, @args) = @_; 3198 my($arg, $real); 3199 my $doneok = 0; 3200 my @reals; 3201 # An unbackslashed @ or % gobbles up the rest of the args 3202 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/; 3203 while ($proto) { 3204 $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//; 3205 my $chr = $1; 3206 if ($chr eq "") { 3207 return "&" if @args; 3208 } elsif ($chr eq ";") { 3209 $doneok = 1; 3210 } elsif ($chr eq "@" or $chr eq "%") { 3211 push @reals, map($self->deparse($_, 6), @args); 3212 @args = (); 3213 } else { 3214 $arg = shift @args; 3215 last unless $arg; 3216 if ($chr eq "\$") { 3217 if (want_scalar $arg) { 3218 push @reals, $self->deparse($arg, 6); 3219 } else { 3220 return "&"; 3221 } 3222 } elsif ($chr eq "&") { 3223 if ($arg->name =~ /^(s?refgen|undef)$/) { 3224 push @reals, $self->deparse($arg, 6); 3225 } else { 3226 return "&"; 3227 } 3228 } elsif ($chr eq "*") { 3229 if ($arg->name =~ /^s?refgen$/ 3230 and $arg->first->first->name eq "rv2gv") 3231 { 3232 $real = $arg->first->first; # skip refgen, null 3233 if ($real->first->name eq "gv") { 3234 push @reals, $self->deparse($real, 6); 3235 } else { 3236 push @reals, $self->deparse($real->first, 6); 3237 } 3238 } else { 3239 return "&"; 3240 } 3241 } elsif (substr($chr, 0, 1) eq "\\") { 3242 $chr =~ tr/\\[]//d; 3243 if ($arg->name =~ /^s?refgen$/ and 3244 !null($real = $arg->first) and 3245 ($chr =~ /\$/ && is_scalar($real->first) 3246 or ($chr =~ /@/ 3247 && class($real->first->sibling) ne 'NULL' 3248 && $real->first->sibling->name 3249 =~ /^(rv2|pad)av$/) 3250 or ($chr =~ /%/ 3251 && class($real->first->sibling) ne 'NULL' 3252 && $real->first->sibling->name 3253 =~ /^(rv2|pad)hv$/) 3254 #or ($chr =~ /&/ # This doesn't work 3255 # && $real->first->name eq "rv2cv") 3256 or ($chr =~ /\*/ 3257 && $real->first->name eq "rv2gv"))) 3258 { 3259 push @reals, $self->deparse($real, 6); 3260 } else { 3261 return "&"; 3262 } 3263 } 3264 } 3265 } 3266 return "&" if $proto and !$doneok; # too few args and no `;' 3267 return "&" if @args; # too many args 3268 return ("", join ", ", @reals); 3269 } 3270 3271 sub pp_entersub { 3272 my $self = shift; 3273 my($op, $cx) = @_; 3274 return $self->e_method($self->_method($op, $cx)) 3275 unless null $op->first->sibling; 3276 my $prefix = ""; 3277 my $amper = ""; 3278 my($kid, @exprs); 3279 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) { 3280 $prefix = "do "; 3281 } elsif ($op->private & OPpENTERSUB_AMPER) { 3282 $amper = "&"; 3283 } 3284 $kid = $op->first; 3285 $kid = $kid->first->sibling; # skip ex-list, pushmark 3286 for (; not null $kid->sibling; $kid = $kid->sibling) { 3287 push @exprs, $kid; 3288 } 3289 my $simple = 0; 3290 my $proto = undef; 3291 if (is_scope($kid)) { 3292 $amper = "&"; 3293 $kid = "{" . $self->deparse($kid, 0) . "}"; 3294 } elsif ($kid->first->name eq "gv") { 3295 my $gv = $self->gv_or_padgv($kid->first); 3296 if (class($gv->CV) ne "SPECIAL") { 3297 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; 3298 } 3299 $simple = 1; # only calls of named functions can be prototyped 3300 $kid = $self->deparse($kid, 24); 3301 if (!$amper) { 3302 if ($kid eq 'main::') { 3303 $kid = '::'; 3304 } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) { 3305 $kid = single_delim("q", "'", $kid) . '->'; 3306 } 3307 } 3308 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { 3309 $amper = "&"; 3310 $kid = $self->deparse($kid, 24); 3311 } else { 3312 $prefix = ""; 3313 my $arrow = is_subscriptable($kid->first) ? "" : "->"; 3314 $kid = $self->deparse($kid, 24) . $arrow; 3315 } 3316 3317 # Doesn't matter how many prototypes there are, if 3318 # they haven't happened yet! 3319 my $declared; 3320 { 3321 no strict 'refs'; 3322 no warnings 'uninitialized'; 3323 $declared = exists $self->{'subs_declared'}{$kid} 3324 || ( 3325 defined &{ ${$self->{'curstash'}."::"}{$kid} } 3326 && !exists 3327 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} 3328 && defined prototype $self->{'curstash'}."::".$kid 3329 ); 3330 if (!$declared && defined($proto)) { 3331 # Avoid "too early to check prototype" warning 3332 ($amper, $proto) = ('&'); 3333 } 3334 } 3335 3336 my $args; 3337 if ($declared and defined $proto and not $amper) { 3338 ($amper, $args) = $self->check_proto($proto, @exprs); 3339 if ($amper eq "&") { 3340 $args = join(", ", map($self->deparse($_, 6), @exprs)); 3341 } 3342 } else { 3343 $args = join(", ", map($self->deparse($_, 6), @exprs)); 3344 } 3345 if ($prefix or $amper) { 3346 if ($op->flags & OPf_STACKED) { 3347 return $prefix . $amper . $kid . "(" . $args . ")"; 3348 } else { 3349 return $prefix . $amper. $kid; 3350 } 3351 } else { 3352 # glob() invocations can be translated into calls of 3353 # CORE::GLOBAL::glob with a second parameter, a number. 3354 # Reverse this. 3355 if ($kid eq "CORE::GLOBAL::glob") { 3356 $kid = "glob"; 3357 $args =~ s/\s*,[^,]+$//; 3358 } 3359 3360 # It's a syntax error to call CORE::GLOBAL::foo without a prefix, 3361 # so it must have been translated from a keyword call. Translate 3362 # it back. 3363 $kid =~ s/^CORE::GLOBAL:://; 3364 3365 my $dproto = defined($proto) ? $proto : "undefined"; 3366 if (!$declared) { 3367 return "$kid(" . $args . ")"; 3368 } elsif ($dproto eq "") { 3369 return $kid; 3370 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) { 3371 # is_scalar is an excessively conservative test here: 3372 # really, we should be comparing to the precedence of the 3373 # top operator of $exprs[0] (ala unop()), but that would 3374 # take some major code restructuring to do right. 3375 return $self->maybe_parens_func($kid, $args, $cx, 16); 3376 } elsif ($dproto ne '$' and defined($proto) || $simple) { #' 3377 return $self->maybe_parens_func($kid, $args, $cx, 5); 3378 } else { 3379 return "$kid(" . $args . ")"; 3380 } 3381 } 3382 } 3383 3384 sub pp_enterwrite { unop(@_, "write") } 3385 3386 # escape things that cause interpolation in double quotes, 3387 # but not character escapes 3388 sub uninterp { 3389 my($str) = @_; 3390 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; 3391 return $str; 3392 } 3393 3394 { 3395 my $bal; 3396 BEGIN { 3397 use re "eval"; 3398 # Matches any string which is balanced with respect to {braces} 3399 $bal = qr( 3400 (?: 3401 [^\\{}] 3402 | \\\\ 3403 | \\[{}] 3404 | \{(??{$bal})\} 3405 )* 3406 )x; 3407 } 3408 3409 # the same, but treat $|, $), $( and $ at the end of the string differently 3410 sub re_uninterp { 3411 my($str) = @_; 3412 3413 $str =~ s/ 3414 ( ^|\G # $1 3415 | [^\\] 3416 ) 3417 3418 ( # $2 3419 (?:\\\\)* 3420 ) 3421 3422 ( # $3 3423 (\(\?\??\{$bal\}\)) # $4 3424 | [\$\@] 3425 (?!\||\)|\(|$) 3426 | \\[uUlLQE] 3427 ) 3428 3429 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; 3430 3431 return $str; 3432 } 3433 3434 # This is for regular expressions with the /x modifier 3435 # We have to leave comments unmangled. 3436 sub re_uninterp_extended { 3437 my($str) = @_; 3438 3439 $str =~ s/ 3440 ( ^|\G # $1 3441 | [^\\] 3442 ) 3443 3444 ( # $2 3445 (?:\\\\)* 3446 ) 3447 3448 ( # $3 3449 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) 3450 | \#[^\n]* # (skip over comments) 3451 ) 3452 | [\$\@] 3453 (?!\||\)|\(|$|\s) 3454 | \\[uUlLQE] 3455 ) 3456 3457 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; 3458 3459 return $str; 3460 } 3461 } 3462 3463 my %unctrl = # portable to to EBCDIC 3464 ( 3465 "\c@" => '\c@', # unused 3466 "\cA" => '\cA', 3467 "\cB" => '\cB', 3468 "\cC" => '\cC', 3469 "\cD" => '\cD', 3470 "\cE" => '\cE', 3471 "\cF" => '\cF', 3472 "\cG" => '\cG', 3473 "\cH" => '\cH', 3474 "\cI" => '\cI', 3475 "\cJ" => '\cJ', 3476 "\cK" => '\cK', 3477 "\cL" => '\cL', 3478 "\cM" => '\cM', 3479 "\cN" => '\cN', 3480 "\cO" => '\cO', 3481 "\cP" => '\cP', 3482 "\cQ" => '\cQ', 3483 "\cR" => '\cR', 3484 "\cS" => '\cS', 3485 "\cT" => '\cT', 3486 "\cU" => '\cU', 3487 "\cV" => '\cV', 3488 "\cW" => '\cW', 3489 "\cX" => '\cX', 3490 "\cY" => '\cY', 3491 "\cZ" => '\cZ', 3492 "\c[" => '\c[', # unused 3493 "\c\\" => '\c\\', # unused 3494 "\c]" => '\c]', # unused 3495 "\c_" => '\c_', # unused 3496 ); 3497 3498 # character escapes, but not delimiters that might need to be escaped 3499 sub escape_str { # ASCII, UTF8 3500 my($str) = @_; 3501 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; 3502 $str =~ s/\a/\\a/g; 3503 # $str =~ s/\cH/\\b/g; # \b means something different in a regex 3504 $str =~ s/\t/\\t/g; 3505 $str =~ s/\n/\\n/g; 3506 $str =~ s/\e/\\e/g; 3507 $str =~ s/\f/\\f/g; 3508 $str =~ s/\r/\\r/g; 3509 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge; 3510 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge; 3511 return $str; 3512 } 3513 3514 # For regexes with the /x modifier. 3515 # Leave whitespace unmangled. 3516 sub escape_extended_re { 3517 my($str) = @_; 3518 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; 3519 $str =~ s/([[:^print:]])/ 3520 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge; 3521 $str =~ s/\n/\n\f/g; 3522 return $str; 3523 } 3524 3525 # Don't do this for regexen 3526 sub unback { 3527 my($str) = @_; 3528 $str =~ s/\\/\\\\/g; 3529 return $str; 3530 } 3531 3532 # Remove backslashes which precede literal control characters, 3533 # to avoid creating ambiguity when we escape the latter. 3534 sub re_unback { 3535 my($str) = @_; 3536 3537 # the insane complexity here is due to the behaviour of "\c\" 3538 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g; 3539 return $str; 3540 } 3541 3542 sub balanced_delim { 3543 my($str) = @_; 3544 my @str = split //, $str; 3545 my($ar, $open, $close, $fail, $c, $cnt, $last_bs); 3546 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { 3547 ($open, $close) = @$ar; 3548 $fail = 0; $cnt = 0; $last_bs = 0; 3549 for $c (@str) { 3550 if ($c eq $open) { 3551 $fail = 1 if $last_bs; 3552 $cnt++; 3553 } elsif ($c eq $close) { 3554 $fail = 1 if $last_bs; 3555 $cnt--; 3556 if ($cnt < 0) { 3557 # qq()() isn't ")(" 3558 $fail = 1; 3559 last; 3560 } 3561 } 3562 $last_bs = $c eq '\\'; 3563 } 3564 $fail = 1 if $cnt != 0; 3565 return ($open, "$open$str$close") if not $fail; 3566 } 3567 return ("", $str); 3568 } 3569 3570 sub single_delim { 3571 my($q, $default, $str) = @_; 3572 return "$default$str$default" if $default and index($str, $default) == -1; 3573 if ($q ne 'qr') { 3574 (my $succeed, $str) = balanced_delim($str); 3575 return "$q$str" if $succeed; 3576 } 3577 for my $delim ('/', '"', '#') { 3578 return "$q$delim" . $str . $delim if index($str, $delim) == -1; 3579 } 3580 if ($default) { 3581 $str =~ s/$default/\\$default/g; 3582 return "$default$str$default"; 3583 } else { 3584 $str =~ s[/][\\/]g; 3585 return "$q/$str/"; 3586 } 3587 } 3588 3589 my $max_prec; 3590 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } 3591 3592 # Split a floating point number into an integer mantissa and a binary 3593 # exponent. Assumes you've already made sure the number isn't zero or 3594 # some weird infinity or NaN. 3595 sub split_float { 3596 my($f) = @_; 3597 my $exponent = 0; 3598 if ($f == int($f)) { 3599 while ($f % 2 == 0) { 3600 $f /= 2; 3601 $exponent++; 3602 } 3603 } else { 3604 while ($f != int($f)) { 3605 $f *= 2; 3606 $exponent--; 3607 } 3608 } 3609 my $mantissa = sprintf("%.0f", $f); 3610 return ($mantissa, $exponent); 3611 } 3612 3613 sub const { 3614 my $self = shift; 3615 my($sv, $cx) = @_; 3616 if ($self->{'use_dumper'}) { 3617 return $self->const_dumper($sv, $cx); 3618 } 3619 if (class($sv) eq "SPECIAL") { 3620 # sv_undef, sv_yes, sv_no 3621 return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1]; 3622 } elsif (class($sv) eq "NULL") { 3623 return 'undef'; 3624 } 3625 # convert a version object into the "v1.2.3" string in its V magic 3626 if ($sv->FLAGS & SVs_RMG) { 3627 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { 3628 return $mg->PTR if $mg->TYPE eq 'V'; 3629 } 3630 } 3631 3632 if ($sv->FLAGS & SVf_IOK) { 3633 my $str = $sv->int_value; 3634 $str = $self->maybe_parens($str, $cx, 21) if $str < 0; 3635 return $str; 3636 } elsif ($sv->FLAGS & SVf_NOK) { 3637 my $nv = $sv->NV; 3638 if ($nv == 0) { 3639 if (pack("F", $nv) eq pack("F", 0)) { 3640 # positive zero 3641 return "0"; 3642 } else { 3643 # negative zero 3644 return $self->maybe_parens("-.0", $cx, 21); 3645 } 3646 } elsif (1/$nv == 0) { 3647 if ($nv > 0) { 3648 # positive infinity 3649 return $self->maybe_parens("9**9**9", $cx, 22); 3650 } else { 3651 # negative infinity 3652 return $self->maybe_parens("-9**9**9", $cx, 21); 3653 } 3654 } elsif ($nv != $nv) { 3655 # NaN 3656 if (pack("F", $nv) eq pack("F", sin(9**9**9))) { 3657 # the normal kind 3658 return "sin(9**9**9)"; 3659 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { 3660 # the inverted kind 3661 return $self->maybe_parens("-sin(9**9**9)", $cx, 21); 3662 } else { 3663 # some other kind 3664 my $hex = unpack("h*", pack("F", $nv)); 3665 return qq'unpack("F", pack("h*", "$hex"))'; 3666 } 3667 } 3668 # first, try the default stringification 3669 my $str = "$nv"; 3670 if ($str != $nv) { 3671 # failing that, try using more precision 3672 $str = sprintf("%.$max_prec}g", $nv); 3673 # if (pack("F", $str) ne pack("F", $nv)) { 3674 if ($str != $nv) { 3675 # not representable in decimal with whatever sprintf() 3676 # and atof() Perl is using here. 3677 my($mant, $exp) = split_float($nv); 3678 return $self->maybe_parens("$mant * 2**$exp", $cx, 19); 3679 } 3680 } 3681 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; 3682 return $str; 3683 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { 3684 my $ref = $sv->RV; 3685 if (class($ref) eq "AV") { 3686 return "[" . $self->list_const(2, $ref->ARRAY) . "]"; 3687 } elsif (class($ref) eq "HV") { 3688 my %hash = $ref->ARRAY; 3689 my @elts; 3690 for my $k (sort keys %hash) { 3691 push @elts, "$k => " . $self->const($hash{$k}, 6); 3692 } 3693 return "{" . join(", ", @elts) . "}"; 3694 } elsif (class($ref) eq "CV") { 3695 return "sub " . $self->deparse_sub($ref); 3696 } 3697 if ($ref->FLAGS & SVs_SMG) { 3698 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { 3699 if ($mg->TYPE eq 'r') { 3700 my $re = re_uninterp(escape_str(re_unback($mg->precomp))); 3701 return single_delim("qr", "", $re); 3702 } 3703 } 3704 } 3705 3706 return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20); 3707 } elsif ($sv->FLAGS & SVf_POK) { 3708 my $str = $sv->PV; 3709 if ($str =~ /[[:^print:]]/) { 3710 return single_delim("qq", '"', uninterp escape_str unback $str); 3711 } else { 3712 return single_delim("q", "'", unback $str); 3713 } 3714 } else { 3715 return "undef"; 3716 } 3717 } 3718 3719 sub const_dumper { 3720 my $self = shift; 3721 my($sv, $cx) = @_; 3722 my $ref = $sv->object_2svref(); 3723 my $dumper = Data::Dumper->new([$$ref], ['$v']); 3724 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); 3725 my $str = $dumper->Dump(); 3726 if ($str =~ /^\$v/) { 3727 return '$my ' . $str . ' \$v}'; 3728 } else { 3729 return $str; 3730 } 3731 } 3732 3733 sub const_sv { 3734 my $self = shift; 3735 my $op = shift; 3736 my $sv = $op->sv; 3737 # the constant could be in the pad (under useithreads) 3738 $sv = $self->padval($op->targ) unless $$sv; 3739 return $sv; 3740 } 3741 3742 sub pp_const { 3743 my $self = shift; 3744 my($op, $cx) = @_; 3745 if ($op->private & OPpCONST_ARYBASE) { 3746 return '$['; 3747 } 3748 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting 3749 # return $self->const_sv($op)->PV; 3750 # } 3751 my $sv = $self->const_sv($op); 3752 return $self->const($sv, $cx); 3753 } 3754 3755 sub dq { 3756 my $self = shift; 3757 my $op = shift; 3758 my $type = $op->name; 3759 if ($type eq "const") { 3760 return '$[' if $op->private & OPpCONST_ARYBASE; 3761 return uninterp(escape_str(unback($self->const_sv($op)->as_string))); 3762 } elsif ($type eq "concat") { 3763 my $first = $self->dq($op->first); 3764 my $last = $self->dq($op->last); 3765 3766 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" 3767 ($last =~ /^[A-Z\\\^\[\]_?]/ && 3768 $first =~ s/([\$@])\^$/$1}{^}/) # "${^}W" etc 3769 || ($last =~ /^[:'{\[\w_]/ && #' 3770 $first =~ s/([\$@])([A-Za-z_]\w*)$/$1}{$2}/); 3771 3772 return $first . $last; 3773 } elsif ($type eq "uc") { 3774 return '\U' . $self->dq($op->first->sibling) . '\E'; 3775 } elsif ($type eq "lc") { 3776 return '\L' . $self->dq($op->first->sibling) . '\E'; 3777 } elsif ($type eq "ucfirst") { 3778 return '\u' . $self->dq($op->first->sibling); 3779 } elsif ($type eq "lcfirst") { 3780 return '\l' . $self->dq($op->first->sibling); 3781 } elsif ($type eq "quotemeta") { 3782 return '\Q' . $self->dq($op->first->sibling) . '\E'; 3783 } elsif ($type eq "join") { 3784 return $self->deparse($op->last, 26); # was join($", @ary) 3785 } else { 3786 return $self->deparse($op, 26); 3787 } 3788 } 3789 3790 sub pp_backtick { 3791 my $self = shift; 3792 my($op, $cx) = @_; 3793 # skip pushmark if it exists (readpipe() vs ``) 3794 my $child = $op->first->sibling->isa('B::NULL') 3795 ? $op->first->first : $op->first->sibling; 3796 return single_delim("qx", '`', $self->dq($child)); 3797 } 3798 3799 sub dquote { 3800 my $self = shift; 3801 my($op, $cx) = @_; 3802 my $kid = $op->first->sibling; # skip ex-stringify, pushmark 3803 return $self->deparse($kid, $cx) if $self->{'unquote'}; 3804 $self->maybe_targmy($kid, $cx, 3805 sub {single_delim("qq", '"', $self->dq($_[1]))}); 3806 } 3807 3808 # OP_STRINGIFY is a listop, but it only ever has one arg 3809 sub pp_stringify { maybe_targmy(@_, \&dquote) } 3810 3811 # tr/// and s/// (and tr[][], tr[]//, tr###, etc) 3812 # note that tr(from)/to/ is OK, but not tr/from/(to) 3813 sub double_delim { 3814 my($from, $to) = @_; 3815 my($succeed, $delim); 3816 if ($from !~ m[/] and $to !~ m[/]) { 3817 return "/$from/$to/"; 3818 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { 3819 if (($succeed, $to) = balanced_delim($to) and $succeed) { 3820 return "$from$to"; 3821 } else { 3822 for $delim ('/', '"', '#') { # note no `'' -- s''' is special 3823 return "$from$delim$to$delim" if index($to, $delim) == -1; 3824 } 3825 $to =~ s[/][\\/]g; 3826 return "$from/$to/"; 3827 } 3828 } else { 3829 for $delim ('/', '"', '#') { # note no ' 3830 return "$delim$from$delim$to$delim" 3831 if index($to . $from, $delim) == -1; 3832 } 3833 $from =~ s[/][\\/]g; 3834 $to =~ s[/][\\/]g; 3835 return "/$from/$to/"; 3836 } 3837 } 3838 3839 # Only used by tr///, so backslashes hyphens 3840 sub pchr { # ASCII 3841 my($n) = @_; 3842 if ($n == ord '\\') { 3843 return '\\\\'; 3844 } elsif ($n == ord "-") { 3845 return "\\-"; 3846 } elsif ($n >= ord(' ') and $n <= ord('~')) { 3847 return chr($n); 3848 } elsif ($n == ord "\a") { 3849 return '\\a'; 3850 } elsif ($n == ord "\b") { 3851 return '\\b'; 3852 } elsif ($n == ord "\t") { 3853 return '\\t'; 3854 } elsif ($n == ord "\n") { 3855 return '\\n'; 3856 } elsif ($n == ord "\e") { 3857 return '\\e'; 3858 } elsif ($n == ord "\f") { 3859 return '\\f'; 3860 } elsif ($n == ord "\r") { 3861 return '\\r'; 3862 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { 3863 return '\\c' . chr(ord("@") + $n); 3864 } else { 3865 # return '\x' . sprintf("%02x", $n); 3866 return '\\' . sprintf("%03o", $n); 3867 } 3868 } 3869 3870 sub collapse { 3871 my(@chars) = @_; 3872 my($str, $c, $tr) = (""); 3873 for ($c = 0; $c < @chars; $c++) { 3874 $tr = $chars[$c]; 3875 $str .= pchr($tr); 3876 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and 3877 $chars[$c + 2] == $tr + 2) 3878 { 3879 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) 3880 {} 3881 $str .= "-"; 3882 $str .= pchr($chars[$c]); 3883 } 3884 } 3885 return $str; 3886 } 3887 3888 sub tr_decode_byte { 3889 my($table, $flags) = @_; 3890 my(@table) = unpack("s*", $table); 3891 splice @table, 0x100, 1; # Number of subsequent elements 3892 my($c, $tr, @from, @to, @delfrom, $delhyphen); 3893 if ($table[ord "-"] != -1 and 3894 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) 3895 { 3896 $tr = $table[ord "-"]; 3897 $table[ord "-"] = -1; 3898 if ($tr >= 0) { 3899 @from = ord("-"); 3900 @to = $tr; 3901 } else { # -2 ==> delete 3902 $delhyphen = 1; 3903 } 3904 } 3905 for ($c = 0; $c < @table; $c++) { 3906 $tr = $table[$c]; 3907 if ($tr >= 0) { 3908 push @from, $c; push @to, $tr; 3909 } elsif ($tr == -2) { 3910 push @delfrom, $c; 3911 } 3912 } 3913 @from = (@from, @delfrom); 3914 if ($flags & OPpTRANS_COMPLEMENT) { 3915 my @newfrom = (); 3916 my %from; 3917 @from{@from} = (1) x @from; 3918 for ($c = 0; $c < 256; $c++) { 3919 push @newfrom, $c unless $from{$c}; 3920 } 3921 @from = @newfrom; 3922 } 3923 unless ($flags & OPpTRANS_DELETE || !@to) { 3924 pop @to while $#to and $to[$#to] == $to[$#to -1]; 3925 } 3926 my($from, $to); 3927 $from = collapse(@from); 3928 $to = collapse(@to); 3929 $from .= "-" if $delhyphen; 3930 return ($from, $to); 3931 } 3932 3933 sub tr_chr { 3934 my $x = shift; 3935 if ($x == ord "-") { 3936 return "\\-"; 3937 } elsif ($x == ord "\\") { 3938 return "\\\\"; 3939 } else { 3940 return chr $x; 3941 } 3942 } 3943 3944 # XXX This doesn't yet handle all cases correctly either 3945 3946 sub tr_decode_utf8 { 3947 my($swash_hv, $flags) = @_; 3948 my %swash = $swash_hv->ARRAY; 3949 my $final = undef; 3950 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; 3951 my $none = $swash{"NONE"}->IV; 3952 my $extra = $none + 1; 3953 my(@from, @delfrom, @to); 3954 my $line; 3955 foreach $line (split /\n/, $swash{'LIST'}->PV) { 3956 my($min, $max, $result) = split(/\t/, $line); 3957 $min = hex $min; 3958 if (length $max) { 3959 $max = hex $max; 3960 } else { 3961 $max = $min; 3962 } 3963 $result = hex $result; 3964 if ($result == $extra) { 3965 push @delfrom, [$min, $max]; 3966 } else { 3967 push @from, [$min, $max]; 3968 push @to, [$result, $result + $max - $min]; 3969 } 3970 } 3971 for my $i (0 .. $#from) { 3972 if ($from[$i][0] == ord '-') { 3973 unshift @from, splice(@from, $i, 1); 3974 unshift @to, splice(@to, $i, 1); 3975 last; 3976 } elsif ($from[$i][1] == ord '-') { 3977 $from[$i][1]--; 3978 $to[$i][1]--; 3979 unshift @from, ord '-'; 3980 unshift @to, ord '-'; 3981 last; 3982 } 3983 } 3984 for my $i (0 .. $#delfrom) { 3985 if ($delfrom[$i][0] == ord '-') { 3986 push @delfrom, splice(@delfrom, $i, 1); 3987 last; 3988 } elsif ($delfrom[$i][1] == ord '-') { 3989 $delfrom[$i][1]--; 3990 push @delfrom, ord '-'; 3991 last; 3992 } 3993 } 3994 if (defined $final and $to[$#to][1] != $final) { 3995 push @to, [$final, $final]; 3996 } 3997 push @from, @delfrom; 3998 if ($flags & OPpTRANS_COMPLEMENT) { 3999 my @newfrom; 4000 my $next = 0; 4001 for my $i (0 .. $#from) { 4002 push @newfrom, [$next, $from[$i][0] - 1]; 4003 $next = $from[$i][1] + 1; 4004 } 4005 @from = (); 4006 for my $range (@newfrom) { 4007 if ($range->[0] <= $range->[1]) { 4008 push @from, $range; 4009 } 4010 } 4011 } 4012 my($from, $to, $diff); 4013 for my $chunk (@from) { 4014 $diff = $chunk->[1] - $chunk->[0]; 4015 if ($diff > 1) { 4016 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); 4017 } elsif ($diff == 1) { 4018 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); 4019 } else { 4020 $from .= tr_chr($chunk->[0]); 4021 } 4022 } 4023 for my $chunk (@to) { 4024 $diff = $chunk->[1] - $chunk->[0]; 4025 if ($diff > 1) { 4026 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); 4027 } elsif ($diff == 1) { 4028 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); 4029 } else { 4030 $to .= tr_chr($chunk->[0]); 4031 } 4032 } 4033 #$final = sprintf("%04x", $final) if defined $final; 4034 #$none = sprintf("%04x", $none) if defined $none; 4035 #$extra = sprintf("%04x", $extra) if defined $extra; 4036 #print STDERR "final: $final\n none: $none\nextra: $extra\n"; 4037 #print STDERR $swash{'LIST'}->PV; 4038 return (escape_str($from), escape_str($to)); 4039 } 4040 4041 sub pp_trans { 4042 my $self = shift; 4043 my($op, $cx) = @_; 4044 my($from, $to); 4045 if (class($op) eq "PVOP") { 4046 ($from, $to) = tr_decode_byte($op->pv, $op->private); 4047 } else { # class($op) eq "SVOP" 4048 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private); 4049 } 4050 my $flags = ""; 4051 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT; 4052 $flags .= "d" if $op->private & OPpTRANS_DELETE; 4053 $to = "" if $from eq $to and $flags eq ""; 4054 $flags .= "s" if $op->private & OPpTRANS_SQUASH; 4055 return "tr" . double_delim($from, $to) . $flags; 4056 } 4057 4058 # Like dq(), but different 4059 sub re_dq { 4060 my $self = shift; 4061 my ($op, $extended) = @_; 4062 4063 my $type = $op->name; 4064 if ($type eq "const") { 4065 return '$[' if $op->private & OPpCONST_ARYBASE; 4066 my $unbacked = re_unback($self->const_sv($op)->as_string); 4067 return re_uninterp_extended(escape_extended_re($unbacked)) 4068 if $extended; 4069 return re_uninterp(escape_str($unbacked)); 4070 } elsif ($type eq "concat") { 4071 my $first = $self->re_dq($op->first, $extended); 4072 my $last = $self->re_dq($op->last, $extended); 4073 4074 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" 4075 ($last =~ /^[A-Z\\\^\[\]_?]/ && 4076 $first =~ s/([\$@])\^$/$1}{^}/) # "${^}W" etc 4077 || ($last =~ /^[{\[\w_]/ && 4078 $first =~ s/([\$@])([A-Za-z_]\w*)$/$1}{$2}/); 4079 4080 return $first . $last; 4081 } elsif ($type eq "uc") { 4082 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E'; 4083 } elsif ($type eq "lc") { 4084 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E'; 4085 } elsif ($type eq "ucfirst") { 4086 return '\u' . $self->re_dq($op->first->sibling, $extended); 4087 } elsif ($type eq "lcfirst") { 4088 return '\l' . $self->re_dq($op->first->sibling, $extended); 4089 } elsif ($type eq "quotemeta") { 4090 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E'; 4091 } elsif ($type eq "join") { 4092 return $self->deparse($op->last, 26); # was join($", @ary) 4093 } else { 4094 return $self->deparse($op, 26); 4095 } 4096 } 4097 4098 sub pure_string { 4099 my ($self, $op) = @_; 4100 return 0 if null $op; 4101 my $type = $op->name; 4102 4103 if ($type eq 'const') { 4104 return 1; 4105 } 4106 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') { 4107 return $self->pure_string($op->first->sibling); 4108 } 4109 elsif ($type eq 'join') { 4110 my $join_op = $op->first->sibling; # Skip pushmark 4111 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV; 4112 4113 my $gvop = $join_op->first; 4114 return 0 unless $gvop->name eq 'gvsv'; 4115 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); 4116 4117 return 0 unless ${$join_op->sibling} eq ${$op->last}; 4118 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/; 4119 } 4120 elsif ($type eq 'concat') { 4121 return $self->pure_string($op->first) 4122 && $self->pure_string($op->last); 4123 } 4124 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { 4125 return 1; 4126 } 4127 elsif ($type eq "null" and $op->can('first') and not null $op->first and 4128 $op->first->name eq "null" and $op->first->can('first') 4129 and not null $op->first->first and 4130 $op->first->first->name eq "aelemfast") { 4131 return 1; 4132 } 4133 else { 4134 return 0; 4135 } 4136 4137 return 1; 4138 } 4139 4140 sub regcomp { 4141 my $self = shift; 4142 my($op, $cx, $extended) = @_; 4143 my $kid = $op->first; 4144 $kid = $kid->first if $kid->name eq "regcmaybe"; 4145 $kid = $kid->first if $kid->name eq "regcreset"; 4146 if ($kid->name eq "null" and !null($kid->first) 4147 and $kid->first->name eq 'pushmark') 4148 { 4149 my $str = ''; 4150 $kid = $kid->first->sibling; 4151 while (!null($kid)) { 4152 $str .= $self->re_dq($kid, $extended); 4153 $kid = $kid->sibling; 4154 } 4155 return $str, 1; 4156 } 4157 4158 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid); 4159 return ($self->deparse($kid, $cx), 0); 4160 } 4161 4162 sub pp_regcomp { 4163 my ($self, $op, $cx) = @_; 4164 return (($self->regcomp($op, $cx, 0))[0]); 4165 } 4166 4167 # osmic acid -- see osmium tetroxide 4168 4169 my %matchwords; 4170 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', 4171 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', 4172 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); 4173 4174 sub matchop { 4175 my $self = shift; 4176 my($op, $cx, $name, $delim) = @_; 4177 my $kid = $op->first; 4178 my ($binop, $var, $re) = ("", "", ""); 4179 if ($op->flags & OPf_STACKED) { 4180 $binop = 1; 4181 $var = $self->deparse($kid, 20); 4182 $kid = $kid->sibling; 4183 } 4184 my $quote = 1; 4185 my $extended = ($op->pmflags & PMf_EXTENDED); 4186 if (null $kid) { 4187 my $unbacked = re_unback($op->precomp); 4188 if ($extended) { 4189 $re = re_uninterp_extended(escape_extended_re($unbacked)); 4190 } else { 4191 $re = re_uninterp(escape_str(re_unback($op->precomp))); 4192 } 4193 } elsif ($kid->name ne 'regcomp') { 4194 carp("found ".$kid->name." where regcomp expected"); 4195 } else { 4196 ($re, $quote) = $self->regcomp($kid, 21, $extended); 4197 } 4198 my $flags = ""; 4199 $flags .= "c" if $op->pmflags & PMf_CONTINUE; 4200 $flags .= "g" if $op->pmflags & PMf_GLOBAL; 4201 $flags .= "i" if $op->pmflags & PMf_FOLD; 4202 $flags .= "m" if $op->pmflags & PMf_MULTILINE; 4203 $flags .= "o" if $op->pmflags & PMf_KEEP; 4204 $flags .= "s" if $op->pmflags & PMf_SINGLELINE; 4205 $flags .= "x" if $op->pmflags & PMf_EXTENDED; 4206 $flags = $matchwords{$flags} if $matchwords{$flags}; 4207 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here 4208 $re =~ s/\?/\\?/g; 4209 $re = "?$re?"; 4210 } elsif ($quote) { 4211 $re = single_delim($name, $delim, $re); 4212 } 4213 $re = $re . $flags if $quote; 4214 if ($binop) { 4215 return $self->maybe_parens("$var =~ $re", $cx, 20); 4216 } else { 4217 return $re; 4218 } 4219 } 4220 4221 sub pp_match { matchop(@_, "m", "/") } 4222 sub pp_pushre { matchop(@_, "m", "/") } 4223 sub pp_qr { matchop(@_, "qr", "") } 4224 4225 sub pp_split { 4226 my $self = shift; 4227 my($op, $cx) = @_; 4228 my($kid, @exprs, $ary, $expr); 4229 $kid = $op->first; 4230 4231 # For our kid (an OP_PUSHRE), pmreplroot is never actually the 4232 # root of a replacement; it's either empty, or abused to point to 4233 # the GV for an array we split into (an optimization to save 4234 # assignment overhead). Depending on whether we're using ithreads, 4235 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs 4236 # figures out for us which it is. 4237 my $replroot = $kid->pmreplroot; 4238 my $gv = 0; 4239 if (ref($replroot) eq "B::GV") { 4240 $gv = $replroot; 4241 } elsif (!ref($replroot) and $replroot > 0) { 4242 $gv = $self->padval($replroot); 4243 } 4244 $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv; 4245 4246 for (; !null($kid); $kid = $kid->sibling) { 4247 push @exprs, $self->deparse($kid, 6); 4248 } 4249 4250 # handle special case of split(), and split(' ') that compiles to /\s+/ 4251 $kid = $op->first; 4252 if ( $kid->flags & OPf_SPECIAL 4253 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE() 4254 : $kid->reflags & RXf_SKIPWHITE() ) ) { 4255 $exprs[0] = "' '"; 4256 } 4257 4258 $expr = "split(" . join(", ", @exprs) . ")"; 4259 if ($ary) { 4260 return $self->maybe_parens("$ary = $expr", $cx, 7); 4261 } else { 4262 return $expr; 4263 } 4264 } 4265 4266 # oxime -- any of various compounds obtained chiefly by the action of 4267 # hydroxylamine on aldehydes and ketones and characterized by the 4268 # bivalent grouping C=NOH [Webster's Tenth] 4269 4270 my %substwords; 4271 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', 4272 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', 4273 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', 4274 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi'); 4275 4276 sub pp_subst { 4277 my $self = shift; 4278 my($op, $cx) = @_; 4279 my $kid = $op->first; 4280 my($binop, $var, $re, $repl) = ("", "", "", ""); 4281 if ($op->flags & OPf_STACKED) { 4282 $binop = 1; 4283 $var = $self->deparse($kid, 20); 4284 $kid = $kid->sibling; 4285 } 4286 my $flags = ""; 4287 if (null($op->pmreplroot)) { 4288 $repl = $self->dq($kid); 4289 $kid = $kid->sibling; 4290 } else { 4291 $repl = $op->pmreplroot->first; # skip substcont 4292 while ($repl->name eq "entereval") { 4293 $repl = $repl->first; 4294 $flags .= "e"; 4295 } 4296 if ($op->pmflags & PMf_EVAL) { 4297 $repl = $self->deparse($repl->first, 0); 4298 } else { 4299 $repl = $self->dq($repl); 4300 } 4301 } 4302 my $extended = ($op->pmflags & PMf_EXTENDED); 4303 if (null $kid) { 4304 my $unbacked = re_unback($op->precomp); 4305 if ($extended) { 4306 $re = re_uninterp_extended(escape_extended_re($unbacked)); 4307 } 4308 else { 4309 $re = re_uninterp(escape_str($unbacked)); 4310 } 4311 } else { 4312 ($re) = $self->regcomp($kid, 1, $extended); 4313 } 4314 $flags .= "e" if $op->pmflags & PMf_EVAL; 4315 $flags .= "g" if $op->pmflags & PMf_GLOBAL; 4316 $flags .= "i" if $op->pmflags & PMf_FOLD; 4317 $flags .= "m" if $op->pmflags & PMf_MULTILINE; 4318 $flags .= "o" if $op->pmflags & PMf_KEEP; 4319 $flags .= "s" if $op->pmflags & PMf_SINGLELINE; 4320 $flags .= "x" if $extended; 4321 $flags = $substwords{$flags} if $substwords{$flags}; 4322 if ($binop) { 4323 return $self->maybe_parens("$var =~ s" 4324 . double_delim($re, $repl) . $flags, 4325 $cx, 20); 4326 } else { 4327 return "s". double_delim($re, $repl) . $flags; 4328 } 4329 } 4330 4331 1; 4332 __END__ 4333 4334 =head1 NAME 4335 4336 B::Deparse - Perl compiler backend to produce perl code 4337 4338 =head1 SYNOPSIS 4339 4340 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>] 4341 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> 4342 4343 =head1 DESCRIPTION 4344 4345 B::Deparse is a backend module for the Perl compiler that generates 4346 perl source code, based on the internal compiled structure that perl 4347 itself creates after parsing a program. The output of B::Deparse won't 4348 be exactly the same as the original source, since perl doesn't keep 4349 track of comments or whitespace, and there isn't a one-to-one 4350 correspondence between perl's syntactical constructions and their 4351 compiled form, but it will often be close. When you use the B<-p> 4352 option, the output also includes parentheses even when they are not 4353 required by precedence, which can make it easy to see if perl is 4354 parsing your expressions the way you intended. 4355 4356 While B::Deparse goes to some lengths to try to figure out what your 4357 original program was doing, some parts of the language can still trip 4358 it up; it still fails even on some parts of Perl's own test suite. If 4359 you encounter a failure other than the most common ones described in 4360 the BUGS section below, you can help contribute to B::Deparse's 4361 ongoing development by submitting a bug report with a small 4362 example. 4363 4364 =head1 OPTIONS 4365 4366 As with all compiler backend options, these must follow directly after 4367 the '-MO=Deparse', separated by a comma but not any white space. 4368 4369 =over 4 4370 4371 =item B<-d> 4372 4373 Output data values (when they appear as constants) using Data::Dumper. 4374 Without this option, B::Deparse will use some simple routines of its 4375 own for the same purpose. Currently, Data::Dumper is better for some 4376 kinds of data (such as complex structures with sharing and 4377 self-reference) while the built-in routines are better for others 4378 (such as odd floating-point values). 4379 4380 =item B<-f>I<FILE> 4381 4382 Normally, B::Deparse deparses the main code of a program, and all the subs 4383 defined in the same file. To include subs defined in other files, pass the 4384 B<-f> option with the filename. You can pass the B<-f> option several times, to 4385 include more than one secondary file. (Most of the time you don't want to 4386 use it at all.) You can also use this option to include subs which are 4387 defined in the scope of a B<#line> directive with two parameters. 4388 4389 =item B<-l> 4390 4391 Add '#line' declarations to the output based on the line and file 4392 locations of the original code. 4393 4394 =item B<-p> 4395 4396 Print extra parentheses. Without this option, B::Deparse includes 4397 parentheses in its output only when they are needed, based on the 4398 structure of your program. With B<-p>, it uses parentheses (almost) 4399 whenever they would be legal. This can be useful if you are used to 4400 LISP, or if you want to see how perl parses your input. If you say 4401 4402 if ($var & 0x7f == 65) {print "Gimme an A!"} 4403 print ($which ? $a : $b), "\n"; 4404 $name = $ENV{USER} or "Bob"; 4405 4406 C<B::Deparse,-p> will print 4407 4408 if (($var & 0)) { 4409 print('Gimme an A!') 4410 }; 4411 (print(($which ? $a : $b)), '???'); 4412 (($name = $ENV{'USER'}) or '???') 4413 4414 which probably isn't what you intended (the C<'???'> is a sign that 4415 perl optimized away a constant value). 4416 4417 =item B<-P> 4418 4419 Disable prototype checking. With this option, all function calls are 4420 deparsed as if no prototype was defined for them. In other words, 4421 4422 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' 4423 4424 will print 4425 4426 sub foo (\@) { 4427 1; 4428 } 4429 &foo(\@x); 4430 4431 making clear how the parameters are actually passed to C<foo>. 4432 4433 =item B<-q> 4434 4435 Expand double-quoted strings into the corresponding combinations of 4436 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For 4437 instance, print 4438 4439 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; 4440 4441 as 4442 4443 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' 4444 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); 4445 4446 Note that the expanded form represents the way perl handles such 4447 constructions internally -- this option actually turns off the reverse 4448 translation that B::Deparse usually does. On the other hand, note that 4449 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value 4450 of $y into a string before doing the assignment. 4451 4452 =item B<-s>I<LETTERS> 4453 4454 Tweak the style of B::Deparse's output. The letters should follow 4455 directly after the 's', with no space or punctuation. The following 4456 options are available: 4457 4458 =over 4 4459 4460 =item B<C> 4461 4462 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print 4463 4464 if (...) { 4465 ... 4466 } else { 4467 ... 4468 } 4469 4470 instead of 4471 4472 if (...) { 4473 ... 4474 } 4475 else { 4476 ... 4477 } 4478 4479 The default is not to cuddle. 4480 4481 =item B<i>I<NUMBER> 4482 4483 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. 4484 4485 =item B<T> 4486 4487 Use tabs for each 8 columns of indent. The default is to use only spaces. 4488 For instance, if the style options are B<-si4T>, a line that's indented 4489 3 times will be preceded by one tab and four spaces; if the options were 4490 B<-si8T>, the same line would be preceded by three tabs. 4491 4492 =item B<v>I<STRING>B<.> 4493 4494 Print I<STRING> for the value of a constant that can't be determined 4495 because it was optimized away (mnemonic: this happens when a constant 4496 is used in B<v>oid context). The end of the string is marked by a period. 4497 The string should be a valid perl expression, generally a constant. 4498 Note that unless it's a number, it probably needs to be quoted, and on 4499 a command line quotes need to be protected from the shell. Some 4500 conventional values include 0, 1, 42, '', 'foo', and 4501 'Useless use of constant omitted' (which may need to be 4502 B<-sv"'Useless use of constant omitted'."> 4503 or something similar depending on your shell). The default is '???'. 4504 If you're using B::Deparse on a module or other file that's require'd, 4505 you shouldn't use a value that evaluates to false, since the customary 4506 true constant at the end of a module will be in void context when the 4507 file is compiled as a main program. 4508 4509 =back 4510 4511 =item B<-x>I<LEVEL> 4512 4513 Expand conventional syntax constructions into equivalent ones that expose 4514 their internal operation. I<LEVEL> should be a digit, with higher values 4515 meaning more expansion. As with B<-q>, this actually involves turning off 4516 special cases in B::Deparse's normal operations. 4517 4518 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent 4519 while loops with continue blocks; for instance 4520 4521 for ($i = 0; $i < 10; ++$i) { 4522 print $i; 4523 } 4524 4525 turns into 4526 4527 $i = 0; 4528 while ($i < 10) { 4529 print $i; 4530 } continue { 4531 ++$i 4532 } 4533 4534 Note that in a few cases this translation can't be perfectly carried back 4535 into the source code -- if the loop's initializer declares a my variable, 4536 for instance, it won't have the correct scope outside of the loop. 4537 4538 If I<LEVEL> is at least 5, C<use> declarations will be translated into 4539 C<BEGIN> blocks containing calls to C<require> and C<import>; for 4540 instance, 4541 4542 use strict 'refs'; 4543 4544 turns into 4545 4546 sub BEGIN { 4547 require strict; 4548 do { 4549 'strict'->import('refs') 4550 }; 4551 } 4552 4553 If I<LEVEL> is at least 7, C<if> statements will be translated into 4554 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance 4555 4556 print 'hi' if $nice; 4557 if ($nice) { 4558 print 'hi'; 4559 } 4560 if ($nice) { 4561 print 'hi'; 4562 } else { 4563 print 'bye'; 4564 } 4565 4566 turns into 4567 4568 $nice and print 'hi'; 4569 $nice and do { print 'hi' }; 4570 $nice ? do { print 'hi' } : do { print 'bye' }; 4571 4572 Long sequences of elsifs will turn into nested ternary operators, which 4573 B::Deparse doesn't know how to indent nicely. 4574 4575 =back 4576 4577 =head1 USING B::Deparse AS A MODULE 4578 4579 =head2 Synopsis 4580 4581 use B::Deparse; 4582 $deparse = B::Deparse->new("-p", "-sC"); 4583 $body = $deparse->coderef2text(\&func); 4584 eval "sub func $body"; # the inverse operation 4585 4586 =head2 Description 4587 4588 B::Deparse can also be used on a sub-by-sub basis from other perl 4589 programs. 4590 4591 =head2 new 4592 4593 $deparse = B::Deparse->new(OPTIONS) 4594 4595 Create an object to store the state of a deparsing operation and any 4596 options. The options are the same as those that can be given on the 4597 command line (see L</OPTIONS>); options that are separated by commas 4598 after B<-MO=Deparse> should be given as separate strings. Some 4599 options, like B<-u>, don't make sense for a single subroutine, so 4600 don't pass them. 4601 4602 =head2 ambient_pragmas 4603 4604 $deparse->ambient_pragmas(strict => 'all', '$[' => $[); 4605 4606 The compilation of a subroutine can be affected by a few compiler 4607 directives, B<pragmas>. These are: 4608 4609 =over 4 4610 4611 =item * 4612 4613 use strict; 4614 4615 =item * 4616 4617 use warnings; 4618 4619 =item * 4620 4621 Assigning to the special variable $[ 4622 4623 =item * 4624 4625 use integer; 4626 4627 =item * 4628 4629 use bytes; 4630 4631 =item * 4632 4633 use utf8; 4634 4635 =item * 4636 4637 use re; 4638 4639 =back 4640 4641 Ordinarily, if you use B::Deparse on a subroutine which has 4642 been compiled in the presence of one or more of these pragmas, 4643 the output will include statements to turn on the appropriate 4644 directives. So if you then compile the code returned by coderef2text, 4645 it will behave the same way as the subroutine which you deparsed. 4646 4647 However, you may know that you intend to use the results in a 4648 particular context, where some pragmas are already in scope. In 4649 this case, you use the B<ambient_pragmas> method to describe the 4650 assumptions you wish to make. 4651 4652 Not all of the options currently have any useful effect. See 4653 L</BUGS> for more details. 4654 4655 The parameters it accepts are: 4656 4657 =over 4 4658 4659 =item strict 4660 4661 Takes a string, possibly containing several values separated 4662 by whitespace. The special values "all" and "none" mean what you'd 4663 expect. 4664 4665 $deparse->ambient_pragmas(strict => 'subs refs'); 4666 4667 =item $[ 4668 4669 Takes a number, the value of the array base $[. 4670 4671 =item bytes 4672 4673 =item utf8 4674 4675 =item integer 4676 4677 If the value is true, then the appropriate pragma is assumed to 4678 be in the ambient scope, otherwise not. 4679 4680 =item re 4681 4682 Takes a string, possibly containing a whitespace-separated list of 4683 values. The values "all" and "none" are special. It's also permissible 4684 to pass an array reference here. 4685 4686 $deparser->ambient_pragmas(re => 'eval'); 4687 4688 4689 =item warnings 4690 4691 Takes a string, possibly containing a whitespace-separated list of 4692 values. The values "all" and "none" are special, again. It's also 4693 permissible to pass an array reference here. 4694 4695 $deparser->ambient_pragmas(warnings => [qw[void io]]); 4696 4697 If one of the values is the string "FATAL", then all the warnings 4698 in that list will be considered fatal, just as with the B<warnings> 4699 pragma itself. Should you need to specify that some warnings are 4700 fatal, and others are merely enabled, you can pass the B<warnings> 4701 parameter twice: 4702 4703 $deparser->ambient_pragmas( 4704 warnings => 'all', 4705 warnings => [FATAL => qw/void io/], 4706 ); 4707 4708 See L<perllexwarn> for more information about lexical warnings. 4709 4710 =item hint_bits 4711 4712 =item warning_bits 4713 4714 These two parameters are used to specify the ambient pragmas in 4715 the format used by the special variables $^H and ${^WARNING_BITS}. 4716 4717 They exist principally so that you can write code like: 4718 4719 { my ($hint_bits, $warning_bits); 4720 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} 4721 $deparser->ambient_pragmas ( 4722 hint_bits => $hint_bits, 4723 warning_bits => $warning_bits, 4724 '$[' => 0 + $[ 4725 ); } 4726 4727 which specifies that the ambient pragmas are exactly those which 4728 are in scope at the point of calling. 4729 4730 =item %^H 4731 4732 This parameter is used to specify the ambient pragmas which are 4733 stored in the special hash %^H. 4734 4735 =back 4736 4737 =head2 coderef2text 4738 4739 $body = $deparse->coderef2text(\&func) 4740 $body = $deparse->coderef2text(sub ($$) { ... }) 4741 4742 Return source code for the body of a subroutine (a block, optionally 4743 preceded by a prototype in parens), given a reference to the 4744 sub. Because a subroutine can have no names, or more than one name, 4745 this method doesn't return a complete subroutine definition -- if you 4746 want to eval the result, you should prepend "sub subname ", or "sub " 4747 for an anonymous function constructor. Unless the sub was defined in 4748 the main:: package, the code will include a package declaration. 4749 4750 =head1 BUGS 4751 4752 =over 4 4753 4754 =item * 4755 4756 The only pragmas to be completely supported are: C<use warnings>, 4757 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which 4758 behaves like a pragma, is also supported.) 4759 4760 Excepting those listed above, we're currently unable to guarantee that 4761 B::Deparse will produce a pragma at the correct point in the program. 4762 (Specifically, pragmas at the beginning of a block often appear right 4763 before the start of the block instead.) 4764 Since the effects of pragmas are often lexically scoped, this can mean 4765 that the pragma holds sway over a different portion of the program 4766 than in the input file. 4767 4768 =item * 4769 4770 In fact, the above is a specific instance of a more general problem: 4771 we can't guarantee to produce BEGIN blocks or C<use> declarations in 4772 exactly the right place. So if you use a module which affects compilation 4773 (such as by over-riding keywords, overloading constants or whatever) 4774 then the output code might not work as intended. 4775 4776 This is the most serious outstanding problem, and will require some help 4777 from the Perl core to fix. 4778 4779 =item * 4780 4781 If a keyword is over-ridden, and your program explicitly calls 4782 the built-in version by using CORE::keyword, the output of B::Deparse 4783 will not reflect this. If you run the resulting code, it will call 4784 the over-ridden version rather than the built-in one. (Maybe there 4785 should be an option to B<always> print keyword calls as C<CORE::name>.) 4786 4787 =item * 4788 4789 Some constants don't print correctly either with or without B<-d>. 4790 For instance, neither B::Deparse nor Data::Dumper know how to print 4791 dual-valued scalars correctly, as in: 4792 4793 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y; 4794 4795 =item * 4796 4797 An input file that uses source filtering probably won't be deparsed into 4798 runnable code, because it will still include the B<use> declaration 4799 for the source filtering module, even though the code that is 4800 produced is already ordinary Perl which shouldn't be filtered again. 4801 4802 =item * 4803 4804 Optimised away statements are rendered as '???'. This includes statements that 4805 have a compile-time side-effect, such as the obscure 4806 4807 my $x if 0; 4808 4809 which is not, consequently, deparsed correctly. 4810 4811 =item * 4812 4813 Lexical (my) variables declared in scopes external to a subroutine 4814 appear in code2ref output text as package variables. This is a tricky 4815 problem, as perl has no native facility for refering to a lexical variable 4816 defined within a different scope, although L<PadWalker> is a good start. 4817 4818 =item * 4819 4820 There are probably many more bugs on non-ASCII platforms (EBCDIC). 4821 4822 =back 4823 4824 =head1 AUTHOR 4825 4826 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version 4827 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from 4828 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, 4829 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael 4830 Garcia-Suarez. 4831 4832 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |