| [ 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