summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-05-12 16:51:27 +0000
committerNorbert Preining <preining@logic.at>2010-05-12 16:51:27 +0000
commitb645030efc22e13c2498a1522083634ab91b2de1 (patch)
treec75c7a71998200d419af56eb755dac2f5115b585 /Master/tlpkg/tlperl/lib/B
parent44ccd4efc5352f9eb1099ba357708e7b5ff03b83 (diff)
move tlperl to tlperl.old
git-svn-id: svn://tug.org/texlive/trunk@18209 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Asmdata.pm250
-rw-r--r--Master/tlpkg/tlperl/lib/B/Assembler.pm328
-rw-r--r--Master/tlpkg/tlperl/lib/B/Bblock.pm224
-rw-r--r--Master/tlpkg/tlperl/lib/B/Bytecode.pm889
-rw-r--r--Master/tlpkg/tlperl/lib/B/C.pm2272
-rw-r--r--Master/tlpkg/tlperl/lib/B/CC.pm2005
-rw-r--r--Master/tlpkg/tlperl/lib/B/Concise.pm1628
-rw-r--r--Master/tlpkg/tlperl/lib/B/Debug.pm305
-rw-r--r--Master/tlpkg/tlperl/lib/B/Deparse.pm4642
-rw-r--r--Master/tlpkg/tlperl/lib/B/Disassembler.pm233
-rw-r--r--Master/tlpkg/tlperl/lib/B/Lint.pm392
-rw-r--r--Master/tlpkg/tlperl/lib/B/Showlex.pm205
-rw-r--r--Master/tlpkg/tlperl/lib/B/Stackobj.pm349
-rw-r--r--Master/tlpkg/tlperl/lib/B/Stash.pm52
-rw-r--r--Master/tlpkg/tlperl/lib/B/Terse.pm103
-rw-r--r--Master/tlpkg/tlperl/lib/B/Xref.pm430
-rw-r--r--Master/tlpkg/tlperl/lib/B/assemble30
-rw-r--r--Master/tlpkg/tlperl/lib/B/cc_harness12
-rw-r--r--Master/tlpkg/tlperl/lib/B/disassemble22
-rw-r--r--Master/tlpkg/tlperl/lib/B/makeliblinks54
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;