← 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
StatementsExecuted 111 statements in 25.9ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111166µs181µsB::Deparse::::BEGIN@3201B::Deparse::BEGIN@3201
11176µs4.99msB::Deparse::::BEGIN@29B::Deparse::BEGIN@29
11121µs32µsB::Deparse::::BEGIN@595B::Deparse::BEGIN@595
642118µs18µsB::Deparse::::CORE:sortB::Deparse::CORE:sort (opcode)
11114µs14µsB::Deparse::::BEGIN@2383B::Deparse::BEGIN@2383
11112µs12µsB::Deparse::::BEGIN@2414B::Deparse::BEGIN@2414
11110µs40µsB::Deparse::::BEGIN@11B::Deparse::BEGIN@11
11110µs10µsB::Deparse::::BEGIN@1383B::Deparse::BEGIN@1383
11110µs24µsB::Deparse::::BEGIN@1998B::Deparse::BEGIN@1998
11110µs20µsB::Deparse::::BEGIN@4170B::Deparse::BEGIN@4170
11110µs27µsB::Deparse::::BEGIN@3802B::Deparse::BEGIN@3802
1118µs24µsB::Deparse::::BEGIN@3871B::Deparse::BEGIN@3871
1118µs22µsB::Deparse::::BEGIN@3803B::Deparse::BEGIN@3803
1118µs614µsB::Deparse::::BEGIN@12B::Deparse::BEGIN@12
1118µs12µsB::Deparse::::BEGIN@3870B::Deparse::BEGIN@3870
1117µs28µsB::Deparse::::BEGIN@25B::Deparse::BEGIN@25
1117µs16µsB::Deparse::::BEGIN@807B::Deparse::BEGIN@807
1116µs15µsB::Deparse::::BEGIN@39B::Deparse::BEGIN@39
1116µs6µsB::Deparse::::BEGIN@728B::Deparse::BEGIN@728
1116µs14µsB::Deparse::::BEGIN@24B::Deparse::BEGIN@24
1114µs4µsB::Deparse::::BEGIN@4064B::Deparse::BEGIN@4064
1114µs4µsB::Deparse::::CORE:qrB::Deparse::CORE:qr (opcode)
1112µs2µsB::Deparse::::BEGIN@26B::Deparse::BEGIN@26
0000s0sB::Deparse::::AUTOLOADB::Deparse::AUTOLOAD
0000s0sB::Deparse::::DESTROYB::Deparse::DESTROY
0000s0sB::Deparse::::WARN_MASKB::Deparse::WARN_MASK
0000s0sB::Deparse::::__ANON__[:1283]B::Deparse::__ANON__[:1283]
0000s0sB::Deparse::::__ANON__[:1354]B::Deparse::__ANON__[:1354]
0000s0sB::Deparse::::__ANON__[:3880]B::Deparse::__ANON__[:3880]
0000s0sB::Deparse::::__ANON__[:4295]B::Deparse::__ANON__[:4295]
0000s0sB::Deparse::::__ANON__[:788]B::Deparse::__ANON__[:788]
0000s0sB::Deparse::::__ANON__[:816]B::Deparse::__ANON__[:816]
0000s0sB::Deparse::::_features_from_bundleB::Deparse::_features_from_bundle
0000s0sB::Deparse::::_methodB::Deparse::_method
0000s0sB::Deparse::::_pessimise_walkB::Deparse::_pessimise_walk
0000s0sB::Deparse::::_pessimise_walk_exeB::Deparse::_pessimise_walk_exe
0000s0sB::Deparse::::ambient_pragmasB::Deparse::ambient_pragmas
0000s0sB::Deparse::::anon_hash_or_listB::Deparse::anon_hash_or_list
0000s0sB::Deparse::::assoc_classB::Deparse::assoc_class
0000s0sB::Deparse::::balanced_delimB::Deparse::balanced_delim
0000s0sB::Deparse::::baseopB::Deparse::baseop
0000s0sB::Deparse::::begin_is_useB::Deparse::begin_is_use
0000s0sB::Deparse::::binopB::Deparse::binop
0000s0sB::Deparse::::check_protoB::Deparse::check_proto
0000s0sB::Deparse::::coderef2textB::Deparse::coderef2text
0000s0sB::Deparse::::collapseB::Deparse::collapse
0000s0sB::Deparse::::compileB::Deparse::compile
0000s0sB::Deparse::::constB::Deparse::const
0000s0sB::Deparse::::const_dumperB::Deparse::const_dumper
0000s0sB::Deparse::::const_svB::Deparse::const_sv
0000s0sB::Deparse::::cop_subsB::Deparse::cop_subs
0000s0sB::Deparse::::declare_hinthashB::Deparse::declare_hinthash
0000s0sB::Deparse::::declare_hintsB::Deparse::declare_hints
0000s0sB::Deparse::::declare_warningsB::Deparse::declare_warnings
0000s0sB::Deparse::::deparseB::Deparse::deparse
0000s0sB::Deparse::::deparse_binop_leftB::Deparse::deparse_binop_left
0000s0sB::Deparse::::deparse_binop_rightB::Deparse::deparse_binop_right
0000s0sB::Deparse::::deparse_formatB::Deparse::deparse_format
0000s0sB::Deparse::::deparse_rootB::Deparse::deparse_root
0000s0sB::Deparse::::deparse_subB::Deparse::deparse_sub
0000s0sB::Deparse::::double_delimB::Deparse::double_delim
0000s0sB::Deparse::::dqB::Deparse::dq
0000s0sB::Deparse::::dq_unopB::Deparse::dq_unop
0000s0sB::Deparse::::dquoteB::Deparse::dquote
0000s0sB::Deparse::::e_anoncodeB::Deparse::e_anoncode
0000s0sB::Deparse::::e_methodB::Deparse::e_method
0000s0sB::Deparse::::elemB::Deparse::elem
0000s0sB::Deparse::::elem_or_slice_array_nameB::Deparse::elem_or_slice_array_name
0000s0sB::Deparse::::elem_or_slice_single_indexB::Deparse::elem_or_slice_single_index
0000s0sB::Deparse::::escape_extended_reB::Deparse::escape_extended_re
0000s0sB::Deparse::::escape_strB::Deparse::escape_str
0000s0sB::Deparse::::find_scopeB::Deparse::find_scope
0000s0sB::Deparse::::find_scope_enB::Deparse::find_scope_en
0000s0sB::Deparse::::find_scope_stB::Deparse::find_scope_st
0000s0sB::Deparse::::for_loopB::Deparse::for_loop
0000s0sB::Deparse::::ftstB::Deparse::ftst
0000s0sB::Deparse::::givwhenB::Deparse::givwhen
0000s0sB::Deparse::::gv_nameB::Deparse::gv_name
0000s0sB::Deparse::::gv_or_padgvB::Deparse::gv_or_padgv
0000s0sB::Deparse::::hint_pragmasB::Deparse::hint_pragmas
0000s0sB::Deparse::::indentB::Deparse::indent
0000s0sB::Deparse::::indiropB::Deparse::indirop
0000s0sB::Deparse::::initB::Deparse::init
0000s0sB::Deparse::::is_for_loopB::Deparse::is_for_loop
0000s0sB::Deparse::::is_ifelse_contB::Deparse::is_ifelse_cont
0000s0sB::Deparse::::is_lexical_subsB::Deparse::is_lexical_subs
0000s0sB::Deparse::::is_miniwhileB::Deparse::is_miniwhile
0000s0sB::Deparse::::is_scalarB::Deparse::is_scalar
0000s0sB::Deparse::::is_scopeB::Deparse::is_scope
0000s0sB::Deparse::::is_stateB::Deparse::is_state
0000s0sB::Deparse::::is_subscriptableB::Deparse::is_subscriptable
0000s0sB::Deparse::::keywordB::Deparse::keyword
0000s0sB::Deparse::::lex_in_scopeB::Deparse::lex_in_scope
0000s0sB::Deparse::::lineseqB::Deparse::lineseq
0000s0sB::Deparse::::list_constB::Deparse::list_const
0000s0sB::Deparse::::listopB::Deparse::listop
0000s0sB::Deparse::::logassignopB::Deparse::logassignop
0000s0sB::Deparse::::logopB::Deparse::logop
0000s0sB::Deparse::::loop_commonB::Deparse::loop_common
0000s0sB::Deparse::::loopexB::Deparse::loopex
0000s0sB::Deparse::::mapopB::Deparse::mapop
0000s0sB::Deparse::::matchopB::Deparse::matchop
0000s0sB::Deparse::::maybe_localB::Deparse::maybe_local
0000s0sB::Deparse::::maybe_myB::Deparse::maybe_my
0000s0sB::Deparse::::maybe_parensB::Deparse::maybe_parens
0000s0sB::Deparse::::maybe_parens_funcB::Deparse::maybe_parens_func
0000s0sB::Deparse::::maybe_parens_unopB::Deparse::maybe_parens_unop
0000s0sB::Deparse::::maybe_qualifyB::Deparse::maybe_qualify
0000s0sB::Deparse::::maybe_targmyB::Deparse::maybe_targmy
0000s0sB::Deparse::::methodB::Deparse::method
0000s0sB::Deparse::::newB::Deparse::new
0000s0sB::Deparse::::next_todoB::Deparse::next_todo
0000s0sB::Deparse::::nullB::Deparse::null
0000s0sB::Deparse::::padanyB::Deparse::padany
0000s0sB::Deparse::::padnameB::Deparse::padname
0000s0sB::Deparse::::padname_svB::Deparse::padname_sv
0000s0sB::Deparse::::padvalB::Deparse::padval
0000s0sB::Deparse::::pchrB::Deparse::pchr
0000s0sB::Deparse::::pessimiseB::Deparse::pessimise
0000s0sB::Deparse::::pfixopB::Deparse::pfixop
0000s0sB::Deparse::::populate_curcvlexB::Deparse::populate_curcvlex
0000s0sB::Deparse::::pp_aassignB::Deparse::pp_aassign
0000s0sB::Deparse::::pp_absB::Deparse::pp_abs
0000s0sB::Deparse::::pp_acceptB::Deparse::pp_accept
0000s0sB::Deparse::::pp_addB::Deparse::pp_add
0000s0sB::Deparse::::pp_aeachB::Deparse::pp_aeach
0000s0sB::Deparse::::pp_aelemB::Deparse::pp_aelem
0000s0sB::Deparse::::pp_aelemfastB::Deparse::pp_aelemfast
0000s0sB::Deparse::::pp_aelemfast_lexB::Deparse::pp_aelemfast_lex
0000s0sB::Deparse::::pp_akeysB::Deparse::pp_akeys
0000s0sB::Deparse::::pp_alarmB::Deparse::pp_alarm
0000s0sB::Deparse::::pp_andB::Deparse::pp_and
0000s0sB::Deparse::::pp_andassignB::Deparse::pp_andassign
0000s0sB::Deparse::::pp_anonlistB::Deparse::pp_anonlist
0000s0sB::Deparse::::pp_asliceB::Deparse::pp_aslice
0000s0sB::Deparse::::pp_atan2B::Deparse::pp_atan2
0000s0sB::Deparse::::pp_av2arylenB::Deparse::pp_av2arylen
0000s0sB::Deparse::::pp_avaluesB::Deparse::pp_avalues
0000s0sB::Deparse::::pp_backtickB::Deparse::pp_backtick
0000s0sB::Deparse::::pp_bindB::Deparse::pp_bind
0000s0sB::Deparse::::pp_binmodeB::Deparse::pp_binmode
0000s0sB::Deparse::::pp_bit_andB::Deparse::pp_bit_and
0000s0sB::Deparse::::pp_bit_orB::Deparse::pp_bit_or
0000s0sB::Deparse::::pp_bit_xorB::Deparse::pp_bit_xor
0000s0sB::Deparse::::pp_blessB::Deparse::pp_bless
0000s0sB::Deparse::::pp_boolkeysB::Deparse::pp_boolkeys
0000s0sB::Deparse::::pp_breakB::Deparse::pp_break
0000s0sB::Deparse::::pp_callerB::Deparse::pp_caller
0000s0sB::Deparse::::pp_chdirB::Deparse::pp_chdir
0000s0sB::Deparse::::pp_chmodB::Deparse::pp_chmod
0000s0sB::Deparse::::pp_chompB::Deparse::pp_chomp
0000s0sB::Deparse::::pp_chopB::Deparse::pp_chop
0000s0sB::Deparse::::pp_chownB::Deparse::pp_chown
0000s0sB::Deparse::::pp_chrB::Deparse::pp_chr
0000s0sB::Deparse::::pp_chrootB::Deparse::pp_chroot
0000s0sB::Deparse::::pp_clonecvB::Deparse::pp_clonecv
0000s0sB::Deparse::::pp_closeB::Deparse::pp_close
0000s0sB::Deparse::::pp_closedirB::Deparse::pp_closedir
0000s0sB::Deparse::::pp_complementB::Deparse::pp_complement
0000s0sB::Deparse::::pp_concatB::Deparse::pp_concat
0000s0sB::Deparse::::pp_cond_exprB::Deparse::pp_cond_expr
0000s0sB::Deparse::::pp_connectB::Deparse::pp_connect
0000s0sB::Deparse::::pp_constB::Deparse::pp_const
0000s0sB::Deparse::::pp_continueB::Deparse::pp_continue
0000s0sB::Deparse::::pp_cosB::Deparse::pp_cos
0000s0sB::Deparse::::pp_cryptB::Deparse::pp_crypt
0000s0sB::Deparse::::pp_dbmcloseB::Deparse::pp_dbmclose
0000s0sB::Deparse::::pp_dbmopenB::Deparse::pp_dbmopen
0000s0sB::Deparse::::pp_dbstateB::Deparse::pp_dbstate
0000s0sB::Deparse::::pp_definedB::Deparse::pp_defined
0000s0sB::Deparse::::pp_deleteB::Deparse::pp_delete
0000s0sB::Deparse::::pp_dieB::Deparse::pp_die
0000s0sB::Deparse::::pp_divideB::Deparse::pp_divide
0000s0sB::Deparse::::pp_dofileB::Deparse::pp_dofile
0000s0sB::Deparse::::pp_dorB::Deparse::pp_dor
0000s0sB::Deparse::::pp_dorassignB::Deparse::pp_dorassign
0000s0sB::Deparse::::pp_dumpB::Deparse::pp_dump
0000s0sB::Deparse::::pp_eachB::Deparse::pp_each
0000s0sB::Deparse::::pp_egrentB::Deparse::pp_egrent
0000s0sB::Deparse::::pp_ehostentB::Deparse::pp_ehostent
0000s0sB::Deparse::::pp_enetentB::Deparse::pp_enetent
0000s0sB::Deparse::::pp_enterevalB::Deparse::pp_entereval
0000s0sB::Deparse::::pp_entersubB::Deparse::pp_entersub
0000s0sB::Deparse::::pp_enterwriteB::Deparse::pp_enterwrite
0000s0sB::Deparse::::pp_eofB::Deparse::pp_eof
0000s0sB::Deparse::::pp_eprotoentB::Deparse::pp_eprotoent
0000s0sB::Deparse::::pp_epwentB::Deparse::pp_epwent
0000s0sB::Deparse::::pp_eqB::Deparse::pp_eq
0000s0sB::Deparse::::pp_eserventB::Deparse::pp_eservent
0000s0sB::Deparse::::pp_execB::Deparse::pp_exec
0000s0sB::Deparse::::pp_existsB::Deparse::pp_exists
0000s0sB::Deparse::::pp_exitB::Deparse::pp_exit
0000s0sB::Deparse::::pp_expB::Deparse::pp_exp
0000s0sB::Deparse::::pp_fcB::Deparse::pp_fc
0000s0sB::Deparse::::pp_fcntlB::Deparse::pp_fcntl
0000s0sB::Deparse::::pp_filenoB::Deparse::pp_fileno
0000s0sB::Deparse::::pp_flockB::Deparse::pp_flock
0000s0sB::Deparse::::pp_flopB::Deparse::pp_flop
0000s0sB::Deparse::::pp_forkB::Deparse::pp_fork
0000s0sB::Deparse::::pp_formlineB::Deparse::pp_formline
0000s0sB::Deparse::::pp_ftatimeB::Deparse::pp_ftatime
0000s0sB::Deparse::::pp_ftbinaryB::Deparse::pp_ftbinary
0000s0sB::Deparse::::pp_ftblkB::Deparse::pp_ftblk
0000s0sB::Deparse::::pp_ftchrB::Deparse::pp_ftchr
0000s0sB::Deparse::::pp_ftctimeB::Deparse::pp_ftctime
0000s0sB::Deparse::::pp_ftdirB::Deparse::pp_ftdir
0000s0sB::Deparse::::pp_fteexecB::Deparse::pp_fteexec
0000s0sB::Deparse::::pp_fteownedB::Deparse::pp_fteowned
0000s0sB::Deparse::::pp_ftereadB::Deparse::pp_fteread
0000s0sB::Deparse::::pp_ftewriteB::Deparse::pp_ftewrite
0000s0sB::Deparse::::pp_ftfileB::Deparse::pp_ftfile
0000s0sB::Deparse::::pp_ftisB::Deparse::pp_ftis
0000s0sB::Deparse::::pp_ftlinkB::Deparse::pp_ftlink
0000s0sB::Deparse::::pp_ftmtimeB::Deparse::pp_ftmtime
0000s0sB::Deparse::::pp_ftpipeB::Deparse::pp_ftpipe
0000s0sB::Deparse::::pp_ftrexecB::Deparse::pp_ftrexec
0000s0sB::Deparse::::pp_ftrownedB::Deparse::pp_ftrowned
0000s0sB::Deparse::::pp_ftrreadB::Deparse::pp_ftrread
0000s0sB::Deparse::::pp_ftrwriteB::Deparse::pp_ftrwrite
0000s0sB::Deparse::::pp_ftsgidB::Deparse::pp_ftsgid
0000s0sB::Deparse::::pp_ftsizeB::Deparse::pp_ftsize
0000s0sB::Deparse::::pp_ftsockB::Deparse::pp_ftsock
0000s0sB::Deparse::::pp_ftsuidB::Deparse::pp_ftsuid
0000s0sB::Deparse::::pp_ftsvtxB::Deparse::pp_ftsvtx
0000s0sB::Deparse::::pp_fttextB::Deparse::pp_fttext
0000s0sB::Deparse::::pp_ftttyB::Deparse::pp_fttty
0000s0sB::Deparse::::pp_ftzeroB::Deparse::pp_ftzero
0000s0sB::Deparse::::pp_geB::Deparse::pp_ge
0000s0sB::Deparse::::pp_gelemB::Deparse::pp_gelem
0000s0sB::Deparse::::pp_getcB::Deparse::pp_getc
0000s0sB::Deparse::::pp_getloginB::Deparse::pp_getlogin
0000s0sB::Deparse::::pp_getpeernameB::Deparse::pp_getpeername
0000s0sB::Deparse::::pp_getpgrpB::Deparse::pp_getpgrp
0000s0sB::Deparse::::pp_getppidB::Deparse::pp_getppid
0000s0sB::Deparse::::pp_getpriorityB::Deparse::pp_getpriority
0000s0sB::Deparse::::pp_getsocknameB::Deparse::pp_getsockname
0000s0sB::Deparse::::pp_ggrentB::Deparse::pp_ggrent
0000s0sB::Deparse::::pp_ggrgidB::Deparse::pp_ggrgid
0000s0sB::Deparse::::pp_ggrnamB::Deparse::pp_ggrnam
0000s0sB::Deparse::::pp_ghbyaddrB::Deparse::pp_ghbyaddr
0000s0sB::Deparse::::pp_ghbynameB::Deparse::pp_ghbyname
0000s0sB::Deparse::::pp_ghostentB::Deparse::pp_ghostent
0000s0sB::Deparse::::pp_globB::Deparse::pp_glob
0000s0sB::Deparse::::pp_gmtimeB::Deparse::pp_gmtime
0000s0sB::Deparse::::pp_gnbyaddrB::Deparse::pp_gnbyaddr
0000s0sB::Deparse::::pp_gnbynameB::Deparse::pp_gnbyname
0000s0sB::Deparse::::pp_gnetentB::Deparse::pp_gnetent
0000s0sB::Deparse::::pp_gotoB::Deparse::pp_goto
0000s0sB::Deparse::::pp_gpbynameB::Deparse::pp_gpbyname
0000s0sB::Deparse::::pp_gpbynumberB::Deparse::pp_gpbynumber
0000s0sB::Deparse::::pp_gprotoentB::Deparse::pp_gprotoent
0000s0sB::Deparse::::pp_gpwentB::Deparse::pp_gpwent
0000s0sB::Deparse::::pp_gpwnamB::Deparse::pp_gpwnam
0000s0sB::Deparse::::pp_gpwuidB::Deparse::pp_gpwuid
0000s0sB::Deparse::::pp_grepstartB::Deparse::pp_grepstart
0000s0sB::Deparse::::pp_grepwhileB::Deparse::pp_grepwhile
0000s0sB::Deparse::::pp_gsbynameB::Deparse::pp_gsbyname
0000s0sB::Deparse::::pp_gsbyportB::Deparse::pp_gsbyport
0000s0sB::Deparse::::pp_gserventB::Deparse::pp_gservent
0000s0sB::Deparse::::pp_gsockoptB::Deparse::pp_gsockopt
0000s0sB::Deparse::::pp_gtB::Deparse::pp_gt
0000s0sB::Deparse::::pp_gvB::Deparse::pp_gv
0000s0sB::Deparse::::pp_gvsvB::Deparse::pp_gvsv
0000s0sB::Deparse::::pp_helemB::Deparse::pp_helem
0000s0sB::Deparse::::pp_hexB::Deparse::pp_hex
0000s0sB::Deparse::::pp_hsliceB::Deparse::pp_hslice
0000s0sB::Deparse::::pp_i_addB::Deparse::pp_i_add
0000s0sB::Deparse::::pp_i_divideB::Deparse::pp_i_divide
0000s0sB::Deparse::::pp_i_eqB::Deparse::pp_i_eq
0000s0sB::Deparse::::pp_i_geB::Deparse::pp_i_ge
0000s0sB::Deparse::::pp_i_gtB::Deparse::pp_i_gt
0000s0sB::Deparse::::pp_i_leB::Deparse::pp_i_le
0000s0sB::Deparse::::pp_i_ltB::Deparse::pp_i_lt
0000s0sB::Deparse::::pp_i_moduloB::Deparse::pp_i_modulo
0000s0sB::Deparse::::pp_i_multiplyB::Deparse::pp_i_multiply
0000s0sB::Deparse::::pp_i_ncmpB::Deparse::pp_i_ncmp
0000s0sB::Deparse::::pp_i_neB::Deparse::pp_i_ne
0000s0sB::Deparse::::pp_i_negateB::Deparse::pp_i_negate
0000s0sB::Deparse::::pp_i_postdecB::Deparse::pp_i_postdec
0000s0sB::Deparse::::pp_i_postincB::Deparse::pp_i_postinc
0000s0sB::Deparse::::pp_i_predecB::Deparse::pp_i_predec
0000s0sB::Deparse::::pp_i_preincB::Deparse::pp_i_preinc
0000s0sB::Deparse::::pp_i_subtractB::Deparse::pp_i_subtract
0000s0sB::Deparse::::pp_indexB::Deparse::pp_index
0000s0sB::Deparse::::pp_intB::Deparse::pp_int
0000s0sB::Deparse::::pp_introcvB::Deparse::pp_introcv
0000s0sB::Deparse::::pp_ioctlB::Deparse::pp_ioctl
0000s0sB::Deparse::::pp_joinB::Deparse::pp_join
0000s0sB::Deparse::::pp_keysB::Deparse::pp_keys
0000s0sB::Deparse::::pp_killB::Deparse::pp_kill
0000s0sB::Deparse::::pp_lastB::Deparse::pp_last
0000s0sB::Deparse::::pp_lcB::Deparse::pp_lc
0000s0sB::Deparse::::pp_lcfirstB::Deparse::pp_lcfirst
0000s0sB::Deparse::::pp_leB::Deparse::pp_le
0000s0sB::Deparse::::pp_leaveB::Deparse::pp_leave
0000s0sB::Deparse::::pp_leavegivenB::Deparse::pp_leavegiven
0000s0sB::Deparse::::pp_leaveloopB::Deparse::pp_leaveloop
0000s0sB::Deparse::::pp_leavetryB::Deparse::pp_leavetry
0000s0sB::Deparse::::pp_leavewhenB::Deparse::pp_leavewhen
0000s0sB::Deparse::::pp_left_shiftB::Deparse::pp_left_shift
0000s0sB::Deparse::::pp_lengthB::Deparse::pp_length
0000s0sB::Deparse::::pp_lineseqB::Deparse::pp_lineseq
0000s0sB::Deparse::::pp_linkB::Deparse::pp_link
0000s0sB::Deparse::::pp_listB::Deparse::pp_list
0000s0sB::Deparse::::pp_listenB::Deparse::pp_listen
0000s0sB::Deparse::::pp_localtimeB::Deparse::pp_localtime
0000s0sB::Deparse::::pp_lockB::Deparse::pp_lock
0000s0sB::Deparse::::pp_logB::Deparse::pp_log
0000s0sB::Deparse::::pp_lsliceB::Deparse::pp_lslice
0000s0sB::Deparse::::pp_lstatB::Deparse::pp_lstat
0000s0sB::Deparse::::pp_ltB::Deparse::pp_lt
0000s0sB::Deparse::::pp_mapstartB::Deparse::pp_mapstart
0000s0sB::Deparse::::pp_mapwhileB::Deparse::pp_mapwhile
0000s0sB::Deparse::::pp_matchB::Deparse::pp_match
0000s0sB::Deparse::::pp_mkdirB::Deparse::pp_mkdir
0000s0sB::Deparse::::pp_moduloB::Deparse::pp_modulo
0000s0sB::Deparse::::pp_msgctlB::Deparse::pp_msgctl
0000s0sB::Deparse::::pp_msggetB::Deparse::pp_msgget
0000s0sB::Deparse::::pp_msgrcvB::Deparse::pp_msgrcv
0000s0sB::Deparse::::pp_msgsndB::Deparse::pp_msgsnd
0000s0sB::Deparse::::pp_multiplyB::Deparse::pp_multiply
0000s0sB::Deparse::::pp_ncmpB::Deparse::pp_ncmp
0000s0sB::Deparse::::pp_neB::Deparse::pp_ne
0000s0sB::Deparse::::pp_negateB::Deparse::pp_negate
0000s0sB::Deparse::::pp_nextB::Deparse::pp_next
0000s0sB::Deparse::::pp_nextstateB::Deparse::pp_nextstate
0000s0sB::Deparse::::pp_notB::Deparse::pp_not
0000s0sB::Deparse::::pp_nullB::Deparse::pp_null
0000s0sB::Deparse::::pp_octB::Deparse::pp_oct
0000s0sB::Deparse::::pp_onceB::Deparse::pp_once
0000s0sB::Deparse::::pp_openB::Deparse::pp_open
0000s0sB::Deparse::::pp_open_dirB::Deparse::pp_open_dir
0000s0sB::Deparse::::pp_orB::Deparse::pp_or
0000s0sB::Deparse::::pp_orassignB::Deparse::pp_orassign
0000s0sB::Deparse::::pp_ordB::Deparse::pp_ord
0000s0sB::Deparse::::pp_packB::Deparse::pp_pack
0000s0sB::Deparse::::pp_padavB::Deparse::pp_padav
0000s0sB::Deparse::::pp_padcvB::Deparse::pp_padcv
0000s0sB::Deparse::::pp_padhvB::Deparse::pp_padhv
0000s0sB::Deparse::::pp_padsvB::Deparse::pp_padsv
0000s0sB::Deparse::::pp_pipe_opB::Deparse::pp_pipe_op
0000s0sB::Deparse::::pp_popB::Deparse::pp_pop
0000s0sB::Deparse::::pp_posB::Deparse::pp_pos
0000s0sB::Deparse::::pp_postdecB::Deparse::pp_postdec
0000s0sB::Deparse::::pp_postincB::Deparse::pp_postinc
0000s0sB::Deparse::::pp_powB::Deparse::pp_pow
0000s0sB::Deparse::::pp_predecB::Deparse::pp_predec
0000s0sB::Deparse::::pp_preincB::Deparse::pp_preinc
0000s0sB::Deparse::::pp_printB::Deparse::pp_print
0000s0sB::Deparse::::pp_prototypeB::Deparse::pp_prototype
0000s0sB::Deparse::::pp_prtfB::Deparse::pp_prtf
0000s0sB::Deparse::::pp_pushB::Deparse::pp_push
0000s0sB::Deparse::::pp_pushreB::Deparse::pp_pushre
0000s0sB::Deparse::::pp_qrB::Deparse::pp_qr
0000s0sB::Deparse::::pp_quotemetaB::Deparse::pp_quotemeta
0000s0sB::Deparse::::pp_randB::Deparse::pp_rand
0000s0sB::Deparse::::pp_rcatlineB::Deparse::pp_rcatline
0000s0sB::Deparse::::pp_readB::Deparse::pp_read
0000s0sB::Deparse::::pp_readdirB::Deparse::pp_readdir
0000s0sB::Deparse::::pp_readlineB::Deparse::pp_readline
0000s0sB::Deparse::::pp_readlinkB::Deparse::pp_readlink
0000s0sB::Deparse::::pp_recvB::Deparse::pp_recv
0000s0sB::Deparse::::pp_redoB::Deparse::pp_redo
0000s0sB::Deparse::::pp_refB::Deparse::pp_ref
0000s0sB::Deparse::::pp_refgenB::Deparse::pp_refgen
0000s0sB::Deparse::::pp_regcompB::Deparse::pp_regcomp
0000s0sB::Deparse::::pp_renameB::Deparse::pp_rename
0000s0sB::Deparse::::pp_repeatB::Deparse::pp_repeat
0000s0sB::Deparse::::pp_requireB::Deparse::pp_require
0000s0sB::Deparse::::pp_resetB::Deparse::pp_reset
0000s0sB::Deparse::::pp_returnB::Deparse::pp_return
0000s0sB::Deparse::::pp_reverseB::Deparse::pp_reverse
0000s0sB::Deparse::::pp_rewinddirB::Deparse::pp_rewinddir
0000s0sB::Deparse::::pp_right_shiftB::Deparse::pp_right_shift
0000s0sB::Deparse::::pp_rindexB::Deparse::pp_rindex
0000s0sB::Deparse::::pp_rmdirB::Deparse::pp_rmdir
0000s0sB::Deparse::::pp_runcvB::Deparse::pp_runcv
0000s0sB::Deparse::::pp_rv2avB::Deparse::pp_rv2av
0000s0sB::Deparse::::pp_rv2cvB::Deparse::pp_rv2cv
0000s0sB::Deparse::::pp_rv2gvB::Deparse::pp_rv2gv
0000s0sB::Deparse::::pp_rv2hvB::Deparse::pp_rv2hv
0000s0sB::Deparse::::pp_rv2svB::Deparse::pp_rv2sv
0000s0sB::Deparse::::pp_sassignB::Deparse::pp_sassign
0000s0sB::Deparse::::pp_sayB::Deparse::pp_say
0000s0sB::Deparse::::pp_scalarB::Deparse::pp_scalar
0000s0sB::Deparse::::pp_schompB::Deparse::pp_schomp
0000s0sB::Deparse::::pp_schopB::Deparse::pp_schop
0000s0sB::Deparse::::pp_scmpB::Deparse::pp_scmp
0000s0sB::Deparse::::pp_scopeB::Deparse::pp_scope
0000s0sB::Deparse::::pp_seekB::Deparse::pp_seek
0000s0sB::Deparse::::pp_seekdirB::Deparse::pp_seekdir
0000s0sB::Deparse::::pp_selectB::Deparse::pp_select
0000s0sB::Deparse::::pp_semctlB::Deparse::pp_semctl
0000s0sB::Deparse::::pp_semgetB::Deparse::pp_semget
0000s0sB::Deparse::::pp_semopB::Deparse::pp_semop
0000s0sB::Deparse::::pp_sendB::Deparse::pp_send
0000s0sB::Deparse::::pp_seqB::Deparse::pp_seq
0000s0sB::Deparse::::pp_setpgrpB::Deparse::pp_setpgrp
0000s0sB::Deparse::::pp_setpriorityB::Deparse::pp_setpriority
0000s0sB::Deparse::::pp_setstateB::Deparse::pp_setstate
0000s0sB::Deparse::::pp_sgeB::Deparse::pp_sge
0000s0sB::Deparse::::pp_sgrentB::Deparse::pp_sgrent
0000s0sB::Deparse::::pp_sgtB::Deparse::pp_sgt
0000s0sB::Deparse::::pp_shiftB::Deparse::pp_shift
0000s0sB::Deparse::::pp_shmctlB::Deparse::pp_shmctl
0000s0sB::Deparse::::pp_shmgetB::Deparse::pp_shmget
0000s0sB::Deparse::::pp_shmreadB::Deparse::pp_shmread
0000s0sB::Deparse::::pp_shmwriteB::Deparse::pp_shmwrite
0000s0sB::Deparse::::pp_shostentB::Deparse::pp_shostent
0000s0sB::Deparse::::pp_shutdownB::Deparse::pp_shutdown
0000s0sB::Deparse::::pp_sinB::Deparse::pp_sin
0000s0sB::Deparse::::pp_sleB::Deparse::pp_sle
0000s0sB::Deparse::::pp_sleepB::Deparse::pp_sleep
0000s0sB::Deparse::::pp_sltB::Deparse::pp_slt
0000s0sB::Deparse::::pp_smartmatchB::Deparse::pp_smartmatch
0000s0sB::Deparse::::pp_sneB::Deparse::pp_sne
0000s0sB::Deparse::::pp_snetentB::Deparse::pp_snetent
0000s0sB::Deparse::::pp_socketB::Deparse::pp_socket
0000s0sB::Deparse::::pp_sockpairB::Deparse::pp_sockpair
0000s0sB::Deparse::::pp_sortB::Deparse::pp_sort
0000s0sB::Deparse::::pp_spliceB::Deparse::pp_splice
0000s0sB::Deparse::::pp_splitB::Deparse::pp_split
0000s0sB::Deparse::::pp_sprintfB::Deparse::pp_sprintf
0000s0sB::Deparse::::pp_sprotoentB::Deparse::pp_sprotoent
0000s0sB::Deparse::::pp_spwentB::Deparse::pp_spwent
0000s0sB::Deparse::::pp_sqrtB::Deparse::pp_sqrt
0000s0sB::Deparse::::pp_srandB::Deparse::pp_srand
0000s0sB::Deparse::::pp_srefgenB::Deparse::pp_srefgen
0000s0sB::Deparse::::pp_sselectB::Deparse::pp_sselect
0000s0sB::Deparse::::pp_sserventB::Deparse::pp_sservent
0000s0sB::Deparse::::pp_ssockoptB::Deparse::pp_ssockopt
0000s0sB::Deparse::::pp_statB::Deparse::pp_stat
0000s0sB::Deparse::::pp_stringifyB::Deparse::pp_stringify
0000s0sB::Deparse::::pp_stubB::Deparse::pp_stub
0000s0sB::Deparse::::pp_studyB::Deparse::pp_study
0000s0sB::Deparse::::pp_substB::Deparse::pp_subst
0000s0sB::Deparse::::pp_substrB::Deparse::pp_substr
0000s0sB::Deparse::::pp_subtractB::Deparse::pp_subtract
0000s0sB::Deparse::::pp_symlinkB::Deparse::pp_symlink
0000s0sB::Deparse::::pp_syscallB::Deparse::pp_syscall
0000s0sB::Deparse::::pp_sysopenB::Deparse::pp_sysopen
0000s0sB::Deparse::::pp_sysreadB::Deparse::pp_sysread
0000s0sB::Deparse::::pp_sysseekB::Deparse::pp_sysseek
0000s0sB::Deparse::::pp_systemB::Deparse::pp_system
0000s0sB::Deparse::::pp_syswriteB::Deparse::pp_syswrite
0000s0sB::Deparse::::pp_tellB::Deparse::pp_tell
0000s0sB::Deparse::::pp_telldirB::Deparse::pp_telldir
0000s0sB::Deparse::::pp_threadsvB::Deparse::pp_threadsv
0000s0sB::Deparse::::pp_tieB::Deparse::pp_tie
0000s0sB::Deparse::::pp_tiedB::Deparse::pp_tied
0000s0sB::Deparse::::pp_timeB::Deparse::pp_time
0000s0sB::Deparse::::pp_tmsB::Deparse::pp_tms
0000s0sB::Deparse::::pp_transB::Deparse::pp_trans
0000s0sB::Deparse::::pp_transrB::Deparse::pp_transr
0000s0sB::Deparse::::pp_truncateB::Deparse::pp_truncate
0000s0sB::Deparse::::pp_ucB::Deparse::pp_uc
0000s0sB::Deparse::::pp_ucfirstB::Deparse::pp_ucfirst
0000s0sB::Deparse::::pp_umaskB::Deparse::pp_umask
0000s0sB::Deparse::::pp_undefB::Deparse::pp_undef
0000s0sB::Deparse::::pp_unlinkB::Deparse::pp_unlink
0000s0sB::Deparse::::pp_unpackB::Deparse::pp_unpack
0000s0sB::Deparse::::pp_unshiftB::Deparse::pp_unshift
0000s0sB::Deparse::::pp_unstackB::Deparse::pp_unstack
0000s0sB::Deparse::::pp_untieB::Deparse::pp_untie
0000s0sB::Deparse::::pp_utimeB::Deparse::pp_utime
0000s0sB::Deparse::::pp_valuesB::Deparse::pp_values
0000s0sB::Deparse::::pp_vecB::Deparse::pp_vec
0000s0sB::Deparse::::pp_waitB::Deparse::pp_wait
0000s0sB::Deparse::::pp_waitpidB::Deparse::pp_waitpid
0000s0sB::Deparse::::pp_wantarrayB::Deparse::pp_wantarray
0000s0sB::Deparse::::pp_warnB::Deparse::pp_warn
0000s0sB::Deparse::::pp_xorB::Deparse::pp_xor
0000s0sB::Deparse::::print_protosB::Deparse::print_protos
0000s0sB::Deparse::::pure_stringB::Deparse::pure_string
0000s0sB::Deparse::::rangeB::Deparse::range
0000s0sB::Deparse::::re_dqB::Deparse::re_dq
0000s0sB::Deparse::::re_dq_disambiguateB::Deparse::re_dq_disambiguate
0000s0sB::Deparse::::re_flagsB::Deparse::re_flags
0000s0sB::Deparse::::re_unbackB::Deparse::re_unback
0000s0sB::Deparse::::re_uninterpB::Deparse::re_uninterp
0000s0sB::Deparse::::re_uninterp_extendedB::Deparse::re_uninterp_extended
0000s0sB::Deparse::::real_concatB::Deparse::real_concat
0000s0sB::Deparse::::real_negateB::Deparse::real_negate
0000s0sB::Deparse::::regcompB::Deparse::regcomp
0000s0sB::Deparse::::rv2gv_or_stringB::Deparse::rv2gv_or_string
0000s0sB::Deparse::::rv2xB::Deparse::rv2x
0000s0sB::Deparse::::scopeopB::Deparse::scopeop
0000s0sB::Deparse::::seq_subsB::Deparse::seq_subs
0000s0sB::Deparse::::single_delimB::Deparse::single_delim
0000s0sB::Deparse::::sliceB::Deparse::slice
0000s0sB::Deparse::::split_floatB::Deparse::split_float
0000s0sB::Deparse::::stash_subsB::Deparse::stash_subs
0000s0sB::Deparse::::stash_variableB::Deparse::stash_variable
0000s0sB::Deparse::::stash_variable_nameB::Deparse::stash_variable_name
0000s0sB::Deparse::::style_optsB::Deparse::style_opts
0000s0sB::Deparse::::todoB::Deparse::todo
0000s0sB::Deparse::::tr_chrB::Deparse::tr_chr
0000s0sB::Deparse::::tr_decode_byteB::Deparse::tr_decode_byte
0000s0sB::Deparse::::tr_decode_utf8B::Deparse::tr_decode_utf8
0000s0sB::Deparse::::unbackB::Deparse::unback
0000s0sB::Deparse::::uninterpB::Deparse::uninterp
0000s0sB::Deparse::::unopB::Deparse::unop
0000s0sB::Deparse::::walk_lineseqB::Deparse::walk_lineseq
0000s0sB::Deparse::::want_listB::Deparse::want_list
0000s0sB::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
10package B::Deparse;
11252µs269µ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
1214µs1607µ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
22126µs1614µs PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
# spent 614µs making 1 call to B::Deparse::BEGIN@12
231800ns$VERSION = '1.20';
24219µs222µ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
25219µs250µ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
26247µs12µ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
271624µsrequire 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.
3313µ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)) {
383019µs154.92ms eval { import B $_ };
# spent 4.92ms making 15 calls to Exporter::import, avg 328µs/call
39247µs224µ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
401540µs *{$_} = sub () {0} unless *{$_}{CODE};
41 }
4211.24ms14.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
320sub _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
374sub _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
411sub 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
423sub null {
424 my $op = shift;
425 return class($op) eq "NULL";
426}
427
428sub 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
446sub 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
485sub 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
586sub 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/(::)?$/::/;
5952689µs242µ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
646sub 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
658sub 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
679sub 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
7272700ns 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 {
72916µs $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
7301407µs16µ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.
739sub 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
754sub 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
80722.77ms225µ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
819sub 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
82812µsmy %strict_bits = do {
82912µs local $^H;
83017µs313µs map +($_ => strict::bits($_)), qw/refs subs vars/
# spent 13µs making 3 calls to strict::bits, avg 4µs/call
831};
832
833sub 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
947sub 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
957sub 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
985sub deparse_sub {
986 my $self = shift;
987 my $cv = shift;
988 my $proto = "";
989Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
990Carp::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
1040sub 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
1072sub 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
1080sub is_state {
1081 my $name = $_[0]->name;
1082 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
1083}
1084
1085sub 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
1099sub 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
1120sub 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
1129sub 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
1146sub 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
1174sub 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
1184sub 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
1209sub 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
1221sub padname_sv {
1222 my $self = shift;
1223 my $targ = shift;
1224 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1225}
1226
1227sub 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
1248sub 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
1257sub 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.
1263sub 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
1294sub 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
1334sub pp_scope { scopeop(0, @_); }
1335sub pp_lineseq { scopeop(0, @_); }
1336sub 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.
1341sub 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
1357sub 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.
13821200nsmy %globalnames;
1383113µ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",
138413.28ms110µs "ENV", "ARGV", "ARGVOUT", "_"); }
# spent 10µs making 1 call to B::Deparse::BEGIN@1383
1385
1386sub gv_name {
1387 my $self = shift;
1388 my $gv = shift;
1389 my $raw = shift;
1390Carp::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.
1416sub 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.
1443sub 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
1457sub 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
1472sub 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
1487sub 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
1515sub find_scope_st { ((find_scope(@_))[0]); }
1516sub find_scope_en { ((find_scope(@_))[1]); }
1517
1518# Recurses down the tree, looking for pad variable introductions and COPs
1519sub 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
1550sub 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
1563sub 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
1576sub _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.
1586sub 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
1681sub 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
1692sub 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
170813µsmy %ignored_hints = (
1709 'open<' => 1,
1710 'open>' => 1,
1711 ':' => 1,
1712 'strict/refs' => 1,
1713 'strict/subs' => 1,
1714 'strict/vars' => 1,
1715);
1716
17171100nsmy %rev_feature;
1718
1719sub 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
1770sub 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
1787sub pp_dbstate { pp_nextstate(@_) }
1788sub pp_setstate { pp_nextstate(@_) }
1789
1790sub pp_unstack { return "" } # see also leaveloop
1791
179218µsmy %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#
180715µsmy %strong_proto_keywords = map { $_ => 1 } qw(
1808 glob
1809 pos
1810 prototype
1811 scalar
1812 study
1813 undef
1814);
1815
1816sub 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
1845sub baseop {
1846 my $self = shift;
1847 my($op, $cx, $name) = @_;
1848 return $self->keyword($name);
1849}
1850
1851sub pp_stub {
1852 my $self = shift;
1853 my($op, $cx, $name) = @_;
1854 if ($cx >= 1) {
1855 return "()";
1856 }
1857 else {
1858 return "();";
1859 }
1860}
1861sub pp_wantarray { baseop(@_, "wantarray") }
1862sub pp_fork { baseop(@_, "fork") }
1863sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1864sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1865sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1866sub pp_tms { baseop(@_, "times") }
1867sub pp_ghostent { baseop(@_, "gethostent") }
1868sub pp_gnetent { baseop(@_, "getnetent") }
1869sub pp_gprotoent { baseop(@_, "getprotoent") }
1870sub pp_gservent { baseop(@_, "getservent") }
1871sub pp_ehostent { baseop(@_, "endhostent") }
1872sub pp_enetent { baseop(@_, "endnetent") }
1873sub pp_eprotoent { baseop(@_, "endprotoent") }
1874sub pp_eservent { baseop(@_, "endservent") }
1875sub pp_gpwent { baseop(@_, "getpwent") }
1876sub pp_spwent { baseop(@_, "setpwent") }
1877sub pp_epwent { baseop(@_, "endpwent") }
1878sub pp_ggrent { baseop(@_, "getgrent") }
1879sub pp_sgrent { baseop(@_, "setgrent") }
1880sub pp_egrent { baseop(@_, "endgrent") }
1881sub pp_getlogin { baseop(@_, "getlogin") }
1882
1883sub 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
1888sub 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
1903sub pp_preinc { pfixop(@_, "++", 23) }
1904sub pp_predec { pfixop(@_, "--", 23) }
1905sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1906sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1907sub pp_i_preinc { pfixop(@_, "++", 23) }
1908sub pp_i_predec { pfixop(@_, "--", 23) }
1909sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1910sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1911sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1912
1913sub pp_negate { maybe_targmy(@_, \&real_negate) }
1914sub 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}
1924sub pp_i_negate { pp_negate(@_) }
1925
1926sub 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
1936sub 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
1969sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1970sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1971sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1972sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1973sub pp_defined { unop(@_, "defined") }
1974sub pp_undef { unop(@_, "undef") }
1975sub pp_study { unop(@_, "study") }
1976sub pp_ref { unop(@_, "ref") }
1977sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1978
1979sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1980sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1981sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1982sub pp_srand { unop(@_, "srand") }
1983sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1984sub pp_log { maybe_targmy(@_, \&unop, "log") }
1985sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1986sub pp_int { maybe_targmy(@_, \&unop, "int") }
1987sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1988sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1989sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1990
1991sub pp_length { maybe_targmy(@_, \&unop, "length") }
1992sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1993sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1994
1995sub pp_each { unop(@_, "each") }
1996sub pp_values { unop(@_, "values") }
1997sub pp_keys { unop(@_, "keys") }
199842.50ms239µ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
1999sub pp_boolkeys {
2000 # no name because its an optimisation op that has no keyword
2001 unop(@_,"");
2002}
2003sub pp_aeach { unop(@_, "each") }
2004sub pp_avalues { unop(@_, "values") }
2005sub pp_akeys { unop(@_, "keys") }
2006sub pp_pop { unop(@_, "pop") }
2007sub pp_shift { unop(@_, "shift") }
2008
2009sub pp_caller { unop(@_, "caller") }
2010sub pp_reset { unop(@_, "reset") }
2011sub pp_exit { unop(@_, "exit") }
2012sub pp_prototype { unop(@_, "prototype") }
2013
2014sub pp_close { unop(@_, "close") }
2015sub pp_fileno { unop(@_, "fileno") }
2016sub pp_umask { unop(@_, "umask") }
2017sub pp_untie { unop(@_, "untie") }
2018sub pp_tied { unop(@_, "tied") }
2019sub pp_dbmclose { unop(@_, "dbmclose") }
2020sub pp_getc { unop(@_, "getc") }
2021sub pp_eof { unop(@_, "eof") }
2022sub pp_tell { unop(@_, "tell") }
2023sub pp_getsockname { unop(@_, "getsockname") }
2024sub pp_getpeername { unop(@_, "getpeername") }
2025
2026sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
2027sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
2028sub pp_readlink { unop(@_, "readlink") }
2029sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
2030sub pp_readdir { unop(@_, "readdir") }
2031sub pp_telldir { unop(@_, "telldir") }
2032sub pp_rewinddir { unop(@_, "rewinddir") }
2033sub pp_closedir { unop(@_, "closedir") }
2034sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
2035sub pp_localtime { unop(@_, "localtime") }
2036sub pp_gmtime { unop(@_, "gmtime") }
2037sub pp_alarm { unop(@_, "alarm") }
2038sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
2039
2040sub pp_dofile {
2041 my $code = unop(@_, "do", 1); # llafr does not apply
2042 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
2043 $code;
2044}
2045sub pp_entereval {
2046 unop(
2047 @_,
2048 $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
2049 )
2050}
2051
2052sub pp_ghbyname { unop(@_, "gethostbyname") }
2053sub pp_gnbyname { unop(@_, "getnetbyname") }
2054sub pp_gpbyname { unop(@_, "getprotobyname") }
2055sub pp_shostent { unop(@_, "sethostent") }
2056sub pp_snetent { unop(@_, "setnetent") }
2057sub pp_sprotoent { unop(@_, "setprotoent") }
2058sub pp_sservent { unop(@_, "setservent") }
2059sub pp_gpwnam { unop(@_, "getpwnam") }
2060sub pp_gpwuid { unop(@_, "getpwuid") }
2061sub pp_ggrnam { unop(@_, "getgrnam") }
2062sub pp_ggrgid { unop(@_, "getgrgid") }
2063
2064sub pp_lock { unop(@_, "lock") }
2065
2066sub pp_continue { unop(@_, "continue"); }
2067sub pp_break { unop(@_, "break"); }
2068
2069sub 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
2091sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2092sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
2093
2094sub 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
2112sub 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
2139sub 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
2162sub 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
2174sub padval {
2175 my $self = shift;
2176 my $targ = shift;
2177 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
2178}
2179
2180sub 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
2199sub 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
220912µs*pp_anonhash = \&pp_anonlist;
2210
2211sub 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
2240sub e_anoncode {
2241 my ($self, $info) = @_;
2242 my $text = $self->deparse_sub($info->{code});
2243 return "sub " . $text;
2244}
2245
2246sub pp_srefgen { pp_refgen(@_) }
2247
2248sub 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
2257sub 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
2264sub 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
2278sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2279sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2280sub pp_uc { dq_unop(@_, "uc") }
2281sub pp_lc { dq_unop(@_, "lc") }
2282sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2283sub pp_fc { dq_unop(@_, "fc") }
2284
2285sub 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
2299sub pp_last { loopex(@_, "last") }
2300sub pp_next { loopex(@_, "next") }
2301sub pp_redo { loopex(@_, "redo") }
2302sub pp_goto { loopex(@_, "goto") }
2303sub pp_dump { loopex(@_, "CORE::dump") }
2304
2305sub 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
2323sub pp_lstat { ftst(@_, "lstat") }
2324sub pp_stat { ftst(@_, "stat") }
2325sub pp_ftrread { ftst(@_, "-R") }
2326sub pp_ftrwrite { ftst(@_, "-W") }
2327sub pp_ftrexec { ftst(@_, "-X") }
2328sub pp_fteread { ftst(@_, "-r") }
2329sub pp_ftewrite { ftst(@_, "-w") }
2330sub pp_fteexec { ftst(@_, "-x") }
2331sub pp_ftis { ftst(@_, "-e") }
2332sub pp_fteowned { ftst(@_, "-O") }
2333sub pp_ftrowned { ftst(@_, "-o") }
2334sub pp_ftzero { ftst(@_, "-z") }
2335sub pp_ftsize { ftst(@_, "-s") }
2336sub pp_ftmtime { ftst(@_, "-M") }
2337sub pp_ftatime { ftst(@_, "-A") }
2338sub pp_ftctime { ftst(@_, "-C") }
2339sub pp_ftsock { ftst(@_, "-S") }
2340sub pp_ftchr { ftst(@_, "-c") }
2341sub pp_ftblk { ftst(@_, "-b") }
2342sub pp_ftfile { ftst(@_, "-f") }
2343sub pp_ftdir { ftst(@_, "-d") }
2344sub pp_ftpipe { ftst(@_, "-p") }
2345sub pp_ftlink { ftst(@_, "-l") }
2346sub pp_ftsuid { ftst(@_, "-u") }
2347sub pp_ftsgid { ftst(@_, "-g") }
2348sub pp_ftsvtx { ftst(@_, "-k") }
2349sub pp_fttty { ftst(@_, "-t") }
2350sub pp_fttext { ftst(@_, "-T") }
2351sub pp_ftbinary { ftst(@_, "-B") }
2352
2353sub SWAP_CHILDREN () { 1 }
2354sub ASSIGN () { 2 } # has OP= variant
2355sub LIST_CONTEXT () { 4 } # Assignment is in list context
2356
23571100nsmy(%left, %right);
2358
2359sub 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 {
2384116µ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 );
23971108µs114µs}
# spent 14µs making 1 call to B::Deparse::BEGIN@2383
2398
2399sub 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 {
2415112µ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 );
243015.03ms112µs}
# spent 12µs making 1 call to B::Deparse::BEGIN@2414
2431
2432sub 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
2444sub 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
2464sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2465sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2466sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2467sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2468sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2469sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2470sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2471sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2472sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2473sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2474sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2475
2476sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2477sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2478sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2479sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2480sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2481
2482sub pp_eq { binop(@_, "==", 14) }
2483sub pp_ne { binop(@_, "!=", 14) }
2484sub pp_lt { binop(@_, "<", 15) }
2485sub pp_gt { binop(@_, ">", 15) }
2486sub pp_ge { binop(@_, ">=", 15) }
2487sub pp_le { binop(@_, "<=", 15) }
2488sub pp_ncmp { binop(@_, "<=>", 14) }
2489sub pp_i_eq { binop(@_, "==", 14) }
2490sub pp_i_ne { binop(@_, "!=", 14) }
2491sub pp_i_lt { binop(@_, "<", 15) }
2492sub pp_i_gt { binop(@_, ">", 15) }
2493sub pp_i_ge { binop(@_, ">=", 15) }
2494sub pp_i_le { binop(@_, "<=", 15) }
2495sub pp_i_ncmp { binop(@_, "<=>", 14) }
2496
2497sub pp_seq { binop(@_, "eq", 14) }
2498sub pp_sne { binop(@_, "ne", 14) }
2499sub pp_slt { binop(@_, "lt", 15) }
2500sub pp_sgt { binop(@_, "gt", 15) }
2501sub pp_sge { binop(@_, "ge", 15) }
2502sub pp_sle { binop(@_, "le", 15) }
2503sub pp_scmp { binop(@_, "cmp", 14) }
2504
2505sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2506sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2507
2508sub 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.
2521sub pp_concat { maybe_targmy(@_, \&real_concat) }
2522sub 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
2539sub 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
2565sub 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
2575sub 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
2585sub 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
2612sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2613sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2614sub 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.
2618sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2619
2620sub 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
2630sub pp_andassign { logassignop(@_, "&&=") }
2631sub pp_orassign { logassignop(@_, "||=") }
2632sub pp_dorassign { logassignop(@_, "//=") }
2633
2634sub 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
2646sub 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
2714sub pp_bless { listop(@_, "bless") }
2715sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2716sub 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}
2726sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2727sub pp_index { maybe_targmy(@_, \&listop, "index") }
2728sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2729sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2730sub pp_formline { listop(@_, "formline") } # see also deparse_format
2731sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2732sub pp_unpack { listop(@_, "unpack") }
2733sub pp_pack { listop(@_, "pack") }
2734sub pp_join { maybe_targmy(@_, \&listop, "join") }
2735sub pp_splice { listop(@_, "splice") }
2736sub pp_push { maybe_targmy(@_, \&listop, "push") }
2737sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2738sub pp_reverse { listop(@_, "reverse") }
2739sub pp_warn { listop(@_, "warn") }
2740sub pp_die { listop(@_, "die") }
2741sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
2742sub pp_open { listop(@_, "open") }
2743sub pp_pipe_op { listop(@_, "pipe") }
2744sub pp_tie { listop(@_, "tie") }
2745sub pp_binmode { listop(@_, "binmode") }
2746sub pp_dbmopen { listop(@_, "dbmopen") }
2747sub pp_sselect { listop(@_, "select") }
2748sub pp_select { listop(@_, "select") }
2749sub pp_read { listop(@_, "read") }
2750sub pp_sysopen { listop(@_, "sysopen") }
2751sub pp_sysseek { listop(@_, "sysseek") }
2752sub pp_sysread { listop(@_, "sysread") }
2753sub pp_syswrite { listop(@_, "syswrite") }
2754sub pp_send { listop(@_, "send") }
2755sub pp_recv { listop(@_, "recv") }
2756sub pp_seek { listop(@_, "seek") }
2757sub pp_fcntl { listop(@_, "fcntl") }
2758sub pp_ioctl { listop(@_, "ioctl") }
2759sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2760sub pp_socket { listop(@_, "socket") }
2761sub pp_sockpair { listop(@_, "sockpair") }
2762sub pp_bind { listop(@_, "bind") }
2763sub pp_connect { listop(@_, "connect") }
2764sub pp_listen { listop(@_, "listen") }
2765sub pp_accept { listop(@_, "accept") }
2766sub pp_shutdown { listop(@_, "shutdown") }
2767sub pp_gsockopt { listop(@_, "getsockopt") }
2768sub pp_ssockopt { listop(@_, "setsockopt") }
2769sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2770sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2771sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2772sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2773sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2774sub pp_link { maybe_targmy(@_, \&listop, "link") }
2775sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2776sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2777sub pp_open_dir { listop(@_, "opendir") }
2778sub pp_seekdir { listop(@_, "seekdir") }
2779sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2780sub pp_system { maybe_targmy(@_, \&listop, "system") }
2781sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2782sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2783sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2784sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2785sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2786sub pp_shmget { listop(@_, "shmget") }
2787sub pp_shmctl { listop(@_, "shmctl") }
2788sub pp_shmread { listop(@_, "shmread") }
2789sub pp_shmwrite { listop(@_, "shmwrite") }
2790sub pp_msgget { listop(@_, "msgget") }
2791sub pp_msgctl { listop(@_, "msgctl") }
2792sub pp_msgsnd { listop(@_, "msgsnd") }
2793sub pp_msgrcv { listop(@_, "msgrcv") }
2794sub pp_semget { listop(@_, "semget") }
2795sub pp_semctl { listop(@_, "semctl") }
2796sub pp_semop { listop(@_, "semop") }
2797sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2798sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2799sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2800sub pp_gsbyname { listop(@_, "getservbyname") }
2801sub pp_gsbyport { listop(@_, "getservbyport") }
2802sub pp_syscall { listop(@_, "syscall") }
2803
2804sub 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
2823sub 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
2846sub 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
2913sub pp_prtf { indirop(@_, "printf") }
2914sub pp_print { indirop(@_, "print") }
2915sub pp_say { indirop(@_, "say") }
2916sub pp_sort { indirop(@_, "sort") }
2917
2918sub 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
2939sub pp_mapwhile { mapop(@_, "map") }
2940sub pp_grepwhile { mapop(@_, "grep") }
2941sub pp_mapstart { baseop(@_, "map") }
2942sub pp_grepstart { baseop(@_, "grep") }
2943
2944sub 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
3017sub 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
3024sub 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
3068sub 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
3076sub 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
3185sub pp_leaveloop { shift->loop_common(@_, "") }
3186
3187sub 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
3196sub pp_leavetry {
3197 my $self = shift;
3198 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
3199}
3200
320115µ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 ]) {
32025174µs514µs eval "sub OP_\U$_ () { " . opnumber($_) . "}"
# spent 14µs making 5 calls to B::opnumber, avg 3µs/call
320312.80ms1181µs}}
# spent 181µs making 1 call to B::Deparse::BEGIN@3201
3204
3205sub 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
3256sub padname {
3257 my $self = shift;
3258 my $targ = shift;
3259 return $self->padname_sv($targ)->PVX;
3260}
3261
3262sub padany {
3263 my $self = shift;
3264 my $op = shift;
3265 return substr($self->padname($op->targ), 1); # skip $/@/%
3266}
3267
3268sub pp_padsv {
3269 my $self = shift;
3270 my($op, $cx) = @_;
3271 return $self->maybe_my($op, $cx, $self->padname($op->targ));
3272}
3273
3274sub pp_padav { pp_padsv(@_) }
3275sub pp_padhv { pp_padsv(@_) }
3276
327717µs11µsmy @threadsv_names = B::threadsv_names;
# spent 1µs making 1 call to B::threadsv_names
3278sub pp_threadsv {
3279 my $self = shift;
3280 my($op, $cx) = @_;
3281 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
3282}
3283
3284sub 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
3294sub 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
3302sub 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
3309sub 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
3317sub 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
3329sub 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
3360sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
3361sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
3362sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
3363
3364# skip rv2av
3365sub 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
3377sub 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
3389sub 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
3407sub 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
3419sub 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
3438sub 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
3464sub 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
3502sub 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
3524sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3525sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3526
3527sub 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
3539sub 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
3567sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3568sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3569
3570sub 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
3581sub want_scalar {
3582 my $op = shift;
3583 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3584}
3585
3586sub want_list {
3587 my $op = shift;
3588 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3589}
3590
3591sub _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
3642sub method {
3643 my $self = shift;
3644 my $info = $self->_method(@_);
3645 return $self->e_method( $self->_method(@_) );
3646}
3647
3648sub 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.
3675sub 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
3752sub 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 {
3802226µs244µ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
38032359µs235µ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
3858sub pp_enterwrite { unop(@_, "write") }
3859
3860# escape things that cause interpolation in double quotes,
3861# but not character escapes
3862sub uninterp {
3863 my($str) = @_;
3864 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3865 return $str;
3866}
3867
3868{
38692300nsmy $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 {
3871260µs241µ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 )*
3880112µs14µs )x;
# spent 4µs making 1 call to B::Deparse::CORE:qr
38811816µs112µ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
3884sub 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.
3910sub 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
3937115µsmy %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
3973sub 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.
3990sub 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
4000sub 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.
4008sub 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
4016sub 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
4044sub 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
40631100nsmy $max_prec;
40641482µs27µ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.
4069sub 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
4087sub 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) {
411411µ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
41311800ns 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)";
41341500ns } 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 {
417113µs if ($] > 5.0150051) {
41721400ns require overloading;
417313µs110µs unimport overloading;
# spent 10µs making 1 call to overloading::unimport
4174 }
417513.95ms120µ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
4204sub 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
4218sub 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
4227sub 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
4240sub 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
4277sub 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
4289sub 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
4299sub 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)
4303sub 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
4330sub 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
4360sub 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
4378sub 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
4423sub 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
4436sub 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
4531sub 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
4553sub pp_transr { &pp_trans . 'r' }
4554
4555sub 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
4566sub 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
4602sub 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
4647sub 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
4671sub pp_regcomp {
4672 my ($self, $op, $cx) = @_;
4673 return (($self->regcomp($op, $cx, 0))[0]);
4674}
4675
4676sub 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
47101100nsmy %matchwords;
4711160µs217µsmap($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
4715sub 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
4774sub pp_match { matchop(@_, "m", "/") }
4775sub pp_pushre { matchop(@_, "m", "/") }
4776sub pp_qr { matchop(@_, "qr", "") }
4777
4778sub pp_runcv { unop(@_, "__SUB__"); }
4779
4780sub 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
48321100nsmy %substwords;
48331100µs4311µsmap($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
4840sub 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
4893sub 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
4901sub 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
4909sub 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
4917sub pp_padcv {
4918 my $self = shift;
4919 my($op, $cx) = @_;
4920 return $self->padany($op);
4921}
4922
4923120µs1;
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