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 10package B::Deparse; 11use Carp; 12use 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 OPf_PARENS 15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpKVSLICE 16 OPpCONST_BARE 17 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY 18 OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST 19 OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE 20 OPpSPLIT_ASSIGN OPpSPLIT_LEX 21 OPpPADHV_ISKEYS OPpRV2HV_ISKEYS 22 OPpCONCAT_NESTED 23 OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE 24 OPpTRUEBOOL OPpINDEX_BOOLNEG 25 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG 26 SVs_PADTMP SVpad_TYPED 27 CVf_METHOD CVf_LVALUE 28 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE 29 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE 30 PADNAMEt_OUTER 31 MDEREF_reload 32 MDEREF_AV_pop_rv2av_aelem 33 MDEREF_AV_gvsv_vivify_rv2av_aelem 34 MDEREF_AV_padsv_vivify_rv2av_aelem 35 MDEREF_AV_vivify_rv2av_aelem 36 MDEREF_AV_padav_aelem 37 MDEREF_AV_gvav_aelem 38 MDEREF_HV_pop_rv2hv_helem 39 MDEREF_HV_gvsv_vivify_rv2hv_helem 40 MDEREF_HV_padsv_vivify_rv2hv_helem 41 MDEREF_HV_vivify_rv2hv_helem 42 MDEREF_HV_padhv_helem 43 MDEREF_HV_gvhv_helem 44 MDEREF_ACTION_MASK 45 MDEREF_INDEX_none 46 MDEREF_INDEX_const 47 MDEREF_INDEX_padsv 48 MDEREF_INDEX_gvsv 49 MDEREF_INDEX_MASK 50 MDEREF_FLAG_last 51 MDEREF_MASK 52 MDEREF_SHIFT 53 ); 54 55$VERSION = '1.49'; 56use strict; 57our $AUTOLOAD; 58use warnings (); 59require feature; 60 61use Config; 62 63BEGIN { 64 # List version-specific constants here. 65 # Easiest way to keep this code portable between version looks to 66 # be to fake up a dummy constant that will never actually be true. 67 foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER 68 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE 69 PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST 70 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST 71 PMf_NONDESTRUCT OPpEVAL_BYTES 72 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV 73 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) { 74 eval { B->import($_) }; 75 no strict 'refs'; 76 *{$_} = sub () {0} unless *{$_}{CODE}; 77 } 78} 79 80# Todo: 81# (See also BUGS section at the end of this file) 82# 83# - finish tr/// changes 84# - add option for even more parens (generalize \&foo change) 85# - left/right context 86# - copy comments (look at real text with $^P?) 87# - avoid semis in one-statement blocks 88# - associativity of &&=, ||=, ?: 89# - ',' => '=>' (auto-unquote?) 90# - break long lines ("\r" as discretionary break?) 91# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. 92# - more style options: brace style, hex vs. octal, quotes, ... 93# - print big ints as hex/octal instead of decimal (heuristic?) 94# - handle 'my $x if 0'? 95# - version using op_next instead of op_first/sibling? 96# - avoid string copies (pass arrays, one big join?) 97# - here-docs? 98 99# Current test.deparse failures 100# comp/hints 6 - location of BEGIN blocks wrt. block openings 101# run/switchI 1 - missing -I switches entirely 102# perl -Ifoo -e 'print @INC' 103# op/caller 2 - warning mask propagates backwards before warnings::register 104# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' 105# op/getpid 2 - can't assign to shared my() declaration (threads only) 106# 'my $x : shared = 5' 107# op/override 7 - parens on overridden require change v-string interpretation 108# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' 109# c.f. 'BEGIN { *f = sub {0} }; f 2' 110# op/pat 774 - losing Unicode-ness of Latin1-only strings 111# 'use charnames ":short"; $x="\N{latin:a with acute}"' 112# op/recurse 12 - missing parens on recursive call makes it look like method 113# 'sub f { f($x) }' 114# op/subst 90 - inconsistent handling of utf8 under "use utf8" 115# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open 116# op/tiehandle compile - "use strict" deparsed in the wrong place 117# uni/tr_ several 118# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs 119# ext/Data/Dumper/t/dumper compile 120# ext/DB_file/several 121# ext/Encode/several 122# ext/Ernno/Errno warnings 123# ext/IO/lib/IO/t/io_sel 23 124# ext/PerlIO/t/encoding compile 125# ext/POSIX/t/posix 6 126# ext/Socket/Socket 8 127# ext/Storable/t/croak compile 128# lib/Attribute/Handlers/t/multi compile 129# lib/bignum/ several 130# lib/charnames 35 131# lib/constant 32 132# lib/English 40 133# lib/ExtUtils/t/bytes 4 134# lib/File/DosGlob compile 135# lib/Filter/Simple/t/data 1 136# lib/Math/BigInt/t/constant 1 137# lib/Net/t/config Deparse-warning 138# lib/overload compile 139# lib/Switch/ several 140# lib/Symbol 4 141# lib/Test/Simple several 142# lib/Term/Complete 143# lib/Tie/File/t/29_downcopy 5 144# lib/vars 22 145 146# Object fields: 147# 148# in_coderef2text: 149# True when deparsing via $deparse->coderef2text; false when deparsing the 150# main program. 151# 152# avoid_local: 153# (local($a), local($b)) and local($a, $b) have the same internal 154# representation but the short form looks better. We notice we can 155# use a large-scale local when checking the list, but need to prevent 156# individual locals too. This hash holds the addresses of OPs that 157# have already had their local-ness accounted for. The same thing 158# is done with my(). 159# 160# curcv: 161# CV for current sub (or main program) being deparsed 162# 163# curcvlex: 164# Cached hash of lexical variables for curcv: keys are 165# names prefixed with "m" or "o" (representing my/our), and 166# each value is an array with two elements indicating the cop_seq 167# of scopes in which a var of that name is valid and a third ele- 168# ment referencing the pad name. 169# 170# curcop: 171# COP for statement being deparsed 172# 173# curstash: 174# name of the current package for deparsed code 175# 176# subs_todo: 177# array of [cop_seq, CV, is_format?, name] for subs and formats we still 178# want to deparse. The fourth element is a pad name thingy for lexical 179# subs or a string for special blocks. For other subs, it is undef. For 180# lexical subs, CV may be undef, indicating a stub declaration. 181# 182# protos_todo: 183# as above, but [name, prototype] for subs that never got a GV 184# 185# subs_done, forms_done: 186# keys are addresses of GVs for subs and formats we've already 187# deparsed (or at least put into subs_todo) 188# 189# subs_declared 190# keys are names of subs for which we've printed declarations. 191# That means we can omit parentheses from the arguments. It also means we 192# need to put CORE:: on core functions of the same name. 193# 194# in_subst_repl 195# True when deparsing the replacement part of a substitution. 196# 197# in_refgen 198# True when deparsing the argument to \. 199# 200# parens: -p 201# linenums: -l 202# unquote: -q 203# cuddle: ' ' or '\n', depending on -sC 204# indent_size: -si 205# use_tabs: -sT 206# ex_const: -sv 207 208# A little explanation of how precedence contexts and associativity 209# work: 210# 211# deparse() calls each per-op subroutine with an argument $cx (short 212# for context, but not the same as the cx* in the perl core), which is 213# a number describing the op's parents in terms of precedence, whether 214# they're inside an expression or at statement level, etc. (see 215# chart below). When ops with children call deparse on them, they pass 216# along their precedence. Fractional values are used to implement 217# associativity ('($x + $y) + $z' => '$x + $y + $y') and related 218# parentheses hacks. The major disadvantage of this scheme is that 219# it doesn't know about right sides and left sides, so say if you 220# assign a listop to a variable, it can't tell it's allowed to leave 221# the parens off the listop. 222 223# Precedences: 224# 26 [TODO] inside interpolation context ("") 225# 25 left terms and list operators (leftward) 226# 24 left -> 227# 23 nonassoc ++ -- 228# 22 right ** 229# 21 right ! ~ \ and unary + and - 230# 20 left =~ !~ 231# 19 left * / % x 232# 18 left + - . 233# 17 left << >> 234# 16 nonassoc named unary operators 235# 15 nonassoc < > <= >= lt gt le ge 236# 14 nonassoc == != <=> eq ne cmp 237# 13 left & 238# 12 left | ^ 239# 11 left && 240# 10 left || 241# 9 nonassoc .. ... 242# 8 right ?: 243# 7 right = += -= *= etc. 244# 6 left , => 245# 5 nonassoc list operators (rightward) 246# 4 right not 247# 3 left and 248# 2 left or xor 249# 1 statement modifiers 250# 0.5 statements, but still print scopes as do { ... } 251# 0 statement level 252# -1 format body 253 254# Nonprinting characters with special meaning: 255# \cS - steal parens (see maybe_parens_unop) 256# \n - newline and indent 257# \t - increase indent 258# \b - decrease indent ('outdent') 259# \f - flush left (no indent) 260# \cK - kill following semicolon, if any 261 262# Semicolon handling: 263# - Individual statements are not deparsed with trailing semicolons. 264# (If necessary, \cK is tacked on to the end.) 265# - Whatever code joins statements together or emits them (lineseq, 266# scopeop, deparse_root) is responsible for adding semicolons where 267# necessary. 268# - use statements are deparsed with trailing semicolons because they are 269# immediately concatenated with the following statement. 270# - indent() removes semicolons wherever it sees \cK. 271 272 273BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem 274 kvaslice kvhslice padsv 275 nextstate dbstate rv2av rv2hv helem custom ]) { 276 eval "sub OP_\U$_ () { " . opnumber($_) . "}" 277}} 278 279# _pessimise_walk(): recursively walk the optree of a sub, 280# possibly undoing optimisations along the way. 281 282sub _pessimise_walk { 283 my ($self, $startop) = @_; 284 285 return unless $$startop; 286 my ($op, $prevop); 287 for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) { 288 my $ppname = $op->name; 289 290 # pessimisations start here 291 292 if ($ppname eq "padrange") { 293 # remove PADRANGE: 294 # the original optimisation either (1) changed this: 295 # pushmark -> (various pad and list and null ops) -> the_rest 296 # or (2), for the = @_ case, changed this: 297 # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest 298 # into this: 299 # padrange ----------------------------------------> the_rest 300 # so we just need to convert the padrange back into a 301 # pushmark, and in case (1), set its op_next to op_sibling, 302 # which is the head of the original chain of optimised-away 303 # pad ops, or for (2), set it to sibling->first, which is 304 # the original gv[_]. 305 306 $B::overlay->{$$op} = { 307 type => OP_PUSHMARK, 308 name => 'pushmark', 309 private => ($op->private & OPpLVAL_INTRO), 310 }; 311 } 312 313 # pessimisations end here 314 315 if (class($op) eq 'PMOP') { 316 if (ref($op->pmreplroot) 317 && ${$op->pmreplroot} 318 && $op->pmreplroot->isa( 'B::OP' )) 319 { 320 $self-> _pessimise_walk($op->pmreplroot); 321 } 322 323 # pessimise any /(?{...})/ code blocks 324 my ($re, $cv); 325 my $code_list = $op->code_list; 326 if ($$code_list) { 327 $self->_pessimise_walk($code_list); 328 } 329 elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) { 330 $code_list = $cv->ROOT # leavesub 331 ->first # qr 332 ->code_list; # list 333 $self->_pessimise_walk($code_list); 334 } 335 } 336 337 if ($op->flags & OPf_KIDS) { 338 $self-> _pessimise_walk($op->first); 339 } 340 341 } 342} 343 344 345# _pessimise_walk_exe(): recursively walk the op_next chain of a sub, 346# possibly undoing optimisations along the way. 347 348sub _pessimise_walk_exe { 349 my ($self, $startop, $visited) = @_; 350 351 no warnings 'recursion'; 352 353 return unless $$startop; 354 return if $visited->{$$startop}; 355 my ($op, $prevop); 356 for ($op = $startop; $$op; $prevop = $op, $op = $op->next) { 357 last if $visited->{$$op}; 358 $visited->{$$op} = 1; 359 my $ppname = $op->name; 360 if ($ppname =~ 361 /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/ 362 # entertry is also a logop, but its op_other invariably points 363 # into the same chain as the main execution path, so we skip it 364 ) { 365 $self->_pessimise_walk_exe($op->other, $visited); 366 } 367 elsif ($ppname eq "subst") { 368 $self->_pessimise_walk_exe($op->pmreplstart, $visited); 369 } 370 elsif ($ppname =~ /^(enter(loop|iter))$/) { 371 # redoop and nextop will already be covered by the main block 372 # of the loop 373 $self->_pessimise_walk_exe($op->lastop, $visited); 374 } 375 376 # pessimisations start here 377 } 378} 379 380# Go through an optree and "remove" some optimisations by using an 381# overlay to selectively modify or un-null some ops. Deparsing in the 382# absence of those optimisations is then easier. 383# 384# Note that older optimisations are not removed, as Deparse was already 385# written to recognise them before the pessimise/overlay system was added. 386 387sub pessimise { 388 my ($self, $root, $start) = @_; 389 390 no warnings 'recursion'; 391 # walk tree in root-to-branch order 392 $self->_pessimise_walk($root); 393 394 my %visited; 395 # walk tree in execution order 396 $self->_pessimise_walk_exe($start, \%visited); 397} 398 399 400sub null { 401 my $op = shift; 402 return class($op) eq "NULL"; 403} 404 405 406# Add a CV to the list of subs that still need deparsing. 407 408sub todo { 409 my $self = shift; 410 my($cv, $is_form, $name) = @_; 411 my $cvfile = $cv->FILE//''; 412 return unless ($cvfile eq $0 || exists $self->{files}{$cvfile}); 413 my $seq; 414 if ($cv->OUTSIDE_SEQ) { 415 $seq = $cv->OUTSIDE_SEQ; 416 } elsif (!null($cv->START) and is_state($cv->START)) { 417 $seq = $cv->START->cop_seq; 418 } else { 419 $seq = 0; 420 } 421 my $stash = $cv->STASH; 422 if (class($stash) eq 'HV') { 423 $self->{packs}{$stash->NAME}++; 424 } 425 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name]; 426} 427 428 429# Pop the next sub from the todo list and deparse it 430 431sub next_todo { 432 my $self = shift; 433 my $ent = shift @{$self->{'subs_todo'}}; 434 my ($seq, $cv, $is_form, $name) = @$ent; 435 436 # any 'use strict; package foo' that should come before the sub 437 # declaration to sync with the first COP of the sub 438 my $pragmata = ''; 439 if ($cv and !null($cv->START) and is_state($cv->START)) { 440 $pragmata = $self->pragmata($cv->START); 441 } 442 443 if (ref $name) { # lexical sub 444 # emit the sub. 445 my @text; 446 my $flags = $name->FLAGS; 447 push @text, 448 !$cv || $seq <= $name->COP_SEQ_RANGE_LOW 449 ? $self->keyword($flags & SVpad_OUR 450 ? "our" 451 : $flags & SVpad_STATE 452 ? "state" 453 : "my") . " " 454 : ""; 455 # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’ 456 # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e., 457 # we have a core bug here. 458 push @text, "sub " . substr $name->PVX, 1; 459 if ($cv) { 460 # my sub foo { } 461 push @text, " " . $self->deparse_sub($cv); 462 $text[-1] =~ s/ ;$/;/; 463 } 464 else { 465 # my sub foo; 466 push @text, ";\n"; 467 } 468 return $pragmata . join "", @text; 469 } 470 471 my $gv = $cv->GV; 472 $name //= $self->gv_name($gv); 473 if ($is_form) { 474 return $pragmata . $self->keyword("format") . " $name =\n" 475 . $self->deparse_format($cv). "\n"; 476 } else { 477 my $use_dec; 478 if ($name eq "BEGIN") { 479 $use_dec = $self->begin_is_use($cv); 480 if (defined ($use_dec) and $self->{'expand'} < 5) { 481 return $pragmata if 0 == length($use_dec); 482 483 # XXX bit of a hack: Test::More's use_ok() method 484 # builds a fake use statement which deparses as, e.g. 485 # use Net::Ping (@{$args[0];}); 486 # As well as being superfluous (the use_ok() is deparsed 487 # too) and ugly, it fails under use strict and otherwise 488 # makes use of a lexical var that's not in scope. 489 # So strip it out. 490 return $pragmata 491 if $use_dec =~ 492 m/ 493 \A 494 use \s \S+ \s \(\@\{ 495 ( 496 \s*\#line\ \d+\ \".*"\s* 497 )? 498 \$args\[0\];\}\); 499 \n 500 \Z 501 /x; 502 503 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e; 504 } 505 } 506 my $l = ''; 507 if ($self->{'linenums'}) { 508 my $line = $gv->LINE; 509 my $file = $gv->FILE; 510 $l = "\n\f#line $line \"$file\"\n"; 511 } 512 my $p = ''; 513 my $stash; 514 if (class($cv->STASH) ne "SPECIAL") { 515 $stash = $cv->STASH->NAME; 516 if ($stash ne $self->{'curstash'}) { 517 $p = $self->keyword("package") . " $stash;\n"; 518 $name = "$self->{'curstash'}::$name" unless $name =~ /::/; 519 $self->{'curstash'} = $stash; 520 } 521 } 522 if ($use_dec) { 523 return "$pragmata$p$l$use_dec"; 524 } 525 if ( $name !~ /::/ and $self->lex_in_scope("&$name") 526 || $self->lex_in_scope("&$name", 1) ) 527 { 528 $name = "$self->{'curstash'}::$name"; 529 } elsif (defined $stash) { 530 $name =~ s/^\Q$stash\E::(?!\z|.*::)//; 531 } 532 my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name " 533 . $self->deparse_sub($cv); 534 $self->{'subs_declared'}{$name} = 1; 535 return $ret; 536 } 537} 538 539 540# Return a "use" declaration for this BEGIN block, if appropriate 541sub begin_is_use { 542 my ($self, $cv) = @_; 543 my $root = $cv->ROOT; 544 local @$self{qw'curcv curcvlex'} = ($cv); 545 local $B::overlay = {}; 546 $self->pessimise($root, $cv->START); 547#require B::Debug; 548#B::walkoptree($cv->ROOT, "debug"); 549 my $lineseq = $root->first; 550 return if $lineseq->name ne "lineseq"; 551 552 my $req_op = $lineseq->first->sibling; 553 return if $req_op->name ne "require"; 554 555 # maybe it's C<require expr> rather than C<require 'foo'> 556 return if ($req_op->first->name ne 'const'); 557 558 my $module; 559 if ($req_op->first->private & OPpCONST_BARE) { 560 # Actually it should always be a bareword 561 $module = $self->const_sv($req_op->first)->PV; 562 $module =~ s[/][::]g; 563 $module =~ s/.pm$//; 564 } 565 else { 566 $module = $self->const($self->const_sv($req_op->first), 6); 567 } 568 569 my $version; 570 my $version_op = $req_op->sibling; 571 return if class($version_op) eq "NULL"; 572 if ($version_op->name eq "lineseq") { 573 # We have a version parameter; skip nextstate & pushmark 574 my $constop = $version_op->first->next->next; 575 576 return unless $self->const_sv($constop)->PV eq $module; 577 $constop = $constop->sibling; 578 $version = $self->const_sv($constop); 579 if (class($version) eq "IV") { 580 $version = $version->int_value; 581 } elsif (class($version) eq "NV") { 582 $version = $version->NV; 583 } elsif (class($version) ne "PVMG") { 584 # Includes PVIV and PVNV 585 $version = $version->PV; 586 } else { 587 # version specified as a v-string 588 $version = 'v'.join '.', map ord, split //, $version->PV; 589 } 590 $constop = $constop->sibling; 591 return if $constop->name ne "method_named"; 592 return if $self->meth_sv($constop)->PV ne "VERSION"; 593 } 594 595 $lineseq = $version_op->sibling; 596 return if $lineseq->name ne "lineseq"; 597 my $entersub = $lineseq->first->sibling; 598 if ($entersub->name eq "stub") { 599 return "use $module $version ();\n" if defined $version; 600 return "use $module ();\n"; 601 } 602 return if $entersub->name ne "entersub"; 603 604 # See if there are import arguments 605 my $args = ''; 606 607 my $svop = $entersub->first->sibling; # Skip over pushmark 608 return unless $self->const_sv($svop)->PV eq $module; 609 610 # Pull out the arguments 611 for ($svop=$svop->sibling; index($svop->name, "method_") != 0; 612 $svop = $svop->sibling) { 613 $args .= ", " if length($args); 614 $args .= $self->deparse($svop, 6); 615 } 616 617 my $use = 'use'; 618 my $method_named = $svop; 619 return if $method_named->name ne "method_named"; 620 my $method_name = $self->meth_sv($method_named)->PV; 621 622 if ($method_name eq "unimport") { 623 $use = 'no'; 624 } 625 626 # Certain pragmas are dealt with using hint bits, 627 # so we ignore them here 628 if ($module eq 'strict' || $module eq 'integer' 629 || $module eq 'bytes' || $module eq 'warnings' 630 || $module eq 'feature') { 631 return ""; 632 } 633 634 if (defined $version && length $args) { 635 return "$use $module $version ($args);\n"; 636 } elsif (defined $version) { 637 return "$use $module $version;\n"; 638 } elsif (length $args) { 639 return "$use $module ($args);\n"; 640 } else { 641 return "$use $module;\n"; 642 } 643} 644 645sub stash_subs { 646 my ($self, $pack, $seen) = @_; 647 my (@ret, $stash); 648 if (!defined $pack) { 649 $pack = ''; 650 $stash = \%::; 651 } 652 else { 653 $pack =~ s/(::)?$/::/; 654 no strict 'refs'; 655 $stash = \%{"main::$pack"}; 656 } 657 return 658 if ($seen ||= {})->{ 659 $INC{"overload.pm"} ? overload::StrVal($stash) : $stash 660 }++; 661 my $stashobj = svref_2object($stash); 662 my %stash = $stashobj->ARRAY; 663 while (my ($key, $val) = each %stash) { 664 my $flags = $val->FLAGS; 665 if ($flags & SVf_ROK) { 666 # A reference. Dump this if it is a reference to a CV. If it 667 # is a constant acting as a proxy for a full subroutine, then 668 # we may or may not have to dump it. If some form of perl- 669 # space visible code must have created it, be it a use 670 # statement, or some direct symbol-table manipulation code that 671 # we will deparse, then we don’t want to dump it. If it is the 672 # result of a declaration like sub f () { 42 } then we *do* 673 # want to dump it. The only way to distinguish these seems 674 # to be the SVs_PADTMP flag on the constant, which is admit- 675 # tedly a hack. 676 my $class = class(my $referent = $val->RV); 677 if ($class eq "CV") { 678 $self->todo($referent, 0); 679 } elsif ( 680 $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/ 681 # A more robust way to write that would be this, but B does 682 # not provide the SVt_ constants: 683 # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV 684 and $referent->FLAGS & SVs_PADTMP 685 ) { 686 push @{$self->{'protos_todo'}}, [$pack . $key, $val]; 687 } 688 } elsif ($flags & (SVf_POK|SVf_IOK)) { 689 # Just a prototype. As an ugly but fairly effective way 690 # to find out if it belongs here is to see if the AUTOLOAD 691 # (if any) for the stash was defined in one of our files. 692 my $A = $stash{"AUTOLOAD"}; 693 if (defined ($A) && class($A) eq "GV" && defined($A->CV) 694 && class($A->CV) eq "CV") { 695 my $AF = $A->FILE; 696 next unless $AF eq $0 || exists $self->{'files'}{$AF}; 697 } 698 push @{$self->{'protos_todo'}}, 699 [$pack . $key, $flags & SVf_POK ? $val->PV: undef]; 700 } elsif (class($val) eq "GV") { 701 if (class(my $cv = $val->CV) ne "SPECIAL") { 702 next if $self->{'subs_done'}{$$val}++; 703 704 # Ignore imposters (aliases etc) 705 my $name = $cv->NAME_HEK; 706 if(defined $name) { 707 # avoid using $cv->GV here because if the $val GV is 708 # an alias, CvGV() could upgrade the real stash entry 709 # from an RV to a GV 710 next unless $name eq $key; 711 next unless $$stashobj == ${$cv->STASH}; 712 } 713 else { 714 next if $$val != ${$cv->GV}; 715 } 716 717 $self->todo($cv, 0); 718 } 719 if (class(my $cv = $val->FORM) ne "SPECIAL") { 720 next if $self->{'forms_done'}{$$val}++; 721 next if $$val != ${$cv->GV}; # Ignore imposters 722 $self->todo($cv, 1); 723 } 724 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { 725 $self->stash_subs($pack . $key, $seen); 726 } 727 } 728 } 729} 730 731sub print_protos { 732 my $self = shift; 733 my $ar; 734 my @ret; 735 foreach $ar (@{$self->{'protos_todo'}}) { 736 if (ref $ar->[1]) { 737 # Only print a constant if it occurs in the same package as a 738 # dumped sub. This is not perfect, but a heuristic that will 739 # hopefully work most of the time. Ideally we would use 740 # CvFILE, but a constant stub has no CvFILE. 741 my $pack = ($ar->[0] =~ /(.*)::/)[0]; 742 next if $pack and !$self->{packs}{$pack} 743 } 744 my $body = defined $ar->[1] 745 ? ref $ar->[1] 746 ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}" 747 : " (". $ar->[1] . ");" 748 : ";"; 749 push @ret, "sub " . $ar->[0] . "$body\n"; 750 } 751 delete $self->{'protos_todo'}; 752 return @ret; 753} 754 755sub style_opts { 756 my $self = shift; 757 my $opts = shift; 758 my $opt; 759 while (length($opt = substr($opts, 0, 1))) { 760 if ($opt eq "C") { 761 $self->{'cuddle'} = " "; 762 $opts = substr($opts, 1); 763 } elsif ($opt eq "i") { 764 $opts =~ s/^i(\d+)//; 765 $self->{'indent_size'} = $1; 766 } elsif ($opt eq "T") { 767 $self->{'use_tabs'} = 1; 768 $opts = substr($opts, 1); 769 } elsif ($opt eq "v") { 770 $opts =~ s/^v([^.]*)(.|$)//; 771 $self->{'ex_const'} = $1; 772 } 773 } 774} 775 776sub new { 777 my $class = shift; 778 my $self = bless {}, $class; 779 $self->{'cuddle'} = "\n"; 780 $self->{'curcop'} = undef; 781 $self->{'curstash'} = "main"; 782 $self->{'ex_const'} = "'???'"; 783 $self->{'expand'} = 0; 784 $self->{'files'} = {}; 785 $self->{'packs'} = {}; 786 $self->{'indent_size'} = 4; 787 $self->{'linenums'} = 0; 788 $self->{'parens'} = 0; 789 $self->{'subs_todo'} = []; 790 $self->{'unquote'} = 0; 791 $self->{'use_dumper'} = 0; 792 $self->{'use_tabs'} = 0; 793 794 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings 795 $self->{'ambient_hints'} = 0; 796 $self->{'ambient_hinthash'} = undef; 797 $self->init(); 798 799 while (my $arg = shift @_) { 800 if ($arg eq "-d") { 801 $self->{'use_dumper'} = 1; 802 require Data::Dumper; 803 } elsif ($arg =~ /^-f(.*)/) { 804 $self->{'files'}{$1} = 1; 805 } elsif ($arg eq "-l") { 806 $self->{'linenums'} = 1; 807 } elsif ($arg eq "-p") { 808 $self->{'parens'} = 1; 809 } elsif ($arg eq "-P") { 810 $self->{'noproto'} = 1; 811 } elsif ($arg eq "-q") { 812 $self->{'unquote'} = 1; 813 } elsif (substr($arg, 0, 2) eq "-s") { 814 $self->style_opts(substr $arg, 2); 815 } elsif ($arg =~ /^-x(\d)$/) { 816 $self->{'expand'} = $1; 817 } 818 } 819 return $self; 820} 821 822{ 823 # Mask out the bits that L<warnings::register> uses 824 my $WARN_MASK; 825 BEGIN { 826 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; 827 } 828 sub WARN_MASK () { 829 return $WARN_MASK; 830 } 831} 832 833# Initialise the contextual information, either from 834# defaults provided with the ambient_pragmas method, 835# or from perl's own defaults otherwise. 836sub init { 837 my $self = shift; 838 839 $self->{'warnings'} = defined ($self->{'ambient_warnings'}) 840 ? $self->{'ambient_warnings'} & WARN_MASK 841 : undef; 842 $self->{'hints'} = $self->{'ambient_hints'}; 843 $self->{'hinthash'} = $self->{'ambient_hinthash'}; 844 845 # also a convenient place to clear out subs_declared 846 delete $self->{'subs_declared'}; 847} 848 849sub compile { 850 my(@args) = @_; 851 return sub { 852 my $self = B::Deparse->new(@args); 853 # First deparse command-line args 854 if (defined $^I) { # deparse -i 855 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); 856 } 857 if ($^W) { # deparse -w 858 print qq(BEGIN { \$^W = $^W; }\n); 859 } 860 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 861 my $fs = perlstring($/) || 'undef'; 862 my $bs = perlstring($O::savebackslash) || 'undef'; 863 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); 864 } 865 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); 866 my @UNITCHECKs = B::unitcheck_av->isa("B::AV") 867 ? B::unitcheck_av->ARRAY 868 : (); 869 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); 870 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); 871 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); 872 my @names = qw(BEGIN UNITCHECK CHECK INIT END); 873 my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs); 874 while (@names) { 875 my ($name, $blocks) = (shift @names, shift @blocks); 876 for my $block (@$blocks) { 877 $self->todo($block, 0, $name); 878 } 879 } 880 $self->stash_subs(); 881 local($SIG{"__DIE__"}) = 882 sub { 883 if ($self->{'curcop'}) { 884 my $cop = $self->{'curcop'}; 885 my($line, $file) = ($cop->line, $cop->file); 886 print STDERR "While deparsing $file near line $line,\n"; 887 } 888 }; 889 $self->{'curcv'} = main_cv; 890 $self->{'curcvlex'} = undef; 891 print $self->print_protos; 892 @{$self->{'subs_todo'}} = 893 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; 894 my $root = main_root; 895 local $B::overlay = {}; 896 unless (null $root) { 897 $self->pad_subs($self->{'curcv'}); 898 # Check for a stub-followed-by-ex-cop, resulting from a program 899 # consisting solely of sub declarations. For backward-compati- 900 # bility (and sane output) we don’t want to emit the stub. 901 # leave 902 # enter 903 # stub 904 # ex-nextstate (or ex-dbstate) 905 my $kid; 906 if ( $root->name eq 'leave' 907 and ($kid = $root->first)->name eq 'enter' 908 and !null($kid = $kid->sibling) and $kid->name eq 'stub' 909 and !null($kid = $kid->sibling) and $kid->name eq 'null' 910 and class($kid) eq 'COP' and null $kid->sibling ) 911 { 912 # ignore 913 } else { 914 $self->pessimise($root, main_start); 915 print $self->indent($self->deparse_root($root)), "\n"; 916 } 917 } 918 my @text; 919 while (scalar(@{$self->{'subs_todo'}})) { 920 push @text, $self->next_todo; 921 } 922 print $self->indent(join("", @text)), "\n" if @text; 923 924 # Print __DATA__ section, if necessary 925 no strict 'refs'; 926 my $laststash = defined $self->{'curcop'} 927 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; 928 if (defined *{$laststash."::DATA"}{IO}) { 929 print $self->keyword("package") . " $laststash;\n" 930 unless $laststash eq $self->{'curstash'}; 931 print $self->keyword("__DATA__") . "\n"; 932 print readline(*{$laststash."::DATA"}); 933 } 934 } 935} 936 937sub coderef2text { 938 my $self = shift; 939 my $sub = shift; 940 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); 941 942 $self->init(); 943 local $self->{in_coderef2text} = 1; 944 return $self->indent($self->deparse_sub(svref_2object($sub))); 945} 946 947my %strict_bits = do { 948 local $^H; 949 map +($_ => strict::bits($_)), qw/refs subs vars/ 950}; 951 952sub ambient_pragmas { 953 my $self = shift; 954 my ($hint_bits, $warning_bits, $hinthash) = (0); 955 956 while (@_ > 1) { 957 my $name = shift(); 958 my $val = shift(); 959 960 if ($name eq 'strict') { 961 require strict; 962 963 if ($val eq 'none') { 964 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/; 965 next(); 966 } 967 968 my @names; 969 if ($val eq "all") { 970 @names = qw/refs subs vars/; 971 } 972 elsif (ref $val) { 973 @names = @$val; 974 } 975 else { 976 @names = split' ', $val; 977 } 978 $hint_bits |= $strict_bits{$_} for @names; 979 } 980 981 elsif ($name eq 'integer' 982 || $name eq 'bytes' 983 || $name eq 'utf8') { 984 require "$name.pm"; 985 if ($val) { 986 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; 987 } 988 else { 989 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; 990 } 991 } 992 993 elsif ($name eq 're') { 994 require re; 995 if ($val eq 'none') { 996 $hint_bits &= ~re::bits(qw/taint eval/); 997 next(); 998 } 999 1000 my @names; 1001 if ($val eq 'all') { 1002 @names = qw/taint eval/; 1003 } 1004 elsif (ref $val) { 1005 @names = @$val; 1006 } 1007 else { 1008 @names = split' ',$val; 1009 } 1010 $hint_bits |= re::bits(@names); 1011 } 1012 1013 elsif ($name eq 'warnings') { 1014 if ($val eq 'none') { 1015 $warning_bits = $warnings::NONE; 1016 next(); 1017 } 1018 1019 my @names; 1020 if (ref $val) { 1021 @names = @$val; 1022 } 1023 else { 1024 @names = split/\s+/, $val; 1025 } 1026 1027 $warning_bits = $warnings::NONE if !defined ($warning_bits); 1028 $warning_bits |= warnings::bits(@names); 1029 } 1030 1031 elsif ($name eq 'warning_bits') { 1032 $warning_bits = $val; 1033 } 1034 1035 elsif ($name eq 'hint_bits') { 1036 $hint_bits = $val; 1037 } 1038 1039 elsif ($name eq '%^H') { 1040 $hinthash = $val; 1041 } 1042 1043 else { 1044 croak "Unknown pragma type: $name"; 1045 } 1046 } 1047 if (@_) { 1048 croak "The ambient_pragmas method expects an even number of args"; 1049 } 1050 1051 $self->{'ambient_warnings'} = $warning_bits; 1052 $self->{'ambient_hints'} = $hint_bits; 1053 $self->{'ambient_hinthash'} = $hinthash; 1054} 1055 1056# This method is the inner loop, so try to keep it simple 1057sub deparse { 1058 my $self = shift; 1059 my($op, $cx) = @_; 1060 1061 Carp::confess("Null op in deparse") if !defined($op) 1062 || class($op) eq "NULL"; 1063 my $meth = "pp_" . $op->name; 1064 return $self->$meth($op, $cx); 1065} 1066 1067sub indent { 1068 my $self = shift; 1069 my $txt = shift; 1070 # \cK also swallows a preceding line break when followed by a 1071 # semicolon. 1072 $txt =~ s/\n\cK;//g; 1073 my @lines = split(/\n/, $txt); 1074 my $leader = ""; 1075 my $level = 0; 1076 my $line; 1077 for $line (@lines) { 1078 my $cmd = substr($line, 0, 1); 1079 if ($cmd eq "\t" or $cmd eq "\b") { 1080 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; 1081 if ($self->{'use_tabs'}) { 1082 $leader = "\t" x ($level / 8) . " " x ($level % 8); 1083 } else { 1084 $leader = " " x $level; 1085 } 1086 $line = substr($line, 1); 1087 } 1088 if (index($line, "\f") > 0) { 1089 $line =~ s/\f/\n/; 1090 } 1091 if (substr($line, 0, 1) eq "\f") { 1092 $line = substr($line, 1); # no indent 1093 } else { 1094 $line = $leader . $line; 1095 } 1096 $line =~ s/\cK;?//g; 1097 } 1098 return join("\n", @lines); 1099} 1100 1101sub pad_subs { 1102 my ($self, $cv) = @_; 1103 my $padlist = $cv->PADLIST; 1104 my @names = $padlist->ARRAYelt(0)->ARRAY; 1105 my @values = $padlist->ARRAYelt(1)->ARRAY; 1106 my @todo; 1107 PADENTRY: 1108 for my $ix (0.. $#names) { for $_ ($names[$ix]) { 1109 next if class($_) eq "SPECIAL"; 1110 my $name = $_->PVX; 1111 if (defined $name && $name =~ /^&./) { 1112 my $low = $_->COP_SEQ_RANGE_LOW; 1113 my $flags = $_->FLAGS; 1114 my $outer = $flags & PADNAMEt_OUTER; 1115 if ($flags & SVpad_OUR) { 1116 push @todo, [$low, undef, 0, $_] 1117 # [seq, no cv, not format, padname] 1118 unless $outer; 1119 next; 1120 } 1121 my $protocv = $flags & SVpad_STATE 1122 ? $values[$ix] 1123 : $_->PROTOCV; 1124 if (class ($protocv) ne 'CV') { 1125 my $flags = $flags; 1126 my $cv = $cv; 1127 my $name = $_; 1128 while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV') 1129 { 1130 $cv = $cv->OUTSIDE; 1131 next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed? 1132 my $padlist = $cv->PADLIST; 1133 my $ix = $name->PARENT_PAD_INDEX; 1134 $name = $padlist->NAMES->ARRAYelt($ix); 1135 $flags = $name->FLAGS; 1136 $protocv = $flags & SVpad_STATE 1137 ? $padlist->ARRAYelt(1)->ARRAYelt($ix) 1138 : $name->PROTOCV; 1139 } 1140 } 1141 my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do { 1142 my $other = $protocv->PADLIST; 1143 $$other && $other->outid == $padlist->id; 1144 }; 1145 if ($flags & PADNAMEt_OUTER) { 1146 next unless $defined_in_this_sub; 1147 push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_]; 1148 next; 1149 } 1150 my $outseq = $protocv->OUTSIDE_SEQ; 1151 if ($outseq <= $low) { 1152 # defined before its name is visible, so it’s gotta be 1153 # declared and defined at once: my sub foo { ... } 1154 push @todo, [$low, $protocv, 0, $_]; 1155 } 1156 else { 1157 # declared and defined separately: my sub f; sub f { ... } 1158 push @todo, [$low, undef, 0, $_]; 1159 push @todo, [$outseq, $protocv, 0, $_] 1160 if $defined_in_this_sub; 1161 } 1162 } 1163 }} 1164 @{$self->{'subs_todo'}} = 1165 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo 1166} 1167 1168 1169# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem 1170# ops into a subroutine signature. If successful, return the first op 1171# following the signature ops plus the signature string; else return the 1172# empty list. 1173# 1174# Normally a bunch of argelem ops will have been generated by the 1175# signature parsing, but it's possible that ops have been added manually 1176# or altered. In this case we return "()" and fall back to general 1177# deparsing of the individual sigelems as 'my $x = $_[N]' etc. 1178# 1179# We're only called if the first two ops are nextstate and argcheck. 1180 1181sub deparse_argops { 1182 my ($self, $firstop, $cv) = @_; 1183 1184 my @sig; 1185 my $o = $firstop; 1186 return if $o->label; #first nextstate; 1187 1188 # OP_ARGCHECK 1189 1190 $o = $o->sibling; 1191 my ($params, $opt_params, $slurpy) = $o->aux_list($cv); 1192 my $mandatory = $params - $opt_params; 1193 my $seen_slurpy = 0; 1194 my $last_ix = -1; 1195 1196 # keep looking for valid nextstate + argelem pairs 1197 1198 while (1) { 1199 # OP_NEXTSTATE 1200 $o = $o->sibling; 1201 last unless $$o; 1202 last unless $o->name =~ /^(next|db)state$/; 1203 last if $o->label; 1204 1205 # OP_ARGELEM 1206 my $o2 = $o->sibling; 1207 last unless $$o2; 1208 1209 if ($o2->name eq 'argelem') { 1210 my $ix = $o2->string($cv); 1211 while (++$last_ix < $ix) { 1212 push @sig, $last_ix < $mandatory ? '$' : '$='; 1213 } 1214 my $var = $self->padname($o2->targ); 1215 if ($var =~ /^[@%]/) { 1216 return if $seen_slurpy; 1217 $seen_slurpy = 1; 1218 return if $ix != $params or !$slurpy 1219 or substr($var,0,1) ne $slurpy; 1220 } 1221 else { 1222 return if $ix >= $params; 1223 } 1224 if ($o2->flags & OPf_KIDS) { 1225 my $kid = $o2->first; 1226 return unless $$kid and $kid->name eq 'argdefelem'; 1227 my $def = $self->deparse($kid->first, 7); 1228 $def = "($def)" if $kid->first->flags & OPf_PARENS; 1229 $var .= " = $def"; 1230 } 1231 push @sig, $var; 1232 } 1233 elsif ($o2->name eq 'null' 1234 and ($o2->flags & OPf_KIDS) 1235 and $o2->first->name eq 'argdefelem') 1236 { 1237 # special case - a void context default expression: $ = expr 1238 1239 my $defop = $o2->first; 1240 my $ix = $defop->targ; 1241 while (++$last_ix < $ix) { 1242 push @sig, $last_ix < $mandatory ? '$' : '$='; 1243 } 1244 return if $last_ix >= $params 1245 or $last_ix < $mandatory; 1246 my $def = $self->deparse($defop->first, 7); 1247 $def = "($def)" if $defop->first->flags & OPf_PARENS; 1248 push @sig, '$ = ' . $def; 1249 } 1250 else { 1251 last; 1252 } 1253 1254 $o = $o2; 1255 } 1256 1257 while (++$last_ix < $params) { 1258 push @sig, $last_ix < $mandatory ? '$' : '$='; 1259 } 1260 push @sig, $slurpy if $slurpy and !$seen_slurpy; 1261 1262 return ($o, join(', ', @sig)); 1263} 1264 1265# Deparse a sub. Returns everything except the 'sub foo', 1266# e.g. ($$) : method { ...; } 1267# or : prototype($$) lvalue ($a, $b) { ...; }; 1268 1269sub deparse_sub { 1270 my $self = shift; 1271 my $cv = shift; 1272 my @attrs; 1273 my $proto; 1274 my $sig; 1275 1276Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); 1277Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); 1278 local $self->{'curcop'} = $self->{'curcop'}; 1279 1280 my $has_sig = $self->{hinthash}{feature_signatures}; 1281 if ($cv->FLAGS & SVf_POK) { 1282 my $myproto = $cv->PV; 1283 if ($has_sig) { 1284 push @attrs, "prototype($myproto)"; 1285 } 1286 else { 1287 $proto = $myproto; 1288 } 1289 } 1290 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) { 1291 push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE; 1292 push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD; 1293 push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST; 1294 } 1295 1296 local($self->{'curcv'}) = $cv; 1297 local($self->{'curcvlex'}); 1298 local(@$self{qw'curstash warnings hints hinthash'}) 1299 = @$self{qw'curstash warnings hints hinthash'}; 1300 my $body; 1301 my $root = $cv->ROOT; 1302 local $B::overlay = {}; 1303 if (not null $root) { 1304 $self->pad_subs($cv); 1305 $self->pessimise($root, $cv->START); 1306 my $lineseq = $root->first; 1307 if ($lineseq->name eq "lineseq") { 1308 my $firstop = $lineseq->first; 1309 1310 if ($has_sig) { 1311 my $o2; 1312 # try to deparse first few ops as a signature if possible 1313 if ( $$firstop 1314 and $firstop->name =~ /^(next|db)state$/ 1315 and (($o2 = $firstop->sibling)) 1316 and $$o2) 1317 { 1318 if ($o2->name eq 'argcheck') { 1319 my ($nexto, $mysig) = $self->deparse_argops($firstop, $cv); 1320 if (defined $nexto) { 1321 $firstop = $nexto; 1322 $sig = $mysig; 1323 } 1324 } 1325 } 1326 } 1327 1328 my @ops; 1329 for (my $o = $firstop; $$o; $o=$o->sibling) { 1330 push @ops, $o; 1331 } 1332 $body = $self->lineseq(undef, 0, @ops).";"; 1333 if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) { 1334 # this handles void context in 1335 # use feature signatures; sub ($=1) {} 1336 $body .= "\n()"; 1337 } 1338 my $scope_en = $self->find_scope_en($lineseq); 1339 if (defined $scope_en) { 1340 my $subs = join"", $self->seq_subs($scope_en); 1341 $body .= ";\n$subs" if length($subs); 1342 } 1343 } 1344 else { 1345 $body = $self->deparse($root->first, 0); 1346 } 1347 1348 my $l = ''; 1349 if ($self->{'linenums'}) { 1350 # a glob's gp_line is set from the line containing a 1351 # sub's closing '}' if the CV is the first use of the GV. 1352 # So make sure the linenum is set correctly for '}' 1353 my $gv = $cv->GV; 1354 my $line = $gv->LINE; 1355 my $file = $gv->FILE; 1356 $l = "\f#line $line \"$file\"\n"; 1357 } 1358 $body = "{\n\t$body\n$l\b}"; 1359 } 1360 else { 1361 my $sv = $cv->const_sv; 1362 if ($$sv) { 1363 # uh-oh. inlinable sub... format it differently 1364 $body = "{ " . $self->const($sv, 0) . " }\n"; 1365 } else { # XSUB? (or just a declaration) 1366 $body = ';' 1367 } 1368 } 1369 $proto = defined $proto ? "($proto) " : ""; 1370 $sig = defined $sig ? "($sig) " : ""; 1371 my $attrs = ''; 1372 $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs; 1373 return "$proto$attrs$sig$body\n"; 1374} 1375 1376sub deparse_format { 1377 my $self = shift; 1378 my $form = shift; 1379 my @text; 1380 local($self->{'curcv'}) = $form; 1381 local($self->{'curcvlex'}); 1382 local($self->{'in_format'}) = 1; 1383 local(@$self{qw'curstash warnings hints hinthash'}) 1384 = @$self{qw'curstash warnings hints hinthash'}; 1385 my $op = $form->ROOT; 1386 local $B::overlay = {}; 1387 $self->pessimise($op, $form->START); 1388 my $kid; 1389 return "\f." if $op->first->name eq 'stub' 1390 || $op->first->name eq 'nextstate'; 1391 $op = $op->first->first; # skip leavewrite, lineseq 1392 while (not null $op) { 1393 $op = $op->sibling; # skip nextstate 1394 my @exprs; 1395 $kid = $op->first->sibling; # skip pushmark 1396 push @text, "\f".$self->const_sv($kid)->PV; 1397 $kid = $kid->sibling; 1398 for (; not null $kid; $kid = $kid->sibling) { 1399 push @exprs, $self->deparse($kid, -1); 1400 $exprs[-1] =~ s/;\z//; 1401 } 1402 push @text, "\f".join(", ", @exprs)."\n" if @exprs; 1403 $op = $op->sibling; 1404 } 1405 return join("", @text) . "\f."; 1406} 1407 1408sub is_scope { 1409 my $op = shift; 1410 return $op->name eq "leave" || $op->name eq "scope" 1411 || $op->name eq "lineseq" 1412 || ($op->name eq "null" && class($op) eq "UNOP" 1413 && (is_scope($op->first) || $op->first->name eq "enter")); 1414} 1415 1416sub is_state { 1417 my $name = $_[0]->name; 1418 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; 1419} 1420 1421sub is_miniwhile { # check for one-line loop ('foo() while $y--') 1422 my $op = shift; 1423 return (!null($op) and null($op->sibling) 1424 and $op->name eq "null" and class($op) eq "UNOP" 1425 and (($op->first->name =~ /^(and|or)$/ 1426 and $op->first->first->sibling->name eq "lineseq") 1427 or ($op->first->name eq "lineseq" 1428 and not null $op->first->first->sibling 1429 and $op->first->first->sibling->name eq "unstack") 1430 )); 1431} 1432 1433# Check if the op and its sibling are the initialization and the rest of a 1434# for (..;..;..) { ... } loop 1435sub is_for_loop { 1436 my $op = shift; 1437 # This OP might be almost anything, though it won't be a 1438 # nextstate. (It's the initialization, so in the canonical case it 1439 # will be an sassign.) The sibling is (old style) a lineseq whose 1440 # first child is a nextstate and whose second is a leaveloop, or 1441 # (new style) an unstack whose sibling is a leaveloop. 1442 my $lseq = $op->sibling; 1443 return 0 unless !is_state($op) and !null($lseq); 1444 if ($lseq->name eq "lineseq") { 1445 if ($lseq->first && !null($lseq->first) && is_state($lseq->first) 1446 && (my $sib = $lseq->first->sibling)) { 1447 return (!null($sib) && $sib->name eq "leaveloop"); 1448 } 1449 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) { 1450 my $sib = $lseq->sibling; 1451 return $sib && !null($sib) && $sib->name eq "leaveloop"; 1452 } 1453 return 0; 1454} 1455 1456sub is_scalar { 1457 my $op = shift; 1458 return ($op->name eq "rv2sv" or 1459 $op->name eq "padsv" or 1460 $op->name eq "gv" or # only in array/hash constructs 1461 $op->flags & OPf_KIDS && !null($op->first) 1462 && $op->first->name eq "gvsv"); 1463} 1464 1465sub maybe_parens { 1466 my $self = shift; 1467 my($text, $cx, $prec) = @_; 1468 if ($prec < $cx # unary ops nest just fine 1469 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 1470 or $self->{'parens'}) 1471 { 1472 $text = "($text)"; 1473 # In a unop, let parent reuse our parens; see maybe_parens_unop 1474 $text = "\cS" . $text if $cx == 16; 1475 return $text; 1476 } else { 1477 return $text; 1478 } 1479} 1480 1481# same as above, but get around the 'if it looks like a function' rule 1482sub maybe_parens_unop { 1483 my $self = shift; 1484 my($name, $kid, $cx) = @_; 1485 if ($cx > 16 or $self->{'parens'}) { 1486 $kid = $self->deparse($kid, 1); 1487 if ($name eq "umask" && $kid =~ /^\d+$/) { 1488 $kid = sprintf("%#o", $kid); 1489 } 1490 return $self->keyword($name) . "($kid)"; 1491 } else { 1492 $kid = $self->deparse($kid, 16); 1493 if ($name eq "umask" && $kid =~ /^\d+$/) { 1494 $kid = sprintf("%#o", $kid); 1495 } 1496 $name = $self->keyword($name); 1497 if (substr($kid, 0, 1) eq "\cS") { 1498 # use kid's parens 1499 return $name . substr($kid, 1); 1500 } elsif (substr($kid, 0, 1) eq "(") { 1501 # avoid looks-like-a-function trap with extra parens 1502 # ('+' can lead to ambiguities) 1503 return "$name(" . $kid . ")"; 1504 } else { 1505 return "$name $kid"; 1506 } 1507 } 1508} 1509 1510sub maybe_parens_func { 1511 my $self = shift; 1512 my($func, $text, $cx, $prec) = @_; 1513 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { 1514 return "$func($text)"; 1515 } else { 1516 return "$func $text"; 1517 } 1518} 1519 1520sub find_our_type { 1521 my ($self, $name) = @_; 1522 $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 1523 my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0; 1524 for my $a (@{$self->{'curcvlex'}{"o$name"}}) { 1525 my ($st, undef, $padname) = @$a; 1526 if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) { 1527 return $padname->SvSTASH->NAME; 1528 } 1529 } 1530 return ''; 1531} 1532 1533sub maybe_local { 1534 my $self = shift; 1535 my($op, $cx, $text) = @_; 1536 my $name = $op->name; 1537 my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign 1538 |lv(?:av)?ref)$/x) 1539 ? OPpOUR_INTRO 1540 : 0; 1541 my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO; 1542 # The @a in \(@a) isn't in ref context, but only when the 1543 # parens are there. 1544 my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/ 1545 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; 1546 if ((my $priv = $op->private) & ($lval_intro|$our_intro)) { 1547 my @our_local; 1548 push @our_local, "local" if $priv & $lval_intro; 1549 push @our_local, "our" if $priv & $our_intro; 1550 my $our_local = join " ", map $self->keyword($_), @our_local; 1551 if( $our_local[-1] eq 'our' ) { 1552 if ( $text !~ /^\W(\w+::)*\w+\z/ 1553 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/ 1554 ) { 1555 die "Unexpected our($text)\n"; 1556 } 1557 $text =~ s/(\w+::)+//; 1558 1559 if (my $type = $self->find_our_type($text)) { 1560 $our_local .= ' ' . $type; 1561 } 1562 } 1563 return $need_parens ? "($text)" : $text 1564 if $self->{'avoid_local'}{$$op}; 1565 if ($need_parens) { 1566 return "$our_local($text)"; 1567 } elsif (want_scalar($op) || $our_local eq 'our') { 1568 return "$our_local $text"; 1569 } else { 1570 return $self->maybe_parens_func("$our_local", $text, $cx, 16); 1571 } 1572 } else { 1573 return $need_parens ? "($text)" : $text; 1574 } 1575} 1576 1577sub maybe_targmy { 1578 my $self = shift; 1579 my($op, $cx, $func, @args) = @_; 1580 if ($op->private & OPpTARGET_MY) { 1581 my $var = $self->padname($op->targ); 1582 my $val = $func->($self, $op, 7, @args); 1583 return $self->maybe_parens("$var = $val", $cx, 7); 1584 } else { 1585 return $func->($self, $op, $cx, @args); 1586 } 1587} 1588 1589sub padname_sv { 1590 my $self = shift; 1591 my $targ = shift; 1592 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); 1593} 1594 1595sub maybe_my { 1596 my $self = shift; 1597 my($op, $cx, $text, $padname, $forbid_parens) = @_; 1598 # The @a in \(@a) isn't in ref context, but only when the 1599 # parens are there. 1600 my $need_parens = !$forbid_parens && $self->{'in_refgen'} 1601 && $op->name =~ /[ah]v\z/ 1602 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; 1603 # The @a in \my @a must not have parens. 1604 if (!$need_parens && $self->{'in_refgen'}) { 1605 $forbid_parens = 1; 1606 } 1607 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { 1608 # Check $padname->FLAGS for statehood, rather than $op->private, 1609 # because enteriter ops do not carry the flag. 1610 my $my = 1611 $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my"); 1612 if ($padname->FLAGS & SVpad_TYPED) { 1613 $my .= ' ' . $padname->SvSTASH->NAME; 1614 } 1615 if ($need_parens) { 1616 return "$my($text)"; 1617 } elsif ($forbid_parens || want_scalar($op)) { 1618 return "$my $text"; 1619 } else { 1620 return $self->maybe_parens_func($my, $text, $cx, 16); 1621 } 1622 } else { 1623 return $need_parens ? "($text)" : $text; 1624 } 1625} 1626 1627# The following OPs don't have functions: 1628 1629# pp_padany -- does not exist after parsing 1630 1631sub AUTOLOAD { 1632 if ($AUTOLOAD =~ s/^.*::pp_//) { 1633 warn "unexpected OP_". 1634 ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD); 1635 return "XXX"; 1636 } else { 1637 die "Undefined subroutine $AUTOLOAD called"; 1638 } 1639} 1640 1641sub DESTROY {} # Do not AUTOLOAD 1642 1643# $root should be the op which represents the root of whatever 1644# we're sequencing here. If it's undefined, then we don't append 1645# any subroutine declarations to the deparsed ops, otherwise we 1646# append appropriate declarations. 1647sub lineseq { 1648 my($self, $root, $cx, @ops) = @_; 1649 my($expr, @exprs); 1650 1651 my $out_cop = $self->{'curcop'}; 1652 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; 1653 my $limit_seq; 1654 if (defined $root) { 1655 $limit_seq = $out_seq; 1656 my $nseq; 1657 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; 1658 $limit_seq = $nseq if !defined($limit_seq) 1659 or defined($nseq) && $nseq < $limit_seq; 1660 } 1661 $limit_seq = $self->{'limit_seq'} 1662 if defined($self->{'limit_seq'}) 1663 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); 1664 local $self->{'limit_seq'} = $limit_seq; 1665 1666 $self->walk_lineseq($root, \@ops, 1667 sub { push @exprs, $_[0]} ); 1668 1669 my $sep = $cx ? '; ' : ";\n"; 1670 my $body = join($sep, grep {length} @exprs); 1671 my $subs = ""; 1672 if (defined $root && defined $limit_seq && !$self->{'in_format'}) { 1673 $subs = join "\n", $self->seq_subs($limit_seq); 1674 } 1675 return join($sep, grep {length} $body, $subs); 1676} 1677 1678sub scopeop { 1679 my($real_block, $self, $op, $cx) = @_; 1680 my $kid; 1681 my @kids; 1682 1683 local(@$self{qw'curstash warnings hints hinthash'}) 1684 = @$self{qw'curstash warnings hints hinthash'} if $real_block; 1685 if ($real_block) { 1686 $kid = $op->first->sibling; # skip enter 1687 if (is_miniwhile($kid)) { 1688 my $top = $kid->first; 1689 my $name = $top->name; 1690 if ($name eq "and") { 1691 $name = $self->keyword("while"); 1692 } elsif ($name eq "or") { 1693 $name = $self->keyword("until"); 1694 } else { # no conditional -> while 1 or until 0 1695 return $self->deparse($top->first, 1) . " " 1696 . $self->keyword("while") . " 1"; 1697 } 1698 my $cond = $top->first; 1699 my $body = $cond->sibling->first; # skip lineseq 1700 $cond = $self->deparse($cond, 1); 1701 $body = $self->deparse($body, 1); 1702 return "$body $name $cond"; 1703 } 1704 } else { 1705 $kid = $op->first; 1706 } 1707 for (; !null($kid); $kid = $kid->sibling) { 1708 push @kids, $kid; 1709 } 1710 if ($cx > 0) { # inside an expression, (a do {} while for lineseq) 1711 my $body = $self->lineseq($op, 0, @kids); 1712 return is_lexical_subs(@kids) 1713 ? $body 1714 : ($self->lex_in_scope("&do") ? "CORE::do" : "do") 1715 . " {\n\t$body\n\b}"; 1716 } else { 1717 my $lineseq = $self->lineseq($op, $cx, @kids); 1718 return (length ($lineseq) ? "$lineseq;" : ""); 1719 } 1720} 1721 1722sub pp_scope { scopeop(0, @_); } 1723sub pp_lineseq { scopeop(0, @_); } 1724sub pp_leave { scopeop(1, @_); } 1725 1726# This is a special case of scopeop and lineseq, for the case of the 1727# main_root. The difference is that we print the output statements as 1728# soon as we get them, for the sake of impatient users. 1729sub deparse_root { 1730 my $self = shift; 1731 my($op) = @_; 1732 local(@$self{qw'curstash warnings hints hinthash'}) 1733 = @$self{qw'curstash warnings hints hinthash'}; 1734 my @kids; 1735 return if null $op->first; # Can happen, e.g., for Bytecode without -k 1736 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { 1737 push @kids, $kid; 1738 } 1739 $self->walk_lineseq($op, \@kids, 1740 sub { return unless length $_[0]; 1741 print $self->indent($_[0].';'); 1742 print "\n" 1743 unless $_[1] == $#kids; 1744 }); 1745} 1746 1747sub walk_lineseq { 1748 my ($self, $op, $kids, $callback) = @_; 1749 my @kids = @$kids; 1750 for (my $i = 0; $i < @kids; $i++) { 1751 my $expr = ""; 1752 if (is_state $kids[$i]) { 1753 $expr = $self->deparse($kids[$i++], 0); 1754 if ($i > $#kids) { 1755 $callback->($expr, $i); 1756 last; 1757 } 1758 } 1759 if (is_for_loop($kids[$i])) { 1760 $callback->($expr . $self->for_loop($kids[$i], 0), 1761 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); 1762 next; 1763 } 1764 my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2); 1765 $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise 1766 $expr .= $expr2; 1767 $callback->($expr, $i); 1768 } 1769} 1770 1771# The BEGIN {} is used here because otherwise this code isn't executed 1772# when you run B::Deparse on itself. 1773my %globalnames; 1774BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", 1775 "ENV", "ARGV", "ARGVOUT", "_"); } 1776 1777sub gv_name { 1778 my $self = shift; 1779 my $gv = shift; 1780 my $raw = shift; 1781#Carp::confess() unless ref($gv) eq "B::GV"; 1782 my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0; 1783 my $stash = ($cv || $gv)->STASH->NAME; 1784 my $name = $raw 1785 ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME 1786 : $cv 1787 ? B::safename($cv->NAME_HEK || $cv->GV->NAME) 1788 : $gv->SAFENAME; 1789 if ($stash eq 'main' && $name =~ /^::/) { 1790 $stash = '::'; 1791 } 1792 elsif (($stash eq 'main' 1793 && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/)) 1794 or ($stash eq $self->{'curstash'} && !$globalnames{$name} 1795 && ($stash eq 'main' || $name !~ /::/)) 1796 ) 1797 { 1798 $stash = ""; 1799 } else { 1800 $stash = $stash . "::"; 1801 } 1802 if (!$raw and $name =~ /^(\^..|{)/) { 1803 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ 1804 } 1805 return $stash . $name; 1806} 1807 1808# Return the name to use for a stash variable. 1809# If a lexical with the same name is in scope, or 1810# if strictures are enabled, it may need to be 1811# fully-qualified. 1812sub stash_variable { 1813 my ($self, $prefix, $name, $cx) = @_; 1814 1815 return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/; 1816 1817 unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #' 1818 $prefix eq '%' || $prefix eq '$#') { 1819 return "$prefix$name"; 1820 } 1821 1822 if ($name =~ /^[^[:alpha:]_+-]$/) { 1823 if (defined $cx && $cx == 26) { 1824 if ($prefix eq '@') { 1825 return "$prefix\{$name}"; 1826 } 1827 elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a" 1828 } 1829 if ($prefix eq '$#') { 1830 return "\$#{$name}"; 1831 } 1832 } 1833 1834 return $prefix . $self->maybe_qualify($prefix, $name); 1835} 1836 1837my %unctrl = # portable to EBCDIC 1838 ( 1839 "\c@" => '@', # unused 1840 "\cA" => 'A', 1841 "\cB" => 'B', 1842 "\cC" => 'C', 1843 "\cD" => 'D', 1844 "\cE" => 'E', 1845 "\cF" => 'F', 1846 "\cG" => 'G', 1847 "\cH" => 'H', 1848 "\cI" => 'I', 1849 "\cJ" => 'J', 1850 "\cK" => 'K', 1851 "\cL" => 'L', 1852 "\cM" => 'M', 1853 "\cN" => 'N', 1854 "\cO" => 'O', 1855 "\cP" => 'P', 1856 "\cQ" => 'Q', 1857 "\cR" => 'R', 1858 "\cS" => 'S', 1859 "\cT" => 'T', 1860 "\cU" => 'U', 1861 "\cV" => 'V', 1862 "\cW" => 'W', 1863 "\cX" => 'X', 1864 "\cY" => 'Y', 1865 "\cZ" => 'Z', 1866 "\c[" => '[', # unused 1867 "\c\\" => '\\', # unused 1868 "\c]" => ']', # unused 1869 "\c_" => '_', # unused 1870 ); 1871 1872# Return just the name, without the prefix. It may be returned as a quoted 1873# string. The second return value is a boolean indicating that. 1874sub stash_variable_name { 1875 my($self, $prefix, $gv) = @_; 1876 my $name = $self->gv_name($gv, 1); 1877 $name = $self->maybe_qualify($prefix,$name); 1878 if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) { 1879 $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e; 1880 $name =~ /^(\^..|{)/ and $name = "{$name}"; 1881 return $name, 0; # not quoted 1882 } 1883 else { 1884 single_delim("q", "'", $name, $self), 1; 1885 } 1886} 1887 1888sub maybe_qualify { 1889 my ($self,$prefix,$name) = @_; 1890 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; 1891 if ($prefix eq "") { 1892 $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/; 1893 return $name; 1894 } 1895 return $name if $name =~ /::/; 1896 return $self->{'curstash'}.'::'. $name 1897 if 1898 $name =~ /^(?!\d)\w/ # alphabetic 1899 && $v !~ /^\$[ab]\z/ # not $a or $b 1900 && $v =~ /\A[\$\@\%\&]/ # scalar, array, hash, or sub 1901 && !$globalnames{$name} # not a global name 1902 && $self->{hints} & $strict_bits{vars} # strict vars 1903 && !$self->lex_in_scope($v,1) # no "our" 1904 or $self->lex_in_scope($v); # conflicts with "my" variable 1905 return $name; 1906} 1907 1908sub lex_in_scope { 1909 my ($self, $name, $our) = @_; 1910 substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my 1911 $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 1912 1913 return 0 if !defined($self->{'curcop'}); 1914 my $seq = $self->{'curcop'}->cop_seq; 1915 return 0 if !exists $self->{'curcvlex'}{$name}; 1916 for my $a (@{$self->{'curcvlex'}{$name}}) { 1917 my ($st, $en) = @$a; 1918 return 1 if $seq > $st && $seq <= $en; 1919 } 1920 return 0; 1921} 1922 1923sub populate_curcvlex { 1924 my $self = shift; 1925 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { 1926 my $padlist = $cv->PADLIST; 1927 # an undef CV still in lexical chain 1928 next if class($padlist) eq "SPECIAL"; 1929 my @padlist = $padlist->ARRAY; 1930 my @ns = $padlist[0]->ARRAY; 1931 1932 for (my $i=0; $i<@ns; ++$i) { 1933 next if class($ns[$i]) eq "SPECIAL"; 1934 if (class($ns[$i]) eq "PV") { 1935 # Probably that pesky lexical @_ 1936 next; 1937 } 1938 my $name = $ns[$i]->PVX; 1939 next unless defined $name; 1940 my ($seq_st, $seq_en) = 1941 ($ns[$i]->FLAGS & SVf_FAKE) 1942 ? (0, 999999) 1943 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH); 1944 1945 push @{$self->{'curcvlex'}{ 1946 ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name 1947 }}, [$seq_st, $seq_en, $ns[$i]]; 1948 } 1949 } 1950} 1951 1952sub find_scope_st { ((find_scope(@_))[0]); } 1953sub find_scope_en { ((find_scope(@_))[1]); } 1954 1955# Recurses down the tree, looking for pad variable introductions and COPs 1956sub find_scope { 1957 my ($self, $op, $scope_st, $scope_en) = @_; 1958 carp("Undefined op in find_scope") if !defined $op; 1959 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; 1960 1961 my @queue = ($op); 1962 while(my $op = shift @queue ) { 1963 for (my $o=$op->first; $$o; $o=$o->sibling) { 1964 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { 1965 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW); 1966 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH; 1967 $scope_st = $s if !defined($scope_st) || $s < $scope_st; 1968 $scope_en = $e if !defined($scope_en) || $e > $scope_en; 1969 return ($scope_st, $scope_en); 1970 } 1971 elsif (is_state($o)) { 1972 my $c = $o->cop_seq; 1973 $scope_st = $c if !defined($scope_st) || $c < $scope_st; 1974 $scope_en = $c if !defined($scope_en) || $c > $scope_en; 1975 return ($scope_st, $scope_en); 1976 } 1977 elsif ($o->flags & OPf_KIDS) { 1978 unshift (@queue, $o); 1979 } 1980 } 1981 } 1982 1983 return ($scope_st, $scope_en); 1984} 1985 1986# Returns a list of subs which should be inserted before the COP 1987sub cop_subs { 1988 my ($self, $op, $out_seq) = @_; 1989 my $seq = $op->cop_seq; 1990 $seq = $out_seq if defined($out_seq) && $out_seq < $seq; 1991 return $self->seq_subs($seq); 1992} 1993 1994sub seq_subs { 1995 my ($self, $seq) = @_; 1996 my @text; 1997#push @text, "# ($seq)\n"; 1998 1999 return "" if !defined $seq; 2000 my @pending; 2001 while (scalar(@{$self->{'subs_todo'}}) 2002 and $seq > $self->{'subs_todo'}[0][0]) { 2003 my $cv = $self->{'subs_todo'}[0][1]; 2004 # Skip the OUTSIDE check for lexical subs. We may be deparsing a 2005 # cloned anon sub with lexical subs declared in it, in which case 2006 # the OUTSIDE pointer points to the anon protosub. 2007 my $lexical = ref $self->{'subs_todo'}[0][3]; 2008 my $outside = !$lexical && $cv && $cv->OUTSIDE; 2009 if (!$lexical and $cv 2010 and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) 2011 { 2012 push @pending, shift @{$self->{'subs_todo'}}; 2013 next; 2014 } 2015 push @text, $self->next_todo; 2016 } 2017 unshift @{$self->{'subs_todo'}}, @pending; 2018 return @text; 2019} 2020 2021sub _features_from_bundle { 2022 my ($hints, $hh) = @_; 2023 foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) { 2024 $hh->{$feature::feature{$_}} = 1; 2025 } 2026 return $hh; 2027} 2028 2029# generate any pragmas, 'package foo' etc needed to synchronise 2030# with the given cop 2031 2032sub pragmata { 2033 my $self = shift; 2034 my($op) = @_; 2035 2036 my @text; 2037 2038 my $stash = $op->stashpv; 2039 if ($stash ne $self->{'curstash'}) { 2040 push @text, $self->keyword("package") . " $stash;\n"; 2041 $self->{'curstash'} = $stash; 2042 } 2043 2044 my $warnings = $op->warnings; 2045 my $warning_bits; 2046 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { 2047 $warning_bits = $warnings::Bits{"all"} & WARN_MASK; 2048 } 2049 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { 2050 $warning_bits = $warnings::NONE; 2051 } 2052 elsif ($warnings->isa("B::SPECIAL")) { 2053 $warning_bits = undef; 2054 } 2055 else { 2056 $warning_bits = $warnings->PV & WARN_MASK; 2057 } 2058 2059 if (defined ($warning_bits) and 2060 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { 2061 push @text, 2062 $self->declare_warnings($self->{'warnings'}, $warning_bits); 2063 $self->{'warnings'} = $warning_bits; 2064 } 2065 2066 my $hints = $op->hints; 2067 my $old_hints = $self->{'hints'}; 2068 if ($self->{'hints'} != $hints) { 2069 push @text, $self->declare_hints($self->{'hints'}, $hints); 2070 $self->{'hints'} = $hints; 2071 } 2072 2073 my $newhh; 2074 $newhh = $op->hints_hash->HASH; 2075 2076 { 2077 # feature bundle hints 2078 my $from = $old_hints & $feature::hint_mask; 2079 my $to = $ hints & $feature::hint_mask; 2080 if ($from != $to) { 2081 if ($to == $feature::hint_mask) { 2082 if ($self->{'hinthash'}) { 2083 delete $self->{'hinthash'}{$_} 2084 for grep /^feature_/, keys %{$self->{'hinthash'}}; 2085 } 2086 else { $self->{'hinthash'} = {} } 2087 $self->{'hinthash'} 2088 = _features_from_bundle($from, $self->{'hinthash'}); 2089 } 2090 else { 2091 my $bundle = 2092 $feature::hint_bundles[$to >> $feature::hint_shift]; 2093 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12 2094 push @text, 2095 $self->keyword("no") . " feature ':all';\n", 2096 $self->keyword("use") . " feature ':$bundle';\n"; 2097 } 2098 } 2099 } 2100 2101 { 2102 push @text, $self->declare_hinthash( 2103 $self->{'hinthash'}, $newhh, 2104 $self->{indent_size}, $self->{hints}, 2105 ); 2106 $self->{'hinthash'} = $newhh; 2107 } 2108 2109 return join("", @text); 2110} 2111 2112 2113# Notice how subs and formats are inserted between statements here; 2114# also $[ assignments and pragmas. 2115sub pp_nextstate { 2116 my $self = shift; 2117 my($op, $cx) = @_; 2118 $self->{'curcop'} = $op; 2119 2120 my @text; 2121 2122 my @subs = $self->cop_subs($op); 2123 if (@subs) { 2124 # Special marker to swallow up the semicolon 2125 push @subs, "\cK"; 2126 } 2127 push @text, @subs; 2128 2129 push @text, $self->pragmata($op); 2130 2131 2132 # This should go after of any branches that add statements, to 2133 # increase the chances that it refers to the same line it did in 2134 # the original program. 2135 if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format 2136 push @text, "\f#line " . $op->line . 2137 ' "' . $op->file, qq'"\n'; 2138 } 2139 2140 push @text, $op->label . ": " if $op->label; 2141 2142 return join("", @text); 2143} 2144 2145sub declare_warnings { 2146 my ($self, $from, $to) = @_; 2147 $from //= ''; 2148 my $all = (warnings::bits("all") & WARN_MASK); 2149 unless ((($from & WARN_MASK) & ~$all) =~ /[^\0]/) { 2150 # no FATAL bits need turning off 2151 if ( ($to & WARN_MASK) eq $all) { 2152 return $self->keyword("use") . " warnings;\n"; 2153 } 2154 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { 2155 return $self->keyword("no") . " warnings;\n"; 2156 } 2157 } 2158 2159 return "BEGIN {\${^WARNING_BITS} = \"" 2160 . join("", map { sprintf("\\x%02x", ord $_) } split "", $to) 2161 . "\"}\n\cK"; 2162} 2163 2164sub declare_hints { 2165 my ($self, $from, $to) = @_; 2166 my $use = $to & ~$from; 2167 my $no = $from & ~$to; 2168 my $decls = ""; 2169 for my $pragma (hint_pragmas($use)) { 2170 $decls .= $self->keyword("use") . " $pragma;\n"; 2171 } 2172 for my $pragma (hint_pragmas($no)) { 2173 $decls .= $self->keyword("no") . " $pragma;\n"; 2174 } 2175 return $decls; 2176} 2177 2178# Internal implementation hints that the core sets automatically, so don't need 2179# (or want) to be passed back to the user 2180my %ignored_hints = ( 2181 'open<' => 1, 2182 'open>' => 1, 2183 ':' => 1, 2184 'strict/refs' => 1, 2185 'strict/subs' => 1, 2186 'strict/vars' => 1, 2187); 2188 2189my %rev_feature; 2190 2191sub declare_hinthash { 2192 my ($self, $from, $to, $indent, $hints) = @_; 2193 my $doing_features = 2194 ($hints & $feature::hint_mask) == $feature::hint_mask; 2195 my @decls; 2196 my @features; 2197 my @unfeatures; # bugs? 2198 for my $key (sort keys %$to) { 2199 next if $ignored_hints{$key}; 2200 my $is_feature = $key =~ /^feature_/; 2201 next if $is_feature and not $doing_features; 2202 if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) { 2203 push(@features, $key), next if $is_feature; 2204 push @decls, 2205 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = ) 2206 . ( 2207 defined $to->{$key} 2208 ? single_delim("q", "'", $to->{$key}, $self) 2209 : 'undef' 2210 ) 2211 . qq(;); 2212 } 2213 } 2214 for my $key (sort keys %$from) { 2215 next if $ignored_hints{$key}; 2216 my $is_feature = $key =~ /^feature_/; 2217 next if $is_feature and not $doing_features; 2218 if (!exists $to->{$key}) { 2219 push(@unfeatures, $key), next if $is_feature; 2220 push @decls, qq(delete \$^H{'$key'};); 2221 } 2222 } 2223 my @ret; 2224 if (@features || @unfeatures) { 2225 if (!%rev_feature) { %rev_feature = reverse %feature::feature } 2226 } 2227 if (@features) { 2228 push @ret, $self->keyword("use") . " feature " 2229 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n"; 2230 } 2231 if (@unfeatures) { 2232 push @ret, $self->keyword("no") . " feature " 2233 . join(", ", map "'$rev_feature{$_}'", @unfeatures) 2234 . ";\n"; 2235 } 2236 @decls and 2237 push @ret, 2238 join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK"; 2239 return @ret; 2240} 2241 2242sub hint_pragmas { 2243 my ($bits) = @_; 2244 my (@pragmas, @strict); 2245 push @pragmas, "integer" if $bits & 0x1; 2246 for (sort keys %strict_bits) { 2247 push @strict, "'$_'" if $bits & $strict_bits{$_}; 2248 } 2249 if (@strict == keys %strict_bits) { 2250 push @pragmas, "strict"; 2251 } 2252 elsif (@strict) { 2253 push @pragmas, "strict " . join ', ', @strict; 2254 } 2255 push @pragmas, "bytes" if $bits & 0x8; 2256 return @pragmas; 2257} 2258 2259sub pp_dbstate { pp_nextstate(@_) } 2260sub pp_setstate { pp_nextstate(@_) } 2261 2262sub pp_unstack { return "" } # see also leaveloop 2263 2264my %feature_keywords = ( 2265 # keyword => 'feature', 2266 state => 'state', 2267 say => 'say', 2268 given => 'switch', 2269 when => 'switch', 2270 default => 'switch', 2271 break => 'switch', 2272 evalbytes=>'evalbytes', 2273 __SUB__ => '__SUB__', 2274 fc => 'fc', 2275); 2276 2277# keywords that are strong and also have a prototype 2278# 2279my %strong_proto_keywords = map { $_ => 1 } qw( 2280 pos 2281 prototype 2282 scalar 2283 study 2284 undef 2285); 2286 2287sub feature_enabled { 2288 my($self,$name) = @_; 2289 my $hh; 2290 my $hints = $self->{hints} & $feature::hint_mask; 2291 if ($hints && $hints != $feature::hint_mask) { 2292 $hh = _features_from_bundle($hints); 2293 } 2294 elsif ($hints) { $hh = $self->{'hinthash'} } 2295 return $hh && $hh->{"feature_$feature_keywords{$name}"} 2296} 2297 2298sub keyword { 2299 my $self = shift; 2300 my $name = shift; 2301 return $name if $name =~ /^CORE::/; # just in case 2302 if (exists $feature_keywords{$name}) { 2303 return "CORE::$name" if not $self->feature_enabled($name); 2304 } 2305 # This sub may be called for a program that has no nextstate ops. In 2306 # that case we may have a lexical sub named no/use/sub in scope but 2307 # but $self->lex_in_scope will return false because it depends on the 2308 # current nextstate op. So we need this alternate method if there is 2309 # no current cop. 2310 if (!$self->{'curcop'}) { 2311 $self->populate_curcvlex() if !defined $self->{'curcvlex'}; 2312 return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"} 2313 || exists $self->{'curcvlex'}{"o&$name"}; 2314 } elsif ($self->lex_in_scope("&$name") 2315 || $self->lex_in_scope("&$name", 1)) { 2316 return "CORE::$name"; 2317 } 2318 if ($strong_proto_keywords{$name} 2319 || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/ 2320 && !defined eval{prototype "CORE::$name"}) 2321 ) { return $name } 2322 if ( 2323 exists $self->{subs_declared}{$name} 2324 or 2325 exists &{"$self->{curstash}::$name"} 2326 ) { 2327 return "CORE::$name" 2328 } 2329 return $name; 2330} 2331 2332sub baseop { 2333 my $self = shift; 2334 my($op, $cx, $name) = @_; 2335 return $self->keyword($name); 2336} 2337 2338sub pp_stub { "()" } 2339sub pp_wantarray { baseop(@_, "wantarray") } 2340sub pp_fork { baseop(@_, "fork") } 2341sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } 2342sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } 2343sub pp_time { maybe_targmy(@_, \&baseop, "time") } 2344sub pp_tms { baseop(@_, "times") } 2345sub pp_ghostent { baseop(@_, "gethostent") } 2346sub pp_gnetent { baseop(@_, "getnetent") } 2347sub pp_gprotoent { baseop(@_, "getprotoent") } 2348sub pp_gservent { baseop(@_, "getservent") } 2349sub pp_ehostent { baseop(@_, "endhostent") } 2350sub pp_enetent { baseop(@_, "endnetent") } 2351sub pp_eprotoent { baseop(@_, "endprotoent") } 2352sub pp_eservent { baseop(@_, "endservent") } 2353sub pp_gpwent { baseop(@_, "getpwent") } 2354sub pp_spwent { baseop(@_, "setpwent") } 2355sub pp_epwent { baseop(@_, "endpwent") } 2356sub pp_ggrent { baseop(@_, "getgrent") } 2357sub pp_sgrent { baseop(@_, "setgrent") } 2358sub pp_egrent { baseop(@_, "endgrent") } 2359sub pp_getlogin { baseop(@_, "getlogin") } 2360 2361sub POSTFIX () { 1 } 2362 2363# I couldn't think of a good short name, but this is the category of 2364# symbolic unary operators with interesting precedence 2365 2366sub pfixop { 2367 my $self = shift; 2368 my($op, $cx, $name, $prec, $flags) = (@_, 0); 2369 my $kid = $op->first; 2370 $kid = $self->deparse($kid, $prec); 2371 return $self->maybe_parens(($flags & POSTFIX) 2372 ? "$kid$name" 2373 # avoid confusion with filetests 2374 : $name eq '-' 2375 && $kid =~ /^[a-zA-Z](?!\w)/ 2376 ? "$name($kid)" 2377 : "$name$kid", 2378 $cx, $prec); 2379} 2380 2381sub pp_preinc { pfixop(@_, "++", 23) } 2382sub pp_predec { pfixop(@_, "--", 23) } 2383sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 2384sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 2385sub pp_i_preinc { pfixop(@_, "++", 23) } 2386sub pp_i_predec { pfixop(@_, "--", 23) } 2387sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } 2388sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } 2389sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } 2390*pp_ncomplement = *pp_complement; 2391sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) } 2392 2393sub pp_negate { maybe_targmy(@_, \&real_negate) } 2394sub real_negate { 2395 my $self = shift; 2396 my($op, $cx) = @_; 2397 if ($op->first->name =~ /^(i_)?negate$/) { 2398 # avoid --$x 2399 $self->pfixop($op, $cx, "-", 21.5); 2400 } else { 2401 $self->pfixop($op, $cx, "-", 21); 2402 } 2403} 2404sub pp_i_negate { pp_negate(@_) } 2405 2406sub pp_not { 2407 my $self = shift; 2408 my($op, $cx) = @_; 2409 if ($cx <= 4) { 2410 $self->listop($op, $cx, "not", $op->first); 2411 } else { 2412 $self->pfixop($op, $cx, "!", 21); 2413 } 2414} 2415 2416sub unop { 2417 my $self = shift; 2418 my($op, $cx, $name, $nollafr) = @_; 2419 my $kid; 2420 if ($op->flags & OPf_KIDS) { 2421 $kid = $op->first; 2422 if (not $name) { 2423 # this deals with 'boolkeys' right now 2424 return $self->deparse($kid,$cx); 2425 } 2426 my $builtinname = $name; 2427 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name"; 2428 if (defined prototype($builtinname) 2429 && $builtinname ne 'CORE::readline' 2430 && prototype($builtinname) =~ /^;?\*/ 2431 && $kid->name eq "rv2gv") { 2432 $kid = $kid->first; 2433 } 2434 2435 if ($nollafr) { 2436 if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) { 2437 # require foo() is a syntax error. 2438 $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; 2439 } 2440 return $self->maybe_parens( 2441 $self->keyword($name) . " $kid", $cx, 16 2442 ); 2443 } 2444 return $self->maybe_parens_unop($name, $kid, $cx); 2445 } else { 2446 return $self->maybe_parens( 2447 $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""), 2448 $cx, 16, 2449 ); 2450 } 2451} 2452 2453sub pp_chop { maybe_targmy(@_, \&unop, "chop") } 2454sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } 2455sub pp_schop { maybe_targmy(@_, \&unop, "chop") } 2456sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } 2457sub pp_defined { unop(@_, "defined") } 2458sub pp_undef { unop(@_, "undef") } 2459sub pp_study { unop(@_, "study") } 2460sub pp_ref { unop(@_, "ref") } 2461sub pp_pos { maybe_local(@_, unop(@_, "pos")) } 2462 2463sub pp_sin { maybe_targmy(@_, \&unop, "sin") } 2464sub pp_cos { maybe_targmy(@_, \&unop, "cos") } 2465sub pp_rand { maybe_targmy(@_, \&unop, "rand") } 2466sub pp_srand { unop(@_, "srand") } 2467sub pp_exp { maybe_targmy(@_, \&unop, "exp") } 2468sub pp_log { maybe_targmy(@_, \&unop, "log") } 2469sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } 2470sub pp_int { maybe_targmy(@_, \&unop, "int") } 2471sub pp_hex { maybe_targmy(@_, \&unop, "hex") } 2472sub pp_oct { maybe_targmy(@_, \&unop, "oct") } 2473sub pp_abs { maybe_targmy(@_, \&unop, "abs") } 2474 2475sub pp_length { maybe_targmy(@_, \&unop, "length") } 2476sub pp_ord { maybe_targmy(@_, \&unop, "ord") } 2477sub pp_chr { maybe_targmy(@_, \&unop, "chr") } 2478 2479sub pp_each { unop(@_, "each") } 2480sub pp_values { unop(@_, "values") } 2481sub pp_keys { unop(@_, "keys") } 2482{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; } 2483sub pp_boolkeys { 2484 # no name because its an optimisation op that has no keyword 2485 unop(@_,""); 2486} 2487sub pp_aeach { unop(@_, "each") } 2488sub pp_avalues { unop(@_, "values") } 2489sub pp_akeys { unop(@_, "keys") } 2490sub pp_pop { unop(@_, "pop") } 2491sub pp_shift { unop(@_, "shift") } 2492 2493sub pp_caller { unop(@_, "caller") } 2494sub pp_reset { unop(@_, "reset") } 2495sub pp_exit { unop(@_, "exit") } 2496sub pp_prototype { unop(@_, "prototype") } 2497 2498sub pp_close { unop(@_, "close") } 2499sub pp_fileno { unop(@_, "fileno") } 2500sub pp_umask { unop(@_, "umask") } 2501sub pp_untie { unop(@_, "untie") } 2502sub pp_tied { unop(@_, "tied") } 2503sub pp_dbmclose { unop(@_, "dbmclose") } 2504sub pp_getc { unop(@_, "getc") } 2505sub pp_eof { unop(@_, "eof") } 2506sub pp_tell { unop(@_, "tell") } 2507sub pp_getsockname { unop(@_, "getsockname") } 2508sub pp_getpeername { unop(@_, "getpeername") } 2509 2510sub pp_chdir { 2511 my ($self, $op, $cx) = @_; 2512 if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) { 2513 my $kw = $self->keyword("chdir"); 2514 my $kid = $self->const_sv($op->first)->PV; 2515 my $code = $kw 2516 . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid"); 2517 maybe_targmy(@_, sub { $_[3] }, $code); 2518 } else { 2519 maybe_targmy(@_, \&unop, "chdir") 2520 } 2521} 2522 2523sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } 2524sub pp_readlink { unop(@_, "readlink") } 2525sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } 2526sub pp_readdir { unop(@_, "readdir") } 2527sub pp_telldir { unop(@_, "telldir") } 2528sub pp_rewinddir { unop(@_, "rewinddir") } 2529sub pp_closedir { unop(@_, "closedir") } 2530sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } 2531sub pp_localtime { unop(@_, "localtime") } 2532sub pp_gmtime { unop(@_, "gmtime") } 2533sub pp_alarm { unop(@_, "alarm") } 2534sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } 2535 2536sub pp_dofile { 2537 my $code = unop(@_, "do", 1); # llafr does not apply 2538 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' } 2539 $code; 2540} 2541sub pp_entereval { 2542 unop( 2543 @_, 2544 $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval" 2545 ) 2546} 2547 2548sub pp_ghbyname { unop(@_, "gethostbyname") } 2549sub pp_gnbyname { unop(@_, "getnetbyname") } 2550sub pp_gpbyname { unop(@_, "getprotobyname") } 2551sub pp_shostent { unop(@_, "sethostent") } 2552sub pp_snetent { unop(@_, "setnetent") } 2553sub pp_sprotoent { unop(@_, "setprotoent") } 2554sub pp_sservent { unop(@_, "setservent") } 2555sub pp_gpwnam { unop(@_, "getpwnam") } 2556sub pp_gpwuid { unop(@_, "getpwuid") } 2557sub pp_ggrnam { unop(@_, "getgrnam") } 2558sub pp_ggrgid { unop(@_, "getgrgid") } 2559 2560sub pp_lock { unop(@_, "lock") } 2561 2562sub pp_continue { unop(@_, "continue"); } 2563sub pp_break { unop(@_, "break"); } 2564 2565sub givwhen { 2566 my $self = shift; 2567 my($op, $cx, $givwhen) = @_; 2568 2569 my $enterop = $op->first; 2570 my ($head, $block); 2571 if ($enterop->flags & OPf_SPECIAL) { 2572 $head = $self->keyword("default"); 2573 $block = $self->deparse($enterop->first, 0); 2574 } 2575 else { 2576 my $cond = $enterop->first; 2577 my $cond_str = $self->deparse($cond, 1); 2578 $head = "$givwhen ($cond_str)"; 2579 $block = $self->deparse($cond->sibling, 0); 2580 } 2581 2582 return "$head {\n". 2583 "\t$block\n". 2584 "\b}\cK"; 2585} 2586 2587sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); } 2588sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); } 2589 2590sub pp_exists { 2591 my $self = shift; 2592 my($op, $cx) = @_; 2593 my $arg; 2594 my $name = $self->keyword("exists"); 2595 if ($op->private & OPpEXISTS_SUB) { 2596 # Checking for the existence of a subroutine 2597 return $self->maybe_parens_func($name, 2598 $self->pp_rv2cv($op->first, 16), $cx, 16); 2599 } 2600 if ($op->flags & OPf_SPECIAL) { 2601 # Array element, not hash element 2602 return $self->maybe_parens_func($name, 2603 $self->pp_aelem($op->first, 16), $cx, 16); 2604 } 2605 return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16), 2606 $cx, 16); 2607} 2608 2609sub pp_delete { 2610 my $self = shift; 2611 my($op, $cx) = @_; 2612 my $arg; 2613 my $name = $self->keyword("delete"); 2614 if ($op->private & (OPpSLICE|OPpKVSLICE)) { 2615 if ($op->flags & OPf_SPECIAL) { 2616 # Deleting from an array, not a hash 2617 return $self->maybe_parens_func($name, 2618 $self->pp_aslice($op->first, 16), 2619 $cx, 16); 2620 } 2621 return $self->maybe_parens_func($name, 2622 $self->pp_hslice($op->first, 16), 2623 $cx, 16); 2624 } else { 2625 if ($op->flags & OPf_SPECIAL) { 2626 # Deleting from an array, not a hash 2627 return $self->maybe_parens_func($name, 2628 $self->pp_aelem($op->first, 16), 2629 $cx, 16); 2630 } 2631 return $self->maybe_parens_func($name, 2632 $self->pp_helem($op->first, 16), 2633 $cx, 16); 2634 } 2635} 2636 2637sub pp_require { 2638 my $self = shift; 2639 my($op, $cx) = @_; 2640 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; 2641 my $kid = $op->first; 2642 if ($kid->name eq 'const') { 2643 my $priv = $kid->private; 2644 my $sv = $self->const_sv($kid); 2645 my $arg; 2646 if ($priv & OPpCONST_BARE) { 2647 $arg = $sv->PV; 2648 $arg =~ s[/][::]g; 2649 $arg =~ s/\.pm//g; 2650 } elsif ($priv & OPpCONST_NOVER) { 2651 $opname = $self->keyword('no'); 2652 $arg = $self->const($sv, 16); 2653 } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) { 2654 $arg = $tmp; 2655 } 2656 if ($arg) { 2657 return $self->maybe_parens("$opname $arg", $cx, 16); 2658 } 2659 } 2660 $self->unop( 2661 $op, $cx, 2662 $opname, 2663 1, # llafr does not apply 2664 ); 2665} 2666 2667sub pp_scalar { 2668 my $self = shift; 2669 my($op, $cx) = @_; 2670 my $kid = $op->first; 2671 if (not null $kid->sibling) { 2672 # XXX Was a here-doc 2673 return $self->dquote($op); 2674 } 2675 $self->unop(@_, "scalar"); 2676} 2677 2678 2679sub padval { 2680 my $self = shift; 2681 my $targ = shift; 2682 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); 2683} 2684 2685sub anon_hash_or_list { 2686 my $self = shift; 2687 my($op, $cx) = @_; 2688 2689 my($pre, $post) = @{{"anonlist" => ["[","]"], 2690 "anonhash" => ["{","}"]}->{$op->name}}; 2691 my($expr, @exprs); 2692 $op = $op->first->sibling; # skip pushmark 2693 for (; !null($op); $op = $op->sibling) { 2694 $expr = $self->deparse($op, 6); 2695 push @exprs, $expr; 2696 } 2697 if ($pre eq "{" and $cx < 1) { 2698 # Disambiguate that it's not a block 2699 $pre = "+{"; 2700 } 2701 return $pre . join(", ", @exprs) . $post; 2702} 2703 2704sub pp_anonlist { 2705 my $self = shift; 2706 my ($op, $cx) = @_; 2707 if ($op->flags & OPf_SPECIAL) { 2708 return $self->anon_hash_or_list($op, $cx); 2709 } 2710 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL"; 2711 return 'XXX'; 2712} 2713 2714*pp_anonhash = \&pp_anonlist; 2715 2716sub pp_refgen { 2717 my $self = shift; 2718 my($op, $cx) = @_; 2719 my $kid = $op->first; 2720 if ($kid->name eq "null") { 2721 my $anoncode = $kid = $kid->first; 2722 if ($anoncode->name eq "anonconst") { 2723 $anoncode = $anoncode->first->first->sibling; 2724 } 2725 if ($anoncode->name eq "anoncode" 2726 or !null($anoncode = $kid->sibling) and 2727 $anoncode->name eq "anoncode") { 2728 return $self->e_anoncode({ code => $self->padval($anoncode->targ) }); 2729 } elsif ($kid->name eq "pushmark") { 2730 my $sib_name = $kid->sibling->name; 2731 if ($sib_name eq 'entersub') { 2732 my $text = $self->deparse($kid->sibling, 1); 2733 # Always show parens for \(&func()), but only with -p otherwise 2734 $text = "($text)" if $self->{'parens'} 2735 or $kid->sibling->private & OPpENTERSUB_AMPER; 2736 return "\\$text"; 2737 } 2738 } 2739 } 2740 local $self->{'in_refgen'} = 1; 2741 $self->pfixop($op, $cx, "\\", 20); 2742} 2743 2744sub e_anoncode { 2745 my ($self, $info) = @_; 2746 my $text = $self->deparse_sub($info->{code}); 2747 return $self->keyword("sub") . " $text"; 2748} 2749 2750sub pp_srefgen { pp_refgen(@_) } 2751 2752sub pp_readline { 2753 my $self = shift; 2754 my($op, $cx) = @_; 2755 my $kid = $op->first; 2756 if (is_scalar($kid) 2757 and $op->flags & OPf_SPECIAL 2758 and $self->deparse($kid, 1) eq 'ARGV') 2759 { 2760 return '<<>>'; 2761 } 2762 return $self->unop($op, $cx, "readline"); 2763} 2764 2765sub pp_rcatline { 2766 my $self = shift; 2767 my($op) = @_; 2768 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; 2769} 2770 2771# Unary operators that can occur as pseudo-listops inside double quotes 2772sub dq_unop { 2773 my $self = shift; 2774 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); 2775 my $kid; 2776 if ($op->flags & OPf_KIDS) { 2777 $kid = $op->first; 2778 # If there's more than one kid, the first is an ex-pushmark. 2779 $kid = $kid->sibling if not null $kid->sibling; 2780 return $self->maybe_parens_unop($name, $kid, $cx); 2781 } else { 2782 return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); 2783 } 2784} 2785 2786sub pp_ucfirst { dq_unop(@_, "ucfirst") } 2787sub pp_lcfirst { dq_unop(@_, "lcfirst") } 2788sub pp_uc { dq_unop(@_, "uc") } 2789sub pp_lc { dq_unop(@_, "lc") } 2790sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } 2791sub pp_fc { dq_unop(@_, "fc") } 2792 2793sub loopex { 2794 my $self = shift; 2795 my ($op, $cx, $name) = @_; 2796 if (class($op) eq "PVOP") { 2797 $name .= " " . $op->pv; 2798 } elsif (class($op) eq "OP") { 2799 # no-op 2800 } elsif (class($op) eq "UNOP") { 2801 (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//; 2802 # last foo() is a syntax error. 2803 $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; 2804 $name .= " $kid"; 2805 } 2806 return $self->maybe_parens($name, $cx, 7); 2807} 2808 2809sub pp_last { loopex(@_, "last") } 2810sub pp_next { loopex(@_, "next") } 2811sub pp_redo { loopex(@_, "redo") } 2812sub pp_goto { loopex(@_, "goto") } 2813sub pp_dump { loopex(@_, "CORE::dump") } 2814 2815sub ftst { 2816 my $self = shift; 2817 my($op, $cx, $name) = @_; 2818 if (class($op) eq "UNOP") { 2819 # Genuine '-X' filetests are exempt from the LLAFR, but not 2820 # l?stat() 2821 if ($name =~ /^-/) { 2822 (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//; 2823 return $self->maybe_parens("$name $kid", $cx, 16); 2824 } 2825 return $self->maybe_parens_unop($name, $op->first, $cx); 2826 } elsif (class($op) =~ /^(SV|PAD)OP$/) { 2827 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); 2828 } else { # I don't think baseop filetests ever survive ck_ftst, but... 2829 return $name; 2830 } 2831} 2832 2833sub pp_lstat { ftst(@_, "lstat") } 2834sub pp_stat { ftst(@_, "stat") } 2835sub pp_ftrread { ftst(@_, "-R") } 2836sub pp_ftrwrite { ftst(@_, "-W") } 2837sub pp_ftrexec { ftst(@_, "-X") } 2838sub pp_fteread { ftst(@_, "-r") } 2839sub pp_ftewrite { ftst(@_, "-w") } 2840sub pp_fteexec { ftst(@_, "-x") } 2841sub pp_ftis { ftst(@_, "-e") } 2842sub pp_fteowned { ftst(@_, "-O") } 2843sub pp_ftrowned { ftst(@_, "-o") } 2844sub pp_ftzero { ftst(@_, "-z") } 2845sub pp_ftsize { ftst(@_, "-s") } 2846sub pp_ftmtime { ftst(@_, "-M") } 2847sub pp_ftatime { ftst(@_, "-A") } 2848sub pp_ftctime { ftst(@_, "-C") } 2849sub pp_ftsock { ftst(@_, "-S") } 2850sub pp_ftchr { ftst(@_, "-c") } 2851sub pp_ftblk { ftst(@_, "-b") } 2852sub pp_ftfile { ftst(@_, "-f") } 2853sub pp_ftdir { ftst(@_, "-d") } 2854sub pp_ftpipe { ftst(@_, "-p") } 2855sub pp_ftlink { ftst(@_, "-l") } 2856sub pp_ftsuid { ftst(@_, "-u") } 2857sub pp_ftsgid { ftst(@_, "-g") } 2858sub pp_ftsvtx { ftst(@_, "-k") } 2859sub pp_fttty { ftst(@_, "-t") } 2860sub pp_fttext { ftst(@_, "-T") } 2861sub pp_ftbinary { ftst(@_, "-B") } 2862 2863sub SWAP_CHILDREN () { 1 } 2864sub ASSIGN () { 2 } # has OP= variant 2865sub LIST_CONTEXT () { 4 } # Assignment is in list context 2866 2867my(%left, %right); 2868 2869sub assoc_class { 2870 my $op = shift; 2871 my $name = $op->name; 2872 if ($name eq "concat" and $op->first->name eq "concat") { 2873 # avoid spurious '=' -- see comment in pp_concat 2874 return "concat"; 2875 } 2876 if ($name eq "null" and class($op) eq "UNOP" 2877 and $op->first->name =~ /^(and|x?or)$/ 2878 and null $op->first->sibling) 2879 { 2880 # Like all conditional constructs, OP_ANDs and OP_ORs are topped 2881 # with a null that's used as the common end point of the two 2882 # flows of control. For precedence purposes, ignore it. 2883 # (COND_EXPRs have these too, but we don't bother with 2884 # their associativity). 2885 return assoc_class($op->first); 2886 } 2887 return $name . ($op->flags & OPf_STACKED ? "=" : ""); 2888} 2889 2890# Left associative operators, like '+', for which 2891# $a + $b + $c is equivalent to ($a + $b) + $c 2892 2893BEGIN { 2894 %left = ('multiply' => 19, 'i_multiply' => 19, 2895 'divide' => 19, 'i_divide' => 19, 2896 'modulo' => 19, 'i_modulo' => 19, 2897 'repeat' => 19, 2898 'add' => 18, 'i_add' => 18, 2899 'subtract' => 18, 'i_subtract' => 18, 2900 'concat' => 18, 2901 'left_shift' => 17, 'right_shift' => 17, 2902 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13, 2903 'bit_or' => 12, 'bit_xor' => 12, 2904 'sbit_or' => 12, 'sbit_xor' => 12, 2905 'nbit_or' => 12, 'nbit_xor' => 12, 2906 'and' => 3, 2907 'or' => 2, 'xor' => 2, 2908 ); 2909} 2910 2911sub deparse_binop_left { 2912 my $self = shift; 2913 my($op, $left, $prec) = @_; 2914 if ($left{assoc_class($op)} && $left{assoc_class($left)} 2915 and $left{assoc_class($op)} == $left{assoc_class($left)}) 2916 { 2917 return $self->deparse($left, $prec - .00001); 2918 } else { 2919 return $self->deparse($left, $prec); 2920 } 2921} 2922 2923# Right associative operators, like '=', for which 2924# $a = $b = $c is equivalent to $a = ($b = $c) 2925 2926BEGIN { 2927 %right = ('pow' => 22, 2928 'sassign=' => 7, 'aassign=' => 7, 2929 'multiply=' => 7, 'i_multiply=' => 7, 2930 'divide=' => 7, 'i_divide=' => 7, 2931 'modulo=' => 7, 'i_modulo=' => 7, 2932 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7, 2933 'add=' => 7, 'i_add=' => 7, 2934 'subtract=' => 7, 'i_subtract=' => 7, 2935 'concat=' => 7, 2936 'left_shift=' => 7, 'right_shift=' => 7, 2937 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7, 2938 'nbit_or=' => 7, 'nbit_xor=' => 7, 2939 'sbit_or=' => 7, 'sbit_xor=' => 7, 2940 'andassign' => 7, 2941 'orassign' => 7, 2942 ); 2943} 2944 2945sub deparse_binop_right { 2946 my $self = shift; 2947 my($op, $right, $prec) = @_; 2948 if ($right{assoc_class($op)} && $right{assoc_class($right)} 2949 and $right{assoc_class($op)} == $right{assoc_class($right)}) 2950 { 2951 return $self->deparse($right, $prec - .00001); 2952 } else { 2953 return $self->deparse($right, $prec); 2954 } 2955} 2956 2957sub binop { 2958 my $self = shift; 2959 my ($op, $cx, $opname, $prec, $flags) = (@_, 0); 2960 my $left = $op->first; 2961 my $right = $op->last; 2962 my $eq = ""; 2963 if ($op->flags & OPf_STACKED && $flags & ASSIGN) { 2964 $eq = "="; 2965 $prec = 7; 2966 } 2967 if ($flags & SWAP_CHILDREN) { 2968 ($left, $right) = ($right, $left); 2969 } 2970 my $leftop = $left; 2971 $left = $self->deparse_binop_left($op, $left, $prec); 2972 $left = "($left)" if $flags & LIST_CONTEXT 2973 and $left !~ /^(my|our|local|state|)\s*[\@%\(]/ 2974 || do { 2975 # Parenthesize if the left argument is a 2976 # lone repeat op. 2977 my $left = $leftop->first->sibling; 2978 $left->name eq 'repeat' 2979 && null($left->sibling); 2980 }; 2981 $right = $self->deparse_binop_right($op, $right, $prec); 2982 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); 2983} 2984 2985sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 2986sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 2987sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } 2988sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 2989sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 2990sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } 2991sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } 2992sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } 2993sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } 2994sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } 2995sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } 2996 2997sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } 2998sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } 2999sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } 3000sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } 3001sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } 3002*pp_nbit_and = *pp_bit_and; 3003*pp_nbit_or = *pp_bit_or; 3004*pp_nbit_xor = *pp_bit_xor; 3005sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) } 3006sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) } 3007sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) } 3008 3009sub pp_eq { binop(@_, "==", 14) } 3010sub pp_ne { binop(@_, "!=", 14) } 3011sub pp_lt { binop(@_, "<", 15) } 3012sub pp_gt { binop(@_, ">", 15) } 3013sub pp_ge { binop(@_, ">=", 15) } 3014sub pp_le { binop(@_, "<=", 15) } 3015sub pp_ncmp { binop(@_, "<=>", 14) } 3016sub pp_i_eq { binop(@_, "==", 14) } 3017sub pp_i_ne { binop(@_, "!=", 14) } 3018sub pp_i_lt { binop(@_, "<", 15) } 3019sub pp_i_gt { binop(@_, ">", 15) } 3020sub pp_i_ge { binop(@_, ">=", 15) } 3021sub pp_i_le { binop(@_, "<=", 15) } 3022sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) } 3023 3024sub pp_seq { binop(@_, "eq", 14) } 3025sub pp_sne { binop(@_, "ne", 14) } 3026sub pp_slt { binop(@_, "lt", 15) } 3027sub pp_sgt { binop(@_, "gt", 15) } 3028sub pp_sge { binop(@_, "ge", 15) } 3029sub pp_sle { binop(@_, "le", 15) } 3030sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) } 3031 3032sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } 3033sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } 3034 3035sub pp_smartmatch { 3036 my ($self, $op, $cx) = @_; 3037 if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) { 3038 return $self->deparse($op->last, $cx); 3039 } 3040 else { 3041 binop(@_, "~~", 14); 3042 } 3043} 3044 3045# '.' is special because concats-of-concats are optimized to save copying 3046# by making all but the first concat stacked. The effect is as if the 3047# programmer had written '($a . $b) .= $c', except legal. 3048sub pp_concat { maybe_targmy(@_, \&real_concat) } 3049sub real_concat { 3050 my $self = shift; 3051 my($op, $cx) = @_; 3052 my $left = $op->first; 3053 my $right = $op->last; 3054 my $eq = ""; 3055 my $prec = 18; 3056 if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) { 3057 # '.=' rather than optimised '.' 3058 $eq = "="; 3059 $prec = 7; 3060 } 3061 $left = $self->deparse_binop_left($op, $left, $prec); 3062 $right = $self->deparse_binop_right($op, $right, $prec); 3063 return $self->maybe_parens("$left .$eq $right", $cx, $prec); 3064} 3065 3066sub pp_repeat { maybe_targmy(@_, \&repeat) } 3067 3068# 'x' is weird when the left arg is a list 3069sub repeat { 3070 my $self = shift; 3071 my($op, $cx) = @_; 3072 my $left = $op->first; 3073 my $right = $op->last; 3074 my $eq = ""; 3075 my $prec = 19; 3076 if ($op->flags & OPf_STACKED) { 3077 $eq = "="; 3078 $prec = 7; 3079 } 3080 if (null($right)) { # list repeat; count is inside left-side ex-list 3081 # in 5.21.5 and earlier 3082 my $kid = $left->first->sibling; # skip pushmark 3083 my @exprs; 3084 for (; !null($kid->sibling); $kid = $kid->sibling) { 3085 push @exprs, $self->deparse($kid, 6); 3086 } 3087 $right = $kid; 3088 $left = "(" . join(", ", @exprs). ")"; 3089 } else { 3090 my $dolist = $op->private & OPpREPEAT_DOLIST; 3091 $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec); 3092 if ($dolist) { 3093 $left = "($left)"; 3094 } 3095 } 3096 $right = $self->deparse_binop_right($op, $right, $prec); 3097 return $self->maybe_parens("$left x$eq $right", $cx, $prec); 3098} 3099 3100sub range { 3101 my $self = shift; 3102 my ($op, $cx, $type) = @_; 3103 my $left = $op->first; 3104 my $right = $left->sibling; 3105 $left = $self->deparse($left, 9); 3106 $right = $self->deparse($right, 9); 3107 return $self->maybe_parens("$left $type $right", $cx, 9); 3108} 3109 3110sub pp_flop { 3111 my $self = shift; 3112 my($op, $cx) = @_; 3113 my $flip = $op->first; 3114 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; 3115 return $self->range($flip->first, $cx, $type); 3116} 3117 3118# one-line while/until is handled in pp_leave 3119 3120sub logop { 3121 my $self = shift; 3122 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; 3123 my $left = $op->first; 3124 my $right = $op->first->sibling; 3125 $blockname &&= $self->keyword($blockname); 3126 if ($cx < 1 and is_scope($right) and $blockname 3127 and $self->{'expand'} < 7) 3128 { # if ($a) {$b} 3129 $left = $self->deparse($left, 1); 3130 $right = $self->deparse($right, 0); 3131 return "$blockname ($left) {\n\t$right\n\b}\cK"; 3132 } elsif ($cx < 1 and $blockname and not $self->{'parens'} 3133 and $self->{'expand'} < 7) { # $b if $a 3134 $right = $self->deparse($right, 1); 3135 $left = $self->deparse($left, 1); 3136 return "$right $blockname $left"; 3137 } elsif ($cx > $lowprec and $highop) { # $a && $b 3138 $left = $self->deparse_binop_left($op, $left, $highprec); 3139 $right = $self->deparse_binop_right($op, $right, $highprec); 3140 return $self->maybe_parens("$left $highop $right", $cx, $highprec); 3141 } else { # $a and $b 3142 $left = $self->deparse_binop_left($op, $left, $lowprec); 3143 $right = $self->deparse_binop_right($op, $right, $lowprec); 3144 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); 3145 } 3146} 3147 3148sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } 3149sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } 3150sub pp_dor { logop(@_, "//", 10) } 3151 3152# xor is syntactically a logop, but it's really a binop (contrary to 3153# old versions of opcode.pl). Syntax is what matters here. 3154sub pp_xor { logop(@_, "xor", 2, "", 0, "") } 3155 3156sub logassignop { 3157 my $self = shift; 3158 my ($op, $cx, $opname) = @_; 3159 my $left = $op->first; 3160 my $right = $op->first->sibling->first; # skip sassign 3161 $left = $self->deparse($left, 7); 3162 $right = $self->deparse($right, 7); 3163 return $self->maybe_parens("$left $opname $right", $cx, 7); 3164} 3165 3166sub pp_andassign { logassignop(@_, "&&=") } 3167sub pp_orassign { logassignop(@_, "||=") } 3168sub pp_dorassign { logassignop(@_, "//=") } 3169 3170sub rv2gv_or_string { 3171 my($self,$op) = @_; 3172 if ($op->name eq "gv") { # could be open("open") or open("###") 3173 my($name,$quoted) = 3174 $self->stash_variable_name("", $self->gv_or_padgv($op)); 3175 $quoted ? $name : "*$name"; 3176 } 3177 else { 3178 $self->deparse($op, 6); 3179 } 3180} 3181 3182sub listop { 3183 my $self = shift; 3184 my($op, $cx, $name, $kid, $nollafr) = @_; 3185 my(@exprs); 3186 my $parens = ($cx >= 5) || $self->{'parens'}; 3187 $kid ||= $op->first->sibling; 3188 # If there are no arguments, add final parentheses (or parenthesize the 3189 # whole thing if the llafr does not apply) to account for cases like 3190 # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a 3191 # precedence of 6 (< comma), as "return, 1" does not need parentheses. 3192 if (null $kid) { 3193 return $nollafr 3194 ? $self->maybe_parens($self->keyword($name), $cx, 7) 3195 : $self->keyword($name) . '()' x (7 < $cx); 3196 } 3197 my $first; 3198 my $fullname = $self->keyword($name); 3199 my $proto = prototype("CORE::$name"); 3200 if ( 3201 ( (defined $proto && $proto =~ /^;?\*/) 3202 || $name eq 'select' # select(F) doesn't have a proto 3203 ) 3204 && $kid->name eq "rv2gv" 3205 && !($kid->private & OPpLVAL_INTRO) 3206 ) { 3207 $first = $self->rv2gv_or_string($kid->first); 3208 } 3209 else { 3210 $first = $self->deparse($kid, 6); 3211 } 3212 if ($name eq "chmod" && $first =~ /^\d+$/) { 3213 $first = sprintf("%#o", $first); 3214 } 3215 $first = "+$first" 3216 if not $parens and not $nollafr and substr($first, 0, 1) eq "("; 3217 push @exprs, $first; 3218 $kid = $kid->sibling; 3219 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv" 3220 && !($kid->private & OPpLVAL_INTRO)) { 3221 push @exprs, $first = $self->rv2gv_or_string($kid->first); 3222 $kid = $kid->sibling; 3223 } 3224 for (; !null($kid); $kid = $kid->sibling) { 3225 push @exprs, $self->deparse($kid, 6); 3226 } 3227 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) { 3228 return "$exprs[0] = $fullname" 3229 . ($parens ? "($exprs[0])" : " $exprs[0]"); 3230 } 3231 3232 if ($parens && $nollafr) { 3233 return "($fullname " . join(", ", @exprs) . ")"; 3234 } elsif ($parens) { 3235 return "$fullname(" . join(", ", @exprs) . ")"; 3236 } else { 3237 return "$fullname " . join(", ", @exprs); 3238 } 3239} 3240 3241sub pp_bless { listop(@_, "bless") } 3242sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } 3243sub pp_substr { 3244 my ($self,$op,$cx) = @_; 3245 if ($op->private & OPpSUBSTR_REPL_FIRST) { 3246 return 3247 listop($self, $op, 7, "substr", $op->first->sibling->sibling) 3248 . " = " 3249 . $self->deparse($op->first->sibling, 7); 3250 } 3251 maybe_local(@_, listop(@_, "substr")) 3252} 3253 3254sub pp_index { 3255 # Also handles pp_rindex. 3256 # 3257 # The body of this function includes an unrolled maybe_targmy(), 3258 # since the two parts of that sub's actions need to have have the 3259 # '== -1' bit in between 3260 3261 my($self, $op, $cx) = @_; 3262 3263 my $lex = ($op->private & OPpTARGET_MY); 3264 my $bool = ($op->private & OPpTRUEBOOL); 3265 3266 my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name); 3267 3268 # (index() == -1) has op_eq and op_const optimised away 3269 if ($bool) { 3270 $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1"; 3271 $val = "($val)" if ($op->flags & OPf_PARENS); 3272 } 3273 if ($lex) { 3274 my $var = $self->padname($op->targ); 3275 $val = $self->maybe_parens("$var = $val", $cx, 7); 3276 } 3277 $val; 3278} 3279 3280sub pp_rindex { pp_index(@_); } 3281sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) } 3282sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } 3283sub pp_formline { listop(@_, "formline") } # see also deparse_format 3284sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } 3285sub pp_unpack { listop(@_, "unpack") } 3286sub pp_pack { listop(@_, "pack") } 3287sub pp_join { maybe_targmy(@_, \&listop, "join") } 3288sub pp_splice { listop(@_, "splice") } 3289sub pp_push { maybe_targmy(@_, \&listop, "push") } 3290sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } 3291sub pp_reverse { listop(@_, "reverse") } 3292sub pp_warn { listop(@_, "warn") } 3293sub pp_die { listop(@_, "die") } 3294sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply 3295sub pp_open { listop(@_, "open") } 3296sub pp_pipe_op { listop(@_, "pipe") } 3297sub pp_tie { listop(@_, "tie") } 3298sub pp_binmode { listop(@_, "binmode") } 3299sub pp_dbmopen { listop(@_, "dbmopen") } 3300sub pp_sselect { listop(@_, "select") } 3301sub pp_select { listop(@_, "select") } 3302sub pp_read { listop(@_, "read") } 3303sub pp_sysopen { listop(@_, "sysopen") } 3304sub pp_sysseek { listop(@_, "sysseek") } 3305sub pp_sysread { listop(@_, "sysread") } 3306sub pp_syswrite { listop(@_, "syswrite") } 3307sub pp_send { listop(@_, "send") } 3308sub pp_recv { listop(@_, "recv") } 3309sub pp_seek { listop(@_, "seek") } 3310sub pp_fcntl { listop(@_, "fcntl") } 3311sub pp_ioctl { listop(@_, "ioctl") } 3312sub pp_flock { maybe_targmy(@_, \&listop, "flock") } 3313sub pp_socket { listop(@_, "socket") } 3314sub pp_sockpair { listop(@_, "socketpair") } 3315sub pp_bind { listop(@_, "bind") } 3316sub pp_connect { listop(@_, "connect") } 3317sub pp_listen { listop(@_, "listen") } 3318sub pp_accept { listop(@_, "accept") } 3319sub pp_shutdown { listop(@_, "shutdown") } 3320sub pp_gsockopt { listop(@_, "getsockopt") } 3321sub pp_ssockopt { listop(@_, "setsockopt") } 3322sub pp_chown { maybe_targmy(@_, \&listop, "chown") } 3323sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } 3324sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } 3325sub pp_utime { maybe_targmy(@_, \&listop, "utime") } 3326sub pp_rename { maybe_targmy(@_, \&listop, "rename") } 3327sub pp_link { maybe_targmy(@_, \&listop, "link") } 3328sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } 3329sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } 3330sub pp_open_dir { listop(@_, "opendir") } 3331sub pp_seekdir { listop(@_, "seekdir") } 3332sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } 3333sub pp_system { maybe_targmy(@_, \&indirop, "system") } 3334sub pp_exec { maybe_targmy(@_, \&indirop, "exec") } 3335sub pp_kill { maybe_targmy(@_, \&listop, "kill") } 3336sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } 3337sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } 3338sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } 3339sub pp_shmget { listop(@_, "shmget") } 3340sub pp_shmctl { listop(@_, "shmctl") } 3341sub pp_shmread { listop(@_, "shmread") } 3342sub pp_shmwrite { listop(@_, "shmwrite") } 3343sub pp_msgget { listop(@_, "msgget") } 3344sub pp_msgctl { listop(@_, "msgctl") } 3345sub pp_msgsnd { listop(@_, "msgsnd") } 3346sub pp_msgrcv { listop(@_, "msgrcv") } 3347sub pp_semget { listop(@_, "semget") } 3348sub pp_semctl { listop(@_, "semctl") } 3349sub pp_semop { listop(@_, "semop") } 3350sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } 3351sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } 3352sub pp_gpbynumber { listop(@_, "getprotobynumber") } 3353sub pp_gsbyname { listop(@_, "getservbyname") } 3354sub pp_gsbyport { listop(@_, "getservbyport") } 3355sub pp_syscall { listop(@_, "syscall") } 3356 3357sub pp_glob { 3358 my $self = shift; 3359 my($op, $cx) = @_; 3360 my $kid = $op->first->sibling; # skip pushmark 3361 my $keyword = 3362 $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob'); 3363 my $text = $self->deparse($kid); 3364 return $cx >= 5 || $self->{'parens'} 3365 ? "$keyword($text)" 3366 : "$keyword $text"; 3367} 3368 3369# Truncate is special because OPf_SPECIAL makes a bareword first arg 3370# be a filehandle. This could probably be better fixed in the core 3371# by moving the GV lookup into ck_truc. 3372 3373sub pp_truncate { 3374 my $self = shift; 3375 my($op, $cx) = @_; 3376 my(@exprs); 3377 my $parens = ($cx >= 5) || $self->{'parens'}; 3378 my $kid = $op->first->sibling; 3379 my $fh; 3380 if ($op->flags & OPf_SPECIAL) { 3381 # $kid is an OP_CONST 3382 $fh = $self->const_sv($kid)->PV; 3383 } else { 3384 $fh = $self->deparse($kid, 6); 3385 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; 3386 } 3387 my $len = $self->deparse($kid->sibling, 6); 3388 my $name = $self->keyword('truncate'); 3389 if ($parens) { 3390 return "$name($fh, $len)"; 3391 } else { 3392 return "$name $fh, $len"; 3393 } 3394} 3395 3396sub indirop { 3397 my $self = shift; 3398 my($op, $cx, $name) = @_; 3399 my($expr, @exprs); 3400 my $firstkid = my $kid = $op->first->sibling; 3401 my $indir = ""; 3402 if ($op->flags & OPf_STACKED) { 3403 $indir = $kid; 3404 $indir = $indir->first; # skip rv2gv 3405 if (is_scope($indir)) { 3406 $indir = "{" . $self->deparse($indir, 0) . "}"; 3407 $indir = "{;}" if $indir eq "{}"; 3408 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { 3409 $indir = $self->const_sv($indir)->PV; 3410 } else { 3411 $indir = $self->deparse($indir, 24); 3412 } 3413 $indir = $indir . " "; 3414 $kid = $kid->sibling; 3415 } 3416 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { 3417 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' 3418 : '{$a <=> $b} '; 3419 } 3420 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { 3421 $indir = '{$b cmp $a} '; 3422 } 3423 for (; !null($kid); $kid = $kid->sibling) { 3424 $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6); 3425 push @exprs, $expr; 3426 } 3427 my $name2; 3428 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { 3429 $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort'); 3430 } 3431 else { $name2 = $self->keyword($name) } 3432 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { 3433 return "$exprs[0] = $name2 $indir $exprs[0]"; 3434 } 3435 3436 my $args = $indir . join(", ", @exprs); 3437 if ($indir ne "" && $name eq "sort") { 3438 # We don't want to say "sort(f 1, 2, 3)", since perl -w will 3439 # give bareword warnings in that case. Therefore if context 3440 # requires, we'll put parens around the outside "(sort f 1, 2, 3441 # 3)". Unfortunately, we'll currently think the parens are 3442 # necessary more often that they really are, because we don't 3443 # distinguish which side of an assignment we're on. 3444 if ($cx >= 5) { 3445 return "($name2 $args)"; 3446 } else { 3447 return "$name2 $args"; 3448 } 3449 } elsif ( 3450 !$indir && $name eq "sort" 3451 && !null($op->first->sibling) 3452 && $op->first->sibling->name eq 'entersub' 3453 ) { 3454 # We cannot say sort foo(bar), as foo will be interpreted as a 3455 # comparison routine. We have to say sort(...) in that case. 3456 return "$name2($args)"; 3457 } else { 3458 return length $args 3459 ? $self->maybe_parens_func($name2, $args, $cx, 5) 3460 : $name2 . '()' x (7 < $cx); 3461 } 3462 3463} 3464 3465sub pp_prtf { indirop(@_, "printf") } 3466sub pp_print { indirop(@_, "print") } 3467sub pp_say { indirop(@_, "say") } 3468sub pp_sort { indirop(@_, "sort") } 3469 3470sub mapop { 3471 my $self = shift; 3472 my($op, $cx, $name) = @_; 3473 my($expr, @exprs); 3474 my $kid = $op->first; # this is the (map|grep)start 3475 $kid = $kid->first->sibling; # skip a pushmark 3476 my $code = $kid->first; # skip a null 3477 if (is_scope $code) { 3478 $code = "{" . $self->deparse($code, 0) . "} "; 3479 } else { 3480 $code = $self->deparse($code, 24); 3481 $code .= ", " if !null($kid->sibling); 3482 } 3483 $kid = $kid->sibling; 3484 for (; !null($kid); $kid = $kid->sibling) { 3485 $expr = $self->deparse($kid, 6); 3486 push @exprs, $expr if defined $expr; 3487 } 3488 return $self->maybe_parens_func($self->keyword($name), 3489 $code . join(", ", @exprs), $cx, 5); 3490} 3491 3492sub pp_mapwhile { mapop(@_, "map") } 3493sub pp_grepwhile { mapop(@_, "grep") } 3494sub pp_mapstart { baseop(@_, "map") } 3495sub pp_grepstart { baseop(@_, "grep") } 3496 3497my %uses_intro; 3498BEGIN { 3499 @uses_intro{ 3500 eval { require B::Op_private } 3501 ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}} 3502 : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice 3503 hslice delete padsv padav padhv enteriter entersub padrange 3504 pushmark cond_expr refassign list) 3505 } = (); 3506 delete @uses_intro{qw( lvref lvrefslice lvavref entersub )}; 3507} 3508 3509 3510# Look for a my/state attribute declaration in a list or ex-list. 3511# Returns undef if not found, 'my($x, @a) :Foo(bar)' etc otherwise. 3512# 3513# There are three basic tree structs that are expected: 3514# 3515# my $x :foo; 3516# <1> ex-list vK/LVINTRO ->c 3517# <0> ex-pushmark v ->3 3518# <1> entersub[t2] vKRS*/TARG ->b 3519# .... 3520# <0> padsv[$x:64,65] vM/LVINTRO ->c 3521# 3522# my @a :foo; 3523# my %h :foo; 3524# 3525# <1> ex-list vK ->c 3526# <0> ex-pushmark v ->3 3527# <0> padav[@a:64,65] vM/LVINTRO ->4 3528# <1> entersub[t2] vKRS*/TARG ->c 3529# .... 3530# 3531# my ($x,@a,%h) :foo; 3532# 3533# <;> nextstate(main 64 -e:1) v:{ ->3 3534# <@> list vKP ->w 3535# <0> pushmark vM/LVINTRO ->4 3536# <0> padsv[$x:64,65] vM/LVINTRO ->5 3537# <0> padav[@a:64,65] vM/LVINTRO ->6 3538# <0> padhv[%h:64,65] vM/LVINTRO ->7 3539# <1> entersub[t4] vKRS*/TARG ->f 3540# .... 3541# <1> entersub[t5] vKRS*/TARG ->n 3542# .... 3543# <1> entersub[t6] vKRS*/TARG ->v 3544# .... 3545# where the entersub in all cases looks like 3546# <1> entersub[t2] vKRS*/TARG ->c 3547# <0> pushmark s ->5 3548# <$> const[PV "attributes"] sM ->6 3549# <$> const[PV "main"] sM ->7 3550# <1> srefgen sKM/1 ->9 3551# <1> ex-list lKRM ->8 3552# <0> padsv[@a:64,65] sRM ->8 3553# <$> const[PV "foo"] sM ->a 3554# <.> method_named[PV "import"] ->b 3555 3556sub maybe_var_attr { 3557 my ($self, $op, $cx) = @_; 3558 3559 my $kid = $op->first->sibling; # skip pushmark 3560 return if class($kid) eq 'NULL'; 3561 3562 my $lop; 3563 my $type; 3564 3565 # Extract out all the pad ops and entersub ops into 3566 # @padops and @entersubops. Return if anything else seen. 3567 # Also determine what class (if any) all the pad vars belong to 3568 my $class; 3569 my $decl; # 'my' or 'state' 3570 my (@padops, @entersubops); 3571 for ($lop = $kid; !null($lop); $lop = $lop->sibling) { 3572 my $lopname = $lop->name; 3573 my $loppriv = $lop->private; 3574 if ($lopname =~ /^pad[sah]v$/) { 3575 return unless $loppriv & OPpLVAL_INTRO; 3576 3577 my $padname = $self->padname_sv($lop->targ); 3578 my $thisclass = ($padname->FLAGS & SVpad_TYPED) 3579 ? $padname->SvSTASH->NAME : 'main'; 3580 3581 # all pad vars must be in the same class 3582 $class //= $thisclass; 3583 return unless $thisclass eq $class; 3584 3585 # all pad vars must be the same sort of declaration 3586 # (all my, all state, etc) 3587 my $this = ($loppriv & OPpPAD_STATE) ? 'state' : 'my'; 3588 if (defined $decl) { 3589 return unless $this eq $decl; 3590 } 3591 $decl = $this; 3592 3593 push @padops, $lop; 3594 } 3595 elsif ($lopname eq 'entersub') { 3596 push @entersubops, $lop; 3597 } 3598 else { 3599 return; 3600 } 3601 } 3602 3603 return unless @padops && @padops == @entersubops; 3604 3605 # there should be a balance: each padop has a corresponding 3606 # 'attributes'->import() method call, in the same order. 3607 3608 my @varnames; 3609 my $attr_text; 3610 3611 for my $i (0..$#padops) { 3612 my $padop = $padops[$i]; 3613 my $esop = $entersubops[$i]; 3614 3615 push @varnames, $self->padname($padop->targ); 3616 3617 return unless ($esop->flags & OPf_KIDS); 3618 3619 my $kid = $esop->first; 3620 return unless $kid->type == OP_PUSHMARK; 3621 3622 $kid = $kid->sibling; 3623 return unless $$kid && $kid->type == OP_CONST; 3624 return unless $self->const_sv($kid)->PV eq 'attributes'; 3625 3626 $kid = $kid->sibling; 3627 return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__ 3628 3629 $kid = $kid->sibling; 3630 return unless $$kid 3631 && $kid->name eq "srefgen" 3632 && ($kid->flags & OPf_KIDS) 3633 && ($kid->first->flags & OPf_KIDS) 3634 && $kid->first->first->name =~ /^pad[sah]v$/ 3635 && $kid->first->first->targ == $padop->targ; 3636 3637 $kid = $kid->sibling; 3638 my @attr; 3639 while ($$kid) { 3640 last if ($kid->type != OP_CONST); 3641 push @attr, $self->const_sv($kid)->PV; 3642 $kid = $kid->sibling; 3643 } 3644 return unless @attr; 3645 my $thisattr = ":" . join(' ', @attr); 3646 $attr_text //= $thisattr; 3647 # all import calls must have the same list of attributes 3648 return unless $attr_text eq $thisattr; 3649 3650 return unless $kid->name eq 'method_named'; 3651 return unless $self->meth_sv($kid)->PV eq 'import'; 3652 3653 $kid = $kid->sibling; 3654 return if $$kid; 3655 } 3656 3657 my $res = $decl; 3658 $res .= " $class " if $class ne 'main'; 3659 $res .= 3660 (@varnames > 1) 3661 ? "(" . join(', ', @varnames) . ')' 3662 : " $varnames[0]"; 3663 3664 return "$res $attr_text"; 3665} 3666 3667 3668sub pp_list { 3669 my $self = shift; 3670 my($op, $cx) = @_; 3671 3672 { 3673 # might be my ($s,@a,%h) :Foo(bar); 3674 my $my_attr = maybe_var_attr($self, $op, $cx); 3675 return $my_attr if defined $my_attr; 3676 } 3677 3678 my($expr, @exprs); 3679 my $kid = $op->first->sibling; # skip pushmark 3680 return '' if class($kid) eq 'NULL'; 3681 my $lop; 3682 my $local = "either"; # could be local(...), my(...), state(...) or our(...) 3683 my $type; 3684 for ($lop = $kid; !null($lop); $lop = $lop->sibling) { 3685 my $lopname = $lop->name; 3686 my $loppriv = $lop->private; 3687 my $newtype; 3688 if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) { 3689 if ($loppriv & OPpPAD_STATE) { # state() 3690 ($local = "", last) if $local !~ /^(?:either|state)$/; 3691 $local = "state"; 3692 } else { # my() 3693 ($local = "", last) if $local !~ /^(?:either|my)$/; 3694 $local = "my"; 3695 } 3696 my $padname = $self->padname_sv($lop->targ); 3697 if ($padname->FLAGS & SVpad_TYPED) { 3698 $newtype = $padname->SvSTASH->NAME; 3699 } 3700 } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/ 3701 && $loppriv & OPpOUR_INTRO 3702 or $lopname eq "null" && class($lop) eq 'UNOP' 3703 && $lop->first->name eq "gvsv" 3704 && $lop->first->private & OPpOUR_INTRO) { # our() 3705 my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our"; 3706 ($local = "", last) 3707 if $local ne 'either' && $local ne $newlocal; 3708 $local = $newlocal; 3709 my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%'; 3710 if (my $t = $self->find_our_type( 3711 $funny . $self->gv_or_padgv($lop->first)->NAME 3712 )) { 3713 $newtype = $t; 3714 } 3715 } elsif ($lopname ne 'undef' 3716 and !($loppriv & OPpLVAL_INTRO) 3717 || !exists $uses_intro{$lopname eq 'null' 3718 ? substr B::ppname($lop->targ), 3 3719 : $lopname}) 3720 { 3721 $local = ""; # or not 3722 last; 3723 } elsif ($lopname ne "undef") 3724 { 3725 # local() 3726 ($local = "", last) if $local !~ /^(?:either|local)$/; 3727 $local = "local"; 3728 } 3729 if (defined $type && defined $newtype && $newtype ne $type) { 3730 $local = ''; 3731 last; 3732 } 3733 $type = $newtype; 3734 } 3735 $local = "" if $local eq "either"; # no point if it's all undefs 3736 $local &&= join ' ', map $self->keyword($_), split / /, $local; 3737 $local .= " $type " if $local && length $type; 3738 return $self->deparse($kid, $cx) if null $kid->sibling and not $local; 3739 for (; !null($kid); $kid = $kid->sibling) { 3740 if ($local) { 3741 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { 3742 $lop = $kid->first; 3743 } else { 3744 $lop = $kid; 3745 } 3746 $self->{'avoid_local'}{$$lop}++; 3747 $expr = $self->deparse($kid, 6); 3748 delete $self->{'avoid_local'}{$$lop}; 3749 } else { 3750 $expr = $self->deparse($kid, 6); 3751 } 3752 push @exprs, $expr; 3753 } 3754 if ($local) { 3755 if (@exprs == 1 && ($local eq 'state' || $local eq 'CORE::state')) { 3756 # 'state @a = ...' is legal, while 'state(@a) = ...' currently isn't 3757 return "$local $exprs[0]"; 3758 } 3759 return "$local(" . join(", ", @exprs) . ")"; 3760 } else { 3761 return $self->maybe_parens( join(", ", @exprs), $cx, 6); 3762 } 3763} 3764 3765sub is_ifelse_cont { 3766 my $op = shift; 3767 return ($op->name eq "null" and class($op) eq "UNOP" 3768 and $op->first->name =~ /^(and|cond_expr)$/ 3769 and is_scope($op->first->first->sibling)); 3770} 3771 3772sub pp_cond_expr { 3773 my $self = shift; 3774 my($op, $cx) = @_; 3775 my $cond = $op->first; 3776 my $true = $cond->sibling; 3777 my $false = $true->sibling; 3778 my $cuddle = $self->{'cuddle'}; 3779 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and 3780 (is_scope($false) || is_ifelse_cont($false)) 3781 and $self->{'expand'} < 7) { 3782 $cond = $self->deparse($cond, 8); 3783 $true = $self->deparse($true, 6); 3784 $false = $self->deparse($false, 8); 3785 return $self->maybe_parens("$cond ? $true : $false", $cx, 8); 3786 } 3787 3788 $cond = $self->deparse($cond, 1); 3789 $true = $self->deparse($true, 0); 3790 my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}"; 3791 my @elsifs; 3792 my $elsif; 3793 while (!null($false) and is_ifelse_cont($false)) { 3794 my $newop = $false->first; 3795 my $newcond = $newop->first; 3796 my $newtrue = $newcond->sibling; 3797 $false = $newtrue->sibling; # last in chain is OP_AND => no else 3798 if ($newcond->name eq "lineseq") 3799 { 3800 # lineseq to ensure correct line numbers in elsif() 3801 # Bug #37302 fixed by change #33710. 3802 $newcond = $newcond->first->sibling; 3803 } 3804 $newcond = $self->deparse($newcond, 1); 3805 $newtrue = $self->deparse($newtrue, 0); 3806 $elsif ||= $self->keyword("elsif"); 3807 push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}"; 3808 } 3809 if (!null($false)) { 3810 $false = $cuddle . $self->keyword("else") . " {\n\t" . 3811 $self->deparse($false, 0) . "\n\b}\cK"; 3812 } else { 3813 $false = "\cK"; 3814 } 3815 return $head . join($cuddle, "", @elsifs) . $false; 3816} 3817 3818sub pp_once { 3819 my ($self, $op, $cx) = @_; 3820 my $cond = $op->first; 3821 my $true = $cond->sibling; 3822 3823 my $ret = $self->deparse($true, $cx); 3824 $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e; 3825 $ret; 3826} 3827 3828sub loop_common { 3829 my $self = shift; 3830 my($op, $cx, $init) = @_; 3831 my $enter = $op->first; 3832 my $kid = $enter->sibling; 3833 local(@$self{qw'curstash warnings hints hinthash'}) 3834 = @$self{qw'curstash warnings hints hinthash'}; 3835 my $head = ""; 3836 my $bare = 0; 3837 my $body; 3838 my $cond = undef; 3839 my $name; 3840 if ($kid->name eq "lineseq") { # bare or infinite loop 3841 if ($kid->last->name eq "unstack") { # infinite 3842 $head = "while (1) "; # Can't use for(;;) if there's a continue 3843 $cond = ""; 3844 } else { 3845 $bare = 1; 3846 } 3847 $body = $kid; 3848 } elsif ($enter->name eq "enteriter") { # foreach 3849 my $ary = $enter->first->sibling; # first was pushmark 3850 my $var = $ary->sibling; 3851 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { 3852 # "reverse" was optimised away 3853 $ary = listop($self, $ary->first->sibling, 1, 'reverse'); 3854 } elsif ($enter->flags & OPf_STACKED 3855 and not null $ary->first->sibling->sibling) 3856 { 3857 $ary = $self->deparse($ary->first->sibling, 9) . " .. " . 3858 $self->deparse($ary->first->sibling->sibling, 9); 3859 } else { 3860 $ary = $self->deparse($ary, 1); 3861 } 3862 if (null $var) { 3863 $var = $self->pp_padsv($enter, 1, 1); 3864 } elsif ($var->name eq "rv2gv") { 3865 $var = $self->pp_rv2sv($var, 1); 3866 if ($enter->private & OPpOUR_INTRO) { 3867 # our declarations don't have package names 3868 $var =~ s/^(.).*::/$1/; 3869 $var = "our $var"; 3870 } 3871 } elsif ($var->name eq "gv") { 3872 $var = "\$" . $self->deparse($var, 1); 3873 } else { 3874 $var = $self->deparse($var, 1); 3875 } 3876 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER 3877 if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) { 3878 confess unless $var eq '$_'; 3879 $body = $body->first; 3880 return $self->deparse($body, 2) . " " 3881 . $self->keyword("foreach") . " ($ary)"; 3882 } 3883 $head = "foreach $var ($ary) "; 3884 } elsif ($kid->name eq "null") { # while/until 3885 $kid = $kid->first; 3886 $name = {"and" => "while", "or" => "until"}->{$kid->name}; 3887 $cond = $kid->first; 3888 $body = $kid->first->sibling; 3889 } elsif ($kid->name eq "stub") { # bare and empty 3890 return "{;}"; # {} could be a hashref 3891 } 3892 # If there isn't a continue block, then the next pointer for the loop 3893 # will point to the unstack, which is kid's last child, except 3894 # in a bare loop, when it will point to the leaveloop. When neither of 3895 # these conditions hold, then the second-to-last child is the continue 3896 # block (or the last in a bare loop). 3897 my $cont_start = $enter->nextop; 3898 my $cont; 3899 my $precond; 3900 my $postcond; 3901 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { 3902 if ($bare) { 3903 $cont = $body->last; 3904 } else { 3905 $cont = $body->first; 3906 while (!null($cont->sibling->sibling)) { 3907 $cont = $cont->sibling; 3908 } 3909 } 3910 my $state = $body->first; 3911 my $cuddle = $self->{'cuddle'}; 3912 my @states; 3913 for (; $$state != $$cont; $state = $state->sibling) { 3914 push @states, $state; 3915 } 3916 $body = $self->lineseq(undef, 0, @states); 3917 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { 3918 $precond = "for ($init; "; 3919 $postcond = "; " . $self->deparse($cont, 1) .") "; 3920 $cont = "\cK"; 3921 } else { 3922 $cont = $cuddle . "continue {\n\t" . 3923 $self->deparse($cont, 0) . "\n\b}\cK"; 3924 } 3925 } else { 3926 return "" if !defined $body; 3927 if (length $init) { 3928 $precond = "for ($init; "; 3929 $postcond = ";) "; 3930 } 3931 $cont = "\cK"; 3932 $body = $self->deparse($body, 0); 3933 } 3934 if ($precond) { # for(;;) 3935 $cond &&= $name eq 'until' 3936 ? listop($self, undef, 1, "not", $cond->first) 3937 : $self->deparse($cond, 1); 3938 $head = "$precond$cond$postcond"; 3939 } 3940 if ($name && !$head) { 3941 ref $cond and $cond = $self->deparse($cond, 1); 3942 $head = "$name ($cond) "; 3943 } 3944 $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e; 3945 $body =~ s/;?$/;\n/; 3946 3947 return $head . "{\n\t" . $body . "\b}" . $cont; 3948} 3949 3950sub pp_leaveloop { shift->loop_common(@_, "") } 3951 3952sub for_loop { 3953 my $self = shift; 3954 my($op, $cx) = @_; 3955 my $init = $self->deparse($op, 1); 3956 my $s = $op->sibling; 3957 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling; 3958 return $self->loop_common($ll, $cx, $init); 3959} 3960 3961sub pp_leavetry { 3962 my $self = shift; 3963 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; 3964} 3965 3966sub _op_is_or_was { 3967 my ($op, $expect_type) = @_; 3968 my $type = $op->type; 3969 return($type == $expect_type 3970 || ($type == OP_NULL && $op->targ == $expect_type)); 3971} 3972 3973sub pp_null { 3974 my($self, $op, $cx) = @_; 3975 3976 # might be 'my $s :Foo(bar);' 3977 if ($op->targ == OP_LIST) { 3978 my $my_attr = maybe_var_attr($self, $op, $cx); 3979 return $my_attr if defined $my_attr; 3980 } 3981 3982 if (class($op) eq "OP") { 3983 # old value is lost 3984 return $self->{'ex_const'} if $op->targ == OP_CONST; 3985 } elsif (class ($op) eq "COP") { 3986 return &pp_nextstate; 3987 } elsif ($op->first->name eq 'pushmark' 3988 or $op->first->name eq 'null' 3989 && $op->first->targ == OP_PUSHMARK 3990 && _op_is_or_was($op, OP_LIST)) { 3991 return $self->pp_list($op, $cx); 3992 } elsif ($op->first->name eq "enter") { 3993 return $self->pp_leave($op, $cx); 3994 } elsif ($op->first->name eq "leave") { 3995 return $self->pp_leave($op->first, $cx); 3996 } elsif ($op->first->name eq "scope") { 3997 return $self->pp_scope($op->first, $cx); 3998 } elsif ($op->targ == OP_STRINGIFY) { 3999 return $self->dquote($op, $cx); 4000 } elsif ($op->targ == OP_GLOB) { 4001 return $self->pp_glob( 4002 $op->first # entersub 4003 ->first # ex-list 4004 ->first # pushmark 4005 ->sibling, # glob 4006 $cx 4007 ); 4008 } elsif (!null($op->first->sibling) and 4009 $op->first->sibling->name eq "readline" and 4010 $op->first->sibling->flags & OPf_STACKED) { 4011 return $self->maybe_parens($self->deparse($op->first, 7) . " = " 4012 . $self->deparse($op->first->sibling, 7), 4013 $cx, 7); 4014 } elsif (!null($op->first->sibling) and 4015 $op->first->sibling->name =~ /^transr?\z/ and 4016 $op->first->sibling->flags & OPf_STACKED) { 4017 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " 4018 . $self->deparse($op->first->sibling, 20), 4019 $cx, 20); 4020 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { 4021 return ($self->lex_in_scope("&do") ? "CORE::do" : "do") 4022 . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; 4023 } elsif (!null($op->first->sibling) and 4024 $op->first->sibling->name eq "null" and 4025 class($op->first->sibling) eq "UNOP" and 4026 $op->first->sibling->first->flags & OPf_STACKED and 4027 $op->first->sibling->first->name eq "rcatline") { 4028 return $self->maybe_parens($self->deparse($op->first, 18) . " .= " 4029 . $self->deparse($op->first->sibling, 18), 4030 $cx, 18); 4031 } else { 4032 return $self->deparse($op->first, $cx); 4033 } 4034} 4035 4036sub padname { 4037 my $self = shift; 4038 my $targ = shift; 4039 return $self->padname_sv($targ)->PVX; 4040} 4041 4042sub padany { 4043 my $self = shift; 4044 my $op = shift; 4045 return substr($self->padname($op->targ), 1); # skip $/@/% 4046} 4047 4048sub pp_padsv { 4049 my $self = shift; 4050 my($op, $cx, $forbid_parens) = @_; 4051 my $targ = $op->targ; 4052 return $self->maybe_my($op, $cx, $self->padname($targ), 4053 $self->padname_sv($targ), 4054 $forbid_parens); 4055} 4056 4057sub pp_padav { pp_padsv(@_) } 4058 4059# prepend 'keys' where its been optimised away, with suitable handling 4060# of CORE:: and parens 4061 4062sub add_keys_keyword { 4063 my ($self, $str, $cx) = @_; 4064 $str = $self->maybe_parens($str, $cx, 16); 4065 # 'keys %h' versus 'keys(%h)' 4066 $str = " $str" unless $str =~ /^\(/; 4067 return $self->keyword("keys") . $str; 4068} 4069 4070sub pp_padhv { 4071 my ($self, $op, $cx) = @_; 4072 my $str = pp_padsv(@_); 4073 # with OPpPADHV_ISKEYS the keys op is optimised away, except 4074 # in scalar context the old op is kept (but not executed) so its targ 4075 # can be used. 4076 if ( ($op->private & OPpPADHV_ISKEYS) 4077 && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR)) 4078 { 4079 $str = $self->add_keys_keyword($str, $cx); 4080 } 4081 $str; 4082} 4083 4084sub gv_or_padgv { 4085 my $self = shift; 4086 my $op = shift; 4087 if (class($op) eq "PADOP") { 4088 return $self->padval($op->padix); 4089 } else { # class($op) eq "SVOP" 4090 return $op->gv; 4091 } 4092} 4093 4094sub pp_gvsv { 4095 my $self = shift; 4096 my($op, $cx) = @_; 4097 my $gv = $self->gv_or_padgv($op); 4098 return $self->maybe_local($op, $cx, $self->stash_variable("\$", 4099 $self->gv_name($gv), $cx)); 4100} 4101 4102sub pp_gv { 4103 my $self = shift; 4104 my($op, $cx) = @_; 4105 my $gv = $self->gv_or_padgv($op); 4106 return $self->maybe_qualify("", $self->gv_name($gv)); 4107} 4108 4109sub pp_aelemfast_lex { 4110 my $self = shift; 4111 my($op, $cx) = @_; 4112 my $name = $self->padname($op->targ); 4113 $name =~ s/^@/\$/; 4114 my $i = $op->private; 4115 $i -= 256 if $i > 127; 4116 return $name . "[$i]"; 4117} 4118 4119sub pp_aelemfast { 4120 my $self = shift; 4121 my($op, $cx) = @_; 4122 # optimised PADAV, pre 5.15 4123 return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL); 4124 4125 my $gv = $self->gv_or_padgv($op); 4126 my($name,$quoted) = $self->stash_variable_name('@',$gv); 4127 $name = $quoted ? "$name->" : '$' . $name; 4128 my $i = $op->private; 4129 $i -= 256 if $i > 127; 4130 return $name . "[$i]"; 4131} 4132 4133sub rv2x { 4134 my $self = shift; 4135 my($op, $cx, $type) = @_; 4136 4137 if (class($op) eq 'NULL' || !$op->can("first")) { 4138 carp("Unexpected op in pp_rv2x"); 4139 return 'XXX'; 4140 } 4141 my $kid = $op->first; 4142 if ($kid->name eq "gv") { 4143 return $self->stash_variable($type, 4144 $self->gv_name($self->gv_or_padgv($kid)), $cx); 4145 } elsif (is_scalar $kid) { 4146 my $str = $self->deparse($kid, 0); 4147 if ($str =~ /^\$([^\w\d])\z/) { 4148 # "$$+" isn't a legal way to write the scalar dereference 4149 # of $+, since the lexer can't tell you aren't trying to 4150 # do something like "$$ + 1" to get one more than your 4151 # PID. Either "${$+}" or "$${+}" are workable 4152 # disambiguations, but if the programmer did the former, 4153 # they'd be in the "else" clause below rather than here. 4154 # It's not clear if this should somehow be unified with 4155 # the code in dq and re_dq that also adds lexer 4156 # disambiguation braces. 4157 $str = '$' . "{$1}"; #' 4158 } 4159 return $type . $str; 4160 } else { 4161 return $type . "{" . $self->deparse($kid, 0) . "}"; 4162 } 4163} 4164 4165sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } 4166sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } 4167 4168sub pp_rv2hv { 4169 my ($self, $op, $cx) = @_; 4170 my $str = rv2x(@_, "%"); 4171 if ($op->private & OPpRV2HV_ISKEYS) { 4172 $str = $self->add_keys_keyword($str, $cx); 4173 } 4174 return maybe_local(@_, $str); 4175} 4176 4177# skip rv2av 4178sub pp_av2arylen { 4179 my $self = shift; 4180 my($op, $cx) = @_; 4181 my $kid = $op->first; 4182 if ($kid->name eq "padav") { 4183 return $self->maybe_local($op, $cx, '$#' . $self->padany($kid)); 4184 } else { 4185 my $kkid; 4186 if ( $kid->name eq "rv2av" 4187 && ($kkid = $kid->first) 4188 && $kkid->name !~ /^(scope|leave|gv)$/) 4189 { 4190 # handle (expr)->$#* postfix form 4191 my $expr; 4192 $expr = $self->deparse($kkid, 24); # 24 is '->' 4193 $expr = "$expr->\$#*"; 4194 # XXX maybe_local is probably wrong here: local($#-expression) 4195 # doesn't "do" local (the is no INTRO flag set) 4196 return $self->maybe_local($op, $cx, $expr); 4197 } 4198 else { 4199 # handle $#{expr} form 4200 # XXX see maybe_local comment above 4201 return $self->maybe_local($op, $cx, $self->rv2x($kid, $cx, '$#')); 4202 } 4203 } 4204} 4205 4206# skip down to the old, ex-rv2cv 4207sub pp_rv2cv { 4208 my ($self, $op, $cx) = @_; 4209 if (!null($op->first) && $op->first->name eq 'null' && 4210 $op->first->targ == OP_LIST) 4211 { 4212 return $self->rv2x($op->first->first->sibling, $cx, "&") 4213 } 4214 else { 4215 return $self->rv2x($op, $cx, "") 4216 } 4217} 4218 4219sub list_const { 4220 my $self = shift; 4221 my($cx, @list) = @_; 4222 my @a = map $self->const($_, 6), @list; 4223 if (@a == 0) { 4224 return "()"; 4225 } elsif (@a == 1) { 4226 return $a[0]; 4227 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { 4228 # collapse (-1,0,1,2) into (-1..2) 4229 my ($s, $e) = @a[0,-1]; 4230 my $i = $s; 4231 return $self->maybe_parens("$s..$e", $cx, 9) 4232 unless grep $i++ != $_, @a; 4233 } 4234 return $self->maybe_parens(join(", ", @a), $cx, 6); 4235} 4236 4237sub pp_rv2av { 4238 my $self = shift; 4239 my($op, $cx) = @_; 4240 my $kid = $op->first; 4241 if ($kid->name eq "const") { # constant list 4242 my $av = $self->const_sv($kid); 4243 return $self->list_const($cx, $av->ARRAY); 4244 } else { 4245 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); 4246 } 4247 } 4248 4249sub is_subscriptable { 4250 my $op = shift; 4251 if ($op->name =~ /^([ahg]elem|multideref$)/) { 4252 return 1; 4253 } elsif ($op->name eq "entersub") { 4254 my $kid = $op->first; 4255 return 0 unless null $kid->sibling; 4256 $kid = $kid->first; 4257 $kid = $kid->sibling until null $kid->sibling; 4258 return 0 if is_scope($kid); 4259 $kid = $kid->first; 4260 return 0 if $kid->name eq "gv" || $kid->name eq "padcv"; 4261 return 0 if is_scalar($kid); 4262 return is_subscriptable($kid); 4263 } else { 4264 return 0; 4265 } 4266} 4267 4268sub elem_or_slice_array_name 4269{ 4270 my $self = shift; 4271 my ($array, $left, $padname, $allow_arrow) = @_; 4272 4273 if ($array->name eq $padname) { 4274 return $self->padany($array); 4275 } elsif (is_scope($array)) { # ${expr}[0] 4276 return "{" . $self->deparse($array, 0) . "}"; 4277 } elsif ($array->name eq "gv") { 4278 ($array, my $quoted) = 4279 $self->stash_variable_name( 4280 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array) 4281 ); 4282 if (!$allow_arrow && $quoted) { 4283 # This cannot happen. 4284 die "Invalid variable name $array for slice"; 4285 } 4286 return $quoted ? "$array->" : $array; 4287 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ... 4288 return $self->deparse($array, 24); 4289 } else { 4290 return undef; 4291 } 4292} 4293 4294sub elem_or_slice_single_index 4295{ 4296 my $self = shift; 4297 my ($idx) = @_; 4298 4299 $idx = $self->deparse($idx, 1); 4300 4301 # Outer parens in an array index will confuse perl 4302 # if we're interpolating in a regular expression, i.e. 4303 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ 4304 # 4305 # If $self->{parens}, then an initial '(' will 4306 # definitely be paired with a final ')'. If 4307 # !$self->{parens}, the misleading parens won't 4308 # have been added in the first place. 4309 # 4310 # [You might think that we could get "(...)...(...)" 4311 # where the initial and final parens do not match 4312 # each other. But we can't, because the above would 4313 # only happen if there's an infix binop between the 4314 # two pairs of parens, and *that* means that the whole 4315 # expression would be parenthesized as well.] 4316 # 4317 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; 4318 4319 # Hash-element braces will autoquote a bareword inside themselves. 4320 # We need to make sure that C<$hash{warn()}> doesn't come out as 4321 # C<$hash{warn}>, which has a quite different meaning. Currently 4322 # B::Deparse will always quote strings, even if the string was a 4323 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored 4324 # for constant strings.) So we can cheat slightly here - if we see 4325 # a bareword, we know that it is supposed to be a function call. 4326 # 4327 $idx =~ s/^([A-Za-z_]\w*)$/$1()/; 4328 4329 return $idx; 4330} 4331 4332sub elem { 4333 my $self = shift; 4334 my ($op, $cx, $left, $right, $padname) = @_; 4335 my($array, $idx) = ($op->first, $op->first->sibling); 4336 4337 $idx = $self->elem_or_slice_single_index($idx); 4338 4339 unless ($array->name eq $padname) { # Maybe this has been fixed 4340 $array = $array->first; # skip rv2av (or ex-rv2av in _53+) 4341 } 4342 if (my $array_name=$self->elem_or_slice_array_name 4343 ($array, $left, $padname, 1)) { 4344 return ($array_name =~ /->\z/ 4345 ? $array_name 4346 : $array_name eq '#' ? '${#}' : "\$" . $array_name) 4347 . $left . $idx . $right; 4348 } else { 4349 # $x[20][3]{hi} or expr->[20] 4350 my $arrow = is_subscriptable($array) ? "" : "->"; 4351 return $self->deparse($array, 24) . $arrow . $left . $idx . $right; 4352 } 4353 4354} 4355 4356# a simplified version of elem_or_slice_array_name() 4357# for the use of pp_multideref 4358 4359sub multideref_var_name { 4360 my $self = shift; 4361 my ($gv, $is_hash) = @_; 4362 4363 my ($name, $quoted) = 4364 $self->stash_variable_name( $is_hash ? '%' : '@', $gv); 4365 return $quoted ? "$name->" 4366 : $name eq '#' 4367 ? '${#}' # avoid ${#}[1] => $#[1] 4368 : '$' . $name; 4369} 4370 4371 4372# deparse an OP_MULTICONCAT. If $in_dq is 1, we're within 4373# a double-quoted string, so for example. 4374# "abc\Qdef$x\Ebar" 4375# might get compiled as 4376# multiconcat("abc", metaquote(multiconcat("def", $x)), "bar") 4377# and the inner multiconcat should be deparsed as C<def$x> rather than 4378# the normal C<def . $x> 4379# Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../. 4380 4381sub do_multiconcat { 4382 my $self = shift; 4383 my($op, $cx, $in_dq) = @_; 4384 4385 my $kid; 4386 my @kids; 4387 my $assign; 4388 my $append; 4389 my $lhs = ""; 4390 4391 for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { 4392 # skip the consts and/or padsv we've optimised away 4393 push @kids, $kid 4394 unless $kid->type == OP_NULL 4395 && ( $kid->targ == OP_PADSV 4396 || $kid->targ == OP_CONST 4397 || $kid->targ == OP_PUSHMARK); 4398 } 4399 4400 $append = ($op->private & OPpMULTICONCAT_APPEND); 4401 4402 if ($op->private & OPpTARGET_MY) { 4403 # '$lex = ...' or '$lex .= ....' or 'my $lex = ' 4404 $lhs = $self->padname($op->targ); 4405 $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO); 4406 $assign = 1; 4407 } 4408 elsif ($op->flags & OPf_STACKED) { 4409 # 'expr = ...' or 'expr .= ....' 4410 my $expr = $append ? shift(@kids) : pop(@kids); 4411 $lhs = $self->deparse($expr, 7); 4412 $assign = 1; 4413 } 4414 4415 if ($assign) { 4416 $lhs .= $append ? ' .= ' : ' = '; 4417 } 4418 4419 my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv}); 4420 4421 my @consts; 4422 my $i = 0; 4423 for (@const_lens) { 4424 if ($_ == -1) { 4425 push @consts, undef; 4426 } 4427 else { 4428 push @consts, substr($const_str, $i, $_); 4429 my @args; 4430 $i += $_; 4431 } 4432 } 4433 4434 my $rhs = ""; 4435 4436 if ( $in_dq 4437 || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'})) 4438 { 4439 # "foo=$foo bar=$bar " 4440 my $not_first; 4441 while (@consts) { 4442 if ($not_first) { 4443 my $s = $self->dq(shift(@kids), 18); 4444 # don't deparse "a${$}b" as "a$$b" 4445 $s = '${$}' if $s eq '$$'; 4446 $rhs = dq_disambiguate($rhs, $s); 4447 } 4448 $not_first = 1; 4449 my $c = shift @consts; 4450 if (defined $c) { 4451 if ($in_dq == 2) { 4452 # in pattern: don't convert newline to '\n' etc etc 4453 my $s = re_uninterp(escape_re(re_unback($c))); 4454 $rhs = re_dq_disambiguate($rhs, $s) 4455 } 4456 else { 4457 my $s = uninterp(escape_str(unback($c))); 4458 $rhs = dq_disambiguate($rhs, $s) 4459 } 4460 } 4461 } 4462 return $rhs if $in_dq; 4463 $rhs = single_delim("qq", '"', $rhs, $self); 4464 } 4465 elsif ($op->private & OPpMULTICONCAT_FAKE) { 4466 # sprintf("foo=%s bar=%s ", $foo, $bar) 4467 4468 my @all; 4469 @consts = map { $_ //= ''; s/%/%%/g; $_ } @consts; 4470 my $fmt = join '%s', @consts; 4471 push @all, $self->quoted_const_str($fmt); 4472 4473 # the following is a stripped down copy of sub listop {} 4474 my $parens = $assign || ($cx >= 5) || $self->{'parens'}; 4475 my $fullname = $self->keyword('sprintf'); 4476 push @all, map $self->deparse($_, 6), @kids; 4477 4478 $rhs = $parens 4479 ? "$fullname(" . join(", ", @all) . ")" 4480 : "$fullname " . join(", ", @all); 4481 } 4482 else { 4483 # "foo=" . $foo . " bar=" . $bar 4484 my @all; 4485 my $not_first; 4486 while (@consts) { 4487 push @all, $self->deparse(shift(@kids), 18) if $not_first; 4488 $not_first = 1; 4489 my $c = shift @consts; 4490 if (defined $c) { 4491 push @all, $self->quoted_const_str($c); 4492 } 4493 } 4494 $rhs .= join ' . ', @all; 4495 } 4496 4497 my $text = $lhs . $rhs; 4498 4499 $text = "($text)" if ($cx >= (($assign) ? 7 : 18+1)) 4500 || $self->{'parens'}; 4501 4502 return $text; 4503} 4504 4505 4506sub pp_multiconcat { 4507 my $self = shift; 4508 $self->do_multiconcat(@_, 0); 4509} 4510 4511 4512sub pp_multideref { 4513 my $self = shift; 4514 my($op, $cx) = @_; 4515 my $text = ""; 4516 4517 if ($op->private & OPpMULTIDEREF_EXISTS) { 4518 $text = $self->keyword("exists"). " "; 4519 } 4520 elsif ($op->private & OPpMULTIDEREF_DELETE) { 4521 $text = $self->keyword("delete"). " "; 4522 } 4523 elsif ($op->private & OPpLVAL_INTRO) { 4524 $text = $self->keyword("local"). " "; 4525 } 4526 4527 if ($op->first && ($op->first->flags & OPf_KIDS)) { 4528 # arbitrary initial expression, e.g. f(1,2,3)->[...] 4529 my $expr = $self->deparse($op->first, 24); 4530 # stop "exists (expr)->{...}" being interpreted as 4531 #"(exists (expr))->{...}" 4532 $expr = "+$expr" if $expr =~ /^\(/; 4533 $text .= $expr; 4534 } 4535 4536 my @items = $op->aux_list($self->{curcv}); 4537 my $actions = shift @items; 4538 4539 my $is_hash; 4540 my $derefs = 0; 4541 4542 while (1) { 4543 if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) { 4544 $actions = shift @items; 4545 next; 4546 } 4547 4548 $is_hash = ( 4549 ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem 4550 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem 4551 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem 4552 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem 4553 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem 4554 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem 4555 ); 4556 4557 if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem 4558 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem) 4559 { 4560 $derefs = 1; 4561 $text .= '$' . substr($self->padname(shift @items), 1); 4562 } 4563 elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem 4564 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem) 4565 { 4566 $derefs = 1; 4567 $text .= $self->multideref_var_name(shift @items, $is_hash); 4568 } 4569 else { 4570 if ( ($actions & MDEREF_ACTION_MASK) == 4571 MDEREF_AV_padsv_vivify_rv2av_aelem 4572 || ($actions & MDEREF_ACTION_MASK) == 4573 MDEREF_HV_padsv_vivify_rv2hv_helem) 4574 { 4575 $text .= $self->padname(shift @items); 4576 } 4577 elsif ( ($actions & MDEREF_ACTION_MASK) == 4578 MDEREF_AV_gvsv_vivify_rv2av_aelem 4579 || ($actions & MDEREF_ACTION_MASK) == 4580 MDEREF_HV_gvsv_vivify_rv2hv_helem) 4581 { 4582 $text .= $self->multideref_var_name(shift @items, $is_hash); 4583 } 4584 elsif ( ($actions & MDEREF_ACTION_MASK) == 4585 MDEREF_AV_pop_rv2av_aelem 4586 || ($actions & MDEREF_ACTION_MASK) == 4587 MDEREF_HV_pop_rv2hv_helem) 4588 { 4589 if ( ($op->flags & OPf_KIDS) 4590 && ( _op_is_or_was($op->first, OP_RV2AV) 4591 || _op_is_or_was($op->first, OP_RV2HV)) 4592 && ($op->first->flags & OPf_KIDS) 4593 && ( _op_is_or_was($op->first->first, OP_AELEM) 4594 || _op_is_or_was($op->first->first, OP_HELEM)) 4595 ) 4596 { 4597 $derefs++; 4598 } 4599 } 4600 4601 $text .= '->' if !$derefs++; 4602 } 4603 4604 4605 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) { 4606 last; 4607 } 4608 4609 $text .= $is_hash ? '{' : '['; 4610 4611 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) { 4612 my $key = shift @items; 4613 if ($is_hash) { 4614 $text .= $self->const($key, $cx); 4615 } 4616 else { 4617 $text .= $key; 4618 } 4619 } 4620 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) { 4621 $text .= $self->padname(shift @items); 4622 } 4623 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) { 4624 $text .= '$' . ($self->stash_variable_name('$', shift @items))[0]; 4625 } 4626 4627 $text .= $is_hash ? '}' : ']'; 4628 4629 if ($actions & MDEREF_FLAG_last) { 4630 last; 4631 } 4632 $actions >>= MDEREF_SHIFT; 4633 } 4634 4635 return $text; 4636} 4637 4638 4639sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } 4640sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } 4641 4642sub pp_gelem { 4643 my $self = shift; 4644 my($op, $cx) = @_; 4645 my($glob, $part) = ($op->first, $op->last); 4646 $glob = $glob->first; # skip rv2gv 4647 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug 4648 my $scope = is_scope($glob); 4649 $glob = $self->deparse($glob, 0); 4650 $part = $self->deparse($part, 1); 4651 $glob =~ s/::\z// unless $scope; 4652 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; 4653} 4654 4655sub slice { 4656 my $self = shift; 4657 my ($op, $cx, $left, $right, $regname, $padname) = @_; 4658 my $last; 4659 my(@elems, $kid, $array, $list); 4660 if (class($op) eq "LISTOP") { 4661 $last = $op->last; 4662 } else { # ex-hslice inside delete() 4663 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} 4664 $last = $kid; 4665 } 4666 $array = $last; 4667 $array = $array->first 4668 if $array->name eq $regname or $array->name eq "null"; 4669 $array = $self->elem_or_slice_array_name($array,$left,$padname,0); 4670 $kid = $op->first->sibling; # skip pushmark 4671 if ($kid->name eq "list") { 4672 $kid = $kid->first->sibling; # skip list, pushmark 4673 for (; !null $kid; $kid = $kid->sibling) { 4674 push @elems, $self->deparse($kid, 6); 4675 } 4676 $list = join(", ", @elems); 4677 } else { 4678 $list = $self->elem_or_slice_single_index($kid); 4679 } 4680 my $lead = ( _op_is_or_was($op, OP_KVHSLICE) 4681 || _op_is_or_was($op, OP_KVASLICE)) 4682 ? '%' : '@'; 4683 return $lead . $array . $left . $list . $right; 4684} 4685 4686sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } 4687sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") } 4688sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } 4689sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") } 4690 4691sub pp_lslice { 4692 my $self = shift; 4693 my($op, $cx) = @_; 4694 my $idx = $op->first; 4695 my $list = $op->last; 4696 my(@elems, $kid); 4697 $list = $self->deparse($list, 1); 4698 $idx = $self->deparse($idx, 1); 4699 return "($list)" . "[$idx]"; 4700} 4701 4702sub want_scalar { 4703 my $op = shift; 4704 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; 4705} 4706 4707sub want_list { 4708 my $op = shift; 4709 return ($op->flags & OPf_WANT) == OPf_WANT_LIST; 4710} 4711 4712sub _method { 4713 my $self = shift; 4714 my($op, $cx) = @_; 4715 my $kid = $op->first->sibling; # skip pushmark 4716 my($meth, $obj, @exprs); 4717 if ($kid->name eq "list" and want_list $kid) { 4718 # When an indirect object isn't a bareword but the args are in 4719 # parens, the parens aren't part of the method syntax (the LLAFR 4720 # doesn't apply), but they make a list with OPf_PARENS set that 4721 # doesn't get flattened by the append_elem that adds the method, 4722 # making a (object, arg1, arg2, ...) list where the object 4723 # usually is. This can be distinguished from 4724 # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an 4725 # object) because in the later the list is in scalar context 4726 # as the left side of -> always is, while in the former 4727 # the list is in list context as method arguments always are. 4728 # (Good thing there aren't method prototypes!) 4729 $meth = $kid->sibling; 4730 $kid = $kid->first->sibling; # skip pushmark 4731 $obj = $kid; 4732 $kid = $kid->sibling; 4733 for (; not null $kid; $kid = $kid->sibling) { 4734 push @exprs, $kid; 4735 } 4736 } else { 4737 $obj = $kid; 4738 $kid = $kid->sibling; 4739 for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/; 4740 $kid = $kid->sibling) { 4741 push @exprs, $kid 4742 } 4743 $meth = $kid; 4744 } 4745 4746 if ($meth->name eq "method_named") { 4747 $meth = $self->meth_sv($meth)->PV; 4748 } elsif ($meth->name eq "method_super") { 4749 $meth = "SUPER::".$self->meth_sv($meth)->PV; 4750 } elsif ($meth->name eq "method_redir") { 4751 $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV; 4752 } elsif ($meth->name eq "method_redir_super") { 4753 $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'. 4754 $self->meth_sv($meth)->PV; 4755 } else { 4756 $meth = $meth->first; 4757 if ($meth->name eq "const") { 4758 # As of 5.005_58, this case is probably obsoleted by the 4759 # method_named case above 4760 $meth = $self->const_sv($meth)->PV; # needs to be bare 4761 } 4762 } 4763 4764 return { method => $meth, variable_method => ref($meth), 4765 object => $obj, args => \@exprs }, 4766 $cx; 4767} 4768 4769# compat function only 4770sub method { 4771 my $self = shift; 4772 my $info = $self->_method(@_); 4773 return $self->e_method( $self->_method(@_) ); 4774} 4775 4776sub e_method { 4777 my ($self, $info, $cx) = @_; 4778 my $obj = $self->deparse($info->{object}, 24); 4779 4780 my $meth = $info->{method}; 4781 $meth = $self->deparse($meth, 1) if $info->{variable_method}; 4782 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} ); 4783 if ($info->{object}->name eq 'scope' && want_list $info->{object}) { 4784 # method { $object } 4785 # This must be deparsed this way to preserve list context 4786 # of $object. 4787 my $need_paren = $cx >= 6; 4788 return '(' x $need_paren 4789 . $meth . substr($obj,2) # chop off the "do" 4790 . " $args" 4791 . ')' x $need_paren; 4792 } 4793 my $kid = $obj . "->" . $meth; 4794 if (length $args) { 4795 return $kid . "(" . $args . ")"; # parens mandatory 4796 } else { 4797 return $kid; 4798 } 4799} 4800 4801# returns "&" if the prototype doesn't match the args, 4802# or ("", $args_after_prototype_demunging) if it does. 4803sub check_proto { 4804 my $self = shift; 4805 return "&" if $self->{'noproto'}; 4806 my($proto, @args) = @_; 4807 my($arg, $real); 4808 my $doneok = 0; 4809 my @reals; 4810 # An unbackslashed @ or % gobbles up the rest of the args 4811 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/; 4812 $proto =~ s/^\s*//; 4813 while ($proto) { 4814 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//; 4815 my $chr = $1; 4816 if ($chr eq "") { 4817 return "&" if @args; 4818 } elsif ($chr eq ";") { 4819 $doneok = 1; 4820 } elsif ($chr eq "@" or $chr eq "%") { 4821 push @reals, map($self->deparse($_, 6), @args); 4822 @args = (); 4823 } else { 4824 $arg = shift @args; 4825 last unless $arg; 4826 if ($chr eq "\$" || $chr eq "_") { 4827 if (want_scalar $arg) { 4828 push @reals, $self->deparse($arg, 6); 4829 } else { 4830 return "&"; 4831 } 4832 } elsif ($chr eq "&") { 4833 if ($arg->name =~ /^(s?refgen|undef)$/) { 4834 push @reals, $self->deparse($arg, 6); 4835 } else { 4836 return "&"; 4837 } 4838 } elsif ($chr eq "*") { 4839 if ($arg->name =~ /^s?refgen$/ 4840 and $arg->first->first->name eq "rv2gv") 4841 { 4842 $real = $arg->first->first; # skip refgen, null 4843 if ($real->first->name eq "gv") { 4844 push @reals, $self->deparse($real, 6); 4845 } else { 4846 push @reals, $self->deparse($real->first, 6); 4847 } 4848 } else { 4849 return "&"; 4850 } 4851 } elsif (substr($chr, 0, 1) eq "\\") { 4852 $chr =~ tr/\\[]//d; 4853 if ($arg->name =~ /^s?refgen$/ and 4854 !null($real = $arg->first) and 4855 ($chr =~ /\$/ && is_scalar($real->first) 4856 or ($chr =~ /@/ 4857 && class($real->first->sibling) ne 'NULL' 4858 && $real->first->sibling->name 4859 =~ /^(rv2|pad)av$/) 4860 or ($chr =~ /%/ 4861 && class($real->first->sibling) ne 'NULL' 4862 && $real->first->sibling->name 4863 =~ /^(rv2|pad)hv$/) 4864 #or ($chr =~ /&/ # This doesn't work 4865 # && $real->first->name eq "rv2cv") 4866 or ($chr =~ /\*/ 4867 && $real->first->name eq "rv2gv"))) 4868 { 4869 push @reals, $self->deparse($real, 6); 4870 } else { 4871 return "&"; 4872 } 4873 } 4874 } 4875 } 4876 return "&" if $proto and !$doneok; # too few args and no ';' 4877 return "&" if @args; # too many args 4878 return ("", join ", ", @reals); 4879} 4880 4881sub retscalar { 4882 my $name = $_[0]->name; 4883 # XXX There has to be a better way of doing this scalar-op check. 4884 # Currently PL_opargs is not exposed. 4885 if ($name eq 'null') { 4886 $name = substr B::ppname($_[0]->targ), 3 4887 } 4888 $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv 4889 |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless 4890 |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans 4891 |transr|sassign|chop|schop|chomp|schomp|defined|undef 4892 |study|pos|preinc|i_preinc|predec|i_predec|postinc 4893 |i_postinc|postdec|i_postdec|pow|multiply|i_multiply 4894 |divide|i_divide|modulo|i_modulo|add|i_add|subtract 4895 |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt 4896 |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp 4897 |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate 4898 |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos 4899 |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr 4900 |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst 4901 |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem 4902 |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor 4903 |andassign|orassign|dorassign|warn|die|reset|nextstate 4904 |dbstate|unstack|last|next|redo|dump|goto|exit|open|close 4905 |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen 4906 |dbmclose|select|getc|read|enterwrite|prtf|print|say 4907 |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate 4908 |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect 4909 |listen|accept|shutdown|gsockopt|ssockopt|getsockname 4910 |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite 4911 |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned 4912 |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe 4913 |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir 4914 |chown|chroot|unlink|chmod|utime|rename|link|symlink 4915 |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir 4916 |closedir|fork|wait|waitpid|system|exec|kill|getppid 4917 |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep 4918 |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd 4919 |msgrcv|semop|semget|semctl|hintseval|shostent|snetent 4920 |sprotoent|sservent|ehostent|enetent|eprotoent|eservent 4921 |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv 4922 |fc)\z/x 4923} 4924 4925sub pp_entersub { 4926 my $self = shift; 4927 my($op, $cx) = @_; 4928 return $self->e_method($self->_method($op, $cx)) 4929 unless null $op->first->sibling; 4930 my $prefix = ""; 4931 my $amper = ""; 4932 my($kid, @exprs); 4933 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) { 4934 $prefix = "do "; 4935 } elsif ($op->private & OPpENTERSUB_AMPER) { 4936 $amper = "&"; 4937 } 4938 $kid = $op->first; 4939 $kid = $kid->first->sibling; # skip ex-list, pushmark 4940 for (; not null $kid->sibling; $kid = $kid->sibling) { 4941 push @exprs, $kid; 4942 } 4943 my $simple = 0; 4944 my $proto = undef; 4945 my $lexical; 4946 if (is_scope($kid)) { 4947 $amper = "&"; 4948 $kid = "{" . $self->deparse($kid, 0) . "}"; 4949 } elsif ($kid->first->name eq "gv") { 4950 my $gv = $self->gv_or_padgv($kid->first); 4951 my $cv; 4952 if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL" 4953 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') { 4954 $proto = $cv->PV if $cv->FLAGS & SVf_POK; 4955 } 4956 $simple = 1; # only calls of named functions can be prototyped 4957 $kid = $self->maybe_qualify("!", $self->gv_name($gv)); 4958 my $fq; 4959 # Fully qualify any sub name that conflicts with a lexical. 4960 if ($self->lex_in_scope("&$kid") 4961 || $self->lex_in_scope("&$kid", 1)) 4962 { 4963 $fq++; 4964 } elsif (!$amper) { 4965 if ($kid eq 'main::') { 4966 $kid = '::'; 4967 } 4968 else { 4969 if ($kid !~ /::/ && $kid ne 'x') { 4970 # Fully qualify any sub name that is also a keyword. While 4971 # we could check the import flag, we cannot guarantee that 4972 # the code deparsed so far would set that flag, so we qual- 4973 # ify the names regardless of importation. 4974 if (exists $feature_keywords{$kid}) { 4975 $fq++ if $self->feature_enabled($kid); 4976 } elsif (do { local $@; local $SIG{__DIE__}; 4977 eval { () = prototype "CORE::$kid"; 1 } }) { 4978 $fq++ 4979 } 4980 } 4981 if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) { 4982 $kid = single_delim("q", "'", $kid, $self) . '->'; 4983 } 4984 } 4985 } 4986 $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::'; 4987 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { 4988 $amper = "&"; 4989 $kid = $self->deparse($kid, 24); 4990 } else { 4991 $prefix = ""; 4992 my $grandkid = $kid->first; 4993 my $arrow = ($lexical = $grandkid->name eq "padcv") 4994 || is_subscriptable($grandkid) 4995 ? "" 4996 : "->"; 4997 $kid = $self->deparse($kid, 24) . $arrow; 4998 if ($lexical) { 4999 my $padlist = $self->{'curcv'}->PADLIST; 5000 my $padoff = $grandkid->targ; 5001 my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff); 5002 my $protocv = $padname->FLAGS & SVpad_STATE 5003 ? $padlist->ARRAYelt(1)->ARRAYelt($padoff) 5004 : $padname->PROTOCV; 5005 if ($protocv->FLAGS & SVf_POK) { 5006 $proto = $protocv->PV 5007 } 5008 $simple = 1; 5009 } 5010 } 5011 5012 # Doesn't matter how many prototypes there are, if 5013 # they haven't happened yet! 5014 my $declared = $lexical || exists $self->{'subs_declared'}{$kid}; 5015 if (not $declared and $self->{'in_coderef2text'}) { 5016 no strict 'refs'; 5017 no warnings 'uninitialized'; 5018 $declared = 5019 ( 5020 defined &{ ${$self->{'curstash'}."::"}{$kid} } 5021 && !exists 5022 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} 5023 && defined prototype $self->{'curstash'}."::".$kid 5024 ); 5025 } 5026 if (!$declared && defined($proto)) { 5027 # Avoid "too early to check prototype" warning 5028 ($amper, $proto) = ('&'); 5029 } 5030 5031 my $args; 5032 my $listargs = 1; 5033 if ($declared and defined $proto and not $amper) { 5034 ($amper, $args) = $self->check_proto($proto, @exprs); 5035 $listargs = $amper; 5036 } 5037 if ($listargs) { 5038 $args = join(", ", map( 5039 ($_->flags & OPf_WANT) == OPf_WANT_SCALAR 5040 && !retscalar($_) 5041 ? $self->maybe_parens_unop('scalar', $_, 6) 5042 : $self->deparse($_, 6), 5043 @exprs 5044 )); 5045 } 5046 if ($prefix or $amper) { 5047 if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as && 5048 if ($op->flags & OPf_STACKED) { 5049 return $prefix . $amper . $kid . "(" . $args . ")"; 5050 } else { 5051 return $prefix . $amper. $kid; 5052 } 5053 } else { 5054 # It's a syntax error to call CORE::GLOBAL::foo with a prefix, 5055 # so it must have been translated from a keyword call. Translate 5056 # it back. 5057 $kid =~ s/^CORE::GLOBAL:://; 5058 5059 my $dproto = defined($proto) ? $proto : "undefined"; 5060 my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/; 5061 if (!$declared) { 5062 return "$kid(" . $args . ")"; 5063 } elsif ($dproto =~ /^\s*\z/) { 5064 return $kid; 5065 } elsif ($scalar_proto and is_scalar($exprs[0])) { 5066 # is_scalar is an excessively conservative test here: 5067 # really, we should be comparing to the precedence of the 5068 # top operator of $exprs[0] (ala unop()), but that would 5069 # take some major code restructuring to do right. 5070 return $self->maybe_parens_func($kid, $args, $cx, 16); 5071 } elsif (not $scalar_proto and defined($proto) || $simple) { #' 5072 return $self->maybe_parens_func($kid, $args, $cx, 5); 5073 } else { 5074 return "$kid(" . $args . ")"; 5075 } 5076 } 5077} 5078 5079sub pp_enterwrite { unop(@_, "write") } 5080 5081# escape things that cause interpolation in double quotes, 5082# but not character escapes 5083sub uninterp { 5084 my($str) = @_; 5085 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; 5086 return $str; 5087} 5088 5089{ 5090my $bal; 5091BEGIN { 5092 use re "eval"; 5093 # Matches any string which is balanced with respect to {braces} 5094 $bal = qr( 5095 (?: 5096 [^\\{}] 5097 | \\\\ 5098 | \\[{}] 5099 | \{(??{$bal})\} 5100 )* 5101 )x; 5102} 5103 5104# the same, but treat $|, $), $( and $ at the end of the string differently 5105# and leave comments unmangled for the sake of /x and (?x). 5106sub re_uninterp { 5107 my($str) = @_; 5108 5109 $str =~ s/ 5110 ( ^|\G # $1 5111 | [^\\] 5112 ) 5113 5114 ( # $2 5115 (?:\\\\)* 5116 ) 5117 5118 ( # $3 5119 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) 5120 | \#[^\n]* # (skip over comments) 5121 ) 5122 | [\$\@] 5123 (?!\||\)|\(|$|\s) 5124 | \\[uUlLQE] 5125 ) 5126 5127 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; 5128 5129 return $str; 5130} 5131} 5132 5133# character escapes, but not delimiters that might need to be escaped 5134sub escape_str { # ASCII, UTF8 5135 my($str) = @_; 5136 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; 5137 $str =~ s/\a/\\a/g; 5138# $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH 5139 # isn't a backspace in EBCDIC 5140 $str =~ s/\t/\\t/g; 5141 $str =~ s/\n/\\n/g; 5142 $str =~ s/\e/\\e/g; 5143 $str =~ s/\f/\\f/g; 5144 $str =~ s/\r/\\r/g; 5145 $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge; 5146 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age; 5147 return $str; 5148} 5149 5150# For regexes. Leave whitespace unmangled in case of /x or (?x). 5151sub escape_re { 5152 my($str) = @_; 5153 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; 5154 $str =~ s/([[:^print:]])/ 5155 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age; 5156 $str =~ s/\n/\n\f/g; 5157 return $str; 5158} 5159 5160# Don't do this for regexen 5161sub unback { 5162 my($str) = @_; 5163 $str =~ s/\\/\\\\/g; 5164 return $str; 5165} 5166 5167# Remove backslashes which precede literal control characters, 5168# to avoid creating ambiguity when we escape the latter. 5169# 5170# Don't remove a backslash from escaped whitespace: where the T represents 5171# a literal tab character, /T/x is not equivalent to /\T/x 5172 5173sub re_unback { 5174 my($str) = @_; 5175 5176 # the insane complexity here is due to the behaviour of "\c\" 5177 $str =~ s/ 5178 # these two lines ensure that the backslash we're about to 5179 # remove isn't preceeded by something which makes it part 5180 # of a \c 5181 5182 (^ | [^\\] | \\c\\) # $1 5183 (?<!\\c) 5184 5185 # the backslash to remove 5186 \\ 5187 5188 # keep pairs of backslashes 5189 (\\\\)* # $2 5190 5191 # only remove if the thing following is a control char 5192 (?=[[:^print:]]) 5193 # and not whitespace 5194 (?=\S) 5195 /$1$2/xg; 5196 return $str; 5197} 5198 5199sub balanced_delim { 5200 my($str) = @_; 5201 my @str = split //, $str; 5202 my($ar, $open, $close, $fail, $c, $cnt, $last_bs); 5203 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { 5204 ($open, $close) = @$ar; 5205 $fail = 0; $cnt = 0; $last_bs = 0; 5206 for $c (@str) { 5207 if ($c eq $open) { 5208 $fail = 1 if $last_bs; 5209 $cnt++; 5210 } elsif ($c eq $close) { 5211 $fail = 1 if $last_bs; 5212 $cnt--; 5213 if ($cnt < 0) { 5214 # qq()() isn't ")(" 5215 $fail = 1; 5216 last; 5217 } 5218 } 5219 $last_bs = $c eq '\\'; 5220 } 5221 $fail = 1 if $cnt != 0; 5222 return ($open, "$open$str$close") if not $fail; 5223 } 5224 return ("", $str); 5225} 5226 5227sub single_delim { 5228 my($q, $default, $str, $self) = @_; 5229 return "$default$str$default" if $default and index($str, $default) == -1; 5230 my $coreq = $self->keyword($q); # maybe CORE::q 5231 if ($q ne 'qr') { 5232 (my $succeed, $str) = balanced_delim($str); 5233 return "$coreq$str" if $succeed; 5234 } 5235 for my $delim ('/', '"', '#') { 5236 return "$coreq$delim" . $str . $delim if index($str, $delim) == -1; 5237 } 5238 if ($default) { 5239 $str =~ s/$default/\\$default/g; 5240 return "$default$str$default"; 5241 } else { 5242 $str =~ s[/][\\/]g; 5243 return "$coreq/$str/"; 5244 } 5245} 5246 5247my $max_prec; 5248BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } 5249 5250# Split a floating point number into an integer mantissa and a binary 5251# exponent. Assumes you've already made sure the number isn't zero or 5252# some weird infinity or NaN. 5253sub split_float { 5254 my($f) = @_; 5255 my $exponent = 0; 5256 if ($f == int($f)) { 5257 while ($f % 2 == 0) { 5258 $f /= 2; 5259 $exponent++; 5260 } 5261 } else { 5262 while ($f != int($f)) { 5263 $f *= 2; 5264 $exponent--; 5265 } 5266 } 5267 my $mantissa = sprintf("%.0f", $f); 5268 return ($mantissa, $exponent); 5269} 5270 5271 5272# suitably single- or double-quote a literal constant string 5273 5274sub quoted_const_str { 5275 my ($self, $str) =@_; 5276 if ($str =~ /[[:^print:]]/a) { 5277 return single_delim("qq", '"', 5278 uninterp(escape_str unback $str), $self); 5279 } else { 5280 return single_delim("q", "'", unback($str), $self); 5281 } 5282} 5283 5284 5285sub const { 5286 my $self = shift; 5287 my($sv, $cx) = @_; 5288 if ($self->{'use_dumper'}) { 5289 return $self->const_dumper($sv, $cx); 5290 } 5291 if (class($sv) eq "SPECIAL") { 5292 # sv_undef, sv_yes, sv_no 5293 return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21) 5294 : ('undef', '1')[$$sv-1]; 5295 } 5296 if (class($sv) eq "NULL") { 5297 return 'undef'; 5298 } 5299 # convert a version object into the "v1.2.3" string in its V magic 5300 if ($sv->FLAGS & SVs_RMG) { 5301 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { 5302 return $mg->PTR if $mg->TYPE eq 'V'; 5303 } 5304 } 5305 5306 if ($sv->FLAGS & SVf_IOK) { 5307 my $str = $sv->int_value; 5308 $str = $self->maybe_parens($str, $cx, 21) if $str < 0; 5309 return $str; 5310 } elsif ($sv->FLAGS & SVf_NOK) { 5311 my $nv = $sv->NV; 5312 if ($nv == 0) { 5313 if (pack("F", $nv) eq pack("F", 0)) { 5314 # positive zero 5315 return "0"; 5316 } else { 5317 # negative zero 5318 return $self->maybe_parens("-.0", $cx, 21); 5319 } 5320 } elsif (1/$nv == 0) { 5321 if ($nv > 0) { 5322 # positive infinity 5323 return $self->maybe_parens("9**9**9", $cx, 22); 5324 } else { 5325 # negative infinity 5326 return $self->maybe_parens("-9**9**9", $cx, 21); 5327 } 5328 } elsif ($nv != $nv) { 5329 # NaN 5330 if (pack("F", $nv) eq pack("F", sin(9**9**9))) { 5331 # the normal kind 5332 return "sin(9**9**9)"; 5333 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { 5334 # the inverted kind 5335 return $self->maybe_parens("-sin(9**9**9)", $cx, 21); 5336 } else { 5337 # some other kind 5338 my $hex = unpack("h*", pack("F", $nv)); 5339 return qq'unpack("F", pack("h*", "$hex"))'; 5340 } 5341 } 5342 # first, try the default stringification 5343 my $str = "$nv"; 5344 if ($str != $nv) { 5345 # failing that, try using more precision 5346 $str = sprintf("%.${max_prec}g", $nv); 5347# if (pack("F", $str) ne pack("F", $nv)) { 5348 if ($str != $nv) { 5349 # not representable in decimal with whatever sprintf() 5350 # and atof() Perl is using here. 5351 my($mant, $exp) = split_float($nv); 5352 return $self->maybe_parens("$mant * 2**$exp", $cx, 19); 5353 } 5354 } 5355 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; 5356 return $str; 5357 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { 5358 my $ref = $sv->RV; 5359 my $class = class($ref); 5360 if ($class eq "AV") { 5361 return "[" . $self->list_const(2, $ref->ARRAY) . "]"; 5362 } elsif ($class eq "HV") { 5363 my %hash = $ref->ARRAY; 5364 my @elts; 5365 for my $k (sort keys %hash) { 5366 push @elts, "$k => " . $self->const($hash{$k}, 6); 5367 } 5368 return "{" . join(", ", @elts) . "}"; 5369 } elsif ($class eq "CV") { 5370 no overloading; 5371 if ($self->{curcv} && 5372 $self->{curcv}->object_2svref == $ref->object_2svref) { 5373 return $self->keyword("__SUB__"); 5374 } 5375 return "sub " . $self->deparse_sub($ref); 5376 } 5377 if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) { 5378 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { 5379 if ($mg->TYPE eq 'r') { 5380 my $re = re_uninterp(escape_re(re_unback($mg->precomp))); 5381 return single_delim("qr", "", $re, $self); 5382 } 5383 } 5384 } 5385 5386 my $const = $self->const($ref, 20); 5387 if ($self->{in_subst_repl} && $const =~ /^[0-9]/) { 5388 $const = "($const)"; 5389 } 5390 return $self->maybe_parens("\\$const", $cx, 20); 5391 } elsif ($sv->FLAGS & SVf_POK) { 5392 my $str = $sv->PV; 5393 return $self->quoted_const_str($str); 5394 } else { 5395 return "undef"; 5396 } 5397} 5398 5399sub const_dumper { 5400 my $self = shift; 5401 my($sv, $cx) = @_; 5402 my $ref = $sv->object_2svref(); 5403 my $dumper = Data::Dumper->new([$$ref], ['$v']); 5404 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); 5405 my $str = $dumper->Dump(); 5406 if ($str =~ /^\$v/) { 5407 return '${my ' . $str . ' \$v}'; 5408 } else { 5409 return $str; 5410 } 5411} 5412 5413sub const_sv { 5414 my $self = shift; 5415 my $op = shift; 5416 my $sv = $op->sv; 5417 # the constant could be in the pad (under useithreads) 5418 $sv = $self->padval($op->targ) unless $$sv; 5419 return $sv; 5420} 5421 5422sub meth_sv { 5423 my $self = shift; 5424 my $op = shift; 5425 my $sv = $op->meth_sv; 5426 # the constant could be in the pad (under useithreads) 5427 $sv = $self->padval($op->targ) unless $$sv; 5428 return $sv; 5429} 5430 5431sub meth_rclass_sv { 5432 my $self = shift; 5433 my $op = shift; 5434 my $sv = $op->rclass; 5435 # the constant could be in the pad (under useithreads) 5436 $sv = $self->padval($sv) unless ref $sv; 5437 return $sv; 5438} 5439 5440sub pp_const { 5441 my $self = shift; 5442 my($op, $cx) = @_; 5443# if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting 5444# return $self->const_sv($op)->PV; 5445# } 5446 my $sv = $self->const_sv($op); 5447 return $self->const($sv, $cx); 5448} 5449 5450 5451# Join two components of a double-quoted string, disambiguating 5452# "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" 5453 5454sub dq_disambiguate { 5455 my ($first, $last) = @_; 5456 ($last =~ /^[A-Z\\\^\[\]_?]/ && 5457 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc 5458 || ($last =~ /^[:'{\[\w_]/ && #' 5459 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); 5460 return $first . $last; 5461} 5462 5463 5464# Deparse a double-quoted optree. For example, "$a[0]\Q$b\Efo\"o" gets 5465# compiled to concat(concat($[0],quotemeta($b)),const("fo\"o")), and this 5466# sub deparses it back to $a[0]\Q$b\Efo"o 5467# (It does not add delimiters) 5468 5469sub dq { 5470 my $self = shift; 5471 my $op = shift; 5472 my $type = $op->name; 5473 if ($type eq "const") { 5474 return uninterp(escape_str(unback($self->const_sv($op)->as_string))); 5475 } elsif ($type eq "concat") { 5476 return dq_disambiguate($self->dq($op->first), $self->dq($op->last)); 5477 } elsif ($type eq "multiconcat") { 5478 return $self->do_multiconcat($op, 26, 1); 5479 } elsif ($type eq "uc") { 5480 return '\U' . $self->dq($op->first->sibling) . '\E'; 5481 } elsif ($type eq "lc") { 5482 return '\L' . $self->dq($op->first->sibling) . '\E'; 5483 } elsif ($type eq "ucfirst") { 5484 return '\u' . $self->dq($op->first->sibling); 5485 } elsif ($type eq "lcfirst") { 5486 return '\l' . $self->dq($op->first->sibling); 5487 } elsif ($type eq "quotemeta") { 5488 return '\Q' . $self->dq($op->first->sibling) . '\E'; 5489 } elsif ($type eq "fc") { 5490 return '\F' . $self->dq($op->first->sibling) . '\E'; 5491 } elsif ($type eq "join") { 5492 return $self->deparse($op->last, 26); # was join($", @ary) 5493 } else { 5494 return $self->deparse($op, 26); 5495 } 5496} 5497 5498sub pp_backtick { 5499 my $self = shift; 5500 my($op, $cx) = @_; 5501 # skip pushmark if it exists (readpipe() vs ``) 5502 my $child = $op->first->sibling->isa('B::NULL') 5503 ? $op->first : $op->first->sibling; 5504 if ($self->pure_string($child)) { 5505 return single_delim("qx", '`', $self->dq($child, 1), $self); 5506 } 5507 unop($self, @_, "readpipe"); 5508} 5509 5510sub dquote { 5511 my $self = shift; 5512 my($op, $cx) = @_; 5513 my $kid = $op->first->sibling; # skip ex-stringify, pushmark 5514 return $self->deparse($kid, $cx) if $self->{'unquote'}; 5515 $self->maybe_targmy($kid, $cx, 5516 sub {single_delim("qq", '"', $self->dq($_[1]), 5517 $self)}); 5518} 5519 5520# OP_STRINGIFY is a listop, but it only ever has one arg 5521sub pp_stringify { 5522 my ($self, $op, $cx) = @_; 5523 my $kid = $op->first->sibling; 5524 while ($kid->name eq 'null' && !null($kid->first)) { 5525 $kid = $kid->first; 5526 } 5527 if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref 5528 |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) { 5529 maybe_targmy(@_, \&dquote); 5530 } 5531 else { 5532 # Actually an optimised join. 5533 my $result = listop(@_,"join"); 5534 $result =~ s/join([( ])/join$1$self->{'ex_const'}, /; 5535 $result; 5536 } 5537} 5538 5539# tr/// and s/// (and tr[][], tr[]//, tr###, etc) 5540# note that tr(from)/to/ is OK, but not tr/from/(to) 5541sub double_delim { 5542 my($from, $to) = @_; 5543 my($succeed, $delim); 5544 if ($from !~ m[/] and $to !~ m[/]) { 5545 return "/$from/$to/"; 5546 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { 5547 if (($succeed, $to) = balanced_delim($to) and $succeed) { 5548 return "$from$to"; 5549 } else { 5550 for $delim ('/', '"', '#') { # note no "'" -- s''' is special 5551 return "$from$delim$to$delim" if index($to, $delim) == -1; 5552 } 5553 $to =~ s[/][\\/]g; 5554 return "$from/$to/"; 5555 } 5556 } else { 5557 for $delim ('/', '"', '#') { # note no ' 5558 return "$delim$from$delim$to$delim" 5559 if index($to . $from, $delim) == -1; 5560 } 5561 $from =~ s[/][\\/]g; 5562 $to =~ s[/][\\/]g; 5563 return "/$from/$to/"; 5564 } 5565} 5566 5567# Escape a characrter. 5568# Only used by tr///, so backslashes hyphens 5569 5570sub pchr { # ASCII 5571 my($n) = @_; 5572 if ($n == ord '\\') { 5573 return '\\\\'; 5574 } elsif ($n == ord "-") { 5575 return "\\-"; 5576 } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' ')) 5577 and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~'))) 5578 { 5579 # I'm presuming a regex is not ok here, otherwise we could have used 5580 # /[[:print:]]/a to get here 5581 return chr($n); 5582 } elsif ($n == ord "\a") { 5583 return '\\a'; 5584 } elsif ($n == ord "\b") { 5585 return '\\b'; 5586 } elsif ($n == ord "\t") { 5587 return '\\t'; 5588 } elsif ($n == ord "\n") { 5589 return '\\n'; 5590 } elsif ($n == ord "\e") { 5591 return '\\e'; 5592 } elsif ($n == ord "\f") { 5593 return '\\f'; 5594 } elsif ($n == ord "\r") { 5595 return '\\r'; 5596 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { 5597 return '\\c' . $unctrl{chr $n}; 5598 } else { 5599# return '\x' . sprintf("%02x", $n); 5600 return '\\' . sprintf("%03o", $n); 5601 } 5602} 5603 5604# Convert a list of characters into a string suitable for tr/// search or 5605# replacement, with suitable escaping and collapsing of ranges 5606 5607sub collapse { 5608 my(@chars) = @_; 5609 my($str, $c, $tr) = (""); 5610 for ($c = 0; $c < @chars; $c++) { 5611 $tr = $chars[$c]; 5612 $str .= pchr($tr); 5613 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and 5614 $chars[$c + 2] == $tr + 2) 5615 { 5616 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) 5617 {} 5618 $str .= "-"; 5619 $str .= pchr($chars[$c]); 5620 } 5621 } 5622 return $str; 5623} 5624 5625sub tr_decode_byte { 5626 my($table, $flags) = @_; 5627 my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l'; 5628 my ($size, @table) = unpack("${ssize_t}s*", $table); 5629 pop @table; # remove the wildcard final entry 5630 5631 my($c, $tr, @from, @to, @delfrom, $delhyphen); 5632 if ($table[ord "-"] != -1 and 5633 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) 5634 { 5635 $tr = $table[ord "-"]; 5636 $table[ord "-"] = -1; 5637 if ($tr >= 0) { 5638 @from = ord("-"); 5639 @to = $tr; 5640 } else { # -2 ==> delete 5641 $delhyphen = 1; 5642 } 5643 } 5644 for ($c = 0; $c < @table; $c++) { 5645 $tr = $table[$c]; 5646 if ($tr >= 0) { 5647 push @from, $c; push @to, $tr; 5648 } elsif ($tr == -2) { 5649 push @delfrom, $c; 5650 } 5651 } 5652 @from = (@from, @delfrom); 5653 5654 if ($flags & OPpTRANS_COMPLEMENT) { 5655 unless ($flags & OPpTRANS_DELETE) { 5656 @to = () if ("@from" eq "@to"); 5657 } 5658 5659 my @newfrom = (); 5660 my %from; 5661 @from{@from} = (1) x @from; 5662 for ($c = 0; $c < 256; $c++) { 5663 push @newfrom, $c unless $from{$c}; 5664 } 5665 @from = @newfrom; 5666 } 5667 unless ($flags & OPpTRANS_DELETE || !@to) { 5668 pop @to while $#to and $to[$#to] == $to[$#to -1]; 5669 } 5670 my($from, $to); 5671 $from = collapse(@from); 5672 $to = collapse(@to); 5673 $from .= "-" if $delhyphen; 5674 return ($from, $to); 5675} 5676 5677sub tr_chr { 5678 my $x = shift; 5679 if ($x == ord "-") { 5680 return "\\-"; 5681 } elsif ($x == ord "\\") { 5682 return "\\\\"; 5683 } else { 5684 return chr $x; 5685 } 5686} 5687 5688# XXX This doesn't yet handle all cases correctly either 5689 5690sub tr_decode_utf8 { 5691 my($swash_hv, $flags) = @_; 5692 my %swash = $swash_hv->ARRAY; 5693 my $final = undef; 5694 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; 5695 my $none = $swash{"NONE"}->IV; 5696 my $extra = $none + 1; 5697 my(@from, @delfrom, @to); 5698 my $line; 5699 foreach $line (split /\n/, $swash{'LIST'}->PV) { 5700 my($min, $max, $result) = split(/\t/, $line); 5701 $min = hex $min; 5702 if (length $max) { 5703 $max = hex $max; 5704 } else { 5705 $max = $min; 5706 } 5707 $result = hex $result; 5708 if ($result == $extra) { 5709 push @delfrom, [$min, $max]; 5710 } else { 5711 push @from, [$min, $max]; 5712 push @to, [$result, $result + $max - $min]; 5713 } 5714 } 5715 for my $i (0 .. $#from) { 5716 if ($from[$i][0] == ord '-') { 5717 unshift @from, splice(@from, $i, 1); 5718 unshift @to, splice(@to, $i, 1); 5719 last; 5720 } elsif ($from[$i][1] == ord '-') { 5721 $from[$i][1]--; 5722 $to[$i][1]--; 5723 unshift @from, ord '-'; 5724 unshift @to, ord '-'; 5725 last; 5726 } 5727 } 5728 for my $i (0 .. $#delfrom) { 5729 if ($delfrom[$i][0] == ord '-') { 5730 push @delfrom, splice(@delfrom, $i, 1); 5731 last; 5732 } elsif ($delfrom[$i][1] == ord '-') { 5733 $delfrom[$i][1]--; 5734 push @delfrom, ord '-'; 5735 last; 5736 } 5737 } 5738 if (defined $final and $to[$#to][1] != $final) { 5739 push @to, [$final, $final]; 5740 } 5741 push @from, @delfrom; 5742 if ($flags & OPpTRANS_COMPLEMENT) { 5743 my @newfrom; 5744 my $next = 0; 5745 for my $i (0 .. $#from) { 5746 push @newfrom, [$next, $from[$i][0] - 1]; 5747 $next = $from[$i][1] + 1; 5748 } 5749 @from = (); 5750 for my $range (@newfrom) { 5751 if ($range->[0] <= $range->[1]) { 5752 push @from, $range; 5753 } 5754 } 5755 } 5756 my($from, $to, $diff); 5757 for my $chunk (@from) { 5758 $diff = $chunk->[1] - $chunk->[0]; 5759 if ($diff > 1) { 5760 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); 5761 } elsif ($diff == 1) { 5762 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); 5763 } else { 5764 $from .= tr_chr($chunk->[0]); 5765 } 5766 } 5767 for my $chunk (@to) { 5768 $diff = $chunk->[1] - $chunk->[0]; 5769 if ($diff > 1) { 5770 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); 5771 } elsif ($diff == 1) { 5772 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); 5773 } else { 5774 $to .= tr_chr($chunk->[0]); 5775 } 5776 } 5777 #$final = sprintf("%04x", $final) if defined $final; 5778 #$none = sprintf("%04x", $none) if defined $none; 5779 #$extra = sprintf("%04x", $extra) if defined $extra; 5780 #print STDERR "final: $final\n none: $none\nextra: $extra\n"; 5781 #print STDERR $swash{'LIST'}->PV; 5782 return (escape_str($from), escape_str($to)); 5783} 5784 5785sub pp_trans { 5786 my $self = shift; 5787 my($op, $cx, $morflags) = @_; 5788 my($from, $to); 5789 my $class = class($op); 5790 my $priv_flags = $op->private; 5791 if ($class eq "PVOP") { 5792 ($from, $to) = tr_decode_byte($op->pv, $priv_flags); 5793 } elsif ($class eq "PADOP") { 5794 ($from, $to) 5795 = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags); 5796 } else { # class($op) eq "SVOP" 5797 ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags); 5798 } 5799 my $flags = ""; 5800 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT; 5801 $flags .= "d" if $priv_flags & OPpTRANS_DELETE; 5802 $to = "" if $from eq $to and $flags eq ""; 5803 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH; 5804 $flags .= $morflags if defined $morflags; 5805 my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags; 5806 if (my $targ = $op->targ) { 5807 return $self->maybe_parens($self->padname($targ) . " =~ $ret", 5808 $cx, 20); 5809 } 5810 return $ret; 5811} 5812 5813sub pp_transr { push @_, 'r'; goto &pp_trans } 5814 5815# Join two components of a double-quoted re, disambiguating 5816# "${foo}bar", "${foo}{bar}", "${foo}[1]". 5817 5818sub re_dq_disambiguate { 5819 my ($first, $last) = @_; 5820 ($last =~ /^[A-Z\\\^\[\]_?]/ && 5821 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc 5822 || ($last =~ /^[{\[\w_]/ && 5823 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); 5824 return $first . $last; 5825} 5826 5827# Like dq(), but different 5828sub re_dq { 5829 my $self = shift; 5830 my ($op) = @_; 5831 5832 my $type = $op->name; 5833 if ($type eq "const") { 5834 my $unbacked = re_unback($self->const_sv($op)->as_string); 5835 return re_uninterp(escape_re($unbacked)); 5836 } elsif ($type eq "concat") { 5837 my $first = $self->re_dq($op->first); 5838 my $last = $self->re_dq($op->last); 5839 return re_dq_disambiguate($first, $last); 5840 } elsif ($type eq "multiconcat") { 5841 return $self->do_multiconcat($op, 26, 2); 5842 } elsif ($type eq "uc") { 5843 return '\U' . $self->re_dq($op->first->sibling) . '\E'; 5844 } elsif ($type eq "lc") { 5845 return '\L' . $self->re_dq($op->first->sibling) . '\E'; 5846 } elsif ($type eq "ucfirst") { 5847 return '\u' . $self->re_dq($op->first->sibling); 5848 } elsif ($type eq "lcfirst") { 5849 return '\l' . $self->re_dq($op->first->sibling); 5850 } elsif ($type eq "quotemeta") { 5851 return '\Q' . $self->re_dq($op->first->sibling) . '\E'; 5852 } elsif ($type eq "fc") { 5853 return '\F' . $self->re_dq($op->first->sibling) . '\E'; 5854 } elsif ($type eq "join") { 5855 return $self->deparse($op->last, 26); # was join($", @ary) 5856 } else { 5857 my $ret = $self->deparse($op, 26); 5858 $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces 5859 or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces 5860 return $ret; 5861 } 5862} 5863 5864sub pure_string { 5865 my ($self, $op) = @_; 5866 return 0 if null $op; 5867 my $type = $op->name; 5868 5869 if ($type eq 'const' || $type eq 'av2arylen') { 5870 return 1; 5871 } 5872 elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') { 5873 return $self->pure_string($op->first->sibling); 5874 } 5875 elsif ($type eq 'join') { 5876 my $join_op = $op->first->sibling; # Skip pushmark 5877 return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV; 5878 5879 my $gvop = $join_op->first; 5880 return 0 unless $gvop->name eq 'gvsv'; 5881 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); 5882 5883 return 0 unless ${$join_op->sibling} eq ${$op->last}; 5884 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/; 5885 } 5886 elsif ($type eq 'concat') { 5887 return $self->pure_string($op->first) 5888 && $self->pure_string($op->last); 5889 } 5890 elsif ($type eq 'multiconcat') { 5891 my ($kid, @kids); 5892 for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { 5893 # skip the consts and/or padsv we've optimised away 5894 push @kids, $kid 5895 unless $kid->type == OP_NULL 5896 && ( $kid->targ == OP_PADSV 5897 || $kid->targ == OP_CONST 5898 || $kid->targ == OP_PUSHMARK); 5899 } 5900 5901 if ($op->flags & OPf_STACKED) { 5902 # remove expr from @kids where 'expr = ...' or 'expr .= ....' 5903 if ($op->private & OPpMULTICONCAT_APPEND) { 5904 shift(@kids); 5905 } 5906 else { 5907 pop(@kids); 5908 } 5909 } 5910 for (@kids) { 5911 return 0 unless $self->pure_string($_); 5912 } 5913 return 1; 5914 } 5915 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { 5916 return 1; 5917 } 5918 elsif ($type eq "null" and $op->can('first') and not null $op->first) { 5919 my $first = $op->first; 5920 5921 return 1 if $first->name eq "multideref"; 5922 return 1 if $first->name eq "aelemfast_lex"; 5923 5924 if ( $first->name eq "null" 5925 and $first->can('first') 5926 and not null $first->first 5927 and $first->first->name eq "aelemfast" 5928 ) 5929 { 5930 return 1; 5931 } 5932 } 5933 5934 return 0; 5935} 5936 5937sub code_list { 5938 my ($self,$op,$cv) = @_; 5939 5940 # localise stuff relating to the current sub 5941 $cv and 5942 local($self->{'curcv'}) = $cv, 5943 local($self->{'curcvlex'}), 5944 local(@$self{qw'curstash warnings hints hinthash curcop'}) 5945 = @$self{qw'curstash warnings hints hinthash curcop'}; 5946 5947 my $re; 5948 for ($op = $op->first->sibling; !null($op); $op = $op->sibling) { 5949 if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) { 5950 my $scope = $op->first; 5951 # 0 context (last arg to scopeop) means statement context, so 5952 # the contents of the block will not be wrapped in do{...}. 5953 my $block = scopeop($scope->first->name eq "enter", $self, 5954 $scope, 0); 5955 # next op is the source code of the block 5956 $op = $op->sibling; 5957 $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0]; 5958 my $multiline = $block =~ /\n/; 5959 $re .= $multiline ? "\n\t" : ' '; 5960 $re .= $block; 5961 $re .= $multiline ? "\n\b})" : " })"; 5962 } else { 5963 $re = re_dq_disambiguate($re, $self->re_dq($op)); 5964 } 5965 } 5966 $re; 5967} 5968 5969sub regcomp { 5970 my $self = shift; 5971 my($op, $cx) = @_; 5972 my $kid = $op->first; 5973 $kid = $kid->first if $kid->name eq "regcmaybe"; 5974 $kid = $kid->first if $kid->name eq "regcreset"; 5975 my $kname = $kid->name; 5976 if ($kname eq "null" and !null($kid->first) 5977 and $kid->first->name eq 'pushmark') 5978 { 5979 my $str = ''; 5980 $kid = $kid->first->sibling; 5981 while (!null($kid)) { 5982 my $first = $str; 5983 my $last = $self->re_dq($kid); 5984 $str = re_dq_disambiguate($first, $last); 5985 $kid = $kid->sibling; 5986 } 5987 return $str, 1; 5988 } 5989 5990 return ($self->re_dq($kid), 1) 5991 if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid); 5992 return ($self->deparse($kid, $cx), 0); 5993} 5994 5995sub pp_regcomp { 5996 my ($self, $op, $cx) = @_; 5997 return (($self->regcomp($op, $cx, 0))[0]); 5998} 5999 6000sub re_flags { 6001 my ($self, $op) = @_; 6002 my $flags = ''; 6003 my $pmflags = $op->pmflags; 6004 if (!$pmflags) { 6005 my $re = $op->pmregexp; 6006 if ($$re) { 6007 $pmflags = $re->compflags; 6008 } 6009 } 6010 $flags .= "g" if $pmflags & PMf_GLOBAL; 6011 $flags .= "i" if $pmflags & PMf_FOLD; 6012 $flags .= "m" if $pmflags & PMf_MULTILINE; 6013 $flags .= "o" if $pmflags & PMf_KEEP; 6014 $flags .= "s" if $pmflags & PMf_SINGLELINE; 6015 $flags .= "x" if $pmflags & PMf_EXTENDED; 6016 $flags .= "x" if $pmflags & PMf_EXTENDED_MORE; 6017 $flags .= "p" if $pmflags & PMf_KEEPCOPY; 6018 $flags .= "n" if $pmflags & PMf_NOCAPTURE; 6019 if (my $charset = $pmflags & PMf_CHARSET) { 6020 # Hardcoding this is fragile, but B does not yet export the 6021 # constants we need. 6022 $flags .= qw(d l u a aa)[$charset >> 7] 6023 } 6024 # The /d flag is indicated by 0; only show it if necessary. 6025 elsif ($self->{hinthash} and 6026 $self->{hinthash}{reflags_charset} 6027 || $self->{hinthash}{feature_unicode} 6028 or $self->{hints} & $feature::hint_mask 6029 && ($self->{hints} & $feature::hint_mask) 6030 != $feature::hint_mask 6031 && $self->{hints} & $feature::hint_uni8bit 6032 ) { 6033 $flags .= 'd'; 6034 } 6035 $flags; 6036} 6037 6038# osmic acid -- see osmium tetroxide 6039 6040my %matchwords; 6041map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', 6042 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', 6043 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix'); 6044 6045# When deparsing a regular expression with code blocks, we have to look in 6046# various places to find the blocks. 6047# 6048# For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv 6049# and the code list (list of blocks and constants, maybe vars) is under 6050# $cv->ROOT->first->code_list: 6051# ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref' 6052# 6053# For qr/$a(?{...})/ with interpolation, the code list is more accessible, 6054# under $pmop->code_list, but the $cv is something you have to dig for in 6055# the regcomp op’s kids: 6056# ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/' 6057# 6058# For m// and split //, things are much simpler. There is no CV. The code 6059# list is under $pmop->code_list. 6060 6061sub matchop { 6062 my $self = shift; 6063 my($op, $cx, $name, $delim) = @_; 6064 my $kid = $op->first; 6065 my ($binop, $var, $re) = ("", "", ""); 6066 if ($op->name ne 'split' && $op->flags & OPf_STACKED) { 6067 $binop = 1; 6068 $var = $self->deparse($kid, 20); 6069 $kid = $kid->sibling; 6070 } 6071 # not $name; $name will be 'm' for both match and split 6072 elsif ($op->name eq 'match' and my $targ = $op->targ) { 6073 $binop = 1; 6074 $var = $self->padname($targ); 6075 } 6076 my $quote = 1; 6077 my $pmflags = $op->pmflags; 6078 my $rhs_bound_to_defsv; 6079 my ($cv, $bregexp); 6080 my $have_kid = !null $kid; 6081 # Check for code blocks first 6082 if (not null my $code_list = $op->code_list) { 6083 $re = $self->code_list($code_list, 6084 $op->name eq 'qr' 6085 ? $self->padval( 6086 $kid->first # ex-list 6087 ->first # pushmark 6088 ->sibling # entersub 6089 ->first # ex-list 6090 ->first # pushmark 6091 ->sibling # srefgen 6092 ->first # ex-list 6093 ->first # anoncode 6094 ->targ 6095 ) 6096 : undef); 6097 } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) { 6098 my $patop = $cv->ROOT # leavesub 6099 ->first # qr 6100 ->code_list;# list 6101 $re = $self->code_list($patop, $cv); 6102 } elsif (!$have_kid) { 6103 $re = re_uninterp(escape_re(re_unback($op->precomp))); 6104 } elsif ($kid->name ne 'regcomp') { 6105 if ($op->name eq 'split') { 6106 # split has other kids, not just regcomp 6107 $re = re_uninterp(escape_re(re_unback($op->precomp))); 6108 } 6109 else { 6110 carp("found ".$kid->name." where regcomp expected"); 6111 } 6112 } else { 6113 ($re, $quote) = $self->regcomp($kid, 21); 6114 } 6115 if ($have_kid and $kid->name eq 'regcomp') { 6116 my $matchop = $kid->first; 6117 if ($matchop->name eq 'regcreset') { 6118 $matchop = $matchop->first; 6119 } 6120 if ($matchop->name =~ /^(?:match|transr?|subst)\z/ 6121 && $matchop->flags & OPf_SPECIAL) { 6122 $rhs_bound_to_defsv = 1; 6123 } 6124 } 6125 my $flags = ""; 6126 $flags .= "c" if $pmflags & PMf_CONTINUE; 6127 $flags .= $self->re_flags($op); 6128 $flags = join '', sort split //, $flags; 6129 $flags = $matchwords{$flags} if $matchwords{$flags}; 6130 if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here 6131 $re =~ s/\?/\\?/g; 6132 $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required 6133 } elsif ($quote) { 6134 $re = single_delim($name, $delim, $re, $self); 6135 } 6136 $re = $re . $flags if $quote; 6137 if ($binop) { 6138 return 6139 $self->maybe_parens( 6140 $rhs_bound_to_defsv 6141 ? "$var =~ (\$_ =~ $re)" 6142 : "$var =~ $re", 6143 $cx, 20 6144 ); 6145 } else { 6146 return $re; 6147 } 6148} 6149 6150sub pp_match { matchop(@_, "m", "/") } 6151sub pp_qr { matchop(@_, "qr", "") } 6152 6153sub pp_runcv { unop(@_, "__SUB__"); } 6154 6155sub pp_split { 6156 my $self = shift; 6157 my($op, $cx) = @_; 6158 my($kid, @exprs, $ary, $expr); 6159 my $stacked = $op->flags & OPf_STACKED; 6160 6161 $kid = $op->first; 6162 $kid = $kid->sibling if $kid->name eq 'regcomp'; 6163 for (; !null($kid); $kid = $kid->sibling) { 6164 push @exprs, $self->deparse($kid, 6); 6165 } 6166 6167 unshift @exprs, $self->matchop($op, $cx, "m", "/"); 6168 6169 if ($op->private & OPpSPLIT_ASSIGN) { 6170 # With C<@array = split(/pat/, str);>, 6171 # array is stored in split's pmreplroot; either 6172 # as an integer index into the pad (for a lexical array) 6173 # or as GV for a package array (which will be a pad index 6174 # on threaded builds) 6175 # With my/our @array = split(/pat/, str), the array is instead 6176 # accessed via an extra padav/rv2av op at the end of the 6177 # split's kid ops. 6178 6179 if ($stacked) { 6180 $ary = pop @exprs; 6181 } 6182 else { 6183 if ($op->private & OPpSPLIT_LEX) { 6184 $ary = $self->padname($op->pmreplroot); 6185 } 6186 else { 6187 # union with op_pmtargetoff, op_pmtargetgv 6188 my $gv = $op->pmreplroot; 6189 $gv = $self->padval($gv) if !ref($gv); 6190 $ary = $self->maybe_local(@_, 6191 $self->stash_variable('@', 6192 $self->gv_name($gv), 6193 $cx)) 6194 } 6195 if ($op->private & OPpLVAL_INTRO) { 6196 $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary"; 6197 } 6198 } 6199 } 6200 6201 # handle special case of split(), and split(' ') that compiles to /\s+/ 6202 $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE(); 6203 6204 $expr = "split(" . join(", ", @exprs) . ")"; 6205 if ($ary) { 6206 return $self->maybe_parens("$ary = $expr", $cx, 7); 6207 } else { 6208 return $expr; 6209 } 6210} 6211 6212# oxime -- any of various compounds obtained chiefly by the action of 6213# hydroxylamine on aldehydes and ketones and characterized by the 6214# bivalent grouping C=NOH [Webster's Tenth] 6215 6216my %substwords; 6217map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', 6218 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', 6219 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', 6220 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue', 6221 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime', 6222 'or', 'rose', 'rosie'); 6223 6224sub pp_subst { 6225 my $self = shift; 6226 my($op, $cx) = @_; 6227 my $kid = $op->first; 6228 my($binop, $var, $re, $repl) = ("", "", "", ""); 6229 if ($op->flags & OPf_STACKED) { 6230 $binop = 1; 6231 $var = $self->deparse($kid, 20); 6232 $kid = $kid->sibling; 6233 } 6234 elsif (my $targ = $op->targ) { 6235 $binop = 1; 6236 $var = $self->padname($targ); 6237 } 6238 my $flags = ""; 6239 my $pmflags = $op->pmflags; 6240 if (null($op->pmreplroot)) { 6241 $repl = $kid; 6242 $kid = $kid->sibling; 6243 } else { 6244 $repl = $op->pmreplroot->first; # skip substcont 6245 } 6246 while ($repl->name eq "entereval") { 6247 $repl = $repl->first; 6248 $flags .= "e"; 6249 } 6250 { 6251 local $self->{in_subst_repl} = 1; 6252 if ($pmflags & PMf_EVAL) { 6253 $repl = $self->deparse($repl->first, 0); 6254 } else { 6255 $repl = $self->dq($repl); 6256 } 6257 } 6258 if (not null my $code_list = $op->code_list) { 6259 $re = $self->code_list($code_list); 6260 } elsif (null $kid) { 6261 $re = re_uninterp(escape_re(re_unback($op->precomp))); 6262 } else { 6263 ($re) = $self->regcomp($kid, 1); 6264 } 6265 $flags .= "r" if $pmflags & PMf_NONDESTRUCT; 6266 $flags .= "e" if $pmflags & PMf_EVAL; 6267 $flags .= $self->re_flags($op); 6268 $flags = join '', sort split //, $flags; 6269 $flags = $substwords{$flags} if $substwords{$flags}; 6270 my $core_s = $self->keyword("s"); # maybe CORE::s 6271 if ($binop) { 6272 return $self->maybe_parens("$var =~ $core_s" 6273 . double_delim($re, $repl) . $flags, 6274 $cx, 20); 6275 } else { 6276 return "$core_s". double_delim($re, $repl) . $flags; 6277 } 6278} 6279 6280sub is_lexical_subs { 6281 my (@ops) = shift; 6282 for my $op (@ops) { 6283 return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/; 6284 } 6285 return 1; 6286} 6287 6288# Pretend these two ops do not exist. The perl parser adds them to the 6289# beginning of any block containing my-sub declarations, whereas we handle 6290# the subs in pad_subs and next_todo. 6291*pp_clonecv = *pp_introcv; 6292sub pp_introcv { 6293 my $self = shift; 6294 my($op, $cx) = @_; 6295 # For now, deparsing doesn't worry about the distinction between introcv 6296 # and clonecv, so pretend this op doesn't exist: 6297 return ''; 6298} 6299 6300sub pp_padcv { 6301 my $self = shift; 6302 my($op, $cx) = @_; 6303 return $self->padany($op); 6304} 6305 6306my %lvref_funnies = ( 6307 OPpLVREF_SV, => '$', 6308 OPpLVREF_AV, => '@', 6309 OPpLVREF_HV, => '%', 6310 OPpLVREF_CV, => '&', 6311); 6312 6313sub pp_refassign { 6314 my ($self, $op, $cx) = @_; 6315 my $left; 6316 if ($op->private & OPpLVREF_ELEM) { 6317 $left = $op->first->sibling; 6318 $left = maybe_local(@_, elem($self, $left, undef, 6319 $left->targ == OP_AELEM 6320 ? qw([ ] padav) 6321 : qw({ } padhv))); 6322 } elsif ($op->flags & OPf_STACKED) { 6323 $left = maybe_local(@_, 6324 $lvref_funnies{$op->private & OPpLVREF_TYPE} 6325 . $self->deparse($op->first->sibling)); 6326 } else { 6327 $left = &pp_padsv; 6328 } 6329 my $right = $self->deparse_binop_right($op, $op->first, 7); 6330 return $self->maybe_parens("\\$left = $right", $cx, 7); 6331} 6332 6333sub pp_lvref { 6334 my ($self, $op, $cx) = @_; 6335 my $code; 6336 if ($op->private & OPpLVREF_ELEM) { 6337 $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem; 6338 } elsif ($op->flags & OPf_STACKED) { 6339 $code = maybe_local(@_, 6340 $lvref_funnies{$op->private & OPpLVREF_TYPE} 6341 . $self->deparse($op->first)); 6342 } else { 6343 $code = &pp_padsv; 6344 } 6345 "\\$code"; 6346} 6347 6348sub pp_lvrefslice { 6349 my ($self, $op, $cx) = @_; 6350 '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice); 6351} 6352 6353sub pp_lvavref { 6354 my ($self, $op, $cx) = @_; 6355 '\\(' . ($op->flags & OPf_STACKED 6356 ? maybe_local(@_, rv2x(@_, "\@")) 6357 : &pp_padsv) . ')' 6358} 6359 6360 6361sub pp_argcheck { 6362 my $self = shift; 6363 my($op, $cx) = @_; 6364 my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv}); 6365 my $mandatory = $params - $opt_params; 6366 my $check = ''; 6367 6368 $check .= <<EOF if !$slurpy; 6369die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params; 6370EOF 6371 6372 $check .= <<EOF if $mandatory > 0; 6373die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory; 6374EOF 6375 6376 my $cond = ($params & 1) ? 'unless' : 'if'; 6377 $check .= <<EOF if $slurpy eq '%'; 6378die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1); 6379EOF 6380 6381 $check =~ s/;\n\z//; 6382 return $check; 6383} 6384 6385 6386sub pp_argelem { 6387 my $self = shift; 6388 my($op, $cx) = @_; 6389 my $var = $self->padname($op->targ); 6390 my $ix = $op->string($self->{curcv}); 6391 my $expr; 6392 if ($op->flags & OPf_KIDS) { 6393 $expr = $self->deparse($op->first, 7); 6394 } 6395 elsif ($var =~ /^[@%]/) { 6396 $expr = $ix ? "\@_[$ix .. \$#_]" : '@_'; 6397 } 6398 else { 6399 $expr = "\$_[$ix]"; 6400 } 6401 return "my $var = $expr"; 6402} 6403 6404 6405sub pp_argdefelem { 6406 my $self = shift; 6407 my($op, $cx) = @_; 6408 my $ix = $op->targ; 6409 my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : "; 6410 my $def = $self->deparse($op->first, 7); 6411 $def = "($def)" if $op->first->flags & OPf_PARENS; 6412 $expr .= $self->deparse($op->first, $cx); 6413 return $expr; 6414} 6415 6416 64171; 6418__END__ 6419 6420=head1 NAME 6421 6422B::Deparse - Perl compiler backend to produce perl code 6423 6424=head1 SYNOPSIS 6425 6426B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>] 6427 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> 6428 6429=head1 DESCRIPTION 6430 6431B::Deparse is a backend module for the Perl compiler that generates 6432perl source code, based on the internal compiled structure that perl 6433itself creates after parsing a program. The output of B::Deparse won't 6434be exactly the same as the original source, since perl doesn't keep 6435track of comments or whitespace, and there isn't a one-to-one 6436correspondence between perl's syntactical constructions and their 6437compiled form, but it will often be close. When you use the B<-p> 6438option, the output also includes parentheses even when they are not 6439required by precedence, which can make it easy to see if perl is 6440parsing your expressions the way you intended. 6441 6442While B::Deparse goes to some lengths to try to figure out what your 6443original program was doing, some parts of the language can still trip 6444it up; it still fails even on some parts of Perl's own test suite. If 6445you encounter a failure other than the most common ones described in 6446the BUGS section below, you can help contribute to B::Deparse's 6447ongoing development by submitting a bug report with a small 6448example. 6449 6450=head1 OPTIONS 6451 6452As with all compiler backend options, these must follow directly after 6453the '-MO=Deparse', separated by a comma but not any white space. 6454 6455=over 4 6456 6457=item B<-d> 6458 6459Output data values (when they appear as constants) using Data::Dumper. 6460Without this option, B::Deparse will use some simple routines of its 6461own for the same purpose. Currently, Data::Dumper is better for some 6462kinds of data (such as complex structures with sharing and 6463self-reference) while the built-in routines are better for others 6464(such as odd floating-point values). 6465 6466=item B<-f>I<FILE> 6467 6468Normally, B::Deparse deparses the main code of a program, and all the subs 6469defined in the same file. To include subs defined in 6470other files, pass the B<-f> option with the filename. 6471You can pass the B<-f> option several times, to 6472include more than one secondary file. (Most of the time you don't want to 6473use it at all.) You can also use this option to include subs which are 6474defined in the scope of a B<#line> directive with two parameters. 6475 6476=item B<-l> 6477 6478Add '#line' declarations to the output based on the line and file 6479locations of the original code. 6480 6481=item B<-p> 6482 6483Print extra parentheses. Without this option, B::Deparse includes 6484parentheses in its output only when they are needed, based on the 6485structure of your program. With B<-p>, it uses parentheses (almost) 6486whenever they would be legal. This can be useful if you are used to 6487LISP, or if you want to see how perl parses your input. If you say 6488 6489 if ($var & 0x7f == 65) {print "Gimme an A!"} 6490 print ($which ? $a : $b), "\n"; 6491 $name = $ENV{USER} or "Bob"; 6492 6493C<B::Deparse,-p> will print 6494 6495 if (($var & 0)) { 6496 print('Gimme an A!') 6497 }; 6498 (print(($which ? $a : $b)), '???'); 6499 (($name = $ENV{'USER'}) or '???') 6500 6501which probably isn't what you intended (the C<'???'> is a sign that 6502perl optimized away a constant value). 6503 6504=item B<-P> 6505 6506Disable prototype checking. With this option, all function calls are 6507deparsed as if no prototype was defined for them. In other words, 6508 6509 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' 6510 6511will print 6512 6513 sub foo (\@) { 6514 1; 6515 } 6516 &foo(\@x); 6517 6518making clear how the parameters are actually passed to C<foo>. 6519 6520=item B<-q> 6521 6522Expand double-quoted strings into the corresponding combinations of 6523concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For 6524instance, print 6525 6526 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; 6527 6528as 6529 6530 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' 6531 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); 6532 6533Note that the expanded form represents the way perl handles such 6534constructions internally -- this option actually turns off the reverse 6535translation that B::Deparse usually does. On the other hand, note that 6536C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value 6537of $y into a string before doing the assignment. 6538 6539=item B<-s>I<LETTERS> 6540 6541Tweak the style of B::Deparse's output. The letters should follow 6542directly after the 's', with no space or punctuation. The following 6543options are available: 6544 6545=over 4 6546 6547=item B<C> 6548 6549Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print 6550 6551 if (...) { 6552 ... 6553 } else { 6554 ... 6555 } 6556 6557instead of 6558 6559 if (...) { 6560 ... 6561 } 6562 else { 6563 ... 6564 } 6565 6566The default is not to cuddle. 6567 6568=item B<i>I<NUMBER> 6569 6570Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. 6571 6572=item B<T> 6573 6574Use tabs for each 8 columns of indent. The default is to use only spaces. 6575For instance, if the style options are B<-si4T>, a line that's indented 65763 times will be preceded by one tab and four spaces; if the options were 6577B<-si8T>, the same line would be preceded by three tabs. 6578 6579=item B<v>I<STRING>B<.> 6580 6581Print I<STRING> for the value of a constant that can't be determined 6582because it was optimized away (mnemonic: this happens when a constant 6583is used in B<v>oid context). The end of the string is marked by a period. 6584The string should be a valid perl expression, generally a constant. 6585Note that unless it's a number, it probably needs to be quoted, and on 6586a command line quotes need to be protected from the shell. Some 6587conventional values include 0, 1, 42, '', 'foo', and 6588'Useless use of constant omitted' (which may need to be 6589B<-sv"'Useless use of constant omitted'."> 6590or something similar depending on your shell). The default is '???'. 6591If you're using B::Deparse on a module or other file that's require'd, 6592you shouldn't use a value that evaluates to false, since the customary 6593true constant at the end of a module will be in void context when the 6594file is compiled as a main program. 6595 6596=back 6597 6598=item B<-x>I<LEVEL> 6599 6600Expand conventional syntax constructions into equivalent ones that expose 6601their internal operation. I<LEVEL> should be a digit, with higher values 6602meaning more expansion. As with B<-q>, this actually involves turning off 6603special cases in B::Deparse's normal operations. 6604 6605If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent 6606while loops with continue blocks; for instance 6607 6608 for ($i = 0; $i < 10; ++$i) { 6609 print $i; 6610 } 6611 6612turns into 6613 6614 $i = 0; 6615 while ($i < 10) { 6616 print $i; 6617 } continue { 6618 ++$i 6619 } 6620 6621Note that in a few cases this translation can't be perfectly carried back 6622into the source code -- if the loop's initializer declares a my variable, 6623for instance, it won't have the correct scope outside of the loop. 6624 6625If I<LEVEL> is at least 5, C<use> declarations will be translated into 6626C<BEGIN> blocks containing calls to C<require> and C<import>; for 6627instance, 6628 6629 use strict 'refs'; 6630 6631turns into 6632 6633 sub BEGIN { 6634 require strict; 6635 do { 6636 'strict'->import('refs') 6637 }; 6638 } 6639 6640If I<LEVEL> is at least 7, C<if> statements will be translated into 6641equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance 6642 6643 print 'hi' if $nice; 6644 if ($nice) { 6645 print 'hi'; 6646 } 6647 if ($nice) { 6648 print 'hi'; 6649 } else { 6650 print 'bye'; 6651 } 6652 6653turns into 6654 6655 $nice and print 'hi'; 6656 $nice and do { print 'hi' }; 6657 $nice ? do { print 'hi' } : do { print 'bye' }; 6658 6659Long sequences of elsifs will turn into nested ternary operators, which 6660B::Deparse doesn't know how to indent nicely. 6661 6662=back 6663 6664=head1 USING B::Deparse AS A MODULE 6665 6666=head2 Synopsis 6667 6668 use B::Deparse; 6669 $deparse = B::Deparse->new("-p", "-sC"); 6670 $body = $deparse->coderef2text(\&func); 6671 eval "sub func $body"; # the inverse operation 6672 6673=head2 Description 6674 6675B::Deparse can also be used on a sub-by-sub basis from other perl 6676programs. 6677 6678=head2 new 6679 6680 $deparse = B::Deparse->new(OPTIONS) 6681 6682Create an object to store the state of a deparsing operation and any 6683options. The options are the same as those that can be given on the 6684command line (see L</OPTIONS>); options that are separated by commas 6685after B<-MO=Deparse> should be given as separate strings. 6686 6687=head2 ambient_pragmas 6688 6689 $deparse->ambient_pragmas(strict => 'all', '$[' => $[); 6690 6691The compilation of a subroutine can be affected by a few compiler 6692directives, B<pragmas>. These are: 6693 6694=over 4 6695 6696=item * 6697 6698use strict; 6699 6700=item * 6701 6702use warnings; 6703 6704=item * 6705 6706Assigning to the special variable $[ 6707 6708=item * 6709 6710use integer; 6711 6712=item * 6713 6714use bytes; 6715 6716=item * 6717 6718use utf8; 6719 6720=item * 6721 6722use re; 6723 6724=back 6725 6726Ordinarily, if you use B::Deparse on a subroutine which has 6727been compiled in the presence of one or more of these pragmas, 6728the output will include statements to turn on the appropriate 6729directives. So if you then compile the code returned by coderef2text, 6730it will behave the same way as the subroutine which you deparsed. 6731 6732However, you may know that you intend to use the results in a 6733particular context, where some pragmas are already in scope. In 6734this case, you use the B<ambient_pragmas> method to describe the 6735assumptions you wish to make. 6736 6737Not all of the options currently have any useful effect. See 6738L</BUGS> for more details. 6739 6740The parameters it accepts are: 6741 6742=over 4 6743 6744=item strict 6745 6746Takes a string, possibly containing several values separated 6747by whitespace. The special values "all" and "none" mean what you'd 6748expect. 6749 6750 $deparse->ambient_pragmas(strict => 'subs refs'); 6751 6752=item $[ 6753 6754Takes a number, the value of the array base $[. 6755Obsolete: cannot be non-zero. 6756 6757=item bytes 6758 6759=item utf8 6760 6761=item integer 6762 6763If the value is true, then the appropriate pragma is assumed to 6764be in the ambient scope, otherwise not. 6765 6766=item re 6767 6768Takes a string, possibly containing a whitespace-separated list of 6769values. The values "all" and "none" are special. It's also permissible 6770to pass an array reference here. 6771 6772 $deparser->ambient_pragmas(re => 'eval'); 6773 6774 6775=item warnings 6776 6777Takes a string, possibly containing a whitespace-separated list of 6778values. The values "all" and "none" are special, again. It's also 6779permissible to pass an array reference here. 6780 6781 $deparser->ambient_pragmas(warnings => [qw[void io]]); 6782 6783If one of the values is the string "FATAL", then all the warnings 6784in that list will be considered fatal, just as with the B<warnings> 6785pragma itself. Should you need to specify that some warnings are 6786fatal, and others are merely enabled, you can pass the B<warnings> 6787parameter twice: 6788 6789 $deparser->ambient_pragmas( 6790 warnings => 'all', 6791 warnings => [FATAL => qw/void io/], 6792 ); 6793 6794See L<warnings> for more information about lexical warnings. 6795 6796=item hint_bits 6797 6798=item warning_bits 6799 6800These two parameters are used to specify the ambient pragmas in 6801the format used by the special variables $^H and ${^WARNING_BITS}. 6802 6803They exist principally so that you can write code like: 6804 6805 { my ($hint_bits, $warning_bits); 6806 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} 6807 $deparser->ambient_pragmas ( 6808 hint_bits => $hint_bits, 6809 warning_bits => $warning_bits, 6810 '$[' => 0 + $[ 6811 ); } 6812 6813which specifies that the ambient pragmas are exactly those which 6814are in scope at the point of calling. 6815 6816=item %^H 6817 6818This parameter is used to specify the ambient pragmas which are 6819stored in the special hash %^H. 6820 6821=back 6822 6823=head2 coderef2text 6824 6825 $body = $deparse->coderef2text(\&func) 6826 $body = $deparse->coderef2text(sub ($$) { ... }) 6827 6828Return source code for the body of a subroutine (a block, optionally 6829preceded by a prototype in parens), given a reference to the 6830sub. Because a subroutine can have no names, or more than one name, 6831this method doesn't return a complete subroutine definition -- if you 6832want to eval the result, you should prepend "sub subname ", or "sub " 6833for an anonymous function constructor. Unless the sub was defined in 6834the main:: package, the code will include a package declaration. 6835 6836=head1 BUGS 6837 6838=over 4 6839 6840=item * 6841 6842The only pragmas to 6843be completely supported are: C<use warnings>, 6844C<use strict>, C<use bytes>, C<use integer> 6845and C<use feature>. 6846 6847Excepting those listed above, we're currently unable to guarantee that 6848B::Deparse will produce a pragma at the correct point in the program. 6849(Specifically, pragmas at the beginning of a block often appear right 6850before the start of the block instead.) 6851Since the effects of pragmas are often lexically scoped, this can mean 6852that the pragma holds sway over a different portion of the program 6853than in the input file. 6854 6855=item * 6856 6857In fact, the above is a specific instance of a more general problem: 6858we can't guarantee to produce BEGIN blocks or C<use> declarations in 6859exactly the right place. So if you use a module which affects compilation 6860(such as by over-riding keywords, overloading constants or whatever) 6861then the output code might not work as intended. 6862 6863=item * 6864 6865Some constants don't print correctly either with or without B<-d>. 6866For instance, neither B::Deparse nor Data::Dumper know how to print 6867dual-valued scalars correctly, as in: 6868 6869 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y; 6870 6871 use constant H => { "#" => 1 }; H->{"#"}; 6872 6873=item * 6874 6875An input file that uses source filtering probably won't be deparsed into 6876runnable code, because it will still include the B<use> declaration 6877for the source filtering module, even though the code that is 6878produced is already ordinary Perl which shouldn't be filtered again. 6879 6880=item * 6881 6882Optimized-away statements are rendered as 6883'???'. This includes statements that 6884have a compile-time side-effect, such as the obscure 6885 6886 my $x if 0; 6887 6888which is not, consequently, deparsed correctly. 6889 6890 foreach my $i (@_) { 0 } 6891 => 6892 foreach my $i (@_) { '???' } 6893 6894=item * 6895 6896Lexical (my) variables declared in scopes external to a subroutine 6897appear in coderef2text output text as package variables. This is a tricky 6898problem, as perl has no native facility for referring to a lexical variable 6899defined within a different scope, although L<PadWalker> is a good start. 6900 6901See also L<Data::Dump::Streamer>, which combines B::Deparse and 6902L<PadWalker> to serialize closures properly. 6903 6904=item * 6905 6906There are probably many more bugs on non-ASCII platforms (EBCDIC). 6907 6908=back 6909 6910=head1 AUTHOR 6911 6912Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version 6913by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from 6914Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, 6915Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael 6916Garcia-Suarez. 6917 6918=cut 6919