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