Profile of B/Deparse.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For bin/dpath
Run on Tue Jun 5 15:30:18 2012
Reported on Tue Jun 5 15:30:47 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/B/Deparse.pm
Statements | Executed 59 statements in 126ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 5.64ms | 6.61ms | B::Deparse::::BEGIN@3436B::Deparse::BEGIN@3436
63 | 2 | 1 | 215µs | 215µs | B::Deparse::::CORE:sortB::Deparse::CORE:sort (opcode)
1 | 1 | 1 | 186µs | 228µs | B::Deparse::::BEGIN@2789B::Deparse::BEGIN@2789
1 | 1 | 1 | 160µs | 160µs | B::Deparse::::BEGIN@34B::Deparse::BEGIN@34
1 | 1 | 1 | 118µs | 130µs | B::Deparse::::BEGIN@2790B::Deparse::BEGIN@2790
1 | 1 | 1 | 114µs | 119µs | B::Deparse::::BEGIN@2791B::Deparse::BEGIN@2791
1 | 1 | 1 | 101µs | 115µs | B::Deparse::::BEGIN@2792B::Deparse::BEGIN@2792
1 | 1 | 1 | 72µs | 72µs | B::Deparse::::BEGIN@2029B::Deparse::BEGIN@2029
1 | 1 | 1 | 64µs | 82µs | B::Deparse::::BEGIN@3629B::Deparse::BEGIN@3629
1 | 1 | 1 | 61µs | 271µs | B::Deparse::::BEGIN@11B::Deparse::BEGIN@11
1 | 1 | 1 | 54µs | 3.65ms | B::Deparse::::BEGIN@12B::Deparse::BEGIN@12
1 | 1 | 1 | 52µs | 52µs | B::Deparse::::BEGIN@1244B::Deparse::BEGIN@1244
1 | 1 | 1 | 48µs | 124µs | B::Deparse::::BEGIN@3368B::Deparse::BEGIN@3368
1 | 1 | 1 | 47µs | 47µs | B::Deparse::::BEGIN@2060B::Deparse::BEGIN@2060
1 | 1 | 1 | 44µs | 113µs | B::Deparse::::BEGIN@482B::Deparse::BEGIN@482
1 | 1 | 1 | 39µs | 69µs | B::Deparse::::BEGIN@3435B::Deparse::BEGIN@3435
1 | 1 | 1 | 35µs | 94µs | B::Deparse::::BEGIN@688B::Deparse::BEGIN@688
1 | 1 | 1 | 34µs | 34µs | B::Deparse::::BEGIN@613B::Deparse::BEGIN@613
1 | 1 | 1 | 34µs | 49µs | B::Deparse::::BEGIN@30B::Deparse::BEGIN@30
1 | 1 | 1 | 30µs | 72µs | B::Deparse::::BEGIN@3369B::Deparse::BEGIN@3369
1 | 1 | 1 | 29µs | 29µs | B::Deparse::::CORE:qrB::Deparse::CORE:qr (opcode)
1 | 1 | 1 | 28µs | 121µs | B::Deparse::::BEGIN@31B::Deparse::BEGIN@31
1 | 1 | 1 | 27µs | 71µs | B::Deparse::::BEGIN@40B::Deparse::BEGIN@40
1 | 1 | 1 | 18µs | 18µs | B::Deparse::::CORE:packB::Deparse::CORE:pack (opcode)
1 | 1 | 1 | 14µs | 14µs | B::Deparse::::BEGIN@32B::Deparse::BEGIN@32
0 | 0 | 0 | 0s | 0s | B::Deparse::::AUTOLOADB::Deparse::AUTOLOAD
0 | 0 | 0 | 0s | 0s | B::Deparse::::DESTROYB::Deparse::DESTROY
0 | 0 | 0 | 0s | 0s | B::Deparse::::WARN_MASKB::Deparse::WARN_MASK
0 | 0 | 0 | 0s | 0s | B::Deparse::::__ANON__[:1146]B::Deparse::__ANON__[:1146]
0 | 0 | 0 | 0s | 0s | B::Deparse::::__ANON__[:1215]B::Deparse::__ANON__[:1215]
0 | 0 | 0 | 0s | 0s | B::Deparse::::__ANON__[:3845]B::Deparse::__ANON__[:3845]
0 | 0 | 0 | 0s | 0s | B::Deparse::::__ANON__[:673]B::Deparse::__ANON__[:673]
0 | 0 | 0 | 0s | 0s | B::Deparse::::__ANON__[:697]B::Deparse::__ANON__[:697]
0 | 0 | 0 | 0s | 0s | B::Deparse::::_methodB::Deparse::_method
0 | 0 | 0 | 0s | 0s | B::Deparse::::ambient_pragmasB::Deparse::ambient_pragmas
0 | 0 | 0 | 0s | 0s | B::Deparse::::anon_hash_or_listB::Deparse::anon_hash_or_list
0 | 0 | 0 | 0s | 0s | B::Deparse::::assoc_classB::Deparse::assoc_class
0 | 0 | 0 | 0s | 0s | B::Deparse::::balanced_delimB::Deparse::balanced_delim
0 | 0 | 0 | 0s | 0s | B::Deparse::::baseopB::Deparse::baseop
0 | 0 | 0 | 0s | 0s | B::Deparse::::begin_is_useB::Deparse::begin_is_use
0 | 0 | 0 | 0s | 0s | B::Deparse::::binopB::Deparse::binop
0 | 0 | 0 | 0s | 0s | B::Deparse::::check_protoB::Deparse::check_proto
0 | 0 | 0 | 0s | 0s | B::Deparse::::coderef2textB::Deparse::coderef2text
0 | 0 | 0 | 0s | 0s | B::Deparse::::collapseB::Deparse::collapse
0 | 0 | 0 | 0s | 0s | B::Deparse::::compileB::Deparse::compile
0 | 0 | 0 | 0s | 0s | B::Deparse::::constB::Deparse::const
0 | 0 | 0 | 0s | 0s | B::Deparse::::const_dumperB::Deparse::const_dumper
0 | 0 | 0 | 0s | 0s | B::Deparse::::const_svB::Deparse::const_sv
0 | 0 | 0 | 0s | 0s | B::Deparse::::cop_subsB::Deparse::cop_subs
0 | 0 | 0 | 0s | 0s | B::Deparse::::declare_hinthashB::Deparse::declare_hinthash
0 | 0 | 0 | 0s | 0s | B::Deparse::::declare_hintsB::Deparse::declare_hints
0 | 0 | 0 | 0s | 0s | B::Deparse::::declare_warningsB::Deparse::declare_warnings
0 | 0 | 0 | 0s | 0s | B::Deparse::::deparseB::Deparse::deparse
0 | 0 | 0 | 0s | 0s | B::Deparse::::deparse_binop_leftB::Deparse::deparse_binop_left
0 | 0 | 0 | 0s | 0s | B::Deparse::::deparse_binop_rightB::Deparse::deparse_binop_right
0 | 0 | 0 | 0s | 0s | B::Deparse::::deparse_formatB::Deparse::deparse_format
0 | 0 | 0 | 0s | 0s | B::Deparse::::deparse_rootB::Deparse::deparse_root
0 | 0 | 0 | 0s | 0s | B::Deparse::::deparse_subB::Deparse::deparse_sub
0 | 0 | 0 | 0s | 0s | B::Deparse::::double_delimB::Deparse::double_delim
0 | 0 | 0 | 0s | 0s | B::Deparse::::dqB::Deparse::dq
0 | 0 | 0 | 0s | 0s | B::Deparse::::dq_unopB::Deparse::dq_unop
0 | 0 | 0 | 0s | 0s | B::Deparse::::dquoteB::Deparse::dquote
0 | 0 | 0 | 0s | 0s | B::Deparse::::e_anoncodeB::Deparse::e_anoncode
0 | 0 | 0 | 0s | 0s | B::Deparse::::e_methodB::Deparse::e_method
0 | 0 | 0 | 0s | 0s | B::Deparse::::elemB::Deparse::elem
0 | 0 | 0 | 0s | 0s | B::Deparse::::elem_or_slice_array_nameB::Deparse::elem_or_slice_array_name
0 | 0 | 0 | 0s | 0s | B::Deparse::::elem_or_slice_single_indexB::Deparse::elem_or_slice_single_index
0 | 0 | 0 | 0s | 0s | B::Deparse::::escape_extended_reB::Deparse::escape_extended_re
0 | 0 | 0 | 0s | 0s | B::Deparse::::escape_strB::Deparse::escape_str
0 | 0 | 0 | 0s | 0s | B::Deparse::::find_scopeB::Deparse::find_scope
0 | 0 | 0 | 0s | 0s | B::Deparse::::find_scope_enB::Deparse::find_scope_en
0 | 0 | 0 | 0s | 0s | B::Deparse::::find_scope_stB::Deparse::find_scope_st
0 | 0 | 0 | 0s | 0s | B::Deparse::::for_loopB::Deparse::for_loop
0 | 0 | 0 | 0s | 0s | B::Deparse::::ftstB::Deparse::ftst
0 | 0 | 0 | 0s | 0s | B::Deparse::::givwhenB::Deparse::givwhen
0 | 0 | 0 | 0s | 0s | B::Deparse::::gv_nameB::Deparse::gv_name
0 | 0 | 0 | 0s | 0s | B::Deparse::::gv_or_padgvB::Deparse::gv_or_padgv
0 | 0 | 0 | 0s | 0s | B::Deparse::::hint_pragmasB::Deparse::hint_pragmas
0 | 0 | 0 | 0s | 0s | B::Deparse::::indentB::Deparse::indent
0 | 0 | 0 | 0s | 0s | B::Deparse::::indiropB::Deparse::indirop
0 | 0 | 0 | 0s | 0s | B::Deparse::::initB::Deparse::init
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_for_loopB::Deparse::is_for_loop
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_ifelse_contB::Deparse::is_ifelse_cont
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_miniwhileB::Deparse::is_miniwhile
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_scalarB::Deparse::is_scalar
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_scopeB::Deparse::is_scope
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_stateB::Deparse::is_state
0 | 0 | 0 | 0s | 0s | B::Deparse::::is_subscriptableB::Deparse::is_subscriptable
0 | 0 | 0 | 0s | 0s | B::Deparse::::lex_in_scopeB::Deparse::lex_in_scope
0 | 0 | 0 | 0s | 0s | B::Deparse::::lineseqB::Deparse::lineseq
0 | 0 | 0 | 0s | 0s | B::Deparse::::list_constB::Deparse::list_const
0 | 0 | 0 | 0s | 0s | B::Deparse::::listopB::Deparse::listop
0 | 0 | 0 | 0s | 0s | B::Deparse::::logassignopB::Deparse::logassignop
0 | 0 | 0 | 0s | 0s | B::Deparse::::logopB::Deparse::logop
0 | 0 | 0 | 0s | 0s | B::Deparse::::loop_commonB::Deparse::loop_common
0 | 0 | 0 | 0s | 0s | B::Deparse::::loopexB::Deparse::loopex
0 | 0 | 0 | 0s | 0s | B::Deparse::::mapopB::Deparse::mapop
0 | 0 | 0 | 0s | 0s | B::Deparse::::matchopB::Deparse::matchop
0 | 0 | 0 | 0s | 0s | B::Deparse::::maybe_localB::Deparse::maybe_local
0 | 0 | 0 | 0s | 0s | B::Deparse::::maybe_myB::Deparse::maybe_my
0 | 0 | 0 | 0s | 0s | B::Deparse::::maybe_parensB::Deparse::maybe_parens
0 | 0 | 0 | 0s | 0s | B::Deparse::::maybe_parens_funcB::Deparse::maybe_parens_func
0 | 0 | 0 | 0s | 0s | B::Deparse::::maybe_parens_unopB::Deparse::maybe_parens_unop
0 | 0 | 0 | 0s | 0s | B::Deparse::::maybe_targmyB::Deparse::maybe_targmy
0 | 0 | 0 | 0s | 0s | B::Deparse::::methodB::Deparse::method
0 | 0 | 0 | 0s | 0s | B::Deparse::::newB::Deparse::new
0 | 0 | 0 | 0s | 0s | B::Deparse::::next_todoB::Deparse::next_todo
0 | 0 | 0 | 0s | 0s | B::Deparse::::nullB::Deparse::null
0 | 0 | 0 | 0s | 0s | B::Deparse::::padanyB::Deparse::padany
0 | 0 | 0 | 0s | 0s | B::Deparse::::padnameB::Deparse::padname
0 | 0 | 0 | 0s | 0s | B::Deparse::::padname_svB::Deparse::padname_sv
0 | 0 | 0 | 0s | 0s | B::Deparse::::padvalB::Deparse::padval
0 | 0 | 0 | 0s | 0s | B::Deparse::::pchrB::Deparse::pchr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pfixopB::Deparse::pfixop
0 | 0 | 0 | 0s | 0s | B::Deparse::::populate_curcvlexB::Deparse::populate_curcvlex
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_aassignB::Deparse::pp_aassign
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_absB::Deparse::pp_abs
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_acceptB::Deparse::pp_accept
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_addB::Deparse::pp_add
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_aeachB::Deparse::pp_aeach
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_aelemB::Deparse::pp_aelem
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_aelemfastB::Deparse::pp_aelemfast
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_akeysB::Deparse::pp_akeys
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_alarmB::Deparse::pp_alarm
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_andB::Deparse::pp_and
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_andassignB::Deparse::pp_andassign
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_anonlistB::Deparse::pp_anonlist
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_asliceB::Deparse::pp_aslice
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_atan2B::Deparse::pp_atan2
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_av2arylenB::Deparse::pp_av2arylen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_avaluesB::Deparse::pp_avalues
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_backtickB::Deparse::pp_backtick
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_bindB::Deparse::pp_bind
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_binmodeB::Deparse::pp_binmode
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_bit_andB::Deparse::pp_bit_and
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_bit_orB::Deparse::pp_bit_or
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_bit_xorB::Deparse::pp_bit_xor
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_blessB::Deparse::pp_bless
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_boolkeysB::Deparse::pp_boolkeys
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_breakB::Deparse::pp_break
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_callerB::Deparse::pp_caller
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chdirB::Deparse::pp_chdir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chmodB::Deparse::pp_chmod
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chompB::Deparse::pp_chomp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chopB::Deparse::pp_chop
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chownB::Deparse::pp_chown
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chrB::Deparse::pp_chr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_chrootB::Deparse::pp_chroot
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_closeB::Deparse::pp_close
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_closedirB::Deparse::pp_closedir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_complementB::Deparse::pp_complement
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_concatB::Deparse::pp_concat
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_cond_exprB::Deparse::pp_cond_expr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_connectB::Deparse::pp_connect
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_constB::Deparse::pp_const
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_continueB::Deparse::pp_continue
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_cosB::Deparse::pp_cos
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_cryptB::Deparse::pp_crypt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dbmcloseB::Deparse::pp_dbmclose
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dbmopenB::Deparse::pp_dbmopen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dbstateB::Deparse::pp_dbstate
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_definedB::Deparse::pp_defined
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_deleteB::Deparse::pp_delete
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dieB::Deparse::pp_die
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_divideB::Deparse::pp_divide
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dofileB::Deparse::pp_dofile
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dorB::Deparse::pp_dor
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dorassignB::Deparse::pp_dorassign
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_dumpB::Deparse::pp_dump
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_eachB::Deparse::pp_each
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_egrentB::Deparse::pp_egrent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ehostentB::Deparse::pp_ehostent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_enetentB::Deparse::pp_enetent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_enterevalB::Deparse::pp_entereval
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_entersubB::Deparse::pp_entersub
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_enterwriteB::Deparse::pp_enterwrite
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_eofB::Deparse::pp_eof
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_eprotoentB::Deparse::pp_eprotoent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_epwentB::Deparse::pp_epwent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_eqB::Deparse::pp_eq
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_eserventB::Deparse::pp_eservent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_execB::Deparse::pp_exec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_existsB::Deparse::pp_exists
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_exitB::Deparse::pp_exit
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_expB::Deparse::pp_exp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_fcntlB::Deparse::pp_fcntl
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_filenoB::Deparse::pp_fileno
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_flockB::Deparse::pp_flock
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_flopB::Deparse::pp_flop
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_forkB::Deparse::pp_fork
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_formlineB::Deparse::pp_formline
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftatimeB::Deparse::pp_ftatime
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftbinaryB::Deparse::pp_ftbinary
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftblkB::Deparse::pp_ftblk
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftchrB::Deparse::pp_ftchr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftctimeB::Deparse::pp_ftctime
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftdirB::Deparse::pp_ftdir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_fteexecB::Deparse::pp_fteexec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_fteownedB::Deparse::pp_fteowned
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftereadB::Deparse::pp_fteread
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftewriteB::Deparse::pp_ftewrite
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftfileB::Deparse::pp_ftfile
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftisB::Deparse::pp_ftis
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftlinkB::Deparse::pp_ftlink
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftmtimeB::Deparse::pp_ftmtime
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftpipeB::Deparse::pp_ftpipe
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftrexecB::Deparse::pp_ftrexec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftrownedB::Deparse::pp_ftrowned
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftrreadB::Deparse::pp_ftrread
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftrwriteB::Deparse::pp_ftrwrite
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftsgidB::Deparse::pp_ftsgid
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftsizeB::Deparse::pp_ftsize
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftsockB::Deparse::pp_ftsock
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftsuidB::Deparse::pp_ftsuid
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftsvtxB::Deparse::pp_ftsvtx
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_fttextB::Deparse::pp_fttext
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftttyB::Deparse::pp_fttty
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ftzeroB::Deparse::pp_ftzero
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_geB::Deparse::pp_ge
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gelemB::Deparse::pp_gelem
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getcB::Deparse::pp_getc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getloginB::Deparse::pp_getlogin
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getpeernameB::Deparse::pp_getpeername
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getpgrpB::Deparse::pp_getpgrp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getppidB::Deparse::pp_getppid
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getpriorityB::Deparse::pp_getpriority
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_getsocknameB::Deparse::pp_getsockname
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ggrentB::Deparse::pp_ggrent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ggrgidB::Deparse::pp_ggrgid
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ggrnamB::Deparse::pp_ggrnam
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ghbyaddrB::Deparse::pp_ghbyaddr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ghbynameB::Deparse::pp_ghbyname
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ghostentB::Deparse::pp_ghostent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_globB::Deparse::pp_glob
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gmtimeB::Deparse::pp_gmtime
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gnbyaddrB::Deparse::pp_gnbyaddr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gnbynameB::Deparse::pp_gnbyname
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gnetentB::Deparse::pp_gnetent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gotoB::Deparse::pp_goto
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gpbynameB::Deparse::pp_gpbyname
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gpbynumberB::Deparse::pp_gpbynumber
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gprotoentB::Deparse::pp_gprotoent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gpwentB::Deparse::pp_gpwent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gpwnamB::Deparse::pp_gpwnam
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gpwuidB::Deparse::pp_gpwuid
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_grepstartB::Deparse::pp_grepstart
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_grepwhileB::Deparse::pp_grepwhile
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gsbynameB::Deparse::pp_gsbyname
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gsbyportB::Deparse::pp_gsbyport
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gserventB::Deparse::pp_gservent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gsockoptB::Deparse::pp_gsockopt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gtB::Deparse::pp_gt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gvB::Deparse::pp_gv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_gvsvB::Deparse::pp_gvsv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_helemB::Deparse::pp_helem
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_hexB::Deparse::pp_hex
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_hsliceB::Deparse::pp_hslice
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_addB::Deparse::pp_i_add
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_divideB::Deparse::pp_i_divide
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_eqB::Deparse::pp_i_eq
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_geB::Deparse::pp_i_ge
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_gtB::Deparse::pp_i_gt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_leB::Deparse::pp_i_le
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_ltB::Deparse::pp_i_lt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_moduloB::Deparse::pp_i_modulo
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_multiplyB::Deparse::pp_i_multiply
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_ncmpB::Deparse::pp_i_ncmp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_neB::Deparse::pp_i_ne
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_negateB::Deparse::pp_i_negate
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_postdecB::Deparse::pp_i_postdec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_postincB::Deparse::pp_i_postinc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_predecB::Deparse::pp_i_predec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_preincB::Deparse::pp_i_preinc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_i_subtractB::Deparse::pp_i_subtract
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_indexB::Deparse::pp_index
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_intB::Deparse::pp_int
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ioctlB::Deparse::pp_ioctl
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_joinB::Deparse::pp_join
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_keysB::Deparse::pp_keys
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_killB::Deparse::pp_kill
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lastB::Deparse::pp_last
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lcB::Deparse::pp_lc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lcfirstB::Deparse::pp_lcfirst
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_leB::Deparse::pp_le
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_leaveB::Deparse::pp_leave
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_leavegivenB::Deparse::pp_leavegiven
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_leaveloopB::Deparse::pp_leaveloop
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_leavetryB::Deparse::pp_leavetry
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_leavewhenB::Deparse::pp_leavewhen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_left_shiftB::Deparse::pp_left_shift
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lengthB::Deparse::pp_length
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lineseqB::Deparse::pp_lineseq
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_linkB::Deparse::pp_link
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_listB::Deparse::pp_list
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_listenB::Deparse::pp_listen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_localtimeB::Deparse::pp_localtime
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lockB::Deparse::pp_lock
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_logB::Deparse::pp_log
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lsliceB::Deparse::pp_lslice
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_lstatB::Deparse::pp_lstat
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ltB::Deparse::pp_lt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_mapstartB::Deparse::pp_mapstart
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_mapwhileB::Deparse::pp_mapwhile
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_matchB::Deparse::pp_match
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_mkdirB::Deparse::pp_mkdir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_moduloB::Deparse::pp_modulo
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_msgctlB::Deparse::pp_msgctl
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_msggetB::Deparse::pp_msgget
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_msgrcvB::Deparse::pp_msgrcv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_msgsndB::Deparse::pp_msgsnd
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_multiplyB::Deparse::pp_multiply
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ncmpB::Deparse::pp_ncmp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_neB::Deparse::pp_ne
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_negateB::Deparse::pp_negate
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_nextB::Deparse::pp_next
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_nextstateB::Deparse::pp_nextstate
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_notB::Deparse::pp_not
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_nullB::Deparse::pp_null
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_octB::Deparse::pp_oct
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_onceB::Deparse::pp_once
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_openB::Deparse::pp_open
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_open_dirB::Deparse::pp_open_dir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_orB::Deparse::pp_or
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_orassignB::Deparse::pp_orassign
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ordB::Deparse::pp_ord
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_packB::Deparse::pp_pack
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_padavB::Deparse::pp_padav
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_padhvB::Deparse::pp_padhv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_padsvB::Deparse::pp_padsv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_pipe_opB::Deparse::pp_pipe_op
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_popB::Deparse::pp_pop
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_posB::Deparse::pp_pos
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_postdecB::Deparse::pp_postdec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_postincB::Deparse::pp_postinc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_powB::Deparse::pp_pow
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_predecB::Deparse::pp_predec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_preincB::Deparse::pp_preinc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_printB::Deparse::pp_print
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_prototypeB::Deparse::pp_prototype
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_prtfB::Deparse::pp_prtf
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_pushB::Deparse::pp_push
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_pushreB::Deparse::pp_pushre
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_qrB::Deparse::pp_qr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_quotemetaB::Deparse::pp_quotemeta
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_randB::Deparse::pp_rand
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rcatlineB::Deparse::pp_rcatline
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_readB::Deparse::pp_read
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_readdirB::Deparse::pp_readdir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_readlineB::Deparse::pp_readline
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_readlinkB::Deparse::pp_readlink
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_recvB::Deparse::pp_recv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_redoB::Deparse::pp_redo
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_refB::Deparse::pp_ref
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_refgenB::Deparse::pp_refgen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_regcompB::Deparse::pp_regcomp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_renameB::Deparse::pp_rename
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_repeatB::Deparse::pp_repeat
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_requireB::Deparse::pp_require
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_resetB::Deparse::pp_reset
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_returnB::Deparse::pp_return
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_reverseB::Deparse::pp_reverse
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rewinddirB::Deparse::pp_rewinddir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_right_shiftB::Deparse::pp_right_shift
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rindexB::Deparse::pp_rindex
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rmdirB::Deparse::pp_rmdir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rv2avB::Deparse::pp_rv2av
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rv2cvB::Deparse::pp_rv2cv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rv2gvB::Deparse::pp_rv2gv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rv2hvB::Deparse::pp_rv2hv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_rv2svB::Deparse::pp_rv2sv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sassignB::Deparse::pp_sassign
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sayB::Deparse::pp_say
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_scalarB::Deparse::pp_scalar
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_schompB::Deparse::pp_schomp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_schopB::Deparse::pp_schop
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_scmpB::Deparse::pp_scmp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_scopeB::Deparse::pp_scope
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_seekB::Deparse::pp_seek
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_seekdirB::Deparse::pp_seekdir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_selectB::Deparse::pp_select
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_semctlB::Deparse::pp_semctl
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_semgetB::Deparse::pp_semget
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_semopB::Deparse::pp_semop
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sendB::Deparse::pp_send
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_seqB::Deparse::pp_seq
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_setpgrpB::Deparse::pp_setpgrp
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_setpriorityB::Deparse::pp_setpriority
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_setstateB::Deparse::pp_setstate
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sgeB::Deparse::pp_sge
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sgrentB::Deparse::pp_sgrent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sgtB::Deparse::pp_sgt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shiftB::Deparse::pp_shift
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shmctlB::Deparse::pp_shmctl
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shmgetB::Deparse::pp_shmget
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shmreadB::Deparse::pp_shmread
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shmwriteB::Deparse::pp_shmwrite
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shostentB::Deparse::pp_shostent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_shutdownB::Deparse::pp_shutdown
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sinB::Deparse::pp_sin
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sleB::Deparse::pp_sle
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sleepB::Deparse::pp_sleep
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sltB::Deparse::pp_slt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_smartmatchB::Deparse::pp_smartmatch
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sneB::Deparse::pp_sne
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_snetentB::Deparse::pp_snetent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_socketB::Deparse::pp_socket
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sockpairB::Deparse::pp_sockpair
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sortB::Deparse::pp_sort
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_spliceB::Deparse::pp_splice
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_splitB::Deparse::pp_split
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sprintfB::Deparse::pp_sprintf
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sprotoentB::Deparse::pp_sprotoent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_spwentB::Deparse::pp_spwent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sqrtB::Deparse::pp_sqrt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_srandB::Deparse::pp_srand
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_srefgenB::Deparse::pp_srefgen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sselectB::Deparse::pp_sselect
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sserventB::Deparse::pp_sservent
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ssockoptB::Deparse::pp_ssockopt
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_statB::Deparse::pp_stat
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_stringifyB::Deparse::pp_stringify
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_stubB::Deparse::pp_stub
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_studyB::Deparse::pp_study
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_substB::Deparse::pp_subst
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_substrB::Deparse::pp_substr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_subtractB::Deparse::pp_subtract
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_symlinkB::Deparse::pp_symlink
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_syscallB::Deparse::pp_syscall
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sysopenB::Deparse::pp_sysopen
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sysreadB::Deparse::pp_sysread
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_sysseekB::Deparse::pp_sysseek
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_systemB::Deparse::pp_system
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_syswriteB::Deparse::pp_syswrite
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_tellB::Deparse::pp_tell
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_telldirB::Deparse::pp_telldir
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_threadsvB::Deparse::pp_threadsv
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_tieB::Deparse::pp_tie
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_tiedB::Deparse::pp_tied
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_timeB::Deparse::pp_time
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_tmsB::Deparse::pp_tms
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_transB::Deparse::pp_trans
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_transrB::Deparse::pp_transr
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_truncateB::Deparse::pp_truncate
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ucB::Deparse::pp_uc
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_ucfirstB::Deparse::pp_ucfirst
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_umaskB::Deparse::pp_umask
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_undefB::Deparse::pp_undef
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_unlinkB::Deparse::pp_unlink
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_unpackB::Deparse::pp_unpack
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_unshiftB::Deparse::pp_unshift
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_unstackB::Deparse::pp_unstack
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_untieB::Deparse::pp_untie
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_utimeB::Deparse::pp_utime
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_valuesB::Deparse::pp_values
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_vecB::Deparse::pp_vec
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_waitB::Deparse::pp_wait
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_waitpidB::Deparse::pp_waitpid
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_wantarrayB::Deparse::pp_wantarray
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_warnB::Deparse::pp_warn
0 | 0 | 0 | 0s | 0s | B::Deparse::::pp_xorB::Deparse::pp_xor
0 | 0 | 0 | 0s | 0s | B::Deparse::::print_protosB::Deparse::print_protos
0 | 0 | 0 | 0s | 0s | B::Deparse::::pure_stringB::Deparse::pure_string
0 | 0 | 0 | 0s | 0s | B::Deparse::::rangeB::Deparse::range
0 | 0 | 0 | 0s | 0s | B::Deparse::::re_dqB::Deparse::re_dq
0 | 0 | 0 | 0s | 0s | B::Deparse::::re_dq_disambiguateB::Deparse::re_dq_disambiguate
0 | 0 | 0 | 0s | 0s | B::Deparse::::re_unbackB::Deparse::re_unback
0 | 0 | 0 | 0s | 0s | B::Deparse::::re_uninterpB::Deparse::re_uninterp
0 | 0 | 0 | 0s | 0s | B::Deparse::::re_uninterp_extendedB::Deparse::re_uninterp_extended
0 | 0 | 0 | 0s | 0s | B::Deparse::::real_concatB::Deparse::real_concat
0 | 0 | 0 | 0s | 0s | B::Deparse::::real_negateB::Deparse::real_negate
0 | 0 | 0 | 0s | 0s | B::Deparse::::regcompB::Deparse::regcomp
0 | 0 | 0 | 0s | 0s | B::Deparse::::rv2xB::Deparse::rv2x
0 | 0 | 0 | 0s | 0s | B::Deparse::::scopeopB::Deparse::scopeop
0 | 0 | 0 | 0s | 0s | B::Deparse::::seq_subsB::Deparse::seq_subs
0 | 0 | 0 | 0s | 0s | B::Deparse::::single_delimB::Deparse::single_delim
0 | 0 | 0 | 0s | 0s | B::Deparse::::sliceB::Deparse::slice
0 | 0 | 0 | 0s | 0s | B::Deparse::::split_floatB::Deparse::split_float
0 | 0 | 0 | 0s | 0s | B::Deparse::::stash_subsB::Deparse::stash_subs
0 | 0 | 0 | 0s | 0s | B::Deparse::::stash_variableB::Deparse::stash_variable
0 | 0 | 0 | 0s | 0s | B::Deparse::::style_optsB::Deparse::style_opts
0 | 0 | 0 | 0s | 0s | B::Deparse::::todoB::Deparse::todo
0 | 0 | 0 | 0s | 0s | B::Deparse::::tr_chrB::Deparse::tr_chr
0 | 0 | 0 | 0s | 0s | B::Deparse::::tr_decode_byteB::Deparse::tr_decode_byte
0 | 0 | 0 | 0s | 0s | B::Deparse::::tr_decode_utf8B::Deparse::tr_decode_utf8
0 | 0 | 0 | 0s | 0s | B::Deparse::::unbackB::Deparse::unback
0 | 0 | 0 | 0s | 0s | B::Deparse::::uninterpB::Deparse::uninterp
0 | 0 | 0 | 0s | 0s | B::Deparse::::unopB::Deparse::unop
0 | 0 | 0 | 0s | 0s | B::Deparse::::walk_lineseqB::Deparse::walk_lineseq
0 | 0 | 0 | 0s | 0s | B::Deparse::::want_listB::Deparse::want_list
0 | 0 | 0 | 0s | 0s | B::Deparse::::want_scalarB::Deparse::want_scalar

Call graph for these subroutines as a Graphviz dot language file.

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