← Index
NYTProf Performance Profile   « line view »
For /home/ss5/perl5/perlbrew/perls/perl-5.22.0/bin/benchmarkanything-storage
  Run on Mon Jan 29 16:55:34 2018
Reported on Mon Jan 29 16:57:07 2018

Filename/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/5.22.0/B/Deparse.pm
StatementsExecuted 152 statements in 23.5ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1113.35ms3.35msB::Deparse::::BEGIN@3368B::Deparse::BEGIN@3368
111187µs204µsB::Deparse::::BEGIN@363B::Deparse::BEGIN@363
11183µs5.89msB::Deparse::::BEGIN@55B::Deparse::BEGIN@55
11113µs13µsB::Deparse::::BEGIN@2814B::Deparse::BEGIN@2814
662112µs12µsB::Deparse::::CORE:sortB::Deparse::CORE:sort (opcode)
11112µs12µsB::Deparse::::BEGIN@2781B::Deparse::BEGIN@2781
1119µs16µsB::Deparse::::BEGIN@67B::Deparse::BEGIN@67
1119µs34µsB::Deparse::::BEGIN@11B::Deparse::BEGIN@11
1119µs16µsB::Deparse::::BEGIN@4831B::Deparse::BEGIN@4831
1119µs12µsB::Deparse::::BEGIN@4588B::Deparse::BEGIN@4588
1118µs8µsB::Deparse::::BEGIN@1679B::Deparse::BEGIN@1679
1118µs20µsB::Deparse::::BEGIN@4513B::Deparse::BEGIN@4513
1117µs23µsB::Deparse::::BEGIN@4589B::Deparse::BEGIN@4589
1117µs613µsB::Deparse::::BEGIN@12B::Deparse::BEGIN@12
1116µs16µsB::Deparse::::BEGIN@2371B::Deparse::BEGIN@2371
1116µs16µsB::Deparse::::BEGIN@721B::Deparse::BEGIN@721
1116µs18µsB::Deparse::::BEGIN@4514B::Deparse::BEGIN@4514
1116µs13µsB::Deparse::::BEGIN@972B::Deparse::BEGIN@972
1115µs5µsB::Deparse::::BEGIN@870B::Deparse::BEGIN@870
1115µs7µsB::Deparse::::BEGIN@50B::Deparse::BEGIN@50
1114µs17µsB::Deparse::::BEGIN@51B::Deparse::BEGIN@51
1113µs3µsB::Deparse::::CORE:qrB::Deparse::CORE:qr (opcode)
1113µs3µsB::Deparse::::BEGIN@4723B::Deparse::BEGIN@4723
1112µs2µsB::Deparse::::BEGIN@52B::Deparse::BEGIN@52
0000s0sB::Deparse::::AUTOLOADB::Deparse::AUTOLOAD
0000s0sB::Deparse::::DESTROYB::Deparse::DESTROY
0000s0sB::Deparse::::WARN_MASKB::Deparse::WARN_MASK
0000s0sB::Deparse::::__ANON__[:1572]B::Deparse::__ANON__[:1572]
0000s0sB::Deparse::::__ANON__[:1649]B::Deparse::__ANON__[:1649]
0000s0sB::Deparse::::__ANON__[:2406]B::Deparse::__ANON__[:2406]
0000s0sB::Deparse::::__ANON__[:4598]B::Deparse::__ANON__[:4598]
0000s0sB::Deparse::::__ANON__[:4980]B::Deparse::__ANON__[:4980]
0000s0sB::Deparse::::__ANON__[:935]B::Deparse::__ANON__[:935]
0000s0sB::Deparse::::__ANON__[:981]B::Deparse::__ANON__[:981]
0000s0sB::Deparse::::_features_from_bundleB::Deparse::_features_from_bundle
0000s0sB::Deparse::::_methodB::Deparse::_method
0000s0sB::Deparse::::_op_is_or_wasB::Deparse::_op_is_or_was
0000s0sB::Deparse::::_pessimise_walkB::Deparse::_pessimise_walk
0000s0sB::Deparse::::_pessimise_walk_exeB::Deparse::_pessimise_walk_exe
0000s0sB::Deparse::::ambient_pragmasB::Deparse::ambient_pragmas
0000s0sB::Deparse::::anon_hash_or_listB::Deparse::anon_hash_or_list
0000s0sB::Deparse::::assoc_classB::Deparse::assoc_class
0000s0sB::Deparse::::balanced_delimB::Deparse::balanced_delim
0000s0sB::Deparse::::baseopB::Deparse::baseop
0000s0sB::Deparse::::begin_is_useB::Deparse::begin_is_use
0000s0sB::Deparse::::binopB::Deparse::binop
0000s0sB::Deparse::::check_protoB::Deparse::check_proto
0000s0sB::Deparse::::code_listB::Deparse::code_list
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_reB::Deparse::escape_re
0000s0sB::Deparse::::escape_strB::Deparse::escape_str
0000s0sB::Deparse::::feature_enabledB::Deparse::feature_enabled
0000s0sB::Deparse::::find_our_typeB::Deparse::find_our_type
0000s0sB::Deparse::::find_scopeB::Deparse::find_scope
0000s0sB::Deparse::::find_scope_enB::Deparse::find_scope_en
0000s0sB::Deparse::::find_scope_stB::Deparse::find_scope_st
0000s0sB::Deparse::::for_loopB::Deparse::for_loop
0000s0sB::Deparse::::ftstB::Deparse::ftst
0000s0sB::Deparse::::givwhenB::Deparse::givwhen
0000s0sB::Deparse::::gv_nameB::Deparse::gv_name
0000s0sB::Deparse::::gv_or_padgvB::Deparse::gv_or_padgv
0000s0sB::Deparse::::hint_pragmasB::Deparse::hint_pragmas
0000s0sB::Deparse::::indentB::Deparse::indent
0000s0sB::Deparse::::indiropB::Deparse::indirop
0000s0sB::Deparse::::initB::Deparse::init
0000s0sB::Deparse::::is_for_loopB::Deparse::is_for_loop
0000s0sB::Deparse::::is_ifelse_contB::Deparse::is_ifelse_cont
0000s0sB::Deparse::::is_lexical_subsB::Deparse::is_lexical_subs
0000s0sB::Deparse::::is_miniwhileB::Deparse::is_miniwhile
0000s0sB::Deparse::::is_scalarB::Deparse::is_scalar
0000s0sB::Deparse::::is_scopeB::Deparse::is_scope
0000s0sB::Deparse::::is_stateB::Deparse::is_state
0000s0sB::Deparse::::is_subscriptableB::Deparse::is_subscriptable
0000s0sB::Deparse::::keywordB::Deparse::keyword
0000s0sB::Deparse::::lex_in_scopeB::Deparse::lex_in_scope
0000s0sB::Deparse::::lineseqB::Deparse::lineseq
0000s0sB::Deparse::::list_constB::Deparse::list_const
0000s0sB::Deparse::::listopB::Deparse::listop
0000s0sB::Deparse::::logassignopB::Deparse::logassignop
0000s0sB::Deparse::::logopB::Deparse::logop
0000s0sB::Deparse::::loop_commonB::Deparse::loop_common
0000s0sB::Deparse::::loopexB::Deparse::loopex
0000s0sB::Deparse::::mapopB::Deparse::mapop
0000s0sB::Deparse::::matchopB::Deparse::matchop
0000s0sB::Deparse::::maybe_localB::Deparse::maybe_local
0000s0sB::Deparse::::maybe_myB::Deparse::maybe_my
0000s0sB::Deparse::::maybe_parensB::Deparse::maybe_parens
0000s0sB::Deparse::::maybe_parens_funcB::Deparse::maybe_parens_func
0000s0sB::Deparse::::maybe_parens_unopB::Deparse::maybe_parens_unop
0000s0sB::Deparse::::maybe_qualifyB::Deparse::maybe_qualify
0000s0sB::Deparse::::maybe_targmyB::Deparse::maybe_targmy
0000s0sB::Deparse::::meth_rclass_svB::Deparse::meth_rclass_sv
0000s0sB::Deparse::::meth_svB::Deparse::meth_sv
0000s0sB::Deparse::::methodB::Deparse::method
0000s0sB::Deparse::::multideref_var_nameB::Deparse::multideref_var_name
0000s0sB::Deparse::::newB::Deparse::new
0000s0sB::Deparse::::next_todoB::Deparse::next_todo
0000s0sB::Deparse::::nullB::Deparse::null
0000s0sB::Deparse::::pad_subsB::Deparse::pad_subs
0000s0sB::Deparse::::padanyB::Deparse::padany
0000s0sB::Deparse::::padnameB::Deparse::padname
0000s0sB::Deparse::::padname_svB::Deparse::padname_sv
0000s0sB::Deparse::::padvalB::Deparse::padval
0000s0sB::Deparse::::pchrB::Deparse::pchr
0000s0sB::Deparse::::pessimiseB::Deparse::pessimise
0000s0sB::Deparse::::pfixopB::Deparse::pfixop
0000s0sB::Deparse::::populate_curcvlexB::Deparse::populate_curcvlex
0000s0sB::Deparse::::pp_aassignB::Deparse::pp_aassign
0000s0sB::Deparse::::pp_absB::Deparse::pp_abs
0000s0sB::Deparse::::pp_acceptB::Deparse::pp_accept
0000s0sB::Deparse::::pp_addB::Deparse::pp_add
0000s0sB::Deparse::::pp_aeachB::Deparse::pp_aeach
0000s0sB::Deparse::::pp_aelemB::Deparse::pp_aelem
0000s0sB::Deparse::::pp_aelemfastB::Deparse::pp_aelemfast
0000s0sB::Deparse::::pp_aelemfast_lexB::Deparse::pp_aelemfast_lex
0000s0sB::Deparse::::pp_akeysB::Deparse::pp_akeys
0000s0sB::Deparse::::pp_alarmB::Deparse::pp_alarm
0000s0sB::Deparse::::pp_andB::Deparse::pp_and
0000s0sB::Deparse::::pp_andassignB::Deparse::pp_andassign
0000s0sB::Deparse::::pp_anonlistB::Deparse::pp_anonlist
0000s0sB::Deparse::::pp_asliceB::Deparse::pp_aslice
0000s0sB::Deparse::::pp_atan2B::Deparse::pp_atan2
0000s0sB::Deparse::::pp_av2arylenB::Deparse::pp_av2arylen
0000s0sB::Deparse::::pp_avaluesB::Deparse::pp_avalues
0000s0sB::Deparse::::pp_backtickB::Deparse::pp_backtick
0000s0sB::Deparse::::pp_bindB::Deparse::pp_bind
0000s0sB::Deparse::::pp_binmodeB::Deparse::pp_binmode
0000s0sB::Deparse::::pp_bit_andB::Deparse::pp_bit_and
0000s0sB::Deparse::::pp_bit_orB::Deparse::pp_bit_or
0000s0sB::Deparse::::pp_bit_xorB::Deparse::pp_bit_xor
0000s0sB::Deparse::::pp_blessB::Deparse::pp_bless
0000s0sB::Deparse::::pp_boolkeysB::Deparse::pp_boolkeys
0000s0sB::Deparse::::pp_breakB::Deparse::pp_break
0000s0sB::Deparse::::pp_callerB::Deparse::pp_caller
0000s0sB::Deparse::::pp_chdirB::Deparse::pp_chdir
0000s0sB::Deparse::::pp_chmodB::Deparse::pp_chmod
0000s0sB::Deparse::::pp_chompB::Deparse::pp_chomp
0000s0sB::Deparse::::pp_chopB::Deparse::pp_chop
0000s0sB::Deparse::::pp_chownB::Deparse::pp_chown
0000s0sB::Deparse::::pp_chrB::Deparse::pp_chr
0000s0sB::Deparse::::pp_chrootB::Deparse::pp_chroot
0000s0sB::Deparse::::pp_closeB::Deparse::pp_close
0000s0sB::Deparse::::pp_closedirB::Deparse::pp_closedir
0000s0sB::Deparse::::pp_complementB::Deparse::pp_complement
0000s0sB::Deparse::::pp_concatB::Deparse::pp_concat
0000s0sB::Deparse::::pp_cond_exprB::Deparse::pp_cond_expr
0000s0sB::Deparse::::pp_connectB::Deparse::pp_connect
0000s0sB::Deparse::::pp_constB::Deparse::pp_const
0000s0sB::Deparse::::pp_continueB::Deparse::pp_continue
0000s0sB::Deparse::::pp_cosB::Deparse::pp_cos
0000s0sB::Deparse::::pp_cryptB::Deparse::pp_crypt
0000s0sB::Deparse::::pp_dbmcloseB::Deparse::pp_dbmclose
0000s0sB::Deparse::::pp_dbmopenB::Deparse::pp_dbmopen
0000s0sB::Deparse::::pp_dbstateB::Deparse::pp_dbstate
0000s0sB::Deparse::::pp_definedB::Deparse::pp_defined
0000s0sB::Deparse::::pp_deleteB::Deparse::pp_delete
0000s0sB::Deparse::::pp_dieB::Deparse::pp_die
0000s0sB::Deparse::::pp_divideB::Deparse::pp_divide
0000s0sB::Deparse::::pp_dofileB::Deparse::pp_dofile
0000s0sB::Deparse::::pp_dorB::Deparse::pp_dor
0000s0sB::Deparse::::pp_dorassignB::Deparse::pp_dorassign
0000s0sB::Deparse::::pp_dumpB::Deparse::pp_dump
0000s0sB::Deparse::::pp_eachB::Deparse::pp_each
0000s0sB::Deparse::::pp_egrentB::Deparse::pp_egrent
0000s0sB::Deparse::::pp_ehostentB::Deparse::pp_ehostent
0000s0sB::Deparse::::pp_enetentB::Deparse::pp_enetent
0000s0sB::Deparse::::pp_enterevalB::Deparse::pp_entereval
0000s0sB::Deparse::::pp_entersubB::Deparse::pp_entersub
0000s0sB::Deparse::::pp_enterwriteB::Deparse::pp_enterwrite
0000s0sB::Deparse::::pp_eofB::Deparse::pp_eof
0000s0sB::Deparse::::pp_eprotoentB::Deparse::pp_eprotoent
0000s0sB::Deparse::::pp_epwentB::Deparse::pp_epwent
0000s0sB::Deparse::::pp_eqB::Deparse::pp_eq
0000s0sB::Deparse::::pp_eserventB::Deparse::pp_eservent
0000s0sB::Deparse::::pp_execB::Deparse::pp_exec
0000s0sB::Deparse::::pp_existsB::Deparse::pp_exists
0000s0sB::Deparse::::pp_exitB::Deparse::pp_exit
0000s0sB::Deparse::::pp_expB::Deparse::pp_exp
0000s0sB::Deparse::::pp_fcB::Deparse::pp_fc
0000s0sB::Deparse::::pp_fcntlB::Deparse::pp_fcntl
0000s0sB::Deparse::::pp_filenoB::Deparse::pp_fileno
0000s0sB::Deparse::::pp_flockB::Deparse::pp_flock
0000s0sB::Deparse::::pp_flopB::Deparse::pp_flop
0000s0sB::Deparse::::pp_forkB::Deparse::pp_fork
0000s0sB::Deparse::::pp_formlineB::Deparse::pp_formline
0000s0sB::Deparse::::pp_ftatimeB::Deparse::pp_ftatime
0000s0sB::Deparse::::pp_ftbinaryB::Deparse::pp_ftbinary
0000s0sB::Deparse::::pp_ftblkB::Deparse::pp_ftblk
0000s0sB::Deparse::::pp_ftchrB::Deparse::pp_ftchr
0000s0sB::Deparse::::pp_ftctimeB::Deparse::pp_ftctime
0000s0sB::Deparse::::pp_ftdirB::Deparse::pp_ftdir
0000s0sB::Deparse::::pp_fteexecB::Deparse::pp_fteexec
0000s0sB::Deparse::::pp_fteownedB::Deparse::pp_fteowned
0000s0sB::Deparse::::pp_ftereadB::Deparse::pp_fteread
0000s0sB::Deparse::::pp_ftewriteB::Deparse::pp_ftewrite
0000s0sB::Deparse::::pp_ftfileB::Deparse::pp_ftfile
0000s0sB::Deparse::::pp_ftisB::Deparse::pp_ftis
0000s0sB::Deparse::::pp_ftlinkB::Deparse::pp_ftlink
0000s0sB::Deparse::::pp_ftmtimeB::Deparse::pp_ftmtime
0000s0sB::Deparse::::pp_ftpipeB::Deparse::pp_ftpipe
0000s0sB::Deparse::::pp_ftrexecB::Deparse::pp_ftrexec
0000s0sB::Deparse::::pp_ftrownedB::Deparse::pp_ftrowned
0000s0sB::Deparse::::pp_ftrreadB::Deparse::pp_ftrread
0000s0sB::Deparse::::pp_ftrwriteB::Deparse::pp_ftrwrite
0000s0sB::Deparse::::pp_ftsgidB::Deparse::pp_ftsgid
0000s0sB::Deparse::::pp_ftsizeB::Deparse::pp_ftsize
0000s0sB::Deparse::::pp_ftsockB::Deparse::pp_ftsock
0000s0sB::Deparse::::pp_ftsuidB::Deparse::pp_ftsuid
0000s0sB::Deparse::::pp_ftsvtxB::Deparse::pp_ftsvtx
0000s0sB::Deparse::::pp_fttextB::Deparse::pp_fttext
0000s0sB::Deparse::::pp_ftttyB::Deparse::pp_fttty
0000s0sB::Deparse::::pp_ftzeroB::Deparse::pp_ftzero
0000s0sB::Deparse::::pp_geB::Deparse::pp_ge
0000s0sB::Deparse::::pp_gelemB::Deparse::pp_gelem
0000s0sB::Deparse::::pp_getcB::Deparse::pp_getc
0000s0sB::Deparse::::pp_getloginB::Deparse::pp_getlogin
0000s0sB::Deparse::::pp_getpeernameB::Deparse::pp_getpeername
0000s0sB::Deparse::::pp_getpgrpB::Deparse::pp_getpgrp
0000s0sB::Deparse::::pp_getppidB::Deparse::pp_getppid
0000s0sB::Deparse::::pp_getpriorityB::Deparse::pp_getpriority
0000s0sB::Deparse::::pp_getsocknameB::Deparse::pp_getsockname
0000s0sB::Deparse::::pp_ggrentB::Deparse::pp_ggrent
0000s0sB::Deparse::::pp_ggrgidB::Deparse::pp_ggrgid
0000s0sB::Deparse::::pp_ggrnamB::Deparse::pp_ggrnam
0000s0sB::Deparse::::pp_ghbyaddrB::Deparse::pp_ghbyaddr
0000s0sB::Deparse::::pp_ghbynameB::Deparse::pp_ghbyname
0000s0sB::Deparse::::pp_ghostentB::Deparse::pp_ghostent
0000s0sB::Deparse::::pp_globB::Deparse::pp_glob
0000s0sB::Deparse::::pp_gmtimeB::Deparse::pp_gmtime
0000s0sB::Deparse::::pp_gnbyaddrB::Deparse::pp_gnbyaddr
0000s0sB::Deparse::::pp_gnbynameB::Deparse::pp_gnbyname
0000s0sB::Deparse::::pp_gnetentB::Deparse::pp_gnetent
0000s0sB::Deparse::::pp_gotoB::Deparse::pp_goto
0000s0sB::Deparse::::pp_gpbynameB::Deparse::pp_gpbyname
0000s0sB::Deparse::::pp_gpbynumberB::Deparse::pp_gpbynumber
0000s0sB::Deparse::::pp_gprotoentB::Deparse::pp_gprotoent
0000s0sB::Deparse::::pp_gpwentB::Deparse::pp_gpwent
0000s0sB::Deparse::::pp_gpwnamB::Deparse::pp_gpwnam
0000s0sB::Deparse::::pp_gpwuidB::Deparse::pp_gpwuid
0000s0sB::Deparse::::pp_grepstartB::Deparse::pp_grepstart
0000s0sB::Deparse::::pp_grepwhileB::Deparse::pp_grepwhile
0000s0sB::Deparse::::pp_gsbynameB::Deparse::pp_gsbyname
0000s0sB::Deparse::::pp_gsbyportB::Deparse::pp_gsbyport
0000s0sB::Deparse::::pp_gserventB::Deparse::pp_gservent
0000s0sB::Deparse::::pp_gsockoptB::Deparse::pp_gsockopt
0000s0sB::Deparse::::pp_gtB::Deparse::pp_gt
0000s0sB::Deparse::::pp_gvB::Deparse::pp_gv
0000s0sB::Deparse::::pp_gvsvB::Deparse::pp_gvsv
0000s0sB::Deparse::::pp_helemB::Deparse::pp_helem
0000s0sB::Deparse::::pp_hexB::Deparse::pp_hex
0000s0sB::Deparse::::pp_hsliceB::Deparse::pp_hslice
0000s0sB::Deparse::::pp_i_addB::Deparse::pp_i_add
0000s0sB::Deparse::::pp_i_divideB::Deparse::pp_i_divide
0000s0sB::Deparse::::pp_i_eqB::Deparse::pp_i_eq
0000s0sB::Deparse::::pp_i_geB::Deparse::pp_i_ge
0000s0sB::Deparse::::pp_i_gtB::Deparse::pp_i_gt
0000s0sB::Deparse::::pp_i_leB::Deparse::pp_i_le
0000s0sB::Deparse::::pp_i_ltB::Deparse::pp_i_lt
0000s0sB::Deparse::::pp_i_moduloB::Deparse::pp_i_modulo
0000s0sB::Deparse::::pp_i_multiplyB::Deparse::pp_i_multiply
0000s0sB::Deparse::::pp_i_ncmpB::Deparse::pp_i_ncmp
0000s0sB::Deparse::::pp_i_neB::Deparse::pp_i_ne
0000s0sB::Deparse::::pp_i_negateB::Deparse::pp_i_negate
0000s0sB::Deparse::::pp_i_postdecB::Deparse::pp_i_postdec
0000s0sB::Deparse::::pp_i_postincB::Deparse::pp_i_postinc
0000s0sB::Deparse::::pp_i_predecB::Deparse::pp_i_predec
0000s0sB::Deparse::::pp_i_preincB::Deparse::pp_i_preinc
0000s0sB::Deparse::::pp_i_subtractB::Deparse::pp_i_subtract
0000s0sB::Deparse::::pp_indexB::Deparse::pp_index
0000s0sB::Deparse::::pp_intB::Deparse::pp_int
0000s0sB::Deparse::::pp_introcvB::Deparse::pp_introcv
0000s0sB::Deparse::::pp_ioctlB::Deparse::pp_ioctl
0000s0sB::Deparse::::pp_joinB::Deparse::pp_join
0000s0sB::Deparse::::pp_keysB::Deparse::pp_keys
0000s0sB::Deparse::::pp_killB::Deparse::pp_kill
0000s0sB::Deparse::::pp_kvasliceB::Deparse::pp_kvaslice
0000s0sB::Deparse::::pp_kvhsliceB::Deparse::pp_kvhslice
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_lvavrefB::Deparse::pp_lvavref
0000s0sB::Deparse::::pp_lvrefB::Deparse::pp_lvref
0000s0sB::Deparse::::pp_lvrefsliceB::Deparse::pp_lvrefslice
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_multiderefB::Deparse::pp_multideref
0000s0sB::Deparse::::pp_multiplyB::Deparse::pp_multiply
0000s0sB::Deparse::::pp_ncmpB::Deparse::pp_ncmp
0000s0sB::Deparse::::pp_neB::Deparse::pp_ne
0000s0sB::Deparse::::pp_negateB::Deparse::pp_negate
0000s0sB::Deparse::::pp_nextB::Deparse::pp_next
0000s0sB::Deparse::::pp_nextstateB::Deparse::pp_nextstate
0000s0sB::Deparse::::pp_notB::Deparse::pp_not
0000s0sB::Deparse::::pp_nullB::Deparse::pp_null
0000s0sB::Deparse::::pp_octB::Deparse::pp_oct
0000s0sB::Deparse::::pp_onceB::Deparse::pp_once
0000s0sB::Deparse::::pp_openB::Deparse::pp_open
0000s0sB::Deparse::::pp_open_dirB::Deparse::pp_open_dir
0000s0sB::Deparse::::pp_orB::Deparse::pp_or
0000s0sB::Deparse::::pp_orassignB::Deparse::pp_orassign
0000s0sB::Deparse::::pp_ordB::Deparse::pp_ord
0000s0sB::Deparse::::pp_packB::Deparse::pp_pack
0000s0sB::Deparse::::pp_padavB::Deparse::pp_padav
0000s0sB::Deparse::::pp_padcvB::Deparse::pp_padcv
0000s0sB::Deparse::::pp_padhvB::Deparse::pp_padhv
0000s0sB::Deparse::::pp_padsvB::Deparse::pp_padsv
0000s0sB::Deparse::::pp_pipe_opB::Deparse::pp_pipe_op
0000s0sB::Deparse::::pp_popB::Deparse::pp_pop
0000s0sB::Deparse::::pp_posB::Deparse::pp_pos
0000s0sB::Deparse::::pp_postdecB::Deparse::pp_postdec
0000s0sB::Deparse::::pp_postincB::Deparse::pp_postinc
0000s0sB::Deparse::::pp_powB::Deparse::pp_pow
0000s0sB::Deparse::::pp_predecB::Deparse::pp_predec
0000s0sB::Deparse::::pp_preincB::Deparse::pp_preinc
0000s0sB::Deparse::::pp_printB::Deparse::pp_print
0000s0sB::Deparse::::pp_prototypeB::Deparse::pp_prototype
0000s0sB::Deparse::::pp_prtfB::Deparse::pp_prtf
0000s0sB::Deparse::::pp_pushB::Deparse::pp_push
0000s0sB::Deparse::::pp_pushreB::Deparse::pp_pushre
0000s0sB::Deparse::::pp_qrB::Deparse::pp_qr
0000s0sB::Deparse::::pp_quotemetaB::Deparse::pp_quotemeta
0000s0sB::Deparse::::pp_randB::Deparse::pp_rand
0000s0sB::Deparse::::pp_rcatlineB::Deparse::pp_rcatline
0000s0sB::Deparse::::pp_readB::Deparse::pp_read
0000s0sB::Deparse::::pp_readdirB::Deparse::pp_readdir
0000s0sB::Deparse::::pp_readlineB::Deparse::pp_readline
0000s0sB::Deparse::::pp_readlinkB::Deparse::pp_readlink
0000s0sB::Deparse::::pp_recvB::Deparse::pp_recv
0000s0sB::Deparse::::pp_redoB::Deparse::pp_redo
0000s0sB::Deparse::::pp_refB::Deparse::pp_ref
0000s0sB::Deparse::::pp_refassignB::Deparse::pp_refassign
0000s0sB::Deparse::::pp_refgenB::Deparse::pp_refgen
0000s0sB::Deparse::::pp_regcompB::Deparse::pp_regcomp
0000s0sB::Deparse::::pp_renameB::Deparse::pp_rename
0000s0sB::Deparse::::pp_repeatB::Deparse::pp_repeat
0000s0sB::Deparse::::pp_requireB::Deparse::pp_require
0000s0sB::Deparse::::pp_resetB::Deparse::pp_reset
0000s0sB::Deparse::::pp_returnB::Deparse::pp_return
0000s0sB::Deparse::::pp_reverseB::Deparse::pp_reverse
0000s0sB::Deparse::::pp_rewinddirB::Deparse::pp_rewinddir
0000s0sB::Deparse::::pp_right_shiftB::Deparse::pp_right_shift
0000s0sB::Deparse::::pp_rindexB::Deparse::pp_rindex
0000s0sB::Deparse::::pp_rmdirB::Deparse::pp_rmdir
0000s0sB::Deparse::::pp_runcvB::Deparse::pp_runcv
0000s0sB::Deparse::::pp_rv2avB::Deparse::pp_rv2av
0000s0sB::Deparse::::pp_rv2cvB::Deparse::pp_rv2cv
0000s0sB::Deparse::::pp_rv2gvB::Deparse::pp_rv2gv
0000s0sB::Deparse::::pp_rv2hvB::Deparse::pp_rv2hv
0000s0sB::Deparse::::pp_rv2svB::Deparse::pp_rv2sv
0000s0sB::Deparse::::pp_sassignB::Deparse::pp_sassign
0000s0sB::Deparse::::pp_sayB::Deparse::pp_say
0000s0sB::Deparse::::pp_sbit_andB::Deparse::pp_sbit_and
0000s0sB::Deparse::::pp_sbit_orB::Deparse::pp_sbit_or
0000s0sB::Deparse::::pp_sbit_xorB::Deparse::pp_sbit_xor
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_scomplementB::Deparse::pp_scomplement
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_tieB::Deparse::pp_tie
0000s0sB::Deparse::::pp_tiedB::Deparse::pp_tied
0000s0sB::Deparse::::pp_timeB::Deparse::pp_time
0000s0sB::Deparse::::pp_tmsB::Deparse::pp_tms
0000s0sB::Deparse::::pp_transB::Deparse::pp_trans
0000s0sB::Deparse::::pp_transrB::Deparse::pp_transr
0000s0sB::Deparse::::pp_truncateB::Deparse::pp_truncate
0000s0sB::Deparse::::pp_ucB::Deparse::pp_uc
0000s0sB::Deparse::::pp_ucfirstB::Deparse::pp_ucfirst
0000s0sB::Deparse::::pp_umaskB::Deparse::pp_umask
0000s0sB::Deparse::::pp_undefB::Deparse::pp_undef
0000s0sB::Deparse::::pp_unlinkB::Deparse::pp_unlink
0000s0sB::Deparse::::pp_unpackB::Deparse::pp_unpack
0000s0sB::Deparse::::pp_unshiftB::Deparse::pp_unshift
0000s0sB::Deparse::::pp_unstackB::Deparse::pp_unstack
0000s0sB::Deparse::::pp_untieB::Deparse::pp_untie
0000s0sB::Deparse::::pp_utimeB::Deparse::pp_utime
0000s0sB::Deparse::::pp_valuesB::Deparse::pp_values
0000s0sB::Deparse::::pp_vecB::Deparse::pp_vec
0000s0sB::Deparse::::pp_waitB::Deparse::pp_wait
0000s0sB::Deparse::::pp_waitpidB::Deparse::pp_waitpid
0000s0sB::Deparse::::pp_wantarrayB::Deparse::pp_wantarray
0000s0sB::Deparse::::pp_warnB::Deparse::pp_warn
0000s0sB::Deparse::::pp_xorB::Deparse::pp_xor
0000s0sB::Deparse::::print_protosB::Deparse::print_protos
0000s0sB::Deparse::::pure_stringB::Deparse::pure_string
0000s0sB::Deparse::::rangeB::Deparse::range
0000s0sB::Deparse::::re_dqB::Deparse::re_dq
0000s0sB::Deparse::::re_dq_disambiguateB::Deparse::re_dq_disambiguate
0000s0sB::Deparse::::re_flagsB::Deparse::re_flags
0000s0sB::Deparse::::re_unbackB::Deparse::re_unback
0000s0sB::Deparse::::re_uninterpB::Deparse::re_uninterp
0000s0sB::Deparse::::real_concatB::Deparse::real_concat
0000s0sB::Deparse::::real_negateB::Deparse::real_negate
0000s0sB::Deparse::::regcompB::Deparse::regcomp
0000s0sB::Deparse::::repeatB::Deparse::repeat
0000s0sB::Deparse::::retscalarB::Deparse::retscalar
0000s0sB::Deparse::::rv2gv_or_stringB::Deparse::rv2gv_or_string
0000s0sB::Deparse::::rv2xB::Deparse::rv2x
0000s0sB::Deparse::::scopeopB::Deparse::scopeop
0000s0sB::Deparse::::seq_subsB::Deparse::seq_subs
0000s0sB::Deparse::::single_delimB::Deparse::single_delim
0000s0sB::Deparse::::sliceB::Deparse::slice
0000s0sB::Deparse::::splitB::Deparse::split
0000s0sB::Deparse::::split_floatB::Deparse::split_float
0000s0sB::Deparse::::stash_subsB::Deparse::stash_subs
0000s0sB::Deparse::::stash_variableB::Deparse::stash_variable
0000s0sB::Deparse::::stash_variable_nameB::Deparse::stash_variable_name
0000s0sB::Deparse::::style_optsB::Deparse::style_opts
0000s0sB::Deparse::::todoB::Deparse::todo
0000s0sB::Deparse::::tr_chrB::Deparse::tr_chr
0000s0sB::Deparse::::tr_decode_byteB::Deparse::tr_decode_byte
0000s0sB::Deparse::::tr_decode_utf8B::Deparse::tr_decode_utf8
0000s0sB::Deparse::::unbackB::Deparse::unback
0000s0sB::Deparse::::uninterpB::Deparse::uninterp
0000s0sB::Deparse::::unopB::Deparse::unop
0000s0sB::Deparse::::walk_lineseqB::Deparse::walk_lineseq
0000s0sB::Deparse::::want_listB::Deparse::want_list
0000s0sB::Deparse::::want_scalarB::Deparse::want_scalar
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# B::Deparse.pm
2# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
3# All rights reserved.
4# This module is free software; you can redistribute and/or modify
5# it under the same terms as Perl itself.
6
7# This is based on the module of the same name by Malcolm Beattie,
8# but essentially none of his code remains.
9
10package B::Deparse;
11255µs259µs
# spent 34µs (9+25) within B::Deparse::BEGIN@11 which was called: # once (9µs+25µs) by YAML::XS::BEGIN@57 at line 11
use Carp;
# spent 34µs making 1 call to B::Deparse::BEGIN@11 # spent 25µs making 1 call to Exporter::import
1214µs1606µs
# spent 613µs (7+606) within B::Deparse::BEGIN@12 which was called: # once (7µs+606µs) by YAML::XS::BEGIN@57 at line 47
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
# spent 606µ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 OPf_PARENS
15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17 OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
18 OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE
19 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
20 SVs_PADTMP SVpad_TYPED
21 CVf_METHOD CVf_LVALUE
22 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
23 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
24 PADNAMEt_OUTER
25 MDEREF_reload
26 MDEREF_AV_pop_rv2av_aelem
27 MDEREF_AV_gvsv_vivify_rv2av_aelem
28 MDEREF_AV_padsv_vivify_rv2av_aelem
29 MDEREF_AV_vivify_rv2av_aelem
30 MDEREF_AV_padav_aelem
31 MDEREF_AV_gvav_aelem
32 MDEREF_HV_pop_rv2hv_helem
33 MDEREF_HV_gvsv_vivify_rv2hv_helem
34 MDEREF_HV_padsv_vivify_rv2hv_helem
35 MDEREF_HV_vivify_rv2hv_helem
36 MDEREF_HV_padhv_helem
37 MDEREF_HV_gvhv_helem
38 MDEREF_ACTION_MASK
39 MDEREF_INDEX_none
40 MDEREF_INDEX_const
41 MDEREF_INDEX_padsv
42 MDEREF_INDEX_gvsv
43 MDEREF_INDEX_MASK
44 MDEREF_FLAG_last
45 MDEREF_MASK
46 MDEREF_SHIFT
47129µs1613µs );
# spent 613µs making 1 call to B::Deparse::BEGIN@12
48
491500ns$VERSION = '1.35';
50214µs28µs
# spent 7µs (5+1) within B::Deparse::BEGIN@50 which was called: # once (5µs+1µs) by YAML::XS::BEGIN@57 at line 50
use strict;
# spent 7µs making 1 call to B::Deparse::BEGIN@50 # spent 1µs making 1 call to strict::import
51214µs229µs
# spent 17µs (4+13) within B::Deparse::BEGIN@51 which was called: # once (4µs+13µs) by YAML::XS::BEGIN@57 at line 51
use vars qw/$AUTOLOAD/;
# spent 17µs making 1 call to B::Deparse::BEGIN@51 # spent 13µs making 1 call to vars::import
52235µs12µs
# spent 2µs within B::Deparse::BEGIN@52 which was called: # once (2µs+0s) by YAML::XS::BEGIN@57 at line 52
use warnings ();
# spent 2µs making 1 call to B::Deparse::BEGIN@52
531484µsrequire feature;
54
55
# spent 5.89ms (83µs+5.80) within B::Deparse::BEGIN@55 which was called: # once (83µs+5.80ms) by YAML::XS::BEGIN@57 at line 70
BEGIN {
56 # List version-specific constants here.
57 # Easiest way to keep this code portable between version looks to
58 # be to fake up a dummy constant that will never actually be true.
5913µs foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
60 OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
61 RXf_PMf_CHARSET RXf_PMf_KEEPCOPY CVf_ANONCONST
62 CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
63 PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES
64 OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV
65 OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) {
664618µs235.80ms eval { import B $_ };
# spent 5.80ms making 23 calls to Exporter::import, avg 252µs/call
67240µs223µs
# spent 16µs (9+7) within B::Deparse::BEGIN@67 which was called: # once (9µs+7µs) by YAML::XS::BEGIN@57 at line 67
no strict 'refs';
# spent 16µs making 1 call to B::Deparse::BEGIN@67 # spent 7µs making 1 call to strict::unimport
682349µs *{$_} = sub () {0} unless *{$_}{CODE};
69 }
701155µs15.89ms}
# spent 5.89ms making 1 call to B::Deparse::BEGIN@55
71
72# Changes between 0.50 and 0.51:
73# - fixed nulled leave with live enter in sort { }
74# - fixed reference constants (\"str")
75# - handle empty programs gracefully
76# - handle infinite loops (for (;;) {}, while (1) {})
77# - differentiate between 'for my $x ...' and 'my $x; for $x ...'
78# - various minor cleanups
79# - moved globals into an object
80# - added '-u', like B::C
81# - package declarations using cop_stash
82# - subs, formats and code sorted by cop_seq
83# Changes between 0.51 and 0.52:
84# - added pp_threadsv (special variables under USE_5005THREADS)
85# - added documentation
86# Changes between 0.52 and 0.53:
87# - many changes adding precedence contexts and associativity
88# - added '-p' and '-s' output style options
89# - various other minor fixes
90# Changes between 0.53 and 0.54:
91# - added support for new 'for (1..100)' optimization,
92# thanks to Gisle Aas
93# Changes between 0.54 and 0.55:
94# - added support for new qr// construct
95# - added support for new pp_regcreset OP
96# Changes between 0.55 and 0.56:
97# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
98# - fixed $# on non-lexicals broken in last big rewrite
99# - added temporary fix for change in opcode of OP_STRINGIFY
100# - fixed problem in 0.54's for() patch in 'for (@ary)'
101# - fixed precedence in conditional of ?:
102# - tweaked list paren elimination in 'my($x) = @_'
103# - made continue-block detection trickier wrt. null ops
104# - fixed various prototype problems in pp_entersub
105# - added support for sub prototypes that never get GVs
106# - added unquoting for special filehandle first arg in truncate
107# - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
108# - added semicolons at the ends of blocks
109# - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
110# Changes between 0.56 and 0.561:
111# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
112# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
113# Changes between 0.561 and 0.57:
114# - stylistic changes to symbolic constant stuff
115# - handled scope in s///e replacement code
116# - added unquote option for expanding "" into concats, etc.
117# - split method and proto parts of pp_entersub into separate functions
118# - various minor cleanups
119# Changes after 0.57:
120# - added parens in \&foo (patch by Albert Dvornik)
121# Changes between 0.57 and 0.58:
122# - fixed '0' statements that weren't being printed
123# - added methods for use from other programs
124# (based on patches from James Duncan and Hugo van der Sanden)
125# - added -si and -sT to control indenting (also based on a patch from Hugo)
126# - added -sv to print something else instead of '???'
127# - preliminary version of utf8 tr/// handling
128# Changes after 0.58:
129# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
130# - added support for Hugo's new OP_SETSTATE (like nextstate)
131# Changes between 0.58 and 0.59
132# - added support for Chip's OP_METHOD_NAMED
133# - added support for Ilya's OPpTARGET_MY optimization
134# - elided arrows before '()' subscripts when possible
135# Changes between 0.59 and 0.60
136# - support for method attributes was added
137# - some warnings fixed
138# - separate recognition of constant subs
139# - rewrote continue block handling, now recognizing for loops
140# - added more control of expanding control structures
141# Changes between 0.60 and 0.61 (mostly by Robin Houston)
142# - many bug-fixes
143# - support for pragmas and 'use'
144# - support for the little-used $[ variable
145# - support for __DATA__ sections
146# - UTF8 support
147# - BEGIN, CHECK, INIT and END blocks
148# - scoping of subroutine declarations fixed
149# - compile-time output from the input program can be suppressed, so that the
150# output is just the deparsed code. (a change to O.pm in fact)
151# - our() declarations
152# - *all* the known bugs are now listed in the BUGS section
153# - comprehensive test mechanism (TEST -deparse)
154# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
155# - bug-fixes
156# - new switch -P
157# - support for command-line switches (-l, -0, etc.)
158# Changes between 0.63 and 0.64
159# - support for //, CHECK blocks, and assertions
160# - improved handling of foreach loops and lexicals
161# - option to use Data::Dumper for constants
162# - more bug fixes
163# - discovered lots more bugs not yet fixed
164#
165# ...
166#
167# Changes between 0.72 and 0.73
168# - support new switch constructs
169
170# Todo:
171# (See also BUGS section at the end of this file)
172#
173# - finish tr/// changes
174# - add option for even more parens (generalize \&foo change)
175# - left/right context
176# - copy comments (look at real text with $^P?)
177# - avoid semis in one-statement blocks
178# - associativity of &&=, ||=, ?:
179# - ',' => '=>' (auto-unquote?)
180# - break long lines ("\r" as discretionary break?)
181# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
182# - more style options: brace style, hex vs. octal, quotes, ...
183# - print big ints as hex/octal instead of decimal (heuristic?)
184# - handle 'my $x if 0'?
185# - version using op_next instead of op_first/sibling?
186# - avoid string copies (pass arrays, one big join?)
187# - here-docs?
188
189# Current test.deparse failures
190# comp/hints 6 - location of BEGIN blocks wrt. block openings
191# run/switchI 1 - missing -I switches entirely
192# perl -Ifoo -e 'print @INC'
193# op/caller 2 - warning mask propagates backwards before warnings::register
194# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
195# op/getpid 2 - can't assign to shared my() declaration (threads only)
196# 'my $x : shared = 5'
197# op/override 7 - parens on overridden require change v-string interpretation
198# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
199# c.f. 'BEGIN { *f = sub {0} }; f 2'
200# op/pat 774 - losing Unicode-ness of Latin1-only strings
201# 'use charnames ":short"; $x="\N{latin:a with acute}"'
202# op/recurse 12 - missing parens on recursive call makes it look like method
203# 'sub f { f($x) }'
204# op/subst 90 - inconsistent handling of utf8 under "use utf8"
205# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
206# op/tiehandle compile - "use strict" deparsed in the wrong place
207# uni/tr_ several
208# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
209# ext/Data/Dumper/t/dumper compile
210# ext/DB_file/several
211# ext/Encode/several
212# ext/Ernno/Errno warnings
213# ext/IO/lib/IO/t/io_sel 23
214# ext/PerlIO/t/encoding compile
215# ext/POSIX/t/posix 6
216# ext/Socket/Socket 8
217# ext/Storable/t/croak compile
218# lib/Attribute/Handlers/t/multi compile
219# lib/bignum/ several
220# lib/charnames 35
221# lib/constant 32
222# lib/English 40
223# lib/ExtUtils/t/bytes 4
224# lib/File/DosGlob compile
225# lib/Filter/Simple/t/data 1
226# lib/Math/BigInt/t/constant 1
227# lib/Net/t/config Deparse-warning
228# lib/overload compile
229# lib/Switch/ several
230# lib/Symbol 4
231# lib/Test/Simple several
232# lib/Term/Complete
233# lib/Tie/File/t/29_downcopy 5
234# lib/vars 22
235
236# Object fields:
237#
238# in_coderef2text:
239# True when deparsing via $deparse->coderef2text; false when deparsing the
240# main program.
241#
242# avoid_local:
243# (local($a), local($b)) and local($a, $b) have the same internal
244# representation but the short form looks better. We notice we can
245# use a large-scale local when checking the list, but need to prevent
246# individual locals too. This hash holds the addresses of OPs that
247# have already had their local-ness accounted for. The same thing
248# is done with my().
249#
250# curcv:
251# CV for current sub (or main program) being deparsed
252#
253# curcvlex:
254# Cached hash of lexical variables for curcv: keys are
255# names prefixed with "m" or "o" (representing my/our), and
256# each value is an array with two elements indicating the cop_seq
257# of scopes in which a var of that name is valid and a third ele-
258# ment referencing the pad name.
259#
260# curcop:
261# COP for statement being deparsed
262#
263# curstash:
264# name of the current package for deparsed code
265#
266# subs_todo:
267# array of [cop_seq, CV, is_format?, name] for subs and formats we still
268# want to deparse. The fourth element is a pad name thingy for lexical
269# subs or a string for special blocks. For other subs, it is undef. For
270# lexical subs, CV may be undef, indicating a stub declaration.
271#
272# protos_todo:
273# as above, but [name, prototype] for subs that never got a GV
274#
275# subs_done, forms_done:
276# keys are addresses of GVs for subs and formats we've already
277# deparsed (or at least put into subs_todo)
278#
279# subs_declared
280# keys are names of subs for which we've printed declarations.
281# That means we can omit parentheses from the arguments. It also means we
282# need to put CORE:: on core functions of the same name.
283#
284# in_subst_repl
285# True when deparsing the replacement part of a substitution.
286#
287# in_refgen
288# True when deparsing the argument to \.
289#
290# parens: -p
291# linenums: -l
292# unquote: -q
293# cuddle: ' ' or '\n', depending on -sC
294# indent_size: -si
295# use_tabs: -sT
296# ex_const: -sv
297
298# A little explanation of how precedence contexts and associativity
299# work:
300#
301# deparse() calls each per-op subroutine with an argument $cx (short
302# for context, but not the same as the cx* in the perl core), which is
303# a number describing the op's parents in terms of precedence, whether
304# they're inside an expression or at statement level, etc. (see
305# chart below). When ops with children call deparse on them, they pass
306# along their precedence. Fractional values are used to implement
307# associativity ('($x + $y) + $z' => '$x + $y + $y') and related
308# parentheses hacks. The major disadvantage of this scheme is that
309# it doesn't know about right sides and left sides, so say if you
310# assign a listop to a variable, it can't tell it's allowed to leave
311# the parens off the listop.
312
313# Precedences:
314# 26 [TODO] inside interpolation context ("")
315# 25 left terms and list operators (leftward)
316# 24 left ->
317# 23 nonassoc ++ --
318# 22 right **
319# 21 right ! ~ \ and unary + and -
320# 20 left =~ !~
321# 19 left * / % x
322# 18 left + - .
323# 17 left << >>
324# 16 nonassoc named unary operators
325# 15 nonassoc < > <= >= lt gt le ge
326# 14 nonassoc == != <=> eq ne cmp
327# 13 left &
328# 12 left | ^
329# 11 left &&
330# 10 left ||
331# 9 nonassoc .. ...
332# 8 right ?:
333# 7 right = += -= *= etc.
334# 6 left , =>
335# 5 nonassoc list operators (rightward)
336# 4 right not
337# 3 left and
338# 2 left or xor
339# 1 statement modifiers
340# 0.5 statements, but still print scopes as do { ... }
341# 0 statement level
342# -1 format body
343
344# Nonprinting characters with special meaning:
345# \cS - steal parens (see maybe_parens_unop)
346# \n - newline and indent
347# \t - increase indent
348# \b - decrease indent ('outdent')
349# \f - flush left (no indent)
350# \cK - kill following semicolon, if any
351
352# Semicolon handling:
353# - Individual statements are not deparsed with trailing semicolons.
354# (If necessary, \cK is tacked on to the end.)
355# - Whatever code joins statements together or emits them (lineseq,
356# scopeop, deparse_root) is responsible for adding semicolons where
357# necessary.
358# - use statements are deparsed with trailing semicolons because they are
359# immediately concatenated with the following statement.
360# - indent() removes semicolons wherever it sees \cK.
361
362
36313µs
# spent 204µs (187+17) within B::Deparse::BEGIN@363 which was called: # once (187µs+17µs) by YAML::XS::BEGIN@57 at line 366
BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
364 nextstate dbstate rv2av rv2hv helem custom ]) {
36514200µs1417µs eval "sub OP_\U$_ () { " . opnumber($_) . "}"
# spent 17µs making 14 calls to B::opnumber, avg 1µs/call
36611.03ms1204µs}}
# spent 204µs making 1 call to B::Deparse::BEGIN@363
367
368# _pessimise_walk(): recursively walk the optree of a sub,
369# possibly undoing optimisations along the way.
370
371sub _pessimise_walk {
372 my ($self, $startop) = @_;
373
374 return unless $$startop;
375 my ($op, $prevop);
376 for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
377 my $ppname = $op->name;
378
379 # pessimisations start here
380
381 if ($ppname eq "padrange") {
382 # remove PADRANGE:
383 # the original optimisation either (1) changed this:
384 # pushmark -> (various pad and list and null ops) -> the_rest
385 # or (2), for the = @_ case, changed this:
386 # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest
387 # into this:
388 # padrange ----------------------------------------> the_rest
389 # so we just need to convert the padrange back into a
390 # pushmark, and in case (1), set its op_next to op_sibling,
391 # which is the head of the original chain of optimised-away
392 # pad ops, or for (2), set it to sibling->first, which is
393 # the original gv[_].
394
395 $B::overlay->{$$op} = {
396 type => OP_PUSHMARK,
397 name => 'pushmark',
398 private => ($op->private & OPpLVAL_INTRO),
399 };
400 }
401
402 # pessimisations end here
403
404 if (class($op) eq 'PMOP'
405 && ref($op->pmreplroot)
406 && ${$op->pmreplroot}
407 && $op->pmreplroot->isa( 'B::OP' ))
408 {
409 $self-> _pessimise_walk($op->pmreplroot);
410 }
411
412 if ($op->flags & OPf_KIDS) {
413 $self-> _pessimise_walk($op->first);
414 }
415
416 }
417}
418
419
420# _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
421# possibly undoing optimisations along the way.
422
423sub _pessimise_walk_exe {
424 my ($self, $startop, $visited) = @_;
425
426 return unless $$startop;
427 return if $visited->{$$startop};
428 my ($op, $prevop);
429 for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
430 last if $visited->{$$op};
431 $visited->{$$op} = 1;
432 my $ppname = $op->name;
433 if ($ppname =~
434 /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
435 # entertry is also a logop, but its op_other invariably points
436 # into the same chain as the main execution path, so we skip it
437 ) {
438 $self->_pessimise_walk_exe($op->other, $visited);
439 }
440 elsif ($ppname eq "subst") {
441 $self->_pessimise_walk_exe($op->pmreplstart, $visited);
442 }
443 elsif ($ppname =~ /^(enter(loop|iter))$/) {
444 # redoop and nextop will already be covered by the main block
445 # of the loop
446 $self->_pessimise_walk_exe($op->lastop, $visited);
447 }
448
449 # pessimisations start here
450 }
451}
452
453# Go through an optree and "remove" some optimisations by using an
454# overlay to selectively modify or un-null some ops. Deparsing in the
455# absence of those optimisations is then easier.
456#
457# Note that older optimisations are not removed, as Deparse was already
458# written to recognise them before the pessimise/overlay system was added.
459
460sub pessimise {
461 my ($self, $root, $start) = @_;
462
463 # walk tree in root-to-branch order
464 $self->_pessimise_walk($root);
465
466 my %visited;
467 # walk tree in execution order
468 $self->_pessimise_walk_exe($start, \%visited);
469}
470
471
472sub null {
473 my $op = shift;
474 return class($op) eq "NULL";
475}
476
477sub todo {
478 my $self = shift;
479 my($cv, $is_form, $name) = @_;
480 my $cvfile = $cv->FILE//'';
481 return unless ($cvfile eq $0 || exists $self->{files}{$cvfile});
482 my $seq;
483 if ($cv->OUTSIDE_SEQ) {
484 $seq = $cv->OUTSIDE_SEQ;
485 } elsif (!null($cv->START) and is_state($cv->START)) {
486 $seq = $cv->START->cop_seq;
487 } else {
488 $seq = 0;
489 }
490 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
491}
492
493sub next_todo {
494 my $self = shift;
495 my $ent = shift @{$self->{'subs_todo'}};
496 my $cv = $ent->[1];
497 if (ref $ent->[3]) { # lexical sub
498 my @text;
499
500 # At this point, we may not yet have deparsed the hints that allow
501 # lexical subroutines to be recognized. So adjust the current
502 # hints and deparse them.
503 # When lex subs cease being experimental, we should be able to
504 # remove this code.
505 {
506 local $^H = $self->{'hints'};
507 local %^H = %{ $self->{'hinthash'} || {} };
508 local ${^WARNING_BITS} = $self->{'warnings'};
509 feature->import("lexical_subs");
510 warnings->unimport("experimental::lexical_subs");
511 # Here we depend on the fact that individual features
512 # will always set the feature bundle to ‘custom’
513 # (== $feature::hint_mask). If we had another specific bundle
514 # enabled previously, normalise it.
515 if (($self->{'hints'} & $feature::hint_mask)
516 != $feature::hint_mask)
517 {
518 if ($self->{'hinthash'}) {
519 delete $self->{'hinthash'}{$_}
520 for grep /^feature_/, keys %{$self->{'hinthash'}};
521 }
522 else { $self->{'hinthash'} = {} }
523 $self->{'hinthash'}
524 = _features_from_bundle(@$self{'hints','hinthash'});
525 }
526 push @text, $self->declare_hinthash($self->{'hinthash'}, \%^H,
527 $self->{indent_size}, $^H);
528 push @text, $self->declare_warnings($self->{'warnings'},
529 ${^WARNING_BITS})
530 unless ($self->{'warnings'} // 'u')
531 eq (${^WARNING_BITS } // 'u');
532 $self->{'warnings'} = ${^WARNING_BITS};
533 $self->{'hints'} = $^H;
534 $self->{'hinthash'} = {%^H};
535 }
536
537 # Now emit the sub itself.
538 my $padname = $ent->[3];
539 my $flags = $padname->FLAGS;
540 push @text,
541 !$cv || $ent->[0] <= $padname->COP_SEQ_RANGE_LOW
542 ? $self->keyword($flags & SVpad_OUR
543 ? "our"
544 : $flags & SVpad_STATE
545 ? "state"
546 : "my") . " "
547 : "";
548 # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
549 # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
550 # we have a core bug here.
551 push @text, "sub " . substr $padname->PVX, 1;
552 if ($cv) {
553 # my sub foo { }
554 push @text, " " . $self->deparse_sub($cv);
555 $text[-1] =~ s/ ;$/;/;
556 }
557 else {
558 # my sub foo;
559 push @text, ";\n";
560 }
561 return join "", @text;
562 }
563 my $gv = $cv->GV;
564 my $name = $ent->[3] // $self->gv_name($gv);
565 if ($ent->[2]) {
566 return $self->keyword("format") . " $name =\n"
567 . $self->deparse_format($ent->[1]). "\n";
568 } else {
569 my $use_dec;
570 if ($name eq "BEGIN") {
571 $use_dec = $self->begin_is_use($cv);
572 if (defined ($use_dec) and $self->{'expand'} < 5) {
573 return () if 0 == length($use_dec);
574 $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e;
575 }
576 }
577 my $l = '';
578 if ($self->{'linenums'}) {
579 my $line = $gv->LINE;
580 my $file = $gv->FILE;
581 $l = "\n\f#line $line \"$file\"\n";
582 }
583 my $p = '';
584 my $stash;
585 if (class($cv->STASH) ne "SPECIAL") {
586 $stash = $cv->STASH->NAME;
587 if ($stash ne $self->{'curstash'}) {
588 $p = $self->keyword("package") . " $stash;\n";
589 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
590 $self->{'curstash'} = $stash;
591 }
592 }
593 if ($use_dec) {
594 return "$p$l$use_dec";
595 }
596 if ( $name !~ /::/ and $self->lex_in_scope("&$name")
597 || $self->lex_in_scope("&$name", 1) )
598 {
599 $name = "$self->{'curstash'}::$name";
600 } elsif (defined $stash) {
601 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
602 }
603 my $ret = "${p}${l}" . $self->keyword("sub") . " $name "
604 . $self->deparse_sub($cv);
605 $self->{'subs_declared'}{$name} = 1;
606 return $ret;
607 }
608}
609
610# Return a "use" declaration for this BEGIN block, if appropriate
611sub begin_is_use {
612 my ($self, $cv) = @_;
613 my $root = $cv->ROOT;
614 local @$self{qw'curcv curcvlex'} = ($cv);
615 local $B::overlay = {};
616 $self->pessimise($root, $cv->START);
617#require B::Debug;
618#B::walkoptree($cv->ROOT, "debug");
619 my $lineseq = $root->first;
620 return if $lineseq->name ne "lineseq";
621
622 my $req_op = $lineseq->first->sibling;
623 return if $req_op->name ne "require";
624
625 my $module;
626 if ($req_op->first->private & OPpCONST_BARE) {
627 # Actually it should always be a bareword
628 $module = $self->const_sv($req_op->first)->PV;
629 $module =~ s[/][::]g;
630 $module =~ s/.pm$//;
631 }
632 else {
633 $module = $self->const($self->const_sv($req_op->first), 6);
634 }
635
636 my $version;
637 my $version_op = $req_op->sibling;
638 return if class($version_op) eq "NULL";
639 if ($version_op->name eq "lineseq") {
640 # We have a version parameter; skip nextstate & pushmark
641 my $constop = $version_op->first->next->next;
642
643 return unless $self->const_sv($constop)->PV eq $module;
644 $constop = $constop->sibling;
645 $version = $self->const_sv($constop);
646 if (class($version) eq "IV") {
647 $version = $version->int_value;
648 } elsif (class($version) eq "NV") {
649 $version = $version->NV;
650 } elsif (class($version) ne "PVMG") {
651 # Includes PVIV and PVNV
652 $version = $version->PV;
653 } else {
654 # version specified as a v-string
655 $version = 'v'.join '.', map ord, split //, $version->PV;
656 }
657 $constop = $constop->sibling;
658 return if $constop->name ne "method_named";
659 return if $self->meth_sv($constop)->PV ne "VERSION";
660 }
661
662 $lineseq = $version_op->sibling;
663 return if $lineseq->name ne "lineseq";
664 my $entersub = $lineseq->first->sibling;
665 if ($entersub->name eq "stub") {
666 return "use $module $version ();\n" if defined $version;
667 return "use $module ();\n";
668 }
669 return if $entersub->name ne "entersub";
670
671 # See if there are import arguments
672 my $args = '';
673
674 my $svop = $entersub->first->sibling; # Skip over pushmark
675 return unless $self->const_sv($svop)->PV eq $module;
676
677 # Pull out the arguments
678 for ($svop=$svop->sibling; index($svop->name, "method_") != 0;
679 $svop = $svop->sibling) {
680 $args .= ", " if length($args);
681 $args .= $self->deparse($svop, 6);
682 }
683
684 my $use = 'use';
685 my $method_named = $svop;
686 return if $method_named->name ne "method_named";
687 my $method_name = $self->meth_sv($method_named)->PV;
688
689 if ($method_name eq "unimport") {
690 $use = 'no';
691 }
692
693 # Certain pragmas are dealt with using hint bits,
694 # so we ignore them here
695 if ($module eq 'strict' || $module eq 'integer'
696 || $module eq 'bytes' || $module eq 'warnings'
697 || $module eq 'feature') {
698 return "";
699 }
700
701 if (defined $version && length $args) {
702 return "$use $module $version ($args);\n";
703 } elsif (defined $version) {
704 return "$use $module $version;\n";
705 } elsif (length $args) {
706 return "$use $module ($args);\n";
707 } else {
708 return "$use $module;\n";
709 }
710}
711
712sub stash_subs {
713 my ($self, $pack, $seen) = @_;
714 my (@ret, $stash);
715 if (!defined $pack) {
716 $pack = '';
717 $stash = \%::;
718 }
719 else {
720 $pack =~ s/(::)?$/::/;
7212508µs226µs
# spent 16µs (6+10) within B::Deparse::BEGIN@721 which was called: # once (6µs+10µs) by YAML::XS::BEGIN@57 at line 721
no strict 'refs';
# spent 16µs making 1 call to B::Deparse::BEGIN@721 # spent 10µs making 1 call to strict::unimport
722 $stash = \%{"main::$pack"};
723 }
724 return
725 if ($seen ||= {})->{
726 $INC{"overload.pm"} ? overload::StrVal($stash) : $stash
727 }++;
728 my %stash = svref_2object($stash)->ARRAY;
729 while (my ($key, $val) = each %stash) {
730 my $flags = $val->FLAGS;
731 if ($flags & SVf_ROK) {
732 # A reference. Dump this if it is a reference to a CV. If it
733 # is a constant acting as a proxy for a full subroutine, then
734 # we may or may not have to dump it. If some form of perl-
735 # space visible code must have created it, be it a use
736 # statement, or some direct symbol-table manipulation code that
737 # we will deparse, then we don’t want to dump it. If it is the
738 # result of a declaration like sub f () { 42 } then we *do*
739 # want to dump it. The only way to distinguish these seems
740 # to be the SVs_PADTMP flag on the constant, which is admit-
741 # tedly a hack.
742 my $class = class(my $referent = $val->RV);
743 if ($class eq "CV") {
744 $self->todo($referent, 0);
745 } elsif (
746 $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/
747 # A more robust way to write that would be this, but B does
748 # not provide the SVt_ constants:
749 # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV
750 and $referent->FLAGS & SVs_PADTMP
751 ) {
752 push @{$self->{'protos_todo'}}, [$pack . $key, $val];
753 }
754 } elsif ($flags & (SVf_POK|SVf_IOK)) {
755 # Just a prototype. As an ugly but fairly effective way
756 # to find out if it belongs here is to see if the AUTOLOAD
757 # (if any) for the stash was defined in one of our files.
758 my $A = $stash{"AUTOLOAD"};
759 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
760 && class($A->CV) eq "CV") {
761 my $AF = $A->FILE;
762 next unless $AF eq $0 || exists $self->{'files'}{$AF};
763 }
764 push @{$self->{'protos_todo'}},
765 [$pack . $key, $flags & SVf_POK ? $val->PV: undef];
766 } elsif (class($val) eq "GV") {
767 if (class(my $cv = $val->CV) ne "SPECIAL") {
768 next if $self->{'subs_done'}{$$val}++;
769 next if $$val != ${$cv->GV}; # Ignore imposters
770 $self->todo($cv, 0);
771 }
772 if (class(my $cv = $val->FORM) ne "SPECIAL") {
773 next if $self->{'forms_done'}{$$val}++;
774 next if $$val != ${$cv->GV}; # Ignore imposters
775 $self->todo($cv, 1);
776 }
777 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
778 $self->stash_subs($pack . $key, $seen);
779 }
780 }
781 }
782}
783
784sub print_protos {
785 my $self = shift;
786 my $ar;
787 my @ret;
788 foreach $ar (@{$self->{'protos_todo'}}) {
789 my $body = defined $ar->[1]
790 ? ref $ar->[1]
791 ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}"
792 : " (". $ar->[1] . ");"
793 : ";";
794 push @ret, "sub " . $ar->[0] . "$body\n";
795 }
796 delete $self->{'protos_todo'};
797 return @ret;
798}
799
800sub style_opts {
801 my $self = shift;
802 my $opts = shift;
803 my $opt;
804 while (length($opt = substr($opts, 0, 1))) {
805 if ($opt eq "C") {
806 $self->{'cuddle'} = " ";
807 $opts = substr($opts, 1);
808 } elsif ($opt eq "i") {
809 $opts =~ s/^i(\d+)//;
810 $self->{'indent_size'} = $1;
811 } elsif ($opt eq "T") {
812 $self->{'use_tabs'} = 1;
813 $opts = substr($opts, 1);
814 } elsif ($opt eq "v") {
815 $opts =~ s/^v([^.]*)(.|$)//;
816 $self->{'ex_const'} = $1;
817 }
818 }
819}
820
821sub new {
822 my $class = shift;
823 my $self = bless {}, $class;
824 $self->{'cuddle'} = "\n";
825 $self->{'curcop'} = undef;
826 $self->{'curstash'} = "main";
827 $self->{'ex_const'} = "'???'";
828 $self->{'expand'} = 0;
829 $self->{'files'} = {};
830 $self->{'indent_size'} = 4;
831 $self->{'linenums'} = 0;
832 $self->{'parens'} = 0;
833 $self->{'subs_todo'} = [];
834 $self->{'unquote'} = 0;
835 $self->{'use_dumper'} = 0;
836 $self->{'use_tabs'} = 0;
837
838 $self->{'ambient_arybase'} = 0;
839 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
840 $self->{'ambient_hints'} = 0;
841 $self->{'ambient_hinthash'} = undef;
842 $self->init();
843
844 while (my $arg = shift @_) {
845 if ($arg eq "-d") {
846 $self->{'use_dumper'} = 1;
847 require Data::Dumper;
848 } elsif ($arg =~ /^-f(.*)/) {
849 $self->{'files'}{$1} = 1;
850 } elsif ($arg eq "-l") {
851 $self->{'linenums'} = 1;
852 } elsif ($arg eq "-p") {
853 $self->{'parens'} = 1;
854 } elsif ($arg eq "-P") {
855 $self->{'noproto'} = 1;
856 } elsif ($arg eq "-q") {
857 $self->{'unquote'} = 1;
858 } elsif (substr($arg, 0, 2) eq "-s") {
859 $self->style_opts(substr $arg, 2);
860 } elsif ($arg =~ /^-x(\d)$/) {
861 $self->{'expand'} = $1;
862 }
863 }
864 return $self;
865}
866
867{
868 # Mask out the bits that L<warnings::register> uses
8691300ns my $WARN_MASK;
870
# spent 5µs within B::Deparse::BEGIN@870 which was called: # once (5µs+0s) by YAML::XS::BEGIN@57 at line 872
BEGIN {
87115µs $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
8721328µs15µs }
# spent 5µs making 1 call to B::Deparse::BEGIN@870
873 sub WARN_MASK () {
874 return $WARN_MASK;
875 }
876}
877
878# Initialise the contextual information, either from
879# defaults provided with the ambient_pragmas method,
880# or from perl's own defaults otherwise.
8811200nssub init {
882 my $self = shift;
883
884 $self->{'arybase'} = $self->{'ambient_arybase'};
885 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
886 ? $self->{'ambient_warnings'} & WARN_MASK
887 : undef;
888 $self->{'hints'} = $self->{'ambient_hints'};
889 $self->{'hints'} &= 0xFF if $] < 5.009;
890 $self->{'hinthash'} = $self->{'ambient_hinthash'};
891
892 # also a convenient place to clear out subs_declared
893 delete $self->{'subs_declared'};
894}
895
896sub compile {
897 my(@args) = @_;
898 return sub {
899 my $self = B::Deparse->new(@args);
900 # First deparse command-line args
901 if (defined $^I) { # deparse -i
902 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
903 }
904 if ($^W) { # deparse -w
905 print qq(BEGIN { \$^W = $^W; }\n);
906 }
907 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
908 my $fs = perlstring($/) || 'undef';
909 my $bs = perlstring($O::savebackslash) || 'undef';
910 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
911 }
912 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
913 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
914 ? B::unitcheck_av->ARRAY
915 : ();
916 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
917 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
918 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
919 my @names = qw(BEGIN UNITCHECK CHECK INIT END);
920 my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs);
921 while (@names) {
922 my ($name, $blocks) = (shift @names, shift @blocks);
923 for my $block (@$blocks) {
924 $self->todo($block, 0, $name);
925 }
926 }
927 $self->stash_subs();
928 local($SIG{"__DIE__"}) =
929 sub {
930 if ($self->{'curcop'}) {
931 my $cop = $self->{'curcop'};
932 my($line, $file) = ($cop->line, $cop->file);
933 print STDERR "While deparsing $file near line $line,\n";
934 }
935 };
936 $self->{'curcv'} = main_cv;
937 $self->{'curcvlex'} = undef;
938 print $self->print_protos;
939 @{$self->{'subs_todo'}} =
940 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
941 my $root = main_root;
942 local $B::overlay = {};
943 unless (null $root) {
944 $self->pad_subs($self->{'curcv'});
945 # Check for a stub-followed-by-ex-cop, resulting from a program
946 # consisting solely of sub declarations. For backward-compati-
947 # bility (and sane output) we don’t want to emit the stub.
948 # leave
949 # enter
950 # stub
951 # ex-nextstate (or ex-dbstate)
952 my $kid;
953 if ( $root->name eq 'leave'
954 and ($kid = $root->first)->name eq 'enter'
955 and !null($kid = $kid->sibling) and $kid->name eq 'stub'
956 and !null($kid = $kid->sibling) and $kid->name eq 'null'
957 and class($kid) eq 'COP' and null $kid->sibling )
958 {
959 # ignore
960 } else {
961 $self->pessimise($root, main_start);
962 print $self->indent($self->deparse_root($root)), "\n";
963 }
964 }
965 my @text;
966 while (scalar(@{$self->{'subs_todo'}})) {
967 push @text, $self->next_todo;
968 }
969 print $self->indent(join("", @text)), "\n" if @text;
970
971 # Print __DATA__ section, if necessary
97222.45ms220µs
# spent 13µs (6+7) within B::Deparse::BEGIN@972 which was called: # once (6µs+7µs) by YAML::XS::BEGIN@57 at line 972
no strict 'refs';
# spent 13µs making 1 call to B::Deparse::BEGIN@972 # spent 7µs making 1 call to strict::unimport
973 my $laststash = defined $self->{'curcop'}
974 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
975 if (defined *{$laststash."::DATA"}{IO}) {
976 print $self->keyword("package") . " $laststash;\n"
977 unless $laststash eq $self->{'curstash'};
978 print $self->keyword("__DATA__") . "\n";
979 print readline(*{$laststash."::DATA"});
980 }
981 }
982}
983
984sub coderef2text {
985 my $self = shift;
986 my $sub = shift;
987 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
988
989 $self->init();
990 local $self->{in_coderef2text} = 1;
991 return $self->indent($self->deparse_sub(svref_2object($sub)));
992}
993
99411µsmy %strict_bits = do {
99512µs local $^H;
99614µs38µs map +($_ => strict::bits($_)), qw/refs subs vars/
# spent 8µs making 3 calls to strict::bits, avg 3µs/call
997};
998
999sub ambient_pragmas {
1000 my $self = shift;
1001 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
1002
1003 while (@_ > 1) {
1004 my $name = shift();
1005 my $val = shift();
1006
1007 if ($name eq 'strict') {
1008 require strict;
1009
1010 if ($val eq 'none') {
1011 $hint_bits &= $strict_bits{$_} for qw/refs subs vars/;
1012 next();
1013 }
1014
1015 my @names;
1016 if ($val eq "all") {
1017 @names = qw/refs subs vars/;
1018 }
1019 elsif (ref $val) {
1020 @names = @$val;
1021 }
1022 else {
1023 @names = split' ', $val;
1024 }
1025 $hint_bits |= $strict_bits{$_} for @names;
1026 }
1027
1028 elsif ($name eq '$[') {
1029 if (OPpCONST_ARYBASE) {
1030 $arybase = $val;
1031 } else {
1032 croak "\$[ can't be non-zero on this perl" unless $val == 0;
1033 }
1034 }
1035
1036 elsif ($name eq 'integer'
1037 || $name eq 'bytes'
1038 || $name eq 'utf8') {
1039 require "$name.pm";
1040 if ($val) {
1041 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
1042 }
1043 else {
1044 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
1045 }
1046 }
1047
1048 elsif ($name eq 're') {
1049 require re;
1050 if ($val eq 'none') {
1051 $hint_bits &= ~re::bits(qw/taint eval/);
1052 next();
1053 }
1054
1055 my @names;
1056 if ($val eq 'all') {
1057 @names = qw/taint eval/;
1058 }
1059 elsif (ref $val) {
1060 @names = @$val;
1061 }
1062 else {
1063 @names = split' ',$val;
1064 }
1065 $hint_bits |= re::bits(@names);
1066 }
1067
1068 elsif ($name eq 'warnings') {
1069 if ($val eq 'none') {
1070 $warning_bits = $warnings::NONE;
1071 next();
1072 }
1073
1074 my @names;
1075 if (ref $val) {
1076 @names = @$val;
1077 }
1078 else {
1079 @names = split/\s+/, $val;
1080 }
1081
1082 $warning_bits = $warnings::NONE if !defined ($warning_bits);
1083 $warning_bits |= warnings::bits(@names);
1084 }
1085
1086 elsif ($name eq 'warning_bits') {
1087 $warning_bits = $val;
1088 }
1089
1090 elsif ($name eq 'hint_bits') {
1091 $hint_bits = $val;
1092 }
1093
1094 elsif ($name eq '%^H') {
1095 $hinthash = $val;
1096 }
1097
1098 else {
1099 croak "Unknown pragma type: $name";
1100 }
1101 }
1102 if (@_) {
1103 croak "The ambient_pragmas method expects an even number of args";
1104 }
1105
1106 $self->{'ambient_arybase'} = $arybase;
1107 $self->{'ambient_warnings'} = $warning_bits;
1108 $self->{'ambient_hints'} = $hint_bits;
1109 $self->{'ambient_hinthash'} = $hinthash;
1110}
1111
1112# This method is the inner loop, so try to keep it simple
1113sub deparse {
1114 my $self = shift;
1115 my($op, $cx) = @_;
1116
1117 Carp::confess("Null op in deparse") if !defined($op)
1118 || class($op) eq "NULL";
1119 my $meth = "pp_" . $op->name;
1120 return $self->$meth($op, $cx);
1121}
1122
1123sub indent {
1124 my $self = shift;
1125 my $txt = shift;
1126 # \cK also swallows a preceding line break when followed by a
1127 # semicolon.
1128 $txt =~ s/\n\cK;//g;
1129 my @lines = split(/\n/, $txt);
1130 my $leader = "";
1131 my $level = 0;
1132 my $line;
1133 for $line (@lines) {
1134 my $cmd = substr($line, 0, 1);
1135 if ($cmd eq "\t" or $cmd eq "\b") {
1136 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
1137 if ($self->{'use_tabs'}) {
1138 $leader = "\t" x ($level / 8) . " " x ($level % 8);
1139 } else {
1140 $leader = " " x $level;
1141 }
1142 $line = substr($line, 1);
1143 }
1144 if (index($line, "\f") > 0) {
1145 $line =~ s/\f/\n/;
1146 }
1147 if (substr($line, 0, 1) eq "\f") {
1148 $line = substr($line, 1); # no indent
1149 } else {
1150 $line = $leader . $line;
1151 }
1152 $line =~ s/\cK;?//g;
1153 }
1154 return join("\n", @lines);
1155}
1156
1157sub pad_subs {
1158 my ($self, $cv) = @_;
1159 my $padlist = $cv->PADLIST;
1160 my @names = $padlist->ARRAYelt(0)->ARRAY;
1161 my @values = $padlist->ARRAYelt(1)->ARRAY;
1162 my @todo;
1163 PADENTRY:
1164 for my $ix (0.. $#names) { for $_ ($names[$ix]) {
1165 next if class($_) eq "SPECIAL";
1166 my $name = $_->PVX;
1167 if (defined $name && $name =~ /^&./) {
1168 my $low = $_->COP_SEQ_RANGE_LOW;
1169 my $flags = $_->FLAGS;
1170 my $outer = $flags & PADNAMEt_OUTER;
1171 if ($flags & SVpad_OUR) {
1172 push @todo, [$low, undef, 0, $_]
1173 # [seq, no cv, not format, padname]
1174 unless $outer;
1175 next;
1176 }
1177 my $protocv = $flags & SVpad_STATE
1178 ? $values[$ix]
1179 : $_->PROTOCV;
1180 if (class ($protocv) ne 'CV') {
1181 my $flags = $flags;
1182 my $cv = $cv;
1183 my $name = $_;
1184 while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV')
1185 {
1186 $cv = $cv->OUTSIDE;
1187 next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed?
1188 my $padlist = $cv->PADLIST;
1189 my $ix = $name->PARENT_PAD_INDEX;
1190 $name = $padlist->NAMES->ARRAYelt($ix);
1191 $flags = $name->FLAGS;
1192 $protocv = $flags & SVpad_STATE
1193 ? $padlist->ARRAYelt(1)->ARRAYelt($ix)
1194 : $name->PROTOCV;
1195 }
1196 }
1197 my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do {
1198 my $other = $protocv->PADLIST;
1199 $$other && $other->outid == $padlist->id;
1200 };
1201 if ($flags & PADNAMEt_OUTER) {
1202 next unless $defined_in_this_sub;
1203 push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_];
1204 next;
1205 }
1206 my $outseq = $protocv->OUTSIDE_SEQ;
1207 if ($outseq <= $low) {
1208 # defined before its name is visible, so it’s gotta be
1209 # declared and defined at once: my sub foo { ... }
1210 push @todo, [$low, $protocv, 0, $_];
1211 }
1212 else {
1213 # declared and defined separately: my sub f; sub f { ... }
1214 push @todo, [$low, undef, 0, $_];
1215 push @todo, [$outseq, $protocv, 0, $_]
1216 if $defined_in_this_sub;
1217 }
1218 }
1219 }}
1220 @{$self->{'subs_todo'}} =
1221 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
1222}
1223
1224sub deparse_sub {
1225 my $self = shift;
1226 my $cv = shift;
1227 my $proto = "";
1228Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
1229Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
1230 local $self->{'curcop'} = $self->{'curcop'};
1231 if ($cv->FLAGS & SVf_POK) {
1232 $proto = "(". $cv->PV . ") ";
1233 }
1234 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
1235 $proto .= ": ";
1236 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
1237 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
1238 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
1239 $proto .= "const " if $cv->CvFLAGS & CVf_ANONCONST;
1240 }
1241
1242 local($self->{'curcv'}) = $cv;
1243 local($self->{'curcvlex'});
1244 local(@$self{qw'curstash warnings hints hinthash'})
1245 = @$self{qw'curstash warnings hints hinthash'};
1246 my $body;
1247 my $root = $cv->ROOT;
1248 local $B::overlay = {};
1249 if (not null $root) {
1250 $self->pad_subs($cv);
1251 $self->pessimise($root, $cv->START);
1252 my $lineseq = $root->first;
1253 if ($lineseq->name eq "lineseq") {
1254 my @ops;
1255 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
1256 push @ops, $o;
1257 }
1258 $body = $self->lineseq(undef, 0, @ops).";";
1259 my $scope_en = $self->find_scope_en($lineseq);
1260 if (defined $scope_en) {
1261 my $subs = join"", $self->seq_subs($scope_en);
1262 $body .= ";\n$subs" if length($subs);
1263 }
1264 }
1265 else {
1266 $body = $self->deparse($root->first, 0);
1267 }
1268 }
1269 else {
1270 my $sv = $cv->const_sv;
1271 if ($$sv) {
1272 # uh-oh. inlinable sub... format it differently
1273 return $proto . "{ " . $self->const($sv, 0) . " }\n";
1274 } else { # XSUB? (or just a declaration)
1275 return "$proto;\n";
1276 }
1277 }
1278 return $proto ."{\n\t$body\n\b}" ."\n";
1279}
1280
1281sub deparse_format {
1282 my $self = shift;
1283 my $form = shift;
1284 my @text;
1285 local($self->{'curcv'}) = $form;
1286 local($self->{'curcvlex'});
1287 local($self->{'in_format'}) = 1;
1288 local(@$self{qw'curstash warnings hints hinthash'})
1289 = @$self{qw'curstash warnings hints hinthash'};
1290 my $op = $form->ROOT;
1291 local $B::overlay = {};
1292 $self->pessimise($op, $form->START);
1293 my $kid;
1294 return "\f." if $op->first->name eq 'stub'
1295 || $op->first->name eq 'nextstate';
1296 $op = $op->first->first; # skip leavewrite, lineseq
1297 while (not null $op) {
1298 $op = $op->sibling; # skip nextstate
1299 my @exprs;
1300 $kid = $op->first->sibling; # skip pushmark
1301 push @text, "\f".$self->const_sv($kid)->PV;
1302 $kid = $kid->sibling;
1303 for (; not null $kid; $kid = $kid->sibling) {
1304 push @exprs, $self->deparse($kid, -1);
1305 $exprs[-1] =~ s/;\z//;
1306 }
1307 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
1308 $op = $op->sibling;
1309 }
1310 return join("", @text) . "\f.";
1311}
1312
1313sub is_scope {
1314 my $op = shift;
1315 return $op->name eq "leave" || $op->name eq "scope"
1316 || $op->name eq "lineseq"
1317 || ($op->name eq "null" && class($op) eq "UNOP"
1318 && (is_scope($op->first) || $op->first->name eq "enter"));
1319}
1320
1321sub is_state {
1322 my $name = $_[0]->name;
1323 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
1324}
1325
1326sub is_miniwhile { # check for one-line loop ('foo() while $y--')
1327 my $op = shift;
1328 return (!null($op) and null($op->sibling)
1329 and $op->name eq "null" and class($op) eq "UNOP"
1330 and (($op->first->name =~ /^(and|or)$/
1331 and $op->first->first->sibling->name eq "lineseq")
1332 or ($op->first->name eq "lineseq"
1333 and not null $op->first->first->sibling
1334 and $op->first->first->sibling->name eq "unstack")
1335 ));
1336}
1337
1338# Check if the op and its sibling are the initialization and the rest of a
1339# for (..;..;..) { ... } loop
1340sub is_for_loop {
1341 my $op = shift;
1342 # This OP might be almost anything, though it won't be a
1343 # nextstate. (It's the initialization, so in the canonical case it
1344 # will be an sassign.) The sibling is (old style) a lineseq whose
1345 # first child is a nextstate and whose second is a leaveloop, or
1346 # (new style) an unstack whose sibling is a leaveloop.
1347 my $lseq = $op->sibling;
1348 return 0 unless !is_state($op) and !null($lseq);
1349 if ($lseq->name eq "lineseq") {
1350 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
1351 && (my $sib = $lseq->first->sibling)) {
1352 return (!null($sib) && $sib->name eq "leaveloop");
1353 }
1354 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
1355 my $sib = $lseq->sibling;
1356 return $sib && !null($sib) && $sib->name eq "leaveloop";
1357 }
1358 return 0;
1359}
1360
1361sub is_scalar {
1362 my $op = shift;
1363 return ($op->name eq "rv2sv" or
1364 $op->name eq "padsv" or
1365 $op->name eq "gv" or # only in array/hash constructs
1366 $op->flags & OPf_KIDS && !null($op->first)
1367 && $op->first->name eq "gvsv");
1368}
1369
1370sub maybe_parens {
1371 my $self = shift;
1372 my($text, $cx, $prec) = @_;
1373 if ($prec < $cx # unary ops nest just fine
1374 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1375 or $self->{'parens'})
1376 {
1377 $text = "($text)";
1378 # In a unop, let parent reuse our parens; see maybe_parens_unop
1379 $text = "\cS" . $text if $cx == 16;
1380 return $text;
1381 } else {
1382 return $text;
1383 }
1384}
1385
1386# same as above, but get around the 'if it looks like a function' rule
1387sub maybe_parens_unop {
1388 my $self = shift;
1389 my($name, $kid, $cx) = @_;
1390 if ($cx > 16 or $self->{'parens'}) {
1391 $kid = $self->deparse($kid, 1);
1392 if ($name eq "umask" && $kid =~ /^\d+$/) {
1393 $kid = sprintf("%#o", $kid);
1394 }
1395 return $self->keyword($name) . "($kid)";
1396 } else {
1397 $kid = $self->deparse($kid, 16);
1398 if ($name eq "umask" && $kid =~ /^\d+$/) {
1399 $kid = sprintf("%#o", $kid);
1400 }
1401 $name = $self->keyword($name);
1402 if (substr($kid, 0, 1) eq "\cS") {
1403 # use kid's parens
1404 return $name . substr($kid, 1);
1405 } elsif (substr($kid, 0, 1) eq "(") {
1406 # avoid looks-like-a-function trap with extra parens
1407 # ('+' can lead to ambiguities)
1408 return "$name(" . $kid . ")";
1409 } else {
1410 return "$name $kid";
1411 }
1412 }
1413}
1414
1415sub maybe_parens_func {
1416 my $self = shift;
1417 my($func, $text, $cx, $prec) = @_;
1418 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1419 return "$func($text)";
1420 } else {
1421 return "$func $text";
1422 }
1423}
1424
1425sub find_our_type {
1426 my ($self, $name) = @_;
1427 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1428 my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0;
1429 for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
1430 my ($st, undef, $padname) = @$a;
1431 if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) {
1432 return $padname->SvSTASH->NAME;
1433 }
1434 }
1435 return '';
1436}
1437
1438sub maybe_local {
1439 my $self = shift;
1440 my($op, $cx, $text) = @_;
1441 my $name = $op->name;
1442 my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign
1443 |lv(?:av)?ref)$/x)
1444 ? OPpOUR_INTRO
1445 : 0;
1446 my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO;
1447 # The @a in \(@a) isn't in ref context, but only when the
1448 # parens are there.
1449 my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/
1450 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1451 if ((my $priv = $op->private) & ($lval_intro|$our_intro)) {
1452 my @our_local;
1453 push @our_local, "local" if $priv & $lval_intro;
1454 push @our_local, "our" if $priv & $our_intro;
1455 my $our_local = join " ", map $self->keyword($_), @our_local;
1456 if( $our_local[-1] eq 'our' ) {
1457 if ( $text !~ /^\W(\w+::)*\w+\z/
1458 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1459 ) {
1460 die "Unexpected our($text)\n";
1461 }
1462 $text =~ s/(\w+::)+//;
1463
1464 if (my $type = $self->find_our_type($text)) {
1465 $our_local .= ' ' . $type;
1466 }
1467 }
1468 return $need_parens ? "($text)" : $text
1469 if $self->{'avoid_local'}{$$op};
1470 if ($need_parens) {
1471 return "$our_local($text)";
1472 } elsif (want_scalar($op)) {
1473 return "$our_local $text";
1474 } else {
1475 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1476 }
1477 } else {
1478 return $need_parens ? "($text)" : $text;
1479 }
1480}
1481
1482sub maybe_targmy {
1483 my $self = shift;
1484 my($op, $cx, $func, @args) = @_;
1485 if ($op->private & OPpTARGET_MY) {
1486 my $var = $self->padname($op->targ);
1487 my $val = $func->($self, $op, 7, @args);
1488 return $self->maybe_parens("$var = $val", $cx, 7);
1489 } else {
1490 return $func->($self, $op, $cx, @args);
1491 }
1492}
1493
1494sub padname_sv {
1495 my $self = shift;
1496 my $targ = shift;
1497 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1498}
1499
1500sub maybe_my {
1501 my $self = shift;
1502 my($op, $cx, $text, $padname, $forbid_parens) = @_;
1503 # The @a in \(@a) isn't in ref context, but only when the
1504 # parens are there.
1505 my $need_parens = !$forbid_parens && $self->{'in_refgen'}
1506 && $op->name =~ /[ah]v\z/
1507 && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS;
1508 # The @a in \my @a must not have parens.
1509 if (!$need_parens && $self->{'in_refgen'}) {
1510 $forbid_parens = 1;
1511 }
1512 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1513 # Check $padname->FLAGS for statehood, rather than $op->private,
1514 # because enteriter ops do not carry the flag.
1515 my $my =
1516 $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my");
1517 if ($padname->FLAGS & SVpad_TYPED) {
1518 $my .= ' ' . $padname->SvSTASH->NAME;
1519 }
1520 if ($need_parens) {
1521 return "$my($text)";
1522 } elsif ($forbid_parens || want_scalar($op)) {
1523 return "$my $text";
1524 } else {
1525 return $self->maybe_parens_func($my, $text, $cx, 16);
1526 }
1527 } else {
1528 return $need_parens ? "($text)" : $text;
1529 }
1530}
1531
1532# The following OPs don't have functions:
1533
1534# pp_padany -- does not exist after parsing
1535
1536sub AUTOLOAD {
1537 if ($AUTOLOAD =~ s/^.*::pp_//) {
1538 warn "unexpected OP_".
1539 ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
1540 return "XXX";
1541 } else {
1542 die "Undefined subroutine $AUTOLOAD called";
1543 }
1544}
1545
1546sub DESTROY {} # Do not AUTOLOAD
1547
1548# $root should be the op which represents the root of whatever
1549# we're sequencing here. If it's undefined, then we don't append
1550# any subroutine declarations to the deparsed ops, otherwise we
1551# append appropriate declarations.
1552sub lineseq {
1553 my($self, $root, $cx, @ops) = @_;
1554 my($expr, @exprs);
1555
1556 my $out_cop = $self->{'curcop'};
1557 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1558 my $limit_seq;
1559 if (defined $root) {
1560 $limit_seq = $out_seq;
1561 my $nseq;
1562 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1563 $limit_seq = $nseq if !defined($limit_seq)
1564 or defined($nseq) && $nseq < $limit_seq;
1565 }
1566 $limit_seq = $self->{'limit_seq'}
1567 if defined($self->{'limit_seq'})
1568 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1569 local $self->{'limit_seq'} = $limit_seq;
1570
1571 $self->walk_lineseq($root, \@ops,
1572 sub { push @exprs, $_[0]} );
1573
1574 my $sep = $cx ? '; ' : ";\n";
1575 my $body = join($sep, grep {length} @exprs);
1576 my $subs = "";
1577 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1578 $subs = join "\n", $self->seq_subs($limit_seq);
1579 }
1580 return join($sep, grep {length} $body, $subs);
1581}
1582
1583sub scopeop {
1584 my($real_block, $self, $op, $cx) = @_;
1585 my $kid;
1586 my @kids;
1587
1588 local(@$self{qw'curstash warnings hints hinthash'})
1589 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1590 if ($real_block) {
1591 $kid = $op->first->sibling; # skip enter
1592 if (is_miniwhile($kid)) {
1593 my $top = $kid->first;
1594 my $name = $top->name;
1595 if ($name eq "and") {
1596 $name = $self->keyword("while");
1597 } elsif ($name eq "or") {
1598 $name = $self->keyword("until");
1599 } else { # no conditional -> while 1 or until 0
1600 return $self->deparse($top->first, 1) . " "
1601 . $self->keyword("while") . " 1";
1602 }
1603 my $cond = $top->first;
1604 my $body = $cond->sibling->first; # skip lineseq
1605 $cond = $self->deparse($cond, 1);
1606 $body = $self->deparse($body, 1);
1607 return "$body $name $cond";
1608 }
1609 } else {
1610 $kid = $op->first;
1611 }
1612 for (; !null($kid); $kid = $kid->sibling) {
1613 push @kids, $kid;
1614 }
1615 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1616 my $body = $self->lineseq($op, 0, @kids);
1617 return is_lexical_subs(@kids)
1618 ? $body
1619 : ($self->lex_in_scope("&do") ? "CORE::do" : "do")
1620 . " {\n\t$body\n\b}";
1621 } else {
1622 my $lineseq = $self->lineseq($op, $cx, @kids);
1623 return (length ($lineseq) ? "$lineseq;" : "");
1624 }
1625}
1626
1627sub pp_scope { scopeop(0, @_); }
1628sub pp_lineseq { scopeop(0, @_); }
1629sub pp_leave { scopeop(1, @_); }
1630
1631# This is a special case of scopeop and lineseq, for the case of the
1632# main_root. The difference is that we print the output statements as
1633# soon as we get them, for the sake of impatient users.
1634sub deparse_root {
1635 my $self = shift;
1636 my($op) = @_;
1637 local(@$self{qw'curstash warnings hints hinthash'})
1638 = @$self{qw'curstash warnings hints hinthash'};
1639 my @kids;
1640 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1641 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1642 push @kids, $kid;
1643 }
1644 $self->walk_lineseq($op, \@kids,
1645 sub { return unless length $_[0];
1646 print $self->indent($_[0].';');
1647 print "\n"
1648 unless $_[1] == $#kids;
1649 });
1650}
1651
1652sub walk_lineseq {
1653 my ($self, $op, $kids, $callback) = @_;
1654 my @kids = @$kids;
1655 for (my $i = 0; $i < @kids; $i++) {
1656 my $expr = "";
1657 if (is_state $kids[$i]) {
1658 $expr = $self->deparse($kids[$i++], 0);
1659 if ($i > $#kids) {
1660 $callback->($expr, $i);
1661 last;
1662 }
1663 }
1664 if (is_for_loop($kids[$i])) {
1665 $callback->($expr . $self->for_loop($kids[$i], 0),
1666 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1667 next;
1668 }
1669 my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
1670 $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise
1671 $expr .= $expr2;
1672 $callback->($expr, $i);
1673 }
1674}
1675
1676# The BEGIN {} is used here because otherwise this code isn't executed
1677# when you run B::Deparse on itself.
16781100nsmy %globalnames;
167918µs
# spent 8µs within B::Deparse::BEGIN@1679 which was called: # once (8µs+0s) by YAML::XS::BEGIN@57 at line 1680
BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
168012.57ms18µs "ENV", "ARGV", "ARGVOUT", "_"); }
# spent 8µs making 1 call to B::Deparse::BEGIN@1679
1681
1682sub gv_name {
1683 my $self = shift;
1684 my $gv = shift;
1685 my $raw = shift;
1686#Carp::confess() unless ref($gv) eq "B::GV";
1687 my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
1688 my $stash = ($cv || $gv)->STASH->NAME;
1689 my $name = $raw
1690 ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
1691 : $cv
1692 ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
1693 : $gv->SAFENAME;
1694 if ($stash eq 'main' && $name =~ /^::/) {
1695 $stash = '::';
1696 }
1697 elsif (($stash eq 'main'
1698 && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/))
1699 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1700 && ($stash eq 'main' || $name !~ /::/))
1701 )
1702 {
1703 $stash = "";
1704 } else {
1705 $stash = $stash . "::";
1706 }
1707 if (!$raw and $name =~ /^(\^..|{)/) {
1708 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1709 }
1710 return $stash . $name;
1711}
1712
1713# Return the name to use for a stash variable.
1714# If a lexical with the same name is in scope, or
1715# if strictures are enabled, it may need to be
1716# fully-qualified.
1717sub stash_variable {
1718 my ($self, $prefix, $name, $cx) = @_;
1719
1720 return "$prefix$name" if $name =~ /::/;
1721
1722 unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #'
1723 $prefix eq '%' || $prefix eq '$#') {
1724 return "$prefix$name";
1725 }
1726
1727 if ($name =~ /^[^[:alpha:]_+-]$/) {
1728 if (defined $cx && $cx == 26) {
1729 if ($prefix eq '@') {
1730 return "$prefix\{$name}";
1731 }
1732 elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a"
1733 }
1734 if ($prefix eq '$#') {
1735 return "\$#{$name}";
1736 }
1737 }
1738
1739 return $prefix . $self->maybe_qualify($prefix, $name);
1740}
1741
174219µsmy %unctrl = # portable to EBCDIC
1743 (
1744 "\c@" => '@', # unused
1745 "\cA" => 'A',
1746 "\cB" => 'B',
1747 "\cC" => 'C',
1748 "\cD" => 'D',
1749 "\cE" => 'E',
1750 "\cF" => 'F',
1751 "\cG" => 'G',
1752 "\cH" => 'H',
1753 "\cI" => 'I',
1754 "\cJ" => 'J',
1755 "\cK" => 'K',
1756 "\cL" => 'L',
1757 "\cM" => 'M',
1758 "\cN" => 'N',
1759 "\cO" => 'O',
1760 "\cP" => 'P',
1761 "\cQ" => 'Q',
1762 "\cR" => 'R',
1763 "\cS" => 'S',
1764 "\cT" => 'T',
1765 "\cU" => 'U',
1766 "\cV" => 'V',
1767 "\cW" => 'W',
1768 "\cX" => 'X',
1769 "\cY" => 'Y',
1770 "\cZ" => 'Z',
1771 "\c[" => '[', # unused
1772 "\c\\" => '\\', # unused
1773 "\c]" => ']', # unused
1774 "\c_" => '_', # unused
1775 );
1776
1777# Return just the name, without the prefix. It may be returned as a quoted
1778# string. The second return value is a boolean indicating that.
1779sub stash_variable_name {
1780 my($self, $prefix, $gv) = @_;
1781 my $name = $self->gv_name($gv, 1);
1782 $name = $self->maybe_qualify($prefix,$name);
1783 if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) {
1784 $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e;
1785 $name =~ /^(\^..|{)/ and $name = "{$name}";
1786 return $name, 0; # not quoted
1787 }
1788 else {
1789 single_delim("q", "'", $name, $self), 1;
1790 }
1791}
1792
1793sub maybe_qualify {
1794 my ($self,$prefix,$name) = @_;
1795 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1796 return $name if !$prefix || $name =~ /::/;
1797 return $self->{'curstash'}.'::'. $name
1798 if
1799 $name =~ /^(?!\d)\w/ # alphabetic
1800 && $v !~ /^\$[ab]\z/ # not $a or $b
1801 && !$globalnames{$name} # not a global name
1802 && $self->{hints} & $strict_bits{vars} # strict vars
1803 && !$self->lex_in_scope($v,1) # no "our"
1804 or $self->lex_in_scope($v); # conflicts with "my" variable
1805 return $name;
1806}
1807
1808sub lex_in_scope {
1809 my ($self, $name, $our) = @_;
1810 substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my
1811 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1812
1813 return 0 if !defined($self->{'curcop'});
1814 my $seq = $self->{'curcop'}->cop_seq;
1815 return 0 if !exists $self->{'curcvlex'}{$name};
1816 for my $a (@{$self->{'curcvlex'}{$name}}) {
1817 my ($st, $en) = @$a;
1818 return 1 if $seq > $st && $seq <= $en;
1819 }
1820 return 0;
1821}
1822
1823sub populate_curcvlex {
1824 my $self = shift;
1825 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1826 my $padlist = $cv->PADLIST;
1827 # an undef CV still in lexical chain
1828 next if class($padlist) eq "SPECIAL";
1829 my @padlist = $padlist->ARRAY;
1830 my @ns = $padlist[0]->ARRAY;
1831
1832 for (my $i=0; $i<@ns; ++$i) {
1833 next if class($ns[$i]) eq "SPECIAL";
1834 if (class($ns[$i]) eq "PV") {
1835 # Probably that pesky lexical @_
1836 next;
1837 }
1838 my $name = $ns[$i]->PVX;
1839 next unless defined $name;
1840 my ($seq_st, $seq_en) =
1841 ($ns[$i]->FLAGS & SVf_FAKE)
1842 ? (0, 999999)
1843 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1844
1845 push @{$self->{'curcvlex'}{
1846 ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
1847 }}, [$seq_st, $seq_en, $ns[$i]];
1848 }
1849 }
1850}
1851
1852sub find_scope_st { ((find_scope(@_))[0]); }
1853sub find_scope_en { ((find_scope(@_))[1]); }
1854
1855# Recurses down the tree, looking for pad variable introductions and COPs
1856sub find_scope {
1857 my ($self, $op, $scope_st, $scope_en) = @_;
1858 carp("Undefined op in find_scope") if !defined $op;
1859 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1860
1861 my @queue = ($op);
1862 while(my $op = shift @queue ) {
1863 for (my $o=$op->first; $$o; $o=$o->sibling) {
1864 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1865 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1866 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1867 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1868 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1869 return ($scope_st, $scope_en);
1870 }
1871 elsif (is_state($o)) {
1872 my $c = $o->cop_seq;
1873 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1874 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1875 return ($scope_st, $scope_en);
1876 }
1877 elsif ($o->flags & OPf_KIDS) {
1878 unshift (@queue, $o);
1879 }
1880 }
1881 }
1882
1883 return ($scope_st, $scope_en);
1884}
1885
1886# Returns a list of subs which should be inserted before the COP
1887sub cop_subs {
1888 my ($self, $op, $out_seq) = @_;
1889 my $seq = $op->cop_seq;
1890 if ($] < 5.021006) {
1891 # If we have nephews, then our sequence number indicates
1892 # the cop_seq of the end of some sort of scope.
1893 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1894 and my $nseq = $self->find_scope_st($op->sibling) ) {
1895 $seq = $nseq;
1896 }
1897 }
1898 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1899 return $self->seq_subs($seq);
1900}
1901
1902sub seq_subs {
1903 my ($self, $seq) = @_;
1904 my @text;
1905#push @text, "# ($seq)\n";
1906
1907 return "" if !defined $seq;
1908 my @pending;
1909 while (scalar(@{$self->{'subs_todo'}})
1910 and $seq > $self->{'subs_todo'}[0][0]) {
1911 my $cv = $self->{'subs_todo'}[0][1];
1912 # Skip the OUTSIDE check for lexical subs. We may be deparsing a
1913 # cloned anon sub with lexical subs declared in it, in which case
1914 # the OUTSIDE pointer points to the anon protosub.
1915 my $lexical = ref $self->{'subs_todo'}[0][3];
1916 my $outside = !$lexical && $cv && $cv->OUTSIDE;
1917 if (!$lexical and $cv
1918 and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}})
1919 {
1920 push @pending, shift @{$self->{'subs_todo'}};
1921 next;
1922 }
1923 push @text, $self->next_todo;
1924 }
1925 unshift @{$self->{'subs_todo'}}, @pending;
1926 return @text;
1927}
1928
1929sub _features_from_bundle {
1930 my ($hints, $hh) = @_;
1931 foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) {
1932 $hh->{$feature::feature{$_}} = 1;
1933 }
1934 return $hh;
1935}
1936
1937# Notice how subs and formats are inserted between statements here;
1938# also $[ assignments and pragmas.
1939sub pp_nextstate {
1940 my $self = shift;
1941 my($op, $cx) = @_;
1942 $self->{'curcop'} = $op;
1943 my @text;
1944 push @text, $self->cop_subs($op);
1945 if (@text) {
1946 # Special marker to swallow up the semicolon
1947 push @text, "\cK";
1948 }
1949 my $stash = $op->stashpv;
1950 if ($stash ne $self->{'curstash'}) {
1951 push @text, $self->keyword("package") . " $stash;\n";
1952 $self->{'curstash'} = $stash;
1953 }
1954
1955 if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) {
1956 push @text, '$[ = '. $op->arybase .";\n";
1957 $self->{'arybase'} = $op->arybase;
1958 }
1959
1960 my $warnings = $op->warnings;
1961 my $warning_bits;
1962 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1963 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1964 }
1965 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1966 $warning_bits = $warnings::NONE;
1967 }
1968 elsif ($warnings->isa("B::SPECIAL")) {
1969 $warning_bits = undef;
1970 }
1971 else {
1972 $warning_bits = $warnings->PV & WARN_MASK;
1973 }
1974
1975 if (defined ($warning_bits) and
1976 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1977 push @text,
1978 $self->declare_warnings($self->{'warnings'}, $warning_bits);
1979 $self->{'warnings'} = $warning_bits;
1980 }
1981
1982 my $hints = $] < 5.008009 ? $op->private : $op->hints;
1983 my $old_hints = $self->{'hints'};
1984 if ($self->{'hints'} != $hints) {
1985 push @text, $self->declare_hints($self->{'hints'}, $hints);
1986 $self->{'hints'} = $hints;
1987 }
1988
1989 my $newhh;
1990 if ($] > 5.009) {
1991 $newhh = $op->hints_hash->HASH;
1992 }
1993
1994 if ($] >= 5.015006) {
1995 # feature bundle hints
1996 my $from = $old_hints & $feature::hint_mask;
1997 my $to = $ hints & $feature::hint_mask;
1998 if ($from != $to) {
1999 if ($to == $feature::hint_mask) {
2000 if ($self->{'hinthash'}) {
2001 delete $self->{'hinthash'}{$_}
2002 for grep /^feature_/, keys %{$self->{'hinthash'}};
2003 }
2004 else { $self->{'hinthash'} = {} }
2005 $self->{'hinthash'}
2006 = _features_from_bundle($from, $self->{'hinthash'});
2007 }
2008 else {
2009 my $bundle =
2010 $feature::hint_bundles[$to >> $feature::hint_shift];
2011 $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12
2012 push @text,
2013 $self->keyword("no") . " feature ':all';\n",
2014 $self->keyword("use") . " feature ':$bundle';\n";
2015 }
2016 }
2017 }
2018
2019 if ($] > 5.009) {
2020 push @text, $self->declare_hinthash(
2021 $self->{'hinthash'}, $newhh,
2022 $self->{indent_size}, $self->{hints},
2023 );
2024 $self->{'hinthash'} = $newhh;
2025 }
2026
2027 # This should go after of any branches that add statements, to
2028 # increase the chances that it refers to the same line it did in
2029 # the original program.
2030 if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format
2031 push @text, "\f#line " . $op->line .
2032 ' "' . $op->file, qq'"\n';
2033 }
2034
2035 push @text, $op->label . ": " if $op->label;
2036
2037 return join("", @text);
2038}
2039
2040sub declare_warnings {
2041 my ($self, $from, $to) = @_;
2042 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
2043 return $self->keyword("use") . " warnings;\n";
2044 }
2045 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
2046 return $self->keyword("no") . " warnings;\n";
2047 }
2048 return "BEGIN {\${^WARNING_BITS} = \""
2049 . join("", map { sprintf("\\x%02x", ord $_) } split "", $to)
2050 . "\"}\n\cK";
2051}
2052
2053sub declare_hints {
2054 my ($self, $from, $to) = @_;
2055 my $use = $to & ~$from;
2056 my $no = $from & ~$to;
2057 my $decls = "";
2058 for my $pragma (hint_pragmas($use)) {
2059 $decls .= $self->keyword("use") . " $pragma;\n";
2060 }
2061 for my $pragma (hint_pragmas($no)) {
2062 $decls .= $self->keyword("no") . " $pragma;\n";
2063 }
2064 return $decls;
2065}
2066
2067# Internal implementation hints that the core sets automatically, so don't need
2068# (or want) to be passed back to the user
206913µsmy %ignored_hints = (
2070 'open<' => 1,
2071 'open>' => 1,
2072 ':' => 1,
2073 'strict/refs' => 1,
2074 'strict/subs' => 1,
2075 'strict/vars' => 1,
2076);
2077
20781100nsmy %rev_feature;
2079
2080sub declare_hinthash {
2081 my ($self, $from, $to, $indent, $hints) = @_;
2082 my $doing_features =
2083 ($hints & $feature::hint_mask) == $feature::hint_mask;
2084 my @decls;
2085 my @features;
2086 my @unfeatures; # bugs?
2087 for my $key (sort keys %$to) {
2088 next if $ignored_hints{$key};
2089 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2090 next if $is_feature and not $doing_features;
2091 if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
2092 push(@features, $key), next if $is_feature;
2093 push @decls,
2094 qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = )
2095 . (
2096 defined $to->{$key}
2097 ? single_delim("q", "'", $to->{$key}, $self)
2098 : 'undef'
2099 )
2100 . qq(;);
2101 }
2102 }
2103 for my $key (sort keys %$from) {
2104 next if $ignored_hints{$key};
2105 my $is_feature = $key =~ /^feature_/ && $^V ge 5.15.6;
2106 next if $is_feature and not $doing_features;
2107 if (!exists $to->{$key}) {
2108 push(@unfeatures, $key), next if $is_feature;
2109 push @decls, qq(delete \$^H{'$key'};);
2110 }
2111 }
2112 my @ret;
2113 if (@features || @unfeatures) {
2114 if (!%rev_feature) { %rev_feature = reverse %feature::feature }
2115 }
2116 if (@features) {
2117 push @ret, $self->keyword("use") . " feature "
2118 . join(", ", map "'$rev_feature{$_}'", @features) . ";\n";
2119 }
2120 if (@unfeatures) {
2121 push @ret, $self->keyword("no") . " feature "
2122 . join(", ", map "'$rev_feature{$_}'", @unfeatures)
2123 . ";\n";
2124 }
2125 @decls and
2126 push @ret,
2127 join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK";
2128 return @ret;
2129}
2130
2131sub hint_pragmas {
2132 my ($bits) = @_;
2133 my (@pragmas, @strict);
2134 push @pragmas, "integer" if $bits & 0x1;
2135 for (sort keys %strict_bits) {
2136 push @strict, "'$_'" if $bits & $strict_bits{$_};
2137 }
2138 if (@strict == keys %strict_bits) {
2139 push @pragmas, "strict";
2140 }
2141 elsif (@strict) {
2142 push @pragmas, "strict " . join ', ', @strict;
2143 }
2144 push @pragmas, "bytes" if $bits & 0x8;
2145 return @pragmas;
2146}
2147
2148sub pp_dbstate { pp_nextstate(@_) }
2149sub pp_setstate { pp_nextstate(@_) }
2150
2151sub pp_unstack { return "" } # see also leaveloop
2152
215313µsmy %feature_keywords = (
2154 # keyword => 'feature',
2155 state => 'state',
2156 say => 'say',
2157 given => 'switch',
2158 when => 'switch',
2159 default => 'switch',
2160 break => 'switch',
2161 evalbytes=>'evalbytes',
2162 __SUB__ => '__SUB__',
2163 fc => 'fc',
2164);
2165
2166# keywords that are strong and also have a prototype
2167#
216812µsmy %strong_proto_keywords = map { $_ => 1 } qw(
2169 pos
2170 prototype
2171 scalar
2172 study
2173 undef
2174);
2175
2176sub feature_enabled {
2177 my($self,$name) = @_;
2178 my $hh;
2179 my $hints = $self->{hints} & $feature::hint_mask;
2180 if ($hints && $hints != $feature::hint_mask) {
2181 $hh = _features_from_bundle($hints);
2182 }
2183 elsif ($hints) { $hh = $self->{'hinthash'} }
2184 return $hh && $hh->{"feature_$feature_keywords{$name}"}
2185}
2186
2187sub keyword {
2188 my $self = shift;
2189 my $name = shift;
2190 return $name if $name =~ /^CORE::/; # just in case
2191 if (exists $feature_keywords{$name}) {
2192 return "CORE::$name" if not $self->feature_enabled($name);
2193 }
2194 # This sub may be called for a program that has no nextstate ops. In
2195 # that case we may have a lexical sub named no/use/sub in scope but
2196 # but $self->lex_in_scope will return false because it depends on the
2197 # current nextstate op. So we need this alternate method if there is
2198 # no current cop.
2199 if (!$self->{'curcop'}) {
2200 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
2201 return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"}
2202 || exists $self->{'curcvlex'}{"o&$name"};
2203 } elsif ($self->lex_in_scope("&$name")
2204 || $self->lex_in_scope("&$name", 1)) {
2205 return "CORE::$name";
2206 }
2207 if ($strong_proto_keywords{$name}
2208 || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
2209 && !defined eval{prototype "CORE::$name"})
2210 ) { return $name }
2211 if (
2212 exists $self->{subs_declared}{$name}
2213 or
2214 exists &{"$self->{curstash}::$name"}
2215 ) {
2216 return "CORE::$name"
2217 }
2218 return $name;
2219}
2220
2221sub baseop {
2222 my $self = shift;
2223 my($op, $cx, $name) = @_;
2224 return $self->keyword($name);
2225}
2226
2227sub pp_stub { "()" }
2228sub pp_wantarray { baseop(@_, "wantarray") }
2229sub pp_fork { baseop(@_, "fork") }
2230sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
2231sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
2232sub pp_time { maybe_targmy(@_, \&baseop, "time") }
2233sub pp_tms { baseop(@_, "times") }
2234sub pp_ghostent { baseop(@_, "gethostent") }
2235sub pp_gnetent { baseop(@_, "getnetent") }
2236sub pp_gprotoent { baseop(@_, "getprotoent") }
2237sub pp_gservent { baseop(@_, "getservent") }
2238sub pp_ehostent { baseop(@_, "endhostent") }
2239sub pp_enetent { baseop(@_, "endnetent") }
2240sub pp_eprotoent { baseop(@_, "endprotoent") }
2241sub pp_eservent { baseop(@_, "endservent") }
2242sub pp_gpwent { baseop(@_, "getpwent") }
2243sub pp_spwent { baseop(@_, "setpwent") }
2244sub pp_epwent { baseop(@_, "endpwent") }
2245sub pp_ggrent { baseop(@_, "getgrent") }
2246sub pp_sgrent { baseop(@_, "setgrent") }
2247sub pp_egrent { baseop(@_, "endgrent") }
2248sub pp_getlogin { baseop(@_, "getlogin") }
2249
2250sub POSTFIX () { 1 }
2251
2252# I couldn't think of a good short name, but this is the category of
2253# symbolic unary operators with interesting precedence
2254
2255sub pfixop {
2256 my $self = shift;
2257 my($op, $cx, $name, $prec, $flags) = (@_, 0);
2258 my $kid = $op->first;
2259 $kid = $self->deparse($kid, $prec);
2260 return $self->maybe_parens(($flags & POSTFIX)
2261 ? "$kid$name"
2262 # avoid confusion with filetests
2263 : $name eq '-'
2264 && $kid =~ /^[a-zA-Z](?!\w)/
2265 ? "$name($kid)"
2266 : "$name$kid",
2267 $cx, $prec);
2268}
2269
2270sub pp_preinc { pfixop(@_, "++", 23) }
2271sub pp_predec { pfixop(@_, "--", 23) }
2272sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2273sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2274sub pp_i_preinc { pfixop(@_, "++", 23) }
2275sub pp_i_predec { pfixop(@_, "--", 23) }
2276sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
2277sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
2278sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
227911µs*pp_ncomplement = *pp_complement;
2280sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) }
2281
2282sub pp_negate { maybe_targmy(@_, \&real_negate) }
2283sub real_negate {
2284 my $self = shift;
2285 my($op, $cx) = @_;
2286 if ($op->first->name =~ /^(i_)?negate$/) {
2287 # avoid --$x
2288 $self->pfixop($op, $cx, "-", 21.5);
2289 } else {
2290 $self->pfixop($op, $cx, "-", 21);
2291 }
2292}
2293sub pp_i_negate { pp_negate(@_) }
2294
2295sub pp_not {
2296 my $self = shift;
2297 my($op, $cx) = @_;
2298 if ($cx <= 4) {
2299 $self->listop($op, $cx, "not", $op->first);
2300 } else {
2301 $self->pfixop($op, $cx, "!", 21);
2302 }
2303}
2304
2305sub unop {
2306 my $self = shift;
2307 my($op, $cx, $name, $nollafr) = @_;
2308 my $kid;
2309 if ($op->flags & OPf_KIDS) {
2310 $kid = $op->first;
2311 if (not $name) {
2312 # this deals with 'boolkeys' right now
2313 return $self->deparse($kid,$cx);
2314 }
2315 my $builtinname = $name;
2316 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
2317 if (defined prototype($builtinname)
2318 && $builtinname ne 'CORE::readline'
2319 && prototype($builtinname) =~ /^;?\*/
2320 && $kid->name eq "rv2gv") {
2321 $kid = $kid->first;
2322 }
2323
2324 if ($nollafr) {
2325 if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) {
2326 # require foo() is a syntax error.
2327 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2328 }
2329 return $self->maybe_parens(
2330 $self->keyword($name) . " $kid", $cx, 16
2331 );
2332 }
2333 return $self->maybe_parens_unop($name, $kid, $cx);
2334 } else {
2335 return $self->maybe_parens(
2336 $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""),
2337 $cx, 16,
2338 );
2339 }
2340}
2341
2342sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
2343sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
2344sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
2345sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
2346sub pp_defined { unop(@_, "defined") }
2347sub pp_undef { unop(@_, "undef") }
2348sub pp_study { unop(@_, "study") }
2349sub pp_ref { unop(@_, "ref") }
2350sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
2351
2352sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
2353sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
2354sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
2355sub pp_srand { unop(@_, "srand") }
2356sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
2357sub pp_log { maybe_targmy(@_, \&unop, "log") }
2358sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
2359sub pp_int { maybe_targmy(@_, \&unop, "int") }
2360sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
2361sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
2362sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
2363
2364sub pp_length { maybe_targmy(@_, \&unop, "length") }
2365sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
2366sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
2367
2368sub pp_each { unop(@_, "each") }
2369sub pp_values { unop(@_, "values") }
2370sub pp_keys { unop(@_, "keys") }
237141.73ms227µs
# spent 16µs (6+10) within B::Deparse::BEGIN@2371 which was called: # once (6µs+10µs) by YAML::XS::BEGIN@57 at line 2371
{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; }
# spent 16µs making 1 call to B::Deparse::BEGIN@2371 # spent 10µs making 1 call to strict::unimport
2372sub pp_boolkeys {
2373 # no name because its an optimisation op that has no keyword
2374 unop(@_,"");
2375}
2376sub pp_aeach { unop(@_, "each") }
2377sub pp_avalues { unop(@_, "values") }
2378sub pp_akeys { unop(@_, "keys") }
2379sub pp_pop { unop(@_, "pop") }
2380sub pp_shift { unop(@_, "shift") }
2381
2382sub pp_caller { unop(@_, "caller") }
2383sub pp_reset { unop(@_, "reset") }
2384sub pp_exit { unop(@_, "exit") }
2385sub pp_prototype { unop(@_, "prototype") }
2386
2387sub pp_close { unop(@_, "close") }
2388sub pp_fileno { unop(@_, "fileno") }
2389sub pp_umask { unop(@_, "umask") }
2390sub pp_untie { unop(@_, "untie") }
2391sub pp_tied { unop(@_, "tied") }
2392sub pp_dbmclose { unop(@_, "dbmclose") }
2393sub pp_getc { unop(@_, "getc") }
2394sub pp_eof { unop(@_, "eof") }
2395sub pp_tell { unop(@_, "tell") }
2396sub pp_getsockname { unop(@_, "getsockname") }
2397sub pp_getpeername { unop(@_, "getpeername") }
2398
2399sub pp_chdir {
2400 my ($self, $op, $cx) = @_;
2401 if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) {
2402 my $kw = $self->keyword("chdir");
2403 my $kid = $self->const_sv($op->first)->PV;
2404 my $code = $kw
2405 . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid");
2406 maybe_targmy(@_, sub { $_[3] }, $code);
2407 } else {
2408 maybe_targmy(@_, \&unop, "chdir")
2409 }
2410}
2411
2412sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
2413sub pp_readlink { unop(@_, "readlink") }
2414sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
2415sub pp_readdir { unop(@_, "readdir") }
2416sub pp_telldir { unop(@_, "telldir") }
2417sub pp_rewinddir { unop(@_, "rewinddir") }
2418sub pp_closedir { unop(@_, "closedir") }
2419sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
2420sub pp_localtime { unop(@_, "localtime") }
2421sub pp_gmtime { unop(@_, "gmtime") }
2422sub pp_alarm { unop(@_, "alarm") }
2423sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
2424
2425sub pp_dofile {
2426 my $code = unop(@_, "do", 1); # llafr does not apply
2427 if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' }
2428 $code;
2429}
2430sub pp_entereval {
2431 unop(
2432 @_,
2433 $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval"
2434 )
2435}
2436
2437sub pp_ghbyname { unop(@_, "gethostbyname") }
2438sub pp_gnbyname { unop(@_, "getnetbyname") }
2439sub pp_gpbyname { unop(@_, "getprotobyname") }
2440sub pp_shostent { unop(@_, "sethostent") }
2441sub pp_snetent { unop(@_, "setnetent") }
2442sub pp_sprotoent { unop(@_, "setprotoent") }
2443sub pp_sservent { unop(@_, "setservent") }
2444sub pp_gpwnam { unop(@_, "getpwnam") }
2445sub pp_gpwuid { unop(@_, "getpwuid") }
2446sub pp_ggrnam { unop(@_, "getgrnam") }
2447sub pp_ggrgid { unop(@_, "getgrgid") }
2448
2449sub pp_lock { unop(@_, "lock") }
2450
2451sub pp_continue { unop(@_, "continue"); }
2452sub pp_break { unop(@_, "break"); }
2453
2454sub givwhen {
2455 my $self = shift;
2456 my($op, $cx, $givwhen) = @_;
2457
2458 my $enterop = $op->first;
2459 my ($head, $block);
2460 if ($enterop->flags & OPf_SPECIAL) {
2461 $head = $self->keyword("default");
2462 $block = $self->deparse($enterop->first, 0);
2463 }
2464 else {
2465 my $cond = $enterop->first;
2466 my $cond_str = $self->deparse($cond, 1);
2467 $head = "$givwhen ($cond_str)";
2468 $block = $self->deparse($cond->sibling, 0);
2469 }
2470
2471 return "$head {\n".
2472 "\t$block\n".
2473 "\b}\cK";
2474}
2475
2476sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); }
2477sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); }
2478
2479sub pp_exists {
2480 my $self = shift;
2481 my($op, $cx) = @_;
2482 my $arg;
2483 my $name = $self->keyword("exists");
2484 if ($op->private & OPpEXISTS_SUB) {
2485 # Checking for the existence of a subroutine
2486 return $self->maybe_parens_func($name,
2487 $self->pp_rv2cv($op->first, 16), $cx, 16);
2488 }
2489 if ($op->flags & OPf_SPECIAL) {
2490 # Array element, not hash element
2491 return $self->maybe_parens_func($name,
2492 $self->pp_aelem($op->first, 16), $cx, 16);
2493 }
2494 return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16),
2495 $cx, 16);
2496}
2497
2498sub pp_delete {
2499 my $self = shift;
2500 my($op, $cx) = @_;
2501 my $arg;
2502 my $name = $self->keyword("delete");
2503 if ($op->private & OPpSLICE) {
2504 if ($op->flags & OPf_SPECIAL) {
2505 # Deleting from an array, not a hash
2506 return $self->maybe_parens_func($name,
2507 $self->pp_aslice($op->first, 16),
2508 $cx, 16);
2509 }
2510 return $self->maybe_parens_func($name,
2511 $self->pp_hslice($op->first, 16),
2512 $cx, 16);
2513 } else {
2514 if ($op->flags & OPf_SPECIAL) {
2515 # Deleting from an array, not a hash
2516 return $self->maybe_parens_func($name,
2517 $self->pp_aelem($op->first, 16),
2518 $cx, 16);
2519 }
2520 return $self->maybe_parens_func($name,
2521 $self->pp_helem($op->first, 16),
2522 $cx, 16);
2523 }
2524}
2525
2526sub pp_require {
2527 my $self = shift;
2528 my($op, $cx) = @_;
2529 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
2530 my $kid = $op->first;
2531 if ($kid->name eq 'const') {
2532 my $priv = $kid->private;
2533 my $sv = $self->const_sv($kid);
2534 my $arg;
2535 if ($priv & OPpCONST_BARE) {
2536 $arg = $sv->PV;
2537 $arg =~ s[/][::]g;
2538 $arg =~ s/\.pm//g;
2539 } elsif ($priv & OPpCONST_NOVER) {
2540 $opname = $self->keyword('no');
2541 $arg = $self->const($sv, 16);
2542 } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) {
2543 $arg = $tmp;
2544 }
2545 if ($arg) {
2546 return $self->maybe_parens("$opname $arg", $cx, 16);
2547 }
2548 }
2549 $self->unop(
2550 $op, $cx,
2551 $opname,
2552 1, # llafr does not apply
2553 );
2554}
2555
2556sub pp_scalar {
2557 my $self = shift;
2558 my($op, $cx) = @_;
2559 my $kid = $op->first;
2560 if (not null $kid->sibling) {
2561 # XXX Was a here-doc
2562 return $self->dquote($op);
2563 }
2564 $self->unop(@_, "scalar");
2565}
2566
2567
2568sub padval {
2569 my $self = shift;
2570 my $targ = shift;
2571 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
2572}
2573
2574sub anon_hash_or_list {
2575 my $self = shift;
2576 my($op, $cx) = @_;
2577
2578 my($pre, $post) = @{{"anonlist" => ["[","]"],
2579 "anonhash" => ["{","}"]}->{$op->name}};
2580 my($expr, @exprs);
2581 $op = $op->first->sibling; # skip pushmark
2582 for (; !null($op); $op = $op->sibling) {
2583 $expr = $self->deparse($op, 6);
2584 push @exprs, $expr;
2585 }
2586 if ($pre eq "{" and $cx < 1) {
2587 # Disambiguate that it's not a block
2588 $pre = "+{";
2589 }
2590 return $pre . join(", ", @exprs) . $post;
2591}
2592
2593sub pp_anonlist {
2594 my $self = shift;
2595 my ($op, $cx) = @_;
2596 if ($op->flags & OPf_SPECIAL) {
2597 return $self->anon_hash_or_list($op, $cx);
2598 }
2599 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
2600 return 'XXX';
2601}
2602
260312µs*pp_anonhash = \&pp_anonlist;
2604
2605sub pp_refgen {
2606 my $self = shift;
2607 my($op, $cx) = @_;
2608 my $kid = $op->first;
2609 if ($kid->name eq "null") {
2610 my $anoncode = $kid = $kid->first;
2611 if ($anoncode->name eq "anonconst") {
2612 $anoncode = $anoncode->first->first->sibling;
2613 }
2614 if ($anoncode->name eq "anoncode"
2615 or !null($anoncode = $kid->sibling) and
2616 $anoncode->name eq "anoncode") {
2617 return $self->e_anoncode({ code => $self->padval($anoncode->targ) });
2618 } elsif ($kid->name eq "pushmark") {
2619 my $sib_name = $kid->sibling->name;
2620 if ($sib_name eq 'entersub') {
2621 my $text = $self->deparse($kid->sibling, 1);
2622 # Always show parens for \(&func()), but only with -p otherwise
2623 $text = "($text)" if $self->{'parens'}
2624 or $kid->sibling->private & OPpENTERSUB_AMPER;
2625 return "\\$text";
2626 }
2627 }
2628 }
2629 local $self->{'in_refgen'} = 1;
2630 $self->pfixop($op, $cx, "\\", 20);
2631}
2632
2633sub e_anoncode {
2634 my ($self, $info) = @_;
2635 my $text = $self->deparse_sub($info->{code});
2636 return $self->keyword("sub") . " $text";
2637}
2638
2639sub pp_srefgen { pp_refgen(@_) }
2640
2641sub pp_readline {
2642 my $self = shift;
2643 my($op, $cx) = @_;
2644 my $kid = $op->first;
2645 if (is_scalar($kid)) {
2646 my $kid_deparsed = $self->deparse($kid, 1);
2647 return '<<>>' if $op->flags & OPf_SPECIAL and $kid_deparsed eq 'ARGV';
2648 return "<$kid_deparsed>";
2649 }
2650 return $self->unop($op, $cx, "readline");
2651}
2652
2653sub pp_rcatline {
2654 my $self = shift;
2655 my($op) = @_;
2656 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
2657}
2658
2659# Unary operators that can occur as pseudo-listops inside double quotes
2660sub dq_unop {
2661 my $self = shift;
2662 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
2663 my $kid;
2664 if ($op->flags & OPf_KIDS) {
2665 $kid = $op->first;
2666 # If there's more than one kid, the first is an ex-pushmark.
2667 $kid = $kid->sibling if not null $kid->sibling;
2668 return $self->maybe_parens_unop($name, $kid, $cx);
2669 } else {
2670 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
2671 }
2672}
2673
2674sub pp_ucfirst { dq_unop(@_, "ucfirst") }
2675sub pp_lcfirst { dq_unop(@_, "lcfirst") }
2676sub pp_uc { dq_unop(@_, "uc") }
2677sub pp_lc { dq_unop(@_, "lc") }
2678sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
2679sub pp_fc { dq_unop(@_, "fc") }
2680
2681sub loopex {
2682 my $self = shift;
2683 my ($op, $cx, $name) = @_;
2684 if (class($op) eq "PVOP") {
2685 $name .= " " . $op->pv;
2686 } elsif (class($op) eq "OP") {
2687 # no-op
2688 } elsif (class($op) eq "UNOP") {
2689 (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
2690 # last foo() is a syntax error.
2691 $kid =~ /^(?!\d)\w/ and $kid = "($kid)";
2692 $name .= " $kid";
2693 }
2694 return $self->maybe_parens($name, $cx, 7);
2695}
2696
2697sub pp_last { loopex(@_, "last") }
2698sub pp_next { loopex(@_, "next") }
2699sub pp_redo { loopex(@_, "redo") }
2700sub pp_goto { loopex(@_, "goto") }
2701sub pp_dump { loopex(@_, "CORE::dump") }
2702
2703sub ftst {
2704 my $self = shift;
2705 my($op, $cx, $name) = @_;
2706 if (class($op) eq "UNOP") {
2707 # Genuine '-X' filetests are exempt from the LLAFR, but not
2708 # l?stat()
2709 if ($name =~ /^-/) {
2710 (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
2711 return $self->maybe_parens("$name $kid", $cx, 16);
2712 }
2713 return $self->maybe_parens_unop($name, $op->first, $cx);
2714 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
2715 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
2716 } else { # I don't think baseop filetests ever survive ck_ftst, but...
2717 return $name;
2718 }
2719}
2720
2721sub pp_lstat { ftst(@_, "lstat") }
2722sub pp_stat { ftst(@_, "stat") }
2723sub pp_ftrread { ftst(@_, "-R") }
2724sub pp_ftrwrite { ftst(@_, "-W") }
2725sub pp_ftrexec { ftst(@_, "-X") }
2726sub pp_fteread { ftst(@_, "-r") }
2727sub pp_ftewrite { ftst(@_, "-w") }
2728sub pp_fteexec { ftst(@_, "-x") }
2729sub pp_ftis { ftst(@_, "-e") }
2730sub pp_fteowned { ftst(@_, "-O") }
2731sub pp_ftrowned { ftst(@_, "-o") }
2732sub pp_ftzero { ftst(@_, "-z") }
2733sub pp_ftsize { ftst(@_, "-s") }
2734sub pp_ftmtime { ftst(@_, "-M") }
2735sub pp_ftatime { ftst(@_, "-A") }
2736sub pp_ftctime { ftst(@_, "-C") }
2737sub pp_ftsock { ftst(@_, "-S") }
2738sub pp_ftchr { ftst(@_, "-c") }
2739sub pp_ftblk { ftst(@_, "-b") }
2740sub pp_ftfile { ftst(@_, "-f") }
2741sub pp_ftdir { ftst(@_, "-d") }
2742sub pp_ftpipe { ftst(@_, "-p") }
2743sub pp_ftlink { ftst(@_, "-l") }
2744sub pp_ftsuid { ftst(@_, "-u") }
2745sub pp_ftsgid { ftst(@_, "-g") }
2746sub pp_ftsvtx { ftst(@_, "-k") }
2747sub pp_fttty { ftst(@_, "-t") }
2748sub pp_fttext { ftst(@_, "-T") }
2749sub pp_ftbinary { ftst(@_, "-B") }
2750
2751sub SWAP_CHILDREN () { 1 }
2752sub ASSIGN () { 2 } # has OP= variant
2753sub LIST_CONTEXT () { 4 } # Assignment is in list context
2754
27551200nsmy(%left, %right);
2756
2757sub assoc_class {
2758 my $op = shift;
2759 my $name = $op->name;
2760 if ($name eq "concat" and $op->first->name eq "concat") {
2761 # avoid spurious '=' -- see comment in pp_concat
2762 return "concat";
2763 }
2764 if ($name eq "null" and class($op) eq "UNOP"
2765 and $op->first->name =~ /^(and|x?or)$/
2766 and null $op->first->sibling)
2767 {
2768 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2769 # with a null that's used as the common end point of the two
2770 # flows of control. For precedence purposes, ignore it.
2771 # (COND_EXPRs have these too, but we don't bother with
2772 # their associativity).
2773 return assoc_class($op->first);
2774 }
2775 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2776}
2777
2778# Left associative operators, like '+', for which
2779# $a + $b + $c is equivalent to ($a + $b) + $c
2780
2781
# spent 12µs within B::Deparse::BEGIN@2781 which was called: # once (12µs+0s) by YAML::XS::BEGIN@57 at line 2797
BEGIN {
2782115µs %left = ('multiply' => 19, 'i_multiply' => 19,
2783 'divide' => 19, 'i_divide' => 19,
2784 'modulo' => 19, 'i_modulo' => 19,
2785 'repeat' => 19,
2786 'add' => 18, 'i_add' => 18,
2787 'subtract' => 18, 'i_subtract' => 18,
2788 'concat' => 18,
2789 'left_shift' => 17, 'right_shift' => 17,
2790 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13,
2791 'bit_or' => 12, 'bit_xor' => 12,
2792 'sbit_or' => 12, 'sbit_xor' => 12,
2793 'nbit_or' => 12, 'nbit_xor' => 12,
2794 'and' => 3,
2795 'or' => 2, 'xor' => 2,
2796 );
2797177µs112µs}
# spent 12µs making 1 call to B::Deparse::BEGIN@2781
2798
2799sub deparse_binop_left {
2800 my $self = shift;
2801 my($op, $left, $prec) = @_;
2802 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2803 and $left{assoc_class($op)} == $left{assoc_class($left)})
2804 {
2805 return $self->deparse($left, $prec - .00001);
2806 } else {
2807 return $self->deparse($left, $prec);
2808 }
2809}
2810
2811# Right associative operators, like '=', for which
2812# $a = $b = $c is equivalent to $a = ($b = $c)
2813
2814
# spent 13µs within B::Deparse::BEGIN@2814 which was called: # once (13µs+0s) by YAML::XS::BEGIN@57 at line 2831
BEGIN {
2815113µs %right = ('pow' => 22,
2816 'sassign=' => 7, 'aassign=' => 7,
2817 'multiply=' => 7, 'i_multiply=' => 7,
2818 'divide=' => 7, 'i_divide=' => 7,
2819 'modulo=' => 7, 'i_modulo=' => 7,
2820 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7,
2821 'add=' => 7, 'i_add=' => 7,
2822 'subtract=' => 7, 'i_subtract=' => 7,
2823 'concat=' => 7,
2824 'left_shift=' => 7, 'right_shift=' => 7,
2825 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7,
2826 'nbit_or=' => 7, 'nbit_xor=' => 7,
2827 'sbit_or=' => 7, 'sbit_xor=' => 7,
2828 'andassign' => 7,
2829 'orassign' => 7,
2830 );
283112.37ms113µs}
# spent 13µs making 1 call to B::Deparse::BEGIN@2814
2832
2833sub deparse_binop_right {
2834 my $self = shift;
2835 my($op, $right, $prec) = @_;
2836 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2837 and $right{assoc_class($op)} == $right{assoc_class($right)})
2838 {
2839 return $self->deparse($right, $prec - .00001);
2840 } else {
2841 return $self->deparse($right, $prec);
2842 }
2843}
2844
2845sub binop {
2846 my $self = shift;
2847 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2848 my $left = $op->first;
2849 my $right = $op->last;
2850 my $eq = "";
2851 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2852 $eq = "=";
2853 $prec = 7;
2854 }
2855 if ($flags & SWAP_CHILDREN) {
2856 ($left, $right) = ($right, $left);
2857 }
2858 my $leftop = $left;
2859 $left = $self->deparse_binop_left($op, $left, $prec);
2860 $left = "($left)" if $flags & LIST_CONTEXT
2861 and $left !~ /^(my|our|local|)[\@\(]/
2862 || do {
2863 # Parenthesize if the left argument is a
2864 # lone repeat op.
2865 my $left = $leftop->first->sibling;
2866 $left->name eq 'repeat'
2867 && null($left->sibling);
2868 };
2869 $right = $self->deparse_binop_right($op, $right, $prec);
2870 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2871}
2872
2873sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2874sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2875sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2876sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2877sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2878sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2879sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2880sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2881sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2882sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2883sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2884
2885sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2886sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2887sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2888sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2889sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
28901400ns*pp_nbit_and = *pp_bit_and;
28911400ns*pp_nbit_or = *pp_bit_or;
28921400ns*pp_nbit_xor = *pp_bit_xor;
2893sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) }
2894sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) }
2895sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) }
2896
2897sub pp_eq { binop(@_, "==", 14) }
2898sub pp_ne { binop(@_, "!=", 14) }
2899sub pp_lt { binop(@_, "<", 15) }
2900sub pp_gt { binop(@_, ">", 15) }
2901sub pp_ge { binop(@_, ">=", 15) }
2902sub pp_le { binop(@_, "<=", 15) }
2903sub pp_ncmp { binop(@_, "<=>", 14) }
2904sub pp_i_eq { binop(@_, "==", 14) }
2905sub pp_i_ne { binop(@_, "!=", 14) }
2906sub pp_i_lt { binop(@_, "<", 15) }
2907sub pp_i_gt { binop(@_, ">", 15) }
2908sub pp_i_ge { binop(@_, ">=", 15) }
2909sub pp_i_le { binop(@_, "<=", 15) }
2910sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) }
2911
2912sub pp_seq { binop(@_, "eq", 14) }
2913sub pp_sne { binop(@_, "ne", 14) }
2914sub pp_slt { binop(@_, "lt", 15) }
2915sub pp_sgt { binop(@_, "gt", 15) }
2916sub pp_sge { binop(@_, "ge", 15) }
2917sub pp_sle { binop(@_, "le", 15) }
2918sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) }
2919
2920sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2921sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2922
2923sub pp_smartmatch {
2924 my ($self, $op, $cx) = @_;
2925 if ($op->flags & OPf_SPECIAL) {
2926 return $self->deparse($op->last, $cx);
2927 }
2928 else {
2929 binop(@_, "~~", 14);
2930 }
2931}
2932
2933# '.' is special because concats-of-concats are optimized to save copying
2934# by making all but the first concat stacked. The effect is as if the
2935# programmer had written '($a . $b) .= $c', except legal.
2936sub pp_concat { maybe_targmy(@_, \&real_concat) }
2937sub real_concat {
2938 my $self = shift;
2939 my($op, $cx) = @_;
2940 my $left = $op->first;
2941 my $right = $op->last;
2942 my $eq = "";
2943 my $prec = 18;
2944 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2945 $eq = "=";
2946 $prec = 7;
2947 }
2948 $left = $self->deparse_binop_left($op, $left, $prec);
2949 $right = $self->deparse_binop_right($op, $right, $prec);
2950 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2951}
2952
2953sub pp_repeat { maybe_targmy(@_, \&repeat) }
2954
2955# 'x' is weird when the left arg is a list
2956sub repeat {
2957 my $self = shift;
2958 my($op, $cx) = @_;
2959 my $left = $op->first;
2960 my $right = $op->last;
2961 my $eq = "";
2962 my $prec = 19;
2963 if ($op->flags & OPf_STACKED) {
2964 $eq = "=";
2965 $prec = 7;
2966 }
2967 if (null($right)) { # list repeat; count is inside left-side ex-list
2968 # in 5.21.5 and earlier
2969 my $kid = $left->first->sibling; # skip pushmark
2970 my @exprs;
2971 for (; !null($kid->sibling); $kid = $kid->sibling) {
2972 push @exprs, $self->deparse($kid, 6);
2973 }
2974 $right = $kid;
2975 $left = "(" . join(", ", @exprs). ")";
2976 } else {
2977 my $dolist = $op->private & OPpREPEAT_DOLIST;
2978 $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
2979 if ($dolist) {
2980 $left = "($left)";
2981 }
2982 }
2983 $right = $self->deparse_binop_right($op, $right, $prec);
2984 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2985}
2986
2987sub range {
2988 my $self = shift;
2989 my ($op, $cx, $type) = @_;
2990 my $left = $op->first;
2991 my $right = $left->sibling;
2992 $left = $self->deparse($left, 9);
2993 $right = $self->deparse($right, 9);
2994 return $self->maybe_parens("$left $type $right", $cx, 9);
2995}
2996
2997sub pp_flop {
2998 my $self = shift;
2999 my($op, $cx) = @_;
3000 my $flip = $op->first;
3001 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
3002 return $self->range($flip->first, $cx, $type);
3003}
3004
3005# one-line while/until is handled in pp_leave
3006
3007sub logop {
3008 my $self = shift;
3009 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
3010 my $left = $op->first;
3011 my $right = $op->first->sibling;
3012 $blockname &&= $self->keyword($blockname);
3013 if ($cx < 1 and is_scope($right) and $blockname
3014 and $self->{'expand'} < 7)
3015 { # if ($a) {$b}
3016 $left = $self->deparse($left, 1);
3017 $right = $self->deparse($right, 0);
3018 return "$blockname ($left) {\n\t$right\n\b}\cK";
3019 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
3020 and $self->{'expand'} < 7) { # $b if $a
3021 $right = $self->deparse($right, 1);
3022 $left = $self->deparse($left, 1);
3023 return "$right $blockname $left";
3024 } elsif ($cx > $lowprec and $highop) { # $a && $b
3025 $left = $self->deparse_binop_left($op, $left, $highprec);
3026 $right = $self->deparse_binop_right($op, $right, $highprec);
3027 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
3028 } else { # $a and $b
3029 $left = $self->deparse_binop_left($op, $left, $lowprec);
3030 $right = $self->deparse_binop_right($op, $right, $lowprec);
3031 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
3032 }
3033}
3034
3035sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
3036sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
3037sub pp_dor { logop(@_, "//", 10) }
3038
3039# xor is syntactically a logop, but it's really a binop (contrary to
3040# old versions of opcode.pl). Syntax is what matters here.
3041sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
3042
3043sub logassignop {
3044 my $self = shift;
3045 my ($op, $cx, $opname) = @_;
3046 my $left = $op->first;
3047 my $right = $op->first->sibling->first; # skip sassign
3048 $left = $self->deparse($left, 7);
3049 $right = $self->deparse($right, 7);
3050 return $self->maybe_parens("$left $opname $right", $cx, 7);
3051}
3052
3053sub pp_andassign { logassignop(@_, "&&=") }
3054sub pp_orassign { logassignop(@_, "||=") }
3055sub pp_dorassign { logassignop(@_, "//=") }
3056
3057sub rv2gv_or_string {
3058 my($self,$op) = @_;
3059 if ($op->name eq "gv") { # could be open("open") or open("###")
3060 my($name,$quoted) =
3061 $self->stash_variable_name("", $self->gv_or_padgv($op));
3062 $quoted ? $name : "*$name";
3063 }
3064 else {
3065 $self->deparse($op, 6);
3066 }
3067}
3068
3069sub listop {
3070 my $self = shift;
3071 my($op, $cx, $name, $kid, $nollafr) = @_;
3072 my(@exprs);
3073 my $parens = ($cx >= 5) || $self->{'parens'};
3074 $kid ||= $op->first->sibling;
3075 # If there are no arguments, add final parentheses (or parenthesize the
3076 # whole thing if the llafr does not apply) to account for cases like
3077 # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a
3078 # precedence of 6 (< comma), as "return, 1" does not need parentheses.
3079 if (null $kid) {
3080 return $nollafr
3081 ? $self->maybe_parens($self->keyword($name), $cx, 7)
3082 : $self->keyword($name) . '()' x (7 < $cx);
3083 }
3084 my $first;
3085 my $fullname = $self->keyword($name);
3086 my $proto = prototype("CORE::$name");
3087 if (
3088 ( (defined $proto && $proto =~ /^;?\*/)
3089 || $name eq 'select' # select(F) doesn't have a proto
3090 )
3091 && $kid->name eq "rv2gv"
3092 && !($kid->private & OPpLVAL_INTRO)
3093 ) {
3094 $first = $self->rv2gv_or_string($kid->first);
3095 }
3096 else {
3097 $first = $self->deparse($kid, 6);
3098 }
3099 if ($name eq "chmod" && $first =~ /^\d+$/) {
3100 $first = sprintf("%#o", $first);
3101 }
3102 $first = "+$first"
3103 if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
3104 push @exprs, $first;
3105 $kid = $kid->sibling;
3106 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv"
3107 && !($kid->private & OPpLVAL_INTRO)) {
3108 push @exprs, $first = $self->rv2gv_or_string($kid->first);
3109 $kid = $kid->sibling;
3110 }
3111 for (; !null($kid); $kid = $kid->sibling) {
3112 push @exprs, $self->deparse($kid, 6);
3113 }
3114 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
3115 return "$exprs[0] = $fullname"
3116 . ($parens ? "($exprs[0])" : " $exprs[0]");
3117 }
3118
3119 if ($parens && $nollafr) {
3120 return "($fullname " . join(", ", @exprs) . ")";
3121 } elsif ($parens) {
3122 return "$fullname(" . join(", ", @exprs) . ")";
3123 } else {
3124 return "$fullname " . join(", ", @exprs);
3125 }
3126}
3127
3128sub pp_bless { listop(@_, "bless") }
3129sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
3130sub pp_substr {
3131 my ($self,$op,$cx) = @_;
3132 if ($op->private & OPpSUBSTR_REPL_FIRST) {
3133 return
3134 listop($self, $op, 7, "substr", $op->first->sibling->sibling)
3135 . " = "
3136 . $self->deparse($op->first->sibling, 7);
3137 }
3138 maybe_local(@_, listop(@_, "substr"))
3139}
3140sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
3141sub pp_index { maybe_targmy(@_, \&listop, "index") }
3142sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
3143sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
3144sub pp_formline { listop(@_, "formline") } # see also deparse_format
3145sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
3146sub pp_unpack { listop(@_, "unpack") }
3147sub pp_pack { listop(@_, "pack") }
3148sub pp_join { maybe_targmy(@_, \&listop, "join") }
3149sub pp_splice { listop(@_, "splice") }
3150sub pp_push { maybe_targmy(@_, \&listop, "push") }
3151sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
3152sub pp_reverse { listop(@_, "reverse") }
3153sub pp_warn { listop(@_, "warn") }
3154sub pp_die { listop(@_, "die") }
3155sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
3156sub pp_open { listop(@_, "open") }
3157sub pp_pipe_op { listop(@_, "pipe") }
3158sub pp_tie { listop(@_, "tie") }
3159sub pp_binmode { listop(@_, "binmode") }
3160sub pp_dbmopen { listop(@_, "dbmopen") }
3161sub pp_sselect { listop(@_, "select") }
3162sub pp_select { listop(@_, "select") }
3163sub pp_read { listop(@_, "read") }
3164sub pp_sysopen { listop(@_, "sysopen") }
3165sub pp_sysseek { listop(@_, "sysseek") }
3166sub pp_sysread { listop(@_, "sysread") }
3167sub pp_syswrite { listop(@_, "syswrite") }
3168sub pp_send { listop(@_, "send") }
3169sub pp_recv { listop(@_, "recv") }
3170sub pp_seek { listop(@_, "seek") }
3171sub pp_fcntl { listop(@_, "fcntl") }
3172sub pp_ioctl { listop(@_, "ioctl") }
3173sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
3174sub pp_socket { listop(@_, "socket") }
3175sub pp_sockpair { listop(@_, "socketpair") }
3176sub pp_bind { listop(@_, "bind") }
3177sub pp_connect { listop(@_, "connect") }
3178sub pp_listen { listop(@_, "listen") }
3179sub pp_accept { listop(@_, "accept") }
3180sub pp_shutdown { listop(@_, "shutdown") }
3181sub pp_gsockopt { listop(@_, "getsockopt") }
3182sub pp_ssockopt { listop(@_, "setsockopt") }
3183sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
3184sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
3185sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
3186sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
3187sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
3188sub pp_link { maybe_targmy(@_, \&listop, "link") }
3189sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
3190sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
3191sub pp_open_dir { listop(@_, "opendir") }
3192sub pp_seekdir { listop(@_, "seekdir") }
3193sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
3194sub pp_system { maybe_targmy(@_, \&indirop, "system") }
3195sub pp_exec { maybe_targmy(@_, \&indirop, "exec") }
3196sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
3197sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
3198sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
3199sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
3200sub pp_shmget { listop(@_, "shmget") }
3201sub pp_shmctl { listop(@_, "shmctl") }
3202sub pp_shmread { listop(@_, "shmread") }
3203sub pp_shmwrite { listop(@_, "shmwrite") }
3204sub pp_msgget { listop(@_, "msgget") }
3205sub pp_msgctl { listop(@_, "msgctl") }
3206sub pp_msgsnd { listop(@_, "msgsnd") }
3207sub pp_msgrcv { listop(@_, "msgrcv") }
3208sub pp_semget { listop(@_, "semget") }
3209sub pp_semctl { listop(@_, "semctl") }
3210sub pp_semop { listop(@_, "semop") }
3211sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
3212sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
3213sub pp_gpbynumber { listop(@_, "getprotobynumber") }
3214sub pp_gsbyname { listop(@_, "getservbyname") }
3215sub pp_gsbyport { listop(@_, "getservbyport") }
3216sub pp_syscall { listop(@_, "syscall") }
3217
3218sub pp_glob {
3219 my $self = shift;
3220 my($op, $cx) = @_;
3221 my $kid = $op->first->sibling; # skip pushmark
3222 my $keyword =
3223 $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
3224 my $text;
3225 if ($keyword =~ /^CORE::/
3226 or $kid->name ne 'const'
3227 or ($text = $self->dq($kid))
3228 =~ /^\$?(\w|::|\`)+$/ # could look like a readline
3229 or $text =~ /[<>]/) {
3230 $text = $self->deparse($kid);
3231 return $cx >= 5 || $self->{'parens'}
3232 ? "$keyword($text)"
3233 : "$keyword $text";
3234 } else {
3235 return '<' . $text . '>';
3236 }
3237}
3238
3239# Truncate is special because OPf_SPECIAL makes a bareword first arg
3240# be a filehandle. This could probably be better fixed in the core
3241# by moving the GV lookup into ck_truc.
3242
3243sub pp_truncate {
3244 my $self = shift;
3245 my($op, $cx) = @_;
3246 my(@exprs);
3247 my $parens = ($cx >= 5) || $self->{'parens'};
3248 my $kid = $op->first->sibling;
3249 my $fh;
3250 if ($op->flags & OPf_SPECIAL) {
3251 # $kid is an OP_CONST
3252 $fh = $self->const_sv($kid)->PV;
3253 } else {
3254 $fh = $self->deparse($kid, 6);
3255 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
3256 }
3257 my $len = $self->deparse($kid->sibling, 6);
3258 my $name = $self->keyword('truncate');
3259 if ($parens) {
3260 return "$name($fh, $len)";
3261 } else {
3262 return "$name $fh, $len";
3263 }
3264}
3265
3266sub indirop {
3267 my $self = shift;
3268 my($op, $cx, $name) = @_;
3269 my($expr, @exprs);
3270 my $firstkid = my $kid = $op->first->sibling;
3271 my $indir = "";
3272 if ($op->flags & OPf_STACKED) {
3273 $indir = $kid;
3274 $indir = $indir->first; # skip rv2gv
3275 if (is_scope($indir)) {
3276 $indir = "{" . $self->deparse($indir, 0) . "}";
3277 $indir = "{;}" if $indir eq "{}";
3278 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
3279 $indir = $self->const_sv($indir)->PV;
3280 } else {
3281 $indir = $self->deparse($indir, 24);
3282 }
3283 $indir = $indir . " ";
3284 $kid = $kid->sibling;
3285 }
3286 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
3287 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
3288 : '{$a <=> $b} ';
3289 }
3290 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
3291 $indir = '{$b cmp $a} ';
3292 }
3293 for (; !null($kid); $kid = $kid->sibling) {
3294 $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
3295 push @exprs, $expr;
3296 }
3297 my $name2;
3298 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
3299 $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort');
3300 }
3301 else { $name2 = $self->keyword($name) }
3302 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
3303 return "$exprs[0] = $name2 $indir $exprs[0]";
3304 }
3305
3306 my $args = $indir . join(", ", @exprs);
3307 if ($indir ne "" && $name eq "sort") {
3308 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
3309 # give bareword warnings in that case. Therefore if context
3310 # requires, we'll put parens around the outside "(sort f 1, 2,
3311 # 3)". Unfortunately, we'll currently think the parens are
3312 # necessary more often that they really are, because we don't
3313 # distinguish which side of an assignment we're on.
3314 if ($cx >= 5) {
3315 return "($name2 $args)";
3316 } else {
3317 return "$name2 $args";
3318 }
3319 } elsif (
3320 !$indir && $name eq "sort"
3321 && !null($op->first->sibling)
3322 && $op->first->sibling->name eq 'entersub'
3323 ) {
3324 # We cannot say sort foo(bar), as foo will be interpreted as a
3325 # comparison routine. We have to say sort(...) in that case.
3326 return "$name2($args)";
3327 } else {
3328 return length $args
3329 ? $self->maybe_parens_func($name2, $args, $cx, 5)
3330 : $name2 . '()' x (7 < $cx);
3331 }
3332
3333}
3334
3335sub pp_prtf { indirop(@_, "printf") }
3336sub pp_print { indirop(@_, "print") }
3337sub pp_say { indirop(@_, "say") }
3338sub pp_sort { indirop(@_, "sort") }
3339
3340sub mapop {
3341 my $self = shift;
3342 my($op, $cx, $name) = @_;
3343 my($expr, @exprs);
3344 my $kid = $op->first; # this is the (map|grep)start
3345 $kid = $kid->first->sibling; # skip a pushmark
3346 my $code = $kid->first; # skip a null
3347 if (is_scope $code) {
3348 $code = "{" . $self->deparse($code, 0) . "} ";
3349 } else {
3350 $code = $self->deparse($code, 24);
3351 $code .= ", " if !null($kid->sibling);
3352 }
3353 $kid = $kid->sibling;
3354 for (; !null($kid); $kid = $kid->sibling) {
3355 $expr = $self->deparse($kid, 6);
3356 push @exprs, $expr if defined $expr;
3357 }
3358 return $self->maybe_parens_func($self->keyword($name),
3359 $code . join(", ", @exprs), $cx, 5);
3360}
3361
3362sub pp_mapwhile { mapop(@_, "map") }
3363sub pp_grepwhile { mapop(@_, "grep") }
3364sub pp_mapstart { baseop(@_, "map") }
3365sub pp_grepstart { baseop(@_, "grep") }
3366
33671100nsmy %uses_intro;
3368
# spent 3.35ms within B::Deparse::BEGIN@3368 which was called: # once (3.35ms+0s) by YAML::XS::BEGIN@57 at line 3377
BEGIN {
3369 @uses_intro{
337012.81ms eval { require B::Op_private }
3371111µs ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
3372 : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
3373 hslice delete padsv padav padhv enteriter entersub padrange
3374 pushmark cond_expr refassign list)
3375 } = ();
337616µs delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
337713.72ms13.35ms}
# spent 3.35ms making 1 call to B::Deparse::BEGIN@3368
3378
3379sub pp_list {
3380 my $self = shift;
3381 my($op, $cx) = @_;
3382 my($expr, @exprs);
3383 my $kid = $op->first->sibling; # skip pushmark
3384 return '' if class($kid) eq 'NULL';
3385 my $lop;
3386 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
3387 my $type;
3388 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
3389 my $lopname = $lop->name;
3390 my $loppriv = $lop->private;
3391 my $newtype;
3392 if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
3393 if ($loppriv & OPpPAD_STATE) { # state()
3394 ($local = "", last) if $local !~ /^(?:either|state)$/;
3395 $local = "state";
3396 } else { # my()
3397 ($local = "", last) if $local !~ /^(?:either|my)$/;
3398 $local = "my";
3399 }
3400 my $padname = $self->padname_sv($lop->targ);
3401 if ($padname->FLAGS & SVpad_TYPED) {
3402 $newtype = $padname->SvSTASH->NAME;
3403 }
3404 } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
3405 && $loppriv & OPpOUR_INTRO
3406 or $lopname eq "null" && class($lop) eq 'UNOP'
3407 && $lop->first->name eq "gvsv"
3408 && $lop->first->private & OPpOUR_INTRO) { # our()
3409 my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our";
3410 ($local = "", last)
3411 if $local ne 'either' && $local ne $newlocal;
3412 $local = $newlocal;
3413 my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
3414 if (my $t = $self->find_our_type(
3415 $funny . $self->gv_or_padgv($lop->first)->NAME
3416 )) {
3417 $newtype = $t;
3418 }
3419 } elsif ($lopname ne 'undef'
3420 and !($loppriv & OPpLVAL_INTRO)
3421 || !exists $uses_intro{$lopname eq 'null'
3422 ? substr B::ppname($lop->targ), 3
3423 : $lopname})
3424 {
3425 $local = ""; # or not
3426 last;
3427 } elsif ($lopname ne "undef")
3428 {
3429 # local()
3430 ($local = "", last) if $local !~ /^(?:either|local)$/;
3431 $local = "local";
3432 }
3433 if (defined $type && defined $newtype && $newtype ne $type) {
3434 $local = '';
3435 last;
3436 }
3437 $type = $newtype;
3438 }
3439 $local = "" if $local eq "either"; # no point if it's all undefs
3440 $local &&= join ' ', map $self->keyword($_), split / /, $local;
3441 $local .= " $type " if $local && length $type;
3442 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
3443 for (; !null($kid); $kid = $kid->sibling) {
3444 if ($local) {
3445 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
3446 $lop = $kid->first;
3447 } else {
3448 $lop = $kid;
3449 }
3450 $self->{'avoid_local'}{$$lop}++;
3451 $expr = $self->deparse($kid, 6);
3452 delete $self->{'avoid_local'}{$$lop};
3453 } else {
3454 $expr = $self->deparse($kid, 6);
3455 }
3456 push @exprs, $expr;
3457 }
3458 if ($local) {
3459 return "$local(" . join(", ", @exprs) . ")";
3460 } else {
3461 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
3462 }
3463}
3464
3465sub is_ifelse_cont {
3466 my $op = shift;
3467 return ($op->name eq "null" and class($op) eq "UNOP"
3468 and $op->first->name =~ /^(and|cond_expr)$/
3469 and is_scope($op->first->first->sibling));
3470}
3471
3472sub pp_cond_expr {
3473 my $self = shift;
3474 my($op, $cx) = @_;
3475 my $cond = $op->first;
3476 my $true = $cond->sibling;
3477 my $false = $true->sibling;
3478 my $cuddle = $self->{'cuddle'};
3479 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
3480 (is_scope($false) || is_ifelse_cont($false))
3481 and $self->{'expand'} < 7) {
3482 $cond = $self->deparse($cond, 8);
3483 $true = $self->deparse($true, 6);
3484 $false = $self->deparse($false, 8);
3485 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
3486 }
3487
3488 $cond = $self->deparse($cond, 1);
3489 $true = $self->deparse($true, 0);
3490 my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}";
3491 my @elsifs;
3492 my $elsif;
3493 while (!null($false) and is_ifelse_cont($false)) {
3494 my $newop = $false->first;
3495 my $newcond = $newop->first;
3496 my $newtrue = $newcond->sibling;
3497 $false = $newtrue->sibling; # last in chain is OP_AND => no else
3498 if ($newcond->name eq "lineseq")
3499 {
3500 # lineseq to ensure correct line numbers in elsif()
3501 # Bug #37302 fixed by change #33710.
3502 $newcond = $newcond->first->sibling;
3503 }
3504 $newcond = $self->deparse($newcond, 1);
3505 $newtrue = $self->deparse($newtrue, 0);
3506 $elsif ||= $self->keyword("elsif");
3507 push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}";
3508 }
3509 if (!null($false)) {
3510 $false = $cuddle . $self->keyword("else") . " {\n\t" .
3511 $self->deparse($false, 0) . "\n\b}\cK";
3512 } else {
3513 $false = "\cK";
3514 }
3515 return $head . join($cuddle, "", @elsifs) . $false;
3516}
3517
3518sub pp_once {
3519 my ($self, $op, $cx) = @_;
3520 my $cond = $op->first;
3521 my $true = $cond->sibling;
3522
3523 my $ret = $self->deparse($true, $cx);
3524 $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
3525 $ret;
3526}
3527
3528sub loop_common {
3529 my $self = shift;
3530 my($op, $cx, $init) = @_;
3531 my $enter = $op->first;
3532 my $kid = $enter->sibling;
3533 local(@$self{qw'curstash warnings hints hinthash'})
3534 = @$self{qw'curstash warnings hints hinthash'};
3535 my $head = "";
3536 my $bare = 0;
3537 my $body;
3538 my $cond = undef;
3539 my $name;
3540 if ($kid->name eq "lineseq") { # bare or infinite loop
3541 if ($kid->last->name eq "unstack") { # infinite
3542 $head = "while (1) "; # Can't use for(;;) if there's a continue
3543 $cond = "";
3544 } else {
3545 $bare = 1;
3546 }
3547 $body = $kid;
3548 } elsif ($enter->name eq "enteriter") { # foreach
3549 my $ary = $enter->first->sibling; # first was pushmark
3550 my $var = $ary->sibling;
3551 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
3552 # "reverse" was optimised away
3553 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
3554 } elsif ($enter->flags & OPf_STACKED
3555 and not null $ary->first->sibling->sibling)
3556 {
3557 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
3558 $self->deparse($ary->first->sibling->sibling, 9);
3559 } else {
3560 $ary = $self->deparse($ary, 1);
3561 }
3562 if (null $var) {
3563 $var = $self->pp_padsv($enter, 1, 1);
3564 } elsif ($var->name eq "rv2gv") {
3565 $var = $self->pp_rv2sv($var, 1);
3566 if ($enter->private & OPpOUR_INTRO) {
3567 # our declarations don't have package names
3568 $var =~ s/^(.).*::/$1/;
3569 $var = "our $var";
3570 }
3571 } elsif ($var->name eq "gv") {
3572 $var = "\$" . $self->deparse($var, 1);
3573 } else {
3574 $var = $self->deparse($var, 1);
3575 }
3576 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
3577 if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) {
3578 confess unless $var eq '$_';
3579 $body = $body->first;
3580 return $self->deparse($body, 2) . " "
3581 . $self->keyword("foreach") . " ($ary)";
3582 }
3583 $head = "foreach $var ($ary) ";
3584 } elsif ($kid->name eq "null") { # while/until
3585 $kid = $kid->first;
3586 $name = {"and" => "while", "or" => "until"}->{$kid->name};
3587 $cond = $kid->first;
3588 $body = $kid->first->sibling;
3589 } elsif ($kid->name eq "stub") { # bare and empty
3590 return "{;}"; # {} could be a hashref
3591 }
3592 # If there isn't a continue block, then the next pointer for the loop
3593 # will point to the unstack, which is kid's last child, except
3594 # in a bare loop, when it will point to the leaveloop. When neither of
3595 # these conditions hold, then the second-to-last child is the continue
3596 # block (or the last in a bare loop).
3597 my $cont_start = $enter->nextop;
3598 my $cont;
3599 my $precond;
3600 my $postcond;
3601 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
3602 if ($bare) {
3603 $cont = $body->last;
3604 } else {
3605 $cont = $body->first;
3606 while (!null($cont->sibling->sibling)) {
3607 $cont = $cont->sibling;
3608 }
3609 }
3610 my $state = $body->first;
3611 my $cuddle = $self->{'cuddle'};
3612 my @states;
3613 for (; $$state != $$cont; $state = $state->sibling) {
3614 push @states, $state;
3615 }
3616 $body = $self->lineseq(undef, 0, @states);
3617 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
3618 $precond = "for ($init; ";
3619 $postcond = "; " . $self->deparse($cont, 1) .") ";
3620 $cont = "\cK";
3621 } else {
3622 $cont = $cuddle . "continue {\n\t" .
3623 $self->deparse($cont, 0) . "\n\b}\cK";
3624 }
3625 } else {
3626 return "" if !defined $body;
3627 if (length $init) {
3628 $precond = "for ($init; ";
3629 $postcond = ";) ";
3630 }
3631 $cont = "\cK";
3632 $body = $self->deparse($body, 0);
3633 }
3634 if ($precond) { # for(;;)
3635 $cond &&= $name eq 'until'
3636 ? listop($self, undef, 1, "not", $cond->first)
3637 : $self->deparse($cond, 1);
3638 $head = "$precond$cond$postcond";
3639 }
3640 if ($name && !$head) {
3641 ref $cond and $cond = $self->deparse($cond, 1);
3642 $head = "$name ($cond) ";
3643 }
3644 $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e;
3645 $body =~ s/;?$/;\n/;
3646
3647 return $head . "{\n\t" . $body . "\b}" . $cont;
3648}
3649
3650sub pp_leaveloop { shift->loop_common(@_, "") }
3651
3652sub for_loop {
3653 my $self = shift;
3654 my($op, $cx) = @_;
3655 my $init = $self->deparse($op, 1);
3656 my $s = $op->sibling;
3657 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
3658 return $self->loop_common($ll, $cx, $init);
3659}
3660
3661sub pp_leavetry {
3662 my $self = shift;
3663 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
3664}
3665
3666sub _op_is_or_was {
3667 my ($op, $expect_type) = @_;
3668 my $type = $op->type;
3669 return($type == $expect_type
3670 || ($type == OP_NULL && $op->targ == $expect_type));
3671}
3672
3673sub pp_null {
3674 my($self, $op, $cx) = @_;
3675 if (class($op) eq "OP") {
3676 # old value is lost
3677 return $self->{'ex_const'} if $op->targ == OP_CONST;
3678 } elsif (class ($op) eq "COP") {
3679 return &pp_nextstate;
3680 } elsif ($op->first->name eq 'pushmark'
3681 or $op->first->name eq 'null'
3682 && $op->first->targ == OP_PUSHMARK
3683 && _op_is_or_was($op, OP_LIST)) {
3684 return $self->pp_list($op, $cx);
3685 } elsif ($op->first->name eq "enter") {
3686 return $self->pp_leave($op, $cx);
3687 } elsif ($op->first->name eq "leave") {
3688 return $self->pp_leave($op->first, $cx);
3689 } elsif ($op->first->name eq "scope") {
3690 return $self->pp_scope($op->first, $cx);
3691 } elsif ($op->targ == OP_STRINGIFY) {
3692 return $self->dquote($op, $cx);
3693 } elsif ($op->targ == OP_GLOB) {
3694 return $self->pp_glob(
3695 $op->first # entersub
3696 ->first # ex-list
3697 ->first # pushmark
3698 ->sibling, # glob
3699 $cx
3700 );
3701 } elsif (!null($op->first->sibling) and
3702 $op->first->sibling->name eq "readline" and
3703 $op->first->sibling->flags & OPf_STACKED) {
3704 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
3705 . $self->deparse($op->first->sibling, 7),
3706 $cx, 7);
3707 } elsif (!null($op->first->sibling) and
3708 $op->first->sibling->name =~ /^transr?\z/ and
3709 $op->first->sibling->flags & OPf_STACKED) {
3710 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
3711 . $self->deparse($op->first->sibling, 20),
3712 $cx, 20);
3713 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
3714 return ($self->lex_in_scope("&do") ? "CORE::do" : "do")
3715 . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
3716 } elsif (!null($op->first->sibling) and
3717 $op->first->sibling->name eq "null" and
3718 class($op->first->sibling) eq "UNOP" and
3719 $op->first->sibling->first->flags & OPf_STACKED and
3720 $op->first->sibling->first->name eq "rcatline") {
3721 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
3722 . $self->deparse($op->first->sibling, 18),
3723 $cx, 18);
3724 } else {
3725 return $self->deparse($op->first, $cx);
3726 }
3727}
3728
3729sub padname {
3730 my $self = shift;
3731 my $targ = shift;
3732 return $self->padname_sv($targ)->PVX;
3733}
3734
3735sub padany {
3736 my $self = shift;
3737 my $op = shift;
3738 return substr($self->padname($op->targ), 1); # skip $/@/%
3739}
3740
3741sub pp_padsv {
3742 my $self = shift;
3743 my($op, $cx, $forbid_parens) = @_;
3744 my $targ = $op->targ;
3745 return $self->maybe_my($op, $cx, $self->padname($targ),
3746 $self->padname_sv($targ),
3747 $forbid_parens);
3748}
3749
3750sub pp_padav { pp_padsv(@_) }
3751sub pp_padhv { pp_padsv(@_) }
3752
3753sub gv_or_padgv {
3754 my $self = shift;
3755 my $op = shift;
3756 if (class($op) eq "PADOP") {
3757 return $self->padval($op->padix);
3758 } else { # class($op) eq "SVOP"
3759 return $op->gv;
3760 }
3761}
3762
3763sub pp_gvsv {
3764 my $self = shift;
3765 my($op, $cx) = @_;
3766 my $gv = $self->gv_or_padgv($op);
3767 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
3768 $self->gv_name($gv), $cx));
3769}
3770
3771sub pp_gv {
3772 my $self = shift;
3773 my($op, $cx) = @_;
3774 my $gv = $self->gv_or_padgv($op);
3775 return $self->gv_name($gv);
3776}
3777
3778sub pp_aelemfast_lex {
3779 my $self = shift;
3780 my($op, $cx) = @_;
3781 my $name = $self->padname($op->targ);
3782 $name =~ s/^@/\$/;
3783 my $i = $op->private;
3784 $i -= 256 if $i > 127;
3785 return $name . "[" . ($i + $self->{'arybase'}) . "]";
3786}
3787
3788sub pp_aelemfast {
3789 my $self = shift;
3790 my($op, $cx) = @_;
3791 # optimised PADAV, pre 5.15
3792 return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL);
3793
3794 my $gv = $self->gv_or_padgv($op);
3795 my($name,$quoted) = $self->stash_variable_name('@',$gv);
3796 $name = $quoted ? "$name->" : '$' . $name;
3797 my $i = $op->private;
3798 $i -= 256 if $i > 127;
3799 return $name . "[" . ($i + $self->{'arybase'}) . "]";
3800}
3801
3802sub rv2x {
3803 my $self = shift;
3804 my($op, $cx, $type) = @_;
3805
3806 if (class($op) eq 'NULL' || !$op->can("first")) {
3807 carp("Unexpected op in pp_rv2x");
3808 return 'XXX';
3809 }
3810 my $kid = $op->first;
3811 if ($kid->name eq "gv") {
3812 return $self->stash_variable($type, $self->deparse($kid, 0), $cx);
3813 } elsif (is_scalar $kid) {
3814 my $str = $self->deparse($kid, 0);
3815 if ($str =~ /^\$([^\w\d])\z/) {
3816 # "$$+" isn't a legal way to write the scalar dereference
3817 # of $+, since the lexer can't tell you aren't trying to
3818 # do something like "$$ + 1" to get one more than your
3819 # PID. Either "${$+}" or "$${+}" are workable
3820 # disambiguations, but if the programmer did the former,
3821 # they'd be in the "else" clause below rather than here.
3822 # It's not clear if this should somehow be unified with
3823 # the code in dq and re_dq that also adds lexer
3824 # disambiguation braces.
3825 $str = '$' . "{$1}"; #'
3826 }
3827 return $type . $str;
3828 } else {
3829 return $type . "{" . $self->deparse($kid, 0) . "}";
3830 }
3831}
3832
3833sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
3834sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
3835sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
3836
3837# skip rv2av
3838sub pp_av2arylen {
3839 my $self = shift;
3840 my($op, $cx) = @_;
3841 if ($op->first->name eq "padav") {
3842 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
3843 } else {
3844 return $self->maybe_local($op, $cx,
3845 $self->rv2x($op->first, $cx, '$#'));
3846 }
3847}
3848
3849# skip down to the old, ex-rv2cv
3850sub pp_rv2cv {
3851 my ($self, $op, $cx) = @_;
3852 if (!null($op->first) && $op->first->name eq 'null' &&
3853 $op->first->targ == OP_LIST)
3854 {
3855 return $self->rv2x($op->first->first->sibling, $cx, "&")
3856 }
3857 else {
3858 return $self->rv2x($op, $cx, "")
3859 }
3860}
3861
3862sub list_const {
3863 my $self = shift;
3864 my($cx, @list) = @_;
3865 my @a = map $self->const($_, 6), @list;
3866 if (@a == 0) {
3867 return "()";
3868 } elsif (@a == 1) {
3869 return $a[0];
3870 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
3871 # collapse (-1,0,1,2) into (-1..2)
3872 my ($s, $e) = @a[0,-1];
3873 my $i = $s;
3874 return $self->maybe_parens("$s..$e", $cx, 9)
3875 unless grep $i++ != $_, @a;
3876 }
3877 return $self->maybe_parens(join(", ", @a), $cx, 6);
3878}
3879
3880sub pp_rv2av {
3881 my $self = shift;
3882 my($op, $cx) = @_;
3883 my $kid = $op->first;
3884 if ($kid->name eq "const") { # constant list
3885 my $av = $self->const_sv($kid);
3886 return $self->list_const($cx, $av->ARRAY);
3887 } else {
3888 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
3889 }
3890 }
3891
3892sub is_subscriptable {
3893 my $op = shift;
3894 if ($op->name =~ /^([ahg]elem|multideref$)/) {
3895 return 1;
3896 } elsif ($op->name eq "entersub") {
3897 my $kid = $op->first;
3898 return 0 unless null $kid->sibling;
3899 $kid = $kid->first;
3900 $kid = $kid->sibling until null $kid->sibling;
3901 return 0 if is_scope($kid);
3902 $kid = $kid->first;
3903 return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
3904 return 0 if is_scalar($kid);
3905 return is_subscriptable($kid);
3906 } else {
3907 return 0;
3908 }
3909}
3910
3911sub elem_or_slice_array_name
3912{
3913 my $self = shift;
3914 my ($array, $left, $padname, $allow_arrow) = @_;
3915
3916 if ($array->name eq $padname) {
3917 return $self->padany($array);
3918 } elsif (is_scope($array)) { # ${expr}[0]
3919 return "{" . $self->deparse($array, 0) . "}";
3920 } elsif ($array->name eq "gv") {
3921 ($array, my $quoted) =
3922 $self->stash_variable_name(
3923 $left eq '[' ? '@' : '%', $self->gv_or_padgv($array)
3924 );
3925 if (!$allow_arrow && $quoted) {
3926 # This cannot happen.
3927 die "Invalid variable name $array for slice";
3928 }
3929 return $quoted ? "$array->" : $array;
3930 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3931 return $self->deparse($array, 24);
3932 } else {
3933 return undef;
3934 }
3935}
3936
3937sub elem_or_slice_single_index
3938{
3939 my $self = shift;
3940 my ($idx) = @_;
3941
3942 $idx = $self->deparse($idx, 1);
3943
3944 # Outer parens in an array index will confuse perl
3945 # if we're interpolating in a regular expression, i.e.
3946 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3947 #
3948 # If $self->{parens}, then an initial '(' will
3949 # definitely be paired with a final ')'. If
3950 # !$self->{parens}, the misleading parens won't
3951 # have been added in the first place.
3952 #
3953 # [You might think that we could get "(...)...(...)"
3954 # where the initial and final parens do not match
3955 # each other. But we can't, because the above would
3956 # only happen if there's an infix binop between the
3957 # two pairs of parens, and *that* means that the whole
3958 # expression would be parenthesized as well.]
3959 #
3960 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3961
3962 # Hash-element braces will autoquote a bareword inside themselves.
3963 # We need to make sure that C<$hash{warn()}> doesn't come out as
3964 # C<$hash{warn}>, which has a quite different meaning. Currently
3965 # B::Deparse will always quote strings, even if the string was a
3966 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3967 # for constant strings.) So we can cheat slightly here - if we see
3968 # a bareword, we know that it is supposed to be a function call.
3969 #
3970 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3971
3972 return $idx;
3973}
3974
3975sub elem {
3976 my $self = shift;
3977 my ($op, $cx, $left, $right, $padname) = @_;
3978 my($array, $idx) = ($op->first, $op->first->sibling);
3979
3980 $idx = $self->elem_or_slice_single_index($idx);
3981
3982 unless ($array->name eq $padname) { # Maybe this has been fixed
3983 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3984 }
3985 if (my $array_name=$self->elem_or_slice_array_name
3986 ($array, $left, $padname, 1)) {
3987 return ($array_name =~ /->\z/
3988 ? $array_name
3989 : $array_name eq '#' ? '${#}' : "\$" . $array_name)
3990 . $left . $idx . $right;
3991 } else {
3992 # $x[20][3]{hi} or expr->[20]
3993 my $arrow = is_subscriptable($array) ? "" : "->";
3994 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3995 }
3996
3997}
3998
3999# a simplified version of elem_or_slice_array_name()
4000# for the use of pp_multideref
4001
4002sub multideref_var_name {
4003 my $self = shift;
4004 my ($gv, $is_hash) = @_;
4005
4006 my ($name, $quoted) =
4007 $self->stash_variable_name( $is_hash ? '%' : '@', $gv);
4008 return $quoted ? "$name->"
4009 : $name eq '#'
4010 ? '${#}' # avoid ${#}[1] => $#[1]
4011 : '$' . $name;
4012}
4013
4014
4015sub pp_multideref {
4016 my $self = shift;
4017 my($op, $cx) = @_;
4018 my $text = "";
4019
4020 if ($op->private & OPpMULTIDEREF_EXISTS) {
4021 $text = $self->keyword("exists"). " ";
4022 }
4023 elsif ($op->private & OPpMULTIDEREF_DELETE) {
4024 $text = $self->keyword("delete"). " ";
4025 }
4026 elsif ($op->private & OPpLVAL_INTRO) {
4027 $text = $self->keyword("local"). " ";
4028 }
4029
4030 if ($op->first && ($op->first->flags & OPf_KIDS)) {
4031 # arbitrary initial expression, e.g. f(1,2,3)->[...]
4032 $text .= $self->deparse($op->first, 24);
4033 }
4034
4035 my @items = $op->aux_list($self->{curcv});
4036 my $actions = shift @items;
4037
4038 my $is_hash;
4039 my $derefs = 0;
4040
4041 while (1) {
4042 if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) {
4043 $actions = shift @items;
4044 next;
4045 }
4046
4047 $is_hash = (
4048 ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem
4049 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem
4050 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem
4051 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem
4052 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem
4053 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem
4054 );
4055
4056 if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem
4057 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem)
4058 {
4059 $derefs = 1;
4060 $text .= '$' . substr($self->padname(shift @items), 1);
4061 }
4062 elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem
4063 || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem)
4064 {
4065 $derefs = 1;
4066 $text .= $self->multideref_var_name(shift @items, $is_hash);
4067 }
4068 else {
4069 if ( ($actions & MDEREF_ACTION_MASK) ==
4070 MDEREF_AV_padsv_vivify_rv2av_aelem
4071 || ($actions & MDEREF_ACTION_MASK) ==
4072 MDEREF_HV_padsv_vivify_rv2hv_helem)
4073 {
4074 $text .= $self->padname(shift @items);
4075 }
4076 elsif ( ($actions & MDEREF_ACTION_MASK) ==
4077 MDEREF_AV_gvsv_vivify_rv2av_aelem
4078 || ($actions & MDEREF_ACTION_MASK) ==
4079 MDEREF_HV_gvsv_vivify_rv2hv_helem)
4080 {
4081 $text .= $self->multideref_var_name(shift @items, $is_hash);
4082 }
4083 elsif ( ($actions & MDEREF_ACTION_MASK) ==
4084 MDEREF_AV_pop_rv2av_aelem
4085 || ($actions & MDEREF_ACTION_MASK) ==
4086 MDEREF_HV_pop_rv2hv_helem)
4087 {
4088 if ( ($op->flags & OPf_KIDS)
4089 && ( _op_is_or_was($op->first, OP_RV2AV)
4090 || _op_is_or_was($op->first, OP_RV2HV))
4091 && ($op->first->flags & OPf_KIDS)
4092 && ( _op_is_or_was($op->first->first, OP_AELEM)
4093 || _op_is_or_was($op->first->first, OP_HELEM))
4094 )
4095 {
4096 $derefs++;
4097 }
4098 }
4099
4100 $text .= '->' if !$derefs++;
4101 }
4102
4103
4104 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) {
4105 last;
4106 }
4107
4108 $text .= $is_hash ? '{' : '[';
4109
4110 if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) {
4111 my $key = shift @items;
4112 if ($is_hash) {
4113 $text .= $self->const($key, $cx);
4114 }
4115 else {
4116 $text .= $key;
4117 }
4118 }
4119 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) {
4120 $text .= $self->padname(shift @items);
4121 }
4122 elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) {
4123 $text .= '$' . ($self->stash_variable_name('$', shift @items))[0];
4124 }
4125
4126 $text .= $is_hash ? '}' : ']';
4127
4128 if ($actions & MDEREF_FLAG_last) {
4129 last;
4130 }
4131 $actions >>= MDEREF_SHIFT;
4132 }
4133
4134 return $text;
4135}
4136
4137
4138sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
4139sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
4140
4141sub pp_gelem {
4142 my $self = shift;
4143 my($op, $cx) = @_;
4144 my($glob, $part) = ($op->first, $op->last);
4145 $glob = $glob->first; # skip rv2gv
4146 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
4147 my $scope = is_scope($glob);
4148 $glob = $self->deparse($glob, 0);
4149 $part = $self->deparse($part, 1);
4150 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
4151}
4152
4153sub slice {
4154 my $self = shift;
4155 my ($op, $cx, $left, $right, $regname, $padname) = @_;
4156 my $last;
4157 my(@elems, $kid, $array, $list);
4158 if (class($op) eq "LISTOP") {
4159 $last = $op->last;
4160 } else { # ex-hslice inside delete()
4161 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
4162 $last = $kid;
4163 }
4164 $array = $last;
4165 $array = $array->first
4166 if $array->name eq $regname or $array->name eq "null";
4167 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
4168 $kid = $op->first->sibling; # skip pushmark
4169 if ($kid->name eq "list") {
4170 $kid = $kid->first->sibling; # skip list, pushmark
4171 for (; !null $kid; $kid = $kid->sibling) {
4172 push @elems, $self->deparse($kid, 6);
4173 }
4174 $list = join(", ", @elems);
4175 } else {
4176 $list = $self->elem_or_slice_single_index($kid);
4177 }
4178 my $lead = '@';
4179 $lead = '%' if $op->name =~ /^kv/i;
4180 return $lead . $array . $left . $list . $right;
4181}
4182
4183sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
4184sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") }
4185sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
4186sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") }
4187
4188sub pp_lslice {
4189 my $self = shift;
4190 my($op, $cx) = @_;
4191 my $idx = $op->first;
4192 my $list = $op->last;
4193 my(@elems, $kid);
4194 $list = $self->deparse($list, 1);
4195 $idx = $self->deparse($idx, 1);
4196 return "($list)" . "[$idx]";
4197}
4198
4199sub want_scalar {
4200 my $op = shift;
4201 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
4202}
4203
4204sub want_list {
4205 my $op = shift;
4206 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
4207}
4208
4209sub _method {
4210 my $self = shift;
4211 my($op, $cx) = @_;
4212 my $kid = $op->first->sibling; # skip pushmark
4213 my($meth, $obj, @exprs);
4214 if ($kid->name eq "list" and want_list $kid) {
4215 # When an indirect object isn't a bareword but the args are in
4216 # parens, the parens aren't part of the method syntax (the LLAFR
4217 # doesn't apply), but they make a list with OPf_PARENS set that
4218 # doesn't get flattened by the append_elem that adds the method,
4219 # making a (object, arg1, arg2, ...) list where the object
4220 # usually is. This can be distinguished from
4221 # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
4222 # object) because in the later the list is in scalar context
4223 # as the left side of -> always is, while in the former
4224 # the list is in list context as method arguments always are.
4225 # (Good thing there aren't method prototypes!)
4226 $meth = $kid->sibling;
4227 $kid = $kid->first->sibling; # skip pushmark
4228 $obj = $kid;
4229 $kid = $kid->sibling;
4230 for (; not null $kid; $kid = $kid->sibling) {
4231 push @exprs, $kid;
4232 }
4233 } else {
4234 $obj = $kid;
4235 $kid = $kid->sibling;
4236 for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/;
4237 $kid = $kid->sibling) {
4238 push @exprs, $kid
4239 }
4240 $meth = $kid;
4241 }
4242
4243 if ($meth->name eq "method_named") {
4244 $meth = $self->meth_sv($meth)->PV;
4245 } elsif ($meth->name eq "method_super") {
4246 $meth = "SUPER::".$self->meth_sv($meth)->PV;
4247 } elsif ($meth->name eq "method_redir") {
4248 $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV;
4249 } elsif ($meth->name eq "method_redir_super") {
4250 $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'.
4251 $self->meth_sv($meth)->PV;
4252 } else {
4253 $meth = $meth->first;
4254 if ($meth->name eq "const") {
4255 # As of 5.005_58, this case is probably obsoleted by the
4256 # method_named case above
4257 $meth = $self->const_sv($meth)->PV; # needs to be bare
4258 }
4259 }
4260
4261 return { method => $meth, variable_method => ref($meth),
4262 object => $obj, args => \@exprs },
4263 $cx;
4264}
4265
4266# compat function only
4267sub method {
4268 my $self = shift;
4269 my $info = $self->_method(@_);
4270 return $self->e_method( $self->_method(@_) );
4271}
4272
4273sub e_method {
4274 my ($self, $info, $cx) = @_;
4275 my $obj = $self->deparse($info->{object}, 24);
4276
4277 my $meth = $info->{method};
4278 $meth = $self->deparse($meth, 1) if $info->{variable_method};
4279 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
4280 if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
4281 # method { $object }
4282 # This must be deparsed this way to preserve list context
4283 # of $object.
4284 my $need_paren = $cx >= 6;
4285 return '(' x $need_paren
4286 . $meth . substr($obj,2) # chop off the "do"
4287 . " $args"
4288 . ')' x $need_paren;
4289 }
4290 my $kid = $obj . "->" . $meth;
4291 if (length $args) {
4292 return $kid . "(" . $args . ")"; # parens mandatory
4293 } else {
4294 return $kid;
4295 }
4296}
4297
4298# returns "&" if the prototype doesn't match the args,
4299# or ("", $args_after_prototype_demunging) if it does.
4300sub check_proto {
4301 my $self = shift;
4302 return "&" if $self->{'noproto'};
4303 my($proto, @args) = @_;
4304 my($arg, $real);
4305 my $doneok = 0;
4306 my @reals;
4307 # An unbackslashed @ or % gobbles up the rest of the args
4308 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
4309 $proto =~ s/^\s*//;
4310 while ($proto) {
4311 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//;
4312 my $chr = $1;
4313 if ($chr eq "") {
4314 return "&" if @args;
4315 } elsif ($chr eq ";") {
4316 $doneok = 1;
4317 } elsif ($chr eq "@" or $chr eq "%") {
4318 push @reals, map($self->deparse($_, 6), @args);
4319 @args = ();
4320 } else {
4321 $arg = shift @args;
4322 last unless $arg;
4323 if ($chr eq "\$" || $chr eq "_") {
4324 if (want_scalar $arg) {
4325 push @reals, $self->deparse($arg, 6);
4326 } else {
4327 return "&";
4328 }
4329 } elsif ($chr eq "&") {
4330 if ($arg->name =~ /^(s?refgen|undef)$/) {
4331 push @reals, $self->deparse($arg, 6);
4332 } else {
4333 return "&";
4334 }
4335 } elsif ($chr eq "*") {
4336 if ($arg->name =~ /^s?refgen$/
4337 and $arg->first->first->name eq "rv2gv")
4338 {
4339 $real = $arg->first->first; # skip refgen, null
4340 if ($real->first->name eq "gv") {
4341 push @reals, $self->deparse($real, 6);
4342 } else {
4343 push @reals, $self->deparse($real->first, 6);
4344 }
4345 } else {
4346 return "&";
4347 }
4348 } elsif (substr($chr, 0, 1) eq "\\") {
4349 $chr =~ tr/\\[]//d;
4350 if ($arg->name =~ /^s?refgen$/ and
4351 !null($real = $arg->first) and
4352 ($chr =~ /\$/ && is_scalar($real->first)
4353 or ($chr =~ /@/
4354 && class($real->first->sibling) ne 'NULL'
4355 && $real->first->sibling->name
4356 =~ /^(rv2|pad)av$/)
4357 or ($chr =~ /%/
4358 && class($real->first->sibling) ne 'NULL'
4359 && $real->first->sibling->name
4360 =~ /^(rv2|pad)hv$/)
4361 #or ($chr =~ /&/ # This doesn't work
4362 # && $real->first->name eq "rv2cv")
4363 or ($chr =~ /\*/
4364 && $real->first->name eq "rv2gv")))
4365 {
4366 push @reals, $self->deparse($real, 6);
4367 } else {
4368 return "&";
4369 }
4370 }
4371 }
4372 }
4373 return "&" if $proto and !$doneok; # too few args and no ';'
4374 return "&" if @args; # too many args
4375 return ("", join ", ", @reals);
4376}
4377
4378sub retscalar {
4379 my $name = $_[0]->name;
4380 # XXX There has to be a better way of doing this scalar-op check.
4381 # Currently PL_opargs is not exposed.
4382 if ($name eq 'null') {
4383 $name = substr B::ppname($_[0]->targ), 3
4384 }
4385 $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv
4386 |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless
4387 |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans
4388 |transr|sassign|chop|schop|chomp|schomp|defined|undef
4389 |study|pos|preinc|i_preinc|predec|i_predec|postinc
4390 |i_postinc|postdec|i_postdec|pow|multiply|i_multiply
4391 |divide|i_divide|modulo|i_modulo|add|i_add|subtract
4392 |i_subtract|concat|stringify|left_shift|right_shift|lt
4393 |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp
4394 |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate
4395 |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos
4396 |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr
4397 |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst
4398 |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem
4399 |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor
4400 |andassign|orassign|dorassign|warn|die|reset|nextstate
4401 |dbstate|unstack|last|next|redo|dump|goto|exit|open|close
4402 |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen
4403 |dbmclose|select|getc|read|enterwrite|prtf|print|say
4404 |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate
4405 |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect
4406 |listen|accept|shutdown|gsockopt|ssockopt|getsockname
4407 |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite
4408 |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned
4409 |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe
4410 |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir
4411 |chown|chroot|unlink|chmod|utime|rename|link|symlink
4412 |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir
4413 |closedir|fork|wait|waitpid|system|exec|kill|getppid
4414 |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep
4415 |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd
4416 |msgrcv|semop|semget|semctl|hintseval|shostent|snetent
4417 |sprotoent|sservent|ehostent|enetent|eprotoent|eservent
4418 |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv
4419 |fc)\z/x
4420}
4421
4422sub pp_entersub {
4423 my $self = shift;
4424 my($op, $cx) = @_;
4425 return $self->e_method($self->_method($op, $cx))
4426 unless null $op->first->sibling;
4427 my $prefix = "";
4428 my $amper = "";
4429 my($kid, @exprs);
4430 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
4431 $prefix = "do ";
4432 } elsif ($op->private & OPpENTERSUB_AMPER) {
4433 $amper = "&";
4434 }
4435 $kid = $op->first;
4436 $kid = $kid->first->sibling; # skip ex-list, pushmark
4437 for (; not null $kid->sibling; $kid = $kid->sibling) {
4438 push @exprs, $kid;
4439 }
4440 my $simple = 0;
4441 my $proto = undef;
4442 my $lexical;
4443 if (is_scope($kid)) {
4444 $amper = "&";
4445 $kid = "{" . $self->deparse($kid, 0) . "}";
4446 } elsif ($kid->first->name eq "gv") {
4447 my $gv = $self->gv_or_padgv($kid->first);
4448 my $cv;
4449 if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
4450 || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
4451 $proto = $cv->PV if $cv->FLAGS & SVf_POK;
4452 }
4453 $simple = 1; # only calls of named functions can be prototyped
4454 $kid = $self->deparse($kid, 24);
4455 my $fq;
4456 # Fully qualify any sub name that conflicts with a lexical.
4457 if ($self->lex_in_scope("&$kid")
4458 || $self->lex_in_scope("&$kid", 1))
4459 {
4460 $fq++;
4461 } elsif (!$amper) {
4462 if ($kid eq 'main::') {
4463 $kid = '::';
4464 }
4465 else {
4466 if ($kid !~ /::/ && $kid ne 'x') {
4467 # Fully qualify any sub name that is also a keyword. While
4468 # we could check the import flag, we cannot guarantee that
4469 # the code deparsed so far would set that flag, so we qual-
4470 # ify the names regardless of importation.
4471 if (exists $feature_keywords{$kid}) {
4472 $fq++ if $self->feature_enabled($kid);
4473 } elsif (do { local $@; local $SIG{__DIE__};
4474 eval { () = prototype "CORE::$kid"; 1 } }) {
4475 $fq++
4476 }
4477 }
4478 if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
4479 $kid = single_delim("q", "'", $kid, $self) . '->';
4480 }
4481 }
4482 }
4483 $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::';
4484 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
4485 $amper = "&";
4486 $kid = $self->deparse($kid, 24);
4487 } else {
4488 $prefix = "";
4489 my $grandkid = $kid->first;
4490 my $arrow = ($lexical = $grandkid->name eq "padcv")
4491 || is_subscriptable($grandkid)
4492 ? ""
4493 : "->";
4494 $kid = $self->deparse($kid, 24) . $arrow;
4495 if ($lexical) {
4496 my $padlist = $self->{'curcv'}->PADLIST;
4497 my $padoff = $grandkid->targ;
4498 my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff);
4499 my $protocv = $padname->FLAGS & SVpad_STATE
4500 ? $padlist->ARRAYelt(1)->ARRAYelt($padoff)
4501 : $padname->PROTOCV;
4502 if ($protocv->FLAGS & SVf_POK) {
4503 $proto = $protocv->PV
4504 }
4505 $simple = 1;
4506 }
4507 }
4508
4509 # Doesn't matter how many prototypes there are, if
4510 # they haven't happened yet!
4511 my $declared = $lexical || exists $self->{'subs_declared'}{$kid};
4512 if (not $declared and $self->{'in_coderef2text'}) {
4513219µs233µs
# spent 20µs (8+13) within B::Deparse::BEGIN@4513 which was called: # once (8µs+13µs) by YAML::XS::BEGIN@57 at line 4513
no strict 'refs';
# spent 20µs making 1 call to B::Deparse::BEGIN@4513 # spent 12µs making 1 call to strict::unimport
45142339µs229µs
# spent 18µs (6+11) within B::Deparse::BEGIN@4514 which was called: # once (6µs+11µs) by YAML::XS::BEGIN@57 at line 4514
no warnings 'uninitialized';
# spent 18µs making 1 call to B::Deparse::BEGIN@4514 # spent 12µs making 1 call to warnings::unimport
4515 $declared =
4516 (
4517 defined &{ ${$self->{'curstash'}."::"}{$kid} }
4518 && !exists
4519 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
4520 && defined prototype $self->{'curstash'}."::".$kid
4521 );
4522 }
4523 if (!$declared && defined($proto)) {
4524 # Avoid "too early to check prototype" warning
4525 ($amper, $proto) = ('&');
4526 }
4527
4528 my $args;
4529 my $listargs = 1;
4530 if ($declared and defined $proto and not $amper) {
4531 ($amper, $args) = $self->check_proto($proto, @exprs);
4532 $listargs = $amper;
4533 }
4534 if ($listargs) {
4535 $args = join(", ", map(
4536 ($_->flags & OPf_WANT) == OPf_WANT_SCALAR
4537 && !retscalar($_)
4538 ? $self->maybe_parens_unop('scalar', $_, 6)
4539 : $self->deparse($_, 6),
4540 @exprs
4541 ));
4542 }
4543 if ($prefix or $amper) {
4544 if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as &&
4545 if ($op->flags & OPf_STACKED) {
4546 return $prefix . $amper . $kid . "(" . $args . ")";
4547 } else {
4548 return $prefix . $amper. $kid;
4549 }
4550 } else {
4551 # It's a syntax error to call CORE::GLOBAL::foo with a prefix,
4552 # so it must have been translated from a keyword call. Translate
4553 # it back.
4554 $kid =~ s/^CORE::GLOBAL:://;
4555
4556 my $dproto = defined($proto) ? $proto : "undefined";
4557 my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/;
4558 if (!$declared) {
4559 return "$kid(" . $args . ")";
4560 } elsif ($dproto =~ /^\s*\z/) {
4561 return $kid;
4562 } elsif ($scalar_proto and is_scalar($exprs[0])) {
4563 # is_scalar is an excessively conservative test here:
4564 # really, we should be comparing to the precedence of the
4565 # top operator of $exprs[0] (ala unop()), but that would
4566 # take some major code restructuring to do right.
4567 return $self->maybe_parens_func($kid, $args, $cx, 16);
4568 } elsif (not $scalar_proto and defined($proto) || $simple) { #'
4569 return $self->maybe_parens_func($kid, $args, $cx, 5);
4570 } else {
4571 return "$kid(" . $args . ")";
4572 }
4573 }
4574}
4575
4576sub pp_enterwrite { unop(@_, "write") }
4577
4578# escape things that cause interpolation in double quotes,
4579# but not character escapes
4580sub uninterp {
4581 my($str) = @_;
4582 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
4583 return $str;
4584}
4585
4586{
45871100nsmy $bal;
4588
# spent 12µs (9+3) within B::Deparse::BEGIN@4588 which was called: # once (9µs+3µs) by YAML::XS::BEGIN@57 at line 4599
BEGIN {
4589253µs239µs
# spent 23µs (7+16) within B::Deparse::BEGIN@4589 which was called: # once (7µs+16µs) by YAML::XS::BEGIN@57 at line 4589
use re "eval";
# spent 23µs making 1 call to B::Deparse::BEGIN@4589 # spent 16µs making 1 call to re::import
4590 # Matches any string which is balanced with respect to {braces}
4591 $bal = qr(
4592 (?:
4593 [^\\{}]
4594 | \\\\
4595 | \\[{}]
4596 | \{(??{$bal})\}
4597 )*
4598110µs13µs )x;
# spent 3µs making 1 call to B::Deparse::CORE:qr
45991446µs112µs}
# spent 12µs making 1 call to B::Deparse::BEGIN@4588
4600
4601# the same, but treat $|, $), $( and $ at the end of the string differently
4602# and leave comments unmangled for the sake of /x and (?x).
4603sub re_uninterp {
4604 my($str) = @_;
4605
4606 $str =~ s/
4607 ( ^|\G # $1
4608 | [^\\]
4609 )
4610
4611 ( # $2
4612 (?:\\\\)*
4613 )
4614
4615 ( # $3
4616 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
4617 | \#[^\n]* # (skip over comments)
4618 )
4619 | [\$\@]
4620 (?!\||\)|\(|$|\s)
4621 | \\[uUlLQE]
4622 )
4623
4624 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
4625
4626 return $str;
4627}
4628}
4629
4630# character escapes, but not delimiters that might need to be escaped
46311100nssub escape_str { # ASCII, UTF8
4632 my($str) = @_;
4633 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4634 $str =~ s/\a/\\a/g;
4635# $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH
4636 # isn't a backspace in EBCDIC
4637 $str =~ s/\t/\\t/g;
4638 $str =~ s/\n/\\n/g;
4639 $str =~ s/\e/\\e/g;
4640 $str =~ s/\f/\\f/g;
4641 $str =~ s/\r/\\r/g;
4642 $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge;
4643 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age;
4644 return $str;
4645}
4646
4647# For regexes. Leave whitespace unmangled in case of /x or (?x).
4648sub escape_re {
4649 my($str) = @_;
4650 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
4651 $str =~ s/([[:^print:]])/
4652 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age;
4653 $str =~ s/\n/\n\f/g;
4654 return $str;
4655}
4656
4657# Don't do this for regexen
4658sub unback {
4659 my($str) = @_;
4660 $str =~ s/\\/\\\\/g;
4661 return $str;
4662}
4663
4664# Remove backslashes which precede literal control characters,
4665# to avoid creating ambiguity when we escape the latter.
4666sub re_unback {
4667 my($str) = @_;
4668
4669 # the insane complexity here is due to the behaviour of "\c\"
4670 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
4671 return $str;
4672}
4673
4674sub balanced_delim {
4675 my($str) = @_;
4676 my @str = split //, $str;
4677 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
4678 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
4679 ($open, $close) = @$ar;
4680 $fail = 0; $cnt = 0; $last_bs = 0;
4681 for $c (@str) {
4682 if ($c eq $open) {
4683 $fail = 1 if $last_bs;
4684 $cnt++;
4685 } elsif ($c eq $close) {
4686 $fail = 1 if $last_bs;
4687 $cnt--;
4688 if ($cnt < 0) {
4689 # qq()() isn't ")("
4690 $fail = 1;
4691 last;
4692 }
4693 }
4694 $last_bs = $c eq '\\';
4695 }
4696 $fail = 1 if $cnt != 0;
4697 return ($open, "$open$str$close") if not $fail;
4698 }
4699 return ("", $str);
4700}
4701
4702sub single_delim {
4703 my($q, $default, $str, $self) = @_;
4704 return "$default$str$default" if $default and index($str, $default) == -1;
4705 my $coreq = $self->keyword($q); # maybe CORE::q
4706 if ($q ne 'qr') {
4707 (my $succeed, $str) = balanced_delim($str);
4708 return "$coreq$str" if $succeed;
4709 }
4710 for my $delim ('/', '"', '#') {
4711 return "$coreq$delim" . $str . $delim if index($str, $delim) == -1;
4712 }
4713 if ($default) {
4714 $str =~ s/$default/\\$default/g;
4715 return "$default$str$default";
4716 } else {
4717 $str =~ s[/][\\/]g;
4718 return "$coreq/$str/";
4719 }
4720}
4721
472210smy $max_prec;
47231317µs25µs
# spent 3µs within B::Deparse::BEGIN@4723 which was called: # once (3µs+0s) by YAML::XS::BEGIN@57 at line 4723
BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
# spent 3µs making 1 call to B::Deparse::BEGIN@4723 # spent 2µs making 1 call to main::CORE:pack
4724
4725# Split a floating point number into an integer mantissa and a binary
4726# exponent. Assumes you've already made sure the number isn't zero or
4727# some weird infinity or NaN.
4728sub split_float {
4729 my($f) = @_;
4730 my $exponent = 0;
4731 if ($f == int($f)) {
4732 while ($f % 2 == 0) {
4733 $f /= 2;
4734 $exponent++;
4735 }
4736 } else {
4737 while ($f != int($f)) {
4738 $f *= 2;
4739 $exponent--;
4740 }
4741 }
4742 my $mantissa = sprintf("%.0f", $f);
4743 return ($mantissa, $exponent);
4744}
4745
4746sub const {
4747 my $self = shift;
4748 my($sv, $cx) = @_;
4749 if ($self->{'use_dumper'}) {
4750 return $self->const_dumper($sv, $cx);
4751 }
4752 if (class($sv) eq "SPECIAL") {
4753 # sv_undef, sv_yes, sv_no
4754 return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21)
4755 : ('undef', '1')[$$sv-1];
4756 }
4757 if (class($sv) eq "NULL") {
4758 return 'undef';
4759 }
4760 # convert a version object into the "v1.2.3" string in its V magic
4761 if ($sv->FLAGS & SVs_RMG) {
4762 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4763 return $mg->PTR if $mg->TYPE eq 'V';
4764 }
4765 }
4766
4767 if ($sv->FLAGS & SVf_IOK) {
4768 my $str = $sv->int_value;
4769 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
4770 return $str;
4771 } elsif ($sv->FLAGS & SVf_NOK) {
4772 my $nv = $sv->NV;
4773 if ($nv == 0) {
47741800ns if (pack("F", $nv) eq pack("F", 0)) {
# spent 800ns making 1 call to main::CORE:pack
4775 # positive zero
4776 return "0";
4777 } else {
4778 # negative zero
4779 return $self->maybe_parens("-.0", $cx, 21);
4780 }
4781 } elsif (1/$nv == 0) {
4782 if ($nv > 0) {
4783 # positive infinity
4784 return $self->maybe_parens("9**9**9", $cx, 22);
4785 } else {
4786 # negative infinity
4787 return $self->maybe_parens("-9**9**9", $cx, 21);
4788 }
4789 } elsif ($nv != $nv) {
4790 # NaN
47911600ns if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
# spent 600ns making 1 call to main::CORE:pack
4792 # the normal kind
4793 return "sin(9**9**9)";
47941300ns } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
# spent 300ns making 1 call to main::CORE:pack
4795 # the inverted kind
4796 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
4797 } else {
4798 # some other kind
4799 my $hex = unpack("h*", pack("F", $nv));
4800 return qq'unpack("F", pack("h*", "$hex"))';
4801 }
4802 }
4803 # first, try the default stringification
4804 my $str = "$nv";
4805 if ($str != $nv) {
4806 # failing that, try using more precision
4807 $str = sprintf("%.${max_prec}g", $nv);
4808# if (pack("F", $str) ne pack("F", $nv)) {
4809 if ($str != $nv) {
4810 # not representable in decimal with whatever sprintf()
4811 # and atof() Perl is using here.
4812 my($mant, $exp) = split_float($nv);
4813 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
4814 }
4815 }
4816 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
4817 return $str;
4818 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
4819 my $ref = $sv->RV;
4820 my $class = class($ref);
4821 if ($class eq "AV") {
4822 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
4823 } elsif ($class eq "HV") {
4824 my %hash = $ref->ARRAY;
4825 my @elts;
4826 for my $k (sort keys %hash) {
4827 push @elts, "$k => " . $self->const($hash{$k}, 6);
4828 }
4829 return "{" . join(", ", @elts) . "}";
4830 } elsif ($class eq "CV") {
4831
# spent 16µs (9+7) within B::Deparse::BEGIN@4831 which was called: # once (9µs+7µs) by YAML::XS::BEGIN@57 at line 4836
BEGIN {
483213µs if ($] > 5.0150051) {
48331400ns require overloading;
483412µs17µs unimport overloading;
# spent 7µs making 1 call to overloading::unimport
4835 }
483613.37ms116µs }
# spent 16µs making 1 call to B::Deparse::BEGIN@4831
4837 if ($] > 5.0150051 && $self->{curcv} &&
4838 $self->{curcv}->object_2svref == $ref->object_2svref) {
4839 return $self->keyword("__SUB__");
4840 }
4841 return "sub " . $self->deparse_sub($ref);
4842 }
4843 if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) {
4844 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
4845 if ($mg->TYPE eq 'r') {
4846 my $re = re_uninterp(escape_re(re_unback($mg->precomp)));
4847 return single_delim("qr", "", $re, $self);
4848 }
4849 }
4850 }
4851
4852 my $const = $self->const($ref, 20);
4853 if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
4854 $const = "($const)";
4855 }
4856 return $self->maybe_parens("\\$const", $cx, 20);
4857 } elsif ($sv->FLAGS & SVf_POK) {
4858 my $str = $sv->PV;
4859 if ($str =~ /[[:^print:]]/a) {
4860 return single_delim("qq", '"',
4861 uninterp(escape_str unback $str), $self);
4862 } else {
4863 return single_delim("q", "'", unback($str), $self);
4864 }
4865 } else {
4866 return "undef";
4867 }
4868}
4869
4870sub const_dumper {
4871 my $self = shift;
4872 my($sv, $cx) = @_;
4873 my $ref = $sv->object_2svref();
4874 my $dumper = Data::Dumper->new([$$ref], ['$v']);
4875 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
4876 my $str = $dumper->Dump();
4877 if ($str =~ /^\$v/) {
4878 return '${my ' . $str . ' \$v}';
4879 } else {
4880 return $str;
4881 }
4882}
4883
4884sub const_sv {
4885 my $self = shift;
4886 my $op = shift;
4887 my $sv = $op->sv;
4888 # the constant could be in the pad (under useithreads)
4889 $sv = $self->padval($op->targ) unless $$sv;
4890 return $sv;
4891}
4892
4893sub meth_sv {
4894 my $self = shift;
4895 my $op = shift;
4896 my $sv = $op->meth_sv;
4897 # the constant could be in the pad (under useithreads)
4898 $sv = $self->padval($op->targ) unless $$sv;
4899 return $sv;
4900}
4901
4902sub meth_rclass_sv {
4903 my $self = shift;
4904 my $op = shift;
4905 my $sv = $op->rclass;
4906 # the constant could be in the pad (under useithreads)
4907 $sv = $self->padval($sv) unless ref $sv;
4908 return $sv;
4909}
4910
4911sub pp_const {
4912 my $self = shift;
4913 my($op, $cx) = @_;
4914 if ($op->private & OPpCONST_ARYBASE) {
4915 return '$[';
4916 }
4917# if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
4918# return $self->const_sv($op)->PV;
4919# }
4920 my $sv = $self->const_sv($op);
4921 return $self->const($sv, $cx);
4922}
4923
4924sub dq {
4925 my $self = shift;
4926 my $op = shift;
4927 my $type = $op->name;
4928 if ($type eq "const") {
4929 return '$[' if $op->private & OPpCONST_ARYBASE;
4930 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
4931 } elsif ($type eq "concat") {
4932 my $first = $self->dq($op->first);
4933 my $last = $self->dq($op->last);
4934
4935 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
4936 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4937 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4938 || ($last =~ /^[:'{\[\w_]/ && #'
4939 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4940
4941 return $first . $last;
4942 } elsif ($type eq "uc") {
4943 return '\U' . $self->dq($op->first->sibling) . '\E';
4944 } elsif ($type eq "lc") {
4945 return '\L' . $self->dq($op->first->sibling) . '\E';
4946 } elsif ($type eq "ucfirst") {
4947 return '\u' . $self->dq($op->first->sibling);
4948 } elsif ($type eq "lcfirst") {
4949 return '\l' . $self->dq($op->first->sibling);
4950 } elsif ($type eq "quotemeta") {
4951 return '\Q' . $self->dq($op->first->sibling) . '\E';
4952 } elsif ($type eq "fc") {
4953 return '\F' . $self->dq($op->first->sibling) . '\E';
4954 } elsif ($type eq "join") {
4955 return $self->deparse($op->last, 26); # was join($", @ary)
4956 } else {
4957 return $self->deparse($op, 26);
4958 }
4959}
4960
4961sub pp_backtick {
4962 my $self = shift;
4963 my($op, $cx) = @_;
4964 # skip pushmark if it exists (readpipe() vs ``)
4965 my $child = $op->first->sibling->isa('B::NULL')
4966 ? $op->first : $op->first->sibling;
4967 if ($self->pure_string($child)) {
4968 return single_delim("qx", '`', $self->dq($child, 1), $self);
4969 }
4970 unop($self, @_, "readpipe");
4971}
4972
4973sub dquote {
4974 my $self = shift;
4975 my($op, $cx) = @_;
4976 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
4977 return $self->deparse($kid, $cx) if $self->{'unquote'};
4978 $self->maybe_targmy($kid, $cx,
4979 sub {single_delim("qq", '"', $self->dq($_[1]),
4980 $self)});
4981}
4982
4983# OP_STRINGIFY is a listop, but it only ever has one arg
4984sub pp_stringify {
4985 my ($self, $op, $cx) = @_;
4986 my $kid = $op->first->sibling;
4987 while ($kid->name eq 'null' && !null($kid->first)) {
4988 $kid = $kid->first;
4989 }
4990 if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref
4991 |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) {
4992 maybe_targmy(@_, \&dquote);
4993 }
4994 else {
4995 # Actually an optimised join.
4996 my $result = listop(@_,"join");
4997 $result =~ s/join([( ])/join$1$self->{'ex_const'}, /;
4998 $result;
4999 }
5000}
5001
5002# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
5003# note that tr(from)/to/ is OK, but not tr/from/(to)
5004sub double_delim {
5005 my($from, $to) = @_;
5006 my($succeed, $delim);
5007 if ($from !~ m[/] and $to !~ m[/]) {
5008 return "/$from/$to/";
5009 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
5010 if (($succeed, $to) = balanced_delim($to) and $succeed) {
5011 return "$from$to";
5012 } else {
5013 for $delim ('/', '"', '#') { # note no "'" -- s''' is special
5014 return "$from$delim$to$delim" if index($to, $delim) == -1;
5015 }
5016 $to =~ s[/][\\/]g;
5017 return "$from/$to/";
5018 }
5019 } else {
5020 for $delim ('/', '"', '#') { # note no '
5021 return "$delim$from$delim$to$delim"
5022 if index($to . $from, $delim) == -1;
5023 }
5024 $from =~ s[/][\\/]g;
5025 $to =~ s[/][\\/]g;
5026 return "/$from/$to/";
5027 }
5028}
5029
5030# Only used by tr///, so backslashes hyphens
5031sub pchr { # ASCII
5032 my($n) = @_;
5033 if ($n == ord '\\') {
5034 return '\\\\';
5035 } elsif ($n == ord "-") {
5036 return "\\-";
5037 } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' '))
5038 and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~')))
5039 {
5040 # I'm presuming a regex is not ok here, otherwise we could have used
5041 # /[[:print:]]/a to get here
5042 return chr($n);
5043 } elsif ($n == ord "\a") {
5044 return '\\a';
5045 } elsif ($n == ord "\b") {
5046 return '\\b';
5047 } elsif ($n == ord "\t") {
5048 return '\\t';
5049 } elsif ($n == ord "\n") {
5050 return '\\n';
5051 } elsif ($n == ord "\e") {
5052 return '\\e';
5053 } elsif ($n == ord "\f") {
5054 return '\\f';
5055 } elsif ($n == ord "\r") {
5056 return '\\r';
5057 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
5058 return '\\c' . unctrl{chr $n};
5059 } else {
5060# return '\x' . sprintf("%02x", $n);
5061 return '\\' . sprintf("%03o", $n);
5062 }
5063}
5064
5065sub collapse {
5066 my(@chars) = @_;
5067 my($str, $c, $tr) = ("");
5068 for ($c = 0; $c < @chars; $c++) {
5069 $tr = $chars[$c];
5070 $str .= pchr($tr);
5071 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
5072 $chars[$c + 2] == $tr + 2)
5073 {
5074 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
5075 {}
5076 $str .= "-";
5077 $str .= pchr($chars[$c]);
5078 }
5079 }
5080 return $str;
5081}
5082
5083sub tr_decode_byte {
5084 my($table, $flags) = @_;
5085 my(@table) = unpack("s*", $table);
5086 splice @table, 0x100, 1; # Number of subsequent elements
5087 my($c, $tr, @from, @to, @delfrom, $delhyphen);
5088 if ($table[ord "-"] != -1 and
5089 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
5090 {
5091 $tr = $table[ord "-"];
5092 $table[ord "-"] = -1;
5093 if ($tr >= 0) {
5094 @from = ord("-");
5095 @to = $tr;
5096 } else { # -2 ==> delete
5097 $delhyphen = 1;
5098 }
5099 }
5100 for ($c = 0; $c < @table; $c++) {
5101 $tr = $table[$c];
5102 if ($tr >= 0) {
5103 push @from, $c; push @to, $tr;
5104 } elsif ($tr == -2) {
5105 push @delfrom, $c;
5106 }
5107 }
5108 @from = (@from, @delfrom);
5109 if ($flags & OPpTRANS_COMPLEMENT) {
5110 my @newfrom = ();
5111 my %from;
5112 @from{@from} = (1) x @from;
5113 for ($c = 0; $c < 256; $c++) {
5114 push @newfrom, $c unless $from{$c};
5115 }
5116 @from = @newfrom;
5117 }
5118 unless ($flags & OPpTRANS_DELETE || !@to) {
5119 pop @to while $#to and $to[$#to] == $to[$#to -1];
5120 }
5121 my($from, $to);
5122 $from = collapse(@from);
5123 $to = collapse(@to);
5124 $from .= "-" if $delhyphen;
5125 return ($from, $to);
5126}
5127
5128sub tr_chr {
5129 my $x = shift;
5130 if ($x == ord "-") {
5131 return "\\-";
5132 } elsif ($x == ord "\\") {
5133 return "\\\\";
5134 } else {
5135 return chr $x;
5136 }
5137}
5138
5139# XXX This doesn't yet handle all cases correctly either
5140
5141sub tr_decode_utf8 {
5142 my($swash_hv, $flags) = @_;
5143 my %swash = $swash_hv->ARRAY;
5144 my $final = undef;
5145 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
5146 my $none = $swash{"NONE"}->IV;
5147 my $extra = $none + 1;
5148 my(@from, @delfrom, @to);
5149 my $line;
5150 foreach $line (split /\n/, $swash{'LIST'}->PV) {
5151 my($min, $max, $result) = split(/\t/, $line);
5152 $min = hex $min;
5153 if (length $max) {
5154 $max = hex $max;
5155 } else {
5156 $max = $min;
5157 }
5158 $result = hex $result;
5159 if ($result == $extra) {
5160 push @delfrom, [$min, $max];
5161 } else {
5162 push @from, [$min, $max];
5163 push @to, [$result, $result + $max - $min];
5164 }
5165 }
5166 for my $i (0 .. $#from) {
5167 if ($from[$i][0] == ord '-') {
5168 unshift @from, splice(@from, $i, 1);
5169 unshift @to, splice(@to, $i, 1);
5170 last;
5171 } elsif ($from[$i][1] == ord '-') {
5172 $from[$i][1]--;
5173 $to[$i][1]--;
5174 unshift @from, ord '-';
5175 unshift @to, ord '-';
5176 last;
5177 }
5178 }
5179 for my $i (0 .. $#delfrom) {
5180 if ($delfrom[$i][0] == ord '-') {
5181 push @delfrom, splice(@delfrom, $i, 1);
5182 last;
5183 } elsif ($delfrom[$i][1] == ord '-') {
5184 $delfrom[$i][1]--;
5185 push @delfrom, ord '-';
5186 last;
5187 }
5188 }
5189 if (defined $final and $to[$#to][1] != $final) {
5190 push @to, [$final, $final];
5191 }
5192 push @from, @delfrom;
5193 if ($flags & OPpTRANS_COMPLEMENT) {
5194 my @newfrom;
5195 my $next = 0;
5196 for my $i (0 .. $#from) {
5197 push @newfrom, [$next, $from[$i][0] - 1];
5198 $next = $from[$i][1] + 1;
5199 }
5200 @from = ();
5201 for my $range (@newfrom) {
5202 if ($range->[0] <= $range->[1]) {
5203 push @from, $range;
5204 }
5205 }
5206 }
5207 my($from, $to, $diff);
5208 for my $chunk (@from) {
5209 $diff = $chunk->[1] - $chunk->[0];
5210 if ($diff > 1) {
5211 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
5212 } elsif ($diff == 1) {
5213 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
5214 } else {
5215 $from .= tr_chr($chunk->[0]);
5216 }
5217 }
5218 for my $chunk (@to) {
5219 $diff = $chunk->[1] - $chunk->[0];
5220 if ($diff > 1) {
5221 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
5222 } elsif ($diff == 1) {
5223 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
5224 } else {
5225 $to .= tr_chr($chunk->[0]);
5226 }
5227 }
5228 #$final = sprintf("%04x", $final) if defined $final;
5229 #$none = sprintf("%04x", $none) if defined $none;
5230 #$extra = sprintf("%04x", $extra) if defined $extra;
5231 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
5232 #print STDERR $swash{'LIST'}->PV;
5233 return (escape_str($from), escape_str($to));
5234}
5235
5236sub pp_trans {
5237 my $self = shift;
5238 my($op, $cx, $morflags) = @_;
5239 my($from, $to);
5240 my $class = class($op);
5241 my $priv_flags = $op->private;
5242 if ($class eq "PVOP") {
5243 ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
5244 } elsif ($class eq "PADOP") {
5245 ($from, $to)
5246 = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
5247 } else { # class($op) eq "SVOP"
5248 ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
5249 }
5250 my $flags = "";
5251 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
5252 $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
5253 $to = "" if $from eq $to and $flags eq "";
5254 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
5255 $flags .= $morflags if defined $morflags;
5256 my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
5257 if (my $targ = $op->targ) {
5258 return $self->maybe_parens($self->padname($targ) . " =~ $ret",
5259 $cx, 20);
5260 }
5261 return $ret;
5262}
5263
5264sub pp_transr { push @_, 'r'; goto &pp_trans }
5265
5266sub re_dq_disambiguate {
5267 my ($first, $last) = @_;
5268 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
5269 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
5270 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
5271 || ($last =~ /^[{\[\w_]/ &&
5272 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
5273 return $first . $last;
5274}
5275
5276# Like dq(), but different
5277sub re_dq {
5278 my $self = shift;
5279 my ($op) = @_;
5280
5281 my $type = $op->name;
5282 if ($type eq "const") {
5283 return '$[' if $op->private & OPpCONST_ARYBASE;
5284 my $unbacked = re_unback($self->const_sv($op)->as_string);
5285 return re_uninterp(escape_re($unbacked));
5286 } elsif ($type eq "concat") {
5287 my $first = $self->re_dq($op->first);
5288 my $last = $self->re_dq($op->last);
5289 return re_dq_disambiguate($first, $last);
5290 } elsif ($type eq "uc") {
5291 return '\U' . $self->re_dq($op->first->sibling) . '\E';
5292 } elsif ($type eq "lc") {
5293 return '\L' . $self->re_dq($op->first->sibling) . '\E';
5294 } elsif ($type eq "ucfirst") {
5295 return '\u' . $self->re_dq($op->first->sibling);
5296 } elsif ($type eq "lcfirst") {
5297 return '\l' . $self->re_dq($op->first->sibling);
5298 } elsif ($type eq "quotemeta") {
5299 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
5300 } elsif ($type eq "fc") {
5301 return '\F' . $self->re_dq($op->first->sibling) . '\E';
5302 } elsif ($type eq "join") {
5303 return $self->deparse($op->last, 26); # was join($", @ary)
5304 } else {
5305 my $ret = $self->deparse($op, 26);
5306 $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces
5307 or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces
5308 return $ret;
5309 }
5310}
5311
5312sub pure_string {
5313 my ($self, $op) = @_;
5314 return 0 if null $op;
5315 my $type = $op->name;
5316
5317 if ($type eq 'const' || $type eq 'av2arylen') {
5318 return 1;
5319 }
5320 elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') {
5321 return $self->pure_string($op->first->sibling);
5322 }
5323 elsif ($type eq 'join') {
5324 my $join_op = $op->first->sibling; # Skip pushmark
5325 return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
5326
5327 my $gvop = $join_op->first;
5328 return 0 unless $gvop->name eq 'gvsv';
5329 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
5330
5331 return 0 unless ${$join_op->sibling} eq ${$op->last};
5332 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
5333 }
5334 elsif ($type eq 'concat') {
5335 return $self->pure_string($op->first)
5336 && $self->pure_string($op->last);
5337 }
5338 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
5339 return 1;
5340 }
5341 elsif ($type eq "null" and $op->can('first') and not null $op->first) {
5342 my $first = $op->first;
5343
5344 return 1 if $first->name eq "multideref";
5345 return 1 if $first->name eq "aelemfast_lex";
5346
5347 if ( $first->name eq "null"
5348 and $first->can('first')
5349 and not null $first->first
5350 and $first->first->name eq "aelemfast"
5351 )
5352 {
5353 return 1;
5354 }
5355 }
5356
5357 return 0;
5358}
5359
5360sub code_list {
5361 my ($self,$op,$cv) = @_;
5362
5363 # localise stuff relating to the current sub
5364 $cv and
5365 local($self->{'curcv'}) = $cv,
5366 local($self->{'curcvlex'}),
5367 local(@$self{qw'curstash warnings hints hinthash curcop'})
5368 = @$self{qw'curstash warnings hints hinthash curcop'};
5369
5370 my $re;
5371 for ($op = $op->first->sibling; !null($op); $op = $op->sibling) {
5372 if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) {
5373 my $scope = $op->first;
5374 # 0 context (last arg to scopeop) means statement context, so
5375 # the contents of the block will not be wrapped in do{...}.
5376 my $block = scopeop($scope->first->name eq "enter", $self,
5377 $scope, 0);
5378 # next op is the source code of the block
5379 $op = $op->sibling;
5380 $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0];
5381 my $multiline = $block =~ /\n/;
5382 $re .= $multiline ? "\n\t" : ' ';
5383 $re .= $block;
5384 $re .= $multiline ? "\n\b})" : " })";
5385 } else {
5386 $re = re_dq_disambiguate($re, $self->re_dq($op));
5387 }
5388 }
5389 $re;
5390}
5391
5392sub regcomp {
5393 my $self = shift;
5394 my($op, $cx) = @_;
5395 my $kid = $op->first;
5396 $kid = $kid->first if $kid->name eq "regcmaybe";
5397 $kid = $kid->first if $kid->name eq "regcreset";
5398 my $kname = $kid->name;
5399 if ($kname eq "null" and !null($kid->first)
5400 and $kid->first->name eq 'pushmark')
5401 {
5402 my $str = '';
5403 $kid = $kid->first->sibling;
5404 while (!null($kid)) {
5405 my $first = $str;
5406 my $last = $self->re_dq($kid);
5407 $str = re_dq_disambiguate($first, $last);
5408 $kid = $kid->sibling;
5409 }
5410 return $str, 1;
5411 }
5412
5413 return ($self->re_dq($kid), 1)
5414 if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid);
5415 return ($self->deparse($kid, $cx), 0);
5416}
5417
5418sub pp_regcomp {
5419 my ($self, $op, $cx) = @_;
5420 return (($self->regcomp($op, $cx, 0))[0]);
5421}
5422
5423sub re_flags {
5424 my ($self, $op) = @_;
5425 my $flags = '';
5426 my $pmflags = $op->pmflags;
5427 if (!$pmflags) {
5428 my $re = $op->pmregexp;
5429 if ($$re) {
5430 $pmflags = $re->compflags;
5431 }
5432 }
5433 $flags .= "g" if $pmflags & PMf_GLOBAL;
5434 $flags .= "i" if $pmflags & PMf_FOLD;
5435 $flags .= "m" if $pmflags & PMf_MULTILINE;
5436 $flags .= "o" if $pmflags & PMf_KEEP;
5437 $flags .= "s" if $pmflags & PMf_SINGLELINE;
5438 $flags .= "x" if $pmflags & PMf_EXTENDED;
5439 $flags .= "x" if $pmflags & PMf_EXTENDED_MORE;
5440 $flags .= "p" if $pmflags & RXf_PMf_KEEPCOPY;
5441 if (my $charset = $pmflags & RXf_PMf_CHARSET) {
5442 # Hardcoding this is fragile, but B does not yet export the
5443 # constants we need.
5444 $flags .= qw(d l u a aa)[$charset >> 7]
5445 }
5446 # The /d flag is indicated by 0; only show it if necessary.
5447 elsif ($self->{hinthash} and
5448 $self->{hinthash}{reflags_charset}
5449 || $self->{hinthash}{feature_unicode}
5450 or $self->{hints} & $feature::hint_mask
5451 && ($self->{hints} & $feature::hint_mask)
5452 != $feature::hint_mask
5453 && do {
5454 $self->{hints} & $feature::hint_uni8bit;
5455 }
5456 ) {
5457 $flags .= 'd';
5458 }
5459 $flags;
5460}
5461
5462# osmic acid -- see osmium tetroxide
5463
5464my %matchwords;
5465140µs236µsmap($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
# spent 6µs making 23 calls to B::Deparse::CORE:sort, avg 248ns/call
5466 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
5467 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix');
5468
5469# When deparsing a regular expression with code blocks, we have to look in
5470# various places to find the blocks.
5471#
5472# For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv
5473# and the code list (list of blocks and constants, maybe vars) is under
5474# $cv->ROOT->first->code_list:
5475# ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref'
5476#
5477# For qr/$a(?{...})/ with interpolation, the code list is more accessible,
5478# under $pmop->code_list, but the $cv is something you have to dig for in
5479# the regcomp op’s kids:
5480# ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/'
5481#
5482# For m// and split //, things are much simpler. There is no CV. The code
5483# list is under $pmop->code_list.
5484
5485sub matchop {
5486 my $self = shift;
5487 my($op, $cx, $name, $delim) = @_;
5488 my $kid = $op->first;
5489 my ($binop, $var, $re) = ("", "", "");
5490 if ($op->flags & OPf_STACKED) {
5491 $binop = 1;
5492 $var = $self->deparse($kid, 20);
5493 $kid = $kid->sibling;
5494 }
5495 # not $name; $name will be 'm' for both match and split
5496 elsif ($op->name eq 'match' and my $targ = $op->targ) {
5497 $binop = 1;
5498 $var = $self->padname($targ);
5499 }
5500 my $quote = 1;
5501 my $pmflags = $op->pmflags;
5502 my $rhs_bound_to_defsv;
5503 my ($cv, $bregexp);
5504 my $have_kid = !null $kid;
5505 # Check for code blocks first
5506 if (not null my $code_list = $op->code_list) {
5507 $re = $self->code_list($code_list,
5508 $op->name eq 'qr'
5509 ? $self->padval(
5510 $kid->first # ex-list
5511 ->first # pushmark
5512 ->sibling # entersub
5513 ->first # ex-list
5514 ->first # pushmark
5515 ->sibling # srefgen
5516 ->first # ex-list
5517 ->first # anoncode
5518 ->targ
5519 )
5520 : undef);
5521 } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) {
5522 my $patop = $cv->ROOT # leavesub
5523 ->first # qr
5524 ->code_list;# list
5525 $re = $self->code_list($patop, $cv);
5526 } elsif (!$have_kid) {
5527 $re = re_uninterp(escape_re(re_unback($op->precomp)));
5528 } elsif ($kid->name ne 'regcomp') {
5529 carp("found ".$kid->name." where regcomp expected");
5530 } else {
5531 ($re, $quote) = $self->regcomp($kid, 21);
5532 }
5533 if ($have_kid and $kid->name eq 'regcomp') {
5534 my $matchop = $kid->first;
5535 if ($matchop->name eq 'regcreset') {
5536 $matchop = $matchop->first;
5537 }
5538 if ($matchop->name =~ /^(?:match|transr?|subst)\z/
5539 && $matchop->flags & OPf_SPECIAL) {
5540 $rhs_bound_to_defsv = 1;
5541 }
5542 }
5543 my $flags = "";
5544 $flags .= "c" if $pmflags & PMf_CONTINUE;
5545 $flags .= $self->re_flags($op);
5546 $flags = join '', sort split //, $flags;
5547 $flags = $matchwords{$flags} if $matchwords{$flags};
5548 if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here
5549 $re =~ s/\?/\\?/g;
5550 $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required
5551 } elsif ($quote) {
5552 $re = single_delim($name, $delim, $re, $self);
5553 }
5554 $re = $re . $flags if $quote;
5555 if ($binop) {
5556 return
5557 $self->maybe_parens(
5558 $rhs_bound_to_defsv
5559 ? "$var =~ (\$_ =~ $re)"
5560 : "$var =~ $re",
5561 $cx, 20
5562 );
5563 } else {
5564 return $re;
5565 }
5566}
5567
5568sub pp_match { matchop(@_, "m", "/") }
5569sub pp_pushre { matchop(@_, "m", "/") }
5570sub pp_qr { matchop(@_, "qr", "") }
5571
5572sub pp_runcv { unop(@_, "__SUB__"); }
5573
5574sub pp_split {
5575 maybe_targmy(@_, \&split);
5576}
5577sub split {
5578 my $self = shift;
5579 my($op, $cx) = @_;
5580 my($kid, @exprs, $ary, $expr);
5581 $kid = $op->first;
5582
5583 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
5584 # root of a replacement; it's either empty, or abused to point to
5585 # the GV for an array we split into (an optimization to save
5586 # assignment overhead). Depending on whether we're using ithreads,
5587 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
5588 # figures out for us which it is.
5589 my $replroot = $kid->pmreplroot;
5590 my $gv = 0;
5591 my $stacked = $op->flags & OPf_STACKED;
5592 if (ref($replroot) eq "B::GV") {
5593 $gv = $replroot;
5594 } elsif (!ref($replroot) and $replroot > 0) {
5595 $gv = $self->padval($replroot);
5596 } elsif ($kid->targ) {
5597 $ary = $self->padname($kid->targ)
5598 } elsif ($stacked) {
5599 $ary = $self->deparse($op->last, 7);
5600 }
5601 $ary = $self->maybe_local(@_,
5602 $self->stash_variable('@',
5603 $self->gv_name($gv),
5604 $cx))
5605 if $gv;
5606
5607 # Skip the last kid when OPf_STACKED is set, since it is the array
5608 # on the left.
5609 for (; !null($stacked ? $kid->sibling : $kid); $kid = $kid->sibling) {
5610 push @exprs, $self->deparse($kid, 6);
5611 }
5612
5613 # handle special case of split(), and split(' ') that compiles to /\s+/
5614 # Under 5.10, the reflags may be undef if the split regexp isn't a constant
5615 # Under 5.17.5-5.17.9, the special flag is on split itself.
5616 $kid = $op->first;
5617 if ( $op->flags & OPf_SPECIAL
5618 or (
5619 $kid->flags & OPf_SPECIAL
5620 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
5621 : ($kid->reflags || 0) & RXf_SKIPWHITE()
5622 )
5623 )
5624 ) {
5625 $exprs[0] = "' '";
5626 }
5627
5628 $expr = "split(" . join(", ", @exprs) . ")";
5629 if ($ary) {
5630 return $self->maybe_parens("$ary = $expr", $cx, 7);
5631 } else {
5632 return $expr;
5633 }
5634}
5635
5636# oxime -- any of various compounds obtained chiefly by the action of
5637# hydroxylamine on aldehydes and ketones and characterized by the
5638# bivalent grouping C=NOH [Webster's Tenth]
5639
564010smy %substwords;
5641161µs436µsmap($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
# spent 6µs making 43 calls to B::Deparse::CORE:sort, avg 147ns/call
5642 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
5643 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
5644 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue',
5645 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
5646 'or', 'rose', 'rosie');
5647
5648sub pp_subst {
5649 my $self = shift;
5650 my($op, $cx) = @_;
5651 my $kid = $op->first;
5652 my($binop, $var, $re, $repl) = ("", "", "", "");
5653 if ($op->flags & OPf_STACKED) {
5654 $binop = 1;
5655 $var = $self->deparse($kid, 20);
5656 $kid = $kid->sibling;
5657 }
5658 elsif (my $targ = $op->targ) {
5659 $binop = 1;
5660 $var = $self->padname($targ);
5661 }
5662 my $flags = "";
5663 my $pmflags = $op->pmflags;
5664 if (null($op->pmreplroot)) {
5665 $repl = $kid;
5666 $kid = $kid->sibling;
5667 } else {
5668 $repl = $op->pmreplroot->first; # skip substcont
5669 }
5670 while ($repl->name eq "entereval") {
5671 $repl = $repl->first;
5672 $flags .= "e";
5673 }
5674 {
5675 local $self->{in_subst_repl} = 1;
5676 if ($pmflags & PMf_EVAL) {
5677 $repl = $self->deparse($repl->first, 0);
5678 } else {
5679 $repl = $self->dq($repl);
5680 }
5681 }
5682 if (not null my $code_list = $op->code_list) {
5683 $re = $self->code_list($code_list);
5684 } elsif (null $kid) {
5685 $re = re_uninterp(escape_re(re_unback($op->precomp)));
5686 } else {
5687 ($re) = $self->regcomp($kid, 1);
5688 }
5689 $flags .= "r" if $pmflags & PMf_NONDESTRUCT;
5690 $flags .= "e" if $pmflags & PMf_EVAL;
5691 $flags .= $self->re_flags($op);
5692 $flags = join '', sort split //, $flags;
5693 $flags = $substwords{$flags} if $substwords{$flags};
5694 my $core_s = $self->keyword("s"); # maybe CORE::s
5695 if ($binop) {
5696 return $self->maybe_parens("$var =~ $core_s"
5697 . double_delim($re, $repl) . $flags,
5698 $cx, 20);
5699 } else {
5700 return "$core_s". double_delim($re, $repl) . $flags;
5701 }
5702}
5703
5704sub is_lexical_subs {
5705 my (@ops) = shift;
5706 for my $op (@ops) {
5707 return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
5708 }
5709 return 1;
5710}
5711
5712# Pretend these two ops do not exist. The perl parser adds them to the
5713# beginning of any block containing my-sub declarations, whereas we handle
5714# the subs in pad_subs and next_todo.
57151200ns*pp_clonecv = *pp_introcv;
5716sub pp_introcv {
5717 my $self = shift;
5718 my($op, $cx) = @_;
5719 # For now, deparsing doesn't worry about the distinction between introcv
5720 # and clonecv, so pretend this op doesn't exist:
5721 return '';
5722}
5723
5724sub pp_padcv {
5725 my $self = shift;
5726 my($op, $cx) = @_;
5727 return $self->padany($op);
5728}
5729
573012µsmy %lvref_funnies = (
5731 OPpLVREF_SV, => '$',
5732 OPpLVREF_AV, => '@',
5733 OPpLVREF_HV, => '%',
5734 OPpLVREF_CV, => '&',
5735);
5736
5737sub pp_refassign {
5738 my ($self, $op, $cx) = @_;
5739 my $left;
5740 if ($op->private & OPpLVREF_ELEM) {
5741 $left = $op->first->sibling;
5742 $left = maybe_local(@_, elem($self, $left, undef,
5743 $left->targ == OP_AELEM
5744 ? qw([ ] padav)
5745 : qw({ } padhv)));
5746 } elsif ($op->flags & OPf_STACKED) {
5747 $left = maybe_local(@_,
5748 $lvref_funnies{$op->private & OPpLVREF_TYPE}
5749 . $self->deparse($op->first->sibling));
5750 } else {
5751 $left = &pp_padsv;
5752 }
5753 my $right = $self->deparse_binop_right($op, $op->first, 7);
5754 return $self->maybe_parens("\\$left = $right", $cx, 7);
5755}
5756
5757sub pp_lvref {
5758 my ($self, $op, $cx) = @_;
5759 my $code;
5760 if ($op->private & OPpLVREF_ELEM) {
5761 $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem;
5762 } elsif ($op->flags & OPf_STACKED) {
5763 $code = maybe_local(@_,
5764 $lvref_funnies{$op->private & OPpLVREF_TYPE}
5765 . $self->deparse($op->first));
5766 } else {
5767 $code = &pp_padsv;
5768 }
5769 "\\$code";
5770}
5771
5772sub pp_lvrefslice {
5773 my ($self, $op, $cx) = @_;
5774 '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice);
5775}
5776
5777sub pp_lvavref {
5778 my ($self, $op, $cx) = @_;
5779 '\\(' . ($op->flags & OPf_STACKED
5780 ? maybe_local(@_, rv2x(@_, "\@"))
5781 : &pp_padsv) . ')'
5782}
5783
5784115µs1;
5785__END__
 
# spent 3µs within B::Deparse::CORE:qr which was called: # once (3µs+0s) by B::Deparse::BEGIN@4588 at line 4598
sub B::Deparse::CORE:qr; # opcode
# spent 12µs within B::Deparse::CORE:sort which was called 66 times, avg 182ns/call: # 43 times (6µs+0s) by YAML::XS::BEGIN@57 at line 5641, avg 147ns/call # 23 times (6µs+0s) by YAML::XS::BEGIN@57 at line 5465, avg 248ns/call
sub B::Deparse::CORE:sort; # opcode