← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:08 2013

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