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

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