diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Asmdata.pm | 250 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Assembler.pm | 328 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Bblock.pm | 224 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Bytecode.pm | 889 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/C.pm | 2272 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/CC.pm | 2005 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Concise.pm | 1628 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Debug.pm | 305 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Deparse.pm | 4642 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Disassembler.pm | 233 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Lint.pm | 392 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Showlex.pm | 205 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Stackobj.pm | 349 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Stash.pm | 52 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Terse.pm | 103 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Xref.pm | 430 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/assemble | 30 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/cc_harness | 12 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/disassemble | 22 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/makeliblinks | 54 |
20 files changed, 0 insertions, 14425 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Asmdata.pm b/Master/tlpkg/tlperl/lib/B/Asmdata.pm deleted file mode 100644 index 9e41d6dd757..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Asmdata.pm +++ /dev/null @@ -1,250 +0,0 @@ -# -#- buffer-read-only: t -#- -# -# Copyright (c) 1996-1999 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -# -# -# This file is autogenerated from bytecode.pl. Changes made here will be lost. -# -package B::Asmdata; - -our $VERSION = '1.01'; - -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); -our(%insn_data, @insn_name, @optype, @specialsv_name); - -@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); -@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); - -# XXX insn_data is initialised this way because with a large -# %insn_data = (foo => [...], bar => [...], ...) initialiser -# I get a hard-to-track-down stack underflow and segfault. -$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"]; -$insn_data{nop} = [10, \&PUT_none, "GET_none"]; -$insn_data{ret} = [0, \&PUT_none, "GET_none"]; -$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; -$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; -$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; -$insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"]; -$insn_data{newop} = [11, \&PUT_U8, "GET_U8"]; -$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"]; -$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{pv_free} = [16, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"]; -$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"]; -$insn_data{xpv} = [22, \&PUT_none, "GET_none"]; -$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"]; -$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"]; -$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"]; -$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"]; -$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"]; -$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"]; -$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"]; -$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"]; -$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_subprocess} = [46, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [47, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [48, \&PUT_U8, "GET_U8"]; -$insn_data{xcv_xsubany} = [49, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_stash} = [50, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_start} = [51, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_root} = [52, \&PUT_opindex, "GET_opindex"]; -$insn_data{xcv_gv} = [53, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_file} = [54, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xcv_depth} = [55, \&PUT_long, "GET_long"]; -$insn_data{xcv_padlist} = [56, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside} = [57, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_outside_seq} = [58, \&PUT_U32, "GET_U32"]; -$insn_data{xcv_flags} = [59, \&PUT_U16, "GET_U16"]; -$insn_data{av_extend} = [60, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{av_pushx} = [61, \&PUT_svindex, "GET_svindex"]; -$insn_data{av_push} = [62, \&PUT_svindex, "GET_svindex"]; -$insn_data{xav_fill} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xav_max} = [64, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{xav_flags} = [65, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [66, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [67, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{xhv_pmroot} = [68, \&PUT_opindex, "GET_opindex"]; -$insn_data{hv_store} = [69, \&PUT_svindex, "GET_svindex"]; -$insn_data{sv_magic} = [70, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [71, \&PUT_svindex, "GET_svindex"]; -$insn_data{mg_private} = [72, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [73, \&PUT_U8, "GET_U8"]; -$insn_data{mg_name} = [74, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{mg_namex} = [75, \&PUT_svindex, "GET_svindex"]; -$insn_data{xmg_stash} = [76, \&PUT_svindex, "GET_svindex"]; -$insn_data{gv_fetchpv} = [77, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_fetchpvx} = [78, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [79, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpvx} = [80, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [81, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_refcnt} = [82, \&PUT_U32, "GET_U32"]; -$insn_data{gp_refcnt_add} = [83, \&PUT_I32, "GET_I32"]; -$insn_data{gp_av} = [84, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_hv} = [85, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cv} = [86, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_file} = [87, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{gp_io} = [88, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_form} = [89, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_cvgen} = [90, \&PUT_U32, "GET_U32"]; -$insn_data{gp_line} = [91, \&PUT_U32, "GET_U32"]; -$insn_data{gp_share} = [92, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_flags} = [93, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [94, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_sibling} = [95, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_ppaddr} = [96, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [97, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{op_type} = [98, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [99, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"]; -$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"]; -$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmstashpv} = [108, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{op_pmreplrootpo} = [109, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{op_pmstash} = [110, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplrootgv} = [111, \&PUT_svindex, "GET_svindex"]; -$insn_data{pregcomp} = [112, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [113, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [114, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmdynflags} = [115, \&PUT_U8, "GET_U8"]; -$insn_data{op_sv} = [116, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_padix} = [117, \&PUT_PADOFFSET, "GET_PADOFFSET"]; -$insn_data{op_pv} = [118, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [119, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [120, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [121, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [122, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [123, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_stashpv} = [124, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_file} = [125, \&PUT_pvindex, "GET_pvindex"]; -$insn_data{cop_stash} = [126, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_filegv} = [127, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_seq} = [128, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [129, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [130, \&PUT_U32, "GET_U32"]; -$insn_data{cop_io} = [131, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_warnings} = [132, \&PUT_svindex, "GET_svindex"]; -$insn_data{main_start} = [133, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [134, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_cv} = [135, \&PUT_svindex, "GET_svindex"]; -$insn_data{curpad} = [136, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_begin} = [137, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_init} = [138, \&PUT_svindex, "GET_svindex"]; -$insn_data{push_end} = [139, \&PUT_svindex, "GET_svindex"]; -$insn_data{curstash} = [140, \&PUT_svindex, "GET_svindex"]; -$insn_data{defstash} = [141, \&PUT_svindex, "GET_svindex"]; -$insn_data{data} = [142, \&PUT_U8, "GET_U8"]; -$insn_data{incav} = [143, \&PUT_svindex, "GET_svindex"]; -$insn_data{load_glob} = [144, \&PUT_svindex, "GET_svindex"]; -$insn_data{regex_padav} = [145, \&PUT_svindex, "GET_svindex"]; -$insn_data{dowarn} = [146, \&PUT_U8, "GET_U8"]; -$insn_data{comppad_name} = [147, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_stash} = [148, \&PUT_svindex, "GET_svindex"]; -$insn_data{signal} = [149, \&PUT_strconst, "GET_strconst"]; -$insn_data{formfeed} = [150, \&PUT_svindex, "GET_svindex"]; - -my ($insn_name, $insn_data); -while (($insn_name, $insn_data) = each %insn_data) { - $insn_name[$insn_data->[0]] = $insn_name; -} -# Fill in any gaps -@insn_name = map($_ || "unused", @insn_name); - -1; - -__END__ - -=head1 NAME - -B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode - -=head1 SYNOPSIS - - use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name); - -=head1 DESCRIPTION - -Provides information about Perl ops in order to generate bytecode via -a bunch of exported variables. Its mostly used by B::Assembler and -B::Disassembler. - -=over 4 - -=item %insn_data - - my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name}; - -For a given $op_name (for example, 'cop_label', 'sv_flags', etc...) -you get an array ref containing the bytecode number of the op, a -reference to the subroutine used to 'PUT', and the name of the method -used to 'GET'. - -=for _private -Add more detail about what $put_sub and $get_meth are and how to use them. - -=item @insn_name - - my $op_name = $insn_name[$bytecode_num]; - -A simple mapping of the bytecode number to the name of the op. -Suitable for using with %insn_data like so: - - my $op_info = $insn_data{$insn_name[$bytecode_num]}; - -=item @optype - - my $op_type = $optype[$op_type_num]; - -A simple mapping of the op type number to its type (like 'COP' or 'BINOP'). - -=item @specialsv_name - - my $sv_name = $specialsv_name[$sv_index]; - -Certain SV types are considered 'special'. They're represented by -B::SPECIAL and are referred to by a number from the specialsv_list. -This array maps that number back to the name of the SV (like 'Nullsv' -or '&PL_sv_undef'). - -=back - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut - -# ex: set ro: diff --git a/Master/tlpkg/tlperl/lib/B/Assembler.pm b/Master/tlpkg/tlperl/lib/B/Assembler.pm deleted file mode 100644 index f312273ce36..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Assembler.pm +++ /dev/null @@ -1,328 +0,0 @@ -# Assembler.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. - -package B::Assembler; -use Exporter; -use B qw(ppname); -use B::Asmdata qw(%insn_data @insn_name); -use Config qw(%Config); -require ByteLoader; # we just need its $VERSION - -no warnings; # XXX - -@ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm); -$VERSION = 0.07; - -use strict; -my %opnumber; -my ($i, $opname); -for ($i = 0; defined($opname = ppname($i)); $i++) { - $opnumber{$opname} = $i; -} - -my($linenum, $errors, $out); # global state, set up by newasm - -sub error { - my $str = shift; - warn "$linenum: $str\n"; - $errors++; -} - -my $debug = 0; -sub debug { $debug = shift } - -sub limcheck($$$$){ - my( $val, $lo, $hi, $loc ) = @_; - if( $val < $lo || $hi < $val ){ - error "argument for $loc outside [$lo, $hi]: $val"; - $val = $hi; - } - return $val; -} - -# -# First define all the data conversion subs to which Asmdata will refer -# - -sub B::Asmdata::PUT_U8 { - my $arg = shift; - my $c = uncstring($arg); - if (defined($c)) { - if (length($c) != 1) { - error "argument for U8 is too long: $c"; - $c = substr($c, 0, 1); - } - } else { - $arg = limcheck( $arg, 0, 0xff, 'U8' ); - $c = chr($arg); - } - return $c; -} - -sub B::Asmdata::PUT_U16 { - my $arg = limcheck( $_[0], 0, 0xffff, 'U16' ); - pack("S", $arg); -} -sub B::Asmdata::PUT_U32 { - my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' ); - pack("L", $arg); -} -sub B::Asmdata::PUT_I32 { - my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' ); - pack("l", $arg); -} -sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) - # may not even be portable between compilers -sub B::Asmdata::PUT_objindex { # could allow names here - my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' ); - pack("L", $arg); -} -sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } -sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } -sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } - -sub B::Asmdata::PUT_strconst { - my $arg = shift; - my $str = uncstring($arg); - if (!defined($str)) { - error "bad string constant: $arg"; - $str = ''; - } - if ($str =~ s/\0//g) { - error "string constant argument contains NUL: $arg"; - $str = ''; - } - return $str . "\0"; -} - -sub B::Asmdata::PUT_pvcontents { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_PV { - my $arg = shift; - my $str = uncstring($arg); - if( ! defined($str) ){ - error "bad string argument: $arg"; - $str = ''; - } - return pack("L", length($str)) . $str; -} -sub B::Asmdata::PUT_comment_t { - my $arg = shift; - $arg = uncstring($arg); - error "bad string argument: $arg" unless defined($arg); - if ($arg =~ s/\n//g) { - error "comment argument contains linefeed: $arg"; - } - return $arg . "\n"; -} -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above -sub B::Asmdata::PUT_none { - my $arg = shift; - error "extraneous argument: $arg" if defined $arg; - return ""; -} -sub B::Asmdata::PUT_op_tr_array { - my @ary = split /\s*,\s*/, shift; - return pack "S*", @ary; -} - -sub B::Asmdata::PUT_IV64 { - return pack "Q", shift; -} - -sub B::Asmdata::PUT_IV { - $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64; -} - -sub B::Asmdata::PUT_PADOFFSET { - $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; -} - -sub B::Asmdata::PUT_long { - $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; -} - -my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", - b => "\b", f => "\f", v => "\013"); - -sub uncstring { - my $s = shift; - $s =~ s/^"// and $s =~ s/"$// or return undef; - $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; - return $s; -} - -sub strip_comments { - my $stmt = shift; - # Comments only allowed in instructions which don't take string arguments - # Treat string as a single line so .* eats \n characters. - $stmt =~ s{ - ^\s* # Ignore leading whitespace - ( - [^"]* # A double quote '"' indicates a string argument. If we - # find a double quote, the match fails and we strip nothing. - ) - \s*\# # Any amount of whitespace plus the comment marker... - .*$ # ...which carries on to end-of-string. - }{$1}sx; # Keep only the instruction and optional argument. - return $stmt; -} - -# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, -# ptrsize, byteorder -# nvtype is irrelevant (floats are stored as strings) -# byteorder is strconst not U32 because of varying size issues - -sub gen_header { - my $header = ""; - - $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' - $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); - $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); - $header .= B::Asmdata::PUT_U32($Config{ivsize}); - $header .= B::Asmdata::PUT_U32($Config{ptrsize}); - $header; -} - -sub parse_statement { - my $stmt = shift; - my ($insn, $arg) = $stmt =~ m{ - ^\s* # allow (but ignore) leading whitespace - (.*?) # Instruction continues up until... - (?: # ...an optional whitespace+argument group - \s+ # first whitespace. - (.*) # The argument is all the rest (newlines included). - )?$ # anchor at end-of-line - }sx; - if (defined($arg)) { - if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { - $arg = hex($arg); - } elsif ($arg =~ s/^0(?=[0-7]+$)//) { - $arg = oct($arg); - } elsif ($arg =~ /^pp_/) { - $arg =~ s/\s*$//; # strip trailing whitespace - my $opnum = $opnumber{$arg}; - if (defined($opnum)) { - $arg = $opnum; - } else { - error qq(No such op type "$arg"); - $arg = 0; - } - } - } - return ($insn, $arg); -} - -sub assemble_insn { - my ($insn, $arg) = @_; - my $data = $insn_data{$insn}; - if (defined($data)) { - my ($bytecode, $putsub) = @{$data}[0, 1]; - my $argcode = &$putsub($arg); - return chr($bytecode).$argcode; - } else { - error qq(no such instruction "$insn"); - return ""; - } -} - -sub assemble_fh { - my ($fh, $out) = @_; - my $line; - my $asm = newasm($out); - while ($line = <$fh>) { - assemble($line); - } - endasm(); -} - -sub newasm { - my($outsub) = @_; - - die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; - die <<EOD if ref $out; -Can't have multiple byteassembly sessions at once! - (perhaps you forgot an endasm()?) -EOD - - $linenum = $errors = 0; - $out = $outsub; - - $out->(gen_header()); -} - -sub endasm { - if ($errors) { - die "There were $errors assembly errors\n"; - } - $linenum = $errors = $out = 0; -} - -sub assemble { - my($line) = @_; - my ($insn, $arg); - $linenum++; - chomp $line; - if ($debug) { - my $quotedline = $line; - $quotedline =~ s/\\/\\\\/g; - $quotedline =~ s/"/\\"/g; - $out->(assemble_insn("comment", qq("$quotedline"))); - } - if( $line = strip_comments($line) ){ - ($insn, $arg) = parse_statement($line); - $out->(assemble_insn($insn, $arg)); - if ($debug) { - $out->(assemble_insn("nop", undef)); - } - } -} - -### temporary workaround - -sub asm { - return if $_[0] =~ /\s*\W/; - if (defined $_[1]) { - return if $_[1] eq "0" and - $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/; - return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/; - } - assemble "@_"; -} - -1; - -__END__ - -=head1 NAME - -B::Assembler - Assemble Perl bytecode - -=head1 SYNOPSIS - - use B::Assembler qw(newasm endasm assemble); - newasm(\&printsub); # sets up for assembly - assemble($buf); # assembles one line - endasm(); # closes down - - use B::Assembler qw(assemble_fh); - assemble_fh($fh, \&printsub); # assemble everything in $fh - -=head1 DESCRIPTION - -See F<ext/B/B/Assembler.pm>. - -=head1 AUTHORS - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> -Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Bblock.pm b/Master/tlpkg/tlperl/lib/B/Bblock.pm deleted file mode 100644 index 9566d125aaa..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Bblock.pm +++ /dev/null @@ -1,224 +0,0 @@ -package B::Bblock; - -our $VERSION = '1.02_01'; - -use Exporter (); -@ISA = "Exporter"; -@EXPORT_OK = qw(find_leaders); - -use B qw(peekop walkoptree walkoptree_exec - main_root main_start svref_2object - OPf_SPECIAL OPf_STACKED ); - -use B::Concise qw(concise_cv concise_main set_style_standard); -use strict; - -my $bblock; -my @bblock_ends; - -sub mark_leader { - my $op = shift; - if ($$op) { - $bblock->{$$op} = $op; - } -} - -sub remove_sortblock{ - foreach (keys %$bblock){ - my $leader=$$bblock{$_}; - delete $$bblock{$_} if( $leader == 0); - } -} -sub find_leaders { - my ($root, $start) = @_; - $bblock = {}; - mark_leader($start) if ( ref $start ne "B::NULL" ); - walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; - remove_sortblock(); - return $bblock; -} - -# Debugging -sub walk_bblocks { - my ($root, $start) = @_; - my ($op, $lastop, $leader, $bb); - $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); - my @leaders = values %$bblock; - while ($leader = shift @leaders) { - $lastop = $leader; - $op = $leader->next; - while ($$op && !exists($bblock->{$$op})) { - $bblock->{$$op} = $leader; - $lastop = $op; - $op = $op->next; - } - push(@bblock_ends, [$leader, $lastop]); - } - foreach $bb (@bblock_ends) { - ($leader, $lastop) = @$bb; - printf "%s .. %s\n", peekop($leader), peekop($lastop); - for ($op = $leader; $$op != $$lastop; $op = $op->next) { - printf " %s\n", peekop($op); - } - printf " %s\n", peekop($lastop); - } -} - -sub walk_bblocks_obj { - my $cvref = shift; - my $cv = svref_2object($cvref); - walk_bblocks($cv->ROOT, $cv->START); -} - -sub B::OP::mark_if_leader {} - -sub B::COP::mark_if_leader { - my $op = shift; - if ($op->label) { - mark_leader($op); - } -} - -sub B::LOOP::mark_if_leader { - my $op = shift; - mark_leader($op->next); - mark_leader($op->nextop); - mark_leader($op->redoop); - mark_leader($op->lastop->next); -} - -sub B::LOGOP::mark_if_leader { - my $op = shift; - my $opname = $op->name; - mark_leader($op->next); - if ($opname eq "entertry") { - mark_leader($op->other->next); - } else { - mark_leader($op->other); - } -} - -sub B::LISTOP::mark_if_leader { - my $op = shift; - my $first=$op->first; - $first=$first->next while ($first->name eq "null"); - mark_leader($op->first) unless (exists( $bblock->{$$first})); - mark_leader($op->next); - if ($op->name eq "sort" and $op->flags & OPf_SPECIAL - and $op->flags & OPf_STACKED){ - my $root=$op->first->sibling->first; - my $leader=$root->first; - $bblock->{$$leader} = 0; - } -} - -sub B::PMOP::mark_if_leader { - my $op = shift; - if ($op->name ne "pushre") { - my $replroot = $op->pmreplroot; - if ($$replroot) { - mark_leader($replroot); - mark_leader($op->next); - mark_leader($op->pmreplstart); - } - } -} - -# PMOP stuff omitted - -sub compile { - my @options = @_; - B::clearsym(); - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "walk_bblocks_obj(\\&$objname)"; - die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; - print "-------\n"; - set_style_standard("terse"); - eval "concise_cv('exec', \\&$objname)"; - die "concise_cv('exec', \\&$objname) failed: $@" if $@; - } - } - } else { - return sub { - walk_bblocks(main_root, main_start); - print "-------\n"; - set_style_standard("terse"); - concise_main("exec"); - }; - } -} - -# Basic block leaders: -# Any COP (pp_nextstate) with a non-NULL label -# [The op after a pp_enter] Omit -# [The op after a pp_entersub. Don't count this one.] -# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP -# The ops pointed at by op_next and op_other of a LOGOP, except -# for pp_entertry which has op_next and op_other->op_next -# The op pointed at by op_pmreplstart of a PMOP -# The op pointed at by op_other->op_pmreplstart of pp_substcont? -# [The op after a pp_return] Omit - -1; - -__END__ - -=head1 NAME - -B::Bblock - Walk basic blocks - -=head1 SYNOPSIS - - # External interface - perl -MO=Bblock[,OPTIONS] foo.pl - - # Programmatic API - use B::Bblock qw(find_leaders); - my $leaders = find_leaders($root_op, $start_op); - -=head1 DESCRIPTION - -This module is used by the B::CC back end. It walks "basic blocks". -A basic block is a series of operations which is known to execute from -start to finish, with no possibility of branching or halting. - -It can be used either stand alone or from inside another program. - -=for _private -Somebody who understands the stand-alone options document them, please. - -=head2 Functions - -=over 4 - -=item B<find_leaders> - - my $leaders = find_leaders($root_op, $start_op); - -Given the root of the op tree and an op from which to start -processing, it will return a hash ref representing all the ops which -start a block. - -=for _private -The above description may be somewhat wrong. - -The values of %$leaders are the op objects themselves. Keys are $$op -addresses. - -=for _private -Above cribbed from B::CC's comments. What's a $$op address? - -=back - - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Bytecode.pm b/Master/tlpkg/tlperl/lib/B/Bytecode.pm deleted file mode 100644 index 250569ae57b..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Bytecode.pm +++ /dev/null @@ -1,889 +0,0 @@ -# B::Bytecode.pm -# Copyright (c) 2003 Enache Adrian. All rights reserved. -# This module is free software; you can redistribute and/or modify -# it under the same terms as Perl itself. - -# Based on the original Bytecode.pm module written by Malcolm Beattie. - -package B::Bytecode; - -our $VERSION = '1.01_01'; - -use strict; -use Config; -use B qw(class main_cv main_root main_start cstring comppadlist - defstash curstash begin_av init_av end_av inc_gv warnhook diehook - dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD - OPpLVAL_INTRO SVf_FAKE SVf_READONLY); -use B::Asmdata qw(@specialsv_name); -use B::Assembler qw(asm newasm endasm); - -################################################# - -my ($varix, $opix, $savebegins, %walked, %files, @cloop); -my %strtab = (0,0); -my %svtab = (0,0); -my %optab = (0,0); -my %spectab = (0,0); -my $tix = 1; -sub asm; -sub nice ($) { } - -BEGIN { - my $ithreads = $Config{'useithreads'} eq 'define'; - eval qq{ - sub ITHREADS() { $ithreads } - sub VERSION() { $] } - }; die $@ if $@; -} - -################################################# - -sub pvstring { - my $pv = shift; - defined($pv) ? cstring ($pv."\0") : "\"\""; -} - -sub pvix { - my $str = pvstring shift; - my $ix = $strtab{$str}; - defined($ix) ? $ix : do { - asm "newpv", $str; - asm "stpv", $strtab{$str} = $tix; - $tix++; - } -} - -sub B::OP::ix { - my $op = shift; - my $ix = $optab{$$op}; - defined($ix) ? $ix : do { - nice "[".$op->name." $tix]"; - asm "newopx", $op->size | $op->type <<7; - $optab{$$op} = $opix = $ix = $tix++; - $op->bsave($ix); - $ix; - } -} - -sub B::SPECIAL::ix { - my $spec = shift; - my $ix = $spectab{$$spec}; - defined($ix) ? $ix : do { - nice '['.$specialsv_name[$$spec].']'; - asm "ldspecsvx", $$spec; - $spectab{$$spec} = $varix = $tix++; - } -} - -sub B::SV::ix { - my $sv = shift; - my $ix = $svtab{$$sv}; - defined($ix) ? $ix : do { - nice '['.class($sv).']'; - asm "newsvx", $sv->FLAGS; - $svtab{$$sv} = $varix = $ix = $tix++; - $sv->bsave($ix); - $ix; - } -} - -sub B::GV::ix { - my ($gv,$desired) = @_; - my $ix = $svtab{$$gv}; - defined($ix) ? $ix : do { - if ($gv->GP) { - my ($svix, $avix, $hvix, $cvix, $ioix, $formix); - nice "[GV]"; - my $name = $gv->STASH->NAME . "::" . $gv->NAME; - asm "gv_fetchpvx", cstring $name; - $svtab{$$gv} = $varix = $ix = $tix++; - asm "sv_flags", $gv->FLAGS; - asm "sv_refcnt", $gv->REFCNT; - asm "xgv_flags", $gv->GvFLAGS; - - asm "gp_refcnt", $gv->GvREFCNT; - asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob"; - return $ix - unless $desired || desired $gv; - $svix = $gv->SV->ix; - $avix = $gv->AV->ix; - $hvix = $gv->HV->ix; - - # XXX {{{{ - my $cv = $gv->CV; - $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0; - my $form = $gv->FORM; - $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0; - - $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; - # }}}} XXX - - nice "-GV-", - asm "ldsv", $varix = $ix unless $ix == $varix; - asm "gp_sv", $svix; - asm "gp_av", $avix; - asm "gp_hv", $hvix; - asm "gp_cv", $cvix; - asm "gp_io", $ioix; - asm "gp_cvgen", $gv->CVGEN; - asm "gp_form", $formix; - asm "gp_file", pvix $gv->FILE; - asm "gp_line", $gv->LINE; - asm "formfeed", $svix if $name eq "main::\cL"; - } else { - nice "[GV]"; - asm "newsvx", $gv->FLAGS; - $svtab{$$gv} = $varix = $ix = $tix++; - my $stashix = $gv->STASH->ix; - $gv->B::PVMG::bsave($ix); - asm "xgv_flags", $gv->GvFLAGS; - asm "xgv_stash", $stashix; - } - $ix; - } -} - -sub B::HV::ix { - my $hv = shift; - my $ix = $svtab{$$hv}; - defined($ix) ? $ix : do { - my ($ix,$i,@array); - my $name = $hv->NAME; - if ($name) { - nice "[STASH]"; - asm "gv_stashpvx", cstring $name; - asm "sv_flags", $hv->FLAGS; - $svtab{$$hv} = $varix = $ix = $tix++; - asm "xhv_name", pvix $name; - # my $pmrootix = $hv->PMROOT->ix; # XXX - asm "ldsv", $varix = $ix unless $ix == $varix; - # asm "xhv_pmroot", $pmrootix; # XXX - } else { - nice "[HV]"; - asm "newsvx", $hv->FLAGS; - $svtab{$$hv} = $varix = $ix = $tix++; - my $stashix = $hv->SvSTASH->ix; - for (@array = $hv->ARRAY) { - next if $i = not $i; - $_ = $_->ix; - } - nice "-HV-", - asm "ldsv", $varix = $ix unless $ix == $varix; - ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_) - for @array; - if (VERSION < 5.009) { - asm "xnv", $hv->NVX; - } - asm "xmg_stash", $stashix; - asm "xhv_riter", $hv->RITER; - } - asm "sv_refcnt", $hv->REFCNT; - $ix; - } -} - -sub B::NULL::ix { - my $sv = shift; - $$sv ? $sv->B::SV::ix : 0; -} - -sub B::NULL::opwalk { 0 } - -################################################# - -sub B::NULL::bsave { - my ($sv,$ix) = @_; - - nice '-'.class($sv).'-', - asm "ldsv", $varix = $ix unless $ix == $varix; - asm "sv_refcnt", $sv->REFCNT; -} - -sub B::SV::bsave; - *B::SV::bsave = *B::NULL::bsave; - -sub B::RV::bsave { - my ($sv,$ix) = @_; - my $rvix = $sv->RV->ix; - $sv->B::NULL::bsave($ix); - asm "xrv", $rvix; -} - -sub B::PV::bsave { - my ($sv,$ix) = @_; - $sv->B::NULL::bsave($ix); - asm "newpv", pvstring $sv->PVBM; - asm "xpv"; -} - -sub B::IV::bsave { - my ($sv,$ix) = @_; - $sv->B::NULL::bsave($ix); - asm "xiv", $sv->IVX; -} - -sub B::NV::bsave { - my ($sv,$ix) = @_; - $sv->B::NULL::bsave($ix); - asm "xnv", sprintf "%.40g", $sv->NVX; -} - -sub B::PVIV::bsave { - my ($sv,$ix) = @_; - $sv->POK ? - $sv->B::PV::bsave($ix): - $sv->ROK ? - $sv->B::RV::bsave($ix): - $sv->B::NULL::bsave($ix); - if (VERSION >= 5.009) { - # See note below in B::PVNV::bsave - return if $sv->isa('B::AV'); - return if $sv->isa('B::HV'); - } - asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ? - "0 but true" : $sv->IVX; -} - -sub B::PVNV::bsave { - my ($sv,$ix) = @_; - $sv->B::PVIV::bsave($ix); - if (VERSION >= 5.009) { - # Magical AVs end up here, but AVs now don't have an NV slot actually - # allocated. Hence don't write out assembly to store the NV slot if - # we're actually an array. - return if $sv->isa('B::AV'); - # Likewise HVs have no NV slot actually allocated. - # I don't think that they can get here, but better safe than sorry - return if $sv->isa('B::HV'); - } - asm "xnv", sprintf "%.40g", $sv->NVX; -} - -sub B::PVMG::domagic { - my ($sv,$ix) = @_; - nice '-MAGICAL-'; - my @mglist = $sv->MAGIC; - my (@mgix, @namix); - for (@mglist) { - push @mgix, $_->OBJ->ix; - push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY; - } - - nice '-'.class($sv).'-', - asm "ldsv", $varix = $ix unless $ix == $varix; - for (@mglist) { - asm "sv_magic", cstring $_->TYPE; - asm "mg_obj", shift @mgix; - my $length = $_->LENGTH; - if ($length == B::HEf_SVKEY) { - asm "mg_namex", shift @namix; - } elsif ($length) { - asm "newpv", pvstring $_->PTR; - asm "mg_name"; - } - } -} - -sub B::PVMG::bsave { - my ($sv,$ix) = @_; - my $stashix = $sv->SvSTASH->ix; - $sv->B::PVNV::bsave($ix); - asm "xmg_stash", $stashix; - $sv->domagic($ix) if $sv->MAGICAL; -} - -sub B::PVLV::bsave { - my ($sv,$ix) = @_; - my $targix = $sv->TARG->ix; - $sv->B::PVMG::bsave($ix); - asm "xlv_targ", $targix; - asm "xlv_targoff", $sv->TARGOFF; - asm "xlv_targlen", $sv->TARGLEN; - asm "xlv_type", $sv->TYPE; - -} - -sub B::BM::bsave { - my ($sv,$ix) = @_; - $sv->B::PVMG::bsave($ix); - asm "xpv_cur", $sv->CUR; - asm "xbm_useful", $sv->USEFUL; - asm "xbm_previous", $sv->PREVIOUS; - asm "xbm_rare", $sv->RARE; -} - -sub B::IO::bsave { - my ($io,$ix) = @_; - my $topix = $io->TOP_GV->ix; - my $fmtix = $io->FMT_GV->ix; - my $bottomix = $io->BOTTOM_GV->ix; - $io->B::PVMG::bsave($ix); - asm "xio_lines", $io->LINES; - asm "xio_page", $io->PAGE; - asm "xio_page_len", $io->PAGE_LEN; - asm "xio_lines_left", $io->LINES_LEFT; - asm "xio_top_name", pvix $io->TOP_NAME; - asm "xio_top_gv", $topix; - asm "xio_fmt_name", pvix $io->FMT_NAME; - asm "xio_fmt_gv", $fmtix; - asm "xio_bottom_name", pvix $io->BOTTOM_NAME; - asm "xio_bottom_gv", $bottomix; - asm "xio_subprocess", $io->SUBPROCESS; - asm "xio_type", ord $io->IoTYPE; - # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX -} - -sub B::CV::bsave { - my ($cv,$ix) = @_; - my $stashix = $cv->STASH->ix; - my $gvix = $cv->GV->ix; - my $padlistix = $cv->PADLIST->ix; - my $outsideix = $cv->OUTSIDE->ix; - my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0; - my $startix = $cv->START->opwalk; - my $rootix = $cv->ROOT->ix; - - $cv->B::PVMG::bsave($ix); - asm "xcv_stash", $stashix; - asm "xcv_start", $startix; - asm "xcv_root", $rootix; - asm "xcv_xsubany", $constix; - asm "xcv_gv", $gvix; - asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD - asm "xcv_padlist", $padlistix; - asm "xcv_outside", $outsideix; - asm "xcv_flags", $cv->CvFLAGS; - asm "xcv_outside_seq", $cv->OUTSIDE_SEQ; - asm "xcv_depth", $cv->DEPTH; -} - -sub B::FM::bsave { - my ($form,$ix) = @_; - - $form->B::CV::bsave($ix); - asm "xfm_lines", $form->LINES; -} - -sub B::AV::bsave { - my ($av,$ix) = @_; - return $av->B::PVMG::bsave($ix) if $av->MAGICAL; - my @array = $av->ARRAY; - $_ = $_->ix for @array; - my $stashix = $av->SvSTASH->ix; - - nice "-AV-", - asm "ldsv", $varix = $ix unless $ix == $varix; - asm "av_extend", $av->MAX if $av->MAX >= 0; - asm "av_pushx", $_ for @array; - asm "sv_refcnt", $av->REFCNT; - if (VERSION < 5.009) { - asm "xav_flags", $av->AvFLAGS; - } - asm "xmg_stash", $stashix; -} - -sub B::GV::desired { - my $gv = shift; - my ($cv, $form); - $files{$gv->FILE} && $gv->LINE - || ${$cv = $gv->CV} && $files{$cv->FILE} - || ${$form = $gv->FORM} && $files{$form->FILE} -} - -sub B::HV::bwalk { - my $hv = shift; - return if $walked{$$hv}++; - my %stash = $hv->ARRAY; - while (my($k,$v) = each %stash) { - if ($v->SvTYPE == SVt_PVGV) { - my $hash = $v->HV; - if ($$hash && $hash->NAME) { - $hash->bwalk; - } - $v->ix(1) if desired $v; - } else { - nice "[prototype]"; - asm "gv_fetchpvx", cstring $hv->NAME . "::$k"; - $svtab{$$v} = $varix = $tix; - $v->bsave($tix++); - asm "sv_flags", $v->FLAGS; - } - } -} - -###################################################### - - -sub B::OP::bsave_thin { - my ($op, $ix) = @_; - my $next = $op->next; - my $nextix = $optab{$$next}; - $nextix = 0, push @cloop, $op unless defined $nextix; - if ($ix != $opix) { - nice '-'.$op->name.'-', - asm "ldop", $opix = $ix; - } - asm "op_next", $nextix; - asm "op_targ", $op->targ if $op->type; # tricky - asm "op_flags", $op->flags; - asm "op_private", $op->private; -} - -sub B::OP::bsave; - *B::OP::bsave = *B::OP::bsave_thin; - -sub B::UNOP::bsave { - my ($op, $ix) = @_; - my $name = $op->name; - my $flags = $op->flags; - my $first = $op->first; - my $firstix = - $name =~ /fl[io]p/ - # that's just neat - || (!ITHREADS && $name eq 'regcomp') - # trick for /$a/o in pp_regcomp - || $name eq 'rv2sv' - && $op->flags & OPf_MOD - && $op->private & OPpLVAL_INTRO - # change #18774 made my life hard - ? $first->ix - : 0; - - $op->B::OP::bsave($ix); - asm "op_first", $firstix; -} - -sub B::BINOP::bsave { - my ($op, $ix) = @_; - if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) { - my $last = $op->last; - my $lastix = do { - local *B::OP::bsave = *B::OP::bsave_fat; - local *B::UNOP::bsave = *B::UNOP::bsave_fat; - $last->ix; - }; - asm "ldop", $lastix unless $lastix == $opix; - asm "op_targ", $last->targ; - $op->B::OP::bsave($ix); - asm "op_last", $lastix; - } else { - $op->B::OP::bsave($ix); - } -} - -# not needed if no pseudohashes - -*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009; - -# deal with sort / formline - -sub B::LISTOP::bsave { - my ($op, $ix) = @_; - my $name = $op->name; - sub blocksort() { OPf_SPECIAL|OPf_STACKED } - if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) { - my $first = $op->first; - my $pushmark = $first->sibling; - my $rvgv = $pushmark->first; - my $leave = $rvgv->first; - - my $leaveix = $leave->ix; - - my $rvgvix = $rvgv->ix; - asm "ldop", $rvgvix unless $rvgvix == $opix; - asm "op_first", $leaveix; - - my $pushmarkix = $pushmark->ix; - asm "ldop", $pushmarkix unless $pushmarkix == $opix; - asm "op_first", $rvgvix; - - my $firstix = $first->ix; - asm "ldop", $firstix unless $firstix == $opix; - asm "op_sibling", $pushmarkix; - - $op->B::OP::bsave($ix); - asm "op_first", $firstix; - } elsif ($name eq 'formline') { - $op->B::UNOP::bsave_fat($ix); - } else { - $op->B::OP::bsave($ix); - } -} - -# fat versions - -sub B::OP::bsave_fat { - my ($op, $ix) = @_; - my $siblix = $op->sibling->ix; - - $op->B::OP::bsave_thin($ix); - asm "op_sibling", $siblix; - # asm "op_seq", -1; XXX don't allocate OPs piece by piece -} - -sub B::UNOP::bsave_fat { - my ($op,$ix) = @_; - my $firstix = $op->first->ix; - - $op->B::OP::bsave($ix); - asm "op_first", $firstix; -} - -sub B::BINOP::bsave_fat { - my ($op,$ix) = @_; - my $last = $op->last; - my $lastix = $op->last->ix; - if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') { - asm "ldop", $lastix unless $lastix == $opix; - asm "op_targ", $last->targ; - } - - $op->B::UNOP::bsave($ix); - asm "op_last", $lastix; -} - -sub B::LOGOP::bsave { - my ($op,$ix) = @_; - my $otherix = $op->other->ix; - - $op->B::UNOP::bsave($ix); - asm "op_other", $otherix; -} - -sub B::PMOP::bsave { - my ($op,$ix) = @_; - my ($rrop, $rrarg, $rstart); - - # my $pmnextix = $op->pmnext->ix; # XXX - - if (ITHREADS) { - if ($op->name eq 'subst') { - $rrop = "op_pmreplroot"; - $rrarg = $op->pmreplroot->ix; - $rstart = $op->pmreplstart->ix; - } elsif ($op->name eq 'pushre') { - $rrop = "op_pmreplrootpo"; - $rrarg = $op->pmreplroot; - } - $op->B::BINOP::bsave($ix); - asm "op_pmstashpv", pvix $op->pmstashpv; - } else { - $rrop = "op_pmreplrootgv"; - $rrarg = $op->pmreplroot->ix; - $rstart = $op->pmreplstart->ix if $op->name eq 'subst'; - my $stashix = $op->pmstash->ix; - $op->B::BINOP::bsave($ix); - asm "op_pmstash", $stashix; - } - - asm $rrop, $rrarg if $rrop; - asm "op_pmreplstart", $rstart if $rstart; - - asm "op_pmflags", $op->pmflags; - asm "op_pmpermflags", $op->pmpermflags; - asm "op_pmdynflags", $op->pmdynflags; - # asm "op_pmnext", $pmnextix; # XXX - asm "newpv", pvstring $op->precomp; - asm "pregcomp"; -} - -sub B::SVOP::bsave { - my ($op,$ix) = @_; - my $svix = $op->sv->ix; - - $op->B::OP::bsave($ix); - asm "op_sv", $svix; -} - -sub B::PADOP::bsave { - my ($op,$ix) = @_; - - $op->B::OP::bsave($ix); - asm "op_padix", $op->padix; -} - -sub B::PVOP::bsave { - my ($op,$ix) = @_; - $op->B::OP::bsave($ix); - return unless my $pv = $op->pv; - - if ($op->name eq 'trans') { - asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv); - } else { - asm "newpv", pvstring $pv; - asm "op_pv"; - } -} - -sub B::LOOP::bsave { - my ($op,$ix) = @_; - my $nextix = $op->nextop->ix; - my $lastix = $op->lastop->ix; - my $redoix = $op->redoop->ix; - - $op->B::BINOP::bsave($ix); - asm "op_redoop", $redoix; - asm "op_nextop", $nextix; - asm "op_lastop", $lastix; -} - -sub B::COP::bsave { - my ($cop,$ix) = @_; - my $warnix = $cop->warnings->ix; - my $ioix = $cop->io->ix; - if (ITHREADS) { - $cop->B::OP::bsave($ix); - asm "cop_stashpv", pvix $cop->stashpv; - asm "cop_file", pvix $cop->file; - } else { - my $stashix = $cop->stash->ix; - my $fileix = $cop->filegv->ix(1); - $cop->B::OP::bsave($ix); - asm "cop_stash", $stashix; - asm "cop_filegv", $fileix; - } - asm "cop_label", pvix $cop->label if $cop->label; # XXX AD - asm "cop_seq", $cop->cop_seq; - asm "cop_arybase", $cop->arybase; - asm "cop_line", $cop->line; - asm "cop_warnings", $warnix; - asm "cop_io", $ioix; -} - -sub B::OP::opwalk { - my $op = shift; - my $ix = $optab{$$op}; - defined($ix) ? $ix : do { - my $ix; - my @oplist = $op->oplist; - push @cloop, undef; - $ix = $_->ix while $_ = pop @oplist; - while ($_ = pop @cloop) { - asm "ldop", $optab{$$_}; - asm "op_next", $optab{${$_->next}}; - } - $ix; - } -} - -################################################# - -sub save_cq { - my $av; - if (($av=begin_av)->isa("B::AV")) { - if ($savebegins) { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - asm "push_begin", $_->ix; - } - } else { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - # XXX BEGIN { goto A while 1; A: } - for (my $op = $_->START; $$op; $op = $op->next) { - next unless $op->name eq 'require' || - # this kludge needed for tests - $op->name eq 'gv' && do { - my $gv = class($op) eq 'SVOP' ? - $op->gv : - (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix]; - $$gv && $gv->NAME =~ /use_ok|plan/ - }; - asm "push_begin", $_->ix; - last; - } - } - } - } - if (($av=init_av)->isa("B::AV")) { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - asm "push_init", $_->ix; - } - } - if (($av=end_av)->isa("B::AV")) { - for ($av->ARRAY) { - next unless $_->FILE eq $0; - asm "push_end", $_->ix; - } - } -} - -sub compile { - my ($head, $scan, $T_inhinc, $keep_syn); - my $cwd = ''; - $files{$0} = 1; - sub keep_syn { - $keep_syn = 1; - *B::OP::bsave = *B::OP::bsave_fat; - *B::UNOP::bsave = *B::UNOP::bsave_fat; - *B::BINOP::bsave = *B::BINOP::bsave_fat; - *B::LISTOP::bsave = *B::LISTOP::bsave_fat; - } - sub bwarn { print STDERR "Bytecode.pm: @_\n" } - - for (@_) { - if (/^-S/) { - *newasm = *endasm = sub { }; - *asm = sub { print " @_\n" }; - *nice = sub ($) { print "\n@_\n" }; - } elsif (/^-H/) { - require ByteLoader; - $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n"; - } elsif (/^-k/) { - keep_syn; - } elsif (/^-o(.*)$/) { - open STDOUT, ">$1" or die "open $1: $!"; - } elsif (/^-f(.*)$/) { - $files{$1} = 1; - } elsif (/^-s(.*)$/) { - $scan = length($1) ? $1 : $0; - } elsif (/^-b/) { - $savebegins = 1; - # this is here for the testsuite - } elsif (/^-TI/) { - $T_inhinc = 1; - } elsif (/^-TF(.*)/) { - my $thatfile = $1; - *B::COP::file = sub { $thatfile }; - } else { - bwarn "Ignoring '$_' option"; - } - } - if ($scan) { - my $f; - if (open $f, $scan) { - while (<$f>) { - /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1; - /^#/ and next; - if (/\bgoto\b\s*[^&]/ && !$keep_syn) { - bwarn "keeping the syntax tree: \"goto\" op found"; - keep_syn; - } - } - } else { - bwarn "cannot rescan '$scan'"; - } - close $f; - } - binmode STDOUT; - return sub { - print $head if $head; - newasm sub { print @_ }; - - defstash->bwalk; - asm "main_start", main_start->opwalk; - asm "main_root", main_root->ix; - asm "main_cv", main_cv->ix; - asm "curpad", (comppadlist->ARRAY)[1]->ix; - - asm "signal", cstring "__WARN__" # XXX - if warnhook->ix; - asm "incav", inc_gv->AV->ix if $T_inhinc; - save_cq; - asm "incav", inc_gv->AV->ix if $T_inhinc; - asm "dowarn", dowarn; - - { - no strict 'refs'; - nice "<DATA>"; - my $dh = *{defstash->NAME."::DATA"}; - unless (eof $dh) { - local undef $/; - asm "data", ord 'D'; - print <$dh>; - } else { - asm "ret"; - } - } - - endasm; - } -} - -1; - -=head1 NAME - -B::Bytecode - Perl compiler's bytecode backend - -=head1 SYNOPSIS - -B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl> - -=head1 DESCRIPTION - -Compiles a Perl script into a bytecode format that could be loaded -later by the ByteLoader module and executed as a regular Perl script. - -=head1 EXAMPLE - - $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"' - $ perl hi - hi! - -=head1 OPTIONS - -=over 4 - -=item B<-b> - -Save all the BEGIN blocks. Normally only BEGIN blocks that C<require> -other files (ex. C<use Foo;>) are saved. - -=item B<-H> - -prepend a C<use ByteLoader VERSION;> line to the produced bytecode. - -=item B<-k> - -keep the syntax tree - it is stripped by default. - -=item B<-o>I<outfile> - -put the bytecode in <outfile> instead of dumping it to STDOUT. - -=item B<-s> - -scan the script for C<# line ..> directives and for <goto LABEL> -expressions. When gotos are found keep the syntax tree. - -=back - -=head1 KNOWN BUGS - -=over 4 - -=item * - -C<BEGIN { goto A: while 1; A: }> won't even compile. - -=item * - -C<?...?> and C<reset> do not work as expected. - -=item * - -variables in C<(?{ ... })> constructs are not properly scoped. - -=item * - -scripts that use source filters will fail miserably. - -=back - -=head1 NOTICE - -There are also undocumented bugs and options. - -THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK. - -=head1 AUTHORS - -Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and -modified by Benjamin Stuhl <sho_pi@hotmail.com>. - -Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d. - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/C.pm b/Master/tlpkg/tlperl/lib/B/C.pm deleted file mode 100644 index cebf4132ffd..00000000000 --- a/Master/tlpkg/tlperl/lib/B/C.pm +++ /dev/null @@ -1,2272 +0,0 @@ -# C.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# - -package B::C; - -our $VERSION = '1.04_01'; - -package B::C::Section; - -use B (); -use base B::Section; - -sub new -{ - my $class = shift; - my $o = $class->SUPER::new(@_); - push @$o, { values => [] }; - return $o; -} - -sub add -{ - my $section = shift; - push(@{$section->[-1]{values}},@_); -} - -sub index -{ - my $section = shift; - return scalar(@{$section->[-1]{values}})-1; -} - -sub output -{ - my ($section, $fh, $format) = @_; - my $sym = $section->symtable || {}; - my $default = $section->default; - my $i; - foreach (@{$section->[-1]{values}}) - { - s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; - printf $fh $format, $_, $i; - ++$i; - } -} - -package B::C::InitSection; - -# avoid use vars -@B::C::InitSection::ISA = qw(B::C::Section); - -sub new { - my $class = shift; - my $max_lines = 10000; #pop; - my $section = $class->SUPER::new( @_ ); - - $section->[-1]{evals} = []; - $section->[-1]{chunks} = []; - $section->[-1]{nosplit} = 0; - $section->[-1]{current} = []; - $section->[-1]{count} = 0; - $section->[-1]{max_lines} = $max_lines; - - return $section; -} - -sub split { - my $section = shift; - $section->[-1]{nosplit}-- - if $section->[-1]{nosplit} > 0; -} - -sub no_split { - shift->[-1]{nosplit}++; -} - -sub inc_count { - my $section = shift; - - $section->[-1]{count} += $_[0]; - # this is cheating - $section->add(); -} - -sub add { - my $section = shift->[-1]; - my $current = $section->{current}; - my $nosplit = $section->{nosplit}; - - push @$current, @_; - $section->{count} += scalar(@_); - if( !$nosplit && $section->{count} >= $section->{max_lines} ) { - push @{$section->{chunks}}, $current; - $section->{current} = []; - $section->{count} = 0; - } -} - -sub add_eval { - my $section = shift; - my @strings = @_; - - foreach my $i ( @strings ) { - $i =~ s/\"/\\\"/g; - } - push @{$section->[-1]{evals}}, @strings; -} - -sub output { - my( $section, $fh, $format, $init_name ) = @_; - my $sym = $section->symtable || {}; - my $default = $section->default; - push @{$section->[-1]{chunks}}, $section->[-1]{current}; - - my $name = "aaaa"; - foreach my $i ( @{$section->[-1]{chunks}} ) { - print $fh <<"EOT"; -static int perl_init_${name}() -{ - dTARG; - dSP; -EOT - foreach my $j ( @$i ) { - $j =~ s{(s\\_[0-9a-f]+)} - { exists($sym->{$1}) ? $sym->{$1} : $default; }ge; - print $fh "\t$j\n"; - } - print $fh "\treturn 0;\n}\n"; - - $section->SUPER::add( "perl_init_${name}();" ); - ++$name; - } - foreach my $i ( @{$section->[-1]{evals}} ) { - $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i ); - } - - print $fh <<"EOT"; -static int ${init_name}() -{ - dTARG; - dSP; -EOT - $section->SUPER::output( $fh, $format ); - print $fh "\treturn 0;\n}\n"; -} - - -package B::C; -use Exporter (); -our %REGEXP; - -{ # block necessary for caller to work - my $caller = caller; - if( $caller eq 'O' ) { - require XSLoader; - XSLoader::load( 'B::C' ); - } -} - -@ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused - init_sections set_callback save_unused_subs objsym save_context); - -use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop - class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation - HEf_SVKEY SVf_POK SVf_ROK CVf_CONST); -use B::Asmdata qw(@specialsv_name); - -use FileHandle; -use Carp; -use strict; -use Config; - -my $hv_index = 0; -my $gv_index = 0; -my $re_index = 0; -my $pv_index = 0; -my $cv_index = 0; -my $anonsub_index = 0; -my $initsub_index = 0; - -my %symtable; -my %xsub; -my $warn_undefined_syms; -my $verbose; -my %unused_sub_packages; -my $use_xsloader; -my $nullop_count; -my $pv_copy_on_grow = 0; -my $optimize_ppaddr = 0; -my $optimize_warn_sv = 0; -my $use_perl_script_name = 0; -my $save_data_fh = 0; -my $save_sig = 0; -my ($debug_cops, $debug_av, $debug_cv, $debug_mg); -my $max_string_len; - -my $ithreads = $Config{useithreads} eq 'define'; - -my @threadsv_names; -BEGIN { - @threadsv_names = threadsv_names(); -} - -# Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, - $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, - $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, - $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect ); -my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect, - $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, - $unopsect ); - -sub walk_and_save_optree; -my $saveoptree_callback = \&walk_and_save_optree; -sub set_callback { $saveoptree_callback = shift } -sub saveoptree { &$saveoptree_callback(@_) } - -sub walk_and_save_optree { - my ($name, $root, $start) = @_; - walkoptree($root, "save"); - return objsym($start); -} - -# Look this up here so we can do just a number compare -# rather than looking up the name of every BASEOP in B::OP -my $OP_THREADSV = opnumber('threadsv'); - -sub savesym { - my ($obj, $value) = @_; - my $sym = sprintf("s\\_%x", $$obj); - $symtable{$sym} = $value; -} - -sub objsym { - my $obj = shift; - return $symtable{sprintf("s\\_%x", $$obj)}; -} - -sub getsym { - my $sym = shift; - my $value; - - return 0 if $sym eq "sym_0"; # special case - $value = $symtable{$sym}; - if (defined($value)) { - return $value; - } else { - warn "warning: undefined symbol $sym\n" if $warn_undefined_syms; - return "UNUSED"; - } -} - -sub savere { - my $re = shift; - my $sym = sprintf("re%d", $re_index++); - $decl->add(sprintf("static char *$sym = %s;", cstring($re))); - - return ($sym,length(pack "a*",$re)); -} - -sub savepv { - my $pv = pack "a*", shift; - my $pvsym = 0; - my $pvmax = 0; - if ($pv_copy_on_grow) { - $pvsym = sprintf("pv%d", $pv_index++); - - if( defined $max_string_len && length($pv) > $max_string_len ) { - my $chars = join ', ', map { cchar $_ } split //, $pv; - $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars)); - } - else { - my $cstring = cstring($pv); - if ($cstring ne "0") { # sic - $decl->add(sprintf("static char %s[] = %s;", - $pvsym, $cstring)); - } - } - } else { - $pvmax = length(pack "a*",$pv) + 1; - } - return ($pvsym, $pvmax); -} - -sub save_rv { - my $sv = shift; -# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK; - my $rv = $sv->RV->save; - - $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/; - - return $rv; -} - -# savesym, pvmax, len, pv -sub save_pv_or_rv { - my $sv = shift; - - my $rok = $sv->FLAGS & SVf_ROK; - my $pok = $sv->FLAGS & SVf_POK; - my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 ); - if( $rok ) { - $savesym = '(char*)' . save_rv( $sv ); - } - else { - $pv = $pok ? (pack "a*", $sv->PV) : undef; - $len = $pok ? length($pv) : 0; - ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 ); - } - - return ( $savesym, $pvmax, $len, $pv ); -} - -# see also init_op_ppaddr below; initializes the ppaddt to the -# OpTYPE; init_op_ppaddr iterates over the ops and sets -# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente -# in perl_init ( ~10 bytes/op with GCC/i386 ) -sub B::OP::fake_ppaddr { - return $optimize_ppaddr ? - sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) : - 'NULL'; -} - -# This pair is needed becase B::FAKEOP::save doesn't scalar dereference -# $op->next and $op->sibling - -{ - # For 5.9 the hard coded text is the values for op_opt and op_static in each - # op. The value of op_opt is irrelevant, and the value of op_static needs to - # be 1 to tell op_free that this is a statically defined op and that is - # shouldn't be freed. - - # For 5.8: - # Current workaround/fix for op_free() trying to free statically - # defined OPs is to set op_seq = -1 and check for that in op_free(). - # Instead of hardwiring -1 in place of $op->seq, we use $op_seq - # so that it can be changed back easily if necessary. In fact, to - # stop compilers from moaning about a U16 being initialised with an - # uncast -1 (the printf format is %d so we can't tweak it), we have - # to "know" that op_seq is a U16 and use 65535. Ugh. - - my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535; - sub B::OP::_save_common_middle { - my $op = shift; - sprintf ("%s, %u, %u, $static, 0x%x, 0x%x", - $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private); - } -} - -sub B::OP::_save_common { - my $op = shift; - return sprintf("s\\_%x, s\\_%x, %s", - ${$op->next}, ${$op->sibling}, $op->_save_common_middle); -} - -sub B::OP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $type = $op->type; - $nullop_count++ unless $type; - if ($type == $OP_THREADSV) { - # saves looking up ppaddr but it's a bit naughty to hard code this - $init->add(sprintf("(void)find_threadsv(%s);", - cstring($threadsv_names[$op->targ]))); - } - $opsect->add($op->_save_common); - my $ix = $opsect->index; - $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "&op_list[$ix]"); -} - -sub B::FAKEOP::new { - my ($class, %objdata) = @_; - bless \%objdata, $class; -} - -sub B::FAKEOP::save { - my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s", - $op->next, $op->sibling, $op->_save_common_middle)); - my $ix = $opsect->index; - $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - return "&op_list[$ix]"; -} - -sub B::FAKEOP::next { $_[0]->{"next"} || 0 } -sub B::FAKEOP::type { $_[0]->{type} || 0} -sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 } -sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 } -sub B::FAKEOP::targ { $_[0]->{targ} || 0 } -sub B::FAKEOP::flags { $_[0]->{flags} || 0 } -sub B::FAKEOP::private { $_[0]->{private} || 0 } - -sub B::UNOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first})); - my $ix = $unopsect->index; - $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&unop_list[$ix]"); -} - -sub B::BINOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $binopsect->add(sprintf("%s, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->last})); - my $ix = $binopsect->index; - $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&binop_list[$ix]"); -} - -sub B::LISTOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $listopsect->add(sprintf("%s, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->last})); - my $ix = $listopsect->index; - $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&listop_list[$ix]"); -} - -sub B::LOGOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $logopsect->add(sprintf("%s, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->other})); - my $ix = $logopsect->index; - $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&logop_list[$ix]"); -} - -sub B::LOOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", - # peekop($op->redoop), peekop($op->nextop), - # peekop($op->lastop)); # debug - $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", - $op->_save_common, ${$op->first}, ${$op->last}, - ${$op->redoop}, ${$op->nextop}, - ${$op->lastop})); - my $ix = $loopsect->index; - $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&loop_list[$ix]"); -} - -sub B::PVOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv))); - my $ix = $pvopsect->index; - $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - savesym($op, "(OP*)&pvop_list[$ix]"); -} - -sub B::SVOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $sv = $op->sv; - my $svsym = '(SV*)' . $sv->save; - my $is_const_addr = $svsym =~ m/Null|\&/; - $svopsect->add(sprintf("%s, %s", $op->_save_common, - ( $is_const_addr ? $svsym : 'Nullsv' ))); - my $ix = $svopsect->index; - $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - $init->add("svop_list[$ix].op_sv = $svsym;") - unless $is_const_addr; - savesym($op, "(OP*)&svop_list[$ix]"); -} - -sub B::PADOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - $padopsect->add(sprintf("%s, %d", - $op->_save_common, $op->padix)); - my $ix = $padopsect->index; - $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; -# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); - savesym($op, "(OP*)&padop_list[$ix]"); -} - -sub B::COP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - warn sprintf("COP: line %d file %s\n", $op->line, $op->file) - if $debug_cops; - # shameless cut'n'paste from B::Deparse - my $warn_sv; - my $warnings = $op->warnings; - my $is_special = $warnings->isa("B::SPECIAL"); - if ($is_special && $$warnings == 4) { - # use warnings 'all'; - $warn_sv = $optimize_warn_sv ? - 'INT2PTR(SV*,1)' : - 'pWARN_ALL'; - } - elsif ($is_special && $$warnings == 5) { - # no warnings 'all'; - $warn_sv = $optimize_warn_sv ? - 'INT2PTR(SV*,2)' : - 'pWARN_NONE'; - } - elsif ($is_special) { - # use warnings; - $warn_sv = $optimize_warn_sv ? - 'INT2PTR(SV*,3)' : - 'pWARN_STD'; - } - else { - # something else - $warn_sv = $warnings->save; - } - - $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s", - $op->_save_common, cstring($op->label), $op->cop_seq, - $op->arybase, $op->line, - ( $optimize_warn_sv ? $warn_sv : 'NULL' ))); - my $ix = $copsect->index; - $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) - unless $optimize_ppaddr; - $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv )) - unless $optimize_warn_sv; - $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)), - sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv))); - - savesym($op, "(OP*)&cop_list[$ix]"); -} - -sub B::PMOP::save { - my ($op, $level) = @_; - my $sym = objsym($op); - return $sym if defined $sym; - my $replroot = $op->pmreplroot; - my $replstart = $op->pmreplstart; - my $replrootfield; - my $replstartfield = sprintf("s\\_%x", $$replstart); - my $gvsym; - my $ppaddr = $op->ppaddr; - # under ithreads, OP_PUSHRE.op_replroot is an integer - $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot; - if($ithreads && $op->name eq "pushre") { - $replrootfield = "INT2PTR(OP*,${replroot})"; - } elsif ($$replroot) { - # OP_PUSHRE (a mutated version of OP_MATCH for the regexp - # argument to a split) stores a GV in op_pmreplroot instead - # of a substitution syntax tree. We don't want to walk that... - if ($op->name eq "pushre") { - $gvsym = $replroot->save; -# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug - $replrootfield = 0; - } else { - $replstartfield = saveoptree("*ignore*", $replroot, $replstart); - } - } - # pmnext handling is broken in perl itself, I think. Bad op_pmnext - # fields aren't noticed in perl's runtime (unless you try reset) but we - # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x", - $op->_save_common, ${$op->first}, ${$op->last}, - $replrootfield, $replstartfield, - ( $ithreads ? $op->pmoffset : 0 ), - $op->pmflags, $op->pmpermflags, $op->pmdynflags )); - my $pm = sprintf("pmop_list[%d]", $pmopsect->index); - $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr)) - unless $optimize_ppaddr; - my $re = $op->precomp; - if (defined($re)) { - my( $resym, $relen ) = savere( $re ); - $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));", - $relen)); - } - if ($gvsym) { - $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); - } - savesym($op, "(OP*)&$pm"); -} - -sub B::SPECIAL::save { - my ($sv) = @_; - # special case: $$sv is not the address but an index into specialsv_list -# warn "SPECIAL::save specialsv $$sv\n"; # debug - my $sym = $specialsv_name[$$sv]; - if (!defined($sym)) { - confess "unknown specialsv index $$sv passed to B::SPECIAL::save"; - } - return $sym; -} - -sub B::OBJECT::save {} - -sub B::NULL::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; -# warn "Saving SVt_NULL SV\n"; # debug - # debug - if ($$sv == 0) { - warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; - return savesym($sv, "(void*)Nullsv /* XXX */"); - } - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::IV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::NV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $val= $sv->NVX; - $val .= '.00' if $val =~ /^-?\d+$/; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub savepvn { - my ($dest,$pv) = @_; - my @res; - # work with byte offsets/lengths - my $pv = pack "a*", $pv; - if (defined $max_string_len && length($pv) > $max_string_len) { - push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1); - my $offset = 0; - while (length $pv) { - my $str = substr $pv, 0, $max_string_len, ''; - push @res, sprintf("Copy(%s,$dest+$offset,%u,char);", - cstring($str), length($str)); - $offset += length $str; - } - push @res, sprintf("%s[%u] = '\\0';", $dest, $offset); - } - else { - push @res, sprintf("%s = savepvn(%s, %u);", $dest, - cstring($pv), length($pv)); - } - return @res; -} - -sub B::PVLV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = $sv->PV; - my $len = length($pv); - my ($pvsym, $pvmax) = savepv($pv); - my ($lvtarg, $lvtarg_sym); - $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, - $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); - $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (!$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv", - $xpvlvsect->index), $pv)); - } - $sv->save_magic; - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVIV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX)); - $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv", - $xpvivsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVNV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - my $val= $sv->NVX; - $val .= '.00' if $val =~ /^-?\d+$/; - $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $savesym, $len, $pvmax, $sv->IVX, $val)); - $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv", - $xpvnvsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::BM::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE); - my $len = length($pv); - $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x", - $len, $len + 258, $sv->IVX, $sv->NVX, - $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); - $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); - $sv->save_magic; - $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv", - $xpvbmsect->index), $pv), - sprintf("xpvbm_list[%d].xpv_cur = %u;", - $xpvbmsect->index, $len - 257)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax)); - $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv", - $xpvsect->index), $pv)); - } - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub B::PVMG::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); - - $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", - $savesym, $len, $pvmax, - $sv->IVX, $sv->NVX)); - $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); - if (defined($pv) && !$pv_copy_on_grow) { - $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv", - $xpvmgsect->index), $pv)); - } - $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); - $sv->save_magic; - return $sym; -} - -sub B::PVMG::save_magic { - my ($sv) = @_; - #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug - my $stash = $sv->SvSTASH; - $stash->save; - if ($$stash) { - warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) - if $debug_mg; - # XXX Hope stash is already going to be saved. - $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); - } - my @mgchain = $sv->MAGIC; - my ($mg, $type, $obj, $ptr,$len,$ptrsv); - foreach $mg (@mgchain) { - $type = $mg->TYPE; - $ptr = $mg->PTR; - $len=$mg->LENGTH; - if ($debug_mg) { - warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", - class($sv), $$sv, class($obj), $$obj, - cchar($type), cstring($ptr)); - } - - unless( $type eq 'r' ) { - $obj = $mg->OBJ; - $obj->save; - } - - if ($len == HEf_SVKEY){ - #The pointer is an SV* - $ptrsv=svref_2object($ptr)->save; - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", - $$sv, $$obj, cchar($type),$ptrsv,$len)); - }elsif( $type eq 'r' ){ - my $rx = $mg->REGEX; - my $pmop = $REGEXP{$rx}; - - confess "PMOP not found for REGEXP $rx" unless $pmop; - - my( $resym, $relen ) = savere( $mg->precomp ); - my $pmsym = $pmop->save; - $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) ); -{ - REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym); - sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d); -} -CODE - }else{ - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", - $$sv, $$obj, cchar($type),cstring($ptr),$len)); - } - } -} - -sub B::RV::save { - my ($sv) = @_; - my $sym = objsym($sv); - return $sym if defined $sym; - my $rv = save_rv( $sv ); - # GVs need to be handled at runtime - if( ref( $sv->RV ) eq 'B::GV' ) { - $xrvsect->add( "(SV*)Nullgv" ); - $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv)); - } - # and stashes, too - elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) { - $xrvsect->add( "(SV*)Nullhv" ); - $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv)); - } - else { - $xrvsect->add($rv); - } - $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); - return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); -} - -sub try_autoload { - my ($cvstashname, $cvname) = @_; - warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname); - # Handle AutoLoader classes explicitly. Any more general AUTOLOAD - # use should be handled by the class itself. - no strict 'refs'; - my $isa = \@{"$cvstashname\::ISA"}; - if (grep($_ eq "AutoLoader", @$isa)) { - warn "Forcing immediate load of sub derived from AutoLoader\n"; - # Tweaked version of AutoLoader::AUTOLOAD - my $dir = $cvstashname; - $dir =~ s(::)(/)g; - eval { require "auto/$dir/$cvname.al" }; - if ($@) { - warn qq(failed require "auto/$dir/$cvname.al": $@\n); - return 0; - } else { - return 1; - } - } -} -sub Dummy_initxs{}; -sub B::CV::save { - my ($cv) = @_; - my $sym = objsym($cv); - if (defined($sym)) { -# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug - return $sym; - } - # Reserve a place in svsect and xpvcvsect and record indices - my $gv = $cv->GV; - my ($cvname, $cvstashname); - if ($$gv){ - $cvname = $gv->NAME; - $cvstashname = $gv->STASH->NAME; - } - my $root = $cv->ROOT; - my $cvxsub = $cv->XSUB; - my $isconst = $cv->CvFLAGS & CVf_CONST; - if( $isconst ) { - my $value = $cv->XSUBANY; - my $stash = $gv->STASH; - my $vsym = $value->save; - my $stsym = $stash->save; - my $name = cstring($cvname); - $decl->add( "static CV* cv$cv_index;" ); - $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" ); - my $sym = savesym( $cv, "cv$cv_index" ); - $cv_index++; - return $sym; - } - #INIT is removed from the symbol table, so this call must come - # from PL_initav->save. Re-bootstrapping will push INIT back in - # so nullop should be sent. - if (!$isconst && $cvxsub && ($cvname ne "INIT")) { - my $egv = $gv->EGV; - my $stashname = $egv->STASH->NAME; - if ($cvname eq "bootstrap") - { - my $file = $gv->FILE; - $decl->add("/* bootstrap $file */"); - warn "Bootstrap $stashname $file\n"; - # if it not isa('DynaLoader'), it should hopefully be XSLoaded - # ( attributes being an exception, of course ) - if( $stashname ne 'attributes' && - !UNIVERSAL::isa($stashname,'DynaLoader') ) { - $xsub{$stashname}='Dynamic-XSLoaded'; - $use_xsloader = 1; - } - else { - $xsub{$stashname}='Dynamic'; - } - # $xsub{$stashname}='Static' unless $xsub{$stashname}; - return qq/NULL/; - } - else - { - # XSUBs for IO::File, IO::Handle, IO::Socket, - # IO::Seekable and IO::Poll - # are defined in IO.xs, so let's bootstrap it - svref_2object( \&IO::bootstrap )->save - if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket - IO::Seekable IO::Poll); - } - warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv; - return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/; - } - if ($cvxsub && $cvname eq "INIT") { - no strict 'refs'; - return svref_2object(\&Dummy_initxs)->save; - } - my $sv_ix = $svsect->index + 1; - $svsect->add("svix$sv_ix"); - my $xpvcv_ix = $xpvcvsect->index + 1; - $xpvcvsect->add("xpvcvix$xpvcv_ix"); - # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() - $sym = savesym($cv, "&sv_list[$sv_ix]"); - warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv; - if (!$$root && !$cvxsub) { - if (try_autoload($cvstashname, $cvname)) { - # Recalculate root and xsub - $root = $cv->ROOT; - $cvxsub = $cv->XSUB; - if ($$root || $cvxsub) { - warn "Successful forced autoload\n"; - } - } - } - my $startfield = 0; - my $padlist = $cv->PADLIST; - my $pv = $cv->PV; - my $xsub = 0; - my $xsubany = "Nullany"; - if ($$root) { - warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n", - $$cv, $$root) if $debug_cv; - my $ppname = ""; - if ($$gv) { - my $stashname = $gv->STASH->NAME; - my $gvname = $gv->NAME; - if ($gvname ne "__ANON__") { - $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_"; - $ppname .= ($stashname eq "main") ? - $gvname : "$stashname\::$gvname"; - $ppname =~ s/::/__/g; - if ($gvname eq "INIT"){ - $ppname .= "_$initsub_index"; - $initsub_index++; - } - } - } - if (!$ppname) { - $ppname = "pp_anonsub_$anonsub_index"; - $anonsub_index++; - } - $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY); - warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n", - $$cv, $ppname, $$root) if $debug_cv; - if ($$padlist) { - warn sprintf("saving PADLIST 0x%x for CV 0x%x\n", - $$padlist, $$cv) if $debug_cv; - $padlist->save; - warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n", - $$padlist, $$cv) if $debug_cv; - } - } - else { - warn sprintf("No definition for sub %s::%s (unable to autoload)\n", - $cvstashname, $cvname); # debug - } - $pv = '' unless defined $pv; # Avoid use of undef warnings - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x", - $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, - $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, - $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS, - $cv->OUTSIDE_SEQ)); - - if (${$cv->OUTSIDE} == ${main_cv()}){ - $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); - $init->add(sprintf("SvREFCNT_inc(PL_main_cv);")); - } - - if ($$gv) { - $gv->save; - $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv)); - warn sprintf("done saving GV 0x%x for CV 0x%x\n", - $$gv, $$cv) if $debug_cv; - } - if( $ithreads ) { - $init->add( savepvn( "CvFILE($sym)", $cv->FILE) ); - } - else { - $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE))); - } - my $stash = $cv->STASH; - if ($$stash) { - $stash->save; - $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash)); - warn sprintf("done saving STASH 0x%x for CV 0x%x\n", - $$stash, $$cv) if $debug_cv; - } - $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", - $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS)); - return $sym; -} - -sub B::GV::save { - my ($gv) = @_; - my $sym = objsym($gv); - if (defined($sym)) { - #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug - return $sym; - } else { - my $ix = $gv_index++; - $sym = savesym($gv, "gv_list[$ix]"); - #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug - } - my $is_empty = $gv->is_empty; - my $gvname = $gv->NAME; - my $fullname = $gv->STASH->NAME . "::" . $gvname; - my $name = cstring($fullname); - #warn "GV name is $name\n"; # debug - my $egvsym; - unless ($is_empty) { - my $egv = $gv->EGV; - if ($$gv != $$egv) { - #warn(sprintf("EGV name is %s, saving it now\n", - # $egv->STASH->NAME . "::" . $egv->NAME)); # debug - $egvsym = $egv->save; - } - } - $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);], - sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ), - sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS)); - $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty; - # XXX hack for when Perl accesses PVX of GVs - $init->add("SvPVX($sym) = emptystring;\n"); - # Shouldn't need to do save_magic since gv_fetchpv handles that - #$gv->save_magic; - # XXX will always be > 1!!! - my $refcnt = $gv->REFCNT + 1; - $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1; - - return $sym if $is_empty; - - # XXX B::walksymtable creates an extra reference to the GV - my $gvrefcnt = $gv->GvREFCNT; - if ($gvrefcnt > 1) { - $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); - } - # some non-alphavetic globs require some parts to be saved - # ( ex. %!, but not $! ) - sub Save_HV() { 1 } - sub Save_AV() { 2 } - sub Save_SV() { 4 } - sub Save_CV() { 8 } - sub Save_FORM() { 16 } - sub Save_IO() { 32 } - my $savefields = 0; - if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) { - $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO; - } - elsif( $gvname eq '!' ) { - $savefields = Save_HV; - } - # attributes::bootstrap is created in perl_parse - # saving it would overwrite it, because perl_init() is - # called after perl_parse() - $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap'; - - # save it - # XXX is that correct? - if (defined($egvsym) && $egvsym !~ m/Null/ ) { - # Shared glob *foo = *bar - $init->add("gp_free($sym);", - "GvGP($sym) = GvGP($egvsym);"); - } elsif ($savefields) { - # Don't save subfields of special GVs (*_, *1, *# and so on) -# warn "GV::save saving subfields\n"; # debug - my $gvsv = $gv->SV; - if ($$gvsv && $savefields&Save_SV) { - $gvsv->save; - $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); -# warn "GV::save \$$name\n"; # debug - } - my $gvav = $gv->AV; - if ($$gvav && $savefields&Save_AV) { - $gvav->save; - $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); -# warn "GV::save \@$name\n"; # debug - } - my $gvhv = $gv->HV; - if ($$gvhv && $savefields&Save_HV) { - $gvhv->save; - $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); -# warn "GV::save \%$name\n"; # debug - } - my $gvcv = $gv->CV; - if ($$gvcv && $savefields&Save_CV) { - my $origname=cstring($gvcv->GV->EGV->STASH->NAME . - "::" . $gvcv->GV->EGV->NAME); - if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias - # must save as a 'stub' so newXS() has a CV to populate - $init->add("{ CV *cv;"); - $init->add("\tcv=perl_get_cv($origname,TRUE);"); - $init->add("\tGvCV($sym)=cv;"); - $init->add("\tSvREFCNT_inc((SV *)cv);"); - $init->add("}"); - } else { - $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save)); -# warn "GV::save &$name\n"; # debug - } - } - $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE))); -# warn "GV::save GvFILE(*$name)\n"; # debug - my $gvform = $gv->FORM; - if ($$gvform && $savefields&Save_FORM) { - $gvform->save; - $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); -# warn "GV::save GvFORM(*$name)\n"; # debug - } - my $gvio = $gv->IO; - if ($$gvio && $savefields&Save_IO) { - $gvio->save; - $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); - if( $fullname =~ m/::DATA$/ && $save_data_fh ) { - no strict 'refs'; - my $fh = *{$fullname}{IO}; - use strict 'refs'; - $gvio->save_data( $fullname, <$fh> ) if $fh->opened; - } -# warn "GV::save GvIO(*$name)\n"; # debug - } - } - return $sym; -} - -sub B::AV::save { - my ($av) = @_; - my $sym = objsym($av); - return $sym if defined $sym; - my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0"; - $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009; - $xpvavsect->add($line); - $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT , $av->FLAGS)); - my $sv_list_index = $svsect->index; - my $fill = $av->FILL; - $av->save_magic; - if ($debug_av) { - $line = sprintf("saving AV 0x%x FILL=$fill", $$av); - $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009; - warn $line; - } - # XXX AVf_REAL is wrong test: need to save comppadlist but not stack - #if ($fill > -1 && ($avflags & AVf_REAL)) { - if ($fill > -1) { - my @array = $av->ARRAY; - if ($debug_av) { - my $el; - my $i = 0; - foreach $el (@array) { - warn sprintf("AV 0x%x[%d] = %s 0x%x\n", - $$av, $i++, class($el), $$el); - } - } -# my @names = map($_->save, @array); - # XXX Better ways to write loop? - # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...; - # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...; - - # micro optimization: op/pat.t ( and other code probably ) - # has very large pads ( 20k/30k elements ) passing them to - # ->add is a performance bottleneck: passing them as a - # single string cuts runtime from 6min20sec to 40sec - - # you want to keep this out of the no_split/split - # map("\t*svp++ = (SV*)$_;", @names), - my $acc = ''; - foreach my $i ( 0..$#array ) { - $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t"; - } - $acc .= "\n"; - - $init->no_split; - $init->add("{", - "\tSV **svp;", - "\tAV *av = (AV*)&sv_list[$sv_list_index];", - "\tav_extend(av, $fill);", - "\tsvp = AvARRAY(av);" ); - $init->add($acc); - $init->add("\tAvFILLp(av) = $fill;", - "}"); - $init->split; - # we really added a lot of lines ( B::C::InitSection->add - # should really scan for \n, but that would slow - # it down - $init->inc_count( $#array ); - } else { - my $max = $av->MAX; - $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);") - if $max > -1; - } - return savesym($av, "(AV*)&sv_list[$sv_list_index]"); -} - -sub B::HV::save { - my ($hv) = @_; - my $sym = objsym($hv); - return $sym if defined $sym; - my $name = $hv->NAME; - if ($name) { - # It's a stash - - # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually - # the only symptom is that sv_reset tries to reset the PMf_USED flag of - # a trashed op but we look at the trashed op_type and segfault. - #my $adpmroot = ${$hv->PMROOT}; - my $adpmroot = 0; - $decl->add("static HV *hv$hv_index;"); - # XXX Beware of weird package names containing double-quotes, \n, ...? - $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]); - if ($adpmroot) { - $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;", - $adpmroot)); - } - $sym = savesym($hv, "hv$hv_index"); - $hv_index++; - return $sym; - } - # It's just an ordinary HV - $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", - $hv->MAX, $hv->RITER)); - $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", - $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); - my $sv_list_index = $svsect->index; - my @contents = $hv->ARRAY; - if (@contents) { - my $i; - for ($i = 1; $i < @contents; $i += 2) { - $contents[$i] = $contents[$i]->save; - } - $init->no_split; - $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];"); - while (@contents) { - my ($key, $value) = splice(@contents, 0, 2); - $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", - cstring($key),length(pack "a*",$key), - $value, hash($key))); -# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", -# cstring($key),length($key),$value, 0)); - } - $init->add("}"); - $init->split; - } - $hv->save_magic(); - return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); -} - -sub B::IO::save_data { - my( $io, $globname, @data ) = @_; - my $data = join '', @data; - - # XXX using $DATA might clobber it! - my $sym = svref_2object( \\$data )->save; - $init->add( split /\n/, <<CODE ); - { - GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV ); - SV* sv = $sym; - GvSV( gv ) = sv; - } -CODE - # for PerlIO::scalar - $use_xsloader = 1; - $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname ); -} - -sub B::IO::save { - my ($io) = @_; - my $sym = objsym($io); - return $sym if defined $sym; - my $pv = $io->PV; - $pv = '' unless defined $pv; - my $len = length($pv); - $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", - $len, $len+1, $io->IVX, $io->NVX, $io->LINES, - $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT, - cstring($io->TOP_NAME), cstring($io->FMT_NAME), - cstring($io->BOTTOM_NAME), $io->SUBPROCESS, - cchar($io->IoTYPE), $io->IoFLAGS)); - $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", - $xpviosect->index, $io->REFCNT , $io->FLAGS)); - $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); - # deal with $x = *STDIN/STDOUT/STDERR{IO} - my $perlio_func; - foreach ( qw(stdin stdout stderr) ) { - $io->IsSTD($_) and $perlio_func = $_; - } - if( $perlio_func ) { - $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" ); - $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" ); - } - - my ($field, $fsym); - foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { - $fsym = $io->$field(); - if ($$fsym) { - $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym)); - $fsym->save; - } - } - $io->save_magic; - return $sym; -} - -sub B::SV::save { - my $sv = shift; - # This is where we catch an honest-to-goodness Nullsv (which gets - # blessed into B::SV explicitly) and any stray erroneous SVs. - return 0 unless $$sv; - confess sprintf("cannot save that type of SV: %s (0x%x)\n", - class($sv), $$sv); -} - -sub output_all { - my $init_name = shift; - my $section; - my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, - $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect, - $loopsect, $copsect, $svsect, $xpvsect, - $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, - $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); - $symsect->output(\*STDOUT, "#define %s\n"); - print "\n"; - output_declarations(); - foreach $section (@sections) { - my $lines = $section->index + 1; - if ($lines) { - my $name = $section->name; - my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); - print "Static $typename ${name}_list[$lines];\n"; - } - } - # XXX hack for when Perl accesses PVX of GVs - print 'Static char emptystring[] = "\0";'; - - $decl->output(\*STDOUT, "%s\n"); - print "\n"; - foreach $section (@sections) { - my $lines = $section->index + 1; - if ($lines) { - my $name = $section->name; - my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); - printf "static %s %s_list[%u] = {\n", $typename, $name, $lines; - $section->output(\*STDOUT, "\t{ %s }, /* %d */\n"); - print "};\n\n"; - } - } - - $init->output(\*STDOUT, "\t%s\n", $init_name ); - if ($verbose) { - warn compile_stats(); - warn "NULLOP count: $nullop_count\n"; - } -} - -sub output_declarations { - print <<'EOT'; -#ifdef BROKEN_STATIC_REDECL -#define Static extern -#else -#define Static static -#endif /* BROKEN_STATIC_REDECL */ - -#ifdef BROKEN_UNION_INIT -/* - * Cribbed from cv.h with ANY (a union) replaced by void*. - * Some pre-Standard compilers can't cope with initialising unions. Ho hum. - */ -typedef struct { - char * xpv_pv; /* pointer to malloced string */ - STRLEN xpv_cur; /* length of xp_pv as a C string */ - STRLEN xpv_len; /* allocated size */ - IV xof_off; /* integer value */ - NV xnv_nv; /* numeric value, if any */ - MAGIC* xmg_magic; /* magic for scalar array */ - HV* xmg_stash; /* class package */ - - HV * xcv_stash; - OP * xcv_start; - OP * xcv_root; - void (*xcv_xsub) (pTHX_ CV*); - ANY xcv_xsubany; - GV * xcv_gv; - char * xcv_file; - long xcv_depth; /* >= 2 indicates recursive call */ - AV * xcv_padlist; - CV * xcv_outside; -EOT - print <<'EOT' if $] < 5.009; -#ifdef USE_5005THREADS - perl_mutex *xcv_mutexp; - struct perl_thread *xcv_owner; /* current owner thread */ -#endif /* USE_5005THREADS */ -EOT - print <<'EOT'; - cv_flags_t xcv_flags; - U32 xcv_outside_seq; /* the COP sequence (at the point of our - * compilation) in the lexically enclosing - * sub */ -} XPVCV_or_similar; -#define ANYINIT(i) i -#else -#define XPVCV_or_similar XPVCV -#define ANYINIT(i) {i} -#endif /* BROKEN_UNION_INIT */ -#define Nullany ANYINIT(0) - -#define UNUSED 0 -#define sym_0 0 -EOT - print "static GV *gv_list[$gv_index];\n" if $gv_index; - print "\n"; -} - - -sub output_boilerplate { - print <<'EOT'; -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef Perl_pp_mapstart -#define Perl_pp_mapstart Perl_pp_grepstart -#undef OP_MAPSTART -#define OP_MAPSTART OP_GREPSTART -#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader -EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); - -static void xs_init (pTHX); -static void dl_init (pTHX); -static PerlInterpreter *my_perl; -EOT -} - -sub init_op_addr { - my( $op_type, $num ) = @_; - my $op_list = $op_type."_list"; - - $init->add( split /\n/, <<EOT ); - { - int i; - - for( i = 0; i < ${num}; ++i ) - { - ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)]; - } - } -EOT -} - -sub init_op_warn { - my( $op_type, $num ) = @_; - my $op_list = $op_type."_list"; - - # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const - $init->add( split /\n/, <<EOT ); - { - int i; - - for( i = 0; i < ${num}; ++i ) - { - switch( (int)(${op_list}\[i].cop_warnings) ) - { - case 1: - ${op_list}\[i].cop_warnings = pWARN_ALL; - break; - case 2: - ${op_list}\[i].cop_warnings = pWARN_NONE; - break; - case 3: - ${op_list}\[i].cop_warnings = pWARN_STD; - break; - default: - break; - } - } - } -EOT -} - -sub output_main { - print <<'EOT'; -/* if USE_IMPLICIT_SYS, we need a 'real' exit */ -#if defined(exit) -#undef exit -#endif - -int -main(int argc, char **argv, char **env) -{ - int exitstatus; - int i; - char **fakeargv; - GV* tmpgv; - SV* tmpsv; - int options_count; - - PERL_SYS_INIT3(&argc,&argv,&env); - - if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - exit(1); - perl_construct( my_perl ); - PL_perl_destruct_level = 0; - } -EOT - if( $ithreads ) { - # XXX init free elems! - my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref - - print <<EOT; -#ifdef USE_ITHREADS - for( i = 0; i < $pad_len; ++i ) { - av_push( PL_regex_padav, newSViv(0) ); - } - PL_regex_pad = AvARRAY( PL_regex_padav ); -#endif -EOT - } - - print <<'EOT'; -#ifdef CSH - if (!PL_cshlen) - PL_cshlen = strlen(PL_cshname); -#endif - -#ifdef ALLOW_PERL_OPTIONS -#define EXTRA_OPTIONS 3 -#else -#define EXTRA_OPTIONS 4 -#endif /* ALLOW_PERL_OPTIONS */ - Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *); - - fakeargv[0] = argv[0]; - fakeargv[1] = "-e"; - fakeargv[2] = ""; - options_count = 3; -EOT - # honour -T - print <<EOT; - if( ${^TAINT} ) { - fakeargv[options_count] = "-T"; - ++options_count; - } -EOT - print <<'EOT'; -#ifndef ALLOW_PERL_OPTIONS - fakeargv[options_count] = "--"; - ++options_count; -#endif /* ALLOW_PERL_OPTIONS */ - for (i = 1; i < argc; i++) - fakeargv[i + options_count - 1] = argv[i]; - fakeargv[argc + options_count - 1] = 0; - - exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1, - fakeargv, NULL); - - if (exitstatus) - exit( exitstatus ); - - TAINT; -EOT - - if( $use_perl_script_name ) { - my $dollar_0 = $0; - $dollar_0 =~ s/\\/\\\\/g; - $dollar_0 = '"' . $dollar_0 . '"'; - - print <<EOT; - if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */ - tmpsv = GvSV(tmpgv); - sv_setpv(tmpsv, ${dollar_0}); - SvSETMAGIC(tmpsv); - } -EOT - } - else { - print <<EOT; - if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */ - tmpsv = GvSV(tmpgv); - sv_setpv(tmpsv, argv[0]); - SvSETMAGIC(tmpsv); - } -EOT - } - - print <<'EOT'; - if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */ - tmpsv = GvSV(tmpgv); -#ifdef WIN32 - sv_setpv(tmpsv,"perl.exe"); -#else - sv_setpv(tmpsv,"perl"); -#endif - SvSETMAGIC(tmpsv); - } - - TAINT_NOT; - - /* PL_main_cv = PL_compcv; */ - PL_compcv = 0; - - exitstatus = perl_init(); - if (exitstatus) - exit( exitstatus ); - dl_init(aTHX); - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - PERL_SYS_TERM(); - - exit( exitstatus ); -} - -/* yanked from perl.c */ -static void -xs_init(pTHX) -{ - char *file = __FILE__; - dTARG; - dSP; -EOT - print "\n#ifdef USE_DYNAMIC_LOADING"; - print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; - print "\n#endif\n" ; - # delete $xsub{'DynaLoader'}; - delete $xsub{'UNIVERSAL'}; - print("/* bootstrapping code*/\n\tSAVETMPS;\n"); - print("\ttarg=sv_newmortal();\n"); - print "#ifdef USE_DYNAMIC_LOADING\n"; - print "\tPUSHMARK(sp);\n"; - print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; - print qq/\tPUTBACK;\n/; - print "\tboot_DynaLoader(aTHX_ NULL);\n"; - print qq/\tSPAGAIN;\n/; - print "#endif\n"; - foreach my $stashname (keys %xsub){ - if ($xsub{$stashname} !~ m/Dynamic/ ) { - my $stashxsub=$stashname; - $stashxsub =~ s/::/__/g; - print "\tPUSHMARK(sp);\n"; - print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; - print qq/\tPUTBACK;\n/; - print "\tboot_$stashxsub(aTHX_ NULL);\n"; - print qq/\tSPAGAIN;\n/; - } - } - print("\tFREETMPS;\n/* end bootstrapping code */\n"); - print "}\n"; - -print <<'EOT'; -static void -dl_init(pTHX) -{ - char *file = __FILE__; - dTARG; - dSP; -EOT - print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); - print("\ttarg=sv_newmortal();\n"); - foreach my $stashname (@DynaLoader::dl_modules) { - warn "Loaded $stashname\n"; - if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) { - my $stashxsub=$stashname; - $stashxsub =~ s/::/__/g; - print "\tPUSHMARK(sp);\n"; - print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; - print qq/\tPUTBACK;\n/; - print "#ifdef USE_DYNAMIC_LOADING\n"; - warn "bootstrapping $stashname added to xs_init\n"; - if( $xsub{$stashname} eq 'Dynamic' ) { - print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; - } - else { - print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/; - } - print "#else\n"; - print "\tboot_$stashxsub(aTHX_ NULL);\n"; - print "#endif\n"; - print qq/\tSPAGAIN;\n/; - } - } - print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); - print "}\n"; -} -sub dump_symtable { - # For debugging - my ($sym, $val); - warn "----Symbol table:\n"; - while (($sym, $val) = each %symtable) { - warn "$sym => $val\n"; - } - warn "---End of symbol table\n"; -} - -sub save_object { - my $sv; - foreach $sv (@_) { - svref_2object($sv)->save; - } -} - -sub Dummy_BootStrap { } - -sub B::GV::savecv -{ - my $gv = shift; - my $package=$gv->STASH->NAME; - my $name = $gv->NAME; - my $cv = $gv->CV; - my $sv = $gv->SV; - my $av = $gv->AV; - my $hv = $gv->HV; - - my $fullname = $gv->STASH->NAME . "::" . $gv->NAME; - - # We may be looking at this package just because it is a branch in the - # symbol table which is on the path to a package which we need to save - # e.g. this is 'Getopt' and we need to save 'Getopt::Long' - # - return unless ($unused_sub_packages{$package}); - return unless ($$cv || $$av || $$sv || $$hv); - $gv->save; -} - -sub mark_package -{ - my $package = shift; - unless ($unused_sub_packages{$package}) - { - no strict 'refs'; - $unused_sub_packages{$package} = 1; - if (defined @{$package.'::ISA'}) - { - foreach my $isa (@{$package.'::ISA'}) - { - if ($isa eq 'DynaLoader') - { - unless (defined(&{$package.'::bootstrap'})) - { - warn "Forcing bootstrap of $package\n"; - eval { $package->bootstrap }; - } - } -# else - { - unless ($unused_sub_packages{$isa}) - { - warn "$isa saved (it is in $package\'s \@ISA)\n"; - mark_package($isa); - } - } - } - } - } - return 1; -} - -sub should_save -{ - no strict qw(vars refs); - my $package = shift; - $package =~ s/::$//; - return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. - # warn "Considering $package\n";#debug - foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) - { - # If this package is a prefix to something we are saving, traverse it - # but do not mark it for saving if it is not already - # e.g. to get to Getopt::Long we need to traverse Getopt but need - # not save Getopt - return 1 if ($u =~ /^$package\:\:/); - } - if (exists $unused_sub_packages{$package}) - { - # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; - delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; - return $unused_sub_packages{$package}; - } - # Omit the packages which we use (and which cause grief - # because of fancy "goto &$AUTOLOAD" stuff). - # XXX Surely there must be a nicer way to do this. - if ($package eq "FileHandle" || $package eq "Config" || - $package eq "SelectSaver" || $package =~/^(B|IO)::/) - { - delete_unsaved_hashINC($package); - return $unused_sub_packages{$package} = 0; - } - # Now see if current package looks like an OO class this is probably too strong. - foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) - { - if (UNIVERSAL::can($package, $m)) - { - warn "$package has method $m: saving package\n";#debug - return mark_package($package); - } - } - delete_unsaved_hashINC($package); - return $unused_sub_packages{$package} = 0; -} -sub delete_unsaved_hashINC{ - my $packname=shift; - $packname =~ s/\:\:/\//g; - $packname .= '.pm'; -# warn "deleting $packname" if $INC{$packname} ;# debug - delete $INC{$packname}; -} -sub walkpackages -{ - my ($symref, $recurse, $prefix) = @_; - my $sym; - my $ref; - no strict 'vars'; - $prefix = '' unless defined $prefix; - while (($sym, $ref) = each %$symref) - { - local(*glob); - *glob = $ref; - if ($sym =~ /::$/) - { - $sym = $prefix . $sym; - if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) - { - walkpackages(\%glob, $recurse, $sym); - } - } - } -} - - -sub save_unused_subs -{ - no strict qw(refs); - &descend_marked_unused; - warn "Prescan\n"; - walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); - warn "Saving methods\n"; - walksymtable(\%{"main::"}, "savecv", \&should_save); -} - -sub save_context -{ - my $curpad_nam = (comppadlist->ARRAY)[0]->save; - my $curpad_sym = (comppadlist->ARRAY)[1]->save; - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; - my $amagic_generate= amagic_generation; - $init->add( "PL_curpad = AvARRAY($curpad_sym);", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", - "PL_amagic_generation= $amagic_generate;" ); -} - -sub descend_marked_unused { - foreach my $pack (keys %unused_sub_packages) - { - mark_package($pack); - } -} - -sub save_main { - # this is mainly for the test suite - my $warner = $SIG{__WARN__}; - local $SIG{__WARN__} = sub { print STDERR @_ }; - - warn "Starting compile\n"; - warn "Walking tree\n"; - seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output - walkoptree(main_root, "save"); - warn "done main optree, walking symtable for extras\n" if $debug_cv; - save_unused_subs(); - # XSLoader was used, force saving of XSLoader::load - if( $use_xsloader ) { - my $cv = svref_2object( \&XSLoader::load ); - $cv->save; - } - # save %SIG ( in case it was set in a BEGIN block ) - if( $save_sig ) { - local $SIG{__WARN__} = $warner; - $init->no_split; - $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" ); - foreach my $k ( keys %SIG ) { - next unless ref $SIG{$k}; - my $cv = svref_2object( \$SIG{$k} ); - my $sv = $cv->save; - $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv ); - $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", - cstring($k),length(pack "a*",$k), - 'sv', hash($k))); - $init->add('mg_set(sv);','}'); - } - $init->add('}'); - $init->split; - } - # honour -w - $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W ); - # - my $init_av = init_av->save; - my $end_av = end_av->save; - $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), - sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_initav = (AV *) $init_av;", - "PL_endav = (AV*) $end_av;"); - save_context(); - # init op addrs ( must be the last action, otherwise - # some ops might not be initialized - if( $optimize_ppaddr ) { - foreach my $i ( @op_sections ) { - my $section = $$i; - next unless $section->index >= 0; - init_op_addr( $section->name, $section->index + 1); - } - } - init_op_warn( $copsect->name, $copsect->index + 1) - if $optimize_warn_sv && $copsect->index >= 0; - - warn "Writing output\n"; - output_boilerplate(); - print "\n"; - output_all("perl_init"); - print "\n"; - output_main(); -} - -sub init_sections { - my @sections = (decl => \$decl, sym => \$symsect, - binop => \$binopsect, condop => \$condopsect, - cop => \$copsect, padop => \$padopsect, - listop => \$listopsect, logop => \$logopsect, - loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, - pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, - sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect, - xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect, - xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, - xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, - xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect); - my ($name, $sectref); - while (($name, $sectref) = splice(@sections, 0, 2)) { - $$sectref = new B::C::Section $name, \%symtable, 0; - } - $init = new B::C::InitSection 'init', \%symtable, 0; -} - -sub mark_unused -{ - my ($arg,$val) = @_; - $unused_sub_packages{$arg} = $val; -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - my @eval_at_startup; - my %option_map = ( 'cog' => \$pv_copy_on_grow, - 'save-data' => \$save_data_fh, - 'ppaddr' => \$optimize_ppaddr, - 'warn-sv' => \$optimize_warn_sv, - 'use-script-name' => \$use_perl_script_name, - 'save-sig-hash' => \$save_sig, - ); - my %optimization_map = ( 0 => [ qw() ], # special case - 1 => [ qw(-fcog) ], - 2 => [ qw(-fwarn-sv -fppaddr) ], - ); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } - if ($opt eq "w") { - $warn_undefined_syms = 1; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "c") { - $debug_cops = 1; - } elsif ($arg eq "A") { - $debug_av = 1; - } elsif ($arg eq "C") { - $debug_cv = 1; - } elsif ($arg eq "M") { - $debug_mg = 1; - } else { - warn "ignoring unknown debug option: $arg\n"; - } - } - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; - } elsif ($opt eq "v") { - $verbose = 1; - } elsif ($opt eq "u") { - $arg ||= shift @options; - mark_unused($arg,undef); - } elsif ($opt eq "f") { - $arg ||= shift @options; - $arg =~ m/(no-)?(.*)/; - my $no = defined($1) && $1 eq 'no-'; - $arg = $no ? $2 : $arg; - if( exists $option_map{$arg} ) { - ${$option_map{$arg}} = !$no; - } else { - die "Invalid optimization '$arg'"; - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my @opt; - foreach my $i ( 1 .. $arg ) { - push @opt, @{$optimization_map{$i}} - if exists $optimization_map{$i}; - } - unshift @options, @opt; - } elsif ($opt eq "e") { - push @eval_at_startup, $arg; - } elsif ($opt eq "l") { - $max_string_len = $arg; - } - } - init_sections(); - foreach my $i ( @eval_at_startup ) { - $init->add_eval( $i ); - } - if (@options) { - return sub { - my $objname; - foreach $objname (@options) { - eval "save_object(\\$objname)"; - } - output_all(); - } - } else { - return sub { save_main() }; - } -} - -1; - -__END__ - -=head1 NAME - -B::C - Perl compiler's C backend - -=head1 SYNOPSIS - - perl -MO=C[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend takes Perl source and generates C source code -corresponding to the internal structures that perl uses to run -your program. When the generated C source is compiled and run, it -cuts out the time which perl would have taken to load and parse -your program into its internal semi-compiled form. That means that -compiling with this backend will not help improve the runtime -execution speed of your program but may improve the start-up time. -Depending on the environment in which your program runs this may be -either a help or a hindrance. - -=head1 OPTIONS - -If there are any non-option arguments, they are taken to be -names of objects to be saved (probably doesn't work properly yet). -Without extra arguments, it saves the main program. - -=over 4 - -=item B<-ofilename> - -Output to filename instead of STDOUT - -=item B<-v> - -Verbose compilation (currently gives a few compilation statistics). - -=item B<--> - -Force end of options - -=item B<-uPackname> - -Force apparently unused subs from package Packname to be compiled. -This allows programs to use eval "foo()" even when sub foo is never -seen to be used at compile time. The down side is that any subs which -really are never used also have code generated. This option is -necessary, for example, if you have a signal handler foo which you -initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just -to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> -options. The compiler tries to figure out which packages may possibly -have subs in which need compiling but the current version doesn't do -it very well. In particular, it is confused by nested packages (i.e. -of the form C<A::B>) where package C<A> does not contain any subs. - -=item B<-D> - -Debug options (concatenated or separate flags like C<perl -D>). - -=item B<-Do> - -OPs, prints each OP as it's processed - -=item B<-Dc> - -COPs, prints COPs as processed (incl. file & line num) - -=item B<-DA> - -prints AV information on saving - -=item B<-DC> - -prints CV information on saving - -=item B<-DM> - -prints MAGIC information on saving - -=item B<-f> - -Force options/optimisations on or off one at a time. You can explicitly -disable an option using B<-fno-option>. All options default to -B<disabled>. - -=over 4 - -=item B<-fcog> - -Copy-on-grow: PVs declared and initialised statically. - -=item B<-fsave-data> - -Save package::DATA filehandles ( only available with PerlIO ). - -=item B<-fppaddr> - -Optimize the initialization of op_ppaddr. - -=item B<-fwarn-sv> - -Optimize the initialization of cop_warnings. - -=item B<-fuse-script-name> - -Use the script name instead of the program name as $0. - -=item B<-fsave-sig-hash> - -Save compile-time modifications to the %SIG hash. - -=back - -=item B<-On> - -Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. - -=over 4 - -=item B<-O0> - -Disable all optimizations. - -=item B<-O1> - -Enable B<-fcog>. - -=item B<-O2> - -Enable B<-fppaddr>, B<-fwarn-sv>. - -=back - -=item B<-llimit> - -Some C compilers impose an arbitrary limit on the length of string -constants (e.g. 2048 characters for Microsoft Visual C++). The -B<-llimit> options tells the C backend not to generate string literals -exceeding that limit. - -=back - -=head1 EXAMPLES - - perl -MO=C,-ofoo.c foo.pl - perl cc_harness -o foo foo.c - -Note that C<cc_harness> lives in the C<B> subdirectory of your perl -library directory. The utility called C<perlcc> may also be used to -help make use of this compiler. - - perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null - -=head1 BUGS - -Plenty. Current status: experimental. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/CC.pm b/Master/tlpkg/tlperl/lib/B/CC.pm deleted file mode 100644 index 079313a0a4e..00000000000 --- a/Master/tlpkg/tlperl/lib/B/CC.pm +++ /dev/null @@ -1,2005 +0,0 @@ -# CC.pm -# -# Copyright (c) 1996, 1997, 1998 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::CC; - -our $VERSION = '1.00_01'; - -use Config; -use strict; -use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info init_av sv_undef amagic_generation - OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL - OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV - OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR - CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK - ); -use B::C qw(save_unused_subs objsym init_sections mark_unused - output_all output_boilerplate output_main); -use B::Bblock qw(find_leaders); -use B::Stackobj qw(:types :flags); - -# These should probably be elsewhere -# Flags for $op->flags - -my $module; # module name (when compiled with -m) -my %done; # hash keyed by $$op of leaders of basic blocks - # which have already been done. -my $leaders; # ref to hash of basic block leaders. Keys are $$op - # addresses, values are the $op objects themselves. -my @bblock_todo; # list of leaders of basic blocks that need visiting - # sometime. -my @cc_todo; # list of tuples defining what PP code needs to be - # saved (e.g. CV, main or PMOP repl code). Each tuple - # is [$name, $root, $start, @padlist]. PMOP repl code - # tuples inherit padlist. -my @stack; # shadows perl's stack when contents are known. - # Values are objects derived from class B::Stackobj -my @pad; # Lexicals in current pad as Stackobj-derived objects -my @padlist; # Copy of current padlist so PMOP repl code can find it -my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo -my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs -my %constobj; # OP_CONST constants as Stackobj-derived objects - # keyed by $$sv. -my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic - # block or even to the end of each loop of blocks, - # depending on optimisation options. -my $know_op = 0; # Set when C variable op already holds the right op - # (from an immediately preceding DOOP(ppname)). -my $errors = 0; # Number of errors encountered -my %skip_stack; # Hash of PP names which don't need write_back_stack -my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals -my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals -my %ignore_op; # Hash of ops which do nothing except returning op_next -my %need_curcop; # Hash of ops which need PL_curcop - -my %lexstate; #state of padsvs at the start of a bblock - -BEGIN { - foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { - $ignore_op{$_} = 1; - } -} - -my ($module_name); -my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, - $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); - -# Optimisation options. On the command line, use hyphens instead of -# underscores for compatibility with gcc-style options. We use -# underscores here because they are OK in (strict) barewords. -my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint); -my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock, - freetmps_each_loop => \$freetmps_each_loop, - omit_taint => \$omit_taint); -# perl patchlevel to generate code for (defaults to current patchlevel) -my $patchlevel = int(0.5 + 1000 * ($] - 5)); - -# Could rewrite push_runtime() and output_runtime() to use a -# temporary file if memory is at a premium. -my $ppname; # name of current fake PP function -my $runtime_list_ref; -my $declare_ref; # Hash ref keyed by C variable type of declarations. - -my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref] - # tuples to be written out. - -my ($init, $decl); - -sub init_hash { map { $_ => 1 } @_ } - -# -# Initialise the hashes for the default PP functions where we can avoid -# either write_back_stack, write_back_lexicals or invalidate_lexicals. -# -%skip_lexicals = init_hash qw(pp_enter pp_enterloop); -%skip_invalidate = init_hash qw(pp_enter pp_enterloop); -%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller - pp_reset pp_rv2cv pp_entereval pp_require pp_dofile - pp_entertry pp_enterloop pp_enteriter pp_entersub - pp_enter pp_method); - -sub debug { - if ($debug_runtime) { - warn(@_); - } else { - my @tmp=@_; - runtime(map { chomp; "/* $_ */"} @tmp); - } -} - -sub declare { - my ($type, $var) = @_; - push(@{$declare_ref->{$type}}, $var); -} - -sub push_runtime { - push(@$runtime_list_ref, @_); - warn join("\n", @_) . "\n" if $debug_runtime; -} - -sub save_runtime { - push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]); -} - -sub output_runtime { - my $ppdata; - print qq(#include "cc_runtime.h"\n); - foreach $ppdata (@pp_list) { - my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nCCPP($name)\n{\n"; - my ($type, $varlist, $line); - while (($type, $varlist) = each %$declare) { - print "\t$type ", join(", ", @$varlist), ";\n"; - } - foreach $line (@$runtime) { - print $line, "\n"; - } - print "}\n"; - } -} - -sub runtime { - my $line; - foreach $line (@_) { - push_runtime("\t$line"); - } -} - -sub init_pp { - $ppname = shift; - $runtime_list_ref = []; - $declare_ref = {}; - runtime("dSP;"); - declare("I32", "oldsave"); - declare("SV", "**svp"); - map { declare("SV", "*$_") } qw(sv src dst left right); - declare("MAGIC", "*mg"); - $decl->add("static OP * $ppname (pTHX);"); - debug "init_pp: $ppname\n" if $debug_queue; -} - -# Initialise runtime_callback function for Stackobj class -BEGIN { B::Stackobj::set_callback(\&runtime) } - -# Initialise saveoptree_callback for B::C class -sub cc_queue { - my ($name, $root, $start, @pl) = @_; - debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" - if $debug_queue; - if ($name eq "*ignore*") { - $name = 0; - } else { - push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]); - } - my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name); - $start = $fakeop->save; - debug "cc_queue: name $name returns $start\n" if $debug_queue; - return $start; -} -BEGIN { B::C::set_callback(\&cc_queue) } - -sub valid_int { $_[0]->{flags} & VALID_INT } -sub valid_double { $_[0]->{flags} & VALID_DOUBLE } -sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) } -sub valid_sv { $_[0]->{flags} & VALID_SV } - -sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } -sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } -sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } -sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } -sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } - -sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } -sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } -sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } -sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } -sub pop_bool { - if (@stack) { - return ((pop @stack)->as_bool); - } else { - # Careful: POPs has an auto-decrement and SvTRUE evaluates - # its argument more than once. - runtime("sv = POPs;"); - return "SvTRUE(sv)"; - } -} - -sub write_back_lexicals { - my $avoid = shift || 0; - debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->write_back unless $lex->{flags} & $avoid; - } -} - -sub save_or_restore_lexical_state { - my $bblock=shift; - unless( exists $lexstate{$bblock}){ - foreach my $lex (@pad) { - next unless ref($lex); - ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ; - } - } - else { - foreach my $lex (@pad) { - next unless ref($lex); - my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ; - next if ( $old_flags eq $lex->{flags}); - if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){ - $lex->write_back; - } - if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){ - $lex->load_double; - } - if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){ - $lex->load_int; - } - } - } -} - -sub write_back_stack { - my $obj; - return unless @stack; - runtime(sprintf("EXTEND(sp, %d);", scalar(@stack))); - foreach $obj (@stack) { - runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv)); - } - @stack = (); -} - -sub invalidate_lexicals { - my $avoid = shift || 0; - debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" - if $debug_shadow; - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - $lex->invalidate unless $lex->{flags} & $avoid; - } -} - -sub reload_lexicals { - my $lex; - foreach $lex (@pad) { - next unless ref($lex); - my $type = $lex->{type}; - if ($type == T_INT) { - $lex->as_int; - } elsif ($type == T_DOUBLE) { - $lex->as_double; - } else { - $lex->as_sv; - } - } -} - -{ - package B::Pseudoreg; - # - # This class allocates pseudo-registers (OK, so they're C variables). - # - my %alloc; # Keyed by variable name. A value of 1 means the - # variable has been declared. A value of 2 means - # it's in use. - - sub new_scope { %alloc = () } - - sub new ($$$) { - my ($class, $type, $prefix) = @_; - my ($ptr, $i, $varname, $status, $obj); - $prefix =~ s/^(\**)//; - $ptr = $1; - $i = 0; - do { - $varname = "$prefix$i"; - $status = $alloc{$varname}; - } while $status == 2; - if ($status != 1) { - # Not declared yet - B::CC::declare($type, "$ptr$varname"); - $alloc{$varname} = 2; # declared and in use - } - $obj = bless \$varname, $class; - return $obj; - } - sub DESTROY { - my $obj = shift; - $alloc{$$obj} = 1; # no longer in use but still declared - } -} -{ - package B::Shadow; - # - # This class gives a standard API for a perl object to shadow a - # C variable and only generate reloads/write-backs when necessary. - # - # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). - # Use $obj->write_back whenever shadowed_c_var needs to be up to date. - # Use $obj->invalidate whenever an unknown function may have - # set shadow itself. - - sub new { - my ($class, $write_back) = @_; - # Object fields are perl shadow variable, validity flag - # (for *C* variable) and callback sub for write_back - # (passed perl shadow variable as argument). - bless [undef, 1, $write_back], $class; - } - sub load { - my ($obj, $newval) = @_; - $obj->[1] = 0; # C variable no longer valid - $obj->[0] = $newval; - } - sub write_back { - my $obj = shift; - if (!($obj->[1])) { - $obj->[1] = 1; # C variable will now be valid - &{$obj->[2]}($obj->[0]); - } - } - sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid -} -my $curcop = new B::Shadow (sub { - my $opsym = shift->save; - runtime("PL_curcop = (COP*)$opsym;"); -}); - -# -# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. -# -sub dopoptoloop { - my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) { - $cxix--; - } - debug "dopoptoloop: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub dopoptolabel { - my $label = shift; - my $cxix = $#cxstack; - while ($cxix >= 0 && - ($cxstack[$cxix]->{type} != CXt_LOOP || - $cxstack[$cxix]->{label} ne $label)) { - $cxix--; - } - debug "dopoptolabel: returning $cxix" if $debug_cxstack; - return $cxix; -} - -sub error { - my $format = shift; - my $file = $curcop->[0]->file; - my $line = $curcop->[0]->line; - $errors++; - if (@_) { - warn sprintf("%s:%d: $format\n", $file, $line, @_); - } else { - warn sprintf("%s:%d: %s\n", $file, $line, $format); - } -} - -# -# Load pad takes (the elements of) a PADLIST as arguments and loads -# up @pad with Stackobj-derived objects which represent those lexicals. -# If/when perl itself can generate type information (my int $foo) then -# we'll take advantage of that here. Until then, we'll use various hacks -# to tell the compiler when we want a lexical to be a particular type -# or to be a register. -# -sub load_pad { - my ($namelistav, $valuelistav) = @_; - @padlist = @_; - my @namelist = $namelistav->ARRAY; - my @valuelist = $valuelistav->ARRAY; - my $ix; - @pad = (); - debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad; - # Temporary lexicals don't get named so it's possible for @valuelist - # to be strictly longer than @namelist. We count $ix up to the end of - # @valuelist but index into @namelist for the name. Any temporaries which - # run off the end of @namelist will make $namesv undefined and we treat - # that the same as having an explicit SPECIAL sv_undef object in @namelist. - # [XXX If/when @_ becomes a lexical, we must start at 0 here.] - for ($ix = 1; $ix < @valuelist; $ix++) { - my $namesv = $namelist[$ix]; - my $type = T_UNKNOWN; - my $flags = 0; - my $name = "tmp$ix"; - my $class = class($namesv); - if (!defined($namesv) || $class eq "SPECIAL") { - # temporaries have &PL_sv_undef instead of a PVNV for a name - $flags = VALID_SV|TEMPORARY|REGISTER; - } else { - if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) { - $name = $1; - if ($2 eq "i") { - $type = T_INT; - $flags = VALID_SV|VALID_INT; - } elsif ($2 eq "d") { - $type = T_DOUBLE; - $flags = VALID_SV|VALID_DOUBLE; - } - $flags |= REGISTER if $3; - } - } - $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, - "i_$name", "d_$name"); - - debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; - } -} - -sub declare_pad { - my $ix; - for ($ix = 1; $ix <= $#pad; $ix++) { - my $type = $pad[$ix]->{type}; - declare("IV", $type == T_INT ? - sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int; - declare("double", $type == T_DOUBLE ? - sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double; - - } -} -# -# Debugging stuff -# -sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) } - -# -# OP stuff -# - -sub label { - my $op = shift; - # XXX Preserve original label name for "real" labels? - return sprintf("lab_%x", $$op); -} - -sub write_label { - my $op = shift; - push_runtime(sprintf(" %s:", label($op))); -} - -sub loadop { - my $op = shift; - my $opsym = $op->save; - runtime("PL_op = $opsym;") unless $know_op; - return $opsym; -} - -sub doop { - my $op = shift; - my $ppname = $op->ppaddr; - my $sym = loadop($op); - runtime("DOOP($ppname);"); - $know_op = 1; - return $sym; -} - -sub gimme { - my $op = shift; - my $flags = $op->flags; - return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); -} - -# -# Code generation for PP code -# - -sub pp_null { - my $op = shift; - return $op->next; -} - -sub pp_stub { - my $op = shift; - my $gimme = gimme($op); - if ($gimme != G_ARRAY) { - my $obj= new B::Stackobj::Const(sv_undef); - push(@stack, $obj); - # XXX Change to push a constant sv_undef Stackobj onto @stack - #write_back_stack(); - #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); - } - return $op->next; -} - -sub pp_unstack { - my $op = shift; - @stack = (); - runtime("PP_UNSTACK;"); - return $op->next; -} - -sub pp_and { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool(); - write_back_stack(); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); - } else { - save_or_restore_lexical_state($$next); - runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_or { - my $op = shift; - my $next = $op->next; - reload_lexicals(); - unshift(@bblock_todo, $next); - if (@stack >= 1) { - my $bool = pop_bool @stack; - write_back_stack(); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", - $bool, label($next))); - } else { - save_or_restore_lexical_state($$next); - runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), - "*sp--;"); - } - return $op->other; -} - -sub pp_cond_expr { - my $op = shift; - my $false = $op->next; - unshift(@bblock_todo, $false); - reload_lexicals(); - my $bool = pop_bool(); - write_back_stack(); - save_or_restore_lexical_state($$false); - runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->other; -} - -sub pp_padsv { - my $op = shift; - my $ix = $op->targ; - push(@stack, $pad[$ix]); - if ($op->flags & OPf_MOD) { - my $private = $op->private; - if ($private & OPpLVAL_INTRO) { - runtime("SAVECLEARSV(PL_curpad[$ix]);"); - } elsif ($private & OPpDEREF) { - runtime(sprintf("vivify_ref(PL_curpad[%d], %d);", - $ix, $private & OPpDEREF)); - $pad[$ix]->invalidate; - } - } - return $op->next; -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - my $obj; - # constant could be in the pad (under useithreads) - if ($$sv) { - $obj = $constobj{$$sv}; - if (!defined($obj)) { - $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); - } - } - else { - $obj = $pad[$op->targ]; - } - push(@stack, $obj); - return $op->next; -} - -sub pp_nextstate { - my $op = shift; - $curcop->load($op); - @stack = (); - debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno; - runtime("TAINT_NOT;") unless $omit_taint; - runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); - if ($freetmps_each_bblock || $freetmps_each_loop) { - $need_freetmps = 1; - } else { - runtime("FREETMPS;"); - } - return $op->next; -} - -sub pp_dbstate { - my $op = shift; - $curcop->invalidate; # XXX? - return default_pp($op); -} - -#default_pp will handle this: -#sub pp_bless { $curcop->write_back; default_pp(@_) } -#sub pp_repeat { $curcop->write_back; default_pp(@_) } -# The following subs need $curcop->write_back if we decide to support arybase: -# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice -#sub pp_caller { $curcop->write_back; default_pp(@_) } -#sub pp_reset { $curcop->write_back; default_pp(@_) } - -sub pp_rv2gv{ - my $op =shift; - $curcop->write_back; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - if ($op->private & OPpDEREF) { - $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;")); - $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", - $op->first->type)); - } - return $op->next; -} -sub pp_sort { - my $op = shift; - my $ppname = $op->ppaddr; - if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){ - #this indicates the sort BLOCK Array case - #ugly surgery required. - my $root=$op->first->sibling->first; - my $start=$root->first; - $op->first->save; - $op->first->sibling->save; - $root->save; - my $sym=$start->save; - my $fakeop=cc_queue("pp_sort".$$op,$root,$start); - $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop)); - } - $curcop->write_back; - write_back_lexicals(); - write_back_stack(); - doop($op); - return $op->next; -} - -sub pp_gv { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - write_back_stack(); - runtime("XPUSHs((SV*)$gvsym);"); - return $op->next; -} - -sub pp_gvsv { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - write_back_stack(); - if ($op->private & OPpLVAL_INTRO) { - runtime("XPUSHs(save_scalar($gvsym));"); - } else { - runtime("XPUSHs(GvSV($gvsym));"); - } - return $op->next; -} - -sub pp_aelemfast { - my $op = shift; - my $gvsym; - if ($Config{useithreads}) { - $gvsym = $pad[$op->padix]->as_sv; - } - else { - $gvsym = $op->gv->save; - } - my $ix = $op->private; - my $flag = $op->flags & OPf_MOD; - write_back_stack(); - runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);", - "PUSHs(svp ? *svp : &PL_sv_undef);"); - return $op->next; -} - -sub int_binop { - my ($op, $operator) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_int(); - if (@stack >= 1) { - my $left = top_int(); - $stack[-1]->set_int(&$operator($left, $right)); - } else { - runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right))); - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int)); - $targ->set_int(&$operator($$left, $$right)); - push(@stack, $targ); - } - return $op->next; -} - -sub INTS_CLOSED () { 0x1 } -sub INT_RESULT () { 0x2 } -sub NUMERIC_RESULT () { 0x4 } - -sub numeric_binop { - my ($op, $operator, $flags) = @_; - my $force_int = 0; - $force_int ||= ($flags & INT_RESULT); - $force_int ||= ($flags & INTS_CLOSED && @stack >= 2 - && valid_int($stack[-2]) && valid_int($stack[-1])); - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - if ($force_int) { - $stack[-1]->set_int(&$operator($left, $right)); - } else { - $stack[-1]->set_numeric(&$operator($left, $right)); - } - } else { - if ($force_int) { - my $rightruntime = new B::Pseudoreg ("IV", "riv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime(sprintf("sv_setiv(TOPs, %s);", - &$operator("TOPi", $$rightruntime))); - } else { - my $rightruntime = new B::Pseudoreg ("double", "rnv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime(sprintf("sv_setnv(TOPs, %s);", - &$operator("TOPn",$$rightruntime))); - } - } - } else { - my $targ = $pad[$op->targ]; - $force_int ||= ($targ->{type} == T_INT); - if ($force_int) { - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_int(&$operator($$left, $$right)); - } else { - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - $targ->set_numeric(&$operator($$left, $$right)); - } - push(@stack, $targ); - } - return $op->next; -} - -sub pp_ncmp { - my ($op) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_numeric(); - if (@stack >= 1) { - my $left = top_numeric(); - runtime sprintf("if (%s > %s){",$left,$right); - $stack[-1]->set_int(1); - $stack[-1]->write_back(); - runtime sprintf("}else if (%s < %s ) {",$left,$right); - $stack[-1]->set_int(-1); - $stack[-1]->write_back(); - runtime sprintf("}else if (%s == %s) {",$left,$right); - $stack[-1]->set_int(0); - $stack[-1]->write_back(); - runtime sprintf("}else {"); - $stack[-1]->set_sv("&PL_sv_undef"); - runtime "}"; - } else { - my $rightruntime = new B::Pseudoreg ("double", "rnv"); - runtime(sprintf("$$rightruntime = %s;",$right)); - runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime); - runtime sprintf("sv_setiv(TOPs,1);"); - runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime); - runtime sprintf("sv_setiv(TOPs,-1);"); - runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime); - runtime sprintf("sv_setiv(TOPs,0);"); - runtime sprintf(qq/}else {/); - runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;"); - runtime "}"; - } - } else { - my $targ = $pad[$op->targ]; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric)); - runtime sprintf("if (%s > %s){",$$left,$$right); - $targ->set_int(1); - $targ->write_back(); - runtime sprintf("}else if (%s < %s ) {",$$left,$$right); - $targ->set_int(-1); - $targ->write_back(); - runtime sprintf("}else if (%s == %s) {",$$left,$$right); - $targ->set_int(0); - $targ->write_back(); - runtime sprintf("}else {"); - $targ->set_sv("&PL_sv_undef"); - runtime "}"; - push(@stack, $targ); - } - return $op->next; -} - -sub sv_binop { - my ($op, $operator, $flags) = @_; - if ($op->flags & OPf_STACKED) { - my $right = pop_sv(); - if (@stack >= 1) { - my $left = top_sv(); - if ($flags & INT_RESULT) { - $stack[-1]->set_int(&$operator($left, $right)); - } elsif ($flags & NUMERIC_RESULT) { - $stack[-1]->set_numeric(&$operator($left, $right)); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv($left, %s);", - &$operator($left, $right))); - $stack[-1]->invalidate; - } - } else { - my $f; - if ($flags & INT_RESULT) { - $f = "sv_setiv"; - } elsif ($flags & NUMERIC_RESULT) { - $f = "sv_setnv"; - } else { - $f = "sv_setsv"; - } - runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right))); - } - } else { - my $targ = $pad[$op->targ]; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv)); - if ($flags & INT_RESULT) { - $targ->set_int(&$operator("left", "right")); - } elsif ($flags & NUMERIC_RESULT) { - $targ->set_numeric(&$operator("left", "right")); - } else { - # XXX Does this work? - runtime(sprintf("sv_setsv(%s, %s);", - $targ->as_sv, &$operator("left", "right"))); - $targ->invalidate; - } - push(@stack, $targ); - } - return $op->next; -} - -sub bool_int_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("IV", "riv"); - my $left = new B::Pseudoreg ("IV", "liv"); - runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_int(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_numeric_binop { - my ($op, $operator) = @_; - my $right = new B::Pseudoreg ("double", "rnv"); - my $left = new B::Pseudoreg ("double", "lnv"); - runtime(sprintf("$$right = %s; $$left = %s;", - pop_numeric(), pop_numeric())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator($$left, $$right)); - push(@stack, $bool); - return $op->next; -} - -sub bool_sv_binop { - my ($op, $operator) = @_; - runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv())); - my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); - $bool->set_numeric(&$operator("left", "right")); - push(@stack, $bool); - return $op->next; -} - -sub infix_op { - my $opname = shift; - return sub { "$_[0] $opname $_[1]" } -} - -sub prefix_op { - my $opname = shift; - return sub { sprintf("%s(%s)", $opname, join(", ", @_)) } -} - -BEGIN { - my $plus_op = infix_op("+"); - my $minus_op = infix_op("-"); - my $multiply_op = infix_op("*"); - my $divide_op = infix_op("/"); - my $modulo_op = infix_op("%"); - my $lshift_op = infix_op("<<"); - my $rshift_op = infix_op(">>"); - my $scmp_op = prefix_op("sv_cmp"); - my $seq_op = prefix_op("sv_eq"); - my $sne_op = prefix_op("!sv_eq"); - my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; - my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; - my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; - my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; - my $eq_op = infix_op("=="); - my $ne_op = infix_op("!="); - my $lt_op = infix_op("<"); - my $gt_op = infix_op(">"); - my $le_op = infix_op("<="); - my $ge_op = infix_op(">="); - - # - # XXX The standard perl PP code has extra handling for - # some special case arguments of these operators. - # - sub pp_add { numeric_binop($_[0], $plus_op) } - sub pp_subtract { numeric_binop($_[0], $minus_op) } - sub pp_multiply { numeric_binop($_[0], $multiply_op) } - sub pp_divide { numeric_binop($_[0], $divide_op) } - sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's - - sub pp_left_shift { int_binop($_[0], $lshift_op) } - sub pp_right_shift { int_binop($_[0], $rshift_op) } - sub pp_i_add { int_binop($_[0], $plus_op) } - sub pp_i_subtract { int_binop($_[0], $minus_op) } - sub pp_i_multiply { int_binop($_[0], $multiply_op) } - sub pp_i_divide { int_binop($_[0], $divide_op) } - sub pp_i_modulo { int_binop($_[0], $modulo_op) } - - sub pp_eq { bool_numeric_binop($_[0], $eq_op) } - sub pp_ne { bool_numeric_binop($_[0], $ne_op) } - sub pp_lt { bool_numeric_binop($_[0], $lt_op) } - sub pp_gt { bool_numeric_binop($_[0], $gt_op) } - sub pp_le { bool_numeric_binop($_[0], $le_op) } - sub pp_ge { bool_numeric_binop($_[0], $ge_op) } - - sub pp_i_eq { bool_int_binop($_[0], $eq_op) } - sub pp_i_ne { bool_int_binop($_[0], $ne_op) } - sub pp_i_lt { bool_int_binop($_[0], $lt_op) } - sub pp_i_gt { bool_int_binop($_[0], $gt_op) } - sub pp_i_le { bool_int_binop($_[0], $le_op) } - sub pp_i_ge { bool_int_binop($_[0], $ge_op) } - - sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) } - sub pp_slt { bool_sv_binop($_[0], $slt_op) } - sub pp_sgt { bool_sv_binop($_[0], $sgt_op) } - sub pp_sle { bool_sv_binop($_[0], $sle_op) } - sub pp_sge { bool_sv_binop($_[0], $sge_op) } - sub pp_seq { bool_sv_binop($_[0], $seq_op) } - sub pp_sne { bool_sv_binop($_[0], $sne_op) } -} - - -sub pp_sassign { - my $op = shift; - my $backwards = $op->private & OPpASSIGN_BACKWARDS; - my ($dst, $src); - if (@stack >= 2) { - $dst = pop @stack; - $src = pop @stack; - ($src, $dst) = ($dst, $src) if $backwards; - my $type = $src->{type}; - if ($type == T_INT) { - $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); - } elsif ($type == T_DOUBLE) { - $dst->set_numeric($src->as_numeric); - } else { - $dst->set_sv($src->as_sv); - } - push(@stack, $dst); - } elsif (@stack == 1) { - if ($backwards) { - my $src = pop @stack; - my $type = $src->{type}; - runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); - if ($type == T_INT) { - if ($src->{flags} & VALID_UNSIGNED){ - runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); - }else{ - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); - } - } elsif ($type == T_DOUBLE) { - runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); - } else { - runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv); - } - runtime("SvSETMAGIC(TOPs);"); - } else { - my $dst = $stack[-1]; - my $type = $dst->{type}; - runtime("sv = POPs;"); - runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); - if ($type == T_INT) { - $dst->set_int("SvIV(sv)"); - } elsif ($type == T_DOUBLE) { - $dst->set_double("SvNV(sv)"); - } else { - runtime("SvSetMagicSV($dst->{sv}, sv);"); - $dst->invalidate; - } - } - } else { - if ($backwards) { - runtime("src = POPs; dst = TOPs;"); - } else { - runtime("dst = POPs; src = TOPs;"); - } - runtime("MAYBE_TAINT_SASSIGN_SRC(src);", - "SvSetSV(dst, src);", - "SvSETMAGIC(dst);", - "SETs(dst);"); - } - return $op->next; -} - -sub pp_preinc { - my $op = shift; - if (@stack >= 1) { - my $obj = $stack[-1]; - my $type = $obj->{type}; - if ($type == T_INT || $type == T_DOUBLE) { - $obj->set_int($obj->as_int . " + 1"); - } else { - runtime sprintf("PP_PREINC(%s);", $obj->as_sv); - $obj->invalidate(); - } - } else { - runtime sprintf("PP_PREINC(TOPs);"); - } - return $op->next; -} - - -sub pp_pushmark { - my $op = shift; - write_back_stack(); - runtime("PUSHMARK(sp);"); - return $op->next; -} - -sub pp_list { - my $op = shift; - write_back_stack(); - my $gimme = gimme($op); - if ($gimme == G_ARRAY) { # sic - runtime("POPMARK;"); # need this even though not a "full" pp_list - } else { - runtime("PP_LIST($gimme);"); - } - return $op->next; -} - -sub pp_entersub { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);"); - runtime("SPAGAIN;}"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} -sub pp_formline { - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - # See comment in pp_grepwhile to see why! - $init->add("((LISTOP*)$sym)->op_first = $sym;"); - runtime("if (PL_op == ((LISTOP*)($sym))->op_first){"); - save_or_restore_lexical_state(${$op->first}); - runtime( sprintf("goto %s;",label($op->first))); - runtime("}"); - return $op->next; -} - -sub pp_goto{ - - my $op = shift; - my $ppname = $op->ppaddr; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - my $sym=doop($op); - runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} -sub pp_enterwrite { - my $op = shift; - pp_entersub($op); -} -sub pp_leavesub{ - my $op = shift; - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){"); - runtime("\tPUTBACK;return 0;"); - runtime("}"); - doop($op); - return $op->next; -} -sub pp_leavewrite { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - # XXX Is this the right way to distinguish between it returning - # CvSTART(cv) (via doform) and pop_return()? - #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); - runtime("SPAGAIN;"); - $know_op = 0; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub doeval { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = loadop($op); - my $ppaddr = $op->ppaddr; - #runtime(qq/printf("$ppaddr type eval\n");/); - runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_entereval { doeval(@_) } -sub pp_dofile { doeval(@_) } - -#pp_require is protected by pp_entertry, so no protection for it. -sub pp_require { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); - runtime("SPAGAIN;}"); - $know_op = 1; - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - - -sub pp_entertry { - my $op = shift; - $curcop->write_back; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - my $sym = doop($op); - my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); - declare("JMPENV", $jmpbuf); - runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); - invalidate_lexicals(REGISTER|TEMPORARY); - return $op->next; -} - -sub pp_leavetry{ - my $op=shift; - default_pp($op); - runtime("PP_LEAVETRY;"); - return $op->next; -} - -sub pp_grepstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - my $sym= doop($op); - my $next=$op->next; - $next->save; - my $nexttonext=$next->next; - $nexttonext->save; - save_or_restore_lexical_state($$nexttonext); - runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", - label($nexttonext))); - return $op->next->other; -} - -sub pp_mapstart { - my $op = shift; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up - $need_freetmps = 0; - } - write_back_stack(); - # pp_mapstart can return either op_next->op_next or op_next->op_other and - # we need to be able to distinguish the two at runtime. - my $sym= doop($op); - my $next=$op->next; - $next->save; - my $nexttonext=$next->next; - $nexttonext->save; - save_or_restore_lexical_state($$nexttonext); - runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", - label($nexttonext))); - return $op->next->other; -} - -sub pp_grepwhile { - my $op = shift; - my $next = $op->next; - unshift(@bblock_todo, $next); - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - # pp_grepwhile can return either op_next or op_other and we need to - # be able to distinguish the two at runtime. Since it's possible for - # both ops to be "inlined", the fields could both be zero. To get - # around that, we hack op_next to be our own op (purely because we - # know it's a non-NULL pointer and can't be the same as op_other). - $init->add("((LOGOP*)$sym)->op_next = $sym;"); - save_or_restore_lexical_state($$next); - runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); - $know_op = 0; - return $op->other; -} - -sub pp_mapwhile { - pp_grepwhile(@_); -} - -sub pp_return { - my $op = shift; - write_back_lexicals(REGISTER|TEMPORARY); - write_back_stack(); - doop($op); - runtime("PUTBACK;", "return PL_op;"); - $know_op = 0; - return $op->next; -} - -sub nyi { - my $op = shift; - warn sprintf("%s not yet implemented properly\n", $op->ppaddr); - return default_pp($op); -} - -sub pp_range { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_WANT)) { - error("context of range unknown at compile-time"); - } - write_back_lexicals(); - write_back_stack(); - unless (($flags & OPf_WANT)== OPf_WANT_LIST) { - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - save_or_restore_lexical_state(${$op->other}); - runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", - $op->targ, label($op->other)); - unshift(@bblock_todo, $op->other); - } - return $op->next; -} - -sub pp_flip { - my $op = shift; - my $flags = $op->flags; - if (!($flags & OPf_WANT)) { - error("context of flip unknown at compile-time"); - } - if (($flags & OPf_WANT)==OPf_WANT_LIST) { - return $op->first->other; - } - write_back_lexicals(); - write_back_stack(); - # We need to save our UNOP structure since pp_flop uses - # it to find and adjust out targ. We don't need it ourselves. - $op->save; - my $ix = $op->targ; - my $rangeix = $op->first->targ; - runtime(($op->private & OPpFLIP_LINENUM) ? - "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {" - : "if (SvTRUE(TOPs)) {"); - runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); - if ($op->flags & OPf_SPECIAL) { - runtime("sv_setiv(PL_curpad[$ix], 1);"); - } else { - save_or_restore_lexical_state(${$op->first->other}); - runtime("\tsv_setiv(PL_curpad[$ix], 0);", - "\tsp--;", - sprintf("\tgoto %s;", label($op->first->other))); - } - runtime("}", - qq{sv_setpv(PL_curpad[$ix], "");}, - "SETs(PL_curpad[$ix]);"); - $know_op = 0; - return $op->next; -} - -sub pp_flop { - my $op = shift; - default_pp($op); - $know_op = 0; - return $op->next; -} - -sub enterloop { - my $op = shift; - my $nextop = $op->nextop; - my $lastop = $op->lastop; - my $redoop = $op->redoop; - $curcop->write_back; - debug "enterloop: pushing on cxstack" if $debug_cxstack; - push(@cxstack, { - type => CXt_LOOP, - op => $op, - "label" => $curcop->[0]->label, - nextop => $nextop, - lastop => $lastop, - redoop => $redoop - }); - $nextop->save; - $lastop->save; - $redoop->save; - return default_pp($op); -} - -sub pp_enterloop { enterloop(@_) } -sub pp_enteriter { enterloop(@_) } - -sub pp_leaveloop { - my $op = shift; - if (!@cxstack) { - die "panic: leaveloop"; - } - debug "leaveloop: popping from cxstack" if $debug_cxstack; - pop(@cxstack); - return default_pp($op); -} - -sub pp_next { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"next" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "next %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $nextop = $cxstack[$cxix]->{nextop}; - push(@bblock_todo, $nextop); - save_or_restore_lexical_state($$nextop); - runtime(sprintf("goto %s;", label($nextop))); - return $op->next; -} - -sub pp_redo { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"redo" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "redo %s"', $op->pv); - return $op->next; # ignore the op - } - } - default_pp($op); - my $redoop = $cxstack[$cxix]->{redoop}; - push(@bblock_todo, $redoop); - save_or_restore_lexical_state($$redoop); - runtime(sprintf("goto %s;", label($redoop))); - return $op->next; -} - -sub pp_last { - my $op = shift; - my $cxix; - if ($op->flags & OPf_SPECIAL) { - $cxix = dopoptoloop(); - if ($cxix < 0) { - error('"last" used outside loop'); - return $op->next; # ignore the op - } - } else { - $cxix = dopoptolabel($op->pv); - if ($cxix < 0) { - error('Label not found at compile time for "last %s"', $op->pv); - return $op->next; # ignore the op - } - # XXX Add support for "last" to leave non-loop blocks - if ($cxstack[$cxix]->{type} != CXt_LOOP) { - error('Use of "last" for non-loop blocks is not yet implemented'); - return $op->next; # ignore the op - } - } - default_pp($op); - my $lastop = $cxstack[$cxix]->{lastop}->next; - push(@bblock_todo, $lastop); - save_or_restore_lexical_state($$lastop); - runtime(sprintf("goto %s;", label($lastop))); - return $op->next; -} - -sub pp_subst { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - my $sym = doop($op); - my $replroot = $op->pmreplroot; - if ($$replroot) { - save_or_restore_lexical_state($$replroot); - runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", - $sym, label($replroot)); - $op->pmreplstart->save; - push(@bblock_todo, $replroot); - } - invalidate_lexicals(); - return $op->next; -} - -sub pp_substcont { - my $op = shift; - write_back_lexicals(); - write_back_stack(); - doop($op); - my $pmop = $op->other; - # warn sprintf("substcont: op = %s, pmop = %s\n", - # peekop($op), peekop($pmop));#debug -# my $pmopsym = objsym($pmop); - my $pmopsym = $pmop->save; # XXX can this recurse? -# warn "pmopsym = $pmopsym\n";#debug - save_or_restore_lexical_state(${$pmop->pmreplstart}); - runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", - $pmopsym, label($pmop->pmreplstart)); - invalidate_lexicals(); - return $pmop->next; -} - -sub default_pp { - my $op = shift; - my $ppname = "pp_" . $op->name; - if ($curcop and $need_curcop{$ppname}){ - $curcop->write_back; - } - write_back_lexicals() unless $skip_lexicals{$ppname}; - write_back_stack() unless $skip_stack{$ppname}; - doop($op); - # XXX If the only way that ops can write to a TEMPORARY lexical is - # when it's named in $op->targ then we could call - # invalidate_lexicals(TEMPORARY) and avoid having to write back all - # the temporaries. For now, we'll play it safe and write back the lot. - invalidate_lexicals() unless $skip_invalidate{$ppname}; - return $op->next; -} - -sub compile_op { - my $op = shift; - my $ppname = "pp_" . $op->name; - if (exists $ignore_op{$ppname}) { - return $op->next; - } - debug peek_stack() if $debug_stack; - if ($debug_op) { - debug sprintf("%s [%s]\n", - peekop($op), - $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ); - } - no strict 'refs'; - if (defined(&$ppname)) { - $know_op = 0; - return &$ppname($op); - } else { - return default_pp($op); - } -} - -sub compile_bblock { - my $op = shift; - #warn "compile_bblock: ", peekop($op), "\n"; # debug - save_or_restore_lexical_state($$op); - write_label($op); - $know_op = 0; - do { - $op = compile_op($op); - } while (defined($op) && $$op && !exists($leaders->{$$op})); - write_back_stack(); # boo hoo: big loss - reload_lexicals(); - return $op; -} - -sub cc { - my ($name, $root, $start, @padlist) = @_; - my $op; - if($done{$$start}){ - #warn "repeat=>".ref($start)."$name,\n";#debug - $decl->add(sprintf("#define $name %s",$done{$$start})); - return; - } - init_pp($name); - load_pad(@padlist); - %lexstate=(); - B::Pseudoreg->new_scope; - @cxstack = (); - if ($debug_timings) { - warn sprintf("Basic block analysis at %s\n", timing_info); - } - $leaders = find_leaders($root, $start); - my @leaders= keys %$leaders; - if ($#leaders > -1) { - @bblock_todo = ($start, values %$leaders) ; - } else{ - runtime("return PL_op?PL_op->op_next:0;"); - } - if ($debug_timings) { - warn sprintf("Compilation at %s\n", timing_info); - } - while (@bblock_todo) { - $op = shift @bblock_todo; - #warn sprintf("Considering basic block %s\n", peekop($op)); # debug - next if !defined($op) || !$$op || $done{$$op}; - #warn "...compiling it\n"; # debug - do { - $done{$$op} = $name; - $op = compile_bblock($op); - if ($need_freetmps && $freetmps_each_bblock) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - } while defined($op) && $$op && !$done{$$op}; - if ($need_freetmps && $freetmps_each_loop) { - runtime("FREETMPS;"); - $need_freetmps = 0; - } - if (!$$op) { - runtime("PUTBACK;","return PL_op;"); - } elsif ($done{$$op}) { - save_or_restore_lexical_state($$op); - runtime(sprintf("goto %s;", label($op))); - } - } - if ($debug_timings) { - warn sprintf("Saving runtime at %s\n", timing_info); - } - declare_pad(@padlist) ; - save_runtime(); -} - -sub cc_recurse { - my $ccinfo; - my $start; - $start = cc_queue(@_) if @_; - while ($ccinfo = shift @cc_todo) { - cc(@$ccinfo); - } - return $start; -} - -sub cc_obj { - my ($name, $cvref) = @_; - my $cv = svref_2object($cvref); - my @padlist = $cv->PADLIST->ARRAY; - my $curpad_sym = $padlist[1]->save; - cc_recurse($name, $cv->ROOT, $cv->START, @padlist); -} - -sub cc_main { - my @comppadlist = comppadlist->ARRAY; - my $curpad_nam = $comppadlist[0]->save; - my $curpad_sym = $comppadlist[1]->save; - my $init_av = init_av->save; - my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - # Do save_unused_subs before saving inc_hv - save_unused_subs(); - cc_recurse(); - - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; - my $amagic_generate= amagic_generation; - return if $errors; - if (!defined($module)) { - $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), - "PL_main_start = $start;", - "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = (AV *) $init_av;", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", - "PL_amagic_generation= $amagic_generate;", - ); - - } - seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output - output_boilerplate(); - print "\n"; - output_all("perl_init"); - output_runtime(); - print "\n"; - output_main(); - if (defined($module)) { - my $cmodule = $module; - $cmodule =~ s/::/__/g; - print <<"EOT"; - -#include "XSUB.h" -XS(boot_$cmodule) -{ - dXSARGS; - perl_init(); - ENTER; - SAVETMPS; - SAVEVPTR(PL_curpad); - SAVEVPTR(PL_op); - PL_curpad = AvARRAY($curpad_sym); - PL_op = $start; - pp_main(aTHX); - FREETMPS; - LEAVE; - ST(0) = &PL_sv_yes; - XSRETURN(1); -} -EOT - } - if ($debug_timings) { - warn sprintf("Done at %s\n", timing_info); - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "open '>$arg': $!\n"; - } elsif ($opt eq "n") { - $arg ||= shift @options; - $module_name = $arg; - } elsif ($opt eq "u") { - $arg ||= shift @options; - mark_unused($arg,undef); - } elsif ($opt eq "f") { - $arg ||= shift @options; - my $value = $arg !~ s/^no-//; - $arg =~ s/-/_/g; - my $ref = $optimise{$arg}; - if (defined($ref)) { - $$ref = $value; - } else { - warn qq(ignoring unknown optimisation option "$arg"\n); - } - } elsif ($opt eq "O") { - $arg = 1 if $arg eq ""; - my $ref; - foreach $ref (values %optimise) { - $$ref = 0; - } - if ($arg >= 2) { - $freetmps_each_loop = 1; - } - if ($arg >= 1) { - $freetmps_each_bblock = 1 unless $freetmps_each_loop; - } - } elsif ($opt eq "m") { - $arg ||= shift @options; - $module = $arg; - mark_unused($arg,undef); - } elsif ($opt eq "p") { - $arg ||= shift @options; - $patchlevel = $arg; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } elsif ($arg eq "s") { - $debug_stack = 1; - } elsif ($arg eq "c") { - $debug_cxstack = 1; - } elsif ($arg eq "p") { - $debug_pad = 1; - } elsif ($arg eq "r") { - $debug_runtime = 1; - } elsif ($arg eq "S") { - $debug_shadow = 1; - } elsif ($arg eq "q") { - $debug_queue = 1; - } elsif ($arg eq "l") { - $debug_lineno = 1; - } elsif ($arg eq "t") { - $debug_timings = 1; - } - } - } - } - init_sections(); - $init = B::Section->get("init"); - $decl = B::Section->get("decl"); - - if (@options) { - return sub { - my ($objname, $ppname); - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - ($ppname = $objname) =~ s/^.*?:://; - eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; - die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; - return if $errors; - } - output_boilerplate(); - print "\n"; - output_all($module_name || "init_module"); - output_runtime(); - } - } else { - return sub { cc_main() }; - } -} - -1; - -__END__ - -=head1 NAME - -B::CC - Perl compiler's optimized C translation backend - -=head1 SYNOPSIS - - perl -MO=CC[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This compiler backend takes Perl source and generates C source code -corresponding to the flow of your program. In other words, this -backend is somewhat a "real" compiler in the sense that many people -think about compilers. Note however that, currently, it is a very -poor compiler in that although it generates (mostly, or at least -sometimes) correct code, it performs relatively few optimisations. -This will change as the compiler develops. The result is that -running an executable compiled with this backend may start up more -quickly than running the original Perl program (a feature shared -by the B<C> compiler backend--see F<B::C>) and may also execute -slightly faster. This is by no means a good optimising compiler--yet. - -=head1 OPTIONS - -If there are any non-option arguments, they are taken to be -names of objects to be saved (probably doesn't work properly yet). -Without extra arguments, it saves the main program. - -=over 4 - -=item B<-ofilename> - -Output to filename instead of STDOUT - -=item B<-v> - -Verbose compilation (currently gives a few compilation statistics). - -=item B<--> - -Force end of options - -=item B<-uPackname> - -Force apparently unused subs from package Packname to be compiled. -This allows programs to use eval "foo()" even when sub foo is never -seen to be used at compile time. The down side is that any subs which -really are never used also have code generated. This option is -necessary, for example, if you have a signal handler foo which you -initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just -to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> -options. The compiler tries to figure out which packages may possibly -have subs in which need compiling but the current version doesn't do -it very well. In particular, it is confused by nested packages (i.e. -of the form C<A::B>) where package C<A> does not contain any subs. - -=item B<-mModulename> - -Instead of generating source for a runnable executable, generate -source for an XSUB module. The boot_Modulename function (which -DynaLoader can look for) does the appropriate initialisation and runs -the main part of the Perl source that is being compiled. - - -=item B<-D> - -Debug options (concatenated or separate flags like C<perl -D>). - -=item B<-Dr> - -Writes debugging output to STDERR just as it's about to write to the -program's runtime (otherwise writes debugging info as comments in -its C output). - -=item B<-DO> - -Outputs each OP as it's compiled - -=item B<-Ds> - -Outputs the contents of the shadow stack at each OP - -=item B<-Dp> - -Outputs the contents of the shadow pad of lexicals as it's loaded for -each sub or the main program. - -=item B<-Dq> - -Outputs the name of each fake PP function in the queue as it's about -to process it. - -=item B<-Dl> - -Output the filename and line number of each original line of Perl -code as it's processed (C<pp_nextstate>). - -=item B<-Dt> - -Outputs timing information of compilation stages. - -=item B<-f> - -Force optimisations on or off one at a time. - -=item B<-ffreetmps-each-bblock> - -Delays FREETMPS from the end of each statement to the end of the each -basic block. - -=item B<-ffreetmps-each-loop> - -Delays FREETMPS from the end of each statement to the end of the group -of basic blocks forming a loop. At most one of the freetmps-each-* -options can be used. - -=item B<-fomit-taint> - -Omits generating code for handling perl's tainting mechanism. - -=item B<-On> - -Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. -Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2> -sets B<-ffreetmps-each-loop>. - -=back - -=head1 EXAMPLES - - perl -MO=CC,-O2,-ofoo.c foo.pl - perl cc_harness -o foo foo.c - -Note that C<cc_harness> lives in the C<B> subdirectory of your perl -library directory. The utility called C<perlcc> may also be used to -help make use of this compiler. - - perl -MO=CC,-mFoo,-oFoo.c Foo.pm - perl cc_harness -shared -c -o Foo.so Foo.c - -=head1 BUGS - -Plenty. Current status: experimental. - -=head1 DIFFERENCES - -These aren't really bugs but they are constructs which are heavily -tied to perl's compile-and-go implementation and with which this -compiler backend cannot cope. - -=head2 Loops - -Standard perl calculates the target of "next", "last", and "redo" -at run-time. The compiler calculates the targets at compile-time. -For example, the program - - sub skip_on_odd { next NUMBER if $_[0] % 2 } - NUMBER: for ($i = 0; $i < 5; $i++) { - skip_on_odd($i); - print $i; - } - -produces the output - - 024 - -with standard perl but gives a compile-time error with the compiler. - -=head2 Context of ".." - -The context (scalar or array) of the ".." operator determines whether -it behaves as a range or a flip/flop. Standard perl delays until -runtime the decision of which context it is in but the compiler needs -to know the context at compile-time. For example, - - @a = (4,6,1,0,0,1); - sub range { (shift @a)..(shift @a) } - print range(); - while (@a) { print scalar(range()) } - -generates the output - - 456123E0 - -with standard Perl but gives a compile-time error with compiled Perl. - -=head2 Arithmetic - -Compiled Perl programs use native C arithmetic much more frequently -than standard perl. Operations on large numbers or on boundary -cases may produce different behaviour. - -=head2 Deprecated features - -Features of standard perl such as C<$[> which have been deprecated -in standard perl since Perl5 was released have not been implemented -in the compiler. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm deleted file mode 100644 index c84578e44c4..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Concise.pm +++ /dev/null @@ -1,1628 +0,0 @@ -package B::Concise; -# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved. -# This program is free software; you can redistribute and/or modify it -# under the same terms as Perl itself. - -# Note: we need to keep track of how many use declarations/BEGIN -# blocks this module uses, so we can avoid printing them when user -# asks for the BEGIN blocks in her program. Update the comments and -# the count in concise_specials if you add or delete one. The -# -MO=Concise counts as use #1. - -use strict; # use #2 -use warnings; # uses #3 and #4, since warnings uses Carp - -use Exporter (); # use #5 - -our $VERSION = "0.66"; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw( set_style set_style_standard add_callback - concise_subref concise_cv concise_main - add_style walk_output compile reset_sequence ); -our %EXPORT_TAGS = - ( io => [qw( walk_output compile reset_sequence )], - style => [qw( add_style set_style_standard )], - cb => [qw( add_callback )], - mech => [qw( concise_subref concise_cv concise_main )], ); - -# use #6 -use B qw(class ppname main_start main_root main_cv cstring svref_2object - SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL - CVf_ANON); - -my %style = - ("terse" => - ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " - . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", - "(*( )*)goto #class (#addr)\n", - "#class pp_#name"], - "concise" => - ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " - . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n" - , " (*( )*) goto #seq\n", - "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], - "linenoise" => - ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", - "gt_#seq ", - "(?(#seq)?)#noise#arg(?([#targarg])?)"], - "debug" => - ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" - . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . - ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n") - . "\top_flags\t#flagval\n\top_private\t#privval\n" - . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" - . "(?(\top_sv\t\t#svaddr\n)?)", - " GOTO #addr\n", - "#addr"], - "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, - $ENV{B_CONCISE_TREE_FORMAT}], - ); - -# Renderings, ie how Concise prints, is controlled by these vars -# primary: -our $stylename; # selects current style from %style -my $order = "basic"; # how optree is walked & printed: basic, exec, tree - -# rendering mechanics: -# these 'formats' are the line-rendering templates -# they're updated from %style when $stylename changes -my ($format, $gotofmt, $treefmt); - -# lesser players: -my $base = 36; # how <sequence#> is displayed -my $big_endian = 1; # more <sequence#> display -my $tree_style = 0; # tree-order details -my $banner = 1; # print banner before optree is traversed -my $do_main = 0; # force printing of main routine - -# another factor: can affect all styles! -our @callbacks; # allow external management - -set_style_standard("concise"); - -my $curcv; -my $cop_seq_base; - -sub set_style { - ($format, $gotofmt, $treefmt) = @_; - #warn "set_style: deprecated, use set_style_standard instead\n"; # someday - die "expecting 3 style-format args\n" unless @_ == 3; -} - -sub add_style { - my ($newstyle,@args) = @_; - die "style '$newstyle' already exists, choose a new name\n" - if exists $style{$newstyle}; - die "expecting 3 style-format args\n" unless @args == 3; - $style{$newstyle} = [@args]; - $stylename = $newstyle; # update rendering state -} - -sub set_style_standard { - ($stylename) = @_; # update rendering state - die "err: style '$stylename' unknown\n" unless exists $style{$stylename}; - set_style(@{$style{$stylename}}); -} - -sub add_callback { - push @callbacks, @_; -} - -# output handle, used with all Concise-output printing -our $walkHandle; # public for your convenience -BEGIN { $walkHandle = \*STDOUT } - -sub walk_output { # updates $walkHandle - my $handle = shift; - return $walkHandle unless $handle; # allow use as accessor - - if (ref $handle eq 'SCALAR') { - require Config; - die "no perlio in this build, can't call walk_output (\\\$scalar)\n" - unless $Config::Config{useperlio}; - # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string - open my $tmp, '>', $handle; # but cant re-set existing STDOUT - $walkHandle = $tmp; # so use my $tmp as intermediate var - return $walkHandle; - } - my $iotype = ref $handle; - die "expecting argument/object that can print\n" - unless $iotype eq 'GLOB' or $iotype and $handle->can('print'); - $walkHandle = $handle; -} - -sub concise_subref { - my($order, $coderef, $name) = @_; - my $codeobj = svref_2object($coderef); - - return concise_stashref(@_) - unless ref $codeobj eq 'B::CV'; - concise_cv_obj($order, $codeobj, $name); -} - -sub concise_stashref { - my($order, $h) = @_; - foreach my $k (sort keys %$h) { - local *s = $h->{$k}; - my $coderef = *s{CODE} or next; - reset_sequence(); - print "FUNC: ", *s, "\n"; - my $codeobj = svref_2object($coderef); - next unless ref $codeobj eq 'B::CV'; - eval { concise_cv_obj($order, $codeobj) } - or warn "err $@ on $codeobj"; - } -} - -# This should have been called concise_subref, but it was exported -# under this name in versions before 0.56 -*concise_cv = \&concise_subref; - -sub concise_cv_obj { - my ($order, $cv, $name) = @_; - # name is either a string, or a CODE ref (copy of $cv arg??) - - $curcv = $cv; - if ($cv->XSUB) { - print $walkHandle "$name is XS code\n"; - return; - } - if (class($cv->START) eq "NULL") { - no strict 'refs'; - if (ref $name eq 'CODE') { - print $walkHandle "coderef $name has no START\n"; - } - elsif (exists &$name) { - print $walkHandle "$name exists in stash, but has no START\n"; - } - else { - print $walkHandle "$name not in symbol table\n"; - } - return; - } - sequence($cv->START); - if ($order eq "exec") { - walk_exec($cv->START); - } - elsif ($order eq "basic") { - # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); - my $root = $cv->ROOT; - unless (ref $root eq 'B::NULL') { - walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0); - } else { - print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n"; - } - } else { - print $walkHandle tree($cv->ROOT, 0); - } -} - -sub concise_main { - my($order) = @_; - sequence(main_start); - $curcv = main_cv; - if ($order eq "exec") { - return if class(main_start) eq "NULL"; - walk_exec(main_start); - } elsif ($order eq "tree") { - return if class(main_root) eq "NULL"; - print $walkHandle tree(main_root, 0); - } elsif ($order eq "basic") { - return if class(main_root) eq "NULL"; - walk_topdown(main_root, - sub { $_[0]->concise($_[1]) }, 0); - } -} - -sub concise_specials { - my($name, $order, @cv_s) = @_; - my $i = 1; - if ($name eq "BEGIN") { - splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ?? - } elsif ($name eq "CHECK") { - pop @cv_s; # skip the CHECK block that calls us - } - for my $cv (@cv_s) { - print $walkHandle "$name $i:\n"; - $i++; - concise_cv_obj($order, $cv, $name); - } -} - -my $start_sym = "\e(0"; # "\cN" sometimes also works -my $end_sym = "\e(B"; # "\cO" respectively - -my @tree_decorations = - ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], - [" ", "-", "+", "+", "|", "`", "", 0], - [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], - [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], - ); - - -sub compileOpts { - # set rendering state from options and args - my (@options,@args); - if (@_) { - @options = grep(/^-/, @_); - @args = grep(!/^-/, @_); - } - for my $o (@options) { - # mode/order - if ($o eq "-basic") { - $order = "basic"; - } elsif ($o eq "-exec") { - $order = "exec"; - } elsif ($o eq "-tree") { - $order = "tree"; - } - # tree-specific - elsif ($o eq "-compact") { - $tree_style |= 1; - } elsif ($o eq "-loose") { - $tree_style &= ~1; - } elsif ($o eq "-vt") { - $tree_style |= 2; - } elsif ($o eq "-ascii") { - $tree_style &= ~2; - } - # sequence numbering - elsif ($o =~ /^-base(\d+)$/) { - $base = $1; - } elsif ($o eq "-bigendian") { - $big_endian = 1; - } elsif ($o eq "-littleendian") { - $big_endian = 0; - } - elsif ($o eq "-nobanner") { - $banner = 0; - } elsif ($o eq "-banner") { - $banner = 1; - } - elsif ($o eq "-main") { - $do_main = 1; - } elsif ($o eq "-nomain") { - $do_main = 0; - } - # line-style options - elsif (exists $style{substr($o, 1)}) { - $stylename = substr($o, 1); - set_style_standard($stylename); - } else { - warn "Option $o unrecognized"; - } - } - return (@args); -} - -sub compile { - my (@args) = compileOpts(@_); - return sub { - my @newargs = compileOpts(@_); # accept new rendering options - warn "disregarding non-options: @newargs\n" if @newargs; - - for my $objname (@args) { - next unless $objname; # skip null args to avoid noisy responses - - if ($objname eq "BEGIN") { - concise_specials("BEGIN", $order, - B::begin_av->isa("B::AV") ? - B::begin_av->ARRAY : ()); - } elsif ($objname eq "INIT") { - concise_specials("INIT", $order, - B::init_av->isa("B::AV") ? - B::init_av->ARRAY : ()); - } elsif ($objname eq "CHECK") { - concise_specials("CHECK", $order, - B::check_av->isa("B::AV") ? - B::check_av->ARRAY : ()); - } elsif ($objname eq "END") { - concise_specials("END", $order, - B::end_av->isa("B::AV") ? - B::end_av->ARRAY : ()); - } - else { - # convert function names to subrefs - my $objref; - if (ref $objname) { - print $walkHandle "B::Concise::compile($objname)\n" - if $banner; - $objref = $objname; - } else { - $objname = "main::" . $objname unless $objname =~ /::/; - print $walkHandle "$objname:\n"; - no strict 'refs'; - unless (exists &$objname) { - print $walkHandle "err: unknown function ($objname)\n"; - return; - } - $objref = \&$objname; - } - concise_subref($order, $objref, $objname); - } - } - if (!@args or $do_main) { - print $walkHandle "main program:\n" if $do_main; - concise_main($order); - } - return @args; # something - } -} - -my %labels; -my $lastnext; # remembers op-chain, used to insert gotos - -my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", - 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", - 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#"); - -no warnings 'qw'; # "Possible attempt to put comments..."; use #7 -my @linenoise = - qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl - ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I - -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< - > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i - ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy - uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ - a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} - v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o - ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v - ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r - -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd - co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 - g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e - e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn - Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO'; - -my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; - -sub op_flags { # common flags (see BASOP.op_flags in op.h) - my($x) = @_; - my(@v); - push @v, "v" if ($x & 3) == 1; - push @v, "s" if ($x & 3) == 2; - push @v, "l" if ($x & 3) == 3; - push @v, "K" if $x & 4; - push @v, "P" if $x & 8; - push @v, "R" if $x & 16; - push @v, "M" if $x & 32; - push @v, "S" if $x & 64; - push @v, "*" if $x & 128; - return join("", @v); -} - -sub base_n { - my $x = shift; - return "-" . base_n(-$x) if $x < 0; - my $str = ""; - do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); - $str = reverse $str if $big_endian; - return $str; -} - -my %sequence_num; -my $seq_max = 1; - -sub reset_sequence { - # reset the sequence - %sequence_num = (); - $seq_max = 1; - $lastnext = 0; -} - -sub seq { - my($op) = @_; - return "-" if not exists $sequence_num{$$op}; - return base_n($sequence_num{$$op}); -} - -sub walk_topdown { - my($op, $sub, $level) = @_; - $sub->($op, $level); - if ($op->flags & OPf_KIDS) { - for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { - walk_topdown($kid, $sub, $level + 1); - } - } - elsif (class($op) eq "PMOP") { - my $maybe_root = $op->pmreplroot; - if (ref($maybe_root) and $maybe_root->isa("B::OP")) { - # It really is the root of the replacement, not something - # else stored here for lack of space elsewhere - walk_topdown($maybe_root, $sub, $level + 1); - } - } -} - -sub walklines { - my($ar, $level) = @_; - for my $l (@$ar) { - if (ref($l) eq "ARRAY") { - walklines($l, $level + 1); - } else { - $l->concise($level); - } - } -} - -sub walk_exec { - my($top, $level) = @_; - my %opsseen; - my @lines; - my @todo = ([$top, \@lines]); - while (@todo and my($op, $targ) = @{shift @todo}) { - for (; $$op; $op = $op->next) { - last if $opsseen{$$op}++; - push @$targ, $op; - my $name = $op->name; - if (class($op) eq "LOGOP") { - my $ar = []; - push @$targ, $ar; - push @todo, [$op->other, $ar]; - } elsif ($name eq "subst" and $ {$op->pmreplstart}) { - my $ar = []; - push @$targ, $ar; - push @todo, [$op->pmreplstart, $ar]; - } elsif ($name =~ /^enter(loop|iter)$/) { - if ($] > 5.009) { - $labels{${$op->nextop}} = "NEXT"; - $labels{${$op->lastop}} = "LAST"; - $labels{${$op->redoop}} = "REDO"; - } else { - $labels{$op->nextop->seq} = "NEXT"; - $labels{$op->lastop->seq} = "LAST"; - $labels{$op->redoop->seq} = "REDO"; - } - } - } - } - walklines(\@lines, 0); -} - -# The structure of this routine is purposely modeled after op.c's peep() -sub sequence { - my($op) = @_; - my $oldop = 0; - return if class($op) eq "NULL" or exists $sequence_num{$$op}; - for (; $$op; $op = $op->next) { - last if exists $sequence_num{$$op}; - my $name = $op->name; - if ($name =~ /^(null|scalar|lineseq|scope)$/) { - next if $oldop and $ {$op->next}; - } else { - $sequence_num{$$op} = $seq_max++; - if (class($op) eq "LOGOP") { - my $other = $op->other; - $other = $other->next while $other->name eq "null"; - sequence($other); - } elsif (class($op) eq "LOOP") { - my $redoop = $op->redoop; - $redoop = $redoop->next while $redoop->name eq "null"; - sequence($redoop); - my $nextop = $op->nextop; - $nextop = $nextop->next while $nextop->name eq "null"; - sequence($nextop); - my $lastop = $op->lastop; - $lastop = $lastop->next while $lastop->name eq "null"; - sequence($lastop); - } elsif ($name eq "subst" and $ {$op->pmreplstart}) { - my $replstart = $op->pmreplstart; - $replstart = $replstart->next while $replstart->name eq "null"; - sequence($replstart); - } - } - $oldop = $op; - } -} - -sub fmt_line { # generate text-line for op. - my($hr, $op, $text, $level) = @_; - - $_->($hr, $op, \$text, \$level, $stylename) for @callbacks; - - return '' if $hr->{SKIP}; # suppress line if a callback said so - return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere - - # spec: (?(text1#varText2)?) - $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ - $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; - - # spec: (x(exec_text;basic_text)x) - $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; - - # spec: (*(text)*) - $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; - - # spec: (*(text1;text2)*) - $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; - - # convert #Var to tag=>val form: Var\t#var - $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs; - - # spec: #varN - $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; - - $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's - $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes - chomp $text; - return "$text\n" if $text ne ""; - return $text; # suppress empty lines -} - -our %priv; # used to display each opcode's BASEOP.op_private values - -$priv{$_}{128} = "LVINTRO" - for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", - "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", - "padav", "padhv", "enteriter"); -$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); -$priv{"aassign"}{64} = "COMMON"; -$priv{"aassign"}{32} = "PHASH" if $] < 5.009; -$priv{"sassign"}{64} = "BKWARD"; -$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr"); -@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL", - "COMPL", "GROWS"); -$priv{"repeat"}{64} = "DOLIST"; -$priv{"leaveloop"}{64} = "CONT"; -@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") - for (qw(rv2gv rv2sv padsv aelem helem)); -@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD"); -@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); -$priv{"gv"}{32} = "EARLYCV"; -$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; -$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv", - "enteriter"); -$priv{$_}{16} = "TARGMY" - for (map(($_,"s$_"),"chop", "chomp"), - map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", - "add", "subtract", "negate"), "pow", "concat", "stringify", - "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", - "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", - "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", - "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", - "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", - "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", - "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", - "setpriority", "time", "sleep"); -$priv{$_}{4} = "REVERSED" for ("enteriter", "iter"); -@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN"); -$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; -$priv{"list"}{64} = "GUESSED"; -$priv{"delete"}{64} = "SLICE"; -$priv{"exists"}{64} = "SUB"; -$priv{$_}{64} = "LOCALE" - for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", - "scmp", "lc", "uc", "lcfirst", "ucfirst"); -@{$priv{"sort"}}{1,2,4,8,16} = ("NUM", "INT", "REV", "INPLACE","DESC"); -$priv{"threadsv"}{64} = "SVREFd"; -@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR") - for ("open", "backtick"); -$priv{"exit"}{128} = "VMS"; -$priv{$_}{2} = "FTACCESS" - for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec"); -if ($] >= 5.009) { - # Stacked filetests are post 5.8.x - $priv{$_}{4} = "FTSTACKED" - for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec", - "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime", - "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir", - "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext", - "ftbinary"); - # Lexical $_ is post 5.8.x - $priv{$_}{2} = "GREPLEX" - for ("mapwhile", "mapstart", "grepwhile", "grepstart"); -} - -sub private_flags { - my($name, $x) = @_; - my @s; - for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { - if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { - $x -= $flag; - push @s, $priv{$name}{$flag}; - } - } - push @s, $x if $x; - return join(",", @s); -} - -sub concise_sv { - my($sv, $hr, $preferpv) = @_; - $hr->{svclass} = class($sv); - $hr->{svclass} = "UV" - if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV; - Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv; - $hr->{svaddr} = sprintf("%#x", $$sv); - if ($hr->{svclass} eq "GV") { - my $gv = $sv; - my $stash = $gv->STASH->NAME; - if ($stash eq "main") { - $stash = ""; - } else { - $stash = $stash . "::"; - } - $hr->{svval} = "*$stash" . $gv->SAFENAME; - return "*$stash" . $gv->SAFENAME; - } else { - while (class($sv) eq "RV") { - $hr->{svval} .= "\\"; - $sv = $sv->RV; - } - if (class($sv) eq "SPECIAL") { - $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; - } elsif ($preferpv && $sv->FLAGS & SVf_POK) { - $hr->{svval} .= cstring($sv->PV); - } elsif ($sv->FLAGS & SVf_NOK) { - $hr->{svval} .= $sv->NV; - } elsif ($sv->FLAGS & SVf_IOK) { - $hr->{svval} .= $sv->int_value; - } elsif ($sv->FLAGS & SVf_POK) { - $hr->{svval} .= cstring($sv->PV); - } elsif (class($sv) eq "HV") { - $hr->{svval} .= 'HASH'; - } - - $hr->{svval} = 'undef' unless defined $hr->{svval}; - my $out = $hr->{svclass}; - return $out .= " $hr->{svval}" ; - } -} - -sub concise_op { - my ($op, $level, $format) = @_; - my %h; - $h{exname} = $h{name} = $op->name; - $h{NAME} = uc $h{name}; - $h{class} = class($op); - $h{extarg} = $h{targ} = $op->targ; - $h{extarg} = "" unless $h{extarg}; - if ($h{name} eq "null" and $h{targ}) { - # targ holds the old type - $h{exname} = "ex-" . substr(ppname($h{targ}), 3); - $h{extarg} = ""; - } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) { - # targ potentially holds a reference count - if ($op->private & 64) { - my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); - $h{targarglife} = $h{targarg} = "$h{targ} $refs"; - } - } elsif ($h{targ}) { - my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; - if (defined $padname and class($padname) ne "SPECIAL") { - $h{targarg} = $padname->PVX; - if ($padname->FLAGS & SVf_FAKE) { - if ($] < 5.009) { - $h{targarglife} = "$h{targarg}:FAKE"; - } else { - # These changes relate to the jumbo closure fix. - # See changes 19939 and 20005 - my $fake = ''; - $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON - $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI - $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON; - $h{targarglife} = "$h{targarg}:FAKE:$fake"; - } - } - else { - my $intro = $padname->NVX - $cop_seq_base; - my $finish = int($padname->IVX) - $cop_seq_base; - $finish = "end" if $finish == 999999999 - $cop_seq_base; - $h{targarglife} = "$h{targarg}:$intro,$finish"; - } - } else { - $h{targarglife} = $h{targarg} = "t" . $h{targ}; - } - } - $h{arg} = ""; - $h{svclass} = $h{svaddr} = $h{svval} = ""; - if ($h{class} eq "PMOP") { - my $precomp = $op->precomp; - if (defined $precomp) { - $precomp = cstring($precomp); # Escape literal control sequences - $precomp = "/$precomp/"; - } else { - $precomp = ""; - } - my $pmreplroot = $op->pmreplroot; - my $pmreplstart; - if (ref($pmreplroot) eq "B::GV") { - # with C<@stash_array = split(/pat/, str);>, - # *stash_array is stored in /pat/'s pmreplroot. - $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")"; - } elsif (!ref($pmreplroot) and $pmreplroot) { - # same as the last case, except the value is actually a - # pad offset for where the GV is kept (this happens under - # ithreads) - my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot]; - $h{arg} = "($precomp => \@" . $gv->NAME . ")"; - } elsif ($ {$op->pmreplstart}) { - undef $lastnext; - $pmreplstart = "replstart->" . seq($op->pmreplstart); - $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; - } else { - $h{arg} = "($precomp)"; - } - } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { - $h{arg} = '("' . $op->pv . '")'; - $h{svval} = '"' . $op->pv . '"'; - } elsif ($h{class} eq "COP") { - my $label = $op->label; - $h{coplabel} = $label; - $label = $label ? "$label: " : ""; - my $loc = $op->file; - $loc =~ s[.*/][]; - $loc .= ":" . $op->line; - my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); - my $arybase = $op->arybase; - $arybase = $arybase ? ' $[=' . $arybase : ""; - $h{arg} = "($label$stash $cseq $loc$arybase)"; - } elsif ($h{class} eq "LOOP") { - $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) - . " redo->" . seq($op->redoop) . ")"; - } elsif ($h{class} eq "LOGOP") { - undef $lastnext; - $h{arg} = "(other->" . seq($op->other) . ")"; - } - elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { - unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { - my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix; - my $preferpv = $h{name} eq "method_named"; - if ($h{class} eq "PADOP" or !${$op->sv}) { - my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx]; - $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]"; - $h{targarglife} = $h{targarg} = ""; - } else { - $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")"; - } - } - } - $h{seq} = $h{hyphseq} = seq($op); - $h{seq} = "" if $h{seq} eq "-"; - if ($] > 5.009) { - $h{opt} = $op->opt; - $h{static} = $op->static; - $h{label} = $labels{$$op}; - } else { - $h{seqnum} = $op->seq; - $h{label} = $labels{$op->seq}; - } - $h{next} = $op->next; - $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); - $h{nextaddr} = sprintf("%#x", $ {$op->next}); - $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); - $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); - $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); - - $h{classsym} = $opclass{$h{class}}; - $h{flagval} = $op->flags; - $h{flags} = op_flags($op->flags); - $h{privval} = $op->private; - $h{private} = private_flags($h{name}, $op->private); - $h{addr} = sprintf("%#x", $$op); - $h{typenum} = $op->type; - $h{noise} = $linenoise[$op->type]; - - return fmt_line(\%h, $op, $format, $level); -} - -sub B::OP::concise { - my($op, $level) = @_; - if ($order eq "exec" and $lastnext and $$lastnext != $$op) { - # insert a 'goto' line - my $synth = {"seq" => seq($lastnext), "class" => class($lastnext), - "addr" => sprintf("%#x", $$lastnext), - "goto" => seq($lastnext), # simplify goto '-' removal - }; - print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1); - } - $lastnext = $op->next; - print $walkHandle concise_op($op, $level, $format); -} - -# B::OP::terse (see Terse.pm) now just calls this -sub b_terse { - my($op, $level) = @_; - - # This isn't necessarily right, but there's no easy way to get - # from an OP to the right CV. This is a limitation of the - # ->terse() interface style, and there isn't much to do about - # it. In particular, we can die in concise_op if the main pad - # isn't long enough, or has the wrong kind of entries, compared to - # the pad a sub was compiled with. The fix for that would be to - # make a backwards compatible "terse" format that never even - # looked at the pad, just like the old B::Terse. I don't think - # that's worth the effort, though. - $curcv = main_cv unless $curcv; - - if ($order eq "exec" and $lastnext and $$lastnext != $$op) { - # insert a 'goto' - my $h = {"seq" => seq($lastnext), "class" => class($lastnext), - "addr" => sprintf("%#x", $$lastnext)}; - print # $walkHandle - fmt_line($h, $op, $style{"terse"}[1], $level+1); - } - $lastnext = $op->next; - print # $walkHandle - concise_op($op, $level, $style{"terse"}[0]); -} - -sub tree { - my $op = shift; - my $level = shift; - my $style = $tree_decorations[$tree_style]; - my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; - my $name = concise_op($op, $level, $treefmt); - if (not $op->flags & OPf_KIDS) { - return $name . "\n"; - } - my @lines; - for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { - push @lines, tree($kid, $level+1); - } - my $i; - for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { - $lines[$i] = $space . $lines[$i]; - } - if ($i > 0) { - $lines[$i] = $last . $lines[$i]; - while ($i-- > 1) { - if (substr($lines[$i], 0, 1) eq " ") { - $lines[$i] = $nokid . $lines[$i]; - } else { - $lines[$i] = $kid . $lines[$i]; - } - } - $lines[$i] = $kids . $lines[$i]; - } else { - $lines[0] = $single . $lines[0]; - } - return("$name$lead" . shift @lines, - map(" " x (length($name)+$size) . $_, @lines)); -} - -# *** Warning: fragile kludge ahead *** -# Because the B::* modules run in the same interpreter as the code -# they're compiling, their presence tends to distort the view we have of -# the code we're looking at. In particular, perl gives sequence numbers -# to COPs. If the program we're looking at were run on its own, this -# would start at 1. Because all of B::Concise and all the modules it -# uses are compiled first, though, by the time we get to the user's -# program the sequence number is already pretty high, which could be -# distracting if you're trying to tell OPs apart. Therefore we'd like to -# subtract an offset from all the sequence numbers we display, to -# restore the simpler view of the world. The trick is to know what that -# offset will be, when we're still compiling B::Concise! If we -# hardcoded a value, it would have to change every time B::Concise or -# other modules we use do. To help a little, what we do here is compile -# a little code at the end of the module, and compute the base sequence -# number for the user's program as being a small offset later, so all we -# have to worry about are changes in the offset. - -# [For 5.8.x and earlier perl is generating sequence numbers for all ops, -# and using them to reference labels] - - -# When you say "perl -MO=Concise -e '$a'", the output should look like: - -# 4 <@> leave[t1] vKP/REFC ->(end) -# 1 <0> enter ->2 - #^ smallest OP sequence number should be 1 -# 2 <;> nextstate(main 1 -e:1) v ->3 - # ^ smallest COP sequence number should be 1 -# - <1> ex-rv2sv vK/1 ->4 -# 3 <$> gvsv(*a) s ->4 - -# If the second of the marked numbers there isn't 1, it means you need -# to update the corresponding magic number in the next line. -# Remember, this needs to stay the last things in the module. - -# Why is this different for MacOS? Does it matter? -my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11; -$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum; - -1; - -__END__ - -=head1 NAME - -B::Concise - Walk Perl syntax tree, printing concise info about ops - -=head1 SYNOPSIS - - perl -MO=Concise[,OPTIONS] foo.pl - - use B::Concise qw(set_style add_callback); - -=head1 DESCRIPTION - -This compiler backend prints the internal OPs of a Perl program's syntax -tree in one of several space-efficient text formats suitable for debugging -the inner workings of perl or other compiler backends. It can print OPs in -the order they appear in the OP tree, in the order they will execute, or -in a text approximation to their tree structure, and the format of the -information displayed is customizable. Its function is similar to that of -perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more -sophisticated and flexible. - -=head1 EXAMPLE - -Here's an example of 2 outputs (aka 'renderings'), using the --exec and -basic (i.e. default) formatting conventions on the same code -snippet. - - % perl -MO=Concise,-exec -e '$a = $b + 42' - 1 <0> enter - 2 <;> nextstate(main 1 -e:1) v - 3 <#> gvsv[*b] s - 4 <$> const[IV 42] s - * 5 <2> add[t3] sK/2 - 6 <#> gvsv[*a] s - 7 <2> sassign vKS/2 - 8 <@> leave[1 ref] vKP/REFC - -Each line corresponds to an opcode. The opcode marked with '*' is used -in a few examples below. - -The 1st column is the op's sequence number, starting at 1, and is -displayed in base 36 by default. This rendering is in -exec (i.e. -execution) order. - -The symbol between angle brackets indicates the op's type, for -example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is -used in threaded perls. (see L</"OP class abbreviations">). - -The opname, as in B<'add[t1]'>, which may be followed by op-specific -information in parentheses or brackets (ex B<'[t1]'>). - -The op-flags (ex B<'sK/2'>) follow, and are described in (L</"OP flags -abbreviations">). - - % perl -MO=Concise -e '$a = $b + 42' - 8 <@> leave[1 ref] vKP/REFC ->(end) - 1 <0> enter ->2 - 2 <;> nextstate(main 1 -e:1) v ->3 - 7 <2> sassign vKS/2 ->8 - * 5 <2> add[t1] sK/2 ->6 - - <1> ex-rv2sv sK/1 ->4 - 3 <$> gvsv(*b) s ->4 - 4 <$> const(IV 42) s ->5 - - <1> ex-rv2sv sKRM*/1 ->7 - 6 <$> gvsv(*a) s ->7 - -The default rendering is top-down, so they're not in execution order. -This form reflects the way the stack is used to parse and evaluate -expressions; the add operates on the two terms below it in the tree. - -Nullops appear as C<ex-opname>, where I<opname> is an op that has been -optimized away by perl. They're displayed with a sequence-number of -'-', because they are not executed (they don't appear in previous -example), they're printed here because they reflect the parse. - -The arrow points to the sequence number of the next op; they're not -displayed in -exec mode, for obvious reasons. - -Note that because this rendering was done on a non-threaded perl, the -PADOPs in the previous examples are now SVOPs, and some (but not all) -of the square brackets have been replaced by round ones. This is a -subtle feature to provide some visual distinction between renderings -on threaded and un-threaded perls. - - -=head1 OPTIONS - -Arguments that don't start with a hyphen are taken to be the names of -subroutines to print the OPs of; if no such functions are specified, -the main body of the program (outside any subroutines, and not -including use'd or require'd files) is rendered. Passing C<BEGIN>, -C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding -special blocks to be printed. - -Options affect how things are rendered (ie printed). They're presented -here by their visual effect, 1st being strongest. They're grouped -according to how they interrelate; within each group the options are -mutually exclusive (unless otherwise stated). - -=head2 Options for Opcode Ordering - -These options control the 'vertical display' of opcodes. The display -'order' is also called 'mode' elsewhere in this document. - -=over 4 - -=item B<-basic> - -Print OPs in the order they appear in the OP tree (a preorder -traversal, starting at the root). The indentation of each OP shows its -level in the tree, and the '->' at the end of the line indicates the -next opcode in execution order. This mode is the default, so the flag -is included simply for completeness. - -=item B<-exec> - -Print OPs in the order they would normally execute (for the majority -of constructs this is a postorder traversal of the tree, ending at the -root). In most cases the OP that usually follows a given OP will -appear directly below it; alternate paths are shown by indentation. In -cases like loops when control jumps out of a linear path, a 'goto' -line is generated. - -=item B<-tree> - -Print OPs in a text approximation of a tree, with the root of the tree -at the left and 'left-to-right' order of children transformed into -'top-to-bottom'. Because this mode grows both to the right and down, -it isn't suitable for large programs (unless you have a very wide -terminal). - -=back - -=head2 Options for Line-Style - -These options select the line-style (or just style) used to render -each opcode, and dictates what info is actually printed into each line. - -=over 4 - -=item B<-concise> - -Use the author's favorite set of formatting conventions. This is the -default, of course. - -=item B<-terse> - -Use formatting conventions that emulate the output of B<B::Terse>. The -basic mode is almost indistinguishable from the real B<B::Terse>, and the -exec mode looks very similar, but is in a more logical order and lacks -curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode -is only vaguely reminiscent of B<B::Terse>. - -=item B<-linenoise> - -Use formatting conventions in which the name of each OP, rather than being -written out in full, is represented by a one- or two-character abbreviation. -This is mainly a joke. - -=item B<-debug> - -Use formatting conventions reminiscent of B<B::Debug>; these aren't -very concise at all. - -=item B<-env> - -Use formatting conventions read from the environment variables -C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>. - -=back - -=head2 Options for tree-specific formatting - -=over 4 - -=item B<-compact> - -Use a tree format in which the minimum amount of space is used for the -lines connecting nodes (one character in most cases). This squeezes out -a few precious columns of screen real estate. - -=item B<-loose> - -Use a tree format that uses longer edges to separate OP nodes. This format -tends to look better than the compact one, especially in ASCII, and is -the default. - -=item B<-vt> - -Use tree connecting characters drawn from the VT100 line-drawing set. -This looks better if your terminal supports it. - -=item B<-ascii> - -Draw the tree with standard ASCII characters like C<+> and C<|>. These don't -look as clean as the VT100 characters, but they'll work with almost any -terminal (or the horizontal scrolling mode of less(1)) and are suitable -for text documentation or email. This is the default. - -=back - -These are pairwise exclusive, i.e. compact or loose, vt or ascii. - -=head2 Options controlling sequence numbering - -=over 4 - -=item B<-base>I<n> - -Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the -digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit -for 37 will be 'A', and so on until 62. Values greater than 62 are not -currently supported. The default is 36. - -=item B<-bigendian> - -Print sequence numbers with the most significant digit first. This is the -usual convention for Arabic numerals, and the default. - -=item B<-littleendian> - -Print seqence numbers with the least significant digit first. This is -obviously mutually exclusive with bigendian. - -=back - -=head2 Other options - -These are pairwise exclusive. - -=over 4 - -=item B<-main> - -Include the main program in the output, even if subroutines were also -specified. This rendering is normally suppressed when a subroutine -name or reference is given. - -=item B<-nomain> - -This restores the default behavior after you've changed it with '-main' -(it's not normally needed). If no subroutine name/ref is given, main is -rendered, regardless of this flag. - -=item B<-nobanner> - -Renderings usually include a banner line identifying the function name -or stringified subref. This suppresses the printing of the banner. - -TBC: Remove the stringified coderef; while it provides a 'cookie' for -each function rendered, the cookies used should be 1,2,3.. not a -random hex-address. It also complicates string comparison of two -different trees. - -=item B<-banner> - -restores default banner behavior. - -=item B<-banneris> => subref - -TBC: a hookpoint (and an option to set it) for a user-supplied -function to produce a banner appropriate for users needs. It's not -ideal, because the rendering-state variables, which are a natural -candidate for use in concise.t, are unavailable to the user. - -=back - -=head2 Option Stickiness - -If you invoke Concise more than once in a program, you should know that -the options are 'sticky'. This means that the options you provide in -the first call will be remembered for the 2nd call, unless you -re-specify or change them. - -=head1 ABBREVIATIONS - -The concise style uses symbols to convey maximum info with minimal -clutter (like hex addresses). With just a little practice, you can -start to see the flowers, not just the branches, in the trees. - -=head2 OP class abbreviations - -These symbols appear before the op-name, and indicate the -B:: namespace that represents the ops in your Perl code. - - 0 OP (aka BASEOP) An OP with no children - 1 UNOP An OP with one child - 2 BINOP An OP with two children - | LOGOP A control branch OP - @ LISTOP An OP that could have lots of children - / PMOP An OP with a regular expression - $ SVOP An OP with an SV - " PVOP An OP with a string - { LOOP An OP that holds pointers for a loop - ; COP An OP that marks the start of a statement - # PADOP An OP with a GV on the pad - -=head2 OP flags abbreviations - -OP flags are either public or private. The public flags alter the -behavior of each opcode in consistent ways, and are represented by 0 -or more single characters. - - v OPf_WANT_VOID Want nothing (void context) - s OPf_WANT_SCALAR Want single value (scalar context) - l OPf_WANT_LIST Want list of any length (list context) - Want is unknown - K OPf_KIDS There is a firstborn child. - P OPf_PARENS This operator was parenthesized. - (Or block needs explicit scope entry.) - R OPf_REF Certified reference. - (Return container, not containee). - M OPf_MOD Will modify (lvalue). - S OPf_STACKED Some arg is arriving on the stack. - * OPf_SPECIAL Do something weird for this op (see op.h) - -Private flags, if any are set for an opcode, are displayed after a '/' - - 8 <@> leave[1 ref] vKP/REFC ->(end) - 7 <2> sassign vKS/2 ->8 - -They're opcode specific, and occur less often than the public ones, so -they're represented by short mnemonics instead of single-chars; see -F<op.h> for gory details, or try this quick 2-liner: - - $> perl -MB::Concise -de 1 - DB<1> |x \%B::Concise::priv - -=head1 FORMATTING SPECIFICATIONS - -For each line-style ('concise', 'terse', 'linenoise', etc.) there are -3 format-specs which control how OPs are rendered. - -The first is the 'default' format, which is used in both basic and exec -modes to print all opcodes. The 2nd, goto-format, is used in exec -mode when branches are encountered. They're not real opcodes, and are -inserted to look like a closing curly brace. The tree-format is tree -specific. - -When a line is rendered, the correct format-spec is copied and scanned -for the following items; data is substituted in, and other -manipulations like basic indenting are done, for each opcode rendered. - -There are 3 kinds of items that may be populated; special patterns, -#vars, and literal text, which is copied verbatim. (Yes, it's a set -of s///g steps.) - -=head2 Special Patterns - -These items are the primitives used to perform indenting, and to -select text from amongst alternatives. - -=over 4 - -=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)> - -Generates I<exec_text> in exec mode, or I<basic_text> in basic mode. - -=item B<(*(>I<text>B<)*)> - -Generates one copy of I<text> for each indentation level. - -=item B<(*(>I<text1>B<;>I<text2>B<)*)> - -Generates one fewer copies of I<text1> than the indentation level, followed -by one copy of I<text2> if the indentation level is more than 0. - -=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)> - -If the value of I<var> is true (not empty or zero), generates the -value of I<var> surrounded by I<text1> and I<Text2>, otherwise -nothing. - -=item B<~> - -Any number of tildes and surrounding whitespace will be collapsed to -a single space. - -=back - -=head2 # Variables - -These #vars represent opcode properties that you may want as part of -your rendering. The '#' is intended as a private sigil; a #var's -value is interpolated into the style-line, much like "read $this". - -These vars take 3 forms: - -=over 4 - -=item B<#>I<var> - -A property named 'var' is assumed to exist for the opcodes, and is -interpolated into the rendering. - -=item B<#>I<var>I<N> - -Generates the value of I<var>, left justified to fill I<N> spaces. -Note that this means while you can have properties 'foo' and 'foo2', -you cannot render 'foo2', but you could with 'foo2a'. You would be -wise not to rely on this behavior going forward ;-) - -=item B<#>I<Var> - -This ucfirst form of #var generates a tag-value form of itself for -display; it converts '#Var' into a 'Var => #var' style, which is then -handled as described above. (Imp-note: #Vars cannot be used for -conditional-fills, because the => #var transform is done after the check -for #Var's value). - -=back - -The following variables are 'defined' by B::Concise; when they are -used in a style, their respective values are plugged into the -rendering of each opcode. - -Only some of these are used by the standard styles, the others are -provided for you to delve into optree mechanics, should you wish to -add a new style (see L</add_style> below) that uses them. You can -also add new ones using L</add_callback>. - -=over 4 - -=item B<#addr> - -The address of the OP, in hexadecimal. - -=item B<#arg> - -The OP-specific information of the OP (such as the SV for an SVOP, the -non-local exit pointers for a LOOP, etc.) enclosed in parentheses. - -=item B<#class> - -The B-determined class of the OP, in all caps. - -=item B<#classsym> - -A single symbol abbreviating the class of the OP. - -=item B<#coplabel> - -The label of the statement or block the OP is the start of, if any. - -=item B<#exname> - -The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. - -=item B<#extarg> - -The target of the OP, or nothing for a nulled OP. - -=item B<#firstaddr> - -The address of the OP's first child, in hexadecimal. - -=item B<#flags> - -The OP's flags, abbreviated as a series of symbols. - -=item B<#flagval> - -The numeric value of the OP's flags. - -=item B<#hyphseq> - -The sequence number of the OP, or a hyphen if it doesn't have one. - -=item B<#label> - -'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec -mode, or empty otherwise. - -=item B<#lastaddr> - -The address of the OP's last child, in hexadecimal. - -=item B<#name> - -The OP's name. - -=item B<#NAME> - -The OP's name, in all caps. - -=item B<#next> - -The sequence number of the OP's next OP. - -=item B<#nextaddr> - -The address of the OP's next OP, in hexadecimal. - -=item B<#noise> - -A one- or two-character abbreviation for the OP's name. - -=item B<#private> - -The OP's private flags, rendered with abbreviated names if possible. - -=item B<#privval> - -The numeric value of the OP's private flags. - -=item B<#seq> - -The sequence number of the OP. Note that this is a sequence number -generated by B::Concise. - -=item B<#seqnum> - -5.8.x and earlier only. 5.9 and later do not provide this. - -The real sequence number of the OP, as a regular number and not adjusted -to be relative to the start of the real program. (This will generally be -a fairly large number because all of B<B::Concise> is compiled before -your program is). - -=item B<#opt> - -Whether or not the op has been optimised by the peephole optimiser. - -Only available in 5.9 and later. - -=item B<#static> - -Whether or not the op is statically defined. This flag is used by the -B::C compiler backend and indicates that the op should not be freed. - -Only available in 5.9 and later. - -=item B<#sibaddr> - -The address of the OP's next youngest sibling, in hexadecimal. - -=item B<#svaddr> - -The address of the OP's SV, if it has an SV, in hexadecimal. - -=item B<#svclass> - -The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). - -=item B<#svval> - -The value of the OP's SV, if it has one, in a short human-readable format. - -=item B<#targ> - -The numeric value of the OP's targ. - -=item B<#targarg> - -The name of the variable the OP's targ refers to, if any, otherwise the -letter t followed by the OP's targ in decimal. - -=item B<#targarglife> - -Same as B<#targarg>, but followed by the COP sequence numbers that delimit -the variable's lifetime (or 'end' for a variable in an open scope) for a -variable. - -=item B<#typenum> - -The numeric value of the OP's type, in decimal. - -=back - -=head1 Using B::Concise outside of the O framework - -The common (and original) usage of B::Concise was for command-line -renderings of simple code, as given in EXAMPLE. But you can also use -B<B::Concise> from your code, and call compile() directly, and -repeatedly. By doing so, you can avoid the compile-time only -operation of O.pm, and even use the debugger to step through -B::Concise::compile() itself. - -Once you're doing this, you may alter Concise output by adding new -rendering styles, and by optionally adding callback routines which -populate new variables, if such were referenced from those (just -added) styles. - -=head2 Example: Altering Concise Renderings - - use B::Concise qw(set_style add_callback); - add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt); - add_callback - ( sub { - my ($h, $op, $format, $level, $stylename) = @_; - $h->{variable} = some_func($op); - }); - $walker = B::Concise::compile(@options,@subnames,@subrefs); - $walker->(); - -=head2 set_style() - -B<set_style> accepts 3 arguments, and updates the three format-specs -comprising a line-style (basic-exec, goto, tree). It has one minor -drawback though; it doesn't register the style under a new name. This -can become an issue if you render more than once and switch styles. -Thus you may prefer to use add_style() and/or set_style_standard() -instead. - -=head2 set_style_standard($name) - -This restores one of the standard line-styles: C<terse>, C<concise>, -C<linenoise>, C<debug>, C<env>, into effect. It also accepts style -names previously defined with add_style(). - -=head2 add_style() - -This subroutine accepts a new style name and three style arguments as -above, and creates, registers, and selects the newly named style. It is -an error to re-add a style; call set_style_standard() to switch between -several styles. - -=head2 add_callback() - -If your newly minted styles refer to any new #variables, you'll need -to define a callback subroutine that will populate (or modify) those -variables. They are then available for use in the style you've -chosen. - -The callbacks are called for each opcode visited by Concise, in the -same order as they are added. Each subroutine is passed five -parameters. - - 1. A hashref, containing the variable names and values which are - populated into the report-line for the op - 2. the op, as a B<B::OP> object - 3. a reference to the format string - 4. the formatting (indent) level - 5. the selected stylename - -To define your own variables, simply add them to the hash, or change -existing values if you need to. The level and format are passed in as -references to scalars, but it is unlikely that they will need to be -changed or even used. - -=head2 Running B::Concise::compile() - -B<compile> accepts options as described above in L</OPTIONS>, and -arguments, which are either coderefs, or subroutine names. - -It constructs and returns a $treewalker coderef, which when invoked, -traverses, or walks, and renders the optrees of the given arguments to -STDOUT. You can reuse this, and can change the rendering style used -each time; thereafter the coderef renders in the new style. - -B<walk_output> lets you change the print destination from STDOUT to -another open filehandle, or into a string passed as a ref (unless -you've built perl with -Uuseperlio). - - my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1 - walk_output(\my $buf); - $walker->(); # 1 renders -terse - set_style_standard('concise'); # 2 - $walker->(); # 2 renders -concise - $walker->(@new); # 3 renders whatever - print "3 different renderings: terse, concise, and @new: $buf\n"; - -When $walker is called, it traverses the subroutines supplied when it -was created, and renders them using the current style. You can change -the style afterwards in several different ways: - - 1. call C<compile>, altering style or mode/order - 2. call C<set_style_standard> - 3. call $walker, passing @new options - -Passing new options to the $walker is the easiest way to change -amongst any pre-defined styles (the ones you add are automatically -recognized as options), and is the only way to alter rendering order -without calling compile again. Note however that rendering state is -still shared amongst multiple $walker objects, so they must still be -used in a coordinated manner. - -=head2 B::Concise::reset_sequence() - -This function (not exported) lets you reset the sequence numbers (note -that they're numbered arbitrarily, their goal being to be human -readable). Its purpose is mostly to support testing, i.e. to compare -the concise output from two identical anonymous subroutines (but -different instances). Without the reset, B::Concise, seeing that -they're separate optrees, generates different sequence numbers in -the output. - -=head2 Errors - -Errors in rendering (non-existent function-name, non-existent coderef) -are written to the STDOUT, or wherever you've set it via -walk_output(). - -Errors using the various *style* calls, and bad args to walk_output(), -result in die(). Use an eval if you wish to catch these errors and -continue processing. - -=head1 AUTHOR - -Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>. - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm deleted file mode 100644 index cb369682d66..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Debug.pm +++ /dev/null @@ -1,305 +0,0 @@ -package B::Debug; - -our $VERSION = '1.02_01'; - -use strict; -use B qw(peekop class walkoptree walkoptree_exec - main_start main_root cstring sv_undef); -use B::Asmdata qw(@specialsv_name); - -my %done_gv; - -sub B::OP::debug { - my ($op) = @_; - printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type; -%s (0x%lx) - op_next 0x%x - op_sibling 0x%x - op_ppaddr %s - op_targ %d - op_type %d -EOT - if ($] > 5.009) { - printf <<'EOT', $op->opt, $op->static; - op_opt %d - op_static %d -EOT - } else { - printf <<'EOT', $op->seq; - op_seq %d -EOT - } - printf <<'EOT', $op->flags, $op->private; - op_flags %d - op_private %d -EOT -} - -sub B::UNOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_first\t0x%x\n", ${$op->first}; -} - -sub B::BINOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_last\t\t0x%x\n", ${$op->last}; -} - -sub B::LOOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; - op_redoop 0x%x - op_nextop 0x%x - op_lastop 0x%x -EOT -} - -sub B::LOGOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_other\t0x%x\n", ${$op->other}; -} - -sub B::LISTOP::debug { - my ($op) = @_; - $op->B::BINOP::debug(); - printf "\top_children\t%d\n", $op->children; -} - -sub B::PMOP::debug { - my ($op) = @_; - $op->B::LISTOP::debug(); - printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; - printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; - printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; - printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); - printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmreplroot->debug; -} - -sub B::COP::debug { - my ($op) = @_; - $op->B::OP::debug(); - my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; - printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io); - cop_label %s - cop_stashpv %s - cop_file %s - cop_seq %d - cop_arybase %d - cop_line %d - cop_warnings 0x%x - cop_io %s -EOT -} - -sub B::SVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_sv\t\t0x%x\n", ${$op->sv}; - $op->sv->debug; -} - -sub B::PVOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_pv\t\t%s\n", cstring($op->pv); -} - -sub B::PADOP::debug { - my ($op) = @_; - $op->B::OP::debug(); - printf "\top_padix\t\t%ld\n", $op->padix; -} - -sub B::NULL::debug { - my ($sv) = @_; - if ($$sv == ${sv_undef()}) { - print "&sv_undef\n"; - } else { - printf "NULL (0x%x)\n", $$sv; - } -} - -sub B::SV::debug { - my ($sv) = @_; - if (!$$sv) { - print class($sv), " = NULL\n"; - return; - } - printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; -%s (0x%x) - REFCNT %d - FLAGS 0x%x -EOT -} - -sub B::RV::debug { - my ($rv) = @_; - B::SV::debug($rv); - printf <<'EOT', ${$rv->RV}; - RV 0x%x -EOT - $rv->RV->debug; -} - -sub B::PV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - my $pv = $sv->PV(); - printf <<'EOT', cstring($pv), length($pv); - xpv_pv %s - xpv_cur %d -EOT -} - -sub B::IV::debug { - my ($sv) = @_; - $sv->B::SV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::NV::debug { - my ($sv) = @_; - $sv->B::IV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVIV::debug { - my ($sv) = @_; - $sv->B::PV::debug(); - printf "\txiv_iv\t\t%d\n", $sv->IV; -} - -sub B::PVNV::debug { - my ($sv) = @_; - $sv->B::PVIV::debug(); - printf "\txnv_nv\t\t%s\n", $sv->NV; -} - -sub B::PVLV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txlv_targoff\t%d\n", $sv->TARGOFF; - printf "\txlv_targlen\t%u\n", $sv->TARGLEN; - printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); -} - -sub B::BM::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - printf "\txbm_useful\t%d\n", $sv->USEFUL; - printf "\txbm_previous\t%u\n", $sv->PREVIOUS; - printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); -} - -sub B::CV::debug { - my ($sv) = @_; - $sv->B::PVNV::debug(); - my ($stash) = $sv->STASH; - my ($start) = $sv->START; - my ($root) = $sv->ROOT; - my ($padlist) = $sv->PADLIST; - my ($file) = $sv->FILE; - my ($gv) = $sv->GV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; - STASH 0x%x - START 0x%x - ROOT 0x%x - GV 0x%x - FILE %s - DEPTH %d - PADLIST 0x%x - OUTSIDE 0x%x - OUTSIDE_SEQ %d -EOT - $start->debug if $start; - $root->debug if $root; - $gv->debug if $gv; - $padlist->debug if $padlist; -} - -sub B::AV::debug { - my ($av) = @_; - $av->B::SV::debug; - my(@array) = $av->ARRAY; - print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; - printf <<'EOT', scalar(@array), $av->MAX, $av->OFF; - FILL %d - MAX %d - OFF %d -EOT - printf <<'EOT', $av->AvFLAGS if $] < 5.009; - AvFLAGS %d -EOT -} - -sub B::GV::debug { - my ($gv) = @_; - if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; - return; - } - my ($sv) = $gv->SV; - my ($av) = $gv->AV; - my ($cv) = $gv->CV; - $gv->B::SV::debug; - printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; - NAME %s - STASH %s (0x%x) - SV 0x%x - GvREFCNT %d - FORM 0x%x - AV 0x%x - HV 0x%x - EGV 0x%x - CV 0x%x - CVGEN %d - LINE %d - FILE %s - GvFLAGS 0x%x -EOT - $sv->debug if $sv; - $av->debug if $av; - $cv->debug if $cv; -} - -sub B::SPECIAL::debug { - my $sv = shift; - print $specialsv_name[$$sv], "\n"; -} - -sub compile { - my $order = shift; - B::clearsym(); - if ($order && $order eq "exec") { - return sub { walkoptree_exec(main_start, "debug") } - } else { - return sub { walkoptree(main_root, "debug") } - } -} - -1; - -__END__ - -=head1 NAME - -B::Debug - Walk Perl syntax tree, printing debug info about ops - -=head1 SYNOPSIS - - perl -MO=Debug[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -See F<ext/B/README>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm deleted file mode 100644 index 3db6fbe6e1f..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Deparse.pm +++ /dev/null @@ -1,4642 +0,0 @@ -# B::Deparse.pm -# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved. -# This module is free software; you can redistribute and/or modify -# it under the same terms as Perl itself. - -# This is based on the module of the same name by Malcolm Beattie, -# but essentially none of his code remains. - -package B::Deparse; -use Carp; -use B qw(class main_root main_start main_cv svref_2object opnumber perlstring - OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST - OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD - OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE - OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY - OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER - OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED - SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG - CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION - PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE - PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.71; -use strict; -use vars qw/$AUTOLOAD/; -use warnings (); - -# Changes between 0.50 and 0.51: -# - fixed nulled leave with live enter in sort { } -# - fixed reference constants (\"str") -# - handle empty programs gracefully -# - handle infinte loops (for (;;) {}, while (1) {}) -# - differentiate between `for my $x ...' and `my $x; for $x ...' -# - various minor cleanups -# - moved globals into an object -# - added `-u', like B::C -# - package declarations using cop_stash -# - subs, formats and code sorted by cop_seq -# Changes between 0.51 and 0.52: -# - added pp_threadsv (special variables under USE_5005THREADS) -# - added documentation -# Changes between 0.52 and 0.53: -# - many changes adding precedence contexts and associativity -# - added `-p' and `-s' output style options -# - various other minor fixes -# Changes between 0.53 and 0.54: -# - added support for new `for (1..100)' optimization, -# thanks to Gisle Aas -# Changes between 0.54 and 0.55: -# - added support for new qr// construct -# - added support for new pp_regcreset OP -# Changes between 0.55 and 0.56: -# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t -# - fixed $# on non-lexicals broken in last big rewrite -# - added temporary fix for change in opcode of OP_STRINGIFY -# - fixed problem in 0.54's for() patch in `for (@ary)' -# - fixed precedence in conditional of ?: -# - tweaked list paren elimination in `my($x) = @_' -# - made continue-block detection trickier wrt. null ops -# - fixed various prototype problems in pp_entersub -# - added support for sub prototypes that never get GVs -# - added unquoting for special filehandle first arg in truncate -# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' -# - added semicolons at the ends of blocks -# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 -# Changes between 0.56 and 0.561: -# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) -# - used new B.pm symbolic constants (done by Nick Ing-Simmons) -# Changes between 0.561 and 0.57: -# - stylistic changes to symbolic constant stuff -# - handled scope in s///e replacement code -# - added unquote option for expanding "" into concats, etc. -# - split method and proto parts of pp_entersub into separate functions -# - various minor cleanups -# Changes after 0.57: -# - added parens in \&foo (patch by Albert Dvornik) -# Changes between 0.57 and 0.58: -# - fixed `0' statements that weren't being printed -# - added methods for use from other programs -# (based on patches from James Duncan and Hugo van der Sanden) -# - added -si and -sT to control indenting (also based on a patch from Hugo) -# - added -sv to print something else instead of '???' -# - preliminary version of utf8 tr/// handling -# Changes after 0.58: -# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) -# - added support for Hugo's new OP_SETSTATE (like nextstate) -# Changes between 0.58 and 0.59 -# - added support for Chip's OP_METHOD_NAMED -# - added support for Ilya's OPpTARGET_MY optimization -# - elided arrows before `()' subscripts when possible -# Changes between 0.59 and 0.60 -# - support for method attribues was added -# - some warnings fixed -# - separate recognition of constant subs -# - rewrote continue block handling, now recoginizing for loops -# - added more control of expanding control structures -# Changes between 0.60 and 0.61 (mostly by Robin Houston) -# - many bug-fixes -# - support for pragmas and 'use' -# - support for the little-used $[ variable -# - support for __DATA__ sections -# - UTF8 support -# - BEGIN, CHECK, INIT and END blocks -# - scoping of subroutine declarations fixed -# - compile-time output from the input program can be suppressed, so that the -# output is just the deparsed code. (a change to O.pm in fact) -# - our() declarations -# - *all* the known bugs are now listed in the BUGS section -# - comprehensive test mechanism (TEST -deparse) -# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) -# - bug-fixes -# - new switch -P -# - support for command-line switches (-l, -0, etc.) -# Changes between 0.63 and 0.64 -# - support for //, CHECK blocks, and assertions -# - improved handling of foreach loops and lexicals -# - option to use Data::Dumper for constants -# - more bug fixes -# - discovered lots more bugs not yet fixed - -# Todo: -# (See also BUGS section at the end of this file) -# -# - finish tr/// changes -# - add option for even more parens (generalize \&foo change) -# - left/right context -# - copy comments (look at real text with $^P?) -# - avoid semis in one-statement blocks -# - associativity of &&=, ||=, ?: -# - ',' => '=>' (auto-unquote?) -# - break long lines ("\r" as discretionary break?) -# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. -# - more style options: brace style, hex vs. octal, quotes, ... -# - print big ints as hex/octal instead of decimal (heuristic?) -# - handle `my $x if 0'? -# - version using op_next instead of op_first/sibling? -# - avoid string copies (pass arrays, one big join?) -# - here-docs? - -# Current test.deparse failures -# comp/assertions 38 - disabled assertions should be like "my($x) if 0" -# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}' -# comp/hints 6 - location of BEGIN blocks wrt. block openings -# run/switchI 1 - missing -I switches entirely -# perl -Ifoo -e 'print @INC' -# op/caller 2 - warning mask propagates backwards before warnings::register -# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' -# op/getpid 2 - can't assign to shared my() declaration (threads only) -# 'my $x : shared = 5' -# op/override 7 - parens on overriden require change v-string interpretation -# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' -# c.f. 'BEGIN { *f = sub {0} }; f 2' -# op/pat 774 - losing Unicode-ness of Latin1-only strings -# 'use charnames ":short"; $x="\N{latin:a with acute}"' -# op/recurse 12 - missing parens on recursive call makes it look like method -# 'sub f { f($x) }' -# op/subst 90 - inconsistent handling of utf8 under "use utf8" -# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open -# op/tiehandle compile - "use strict" deparsed in the wrong place -# uni/tr_ several -# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs -# ext/Data/Dumper/t/dumper compile -# ext/DB_file/several -# ext/Encode/several -# ext/Ernno/Errno warnings -# ext/IO/lib/IO/t/io_sel 23 -# ext/PerlIO/t/encoding compile -# ext/POSIX/t/posix 6 -# ext/Socket/Socket 8 -# ext/Storable/t/croak compile -# lib/Attribute/Handlers/t/multi compile -# lib/bignum/ several -# lib/charnames 35 -# lib/constant 32 -# lib/English 40 -# lib/ExtUtils/t/bytes 4 -# lib/File/DosGlob compile -# lib/Filter/Simple/t/data 1 -# lib/Math/BigInt/t/constant 1 -# lib/Net/t/config Deparse-warning -# lib/overload compile -# lib/Switch/ several -# lib/Symbol 4 -# lib/Test/Simple several -# lib/Term/Complete -# lib/Tie/File/t/29_downcopy 5 -# lib/vars 22 - -# Object fields (were globals): -# -# avoid_local: -# (local($a), local($b)) and local($a, $b) have the same internal -# representation but the short form looks better. We notice we can -# use a large-scale local when checking the list, but need to prevent -# individual locals too. This hash holds the addresses of OPs that -# have already had their local-ness accounted for. The same thing -# is done with my(). -# -# curcv: -# CV for current sub (or main program) being deparsed -# -# curcvlex: -# Cached hash of lexical variables for curcv: keys are names, -# each value is an array of pairs, indicating the cop_seq of scopes -# in which a var of that name is valid. -# -# curcop: -# COP for statement being deparsed -# -# curstash: -# name of the current package for deparsed code -# -# subs_todo: -# array of [cop_seq, CV, is_format?] for subs and formats we still -# want to deparse -# -# protos_todo: -# as above, but [name, prototype] for subs that never got a GV -# -# subs_done, forms_done: -# keys are addresses of GVs for subs and formats we've already -# deparsed (or at least put into subs_todo) -# -# subs_declared -# keys are names of subs for which we've printed declarations. -# That means we can omit parentheses from the arguments. -# -# subs_deparsed -# Keeps track of fully qualified names of all deparsed subs. -# -# parens: -p -# linenums: -l -# unquote: -q -# cuddle: ` ' or `\n', depending on -sC -# indent_size: -si -# use_tabs: -sT -# ex_const: -sv - -# A little explanation of how precedence contexts and associativity -# work: -# -# deparse() calls each per-op subroutine with an argument $cx (short -# for context, but not the same as the cx* in the perl core), which is -# a number describing the op's parents in terms of precedence, whether -# they're inside an expression or at statement level, etc. (see -# chart below). When ops with children call deparse on them, they pass -# along their precedence. Fractional values are used to implement -# associativity (`($x + $y) + $z' => `$x + $y + $y') and related -# parentheses hacks. The major disadvantage of this scheme is that -# it doesn't know about right sides and left sides, so say if you -# assign a listop to a variable, it can't tell it's allowed to leave -# the parens off the listop. - -# Precedences: -# 26 [TODO] inside interpolation context ("") -# 25 left terms and list operators (leftward) -# 24 left -> -# 23 nonassoc ++ -- -# 22 right ** -# 21 right ! ~ \ and unary + and - -# 20 left =~ !~ -# 19 left * / % x -# 18 left + - . -# 17 left << >> -# 16 nonassoc named unary operators -# 15 nonassoc < > <= >= lt gt le ge -# 14 nonassoc == != <=> eq ne cmp -# 13 left & -# 12 left | ^ -# 11 left && -# 10 left || -# 9 nonassoc .. ... -# 8 right ?: -# 7 right = += -= *= etc. -# 6 left , => -# 5 nonassoc list operators (rightward) -# 4 right not -# 3 left and -# 2 left or xor -# 1 statement modifiers -# 0.5 statements, but still print scopes as do { ... } -# 0 statement level - -# Nonprinting characters with special meaning: -# \cS - steal parens (see maybe_parens_unop) -# \n - newline and indent -# \t - increase indent -# \b - decrease indent (`outdent') -# \f - flush left (no indent) -# \cK - kill following semicolon, if any - -sub null { - my $op = shift; - return class($op) eq "NULL"; -} - -sub todo { - my $self = shift; - my($cv, $is_form) = @_; - return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE}); - my $seq; - if ($cv->OUTSIDE_SEQ) { - $seq = $cv->OUTSIDE_SEQ; - } elsif (!null($cv->START) and is_state($cv->START)) { - $seq = $cv->START->cop_seq; - } else { - $seq = 0; - } - push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form]; - unless ($is_form || class($cv->STASH) eq 'SPECIAL') { - $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1; - } -} - -sub next_todo { - my $self = shift; - my $ent = shift @{$self->{'subs_todo'}}; - my $cv = $ent->[1]; - my $gv = $cv->GV; - my $name = $self->gv_name($gv); - if ($ent->[2]) { - return "format $name =\n" - . $self->deparse_format($ent->[1]). "\n"; - } else { - $self->{'subs_declared'}{$name} = 1; - if ($name eq "BEGIN") { - my $use_dec = $self->begin_is_use($cv); - if (defined ($use_dec) and $self->{'expand'} < 5) { - return () if 0 == length($use_dec); - return $use_dec; - } - } - my $l = ''; - if ($self->{'linenums'}) { - my $line = $gv->LINE; - my $file = $gv->FILE; - $l = "\n\f#line $line \"$file\"\n"; - } - my $p = ''; - if (class($cv->STASH) ne "SPECIAL") { - my $stash = $cv->STASH->NAME; - if ($stash ne $self->{'curstash'}) { - $p = "package $stash;\n"; - $name = "$self->{'curstash'}::$name" unless $name =~ /::/; - $self->{'curstash'} = $stash; - } - $name =~ s/^\Q$stash\E:://; - } - return "${p}${l}sub $name " . $self->deparse_sub($cv); - } -} - -# Return a "use" declaration for this BEGIN block, if appropriate -sub begin_is_use { - my ($self, $cv) = @_; - my $root = $cv->ROOT; - local @$self{qw'curcv curcvlex'} = ($cv); -#require B::Debug; -#B::walkoptree($cv->ROOT, "debug"); - my $lineseq = $root->first; - return if $lineseq->name ne "lineseq"; - - my $req_op = $lineseq->first->sibling; - return if $req_op->name ne "require"; - - my $module; - if ($req_op->first->private & OPpCONST_BARE) { - # Actually it should always be a bareword - $module = $self->const_sv($req_op->first)->PV; - $module =~ s[/][::]g; - $module =~ s/.pm$//; - } - else { - $module = $self->const($self->const_sv($req_op->first), 6); - } - - my $version; - my $version_op = $req_op->sibling; - return if class($version_op) eq "NULL"; - if ($version_op->name eq "lineseq") { - # We have a version parameter; skip nextstate & pushmark - my $constop = $version_op->first->next->next; - - return unless $self->const_sv($constop)->PV eq $module; - $constop = $constop->sibling; - $version = $self->const_sv($constop); - if (class($version) eq "IV") { - $version = $version->int_value; - } elsif (class($version) eq "NV") { - $version = $version->NV; - } elsif (class($version) ne "PVMG") { - # Includes PVIV and PVNV - $version = $version->PV; - } else { - # version specified as a v-string - $version = 'v'.join '.', map ord, split //, $version->PV; - } - $constop = $constop->sibling; - return if $constop->name ne "method_named"; - return if $self->const_sv($constop)->PV ne "VERSION"; - } - - $lineseq = $version_op->sibling; - return if $lineseq->name ne "lineseq"; - my $entersub = $lineseq->first->sibling; - if ($entersub->name eq "stub") { - return "use $module $version ();\n" if defined $version; - return "use $module ();\n"; - } - return if $entersub->name ne "entersub"; - - # See if there are import arguments - my $args = ''; - - my $svop = $entersub->first->sibling; # Skip over pushmark - return unless $self->const_sv($svop)->PV eq $module; - - # Pull out the arguments - for ($svop=$svop->sibling; $svop->name ne "method_named"; - $svop = $svop->sibling) { - $args .= ", " if length($args); - $args .= $self->deparse($svop, 6); - } - - my $use = 'use'; - my $method_named = $svop; - return if $method_named->name ne "method_named"; - my $method_name = $self->const_sv($method_named)->PV; - - if ($method_name eq "unimport") { - $use = 'no'; - } - - # Certain pragmas are dealt with using hint bits, - # so we ignore them here - if ($module eq 'strict' || $module eq 'integer' - || $module eq 'bytes' || $module eq 'warnings') { - return ""; - } - - if (defined $version && length $args) { - return "$use $module $version ($args);\n"; - } elsif (defined $version) { - return "$use $module $version;\n"; - } elsif (length $args) { - return "$use $module ($args);\n"; - } else { - return "$use $module;\n"; - } -} - -sub stash_subs { - my ($self, $pack) = @_; - my (@ret, $stash); - if (!defined $pack) { - $pack = ''; - $stash = \%::; - } - else { - $pack =~ s/(::)?$/::/; - no strict 'refs'; - $stash = \%$pack; - } - my %stash = svref_2object($stash)->ARRAY; - while (my ($key, $val) = each %stash) { - next if $key eq 'main::'; # avoid infinite recursion - my $class = class($val); - if ($class eq "PV") { - # Just a prototype. As an ugly but fairly effective way - # to find out if it belongs here is to see if the AUTOLOAD - # (if any) for the stash was defined in one of our files. - my $A = $stash{"AUTOLOAD"}; - if (defined ($A) && class($A) eq "GV" && defined($A->CV) - && class($A->CV) eq "CV") { - my $AF = $A->FILE; - next unless $AF eq $0 || exists $self->{'files'}{$AF}; - } - push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; - } elsif ($class eq "IV") { - # Just a name. As above. - my $A = $stash{"AUTOLOAD"}; - if (defined ($A) && class($A) eq "GV" && defined($A->CV) - && class($A->CV) eq "CV") { - my $AF = $A->FILE; - next unless $AF eq $0 || exists $self->{'files'}{$AF}; - } - push @{$self->{'protos_todo'}}, [$pack . $key, undef]; - } elsif ($class eq "GV") { - if (class(my $cv = $val->CV) ne "SPECIAL") { - next if $self->{'subs_done'}{$$val}++; - next if $$val != ${$cv->GV}; # Ignore imposters - $self->todo($cv, 0); - } - if (class(my $cv = $val->FORM) ne "SPECIAL") { - next if $self->{'forms_done'}{$$val}++; - next if $$val != ${$cv->GV}; # Ignore imposters - $self->todo($cv, 1); - } - if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { - $self->stash_subs($pack . $key); - } - } - } -} - -sub print_protos { - my $self = shift; - my $ar; - my @ret; - foreach $ar (@{$self->{'protos_todo'}}) { - my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); - push @ret, "sub " . $ar->[0] . "$proto;\n"; - } - delete $self->{'protos_todo'}; - return @ret; -} - -sub style_opts { - my $self = shift; - my $opts = shift; - my $opt; - while (length($opt = substr($opts, 0, 1))) { - if ($opt eq "C") { - $self->{'cuddle'} = " "; - $opts = substr($opts, 1); - } elsif ($opt eq "i") { - $opts =~ s/^i(\d+)//; - $self->{'indent_size'} = $1; - } elsif ($opt eq "T") { - $self->{'use_tabs'} = 1; - $opts = substr($opts, 1); - } elsif ($opt eq "v") { - $opts =~ s/^v([^.]*)(.|$)//; - $self->{'ex_const'} = $1; - } - } -} - -sub new { - my $class = shift; - my $self = bless {}, $class; - $self->{'cuddle'} = "\n"; - $self->{'curcop'} = undef; - $self->{'curstash'} = "main"; - $self->{'ex_const'} = "'???'"; - $self->{'expand'} = 0; - $self->{'files'} = {}; - $self->{'indent_size'} = 4; - $self->{'linenums'} = 0; - $self->{'parens'} = 0; - $self->{'subs_todo'} = []; - $self->{'unquote'} = 0; - $self->{'use_dumper'} = 0; - $self->{'use_tabs'} = 0; - - $self->{'ambient_arybase'} = 0; - $self->{'ambient_warnings'} = undef; # Assume no lexical warnings - $self->{'ambient_hints'} = 0; - $self->init(); - - while (my $arg = shift @_) { - if ($arg eq "-d") { - $self->{'use_dumper'} = 1; - require Data::Dumper; - } elsif ($arg =~ /^-f(.*)/) { - $self->{'files'}{$1} = 1; - } elsif ($arg eq "-l") { - $self->{'linenums'} = 1; - } elsif ($arg eq "-p") { - $self->{'parens'} = 1; - } elsif ($arg eq "-P") { - $self->{'noproto'} = 1; - } elsif ($arg eq "-q") { - $self->{'unquote'} = 1; - } elsif (substr($arg, 0, 2) eq "-s") { - $self->style_opts(substr $arg, 2); - } elsif ($arg =~ /^-x(\d)$/) { - $self->{'expand'} = $1; - } - } - return $self; -} - -{ - # Mask out the bits that L<warnings::register> uses - my $WARN_MASK; - BEGIN { - $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; - } - sub WARN_MASK () { - return $WARN_MASK; - } -} - -# Initialise the contextual information, either from -# defaults provided with the ambient_pragmas method, -# or from perl's own defaults otherwise. -sub init { - my $self = shift; - - $self->{'arybase'} = $self->{'ambient_arybase'}; - $self->{'warnings'} = defined ($self->{'ambient_warnings'}) - ? $self->{'ambient_warnings'} & WARN_MASK - : undef; - $self->{'hints'} = $self->{'ambient_hints'} & 0xFF; - - # also a convenient place to clear out subs_declared - delete $self->{'subs_declared'}; -} - -sub compile { - my(@args) = @_; - return sub { - my $self = B::Deparse->new(@args); - # First deparse command-line args - if (defined $^I) { # deparse -i - print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); - } - if ($^W) { # deparse -w - print qq(BEGIN { \$^W = $^W; }\n); - } - if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 - my $fs = perlstring($/) || 'undef'; - my $bs = perlstring($O::savebackslash) || 'undef'; - print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); - } - my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); - my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); - my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); - my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); - for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) { - $self->todo($block, 0); - } - $self->stash_subs(); - local($SIG{"__DIE__"}) = - sub { - if ($self->{'curcop'}) { - my $cop = $self->{'curcop'}; - my($line, $file) = ($cop->line, $cop->file); - print STDERR "While deparsing $file near line $line,\n"; - } - }; - $self->{'curcv'} = main_cv; - $self->{'curcvlex'} = undef; - print $self->print_protos; - @{$self->{'subs_todo'}} = - sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; - print $self->indent($self->deparse_root(main_root)), "\n" - unless null main_root; - my @text; - while (scalar(@{$self->{'subs_todo'}})) { - push @text, $self->next_todo; - } - print $self->indent(join("", @text)), "\n" if @text; - - # Print __DATA__ section, if necessary - no strict 'refs'; - my $laststash = defined $self->{'curcop'} - ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; - if (defined *{$laststash."::DATA"}{IO}) { - print "package $laststash;\n" - unless $laststash eq $self->{'curstash'}; - print "__DATA__\n"; - print readline(*{$laststash."::DATA"}); - } - } -} - -sub coderef2text { - my $self = shift; - my $sub = shift; - croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); - - $self->init(); - return $self->indent($self->deparse_sub(svref_2object($sub))); -} - -sub ambient_pragmas { - my $self = shift; - my ($arybase, $hint_bits, $warning_bits) = (0, 0); - - while (@_ > 1) { - my $name = shift(); - my $val = shift(); - - if ($name eq 'strict') { - require strict; - - if ($val eq 'none') { - $hint_bits &= ~strict::bits(qw/refs subs vars/); - next(); - } - - my @names; - if ($val eq "all") { - @names = qw/refs subs vars/; - } - elsif (ref $val) { - @names = @$val; - } - else { - @names = split' ', $val; - } - $hint_bits |= strict::bits(@names); - } - - elsif ($name eq '$[') { - $arybase = $val; - } - - elsif ($name eq 'integer' - || $name eq 'bytes' - || $name eq 'utf8') { - require "$name.pm"; - if ($val) { - $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; - } - else { - $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; - } - } - - elsif ($name eq 're') { - require re; - if ($val eq 'none') { - $hint_bits &= ~re::bits(qw/taint eval/); - next(); - } - - my @names; - if ($val eq 'all') { - @names = qw/taint eval/; - } - elsif (ref $val) { - @names = @$val; - } - else { - @names = split' ',$val; - } - $hint_bits |= re::bits(@names); - } - - elsif ($name eq 'warnings') { - if ($val eq 'none') { - $warning_bits = $warnings::NONE; - next(); - } - - my @names; - if (ref $val) { - @names = @$val; - } - else { - @names = split/\s+/, $val; - } - - $warning_bits = $warnings::NONE if !defined ($warning_bits); - $warning_bits |= warnings::bits(@names); - } - - elsif ($name eq 'warning_bits') { - $warning_bits = $val; - } - - elsif ($name eq 'hint_bits') { - $hint_bits = $val; - } - - else { - croak "Unknown pragma type: $name"; - } - } - if (@_) { - croak "The ambient_pragmas method expects an even number of args"; - } - - $self->{'ambient_arybase'} = $arybase; - $self->{'ambient_warnings'} = $warning_bits; - $self->{'ambient_hints'} = $hint_bits; -} - -# This method is the inner loop, so try to keep it simple -sub deparse { - my $self = shift; - my($op, $cx) = @_; - - Carp::confess("Null op in deparse") if !defined($op) - || class($op) eq "NULL"; - my $meth = "pp_" . $op->name; - return $self->$meth($op, $cx); -} - -sub indent { - my $self = shift; - my $txt = shift; - my @lines = split(/\n/, $txt); - my $leader = ""; - my $level = 0; - my $line; - for $line (@lines) { - my $cmd = substr($line, 0, 1); - if ($cmd eq "\t" or $cmd eq "\b") { - $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; - if ($self->{'use_tabs'}) { - $leader = "\t" x ($level / 8) . " " x ($level % 8); - } else { - $leader = " " x $level; - } - $line = substr($line, 1); - } - if (substr($line, 0, 1) eq "\f") { - $line = substr($line, 1); # no indent - } else { - $line = $leader . $line; - } - $line =~ s/\cK;?//g; - } - return join("\n", @lines); -} - -sub deparse_sub { - my $self = shift; - my $cv = shift; - my $proto = ""; -Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); -Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); - local $self->{'curcop'} = $self->{'curcop'}; - if ($cv->FLAGS & SVf_POK) { - $proto = "(". $cv->PV . ") "; - } - if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) { - $proto .= ": "; - $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; - $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; - $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; - $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION; - } - - local($self->{'curcv'}) = $cv; - local($self->{'curcvlex'}); - local(@$self{qw'curstash warnings hints'}) - = @$self{qw'curstash warnings hints'}; - my $body; - if (not null $cv->ROOT) { - my $lineseq = $cv->ROOT->first; - if ($lineseq->name eq "lineseq") { - my @ops; - for(my$o=$lineseq->first; $$o; $o=$o->sibling) { - push @ops, $o; - } - $body = $self->lineseq(undef, @ops).";"; - my $scope_en = $self->find_scope_en($lineseq); - if (defined $scope_en) { - my $subs = join"", $self->seq_subs($scope_en); - $body .= ";\n$subs" if length($subs); - } - } - else { - $body = $self->deparse($cv->ROOT->first, 0); - } - } - else { - my $sv = $cv->const_sv; - if ($$sv) { - # uh-oh. inlinable sub... format it differently - return $proto . "{ " . $self->const($sv, 0) . " }\n"; - } else { # XSUB? (or just a declaration) - return "$proto;\n"; - } - } - return $proto ."{\n\t$body\n\b}" ."\n"; -} - -sub deparse_format { - my $self = shift; - my $form = shift; - my @text; - local($self->{'curcv'}) = $form; - local($self->{'curcvlex'}); - local($self->{'in_format'}) = 1; - local(@$self{qw'curstash warnings hints'}) - = @$self{qw'curstash warnings hints'}; - my $op = $form->ROOT; - my $kid; - return "\f." if $op->first->name eq 'stub' - || $op->first->name eq 'nextstate'; - $op = $op->first->first; # skip leavewrite, lineseq - while (not null $op) { - $op = $op->sibling; # skip nextstate - my @exprs; - $kid = $op->first->sibling; # skip pushmark - push @text, "\f".$self->const_sv($kid)->PV; - $kid = $kid->sibling; - for (; not null $kid; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 0); - } - push @text, "\f".join(", ", @exprs)."\n" if @exprs; - $op = $op->sibling; - } - return join("", @text) . "\f."; -} - -sub is_scope { - my $op = shift; - return $op->name eq "leave" || $op->name eq "scope" - || $op->name eq "lineseq" - || ($op->name eq "null" && class($op) eq "UNOP" - && (is_scope($op->first) || $op->first->name eq "enter")); -} - -sub is_state { - my $name = $_[0]->name; - return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; -} - -sub is_miniwhile { # check for one-line loop (`foo() while $y--') - my $op = shift; - return (!null($op) and null($op->sibling) - and $op->name eq "null" and class($op) eq "UNOP" - and (($op->first->name =~ /^(and|or)$/ - and $op->first->first->sibling->name eq "lineseq") - or ($op->first->name eq "lineseq" - and not null $op->first->first->sibling - and $op->first->first->sibling->name eq "unstack") - )); -} - -# Check if the op and its sibling are the initialization and the rest of a -# for (..;..;..) { ... } loop -sub is_for_loop { - my $op = shift; - # This OP might be almost anything, though it won't be a - # nextstate. (It's the initialization, so in the canonical case it - # will be an sassign.) The sibling is a lineseq whose first child - # is a nextstate and whose second is a leaveloop. - my $lseq = $op->sibling; - if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") { - if ($lseq->first && !null($lseq->first) && is_state($lseq->first) - && (my $sib = $lseq->first->sibling)) { - return (!null($sib) && $sib->name eq "leaveloop"); - } - } - return 0; -} - -sub is_scalar { - my $op = shift; - return ($op->name eq "rv2sv" or - $op->name eq "padsv" or - $op->name eq "gv" or # only in array/hash constructs - $op->flags & OPf_KIDS && !null($op->first) - && $op->first->name eq "gvsv"); -} - -sub maybe_parens { - my $self = shift; - my($text, $cx, $prec) = @_; - if ($prec < $cx # unary ops nest just fine - or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 - or $self->{'parens'}) - { - $text = "($text)"; - # In a unop, let parent reuse our parens; see maybe_parens_unop - $text = "\cS" . $text if $cx == 16; - return $text; - } else { - return $text; - } -} - -# same as above, but get around the `if it looks like a function' rule -sub maybe_parens_unop { - my $self = shift; - my($name, $kid, $cx) = @_; - if ($cx > 16 or $self->{'parens'}) { - $kid = $self->deparse($kid, 1); - if ($name eq "umask" && $kid =~ /^\d+$/) { - $kid = sprintf("%#o", $kid); - } - return "$name($kid)"; - } else { - $kid = $self->deparse($kid, 16); - if ($name eq "umask" && $kid =~ /^\d+$/) { - $kid = sprintf("%#o", $kid); - } - if (substr($kid, 0, 1) eq "\cS") { - # use kid's parens - return $name . substr($kid, 1); - } elsif (substr($kid, 0, 1) eq "(") { - # avoid looks-like-a-function trap with extra parens - # (`+' can lead to ambiguities) - return "$name(" . $kid . ")"; - } else { - return "$name $kid"; - } - } -} - -sub maybe_parens_func { - my $self = shift; - my($func, $text, $cx, $prec) = @_; - if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { - return "$func($text)"; - } else { - return "$func $text"; - } -} - -sub maybe_local { - my $self = shift; - my($op, $cx, $text) = @_; - my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; - if ($op->private & (OPpLVAL_INTRO|$our_intro) - and not $self->{'avoid_local'}{$$op}) { - my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; - if( $our_local eq 'our' ) { - # XXX This assertion fails code with non-ASCII identifiers, - # like ./ext/Encode/t/jperl.t - die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/; - $text =~ s/(\w+::)+//; - } - if (want_scalar($op)) { - return "$our_local $text"; - } else { - return $self->maybe_parens_func("$our_local", $text, $cx, 16); - } - } else { - return $text; - } -} - -sub maybe_targmy { - my $self = shift; - my($op, $cx, $func, @args) = @_; - if ($op->private & OPpTARGET_MY) { - my $var = $self->padname($op->targ); - my $val = $func->($self, $op, 7, @args); - return $self->maybe_parens("$var = $val", $cx, 7); - } else { - return $func->($self, $op, $cx, @args); - } -} - -sub padname_sv { - my $self = shift; - my $targ = shift; - return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); -} - -sub maybe_my { - my $self = shift; - my($op, $cx, $text) = @_; - if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - if (want_scalar($op)) { - return "my $text"; - } else { - return $self->maybe_parens_func("my", $text, $cx, 16); - } - } else { - return $text; - } -} - -# The following OPs don't have functions: - -# pp_padany -- does not exist after parsing - -sub AUTOLOAD { - if ($AUTOLOAD =~ s/^.*::pp_//) { - warn "unexpected OP_".uc $AUTOLOAD; - return "XXX"; - } else { - die "Undefined subroutine $AUTOLOAD called"; - } -} - -sub DESTROY {} # Do not AUTOLOAD - -# $root should be the op which represents the root of whatever -# we're sequencing here. If it's undefined, then we don't append -# any subroutine declarations to the deparsed ops, otherwise we -# append appropriate declarations. -sub lineseq { - my($self, $root, @ops) = @_; - my($expr, @exprs); - - my $out_cop = $self->{'curcop'}; - my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; - my $limit_seq; - if (defined $root) { - $limit_seq = $out_seq; - my $nseq; - $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; - $limit_seq = $nseq if !defined($limit_seq) - or defined($nseq) && $nseq < $limit_seq; - } - $limit_seq = $self->{'limit_seq'} - if defined($self->{'limit_seq'}) - && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); - local $self->{'limit_seq'} = $limit_seq; - for (my $i = 0; $i < @ops; $i++) { - $expr = ""; - if (is_state $ops[$i]) { - $expr = $self->deparse($ops[$i], 0); - $i++; - if ($i > $#ops) { - push @exprs, $expr; - last; - } - } - if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and - !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq") - { - if ($ls->first && !null($ls->first) && is_state($ls->first) - && (my $sib = $ls->first->sibling)) { - if (!null($sib) && $sib->name eq "leaveloop") { - push @exprs, $expr . $self->for_loop($ops[$i], 0); - $i++; - next; - } - } - } - $expr .= $self->deparse($ops[$i], (@ops != 1)/2); - $expr =~ s/;\n?\z//; - push @exprs, $expr; - } - my $body = join(";\n", grep {length} @exprs); - my $subs = ""; - if (defined $root && defined $limit_seq && !$self->{'in_format'}) { - $subs = join "\n", $self->seq_subs($limit_seq); - } - return join(";\n", grep {length} $body, $subs); -} - -sub scopeop { - my($real_block, $self, $op, $cx) = @_; - my $kid; - my @kids; - - local(@$self{qw'curstash warnings hints'}) - = @$self{qw'curstash warnings hints'} if $real_block; - if ($real_block) { - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - } else { - $kid = $op->first; - } - for (; !null($kid); $kid = $kid->sibling) { - push @kids, $kid; - } - if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}"; - } else { - my $lineseq = $self->lineseq($op, @kids); - return (length ($lineseq) ? "$lineseq;" : ""); - } -} - -sub pp_scope { scopeop(0, @_); } -sub pp_lineseq { scopeop(0, @_); } -sub pp_leave { scopeop(1, @_); } - -# This is a special case of scopeop and lineseq, for the case of the -# main_root. The difference is that we print the output statements as -# soon as we get them, for the sake of impatient users. -sub deparse_root { - my $self = shift; - my($op) = @_; - local(@$self{qw'curstash warnings hints'}) - = @$self{qw'curstash warnings hints'}; - my @kids; - for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { - push @kids, $kid; - } - for (my $i = 0; $i < @kids; $i++) { - my $expr = ""; - if (is_state $kids[$i]) { - $expr = $self->deparse($kids[$i], 0); - $i++; - if ($i > $#kids) { - print $self->indent($expr); - last; - } - } - if (is_for_loop($kids[$i])) { - $expr .= $self->for_loop($kids[$i], 0); - $expr .= ";\n" unless $i == $#kids; - print $self->indent($expr); - $i++; - next; - } - $expr .= $self->deparse($kids[$i], (@kids != 1)/2); - $expr =~ s/;\n?\z//; - $expr .= ";"; - print $self->indent($expr); - print "\n" unless $i == $#kids; - } -} - -# The BEGIN {} is used here because otherwise this code isn't executed -# when you run B::Deparse on itself. -my %globalnames; -BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", - "ENV", "ARGV", "ARGVOUT", "_"); } - -sub gv_name { - my $self = shift; - my $gv = shift; -Carp::confess() unless ref($gv) eq "B::GV"; - my $stash = $gv->STASH->NAME; - my $name = $gv->SAFENAME; - if (($stash eq 'main' && $globalnames{$name}) - or ($stash eq $self->{'curstash'} && !$globalnames{$name}) - or $name =~ /^[^A-Za-z_:]/) - { - $stash = ""; - } else { - $stash = $stash . "::"; - } - if ($name =~ /^(\^..|{)/) { - $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ - } - return $stash . $name; -} - -# Return the name to use for a stash variable. -# If a lexical with the same name is in scope, it may need to be -# fully-qualified. -sub stash_variable { - my ($self, $prefix, $name) = @_; - - return "$prefix$name" if $name =~ /::/; - - unless ($prefix eq '$' || $prefix eq '@' || #' - $prefix eq '%' || $prefix eq '$#') { - return "$prefix$name"; - } - - my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; - return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v); - return "$prefix$name"; -} - -sub lex_in_scope { - my ($self, $name) = @_; - $self->populate_curcvlex() if !defined $self->{'curcvlex'}; - - return 0 if !defined($self->{'curcop'}); - my $seq = $self->{'curcop'}->cop_seq; - return 0 if !exists $self->{'curcvlex'}{$name}; - for my $a (@{$self->{'curcvlex'}{$name}}) { - my ($st, $en) = @$a; - return 1 if $seq > $st && $seq <= $en; - } - return 0; -} - -sub populate_curcvlex { - my $self = shift; - for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { - my $padlist = $cv->PADLIST; - # an undef CV still in lexical chain - next if class($padlist) eq "SPECIAL"; - my @padlist = $padlist->ARRAY; - my @ns = $padlist[0]->ARRAY; - - for (my $i=0; $i<@ns; ++$i) { - next if class($ns[$i]) eq "SPECIAL"; - next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars - if (class($ns[$i]) eq "PV") { - # Probably that pesky lexical @_ - next; - } - my $name = $ns[$i]->PVX; - my ($seq_st, $seq_en) = - ($ns[$i]->FLAGS & SVf_FAKE) - ? (0, 999999) - : ($ns[$i]->NVX, $ns[$i]->IVX); - - push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en]; - } - } -} - -sub find_scope_st { ((find_scope(@_))[0]); } -sub find_scope_en { ((find_scope(@_))[1]); } - -# Recurses down the tree, looking for pad variable introductions and COPs -sub find_scope { - my ($self, $op, $scope_st, $scope_en) = @_; - carp("Undefined op in find_scope") if !defined $op; - return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; - - for (my $o=$op->first; $$o; $o=$o->sibling) { - if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { - my $s = int($self->padname_sv($o->targ)->NVX); - my $e = $self->padname_sv($o->targ)->IVX; - $scope_st = $s if !defined($scope_st) || $s < $scope_st; - $scope_en = $e if !defined($scope_en) || $e > $scope_en; - } - elsif (is_state($o)) { - my $c = $o->cop_seq; - $scope_st = $c if !defined($scope_st) || $c < $scope_st; - $scope_en = $c if !defined($scope_en) || $c > $scope_en; - } - elsif ($o->flags & OPf_KIDS) { - ($scope_st, $scope_en) = - $self->find_scope($o, $scope_st, $scope_en) - } - } - - return ($scope_st, $scope_en); -} - -# Returns a list of subs which should be inserted before the COP -sub cop_subs { - my ($self, $op, $out_seq) = @_; - my $seq = $op->cop_seq; - # If we have nephews, then our sequence number indicates - # the cop_seq of the end of some sort of scope. - if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS - and my $nseq = $self->find_scope_st($op->sibling) ) { - $seq = $nseq; - } - $seq = $out_seq if defined($out_seq) && $out_seq < $seq; - return $self->seq_subs($seq); -} - -sub seq_subs { - my ($self, $seq) = @_; - my @text; -#push @text, "# ($seq)\n"; - - return "" if !defined $seq; - while (scalar(@{$self->{'subs_todo'}}) - and $seq > $self->{'subs_todo'}[0][0]) { - push @text, $self->next_todo; - } - return @text; -} - -# Notice how subs and formats are inserted between statements here; -# also $[ assignments and pragmas. -sub pp_nextstate { - my $self = shift; - my($op, $cx) = @_; - $self->{'curcop'} = $op; - my @text; - push @text, $self->cop_subs($op); - push @text, $op->label . ": " if $op->label; - my $stash = $op->stashpv; - if ($stash ne $self->{'curstash'}) { - push @text, "package $stash;\n"; - $self->{'curstash'} = $stash; - } - - if ($self->{'arybase'} != $op->arybase) { - push @text, '$[ = '. $op->arybase .";\n"; - $self->{'arybase'} = $op->arybase; - } - - my $warnings = $op->warnings; - my $warning_bits; - if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { - $warning_bits = $warnings::Bits{"all"} & WARN_MASK; - } - elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { - $warning_bits = $warnings::NONE; - } - elsif ($warnings->isa("B::SPECIAL")) { - $warning_bits = undef; - } - else { - $warning_bits = $warnings->PV & WARN_MASK; - } - - if (defined ($warning_bits) and - !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { - push @text, declare_warnings($self->{'warnings'}, $warning_bits); - $self->{'warnings'} = $warning_bits; - } - - if ($self->{'hints'} != $op->private) { - push @text, declare_hints($self->{'hints'}, $op->private); - $self->{'hints'} = $op->private; - } - - # This should go after of any branches that add statements, to - # increase the chances that it refers to the same line it did in - # the original program. - if ($self->{'linenums'}) { - push @text, "\f#line " . $op->line . - ' "' . $op->file, qq'"\n'; - } - - return join("", @text); -} - -sub declare_warnings { - my ($from, $to) = @_; - if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) { - return "use warnings;\n"; - } - elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { - return "no warnings;\n"; - } - return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n"; -} - -sub declare_hints { - my ($from, $to) = @_; - my $use = $to & ~$from; - my $no = $from & ~$to; - my $decls = ""; - for my $pragma (hint_pragmas($use)) { - $decls .= "use $pragma;\n"; - } - for my $pragma (hint_pragmas($no)) { - $decls .= "no $pragma;\n"; - } - return $decls; -} - -sub hint_pragmas { - my ($bits) = @_; - my @pragmas; - push @pragmas, "integer" if $bits & 0x1; - push @pragmas, "strict 'refs'" if $bits & 0x2; - push @pragmas, "bytes" if $bits & 0x8; - return @pragmas; -} - -sub pp_dbstate { pp_nextstate(@_) } -sub pp_setstate { pp_nextstate(@_) } - -sub pp_unstack { return "" } # see also leaveloop - -sub baseop { - my $self = shift; - my($op, $cx, $name) = @_; - return $name; -} - -sub pp_stub { - my $self = shift; - my($op, $cx, $name) = @_; - if ($cx >= 1) { - return "()"; - } - else { - return "();"; - } -} -sub pp_wantarray { baseop(@_, "wantarray") } -sub pp_fork { baseop(@_, "fork") } -sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } -sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } -sub pp_time { maybe_targmy(@_, \&baseop, "time") } -sub pp_tms { baseop(@_, "times") } -sub pp_ghostent { baseop(@_, "gethostent") } -sub pp_gnetent { baseop(@_, "getnetent") } -sub pp_gprotoent { baseop(@_, "getprotoent") } -sub pp_gservent { baseop(@_, "getservent") } -sub pp_ehostent { baseop(@_, "endhostent") } -sub pp_enetent { baseop(@_, "endnetent") } -sub pp_eprotoent { baseop(@_, "endprotoent") } -sub pp_eservent { baseop(@_, "endservent") } -sub pp_gpwent { baseop(@_, "getpwent") } -sub pp_spwent { baseop(@_, "setpwent") } -sub pp_epwent { baseop(@_, "endpwent") } -sub pp_ggrent { baseop(@_, "getgrent") } -sub pp_sgrent { baseop(@_, "setgrent") } -sub pp_egrent { baseop(@_, "endgrent") } -sub pp_getlogin { baseop(@_, "getlogin") } - -sub POSTFIX () { 1 } - -# I couldn't think of a good short name, but this is the category of -# symbolic unary operators with interesting precedence - -sub pfixop { - my $self = shift; - my($op, $cx, $name, $prec, $flags) = (@_, 0); - my $kid = $op->first; - $kid = $self->deparse($kid, $prec); - return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid", - $cx, $prec); -} - -sub pp_preinc { pfixop(@_, "++", 23) } -sub pp_predec { pfixop(@_, "--", 23) } -sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } -sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } -sub pp_i_preinc { pfixop(@_, "++", 23) } -sub pp_i_predec { pfixop(@_, "--", 23) } -sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } -sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } -sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } - -sub pp_negate { maybe_targmy(@_, \&real_negate) } -sub real_negate { - my $self = shift; - my($op, $cx) = @_; - if ($op->first->name =~ /^(i_)?negate$/) { - # avoid --$x - $self->pfixop($op, $cx, "-", 21.5); - } else { - $self->pfixop($op, $cx, "-", 21); - } -} -sub pp_i_negate { pp_negate(@_) } - -sub pp_not { - my $self = shift; - my($op, $cx) = @_; - if ($cx <= 4) { - $self->pfixop($op, $cx, "not ", 4); - } else { - $self->pfixop($op, $cx, "!", 21); - } -} - -sub unop { - my $self = shift; - my($op, $cx, $name) = @_; - my $kid; - if ($op->flags & OPf_KIDS) { - $kid = $op->first; - if (defined prototype("CORE::$name") - && prototype("CORE::$name") =~ /^;?\*/ - && $kid->name eq "rv2gv") { - $kid = $kid->first; - } - - return $self->maybe_parens_unop($name, $kid, $cx); - } else { - return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); - } -} - -sub pp_chop { maybe_targmy(@_, \&unop, "chop") } -sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } -sub pp_schop { maybe_targmy(@_, \&unop, "chop") } -sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } -sub pp_defined { unop(@_, "defined") } -sub pp_undef { unop(@_, "undef") } -sub pp_study { unop(@_, "study") } -sub pp_ref { unop(@_, "ref") } -sub pp_pos { maybe_local(@_, unop(@_, "pos")) } - -sub pp_sin { maybe_targmy(@_, \&unop, "sin") } -sub pp_cos { maybe_targmy(@_, \&unop, "cos") } -sub pp_rand { maybe_targmy(@_, \&unop, "rand") } -sub pp_srand { unop(@_, "srand") } -sub pp_exp { maybe_targmy(@_, \&unop, "exp") } -sub pp_log { maybe_targmy(@_, \&unop, "log") } -sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } -sub pp_int { maybe_targmy(@_, \&unop, "int") } -sub pp_hex { maybe_targmy(@_, \&unop, "hex") } -sub pp_oct { maybe_targmy(@_, \&unop, "oct") } -sub pp_abs { maybe_targmy(@_, \&unop, "abs") } - -sub pp_length { maybe_targmy(@_, \&unop, "length") } -sub pp_ord { maybe_targmy(@_, \&unop, "ord") } -sub pp_chr { maybe_targmy(@_, \&unop, "chr") } - -sub pp_each { unop(@_, "each") } -sub pp_values { unop(@_, "values") } -sub pp_keys { unop(@_, "keys") } -sub pp_pop { unop(@_, "pop") } -sub pp_shift { unop(@_, "shift") } - -sub pp_caller { unop(@_, "caller") } -sub pp_reset { unop(@_, "reset") } -sub pp_exit { unop(@_, "exit") } -sub pp_prototype { unop(@_, "prototype") } - -sub pp_close { unop(@_, "close") } -sub pp_fileno { unop(@_, "fileno") } -sub pp_umask { unop(@_, "umask") } -sub pp_untie { unop(@_, "untie") } -sub pp_tied { unop(@_, "tied") } -sub pp_dbmclose { unop(@_, "dbmclose") } -sub pp_getc { unop(@_, "getc") } -sub pp_eof { unop(@_, "eof") } -sub pp_tell { unop(@_, "tell") } -sub pp_getsockname { unop(@_, "getsockname") } -sub pp_getpeername { unop(@_, "getpeername") } - -sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } -sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } -sub pp_readlink { unop(@_, "readlink") } -sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } -sub pp_readdir { unop(@_, "readdir") } -sub pp_telldir { unop(@_, "telldir") } -sub pp_rewinddir { unop(@_, "rewinddir") } -sub pp_closedir { unop(@_, "closedir") } -sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } -sub pp_localtime { unop(@_, "localtime") } -sub pp_gmtime { unop(@_, "gmtime") } -sub pp_alarm { unop(@_, "alarm") } -sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } - -sub pp_dofile { unop(@_, "do") } -sub pp_entereval { unop(@_, "eval") } - -sub pp_ghbyname { unop(@_, "gethostbyname") } -sub pp_gnbyname { unop(@_, "getnetbyname") } -sub pp_gpbyname { unop(@_, "getprotobyname") } -sub pp_shostent { unop(@_, "sethostent") } -sub pp_snetent { unop(@_, "setnetent") } -sub pp_sprotoent { unop(@_, "setprotoent") } -sub pp_sservent { unop(@_, "setservent") } -sub pp_gpwnam { unop(@_, "getpwnam") } -sub pp_gpwuid { unop(@_, "getpwuid") } -sub pp_ggrnam { unop(@_, "getgrnam") } -sub pp_ggrgid { unop(@_, "getgrgid") } - -sub pp_lock { unop(@_, "lock") } - -sub pp_exists { - my $self = shift; - my($op, $cx) = @_; - my $arg; - if ($op->private & OPpEXISTS_SUB) { - # Checking for the existence of a subroutine - return $self->maybe_parens_func("exists", - $self->pp_rv2cv($op->first, 16), $cx, 16); - } - if ($op->flags & OPf_SPECIAL) { - # Array element, not hash element - return $self->maybe_parens_func("exists", - $self->pp_aelem($op->first, 16), $cx, 16); - } - return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16), - $cx, 16); -} - -sub pp_delete { - my $self = shift; - my($op, $cx) = @_; - my $arg; - if ($op->private & OPpSLICE) { - if ($op->flags & OPf_SPECIAL) { - # Deleting from an array, not a hash - return $self->maybe_parens_func("delete", - $self->pp_aslice($op->first, 16), - $cx, 16); - } - return $self->maybe_parens_func("delete", - $self->pp_hslice($op->first, 16), - $cx, 16); - } else { - if ($op->flags & OPf_SPECIAL) { - # Deleting from an array, not a hash - return $self->maybe_parens_func("delete", - $self->pp_aelem($op->first, 16), - $cx, 16); - } - return $self->maybe_parens_func("delete", - $self->pp_helem($op->first, 16), - $cx, 16); - } -} - -sub pp_require { - my $self = shift; - my($op, $cx) = @_; - my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; - if (class($op) eq "UNOP" and $op->first->name eq "const" - and $op->first->private & OPpCONST_BARE) - { - my $name = $self->const_sv($op->first)->PV; - $name =~ s[/][::]g; - $name =~ s/\.pm//g; - return "$opname $name"; - } else { - $self->unop($op, $cx, $opname); - } -} - -sub pp_scalar { - my $self = shift; - my($op, $cv) = @_; - my $kid = $op->first; - if (not null $kid->sibling) { - # XXX Was a here-doc - return $self->dquote($op); - } - $self->unop(@_, "scalar"); -} - - -sub padval { - my $self = shift; - my $targ = shift; - return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); -} - -sub pp_refgen { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - if ($kid->name eq "null") { - $kid = $kid->first; - if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { - my($pre, $post) = @{{"anonlist" => ["[","]"], - "anonhash" => ["{","}"]}->{$kid->name}}; - my($expr, @exprs); - $kid = $kid->first->sibling; # skip pushmark - for (; !null($kid); $kid = $kid->sibling) { - $expr = $self->deparse($kid, 6); - push @exprs, $expr; - } - return $pre . join(", ", @exprs) . $post; - } elsif (!null($kid->sibling) and - $kid->sibling->name eq "anoncode") { - return "sub " . - $self->deparse_sub($self->padval($kid->sibling->targ)); - } elsif ($kid->name eq "pushmark") { - my $sib_name = $kid->sibling->name; - if ($sib_name =~ /^(pad|rv2)[ah]v$/ - and not $kid->sibling->flags & OPf_REF) - { - # The @a in \(@a) isn't in ref context, but only when the - # parens are there. - return "\\(" . $self->pp_list($op->first) . ")"; - } elsif ($sib_name eq 'entersub') { - my $text = $self->deparse($kid->sibling, 1); - # Always show parens for \(&func()), but only with -p otherwise - $text = "($text)" if $self->{'parens'} - or $kid->sibling->private & OPpENTERSUB_AMPER; - return "\\$text"; - } - } - } - $self->pfixop($op, $cx, "\\", 20); -} - -sub pp_srefgen { pp_refgen(@_) } - -sub pp_readline { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> - return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid); - return $self->unop($op, $cx, "readline"); -} - -sub pp_rcatline { - my $self = shift; - my($op) = @_; - return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; -} - -# Unary operators that can occur as pseudo-listops inside double quotes -sub dq_unop { - my $self = shift; - my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); - my $kid; - if ($op->flags & OPf_KIDS) { - $kid = $op->first; - # If there's more than one kid, the first is an ex-pushmark. - $kid = $kid->sibling if not null $kid->sibling; - return $self->maybe_parens_unop($name, $kid, $cx); - } else { - return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); - } -} - -sub pp_ucfirst { dq_unop(@_, "ucfirst") } -sub pp_lcfirst { dq_unop(@_, "lcfirst") } -sub pp_uc { dq_unop(@_, "uc") } -sub pp_lc { dq_unop(@_, "lc") } -sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } - -sub loopex { - my $self = shift; - my ($op, $cx, $name) = @_; - if (class($op) eq "PVOP") { - return "$name " . $op->pv; - } elsif (class($op) eq "OP") { - return $name; - } elsif (class($op) eq "UNOP") { - # Note -- loop exits are actually exempt from the - # looks-like-a-func rule, but a few extra parens won't hurt - return $self->maybe_parens_unop($name, $op->first, $cx); - } -} - -sub pp_last { loopex(@_, "last") } -sub pp_next { loopex(@_, "next") } -sub pp_redo { loopex(@_, "redo") } -sub pp_goto { loopex(@_, "goto") } -sub pp_dump { loopex(@_, "dump") } - -sub ftst { - my $self = shift; - my($op, $cx, $name) = @_; - if (class($op) eq "UNOP") { - # Genuine `-X' filetests are exempt from the LLAFR, but not - # l?stat(); for the sake of clarity, give'em all parens - return $self->maybe_parens_unop($name, $op->first, $cx); - } elsif (class($op) =~ /^(SV|PAD)OP$/) { - return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); - } else { # I don't think baseop filetests ever survive ck_ftst, but... - return $name; - } -} - -sub pp_lstat { ftst(@_, "lstat") } -sub pp_stat { ftst(@_, "stat") } -sub pp_ftrread { ftst(@_, "-R") } -sub pp_ftrwrite { ftst(@_, "-W") } -sub pp_ftrexec { ftst(@_, "-X") } -sub pp_fteread { ftst(@_, "-r") } -sub pp_ftewrite { ftst(@_, "-w") } -sub pp_fteexec { ftst(@_, "-x") } -sub pp_ftis { ftst(@_, "-e") } -sub pp_fteowned { ftst(@_, "-O") } -sub pp_ftrowned { ftst(@_, "-o") } -sub pp_ftzero { ftst(@_, "-z") } -sub pp_ftsize { ftst(@_, "-s") } -sub pp_ftmtime { ftst(@_, "-M") } -sub pp_ftatime { ftst(@_, "-A") } -sub pp_ftctime { ftst(@_, "-C") } -sub pp_ftsock { ftst(@_, "-S") } -sub pp_ftchr { ftst(@_, "-c") } -sub pp_ftblk { ftst(@_, "-b") } -sub pp_ftfile { ftst(@_, "-f") } -sub pp_ftdir { ftst(@_, "-d") } -sub pp_ftpipe { ftst(@_, "-p") } -sub pp_ftlink { ftst(@_, "-l") } -sub pp_ftsuid { ftst(@_, "-u") } -sub pp_ftsgid { ftst(@_, "-g") } -sub pp_ftsvtx { ftst(@_, "-k") } -sub pp_fttty { ftst(@_, "-t") } -sub pp_fttext { ftst(@_, "-T") } -sub pp_ftbinary { ftst(@_, "-B") } - -sub SWAP_CHILDREN () { 1 } -sub ASSIGN () { 2 } # has OP= variant -sub LIST_CONTEXT () { 4 } # Assignment is in list context - -my(%left, %right); - -sub assoc_class { - my $op = shift; - my $name = $op->name; - if ($name eq "concat" and $op->first->name eq "concat") { - # avoid spurious `=' -- see comment in pp_concat - return "concat"; - } - if ($name eq "null" and class($op) eq "UNOP" - and $op->first->name =~ /^(and|x?or)$/ - and null $op->first->sibling) - { - # Like all conditional constructs, OP_ANDs and OP_ORs are topped - # with a null that's used as the common end point of the two - # flows of control. For precedence purposes, ignore it. - # (COND_EXPRs have these too, but we don't bother with - # their associativity). - return assoc_class($op->first); - } - return $name . ($op->flags & OPf_STACKED ? "=" : ""); -} - -# Left associative operators, like `+', for which -# $a + $b + $c is equivalent to ($a + $b) + $c - -BEGIN { - %left = ('multiply' => 19, 'i_multiply' => 19, - 'divide' => 19, 'i_divide' => 19, - 'modulo' => 19, 'i_modulo' => 19, - 'repeat' => 19, - 'add' => 18, 'i_add' => 18, - 'subtract' => 18, 'i_subtract' => 18, - 'concat' => 18, - 'left_shift' => 17, 'right_shift' => 17, - 'bit_and' => 13, - 'bit_or' => 12, 'bit_xor' => 12, - 'and' => 3, - 'or' => 2, 'xor' => 2, - ); -} - -sub deparse_binop_left { - my $self = shift; - my($op, $left, $prec) = @_; - if ($left{assoc_class($op)} && $left{assoc_class($left)} - and $left{assoc_class($op)} == $left{assoc_class($left)}) - { - return $self->deparse($left, $prec - .00001); - } else { - return $self->deparse($left, $prec); - } -} - -# Right associative operators, like `=', for which -# $a = $b = $c is equivalent to $a = ($b = $c) - -BEGIN { - %right = ('pow' => 22, - 'sassign=' => 7, 'aassign=' => 7, - 'multiply=' => 7, 'i_multiply=' => 7, - 'divide=' => 7, 'i_divide=' => 7, - 'modulo=' => 7, 'i_modulo=' => 7, - 'repeat=' => 7, - 'add=' => 7, 'i_add=' => 7, - 'subtract=' => 7, 'i_subtract=' => 7, - 'concat=' => 7, - 'left_shift=' => 7, 'right_shift=' => 7, - 'bit_and=' => 7, - 'bit_or=' => 7, 'bit_xor=' => 7, - 'andassign' => 7, - 'orassign' => 7, - ); -} - -sub deparse_binop_right { - my $self = shift; - my($op, $right, $prec) = @_; - if ($right{assoc_class($op)} && $right{assoc_class($right)} - and $right{assoc_class($op)} == $right{assoc_class($right)}) - { - return $self->deparse($right, $prec - .00001); - } else { - return $self->deparse($right, $prec); - } -} - -sub binop { - my $self = shift; - my ($op, $cx, $opname, $prec, $flags) = (@_, 0); - my $left = $op->first; - my $right = $op->last; - my $eq = ""; - if ($op->flags & OPf_STACKED && $flags & ASSIGN) { - $eq = "="; - $prec = 7; - } - if ($flags & SWAP_CHILDREN) { - ($left, $right) = ($right, $left); - } - $left = $self->deparse_binop_left($op, $left, $prec); - $left = "($left)" if $flags & LIST_CONTEXT - && $left !~ /^(my|our|local|)[\@\(]/; - $right = $self->deparse_binop_right($op, $right, $prec); - return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); -} - -sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } -sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } -sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } -sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } -sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } -sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } -sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } -sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } -sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } -sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } -sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } - -sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } -sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } -sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } -sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } -sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } - -sub pp_eq { binop(@_, "==", 14) } -sub pp_ne { binop(@_, "!=", 14) } -sub pp_lt { binop(@_, "<", 15) } -sub pp_gt { binop(@_, ">", 15) } -sub pp_ge { binop(@_, ">=", 15) } -sub pp_le { binop(@_, "<=", 15) } -sub pp_ncmp { binop(@_, "<=>", 14) } -sub pp_i_eq { binop(@_, "==", 14) } -sub pp_i_ne { binop(@_, "!=", 14) } -sub pp_i_lt { binop(@_, "<", 15) } -sub pp_i_gt { binop(@_, ">", 15) } -sub pp_i_ge { binop(@_, ">=", 15) } -sub pp_i_le { binop(@_, "<=", 15) } -sub pp_i_ncmp { binop(@_, "<=>", 14) } - -sub pp_seq { binop(@_, "eq", 14) } -sub pp_sne { binop(@_, "ne", 14) } -sub pp_slt { binop(@_, "lt", 15) } -sub pp_sgt { binop(@_, "gt", 15) } -sub pp_sge { binop(@_, "ge", 15) } -sub pp_sle { binop(@_, "le", 15) } -sub pp_scmp { binop(@_, "cmp", 14) } - -sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } -sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } - -# `.' is special because concats-of-concats are optimized to save copying -# by making all but the first concat stacked. The effect is as if the -# programmer had written `($a . $b) .= $c', except legal. -sub pp_concat { maybe_targmy(@_, \&real_concat) } -sub real_concat { - my $self = shift; - my($op, $cx) = @_; - my $left = $op->first; - my $right = $op->last; - my $eq = ""; - my $prec = 18; - if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { - $eq = "="; - $prec = 7; - } - $left = $self->deparse_binop_left($op, $left, $prec); - $right = $self->deparse_binop_right($op, $right, $prec); - return $self->maybe_parens("$left .$eq $right", $cx, $prec); -} - -# `x' is weird when the left arg is a list -sub pp_repeat { - my $self = shift; - my($op, $cx) = @_; - my $left = $op->first; - my $right = $op->last; - my $eq = ""; - my $prec = 19; - if ($op->flags & OPf_STACKED) { - $eq = "="; - $prec = 7; - } - if (null($right)) { # list repeat; count is inside left-side ex-list - my $kid = $left->first->sibling; # skip pushmark - my @exprs; - for (; !null($kid->sibling); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - $right = $kid; - $left = "(" . join(", ", @exprs). ")"; - } else { - $left = $self->deparse_binop_left($op, $left, $prec); - } - $right = $self->deparse_binop_right($op, $right, $prec); - return $self->maybe_parens("$left x$eq $right", $cx, $prec); -} - -sub range { - my $self = shift; - my ($op, $cx, $type) = @_; - my $left = $op->first; - my $right = $left->sibling; - $left = $self->deparse($left, 9); - $right = $self->deparse($right, 9); - return $self->maybe_parens("$left $type $right", $cx, 9); -} - -sub pp_flop { - my $self = shift; - my($op, $cx) = @_; - my $flip = $op->first; - my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; - return $self->range($flip->first, $cx, $type); -} - -# one-line while/until is handled in pp_leave - -sub logop { - my $self = shift; - my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; - my $left = $op->first; - my $right = $op->first->sibling; - if ($cx < 1 and is_scope($right) and $blockname - and $self->{'expand'} < 7) - { # if ($a) {$b} - $left = $self->deparse($left, 1); - $right = $self->deparse($right, 0); - return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx < 1 and $blockname and not $self->{'parens'} - and $self->{'expand'} < 7) { # $b if $a - $right = $self->deparse($right, 1); - $left = $self->deparse($left, 1); - return "$right $blockname $left"; - } elsif ($cx > $lowprec and $highop) { # $a && $b - $left = $self->deparse_binop_left($op, $left, $highprec); - $right = $self->deparse_binop_right($op, $right, $highprec); - return $self->maybe_parens("$left $highop $right", $cx, $highprec); - } else { # $a and $b - $left = $self->deparse_binop_left($op, $left, $lowprec); - $right = $self->deparse_binop_right($op, $right, $lowprec); - return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); - } -} - -sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } -sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } -sub pp_dor { logop(@_, "err", 2, "//", 10, "") } - -# xor is syntactically a logop, but it's really a binop (contrary to -# old versions of opcode.pl). Syntax is what matters here. -sub pp_xor { logop(@_, "xor", 2, "", 0, "") } - -sub logassignop { - my $self = shift; - my ($op, $cx, $opname) = @_; - my $left = $op->first; - my $right = $op->first->sibling->first; # skip sassign - $left = $self->deparse($left, 7); - $right = $self->deparse($right, 7); - return $self->maybe_parens("$left $opname $right", $cx, 7); -} - -sub pp_andassign { logassignop(@_, "&&=") } -sub pp_orassign { logassignop(@_, "||=") } -sub pp_dorassign { logassignop(@_, "//=") } - -sub listop { - my $self = shift; - my($op, $cx, $name) = @_; - my(@exprs); - my $parens = ($cx >= 5) || $self->{'parens'}; - my $kid = $op->first->sibling; - return $name if null $kid; - my $first; - $name = "socketpair" if $name eq "sockpair"; - my $proto = prototype("CORE::$name"); - if (defined $proto - && $proto =~ /^;?\*/ - && $kid->name eq "rv2gv") { - $first = $self->deparse($kid->first, 6); - } - else { - $first = $self->deparse($kid, 6); - } - if ($name eq "chmod" && $first =~ /^\d+$/) { - $first = sprintf("%#o", $first); - } - $first = "+$first" if not $parens and substr($first, 0, 1) eq "("; - push @exprs, $first; - $kid = $kid->sibling; - if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") { - push @exprs, $self->deparse($kid->first, 6); - $kid = $kid->sibling; - } - for (; !null($kid); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - if ($parens) { - return "$name(" . join(", ", @exprs) . ")"; - } else { - return "$name " . join(", ", @exprs); - } -} - -sub pp_bless { listop(@_, "bless") } -sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } -sub pp_substr { maybe_local(@_, listop(@_, "substr")) } -sub pp_vec { maybe_local(@_, listop(@_, "vec")) } -sub pp_index { maybe_targmy(@_, \&listop, "index") } -sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } -sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } -sub pp_formline { listop(@_, "formline") } # see also deparse_format -sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } -sub pp_unpack { listop(@_, "unpack") } -sub pp_pack { listop(@_, "pack") } -sub pp_join { maybe_targmy(@_, \&listop, "join") } -sub pp_splice { listop(@_, "splice") } -sub pp_push { maybe_targmy(@_, \&listop, "push") } -sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } -sub pp_reverse { listop(@_, "reverse") } -sub pp_warn { listop(@_, "warn") } -sub pp_die { listop(@_, "die") } -# Actually, return is exempt from the LLAFR (see examples in this very -# module!), but for consistency's sake, ignore that fact -sub pp_return { listop(@_, "return") } -sub pp_open { listop(@_, "open") } -sub pp_pipe_op { listop(@_, "pipe") } -sub pp_tie { listop(@_, "tie") } -sub pp_binmode { listop(@_, "binmode") } -sub pp_dbmopen { listop(@_, "dbmopen") } -sub pp_sselect { listop(@_, "select") } -sub pp_select { listop(@_, "select") } -sub pp_read { listop(@_, "read") } -sub pp_sysopen { listop(@_, "sysopen") } -sub pp_sysseek { listop(@_, "sysseek") } -sub pp_sysread { listop(@_, "sysread") } -sub pp_syswrite { listop(@_, "syswrite") } -sub pp_send { listop(@_, "send") } -sub pp_recv { listop(@_, "recv") } -sub pp_seek { listop(@_, "seek") } -sub pp_fcntl { listop(@_, "fcntl") } -sub pp_ioctl { listop(@_, "ioctl") } -sub pp_flock { maybe_targmy(@_, \&listop, "flock") } -sub pp_socket { listop(@_, "socket") } -sub pp_sockpair { listop(@_, "sockpair") } -sub pp_bind { listop(@_, "bind") } -sub pp_connect { listop(@_, "connect") } -sub pp_listen { listop(@_, "listen") } -sub pp_accept { listop(@_, "accept") } -sub pp_shutdown { listop(@_, "shutdown") } -sub pp_gsockopt { listop(@_, "getsockopt") } -sub pp_ssockopt { listop(@_, "setsockopt") } -sub pp_chown { maybe_targmy(@_, \&listop, "chown") } -sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } -sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } -sub pp_utime { maybe_targmy(@_, \&listop, "utime") } -sub pp_rename { maybe_targmy(@_, \&listop, "rename") } -sub pp_link { maybe_targmy(@_, \&listop, "link") } -sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } -sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } -sub pp_open_dir { listop(@_, "opendir") } -sub pp_seekdir { listop(@_, "seekdir") } -sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } -sub pp_system { maybe_targmy(@_, \&listop, "system") } -sub pp_exec { maybe_targmy(@_, \&listop, "exec") } -sub pp_kill { maybe_targmy(@_, \&listop, "kill") } -sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } -sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } -sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } -sub pp_shmget { listop(@_, "shmget") } -sub pp_shmctl { listop(@_, "shmctl") } -sub pp_shmread { listop(@_, "shmread") } -sub pp_shmwrite { listop(@_, "shmwrite") } -sub pp_msgget { listop(@_, "msgget") } -sub pp_msgctl { listop(@_, "msgctl") } -sub pp_msgsnd { listop(@_, "msgsnd") } -sub pp_msgrcv { listop(@_, "msgrcv") } -sub pp_semget { listop(@_, "semget") } -sub pp_semctl { listop(@_, "semctl") } -sub pp_semop { listop(@_, "semop") } -sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } -sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } -sub pp_gpbynumber { listop(@_, "getprotobynumber") } -sub pp_gsbyname { listop(@_, "getservbyname") } -sub pp_gsbyport { listop(@_, "getservbyport") } -sub pp_syscall { listop(@_, "syscall") } - -sub pp_glob { - my $self = shift; - my($op, $cx) = @_; - my $text = $self->dq($op->first->sibling); # skip pushmark - if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline - or $text =~ /[<>]/) { - return 'glob(' . single_delim('qq', '"', $text) . ')'; - } else { - return '<' . $text . '>'; - } -} - -# Truncate is special because OPf_SPECIAL makes a bareword first arg -# be a filehandle. This could probably be better fixed in the core -# by moving the GV lookup into ck_truc. - -sub pp_truncate { - my $self = shift; - my($op, $cx) = @_; - my(@exprs); - my $parens = ($cx >= 5) || $self->{'parens'}; - my $kid = $op->first->sibling; - my $fh; - if ($op->flags & OPf_SPECIAL) { - # $kid is an OP_CONST - $fh = $self->const_sv($kid)->PV; - } else { - $fh = $self->deparse($kid, 6); - $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; - } - my $len = $self->deparse($kid->sibling, 6); - if ($parens) { - return "truncate($fh, $len)"; - } else { - return "truncate $fh, $len"; - } -} - -sub indirop { - my $self = shift; - my($op, $cx, $name) = @_; - my($expr, @exprs); - my $kid = $op->first->sibling; - my $indir = ""; - if ($op->flags & OPf_STACKED) { - $indir = $kid; - $indir = $indir->first; # skip rv2gv - if (is_scope($indir)) { - $indir = "{" . $self->deparse($indir, 0) . "}"; - $indir = "{;}" if $indir eq "{}"; - } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { - $indir = $self->const_sv($indir)->PV; - } else { - $indir = $self->deparse($indir, 24); - } - $indir = $indir . " "; - $kid = $kid->sibling; - } - if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { - $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' - : '{$a <=> $b} '; - } - elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { - $indir = '{$b cmp $a} '; - } - for (; !null($kid); $kid = $kid->sibling) { - $expr = $self->deparse($kid, 6); - push @exprs, $expr; - } - my $name2 = $name; - if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { - $name2 = 'reverse sort'; - } - if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { - return "$exprs[0] = $name2 $indir $exprs[0]"; - } - - my $args = $indir . join(", ", @exprs); - if ($indir ne "" and $name eq "sort") { - # We don't want to say "sort(f 1, 2, 3)", since perl -w will - # give bareword warnings in that case. Therefore if context - # requires, we'll put parens around the outside "(sort f 1, 2, - # 3)". Unfortunately, we'll currently think the parens are - # necessary more often that they really are, because we don't - # distinguish which side of an assignment we're on. - if ($cx >= 5) { - return "($name2 $args)"; - } else { - return "$name2 $args"; - } - } else { - return $self->maybe_parens_func($name2, $args, $cx, 5); - } - -} - -sub pp_prtf { indirop(@_, "printf") } -sub pp_print { indirop(@_, "print") } -sub pp_sort { indirop(@_, "sort") } - -sub mapop { - my $self = shift; - my($op, $cx, $name) = @_; - my($expr, @exprs); - my $kid = $op->first; # this is the (map|grep)start - $kid = $kid->first->sibling; # skip a pushmark - my $code = $kid->first; # skip a null - if (is_scope $code) { - $code = "{" . $self->deparse($code, 0) . "} "; - } else { - $code = $self->deparse($code, 24) . ", "; - } - $kid = $kid->sibling; - for (; !null($kid); $kid = $kid->sibling) { - $expr = $self->deparse($kid, 6); - push @exprs, $expr if defined $expr; - } - return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5); -} - -sub pp_mapwhile { mapop(@_, "map") } -sub pp_grepwhile { mapop(@_, "grep") } -sub pp_mapstart { baseop(@_, "map") } -sub pp_grepstart { baseop(@_, "grep") } - -sub pp_list { - my $self = shift; - my($op, $cx) = @_; - my($expr, @exprs); - my $kid = $op->first->sibling; # skip pushmark - my $lop; - my $local = "either"; # could be local(...), my(...) or our(...) - for ($lop = $kid; !null($lop); $lop = $lop->sibling) { - # This assumes that no other private flags equal 128, and that - # OPs that store things other than flags in their op_private, - # like OP_AELEMFAST, won't be immediate children of a list. - # - # OP_ENTERSUB can break this logic, so check for it. - # I suspect that open and exit can too. - - if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO) - or $lop->name eq "undef") - or $lop->name eq "entersub" - or $lop->name eq "exit" - or $lop->name eq "open") - { - $local = ""; # or not - last; - } - if ($lop->name =~ /^pad[ash]v$/) { # my() - ($local = "", last) if $local eq "local" || $local eq "our"; - $local = "my"; - } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/ - && $lop->private & OPpOUR_INTRO - or $lop->name eq "null" && $lop->first->name eq "gvsv" - && $lop->first->private & OPpOUR_INTRO) { # our() - ($local = "", last) if $local eq "my" || $local eq "local"; - $local = "our"; - } elsif ($lop->name ne "undef" - # specifically avoid the "reverse sort" optimisation, - # where "reverse" is nullified - && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE))) - { - # local() - ($local = "", last) if $local eq "my" || $local eq "our"; - $local = "local"; - } - } - $local = "" if $local eq "either"; # no point if it's all undefs - return $self->deparse($kid, $cx) if null $kid->sibling and not $local; - for (; !null($kid); $kid = $kid->sibling) { - if ($local) { - if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { - $lop = $kid->first; - } else { - $lop = $kid; - } - $self->{'avoid_local'}{$$lop}++; - $expr = $self->deparse($kid, 6); - delete $self->{'avoid_local'}{$$lop}; - } else { - $expr = $self->deparse($kid, 6); - } - push @exprs, $expr; - } - if ($local) { - return "$local(" . join(", ", @exprs) . ")"; - } else { - return $self->maybe_parens( join(", ", @exprs), $cx, 6); - } -} - -sub is_ifelse_cont { - my $op = shift; - return ($op->name eq "null" and class($op) eq "UNOP" - and $op->first->name =~ /^(and|cond_expr)$/ - and is_scope($op->first->first->sibling)); -} - -sub pp_cond_expr { - my $self = shift; - my($op, $cx) = @_; - my $cond = $op->first; - my $true = $cond->sibling; - my $false = $true->sibling; - my $cuddle = $self->{'cuddle'}; - unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and - (is_scope($false) || is_ifelse_cont($false)) - and $self->{'expand'} < 7) { - $cond = $self->deparse($cond, 8); - $true = $self->deparse($true, 8); - $false = $self->deparse($false, 8); - return $self->maybe_parens("$cond ? $true : $false", $cx, 8); - } - - $cond = $self->deparse($cond, 1); - $true = $self->deparse($true, 0); - my $head = "if ($cond) {\n\t$true\n\b}"; - my @elsifs; - while (!null($false) and is_ifelse_cont($false)) { - my $newop = $false->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - $false = $newtrue->sibling; # last in chain is OP_AND => no else - $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); - push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; - } - if (!null($false)) { - $false = $cuddle . "else {\n\t" . - $self->deparse($false, 0) . "\n\b}\cK"; - } else { - $false = "\cK"; - } - return $head . join($cuddle, "", @elsifs) . $false; -} - -sub loop_common { - my $self = shift; - my($op, $cx, $init) = @_; - my $enter = $op->first; - my $kid = $enter->sibling; - local(@$self{qw'curstash warnings hints'}) - = @$self{qw'curstash warnings hints'}; - my $head = ""; - my $bare = 0; - my $body; - my $cond = undef; - if ($kid->name eq "lineseq") { # bare or infinite loop - if ($kid->last->name eq "unstack") { # infinite - $head = "while (1) "; # Can't use for(;;) if there's a continue - $cond = ""; - } else { - $bare = 1; - } - $body = $kid; - } elsif ($enter->name eq "enteriter") { # foreach - my $ary = $enter->first->sibling; # first was pushmark - my $var = $ary->sibling; - if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { - # "reverse" was optimised away - $ary = listop($self, $ary->first->sibling, 1, 'reverse'); - } elsif ($enter->flags & OPf_STACKED - and not null $ary->first->sibling->sibling) - { - $ary = $self->deparse($ary->first->sibling, 9) . " .. " . - $self->deparse($ary->first->sibling->sibling, 9); - } else { - $ary = $self->deparse($ary, 1); - } - if (null $var) { - if ($enter->flags & OPf_SPECIAL) { # thread special var - $var = $self->pp_threadsv($enter, 1); - } else { # regular my() variable - $var = $self->pp_padsv($enter, 1); - } - } elsif ($var->name eq "rv2gv") { - $var = $self->pp_rv2sv($var, 1); - if ($enter->private & OPpOUR_INTRO) { - # our declarations don't have package names - $var =~ s/^(.).*::/$1/; - $var = "our $var"; - } - } elsif ($var->name eq "gv") { - $var = "\$" . $self->deparse($var, 1); - } - $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER - if (!is_state $body->first and $body->first->name ne "stub") { - confess unless $var eq '$_'; - $body = $body->first; - return $self->deparse($body, 2) . " foreach ($ary)"; - } - $head = "foreach $var ($ary) "; - } elsif ($kid->name eq "null") { # while/until - $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"}->{$kid->name}; - $cond = $self->deparse($kid->first, 1); - $head = "$name ($cond) "; - $body = $kid->first->sibling; - } elsif ($kid->name eq "stub") { # bare and empty - return "{;}"; # {} could be a hashref - } - # If there isn't a continue block, then the next pointer for the loop - # will point to the unstack, which is kid's last child, except - # in a bare loop, when it will point to the leaveloop. When neither of - # these conditions hold, then the second-to-last child is the continue - # block (or the last in a bare loop). - my $cont_start = $enter->nextop; - my $cont; - if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { - if ($bare) { - $cont = $body->last; - } else { - $cont = $body->first; - while (!null($cont->sibling->sibling)) { - $cont = $cont->sibling; - } - } - my $state = $body->first; - my $cuddle = $self->{'cuddle'}; - my @states; - for (; $$state != $$cont; $state = $state->sibling) { - push @states, $state; - } - $body = $self->lineseq(undef, @states); - if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { - $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; - $cont = "\cK"; - } else { - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; - } - } else { - return "" if !defined $body; - if (length $init) { - $head = "for ($init; $cond;) "; - } - $cont = "\cK"; - $body = $self->deparse($body, 0); - } - $body =~ s/;?$/;\n/; - - return $head . "{\n\t" . $body . "\b}" . $cont; -} - -sub pp_leaveloop { loop_common(@_, "") } - -sub for_loop { - my $self = shift; - my($op, $cx) = @_; - my $init = $self->deparse($op, 1); - return $self->loop_common($op->sibling->first->sibling, $cx, $init); -} - -sub pp_leavetry { - my $self = shift; - return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; -} - -BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } -BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } -BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" } -BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" } - -sub pp_null { - my $self = shift; - my($op, $cx) = @_; - if (class($op) eq "OP") { - # old value is lost - return $self->{'ex_const'} if $op->targ == OP_CONST; - } elsif ($op->first->name eq "pushmark") { - return $self->pp_list($op, $cx); - } elsif ($op->first->name eq "enter") { - return $self->pp_leave($op, $cx); - } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op, $cx); - } elsif (!null($op->first->sibling) and - $op->first->sibling->name eq "readline" and - $op->first->sibling->flags & OPf_STACKED) { - return $self->maybe_parens($self->deparse($op->first, 7) . " = " - . $self->deparse($op->first->sibling, 7), - $cx, 7); - } elsif (!null($op->first->sibling) and - $op->first->sibling->name eq "trans" and - $op->first->sibling->flags & OPf_STACKED) { - return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " - . $self->deparse($op->first->sibling, 20), - $cx, 20); - } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { - return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; - } elsif (!null($op->first->sibling) and - $op->first->sibling->name eq "null" and - class($op->first->sibling) eq "UNOP" and - $op->first->sibling->first->flags & OPf_STACKED and - $op->first->sibling->first->name eq "rcatline") { - return $self->maybe_parens($self->deparse($op->first, 18) . " .= " - . $self->deparse($op->first->sibling, 18), - $cx, 18); - } else { - return $self->deparse($op->first, $cx); - } -} - -sub padname { - my $self = shift; - my $targ = shift; - return $self->padname_sv($targ)->PVX; -} - -sub padany { - my $self = shift; - my $op = shift; - return substr($self->padname($op->targ), 1); # skip $/@/% -} - -sub pp_padsv { - my $self = shift; - my($op, $cx) = @_; - return $self->maybe_my($op, $cx, $self->padname($op->targ)); -} - -sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } - -my @threadsv_names; - -BEGIN { - @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9", - "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";", - "^", "-", "%", "=", "|", "~", ":", "^A", "^E", - "!", "@"); -} - -sub pp_threadsv { - my $self = shift; - my($op, $cx) = @_; - return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); -} - -sub gv_or_padgv { - my $self = shift; - my $op = shift; - if (class($op) eq "PADOP") { - return $self->padval($op->padix); - } else { # class($op) eq "SVOP" - return $op->gv; - } -} - -sub pp_gvsv { - my $self = shift; - my($op, $cx) = @_; - my $gv = $self->gv_or_padgv($op); - return $self->maybe_local($op, $cx, $self->stash_variable("\$", - $self->gv_name($gv))); -} - -sub pp_gv { - my $self = shift; - my($op, $cx) = @_; - my $gv = $self->gv_or_padgv($op); - return $self->gv_name($gv); -} - -sub pp_aelemfast { - my $self = shift; - my($op, $cx) = @_; - my $name; - if ($op->flags & OPf_SPECIAL) { # optimised PADAV - $name = $self->padname($op->targ); - $name =~ s/^@/\$/; - } - else { - my $gv = $self->gv_or_padgv($op); - $name = $self->gv_name($gv); - $name = $self->{'curstash'}."::$name" - if $name !~ /::/ && $self->lex_in_scope('@'.$name); - $name = '$' . $name; - } - - return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; -} - -sub rv2x { - my $self = shift; - my($op, $cx, $type) = @_; - - if (class($op) eq 'NULL' || !$op->can("first")) { - carp("Unexpected op in pp_rv2x"); - return 'XXX'; - } - my $kid = $op->first; - if ($kid->name eq "gv") { - return $self->stash_variable($type, $self->deparse($kid, 0)); - } elsif (is_scalar $kid) { - my $str = $self->deparse($kid, 0); - if ($str =~ /^\$([^\w\d])\z/) { - # "$$+" isn't a legal way to write the scalar dereference - # of $+, since the lexer can't tell you aren't trying to - # do something like "$$ + 1" to get one more than your - # PID. Either "${$+}" or "$${+}" are workable - # disambiguations, but if the programmer did the former, - # they'd be in the "else" clause below rather than here. - # It's not clear if this should somehow be unified with - # the code in dq and re_dq that also adds lexer - # disambiguation braces. - $str = '$' . "{$1}"; #' - } - return $type . $str; - } else { - return $type . "{" . $self->deparse($kid, 0) . "}"; - } -} - -sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } -sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } -sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } - -# skip rv2av -sub pp_av2arylen { - my $self = shift; - my($op, $cx) = @_; - if ($op->first->name eq "padav") { - return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); - } else { - return $self->maybe_local($op, $cx, - $self->rv2x($op->first, $cx, '$#')); - } -} - -# skip down to the old, ex-rv2cv -sub pp_rv2cv { - my ($self, $op, $cx) = @_; - if (!null($op->first) && $op->first->name eq 'null' && - $op->first->targ eq OP_LIST) - { - return $self->rv2x($op->first->first->sibling, $cx, "&") - } - else { - return $self->rv2x($op, $cx, "") - } -} - -sub list_const { - my $self = shift; - my($cx, @list) = @_; - my @a = map $self->const($_, 6), @list; - if (@a == 0) { - return "()"; - } elsif (@a == 1) { - return $a[0]; - } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { - # collapse (-1,0,1,2) into (-1..2) - my ($s, $e) = @a[0,-1]; - my $i = $s; - return $self->maybe_parens("$s..$e", $cx, 9) - unless grep $i++ != $_, @a; - } - return $self->maybe_parens(join(", ", @a), $cx, 6); -} - -sub pp_rv2av { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - if ($kid->name eq "const") { # constant list - my $av = $self->const_sv($kid); - return $self->list_const($cx, $av->ARRAY); - } else { - return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); - } - } - -sub is_subscriptable { - my $op = shift; - if ($op->name =~ /^[ahg]elem/) { - return 1; - } elsif ($op->name eq "entersub") { - my $kid = $op->first; - return 0 unless null $kid->sibling; - $kid = $kid->first; - $kid = $kid->sibling until null $kid->sibling; - return 0 if is_scope($kid); - $kid = $kid->first; - return 0 if $kid->name eq "gv"; - return 0 if is_scalar($kid); - return is_subscriptable($kid); - } else { - return 0; - } -} - -sub elem { - my $self = shift; - my ($op, $cx, $left, $right, $padname) = @_; - my($array, $idx) = ($op->first, $op->first->sibling); - unless ($array->name eq $padname) { # Maybe this has been fixed - $array = $array->first; # skip rv2av (or ex-rv2av in _53+) - } - if ($array->name eq $padname) { - $array = $self->padany($array); - } elsif (is_scope($array)) { # ${expr}[0] - $array = "{" . $self->deparse($array, 0) . "}"; - } elsif ($array->name eq "gv") { - $array = $self->gv_name($self->gv_or_padgv($array)); - if ($array !~ /::/) { - my $prefix = ($left eq '[' ? '@' : '%'); - $array = $self->{curstash}.'::'.$array - if $self->lex_in_scope($prefix . $array); - } - } elsif (is_scalar $array) { # $x[0], $$x[0], ... - $array = $self->deparse($array, 24); - } else { - # $x[20][3]{hi} or expr->[20] - my $arrow = is_subscriptable($array) ? "" : "->"; - return $self->deparse($array, 24) . $arrow . - $left . $self->deparse($idx, 1) . $right; - } - $idx = $self->deparse($idx, 1); - - # Outer parens in an array index will confuse perl - # if we're interpolating in a regular expression, i.e. - # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ - # - # If $self->{parens}, then an initial '(' will - # definitely be paired with a final ')'. If - # !$self->{parens}, the misleading parens won't - # have been added in the first place. - # - # [You might think that we could get "(...)...(...)" - # where the initial and final parens do not match - # each other. But we can't, because the above would - # only happen if there's an infix binop between the - # two pairs of parens, and *that* means that the whole - # expression would be parenthesized as well.] - # - $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; - - # Hash-element braces will autoquote a bareword inside themselves. - # We need to make sure that C<$hash{warn()}> doesn't come out as - # C<$hash{warn}>, which has a quite different meaning. Currently - # B::Deparse will always quote strings, even if the string was a - # bareword in the original (i.e. the OPpCONST_BARE flag is ignored - # for constant strings.) So we can cheat slightly here - if we see - # a bareword, we know that it is supposed to be a function call. - # - $idx =~ s/^([A-Za-z_]\w*)$/$1()/; - - return "\$" . $array . $left . $idx . $right; -} - -sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } -sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } - -sub pp_gelem { - my $self = shift; - my($op, $cx) = @_; - my($glob, $part) = ($op->first, $op->last); - $glob = $glob->first; # skip rv2gv - $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug - my $scope = is_scope($glob); - $glob = $self->deparse($glob, 0); - $part = $self->deparse($part, 1); - return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; -} - -sub slice { - my $self = shift; - my ($op, $cx, $left, $right, $regname, $padname) = @_; - my $last; - my(@elems, $kid, $array, $list); - if (class($op) eq "LISTOP") { - $last = $op->last; - } else { # ex-hslice inside delete() - for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} - $last = $kid; - } - $array = $last; - $array = $array->first - if $array->name eq $regname or $array->name eq "null"; - if (is_scope($array)) { - $array = "{" . $self->deparse($array, 0) . "}"; - } elsif ($array->name eq $padname) { - $array = $self->padany($array); - } else { - $array = $self->deparse($array, 24); - } - $kid = $op->first->sibling; # skip pushmark - if ($kid->name eq "list") { - $kid = $kid->first->sibling; # skip list, pushmark - for (; !null $kid; $kid = $kid->sibling) { - push @elems, $self->deparse($kid, 6); - } - $list = join(", ", @elems); - } else { - $list = $self->deparse($kid, 1); - } - return "\@" . $array . $left . $list . $right; -} - -sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } -sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } - -sub pp_lslice { - my $self = shift; - my($op, $cx) = @_; - my $idx = $op->first; - my $list = $op->last; - my(@elems, $kid); - $list = $self->deparse($list, 1); - $idx = $self->deparse($idx, 1); - return "($list)" . "[$idx]"; -} - -sub want_scalar { - my $op = shift; - return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; -} - -sub want_list { - my $op = shift; - return ($op->flags & OPf_WANT) == OPf_WANT_LIST; -} - -sub method { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first->sibling; # skip pushmark - my($meth, $obj, @exprs); - if ($kid->name eq "list" and want_list $kid) { - # When an indirect object isn't a bareword but the args are in - # parens, the parens aren't part of the method syntax (the LLAFR - # doesn't apply), but they make a list with OPf_PARENS set that - # doesn't get flattened by the append_elem that adds the method, - # making a (object, arg1, arg2, ...) list where the object - # usually is. This can be distinguished from - # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an - # object) because in the later the list is in scalar context - # as the left side of -> always is, while in the former - # the list is in list context as method arguments always are. - # (Good thing there aren't method prototypes!) - $meth = $kid->sibling; - $kid = $kid->first->sibling; # skip pushmark - $obj = $kid; - $kid = $kid->sibling; - for (; not null $kid; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - } else { - $obj = $kid; - $kid = $kid->sibling; - for (; !null ($kid->sibling) && $kid->name ne "method_named"; - $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - $meth = $kid; - } - $obj = $self->deparse($obj, 24); - if ($meth->name eq "method_named") { - $meth = $self->const_sv($meth)->PV; - } else { - $meth = $meth->first; - if ($meth->name eq "const") { - # As of 5.005_58, this case is probably obsoleted by the - # method_named case above - $meth = $self->const_sv($meth)->PV; # needs to be bare - } else { - $meth = $self->deparse($meth, 1); - } - } - my $args = join(", ", @exprs); - $kid = $obj . "->" . $meth; - if (length $args) { - return $kid . "(" . $args . ")"; # parens mandatory - } else { - return $kid; - } -} - -# returns "&" if the prototype doesn't match the args, -# or ("", $args_after_prototype_demunging) if it does. -sub check_proto { - my $self = shift; - return "&" if $self->{'noproto'}; - my($proto, @args) = @_; - my($arg, $real); - my $doneok = 0; - my @reals; - # An unbackslashed @ or % gobbles up the rest of the args - 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/; - while ($proto) { - $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//; - my $chr = $1; - if ($chr eq "") { - return "&" if @args; - } elsif ($chr eq ";") { - $doneok = 1; - } elsif ($chr eq "@" or $chr eq "%") { - push @reals, map($self->deparse($_, 6), @args); - @args = (); - } else { - $arg = shift @args; - last unless $arg; - if ($chr eq "\$") { - if (want_scalar $arg) { - push @reals, $self->deparse($arg, 6); - } else { - return "&"; - } - } elsif ($chr eq "&") { - if ($arg->name =~ /^(s?refgen|undef)$/) { - push @reals, $self->deparse($arg, 6); - } else { - return "&"; - } - } elsif ($chr eq "*") { - if ($arg->name =~ /^s?refgen$/ - and $arg->first->first->name eq "rv2gv") - { - $real = $arg->first->first; # skip refgen, null - if ($real->first->name eq "gv") { - push @reals, $self->deparse($real, 6); - } else { - push @reals, $self->deparse($real->first, 6); - } - } else { - return "&"; - } - } elsif (substr($chr, 0, 1) eq "\\") { - $chr =~ tr/\\[]//d; - if ($arg->name =~ /^s?refgen$/ and - !null($real = $arg->first) and - ($chr =~ /\$/ && is_scalar($real->first) - or ($chr =~ /@/ - && class($real->first->sibling) ne 'NULL' - && $real->first->sibling->name - =~ /^(rv2|pad)av$/) - or ($chr =~ /%/ - && class($real->first->sibling) ne 'NULL' - && $real->first->sibling->name - =~ /^(rv2|pad)hv$/) - #or ($chr =~ /&/ # This doesn't work - # && $real->first->name eq "rv2cv") - or ($chr =~ /\*/ - && $real->first->name eq "rv2gv"))) - { - push @reals, $self->deparse($real, 6); - } else { - return "&"; - } - } - } - } - return "&" if $proto and !$doneok; # too few args and no `;' - return "&" if @args; # too many args - return ("", join ", ", @reals); -} - -sub pp_entersub { - my $self = shift; - my($op, $cx) = @_; - return $self->method($op, $cx) unless null $op->first->sibling; - my $prefix = ""; - my $amper = ""; - my($kid, @exprs); - if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) { - $prefix = "do "; - } elsif ($op->private & OPpENTERSUB_AMPER) { - $amper = "&"; - } - $kid = $op->first; - $kid = $kid->first->sibling; # skip ex-list, pushmark - for (; not null $kid->sibling; $kid = $kid->sibling) { - push @exprs, $kid; - } - my $simple = 0; - my $proto = undef; - if (is_scope($kid)) { - $amper = "&"; - $kid = "{" . $self->deparse($kid, 0) . "}"; - } elsif ($kid->first->name eq "gv") { - my $gv = $self->gv_or_padgv($kid->first); - if (class($gv->CV) ne "SPECIAL") { - $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; - } - $simple = 1; # only calls of named functions can be prototyped - $kid = $self->deparse($kid, 24); - } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { - $amper = "&"; - $kid = $self->deparse($kid, 24); - } else { - $prefix = ""; - my $arrow = is_subscriptable($kid->first) ? "" : "->"; - $kid = $self->deparse($kid, 24) . $arrow; - } - - # Doesn't matter how many prototypes there are, if - # they haven't happened yet! - my $declared; - { - no strict 'refs'; - no warnings 'uninitialized'; - $declared = exists $self->{'subs_declared'}{$kid} - || ( - defined &{ ${$self->{'curstash'}."::"}{$kid} } - && !exists - $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} - && defined prototype $self->{'curstash'}."::".$kid - ); - if (!$declared && defined($proto)) { - # Avoid "too early to check prototype" warning - ($amper, $proto) = ('&'); - } - } - - my $args; - if ($declared and defined $proto and not $amper) { - ($amper, $args) = $self->check_proto($proto, @exprs); - if ($amper eq "&") { - $args = join(", ", map($self->deparse($_, 6), @exprs)); - } - } else { - $args = join(", ", map($self->deparse($_, 6), @exprs)); - } - if ($prefix or $amper) { - if ($op->flags & OPf_STACKED) { - return $prefix . $amper . $kid . "(" . $args . ")"; - } else { - return $prefix . $amper. $kid; - } - } else { - # glob() invocations can be translated into calls of - # CORE::GLOBAL::glob with a second parameter, a number. - # Reverse this. - if ($kid eq "CORE::GLOBAL::glob") { - $kid = "glob"; - $args =~ s/\s*,[^,]+$//; - } - - # It's a syntax error to call CORE::GLOBAL::foo without a prefix, - # so it must have been translated from a keyword call. Translate - # it back. - $kid =~ s/^CORE::GLOBAL:://; - - my $dproto = defined($proto) ? $proto : "undefined"; - if (!$declared) { - return "$kid(" . $args . ")"; - } elsif ($dproto eq "") { - return $kid; - } elsif ($dproto eq "\$" and is_scalar($exprs[0])) { - # is_scalar is an excessively conservative test here: - # really, we should be comparing to the precedence of the - # top operator of $exprs[0] (ala unop()), but that would - # take some major code restructuring to do right. - return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif ($dproto ne '$' and defined($proto) || $simple) { #' - return $self->maybe_parens_func($kid, $args, $cx, 5); - } else { - return "$kid(" . $args . ")"; - } - } -} - -sub pp_enterwrite { unop(@_, "write") } - -# escape things that cause interpolation in double quotes, -# but not character escapes -sub uninterp { - my($str) = @_; - $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; - return $str; -} - -{ -my $bal; -BEGIN { - use re "eval"; - # Matches any string which is balanced with respect to {braces} - $bal = qr( - (?: - [^\\{}] - | \\\\ - | \\[{}] - | \{(??{$bal})\} - )* - )x; -} - -# the same, but treat $|, $), $( and $ at the end of the string differently -sub re_uninterp { - my($str) = @_; - - $str =~ s/ - ( ^|\G # $1 - | [^\\] - ) - - ( # $2 - (?:\\\\)* - ) - - ( # $3 - (\(\?\??\{$bal\}\)) # $4 - | [\$\@] - (?!\||\)|\(|$) - | \\[uUlLQE] - ) - - /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; - - return $str; -} - -# This is for regular expressions with the /x modifier -# We have to leave comments unmangled. -sub re_uninterp_extended { - my($str) = @_; - - $str =~ s/ - ( ^|\G # $1 - | [^\\] - ) - - ( # $2 - (?:\\\\)* - ) - - ( # $3 - ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) - | \#[^\n]* # (skip over comments) - ) - | [\$\@] - (?!\||\)|\(|$|\s) - | \\[uUlLQE] - ) - - /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; - - return $str; -} -} - -my %unctrl = # portable to to EBCDIC - ( - "\c@" => '\c@', # unused - "\cA" => '\cA', - "\cB" => '\cB', - "\cC" => '\cC', - "\cD" => '\cD', - "\cE" => '\cE', - "\cF" => '\cF', - "\cG" => '\cG', - "\cH" => '\cH', - "\cI" => '\cI', - "\cJ" => '\cJ', - "\cK" => '\cK', - "\cL" => '\cL', - "\cM" => '\cM', - "\cN" => '\cN', - "\cO" => '\cO', - "\cP" => '\cP', - "\cQ" => '\cQ', - "\cR" => '\cR', - "\cS" => '\cS', - "\cT" => '\cT', - "\cU" => '\cU', - "\cV" => '\cV', - "\cW" => '\cW', - "\cX" => '\cX', - "\cY" => '\cY', - "\cZ" => '\cZ', - "\c[" => '\c[', # unused - "\c\\" => '\c\\', # unused - "\c]" => '\c]', # unused - "\c_" => '\c_', # unused - ); - -# character escapes, but not delimiters that might need to be escaped -sub escape_str { # ASCII, UTF8 - my($str) = @_; - $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; - $str =~ s/\a/\\a/g; -# $str =~ s/\cH/\\b/g; # \b means something different in a regex - $str =~ s/\t/\\t/g; - $str =~ s/\n/\\n/g; - $str =~ s/\e/\\e/g; - $str =~ s/\f/\\f/g; - $str =~ s/\r/\\r/g; - $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge; - $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge; - return $str; -} - -# For regexes with the /x modifier. -# Leave whitespace unmangled. -sub escape_extended_re { - my($str) = @_; - $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; - $str =~ s/([[:^print:]])/ - ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge; - $str =~ s/\n/\n\f/g; - return $str; -} - -# Don't do this for regexen -sub unback { - my($str) = @_; - $str =~ s/\\/\\\\/g; - return $str; -} - -# Remove backslashes which precede literal control characters, -# to avoid creating ambiguity when we escape the latter. -sub re_unback { - my($str) = @_; - - # the insane complexity here is due to the behaviour of "\c\" - $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g; - return $str; -} - -sub balanced_delim { - my($str) = @_; - my @str = split //, $str; - my($ar, $open, $close, $fail, $c, $cnt); - for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { - ($open, $close) = @$ar; - $fail = 0; $cnt = 0; - for $c (@str) { - if ($c eq $open) { - $cnt++; - } elsif ($c eq $close) { - $cnt--; - if ($cnt < 0) { - # qq()() isn't ")(" - $fail = 1; - last; - } - } - } - $fail = 1 if $cnt != 0; - return ($open, "$open$str$close") if not $fail; - } - return ("", $str); -} - -sub single_delim { - my($q, $default, $str) = @_; - return "$default$str$default" if $default and index($str, $default) == -1; - if ($q ne 'qr') { - (my $succeed, $str) = balanced_delim($str); - return "$q$str" if $succeed; - } - for my $delim ('/', '"', '#') { - return "$q$delim" . $str . $delim if index($str, $delim) == -1; - } - if ($default) { - $str =~ s/$default/\\$default/g; - return "$default$str$default"; - } else { - $str =~ s[/][\\/]g; - return "$q/$str/"; - } -} - -my $max_prec; -BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } - -# Split a floating point number into an integer mantissa and a binary -# exponent. Assumes you've already made sure the number isn't zero or -# some weird infinity or NaN. -sub split_float { - my($f) = @_; - my $exponent = 0; - if ($f == int($f)) { - while ($f % 2 == 0) { - $f /= 2; - $exponent++; - } - } else { - while ($f != int($f)) { - $f *= 2; - $exponent--; - } - } - my $mantissa = sprintf("%.0f", $f); - return ($mantissa, $exponent); -} - -sub const { - my $self = shift; - my($sv, $cx) = @_; - if ($self->{'use_dumper'}) { - return $self->const_dumper($sv, $cx); - } - if (class($sv) eq "SPECIAL") { - # sv_undef, sv_yes, sv_no - return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1]; - } elsif (class($sv) eq "NULL") { - return 'undef'; - } - # convert a version object into the "v1.2.3" string in its V magic - if ($sv->FLAGS & SVs_RMG) { - for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { - return $mg->PTR if $mg->TYPE eq 'V'; - } - } - - if ($sv->FLAGS & SVf_IOK) { - my $str = $sv->int_value; - $str = $self->maybe_parens($str, $cx, 21) if $str < 0; - return $str; - } elsif ($sv->FLAGS & SVf_NOK) { - my $nv = $sv->NV; - if ($nv == 0) { - if (pack("F", $nv) eq pack("F", 0)) { - # positive zero - return "0"; - } else { - # negative zero - return $self->maybe_parens("-.0", $cx, 21); - } - } elsif (1/$nv == 0) { - if ($nv > 0) { - # positive infinity - return $self->maybe_parens("9**9**9", $cx, 22); - } else { - # negative infinity - return $self->maybe_parens("-9**9**9", $cx, 21); - } - } elsif ($nv != $nv) { - # NaN - if (pack("F", $nv) eq pack("F", sin(9**9**9))) { - # the normal kind - return "sin(9**9**9)"; - } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { - # the inverted kind - return $self->maybe_parens("-sin(9**9**9)", $cx, 21); - } else { - # some other kind - my $hex = unpack("h*", pack("F", $nv)); - return qq'unpack("F", pack("h*", "$hex"))'; - } - } - # first, try the default stringification - my $str = "$nv"; - if ($str != $nv) { - # failing that, try using more precision - $str = sprintf("%.${max_prec}g", $nv); -# if (pack("F", $str) ne pack("F", $nv)) { - if ($str != $nv) { - # not representable in decimal with whatever sprintf() - # and atof() Perl is using here. - my($mant, $exp) = split_float($nv); - return $self->maybe_parens("$mant * 2**$exp", $cx, 19); - } - } - $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; - return $str; - } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { - my $ref = $sv->RV; - if (class($ref) eq "AV") { - return "[" . $self->list_const(2, $ref->ARRAY) . "]"; - } elsif (class($ref) eq "HV") { - my %hash = $ref->ARRAY; - my @elts; - for my $k (sort keys %hash) { - push @elts, "$k => " . $self->const($hash{$k}, 6); - } - return "{" . join(", ", @elts) . "}"; - } elsif (class($ref) eq "CV") { - return "sub " . $self->deparse_sub($ref); - } - if ($ref->FLAGS & SVs_SMG) { - for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { - if ($mg->TYPE eq 'r') { - my $re = re_uninterp(escape_str(re_unback($mg->precomp))); - return single_delim("qr", "", $re); - } - } - } - - return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20); - } elsif ($sv->FLAGS & SVf_POK) { - my $str = $sv->PV; - if ($str =~ /[^ -~]/) { # ASCII for non-printing - return single_delim("qq", '"', uninterp escape_str unback $str); - } else { - return single_delim("q", "'", unback $str); - } - } else { - return "undef"; - } -} - -sub const_dumper { - my $self = shift; - my($sv, $cx) = @_; - my $ref = $sv->object_2svref(); - my $dumper = Data::Dumper->new([$$ref], ['$v']); - $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); - my $str = $dumper->Dump(); - if ($str =~ /^\$v/) { - return '${my ' . $str . ' \$v}'; - } else { - return $str; - } -} - -sub const_sv { - my $self = shift; - my $op = shift; - my $sv = $op->sv; - # the constant could be in the pad (under useithreads) - $sv = $self->padval($op->targ) unless $$sv; - return $sv; -} - -sub pp_const { - my $self = shift; - my($op, $cx) = @_; - if ($op->private & OPpCONST_ARYBASE) { - return '$['; - } -# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting -# return $self->const_sv($op)->PV; -# } - my $sv = $self->const_sv($op); - return $self->const($sv, $cx); -} - -sub dq { - my $self = shift; - my $op = shift; - my $type = $op->name; - if ($type eq "const") { - return '$[' if $op->private & OPpCONST_ARYBASE; - return uninterp(escape_str(unback($self->const_sv($op)->as_string))); - } elsif ($type eq "concat") { - my $first = $self->dq($op->first); - my $last = $self->dq($op->last); - - # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" - ($last =~ /^[A-Z\\\^\[\]_?]/ && - $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc - || ($last =~ /^[:'{\[\w_]/ && #' - $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); - - return $first . $last; - } elsif ($type eq "uc") { - return '\U' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "lc") { - return '\L' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "ucfirst") { - return '\u' . $self->dq($op->first->sibling); - } elsif ($type eq "lcfirst") { - return '\l' . $self->dq($op->first->sibling); - } elsif ($type eq "quotemeta") { - return '\Q' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "join") { - return $self->deparse($op->last, 26); # was join($", @ary) - } else { - return $self->deparse($op, 26); - } -} - -sub pp_backtick { - my $self = shift; - my($op, $cx) = @_; - # skip pushmark - return single_delim("qx", '`', $self->dq($op->first->sibling)); -} - -sub dquote { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first->sibling; # skip ex-stringify, pushmark - return $self->deparse($kid, $cx) if $self->{'unquote'}; - $self->maybe_targmy($kid, $cx, - sub {single_delim("qq", '"', $self->dq($_[1]))}); -} - -# OP_STRINGIFY is a listop, but it only ever has one arg -sub pp_stringify { maybe_targmy(@_, \&dquote) } - -# tr/// and s/// (and tr[][], tr[]//, tr###, etc) -# note that tr(from)/to/ is OK, but not tr/from/(to) -sub double_delim { - my($from, $to) = @_; - my($succeed, $delim); - if ($from !~ m[/] and $to !~ m[/]) { - return "/$from/$to/"; - } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { - if (($succeed, $to) = balanced_delim($to) and $succeed) { - return "$from$to"; - } else { - for $delim ('/', '"', '#') { # note no `'' -- s''' is special - return "$from$delim$to$delim" if index($to, $delim) == -1; - } - $to =~ s[/][\\/]g; - return "$from/$to/"; - } - } else { - for $delim ('/', '"', '#') { # note no ' - return "$delim$from$delim$to$delim" - if index($to . $from, $delim) == -1; - } - $from =~ s[/][\\/]g; - $to =~ s[/][\\/]g; - return "/$from/$to/"; - } -} - -# Only used by tr///, so backslashes hyphens -sub pchr { # ASCII - my($n) = @_; - if ($n == ord '\\') { - return '\\\\'; - } elsif ($n == ord "-") { - return "\\-"; - } elsif ($n >= ord(' ') and $n <= ord('~')) { - return chr($n); - } elsif ($n == ord "\a") { - return '\\a'; - } elsif ($n == ord "\b") { - return '\\b'; - } elsif ($n == ord "\t") { - return '\\t'; - } elsif ($n == ord "\n") { - return '\\n'; - } elsif ($n == ord "\e") { - return '\\e'; - } elsif ($n == ord "\f") { - return '\\f'; - } elsif ($n == ord "\r") { - return '\\r'; - } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { - return '\\c' . chr(ord("@") + $n); - } else { -# return '\x' . sprintf("%02x", $n); - return '\\' . sprintf("%03o", $n); - } -} - -sub collapse { - my(@chars) = @_; - my($str, $c, $tr) = (""); - for ($c = 0; $c < @chars; $c++) { - $tr = $chars[$c]; - $str .= pchr($tr); - if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and - $chars[$c + 2] == $tr + 2) - { - for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) - {} - $str .= "-"; - $str .= pchr($chars[$c]); - } - } - return $str; -} - -sub tr_decode_byte { - my($table, $flags) = @_; - my(@table) = unpack("s*", $table); - splice @table, 0x100, 1; # Number of subsequent elements - my($c, $tr, @from, @to, @delfrom, $delhyphen); - if ($table[ord "-"] != -1 and - $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) - { - $tr = $table[ord "-"]; - $table[ord "-"] = -1; - if ($tr >= 0) { - @from = ord("-"); - @to = $tr; - } else { # -2 ==> delete - $delhyphen = 1; - } - } - for ($c = 0; $c < @table; $c++) { - $tr = $table[$c]; - if ($tr >= 0) { - push @from, $c; push @to, $tr; - } elsif ($tr == -2) { - push @delfrom, $c; - } - } - @from = (@from, @delfrom); - if ($flags & OPpTRANS_COMPLEMENT) { - my @newfrom = (); - my %from; - @from{@from} = (1) x @from; - for ($c = 0; $c < 256; $c++) { - push @newfrom, $c unless $from{$c}; - } - @from = @newfrom; - } - unless ($flags & OPpTRANS_DELETE || !@to) { - pop @to while $#to and $to[$#to] == $to[$#to -1]; - } - my($from, $to); - $from = collapse(@from); - $to = collapse(@to); - $from .= "-" if $delhyphen; - return ($from, $to); -} - -sub tr_chr { - my $x = shift; - if ($x == ord "-") { - return "\\-"; - } elsif ($x == ord "\\") { - return "\\\\"; - } else { - return chr $x; - } -} - -# XXX This doesn't yet handle all cases correctly either - -sub tr_decode_utf8 { - my($swash_hv, $flags) = @_; - my %swash = $swash_hv->ARRAY; - my $final = undef; - $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; - my $none = $swash{"NONE"}->IV; - my $extra = $none + 1; - my(@from, @delfrom, @to); - my $line; - foreach $line (split /\n/, $swash{'LIST'}->PV) { - my($min, $max, $result) = split(/\t/, $line); - $min = hex $min; - if (length $max) { - $max = hex $max; - } else { - $max = $min; - } - $result = hex $result; - if ($result == $extra) { - push @delfrom, [$min, $max]; - } else { - push @from, [$min, $max]; - push @to, [$result, $result + $max - $min]; - } - } - for my $i (0 .. $#from) { - if ($from[$i][0] == ord '-') { - unshift @from, splice(@from, $i, 1); - unshift @to, splice(@to, $i, 1); - last; - } elsif ($from[$i][1] == ord '-') { - $from[$i][1]--; - $to[$i][1]--; - unshift @from, ord '-'; - unshift @to, ord '-'; - last; - } - } - for my $i (0 .. $#delfrom) { - if ($delfrom[$i][0] == ord '-') { - push @delfrom, splice(@delfrom, $i, 1); - last; - } elsif ($delfrom[$i][1] == ord '-') { - $delfrom[$i][1]--; - push @delfrom, ord '-'; - last; - } - } - if (defined $final and $to[$#to][1] != $final) { - push @to, [$final, $final]; - } - push @from, @delfrom; - if ($flags & OPpTRANS_COMPLEMENT) { - my @newfrom; - my $next = 0; - for my $i (0 .. $#from) { - push @newfrom, [$next, $from[$i][0] - 1]; - $next = $from[$i][1] + 1; - } - @from = (); - for my $range (@newfrom) { - if ($range->[0] <= $range->[1]) { - push @from, $range; - } - } - } - my($from, $to, $diff); - for my $chunk (@from) { - $diff = $chunk->[1] - $chunk->[0]; - if ($diff > 1) { - $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); - } elsif ($diff == 1) { - $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); - } else { - $from .= tr_chr($chunk->[0]); - } - } - for my $chunk (@to) { - $diff = $chunk->[1] - $chunk->[0]; - if ($diff > 1) { - $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); - } elsif ($diff == 1) { - $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); - } else { - $to .= tr_chr($chunk->[0]); - } - } - #$final = sprintf("%04x", $final) if defined $final; - #$none = sprintf("%04x", $none) if defined $none; - #$extra = sprintf("%04x", $extra) if defined $extra; - #print STDERR "final: $final\n none: $none\nextra: $extra\n"; - #print STDERR $swash{'LIST'}->PV; - return (escape_str($from), escape_str($to)); -} - -sub pp_trans { - my $self = shift; - my($op, $cx) = @_; - my($from, $to); - if (class($op) eq "PVOP") { - ($from, $to) = tr_decode_byte($op->pv, $op->private); - } else { # class($op) eq "SVOP" - ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private); - } - my $flags = ""; - $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT; - $flags .= "d" if $op->private & OPpTRANS_DELETE; - $to = "" if $from eq $to and $flags eq ""; - $flags .= "s" if $op->private & OPpTRANS_SQUASH; - return "tr" . double_delim($from, $to) . $flags; -} - -# Like dq(), but different -sub re_dq { - my $self = shift; - my ($op, $extended) = @_; - - my $type = $op->name; - if ($type eq "const") { - return '$[' if $op->private & OPpCONST_ARYBASE; - my $unbacked = re_unback($self->const_sv($op)->as_string); - return re_uninterp_extended(escape_extended_re($unbacked)) - if $extended; - return re_uninterp(escape_str($unbacked)); - } elsif ($type eq "concat") { - my $first = $self->re_dq($op->first, $extended); - my $last = $self->re_dq($op->last, $extended); - - # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" - ($last =~ /^[A-Z\\\^\[\]_?]/ && - $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc - || ($last =~ /^[{\[\w_]/ && - $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); - - return $first . $last; - } elsif ($type eq "uc") { - return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E'; - } elsif ($type eq "lc") { - return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E'; - } elsif ($type eq "ucfirst") { - return '\u' . $self->re_dq($op->first->sibling, $extended); - } elsif ($type eq "lcfirst") { - return '\l' . $self->re_dq($op->first->sibling, $extended); - } elsif ($type eq "quotemeta") { - return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E'; - } elsif ($type eq "join") { - return $self->deparse($op->last, 26); # was join($", @ary) - } else { - return $self->deparse($op, 26); - } -} - -sub pure_string { - my ($self, $op) = @_; - return 0 if null $op; - my $type = $op->name; - - if ($type eq 'const') { - return 1; - } - elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') { - return $self->pure_string($op->first->sibling); - } - elsif ($type eq 'join') { - my $join_op = $op->first->sibling; # Skip pushmark - return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV; - - my $gvop = $join_op->first; - return 0 unless $gvop->name eq 'gvsv'; - return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); - - return 0 unless ${$join_op->sibling} eq ${$op->last}; - return 0 unless $op->last->name =~ /^(rv2|pad)av$/; - } - elsif ($type eq 'concat') { - return $self->pure_string($op->first) - && $self->pure_string($op->last); - } - elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { - return 1; - } - elsif ($type eq "null" and $op->can('first') and not null $op->first and - $op->first->name eq "null" and $op->first->can('first') - and not null $op->first->first and - $op->first->first->name eq "aelemfast") { - return 1; - } - else { - return 0; - } - - return 1; -} - -sub regcomp { - my $self = shift; - my($op, $cx, $extended) = @_; - my $kid = $op->first; - $kid = $kid->first if $kid->name eq "regcmaybe"; - $kid = $kid->first if $kid->name eq "regcreset"; - if ($kid->name eq "null" and !null($kid->first) - and $kid->first->name eq 'pushmark') - { - my $str = ''; - $kid = $kid->first->sibling; - while (!null($kid)) { - $str .= $self->re_dq($kid, $extended); - $kid = $kid->sibling; - } - return $str, 1; - } - - return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid); - return ($self->deparse($kid, $cx), 0); -} - -sub pp_regcomp { - my ($self, $op, $cx) = @_; - return (($self->regcomp($op, $cx, 0))[0]); -} - -# osmic acid -- see osmium tetroxide - -my %matchwords; -map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', - 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', - 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); - -sub matchop { - my $self = shift; - my($op, $cx, $name, $delim) = @_; - my $kid = $op->first; - my ($binop, $var, $re) = ("", "", ""); - if ($op->flags & OPf_STACKED) { - $binop = 1; - $var = $self->deparse($kid, 20); - $kid = $kid->sibling; - } - my $quote = 1; - my $extended = ($op->pmflags & PMf_EXTENDED); - if (null $kid) { - my $unbacked = re_unback($op->precomp); - if ($extended) { - $re = re_uninterp_extended(escape_extended_re($unbacked)); - } else { - $re = re_uninterp(escape_str(re_unback($op->precomp))); - } - } elsif ($kid->name ne 'regcomp') { - carp("found ".$kid->name." where regcomp expected"); - } else { - ($re, $quote) = $self->regcomp($kid, 21, $extended); - } - my $flags = ""; - $flags .= "c" if $op->pmflags & PMf_CONTINUE; - $flags .= "g" if $op->pmflags & PMf_GLOBAL; - $flags .= "i" if $op->pmflags & PMf_FOLD; - $flags .= "m" if $op->pmflags & PMf_MULTILINE; - $flags .= "o" if $op->pmflags & PMf_KEEP; - $flags .= "s" if $op->pmflags & PMf_SINGLELINE; - $flags .= "x" if $op->pmflags & PMf_EXTENDED; - $flags = $matchwords{$flags} if $matchwords{$flags}; - if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here - $re =~ s/\?/\\?/g; - $re = "?$re?"; - } elsif ($quote) { - $re = single_delim($name, $delim, $re); - } - $re = $re . $flags if $quote; - if ($binop) { - return $self->maybe_parens("$var =~ $re", $cx, 20); - } else { - return $re; - } -} - -sub pp_match { matchop(@_, "m", "/") } -sub pp_pushre { matchop(@_, "m", "/") } -sub pp_qr { matchop(@_, "qr", "") } - -sub pp_split { - my $self = shift; - my($op, $cx) = @_; - my($kid, @exprs, $ary, $expr); - $kid = $op->first; - - # For our kid (an OP_PUSHRE), pmreplroot is never actually the - # root of a replacement; it's either empty, or abused to point to - # the GV for an array we split into (an optimization to save - # assignment overhead). Depending on whether we're using ithreads, - # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs - # figures out for us which it is. - my $replroot = $kid->pmreplroot; - my $gv = 0; - if (ref($replroot) eq "B::GV") { - $gv = $replroot; - } elsif (!ref($replroot) and $replroot > 0) { - $gv = $self->padval($replroot); - } - $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv; - - for (; !null($kid); $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); - } - - # handle special case of split(), and split(" ") that compiles to /\s+/ - $kid = $op->first; - if ($kid->flags & OPf_SPECIAL - && $exprs[0] eq '/\\s+/' - && $kid->pmflags & PMf_SKIPWHITE ) { - $exprs[0] = '" "'; - } - - $expr = "split(" . join(", ", @exprs) . ")"; - if ($ary) { - return $self->maybe_parens("$ary = $expr", $cx, 7); - } else { - return $expr; - } -} - -# oxime -- any of various compounds obtained chiefly by the action of -# hydroxylamine on aldehydes and ketones and characterized by the -# bivalent grouping C=NOH [Webster's Tenth] - -my %substwords; -map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', - 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', - 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', - 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi'); - -sub pp_subst { - my $self = shift; - my($op, $cx) = @_; - my $kid = $op->first; - my($binop, $var, $re, $repl) = ("", "", "", ""); - if ($op->flags & OPf_STACKED) { - $binop = 1; - $var = $self->deparse($kid, 20); - $kid = $kid->sibling; - } - my $flags = ""; - if (null($op->pmreplroot)) { - $repl = $self->dq($kid); - $kid = $kid->sibling; - } else { - $repl = $op->pmreplroot->first; # skip substcont - while ($repl->name eq "entereval") { - $repl = $repl->first; - $flags .= "e"; - } - if ($op->pmflags & PMf_EVAL) { - $repl = $self->deparse($repl->first, 0); - } else { - $repl = $self->dq($repl); - } - } - my $extended = ($op->pmflags & PMf_EXTENDED); - if (null $kid) { - my $unbacked = re_unback($op->precomp); - if ($extended) { - $re = re_uninterp_extended(escape_extended_re($unbacked)); - } - else { - $re = re_uninterp(escape_str($unbacked)); - } - } else { - ($re) = $self->regcomp($kid, 1, $extended); - } - $flags .= "e" if $op->pmflags & PMf_EVAL; - $flags .= "g" if $op->pmflags & PMf_GLOBAL; - $flags .= "i" if $op->pmflags & PMf_FOLD; - $flags .= "m" if $op->pmflags & PMf_MULTILINE; - $flags .= "o" if $op->pmflags & PMf_KEEP; - $flags .= "s" if $op->pmflags & PMf_SINGLELINE; - $flags .= "x" if $extended; - $flags = $substwords{$flags} if $substwords{$flags}; - if ($binop) { - return $self->maybe_parens("$var =~ s" - . double_delim($re, $repl) . $flags, - $cx, 20); - } else { - return "s". double_delim($re, $repl) . $flags; - } -} - -1; -__END__ - -=head1 NAME - -B::Deparse - Perl compiler backend to produce perl code - -=head1 SYNOPSIS - -B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>] - [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> - -=head1 DESCRIPTION - -B::Deparse is a backend module for the Perl compiler that generates -perl source code, based on the internal compiled structure that perl -itself creates after parsing a program. The output of B::Deparse won't -be exactly the same as the original source, since perl doesn't keep -track of comments or whitespace, and there isn't a one-to-one -correspondence between perl's syntactical constructions and their -compiled form, but it will often be close. When you use the B<-p> -option, the output also includes parentheses even when they are not -required by precedence, which can make it easy to see if perl is -parsing your expressions the way you intended. - -While B::Deparse goes to some lengths to try to figure out what your -original program was doing, some parts of the language can still trip -it up; it still fails even on some parts of Perl's own test suite. If -you encounter a failure other than the most common ones described in -the BUGS section below, you can help contribute to B::Deparse's -ongoing development by submitting a bug report with a small -example. - -=head1 OPTIONS - -As with all compiler backend options, these must follow directly after -the '-MO=Deparse', separated by a comma but not any white space. - -=over 4 - -=item B<-d> - -Output data values (when they appear as constants) using Data::Dumper. -Without this option, B::Deparse will use some simple routines of its -own for the same purpose. Currently, Data::Dumper is better for some -kinds of data (such as complex structures with sharing and -self-reference) while the built-in routines are better for others -(such as odd floating-point values). - -=item B<-f>I<FILE> - -Normally, B::Deparse deparses the main code of a program, and all the subs -defined in the same file. To include subs defined in other files, pass the -B<-f> option with the filename. You can pass the B<-f> option several times, to -include more than one secondary file. (Most of the time you don't want to -use it at all.) You can also use this option to include subs which are -defined in the scope of a B<#line> directive with two parameters. - -=item B<-l> - -Add '#line' declarations to the output based on the line and file -locations of the original code. - -=item B<-p> - -Print extra parentheses. Without this option, B::Deparse includes -parentheses in its output only when they are needed, based on the -structure of your program. With B<-p>, it uses parentheses (almost) -whenever they would be legal. This can be useful if you are used to -LISP, or if you want to see how perl parses your input. If you say - - if ($var & 0x7f == 65) {print "Gimme an A!"} - print ($which ? $a : $b), "\n"; - $name = $ENV{USER} or "Bob"; - -C<B::Deparse,-p> will print - - if (($var & 0)) { - print('Gimme an A!') - }; - (print(($which ? $a : $b)), '???'); - (($name = $ENV{'USER'}) or '???') - -which probably isn't what you intended (the C<'???'> is a sign that -perl optimized away a constant value). - -=item B<-P> - -Disable prototype checking. With this option, all function calls are -deparsed as if no prototype was defined for them. In other words, - - perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' - -will print - - sub foo (\@) { - 1; - } - &foo(\@x); - -making clear how the parameters are actually passed to C<foo>. - -=item B<-q> - -Expand double-quoted strings into the corresponding combinations of -concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For -instance, print - - print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; - -as - - print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' - . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); - -Note that the expanded form represents the way perl handles such -constructions internally -- this option actually turns off the reverse -translation that B::Deparse usually does. On the other hand, note that -C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value -of $y into a string before doing the assignment. - -=item B<-s>I<LETTERS> - -Tweak the style of B::Deparse's output. The letters should follow -directly after the 's', with no space or punctuation. The following -options are available: - -=over 4 - -=item B<C> - -Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print - - if (...) { - ... - } else { - ... - } - -instead of - - if (...) { - ... - } - else { - ... - } - -The default is not to cuddle. - -=item B<i>I<NUMBER> - -Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. - -=item B<T> - -Use tabs for each 8 columns of indent. The default is to use only spaces. -For instance, if the style options are B<-si4T>, a line that's indented -3 times will be preceded by one tab and four spaces; if the options were -B<-si8T>, the same line would be preceded by three tabs. - -=item B<v>I<STRING>B<.> - -Print I<STRING> for the value of a constant that can't be determined -because it was optimized away (mnemonic: this happens when a constant -is used in B<v>oid context). The end of the string is marked by a period. -The string should be a valid perl expression, generally a constant. -Note that unless it's a number, it probably needs to be quoted, and on -a command line quotes need to be protected from the shell. Some -conventional values include 0, 1, 42, '', 'foo', and -'Useless use of constant omitted' (which may need to be -B<-sv"'Useless use of constant omitted'."> -or something similar depending on your shell). The default is '???'. -If you're using B::Deparse on a module or other file that's require'd, -you shouldn't use a value that evaluates to false, since the customary -true constant at the end of a module will be in void context when the -file is compiled as a main program. - -=back - -=item B<-x>I<LEVEL> - -Expand conventional syntax constructions into equivalent ones that expose -their internal operation. I<LEVEL> should be a digit, with higher values -meaning more expansion. As with B<-q>, this actually involves turning off -special cases in B::Deparse's normal operations. - -If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent -while loops with continue blocks; for instance - - for ($i = 0; $i < 10; ++$i) { - print $i; - } - -turns into - - $i = 0; - while ($i < 10) { - print $i; - } continue { - ++$i - } - -Note that in a few cases this translation can't be perfectly carried back -into the source code -- if the loop's initializer declares a my variable, -for instance, it won't have the correct scope outside of the loop. - -If I<LEVEL> is at least 5, C<use> declarations will be translated into -C<BEGIN> blocks containing calls to C<require> and C<import>; for -instance, - - use strict 'refs'; - -turns into - - sub BEGIN { - require strict; - do { - 'strict'->import('refs') - }; - } - -If I<LEVEL> is at least 7, C<if> statements will be translated into -equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance - - print 'hi' if $nice; - if ($nice) { - print 'hi'; - } - if ($nice) { - print 'hi'; - } else { - print 'bye'; - } - -turns into - - $nice and print 'hi'; - $nice and do { print 'hi' }; - $nice ? do { print 'hi' } : do { print 'bye' }; - -Long sequences of elsifs will turn into nested ternary operators, which -B::Deparse doesn't know how to indent nicely. - -=back - -=head1 USING B::Deparse AS A MODULE - -=head2 Synopsis - - use B::Deparse; - $deparse = B::Deparse->new("-p", "-sC"); - $body = $deparse->coderef2text(\&func); - eval "sub func $body"; # the inverse operation - -=head2 Description - -B::Deparse can also be used on a sub-by-sub basis from other perl -programs. - -=head2 new - - $deparse = B::Deparse->new(OPTIONS) - -Create an object to store the state of a deparsing operation and any -options. The options are the same as those that can be given on the -command line (see L</OPTIONS>); options that are separated by commas -after B<-MO=Deparse> should be given as separate strings. Some -options, like B<-u>, don't make sense for a single subroutine, so -don't pass them. - -=head2 ambient_pragmas - - $deparse->ambient_pragmas(strict => 'all', '$[' => $[); - -The compilation of a subroutine can be affected by a few compiler -directives, B<pragmas>. These are: - -=over 4 - -=item * - -use strict; - -=item * - -use warnings; - -=item * - -Assigning to the special variable $[ - -=item * - -use integer; - -=item * - -use bytes; - -=item * - -use utf8; - -=item * - -use re; - -=back - -Ordinarily, if you use B::Deparse on a subroutine which has -been compiled in the presence of one or more of these pragmas, -the output will include statements to turn on the appropriate -directives. So if you then compile the code returned by coderef2text, -it will behave the same way as the subroutine which you deparsed. - -However, you may know that you intend to use the results in a -particular context, where some pragmas are already in scope. In -this case, you use the B<ambient_pragmas> method to describe the -assumptions you wish to make. - -Not all of the options currently have any useful effect. See -L</BUGS> for more details. - -The parameters it accepts are: - -=over 4 - -=item strict - -Takes a string, possibly containing several values separated -by whitespace. The special values "all" and "none" mean what you'd -expect. - - $deparse->ambient_pragmas(strict => 'subs refs'); - -=item $[ - -Takes a number, the value of the array base $[. - -=item bytes - -=item utf8 - -=item integer - -If the value is true, then the appropriate pragma is assumed to -be in the ambient scope, otherwise not. - -=item re - -Takes a string, possibly containing a whitespace-separated list of -values. The values "all" and "none" are special. It's also permissible -to pass an array reference here. - - $deparser->ambient_pragmas(re => 'eval'); - - -=item warnings - -Takes a string, possibly containing a whitespace-separated list of -values. The values "all" and "none" are special, again. It's also -permissible to pass an array reference here. - - $deparser->ambient_pragmas(warnings => [qw[void io]]); - -If one of the values is the string "FATAL", then all the warnings -in that list will be considered fatal, just as with the B<warnings> -pragma itself. Should you need to specify that some warnings are -fatal, and others are merely enabled, you can pass the B<warnings> -parameter twice: - - $deparser->ambient_pragmas( - warnings => 'all', - warnings => [FATAL => qw/void io/], - ); - -See L<perllexwarn> for more information about lexical warnings. - -=item hint_bits - -=item warning_bits - -These two parameters are used to specify the ambient pragmas in -the format used by the special variables $^H and ${^WARNING_BITS}. - -They exist principally so that you can write code like: - - { my ($hint_bits, $warning_bits); - BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} - $deparser->ambient_pragmas ( - hint_bits => $hint_bits, - warning_bits => $warning_bits, - '$[' => 0 + $[ - ); } - -which specifies that the ambient pragmas are exactly those which -are in scope at the point of calling. - -=back - -=head2 coderef2text - - $body = $deparse->coderef2text(\&func) - $body = $deparse->coderef2text(sub ($$) { ... }) - -Return source code for the body of a subroutine (a block, optionally -preceded by a prototype in parens), given a reference to the -sub. Because a subroutine can have no names, or more than one name, -this method doesn't return a complete subroutine definition -- if you -want to eval the result, you should prepend "sub subname ", or "sub " -for an anonymous function constructor. Unless the sub was defined in -the main:: package, the code will include a package declaration. - -=head1 BUGS - -=over 4 - -=item * - -The only pragmas to be completely supported are: C<use warnings>, -C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which -behaves like a pragma, is also supported.) - -Excepting those listed above, we're currently unable to guarantee that -B::Deparse will produce a pragma at the correct point in the program. -(Specifically, pragmas at the beginning of a block often appear right -before the start of the block instead.) -Since the effects of pragmas are often lexically scoped, this can mean -that the pragma holds sway over a different portion of the program -than in the input file. - -=item * - -In fact, the above is a specific instance of a more general problem: -we can't guarantee to produce BEGIN blocks or C<use> declarations in -exactly the right place. So if you use a module which affects compilation -(such as by over-riding keywords, overloading constants or whatever) -then the output code might not work as intended. - -This is the most serious outstanding problem, and will require some help -from the Perl core to fix. - -=item * - -If a keyword is over-ridden, and your program explicitly calls -the built-in version by using CORE::keyword, the output of B::Deparse -will not reflect this. If you run the resulting code, it will call -the over-ridden version rather than the built-in one. (Maybe there -should be an option to B<always> print keyword calls as C<CORE::name>.) - -=item * - -Some constants don't print correctly either with or without B<-d>. -For instance, neither B::Deparse nor Data::Dumper know how to print -dual-valued scalars correctly, as in: - - use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y; - -=item * - -An input file that uses source filtering probably won't be deparsed into -runnable code, because it will still include the B<use> declaration -for the source filtering module, even though the code that is -produced is already ordinary Perl which shouldn't be filtered again. - -=item * - -Optimised away statements are rendered as '???'. This includes statements that -have a compile-time side-effect, such as the obscure - - my $x if 0; - -which is not, consequently, deparsed correctly. - -=item * - -There are probably many more bugs on non-ASCII platforms (EBCDIC). - -=back - -=head1 AUTHOR - -Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version -by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from -Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, -Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael -Garcia-Suarez. - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Disassembler.pm b/Master/tlpkg/tlperl/lib/B/Disassembler.pm deleted file mode 100644 index e1993aa9537..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Disassembler.pm +++ /dev/null @@ -1,233 +0,0 @@ -# Disassembler.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. - -$B::Disassembler::VERSION = '1.05'; - -package B::Disassembler::BytecodeStream; - -use FileHandle; -use Carp; -use Config qw(%Config); -use B qw(cstring cast_I32); -@ISA = qw(FileHandle); -sub readn { - my ($fh, $len) = @_; - my $data; - read($fh, $data, $len); - croak "reached EOF while reading $len bytes" unless length($data) == $len; - return $data; -} - -sub GET_U8 { - my $fh = shift; - my $c = $fh->getc; - croak "reached EOF while reading U8" unless defined($c); - return ord($c); -} - -sub GET_U16 { - my $fh = shift; - my $str = $fh->readn(2); - croak "reached EOF while reading U16" unless length($str) == 2; - return unpack("S", $str); -} - -sub GET_NV { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading double" unless defined($c); - return $str; -} - -sub GET_U32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading U32" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_I32 { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading I32" unless length($str) == 4; - return unpack("l", $str); -} - -sub GET_objindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading objindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_opindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading opindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_svindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading svindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_pvindex { - my $fh = shift; - my $str = $fh->readn(4); - croak "reached EOF while reading pvindex" unless length($str) == 4; - return unpack("L", $str); -} - -sub GET_strconst { - my $fh = shift; - my ($str, $c); - $str = ''; - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading strconst" unless defined($c); - return cstring($str); -} - -sub GET_pvcontents {} - -sub GET_PV { - my $fh = shift; - my $str; - my $len = $fh->GET_U32; - if ($len) { - read($fh, $str, $len); - croak "reached EOF while reading PV" unless length($str) == $len; - return cstring($str); - } else { - return '""'; - } -} - -sub GET_comment_t { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\n") { - $str .= $c; - } - croak "reached EOF while reading comment" unless defined($c); - return cstring($str); -} - -sub GET_double { - my $fh = shift; - my ($str, $c); - while (defined($c = $fh->getc) && $c ne "\0") { - $str .= $c; - } - croak "reached EOF while reading double" unless defined($c); - return $str; -} - -sub GET_none {} - -sub GET_op_tr_array { - my $fh = shift; - my $len = unpack "S", $fh->readn(2); - my @ary = unpack "S*", $fh->readn($len*2); - return join(",", $len, @ary); -} - -sub GET_IV64 { - my $fh = shift; - my $str = $fh->readn(8); - croak "reached EOF while reading I32" unless length($str) == 8; - return sprintf "0x%09llx", unpack("q", $str); -} - -sub GET_IV { - $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64; -} - -sub GET_PADOFFSET { - $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32; -} - -sub GET_long { - $Config{longsize} == 8 ? &GET_IV64 : &GET_U32; -} - - -package B::Disassembler; -use Exporter; -@ISA = qw(Exporter); -@EXPORT_OK = qw(disassemble_fh get_header); -use Carp; -use strict; - -use B::Asmdata qw(%insn_data @insn_name); - -our( $magic, $archname, $blversion, $ivsize, $ptrsize ); - -sub dis_header($){ - my( $fh ) = @_; - $magic = $fh->GET_U32(); - warn( "bad magic" ) if $magic != 0x43424c50; - $archname = $fh->GET_strconst(); - $blversion = $fh->GET_strconst(); - $ivsize = $fh->GET_U32(); - $ptrsize = $fh->GET_U32(); -} - -sub get_header(){ - return( $magic, $archname, $blversion, $ivsize, $ptrsize); -} - -sub disassemble_fh { - my ($fh, $out) = @_; - my ($c, $getmeth, $insn, $arg); - bless $fh, "B::Disassembler::BytecodeStream"; - dis_header( $fh ); - while (defined($c = $fh->getc)) { - $c = ord($c); - $insn = $insn_name[$c]; - if (!defined($insn) || $insn eq "unused") { - my $pos = $fh->tell - 1; - die "Illegal instruction code $c at stream offset $pos\n"; - } - $getmeth = $insn_data{$insn}->[2]; - $arg = $fh->$getmeth(); - if (defined($arg)) { - &$out($insn, $arg); - } else { - &$out($insn); - } - } -} - -1; - -__END__ - -=head1 NAME - -B::Disassembler - Disassemble Perl bytecode - -=head1 SYNOPSIS - - use Disassembler; - -=head1 DESCRIPTION - -See F<ext/B/B/Disassembler.pm>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm deleted file mode 100644 index 3475bd2596e..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Lint.pm +++ /dev/null @@ -1,392 +0,0 @@ -package B::Lint; - -our $VERSION = '1.03'; - -=head1 NAME - -B::Lint - Perl lint - -=head1 SYNOPSIS - -perl -MO=Lint[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Lint module is equivalent to an extended version of the B<-w> -option of B<perl>. It is named after the program F<lint> which carries -out a similar process for C programs. - -=head1 OPTIONS AND LINT CHECKS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. Following any options -(indicated by a leading B<->) come lint check arguments. Each such -argument (apart from the special B<all> and B<none> options) is a -word representing one possible lint check (turning on that check) or -is B<no-foo> (turning off that check). Before processing the check -arguments, a standard list of checks is turned on. Later options -override earlier ones. Available options are: - -=over 8 - -=item B<context> - -Produces a warning whenever an array is used in an implicit scalar -context. For example, both of the lines - - $foo = length(@bar); - $foo = @bar; - -will elicit a warning. Using an explicit B<scalar()> silences the -warning. For example, - - $foo = scalar(@bar); - -=item B<implicit-read> and B<implicit-write> - -These options produce a warning whenever an operation implicitly -reads or (respectively) writes to one of Perl's special variables. -For example, B<implicit-read> will warn about these: - - /foo/; - -and B<implicit-write> will warn about these: - - s/foo/bar/; - -Both B<implicit-read> and B<implicit-write> warn about this: - - for (@a) { ... } - -=item B<bare-subs> - -This option warns whenever a bareword is implicitly quoted, but is also -the name of a subroutine in the current package. Typical mistakes that it will -trap are: - - use constant foo => 'bar'; - @a = ( foo => 1 ); - $b{foo} = 2; - -Neither of these will do what a naive user would expect. - -=item B<dollar-underscore> - -This option warns whenever C<$_> is used either explicitly anywhere or -as the implicit argument of a B<print> statement. - -=item B<private-names> - -This option warns on each use of any variable, subroutine or -method name that lives in a non-current package but begins with -an underscore ("_"). Warnings aren't issued for the special case -of the single character name "_" by itself (e.g. C<$_> and C<@_>). - -=item B<undefined-subs> - -This option warns whenever an undefined subroutine is invoked. -This option will only catch explicitly invoked subroutines such -as C<foo()> and not indirect invocations such as C<&$subref()> -or C<$obj-E<gt>meth()>. Note that some programs or modules delay -definition of subs until runtime by means of the AUTOLOAD -mechanism. - -=item B<regexp-variables> - -This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'> -is used. Any occurrence of any of these variables in your -program can slow your whole program down. See L<perlre> for -details. - -=item B<all> - -Turn all warnings on. - -=item B<none> - -Turn all warnings off. - -=back - -=head1 NON LINT-CHECK OPTIONS - -=over 8 - -=item B<-u Package> - -Normally, Lint only checks the main code of the program together -with all subs defined in package main. The B<-u> option lets you -include other package names whose subs are then checked by Lint. - -=back - -=head1 BUGS - -This is only a very preliminary version. - -This module doesn't work correctly on thread-enabled perls. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents - OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK - ); - -my $file = "unknown"; # shadows current filename -my $line = 0; # shadows current line number -my $curstash = "main"; # shadows current stash - -# Lint checks -my %check; -my %implies_ok_context; -BEGIN { - map($implies_ok_context{$_}++, - qw(scalar av2arylen aelem aslice helem hslice - keys values hslice defined undef delete)); -} - -# Lint checks turned on by default -my @default_checks = qw(context); - -my %valid_check; -# All valid checks -BEGIN { - map($valid_check{$_}++, - qw(context implicit_read implicit_write dollar_underscore - private_names bare_subs undefined_subs regexp_variables)); -} - -# Debugging options -my ($debug_op); - -my %done_cv; # used to mark which subs have already been linted -my @extra_packages; # Lint checks mainline code and all subs which are - # in main:: or in one of these packages. - -sub warning { - my $format = (@_ < 2) ? "%s" : shift; - warn sprintf("$format at %s line %d\n", @_, $file, $line); -} - -# This gimme can't cope with context that's only determined -# at runtime via dowantarray(). -sub gimme { - my $op = shift; - my $flags = $op->flags; - if ($flags & OPf_WANT) { - return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0); - } - return undef; -} - -sub B::OP::lint {} - -sub B::COP::lint { - my $op = shift; - if ($op->name eq "nextstate") { - $file = $op->file; - $line = $op->line; - $curstash = $op->stash->NAME; - } -} - -sub B::UNOP::lint { - my $op = shift; - my $opname = $op->name; - if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { - my $parent = parents->[0]; - my $pname = $parent->name; - return if gimme($op) || $implies_ok_context{$pname}; - # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" - # null out the parent so we have to check for a parent of pp_null and - # a grandparent of pp_enteriter or pp_delete - if ($pname eq "null") { - my $gpname = parents->[1]->name; - return if $gpname eq "enteriter" || $gpname eq "delete"; - } - warning("Implicit scalar context for %s in %s", - $opname eq "rv2av" ? "array" : "hash", $parent->desc); - } - if ($check{private_names} && $opname eq "method") { - my $methop = $op->first; - if ($methop->name eq "const") { - my $method = $methop->sv->PV; - if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { - warning("Illegal reference to private method name $method"); - } - } - } -} - -sub B::PMOP::lint { - my $op = shift; - if ($check{implicit_read}) { - if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { - warning('Implicit match on $_'); - } - } - if ($check{implicit_write}) { - if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { - warning('Implicit substitution on $_'); - } - } -} - -sub B::LOOP::lint { - my $op = shift; - if ($check{implicit_read} || $check{implicit_write}) { - if ($op->name eq "enteriter") { - my $last = $op->last; - if ($last->name eq "gv" && $last->gv->NAME eq "_") { - warning('Implicit use of $_ in foreach'); - } - } - } -} - -sub B::SVOP::lint { - my $op = shift; - if ( $check{bare_subs} && $op->name eq 'const' - && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h - { - my $sv = $op->sv; - if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) { - warning "Bare sub name '" . $sv->PV . "' interpreted as string"; - } - } - if ($check{dollar_underscore} && $op->name eq "gvsv" - && $op->gv->NAME eq "_") - { - warning('Use of $_'); - } - if ($check{private_names}) { - my $opname = $op->name; - if ($opname eq "gv" || $opname eq "gvsv") { - my $gv = $op->gv; - if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { - warning('Illegal reference to private name %s', $gv->NAME); - } - } elsif ($opname eq "method_named") { - my $method = $op->gv->PV; - if ($method =~ /^_./) { - warning("Illegal reference to private method name $method"); - } - } - } - if ($check{undefined_subs}) { - if ($op->name eq "gv" - && $op->next->name eq "entersub") - { - my $gv = $op->gv; - my $subname = $gv->STASH->NAME . "::" . $gv->NAME; - no strict 'refs'; - if (!defined(&$subname)) { - $subname =~ s/^main:://; - warning('Undefined subroutine %s called', $subname); - } - } - } - if ($check{regexp_variables} && $op->name eq "gvsv") { - my $name = $op->gv->NAME; - if ($name =~ /^[&'`]$/) { - warning('Use of regexp variable $%s', $name); - } - } -} - -sub B::GV::lintcv { - my $gv = shift; - my $cv = $gv->CV; - #warn sprintf("lintcv: %s::%s (done=%d)\n", - # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug - return if !$$cv || $done_cv{$$cv}++; - my $root = $cv->ROOT; - #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; -} - -sub do_lint { - my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; - - # Now do subs in main - no strict qw(vars refs); - local(*glob); - for my $sym (keys %main::) { - next if $sym =~ /::$/; - *glob = $main::{$sym}; - svref_2object(\*glob)->EGV->lintcv; - } - - # Now do subs in non-main packages given by -u options - map { $search_pack{$_} = 1 } @extra_packages; - walksymtable(\%{"main::"}, "lintcv", sub { - my $package = shift; - $package =~ s/::$//; - #warn "Considering $package\n";#debug - return exists $search_pack{$package}; - }); -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - # Turn on default lint checks - for $opt (@default_checks) { - $check{$opt} = 1; - } - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } - } - } elsif ($opt eq "u") { - $arg ||= shift @options; - push(@extra_packages, $arg); - } - } - foreach $opt (@default_checks, @options) { - $opt =~ tr/-/_/; - if ($opt eq "all") { - %check = %valid_check; - } - elsif ($opt eq "none") { - %check = (); - } - else { - if ($opt =~ s/^no_//) { - $check{$opt} = 0; - } - else { - $check{$opt} = 1; - } - warn "No such check: $opt\n" unless defined $valid_check{$opt}; - } - } - # Remaining arguments are things to check - - return \&do_lint; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/B/Showlex.pm b/Master/tlpkg/tlperl/lib/B/Showlex.pm deleted file mode 100644 index 3b261a337df..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Showlex.pm +++ /dev/null @@ -1,205 +0,0 @@ -package B::Showlex; - -our $VERSION = '1.02'; - -use strict; -use B qw(svref_2object comppadlist class); -use B::Terse (); -use B::Concise (); - -# -# Invoke as -# perl -MO=Showlex,foo bar.pl -# to see the names of lexical variables used by &foo -# or as -# perl -MO=Showlex bar.pl -# to see the names of file scope lexicals used by bar.pl -# - - -# borrowed from B::Concise -our $walkHandle = \*STDOUT; - -sub walk_output { # updates $walkHandle - $walkHandle = B::Concise::walk_output(@_); - #print "got $walkHandle"; - #print $walkHandle "using it"; - $walkHandle; -} - -sub shownamearray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print $walkHandle "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - my $sv = $els[$i]; - if (class($sv) ne "SPECIAL") { - printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; - } else { - printf $walkHandle "$i: %s\n", $sv->terse; - #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); - } - } -} - -sub showvaluearray { - my ($name, $av) = @_; - my @els = $av->ARRAY; - my $count = @els; - my $i; - print $walkHandle "$name has $count entries\n"; - for ($i = 0; $i < $count; $i++) { - printf $walkHandle "$i: %s\n", $els[$i]->terse; - #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); - } -} - -sub showlex { - my ($objname, $namesav, $valsav) = @_; - shownamearray("Pad of lexical names for $objname", $namesav); - showvaluearray("Pad of lexical values for $objname", $valsav); -} - -my ($newlex, $nosp1); # rendering state vars - -sub newlex { # drop-in for showlex - my ($objname, $names, $vals) = @_; - my @names = $names->ARRAY; - my @vals = $vals->ARRAY; - my $count = @names; - print $walkHandle "$objname Pad has $count entries\n"; - printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; - for (my $i = 1; $i < $count; $i++) { - printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse - unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; - } -} - -sub showlex_obj { - my ($objname, $obj) = @_; - $objname =~ s/^&main::/&/; - showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; - newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; -} - -sub showlex_main { - showlex("comppadlist", comppadlist->ARRAY) if !$newlex; - newlex ("main", comppadlist->ARRAY) if $newlex; -} - -sub compile { - my @options = grep(/^-/, @_); - my @args = grep(!/^-/, @_); - for my $o (@options) { - $newlex = 1 if $o eq "-newlex"; - $nosp1 = 1 if $o eq "-nosp"; - } - - return \&showlex_main unless @args; - return sub { - my $objref; - foreach my $objname (@args) { - next unless $objname; # skip nulls w/o carping - - if (ref $objname) { - print $walkHandle "B::Showlex::compile($objname)\n"; - $objref = $objname; - } else { - $objname = "main::$objname" unless $objname =~ /::/; - print $walkHandle "$objname:\n"; - no strict 'refs'; - die "err: unknown function ($objname)\n" - unless *{$objname}{CODE}; - $objref = \&$objname; - } - showlex_obj($objname, $objref); - } - } -} - -1; - -__END__ - -=head1 NAME - -B::Showlex - Show lexical variables used in functions or files - -=head1 SYNOPSIS - - perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl - -=head1 DESCRIPTION - -When a comma-separated list of subroutine names is given as options, Showlex -prints the lexical variables used in those subroutines. Otherwise, it prints -the file-scope lexicals in the file. - -=head1 EXAMPLES - -Traditional form: - - $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' - Pad of lexical names for comppadlist has 4 entries - 0: SPECIAL #1 &PL_sv_undef - 1: PVNV (0x9db0fb0) $i - 2: PVNV (0x9db0f38) $j - 3: PVNV (0x9db0f50) $k - Pad of lexical values for comppadlist has 5 entries - 0: SPECIAL #1 &PL_sv_undef - 1: NULL (0x9da4234) - 2: NULL (0x9db0f2c) - 3: NULL (0x9db0f44) - 4: NULL (0x9da4264) - -e syntax OK - -New-style form: - - $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' - main Pad has 4 entries - 0: SPECIAL #1 &PL_sv_undef - 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) - 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) - 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) - -e syntax OK - -New form, no specials, outside O framework: - - $ perl -MB::Showlex -e \ - 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' - main Pad has 4 entries - 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 - 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" - 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) - -Note that this example shows the values of the lexicals, whereas the other -examples did not (as they're compile-time only). - -=head2 OPTIONS - -The C<-newlex> option produces a more readable C<< name => value >> format, -and is shown in the second example above. - -The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL -#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm -your declared lexicals. - -=head1 SEE ALSO - -C<B::Showlex> can also be used outside of the O framework, as in the third -example. See C<B::Concise> for a fuller explanation of reasons. - -=head1 TODO - -Some of the reported info, such as hex addresses, is not particularly -valuable. Other information would be more useful for the typical -programmer, such as line-numbers, pad-slot reuses, etc.. Given this, --newlex isnt a particularly good flag-name. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Stackobj.pm b/Master/tlpkg/tlperl/lib/B/Stackobj.pm deleted file mode 100644 index b17dfb8173a..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Stackobj.pm +++ /dev/null @@ -1,349 +0,0 @@ -# Stackobj.pm -# -# Copyright (c) 1996 Malcolm Beattie -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# -package B::Stackobj; - -our $VERSION = '1.00'; - -use Exporter (); -@ISA = qw(Exporter); -@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED - VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); -%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], - flags => [qw(VALID_INT VALID_DOUBLE VALID_SV - VALID_UNSIGNED REGISTER TEMPORARY)]); - -use Carp qw(confess); -use strict; -use B qw(class SVf_IOK SVf_NOK SVf_IVisUV); - -# Types -sub T_UNKNOWN () { 0 } -sub T_DOUBLE () { 1 } -sub T_INT () { 2 } -sub T_SPECIAL () { 3 } - -# Flags -sub VALID_INT () { 0x01 } -sub VALID_UNSIGNED () { 0x02 } -sub VALID_DOUBLE () { 0x04 } -sub VALID_SV () { 0x08 } -sub REGISTER () { 0x10 } # no implicit write-back when calling subs -sub TEMPORARY () { 0x20 } # no implicit write-back needed at all -sub SAVE_INT () { 0x40 } #if int part needs to be saved at all -sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all - - -# -# Callback for runtime code generation -# -my $runtime_callback = sub { confess "set_callback not yet called" }; -sub set_callback (&) { $runtime_callback = shift } -sub runtime { &$runtime_callback(@_) } - -# -# Methods -# - -sub write_back { confess "stack object does not implement write_back" } - -sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) } - -sub as_sv { - my $obj = shift; - if (!($obj->{flags} & VALID_SV)) { - $obj->write_back; - $obj->{flags} |= VALID_SV; - } - return $obj->{sv}; -} - -sub as_int { - my $obj = shift; - if (!($obj->{flags} & VALID_INT)) { - $obj->load_int; - $obj->{flags} |= VALID_INT|SAVE_INT; - } - return $obj->{iv}; -} - -sub as_double { - my $obj = shift; - if (!($obj->{flags} & VALID_DOUBLE)) { - $obj->load_double; - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; - } - return $obj->{nv}; -} - -sub as_numeric { - my $obj = shift; - return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; -} - -sub as_bool { - my $obj=shift; - if ($obj->{flags} & VALID_INT ){ - return $obj->{iv}; - } - if ($obj->{flags} & VALID_DOUBLE ){ - return $obj->{nv}; - } - return sprintf("(SvTRUE(%s))", $obj->as_sv) ; -} - -# -# Debugging methods -# -sub peek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - my @flags; - if ($type == T_UNKNOWN) { - $type = "T_UNKNOWN"; - } elsif ($type == T_INT) { - $type = "T_INT"; - } elsif ($type == T_DOUBLE) { - $type = "T_DOUBLE"; - } else { - $type = "(illegal type $type)"; - } - push(@flags, "VALID_INT") if $flags & VALID_INT; - push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE; - push(@flags, "VALID_SV") if $flags & VALID_SV; - push(@flags, "REGISTER") if $flags & REGISTER; - push(@flags, "TEMPORARY") if $flags & TEMPORARY; - @flags = ("none") unless @flags; - return sprintf("%s type=$type flags=%s sv=$obj->{sv}", - class($obj), join("|", @flags)); -} - -sub minipeek { - my $obj = shift; - my $type = $obj->{type}; - my $flags = $obj->{flags}; - if ($type == T_INT || $flags & VALID_INT) { - return $obj->{iv}; - } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) { - return $obj->{nv}; - } else { - return $obj->{sv}; - } -} - -# -# Caller needs to ensure that set_int, set_double, -# set_numeric and set_sv are only invoked on legal lvalues. -# -sub set_int { - my ($obj, $expr,$unsigned) = @_; - runtime("$obj->{iv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); - $obj->{flags} |= VALID_INT|SAVE_INT; - $obj->{flags} |= VALID_UNSIGNED if $unsigned; -} - -sub set_double { - my ($obj, $expr) = @_; - runtime("$obj->{nv} = $expr;"); - $obj->{flags} &= ~(VALID_SV | VALID_INT); - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; -} - -sub set_numeric { - my ($obj, $expr) = @_; - if ($obj->{type} == T_INT) { - $obj->set_int($expr); - } else { - $obj->set_double($expr); - } -} - -sub set_sv { - my ($obj, $expr) = @_; - runtime("SvSetSV($obj->{sv}, $expr);"); - $obj->invalidate; - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Padsv -# - -@B::Stackobj::Padsv::ISA = 'B::Stackobj'; -sub B::Stackobj::Padsv::new { - my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; - $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; - $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; - bless { - type => $type, - flags => VALID_SV | $extra_flags, - sv => "PL_curpad[$ix]", - iv => "$iname", - nv => "$dname" - }, $class; -} - -sub B::Stackobj::Padsv::load_int { - my $obj = shift; - if ($obj->{flags} & VALID_DOUBLE) { - runtime("$obj->{iv} = $obj->{nv};"); - } else { - runtime("$obj->{iv} = SvIV($obj->{sv});"); - } - $obj->{flags} |= VALID_INT|SAVE_INT; -} - -sub B::Stackobj::Padsv::load_double { - my $obj = shift; - $obj->write_back; - runtime("$obj->{nv} = SvNV($obj->{sv});"); - $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; -} -sub B::Stackobj::Padsv::save_int { - my $obj = shift; - return $obj->{flags} & SAVE_INT; -} - -sub B::Stackobj::Padsv::save_double { - my $obj = shift; - return $obj->{flags} & SAVE_DOUBLE; -} - -sub B::Stackobj::Padsv::write_back { - my $obj = shift; - my $flags = $obj->{flags}; - return if $flags & VALID_SV; - if ($flags & VALID_INT) { - if ($flags & VALID_UNSIGNED ){ - runtime("sv_setuv($obj->{sv}, $obj->{iv});"); - }else{ - runtime("sv_setiv($obj->{sv}, $obj->{iv});"); - } - } elsif ($flags & VALID_DOUBLE) { - runtime("sv_setnv($obj->{sv}, $obj->{nv});"); - } else { - confess "write_back failed for lexical @{[$obj->peek]}\n"; - } - $obj->{flags} |= VALID_SV; -} - -# -# Stackobj::Const -# - -@B::Stackobj::Const::ISA = 'B::Stackobj'; -sub B::Stackobj::Const::new { - my ($class, $sv) = @_; - my $obj = bless { - flags => 0, - sv => $sv # holds the SV object until write_back happens - }, $class; - if ( ref($sv) eq "B::SPECIAL" ){ - $obj->{type}= T_SPECIAL; - }else{ - my $svflags = $sv->FLAGS; - if ($svflags & SVf_IOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_INT; - if ($svflags & SVf_IVisUV){ - $obj->{flags} |= VALID_UNSIGNED; - $obj->{nv} = $obj->{iv} = $sv->UVX; - }else{ - $obj->{nv} = $obj->{iv} = $sv->IV; - } - } elsif ($svflags & SVf_NOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_DOUBLE; - $obj->{iv} = $obj->{nv} = $sv->NV; - } else { - $obj->{type} = T_UNKNOWN; - } - } - return $obj; -} - -sub B::Stackobj::Const::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - # Save the SV object and replace $obj->{sv} by its C source code name - $obj->{sv} = $obj->{sv}->save; - $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE; -} - -sub B::Stackobj::Const::load_int { - my $obj = shift; - if (ref($obj->{sv}) eq "B::RV"){ - $obj->{iv} = int($obj->{sv}->RV->PV); - }else{ - $obj->{iv} = int($obj->{sv}->PV); - } - $obj->{flags} |= VALID_INT; -} - -sub B::Stackobj::Const::load_double { - my $obj = shift; - if (ref($obj->{sv}) eq "B::RV"){ - $obj->{nv} = $obj->{sv}->RV->PV + 0.0; - }else{ - $obj->{nv} = $obj->{sv}->PV + 0.0; - } - $obj->{flags} |= VALID_DOUBLE; -} - -sub B::Stackobj::Const::invalidate {} - -# -# Stackobj::Bool -# - -@B::Stackobj::Bool::ISA = 'B::Stackobj'; -sub B::Stackobj::Bool::new { - my ($class, $preg) = @_; - my $obj = bless { - type => T_INT, - flags => VALID_INT|VALID_DOUBLE, - iv => $$preg, - nv => $$preg, - preg => $preg # this holds our ref to the pseudo-reg - }, $class; - return $obj; -} - -sub B::Stackobj::Bool::write_back { - my $obj = shift; - return if $obj->{flags} & VALID_SV; - $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)"; - $obj->{flags} |= VALID_SV; -} - -# XXX Might want to handle as_double/set_double/load_double? - -sub B::Stackobj::Bool::invalidate {} - -1; - -__END__ - -=head1 NAME - -B::Stackobj - Helper module for CC backend - -=head1 SYNOPSIS - - use B::Stackobj; - -=head1 DESCRIPTION - -See F<ext/B/README>. - -=head1 AUTHOR - -Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Stash.pm b/Master/tlpkg/tlperl/lib/B/Stash.pm deleted file mode 100644 index 5e60868a28e..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Stash.pm +++ /dev/null @@ -1,52 +0,0 @@ -# Stash.pm -- show what stashes are loaded -# vishalb@hotmail.com -package B::Stash; - -our $VERSION = '1.00'; - -=pod - -=head1 NAME - -B::Stash - show what stashes are loaded - -=cut - -BEGIN { %Seen = %INC } - -CHECK { - my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; - print "-umain,-u", join (",-u",@arr) ,"\n"; -} -sub scan{ - my $start=shift; - my $prefix=shift; - $prefix = '' unless defined $prefix; - my @return; - foreach my $key ( keys %{$start}){ -# print $prefix,$key,"\n"; - if ($key =~ /::$/){ - unless ($start eq ${$start}{$key} or $key eq "B::" ){ - push @return, $key unless omit($prefix.$key); - foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ - push @return, "$key".$subscan; - } - } - } - } - return @return; -} -sub omit{ - my $module = shift; - my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 , - "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); - return 1 if $omit{$module}; - if ($module eq "IO::" or $module eq "IO::Handle::"){ - $module =~ s/::/\//g; - return 1 unless $INC{$module}; - } - - return 0; -} -1; diff --git a/Master/tlpkg/tlperl/lib/B/Terse.pm b/Master/tlpkg/tlperl/lib/B/Terse.pm deleted file mode 100644 index 1d53950ad3b..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Terse.pm +++ /dev/null @@ -1,103 +0,0 @@ -package B::Terse; - -our $VERSION = '1.03_01'; - -use strict; -use B qw(class); -use B::Asmdata qw(@specialsv_name); -use B::Concise qw(concise_subref set_style_standard); -use Carp; - -sub terse { - my ($order, $subref) = @_; - set_style_standard("terse"); - if ($order eq "exec") { - concise_subref('exec', $subref); - } else { - concise_subref('basic', $subref); - } -} - -sub compile { - my @args = @_; - my $order = @args ? shift(@args) : ""; - $order = "-exec" if $order eq "exec"; - unshift @args, $order if $order ne ""; - B::Concise::compile("-terse", @args); -} - -sub indent { - my ($level) = @_ ? shift : 0; - return " " x $level; -} - -# Don't use this, at least on OPs in subroutines: it has no way of -# getting to the pad, and will give wrong answers or crash. -sub B::OP::terse { - carp "B::OP::terse is deprecated; use B::Concise instead"; - B::Concise::b_terse(@_); -} - -sub B::SV::terse { - my($sv, $level) = (@_, 0); - my %info; - B::Concise::concise_sv($sv, \%info); - my $s = indent($level) - . B::Concise::fmt_line(\%info, $sv, - "#svclass~(?((#svaddr))?)~#svval", 0); - chomp $s; - print "$s\n" unless defined wantarray; - $s; -} - -sub B::NULL::terse { - my ($sv, $level) = (@_, 0); - my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv; - print "$s\n" unless defined wantarray; - $s; -} - -sub B::SPECIAL::terse { - my ($sv, $level) = (@_, 0); - my $s = indent($level) - . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]); - print "$s\n" unless defined wantarray; - $s; -} - -1; - -__END__ - -=head1 NAME - -B::Terse - Walk Perl syntax tree, printing terse info about ops - -=head1 SYNOPSIS - - perl -MO=Terse[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -This version of B::Terse is really just a wrapper that calls B::Concise -with the B<-terse> option. It is provided for compatibility with old scripts -(and habits) but using B::Concise directly is now recommended instead. - -For compatibility with the old B::Terse, this module also adds a -method named C<terse> to B::OP and B::SV objects. The B::SV method is -largely compatible with the old one, though authors of new software -might be advised to choose a more user-friendly output format. The -B::OP C<terse> method, however, doesn't work well. Since B::Terse was -first written, much more information in OPs has migrated to the -scratchpad datastructure, but the C<terse> interface doesn't have any -way of getting to the correct pad. As a kludge, the new version will -always use the pad for the main program, but for OPs in subroutines -this will give the wrong answer or crash. - -=head1 AUTHOR - -The original version of B::Terse was written by Malcolm Beattie, -E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen -McCamant, E<lt>smcc@MIT.EDUE<gt>. - -=cut diff --git a/Master/tlpkg/tlperl/lib/B/Xref.pm b/Master/tlpkg/tlperl/lib/B/Xref.pm deleted file mode 100644 index f727dc766b5..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Xref.pm +++ /dev/null @@ -1,430 +0,0 @@ -package B::Xref; - -our $VERSION = '1.01'; - -=head1 NAME - -B::Xref - Generates cross reference reports for Perl programs - -=head1 SYNOPSIS - -perl -MO=Xref[,OPTIONS] foo.pl - -=head1 DESCRIPTION - -The B::Xref module is used to generate a cross reference listing of all -definitions and uses of variables, subroutines and formats in a Perl program. -It is implemented as a backend for the Perl compiler. - -The report generated is in the following format: - - File filename1 - Subroutine subname1 - Package package1 - object1 line numbers - object2 line numbers - ... - Package package2 - ... - -Each B<File> section reports on a single file. Each B<Subroutine> section -reports on a single subroutine apart from the special cases -"(definitions)" and "(main)". These report, respectively, on subroutine -definitions found by the initial symbol table walk and on the main part of -the program or module external to all subroutines. - -The report is then grouped by the B<Package> of each variable, -subroutine or format with the special case "(lexicals)" meaning -lexical variables. Each B<object> name (implicitly qualified by its -containing B<Package>) includes its type character(s) at the beginning -where possible. Lexical variables are easier to track and even -included dereferencing information where possible. - -The C<line numbers> are a comma separated list of line numbers (some -preceded by code letters) where that object is used in some way. -Simple uses aren't preceded by a code letter. Introductions (such as -where a lexical is first defined with C<my>) are indicated with the -letter "i". Subroutine and method calls are indicated by the character -"&". Subroutine definitions are indicated by "s" and format -definitions by "f". - -=head1 OPTIONS - -Option words are separated by commas (not whitespace) and follow the -usual conventions of compiler backend options. - -=over 8 - -=item C<-oFILENAME> - -Directs output to C<FILENAME> instead of standard output. - -=item C<-r> - -Raw output. Instead of producing a human-readable report, outputs a line -in machine-readable form for each definition/use of a variable/sub/format. - -=item C<-d> - -Don't output the "(definitions)" sections. - -=item C<-D[tO]> - -(Internal) debug options, probably only useful if C<-r> included. -The C<t> option prints the object on the top of the stack as it's -being tracked. The C<O> option prints each operator as it's being -processed in the execution order of the program. - -=back - -=head1 BUGS - -Non-lexical variables are quite difficult to track through a program. -Sometimes the type of a non-lexical variable's use is impossible to -determine. Introductions of non-lexical non-scalars don't seem to be -reported properly. - -=head1 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -use strict; -use Config; -use B qw(peekop class comppadlist main_start svref_2object walksymtable - OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring - ); - -sub UNKNOWN { ["?", "?", "?"] } - -my @pad; # lexicals in current pad - # as ["(lexical)", type, name] -my %done; # keyed by $$op: set when each $op is done -my $top = UNKNOWN; # shadows top element of stack as - # [pack, type, name] (pack can be "(lexical)") -my $file; # shadows current filename -my $line; # shadows current line number -my $subname; # shadows current sub name -my %table; # Multi-level hash to record all uses etc. -my @todo = (); # List of CVs that need processing - -my %code = (intro => "i", used => "", - subdef => "s", subused => "&", - formdef => "f", meth => "->"); - - -# Options -my ($debug_op, $debug_top, $nodefs, $raw); - -sub process { - my ($var, $event) = @_; - my ($pack, $type, $name) = @$var; - if ($type eq "*") { - if ($event eq "used") { - return; - } elsif ($event eq "subused") { - $type = "&"; - } - } - $type =~ s/(.)\*$/$1/g; - if ($raw) { - printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", - $file, $subname, $line, $pack, $type, $name, $event; - } else { - # Wheee - push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, - $line); - } -} - -sub load_pad { - my $padlist = shift; - my ($namelistav, $vallistav, @namelist, $ix); - @pad = (); - return if class($padlist) eq "SPECIAL"; - ($namelistav,$vallistav) = $padlist->ARRAY; - @namelist = $namelistav->ARRAY; - for ($ix = 1; $ix < @namelist; $ix++) { - my $namesv = $namelist[$ix]; - next if class($namesv) eq "SPECIAL"; - my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; - $pad[$ix] = ["(lexical)", $type || '?', $name || '?']; - } - if ($Config{useithreads}) { - my (@vallist); - @vallist = $vallistav->ARRAY; - for ($ix = 1; $ix < @vallist; $ix++) { - my $valsv = $vallist[$ix]; - next unless class($valsv) eq "GV"; - # these pad GVs don't have corresponding names, so same @pad - # array can be used without collisions - $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; - } - } -} - -sub xref { - my $start = shift; - my $op; - for ($op = $start; $$op; $op = $op->next) { - last if $done{$$op}++; - warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; - warn peekop($op), "\n" if $debug_op; - my $opname = $op->name; - if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { - xref($op->other); - } elsif ($opname eq "match" || $opname eq "subst") { - xref($op->pmreplstart); - } elsif ($opname eq "substcont") { - xref($op->other->pmreplstart); - $op = $op->other; - redo; - } elsif ($opname eq "enterloop") { - xref($op->redoop); - xref($op->nextop); - xref($op->lastop); - } elsif ($opname eq "subst") { - xref($op->pmreplstart); - } else { - no strict 'refs'; - my $ppname = "pp_$opname"; - &$ppname($op) if defined(&$ppname); - } - } -} - -sub xref_cv { - my $cv = shift; - my $pack = $cv->GV->STASH->NAME; - $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; - load_pad($cv->PADLIST); - xref($cv->START); - $subname = "(main)"; -} - -sub xref_object { - my $cvref = shift; - xref_cv(svref_2object($cvref)); -} - -sub xref_main { - $subname = "(main)"; - load_pad(comppadlist); - xref(main_start); - while (@todo) { - xref_cv(shift @todo); - } -} - -sub pp_nextstate { - my $op = shift; - $file = $op->file; - $line = $op->line; - $top = UNKNOWN; -} - -sub pp_padsv { - my $op = shift; - $top = $pad[$op->targ]; - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_padav { pp_padsv(@_) } -sub pp_padhv { pp_padsv(@_) } - -sub deref { - my ($op, $var, $as) = @_; - $var->[1] = $as . $var->[1]; - process($var, $op->private & OPpOUR_INTRO ? "intro" : "used"); -} - -sub pp_rv2cv { deref(shift, $top, "&"); } -sub pp_rv2hv { deref(shift, $top, "%"); } -sub pp_rv2sv { deref(shift, $top, "\$"); } -sub pp_rv2av { deref(shift, $top, "\@"); } -sub pp_rv2gv { deref(shift, $top, "*"); } - -sub pp_gvsv { - my $op = shift; - my $gv; - if ($Config{useithreads}) { - $top = $pad[$op->padix]; - $top = UNKNOWN unless $top; - $top->[1] = '$'; - } - else { - $gv = $op->gv; - $top = [$gv->STASH->NAME, '$', $gv->SAFENAME]; - } - process($top, $op->private & OPpLVAL_INTRO || - $op->private & OPpOUR_INTRO ? "intro" : "used"); -} - -sub pp_gv { - my $op = shift; - my $gv; - if ($Config{useithreads}) { - $top = $pad[$op->padix]; - $top = UNKNOWN unless $top; - $top->[1] = '*'; - } - else { - $gv = $op->gv; - $top = [$gv->STASH->NAME, "*", $gv->SAFENAME]; - } - process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); -} - -sub pp_const { - my $op = shift; - my $sv = $op->sv; - # constant could be in the pad (under useithreads) - if ($$sv) { - $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) - ? cstring($sv->PV) : "?"]; - } - else { - $top = $pad[$op->targ]; - $top = UNKNOWN unless $top; - } -} - -sub pp_method { - my $op = shift; - $top = ["(method)", "->".$top->[1], $top->[2]]; -} - -sub pp_entersub { - my $op = shift; - if ($top->[1] eq "m") { - process($top, "meth"); - } else { - process($top, "subused"); - } - $top = UNKNOWN; -} - -# -# Stuff for cross referencing definitions of variables and subs -# - -sub B::GV::xref { - my $gv = shift; - my $cv = $gv->CV; - if ($$cv) { - #return if $done{$$cv}++; - $file = $gv->FILE; - $line = $gv->LINE; - process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); - push(@todo, $cv); - } - my $form = $gv->FORM; - if ($$form) { - return if $done{$$form}++; - $file = $gv->FILE; - $line = $gv->LINE; - process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); - } -} - -sub xref_definitions { - my ($pack, %exclude); - return if $nodefs; - $subname = "(definitions)"; - foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS - strict vars FileHandle Exporter Carp PerlIO::Layer - attributes utf8 warnings)) { - $exclude{$pack."::"} = 1; - } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); -} - -sub output { - return if $raw; - my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, - $perpack, $pername, $perev); - foreach $file (sort(keys(%table))) { - $perfile = $table{$file}; - print "File $file\n"; - foreach $subname (sort(keys(%$perfile))) { - $persubname = $perfile->{$subname}; - print " Subroutine $subname\n"; - foreach $pack (sort(keys(%$persubname))) { - $perpack = $persubname->{$pack}; - print " Package $pack\n"; - foreach $name (sort(keys(%$perpack))) { - $pername = $perpack->{$name}; - my @lines; - foreach $ev (qw(intro formdef subdef meth subused used)) { - $perev = $pername->{$ev}; - if (defined($perev) && @$perev) { - my $code = $code{$ev}; - push(@lines, map("$code$_", @$perev)); - } - } - printf " %-16s %s\n", $name, join(", ", @lines); - } - } - } - } -} - -sub compile { - my @options = @_; - my ($option, $opt, $arg); - OPTION: - while ($option = shift @options) { - if ($option =~ /^-(.)(.*)/) { - $opt = $1; - $arg = $2; - } else { - unshift @options, $option; - last OPTION; - } - if ($opt eq "-" && $arg eq "-") { - shift @options; - last OPTION; - } elsif ($opt eq "o") { - $arg ||= shift @options; - open(STDOUT, ">$arg") or return "$arg: $!\n"; - } elsif ($opt eq "d") { - $nodefs = 1; - } elsif ($opt eq "r") { - $raw = 1; - } elsif ($opt eq "D") { - $arg ||= shift @options; - foreach $arg (split(//, $arg)) { - if ($arg eq "o") { - B->debug(1); - } elsif ($arg eq "O") { - $debug_op = 1; - } elsif ($arg eq "t") { - $debug_top = 1; - } - } - } - } - if (@options) { - return sub { - my $objname; - xref_definitions(); - foreach $objname (@options) { - $objname = "main::$objname" unless $objname =~ /::/; - eval "xref_object(\\&$objname)"; - die "xref_object(\\&$objname) failed: $@" if $@; - } - output(); - } - } else { - return sub { - xref_definitions(); - xref_main(); - output(); - } - } -} - -1; diff --git a/Master/tlpkg/tlperl/lib/B/assemble b/Master/tlpkg/tlperl/lib/B/assemble deleted file mode 100644 index 43cc5bc4b33..00000000000 --- a/Master/tlpkg/tlperl/lib/B/assemble +++ /dev/null @@ -1,30 +0,0 @@ -use B::Assembler qw(assemble_fh); -use FileHandle; - -my ($filename, $fh, $out); - -if ($ARGV[0] eq "-d") { - B::Assembler::debug(1); - shift; -} - -$out = \*STDOUT; - -if (@ARGV == 0) { - $fh = \*STDIN; - $filename = "-"; -} elsif (@ARGV == 1) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; -} elsif (@ARGV == 2) { - $filename = $ARGV[0]; - $fh = new FileHandle "<$filename"; - $out = new FileHandle ">$ARGV[1]"; -} else { - die "Usage: assemble [filename] [outfilename]\n"; -} - -binmode $out; -$SIG{__WARN__} = sub { warn "$filename:@_" }; -$SIG{__DIE__} = sub { die "$filename: @_" }; -assemble_fh($fh, sub { print $out @_ }); diff --git a/Master/tlpkg/tlperl/lib/B/cc_harness b/Master/tlpkg/tlperl/lib/B/cc_harness deleted file mode 100644 index 79f8727a8f0..00000000000 --- a/Master/tlpkg/tlperl/lib/B/cc_harness +++ /dev/null @@ -1,12 +0,0 @@ -use Config; - -$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; - -if (!grep(/^-[cS]$/, @ARGV)) { - $linkargs = sprintf("%s $libdir/$Config{libperl} %s", - @Config{qw(ldflags libs)}); -} - -$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; -print "$cccmd\n"; -exec $cccmd; diff --git a/Master/tlpkg/tlperl/lib/B/disassemble b/Master/tlpkg/tlperl/lib/B/disassemble deleted file mode 100644 index 6530b809502..00000000000 --- a/Master/tlpkg/tlperl/lib/B/disassemble +++ /dev/null @@ -1,22 +0,0 @@ -use B::Disassembler qw(disassemble_fh); -use FileHandle; - -my $fh; -if (@ARGV == 0) { - $fh = \*STDIN; -} elsif (@ARGV == 1) { - $fh = new FileHandle "<$ARGV[0]"; -} else { - die "Usage: disassemble [filename]\n"; -} - -sub print_insn { - my ($insn, $arg) = @_; - if (defined($arg)) { - printf "%s %s\n", $insn, $arg; - } else { - print $insn, "\n"; - } -} - -disassemble_fh($fh, \&print_insn); diff --git a/Master/tlpkg/tlperl/lib/B/makeliblinks b/Master/tlpkg/tlperl/lib/B/makeliblinks deleted file mode 100644 index 82560783c01..00000000000 --- a/Master/tlpkg/tlperl/lib/B/makeliblinks +++ /dev/null @@ -1,54 +0,0 @@ -use File::Find; -use Config; - -if (@ARGV != 2) { - warn <<"EOT"; -Usage: makeliblinks libautodir targetdir -where libautodir is the architecture-dependent auto directory -(e.g. $Config::Config{archlib}/auto). -EOT - exit 2; -} - -my ($libautodir, $targetdir) = @ARGV; - -# Calculate relative path prefix from $targetdir to $libautodir -sub relprefix { - my ($to, $from) = @_; - my $up; - for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { - $from =~ s( - [^/]+ (?# a group of non-slashes) - /* (?# maybe with some trailing slashes) - $ (?# at the end of the path) - )()x; - } - return (("../" x $up) . substr($to, length($from))); -} - -my $relprefix = relprefix($libautodir, $targetdir); - -my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; - -sub link_if_library { - if (/\.($dlext|$lib_ext)$/o) { - my $ext = $1; - my $name = $File::Find::name; - if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { - die "directory of $name doesn't match $libautodir\n"; - } - substr($name, 0, length($libautodir) + 1) = ''; - my @parts = split(m(/), $name); - if ($parts[-1] ne "$parts[-2].$ext") { - die "module name $_ doesn't match its directory $libautodir\n"; - } - pop @parts; - my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; - print "$libpath -> $relprefix/$name\n"; - symlink("$relprefix/$name", $libpath) - or warn "above link failed with error: $!\n"; - } -} - -find(\&link_if_library, $libautodir); -exit 0; |