Profile of B/Deparse.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:11 2016

Filename | /usr/share/perl/5.18/B/Deparse.pm
Statements | Executed 111 statements in 25.9ms

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