Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

6577 lines (6056 sloc) 223.284 kb
# C.pm
#
# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
# Copyright (c) 2008, 2009, 2010, 2011 Reini Urban
# Copyright (c) 2010 Nick Koston
# Copyright (c) 2011, 2012 cPanel Inc
#
# 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;
use strict;
our $VERSION = '1.43';
my %debug;
my $eval_pvs = '';
package B::C::Section;
use strict;
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 remove {
my $section = shift;
pop @{ $section->[-1]{values} };
}
sub index {
my $section = shift;
return scalar( @{ $section->[-1]{values} } ) - 1;
}
sub comment {
my $section = shift;
$section->[-1]{comment} = join( "", @_ ) if @_;
$section->[-1]{comment};
}
# add debugging info - stringified flags on -DF
sub debug {
my $section = shift;
my $dbg = join( " ", @_ );
$section->[-1]{dbg}->[ $section->index ] = $dbg if $dbg;
}
sub output {
my ( $section, $fh, $format ) = @_;
my $sym = $section->symtable || {};
my $default = $section->default;
my $i = 0;
my $dodbg = 1 if $debug{flags} and $section->[-1]{dbg};
foreach ( @{ $section->[-1]{values} } ) {
my $dbg = "";
s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
if ($dodbg and $section->[-1]{dbg}->[$i]) {
$dbg = " /* ".$section->[-1]{dbg}->[$i]." */";
}
printf $fh $format, $_, $section->name, $i, $dbg;
++$i;
}
}
package B::C::InitSection;
use strict;
# 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]{initav} = [];
$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 add_initav {
my $section = shift;
push @{ $section->[-1]{initav} }, @_;
}
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} } ) {
# dTARG and dSP unused -nt
print $fh <<"EOT";
static int perl_init_${name}(pTHX)
{
EOT
foreach my $i ( @{ $section->[-1]{initav} } ) {
print $fh "\t",$i,"\n";
}
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}(aTHX);");
++$name;
}
# We need to output evals after dl_init.
foreach my $s ( @{ $section->[-1]{evals} } ) {
${B::C::eval_pvs} .= " eval_pv(\"$s\",1);\n";
}
print $fh "static int ${init_name}(pTHX)
{";
$section->SUPER::output( $fh, $format );
print $fh "\treturn 0;\n}\n";
}
package B::C;
use strict;
use Exporter ();
use Errno (); #needed since 5.14
our %Regexp;
{ # block necessary for caller to work
my $caller = caller;
if ( $caller eq 'O' or $caller eq 'Od' ) {
require XSLoader;
XSLoader::load('B::C'); # for r-magic only
}
}
our @ISA = qw(Exporter);
our @EXPORT_OK =
qw( output_all output_boilerplate output_main output_main_rest mark_unused mark_skip
init_sections set_callback save_unused_subs objsym save_context fixup_ppaddr
save_sig svop_pv inc_cleanup );
# for 5.6 better use the native B::C
# 5.6.2 works fine though.
use B
qw( minus_c sv_undef walkoptree walkoptree_slow walksymtable main_root main_start peekop
class cchar svref_2object compile_stats comppadlist hash
threadsv_names main_cv init_av end_av opnumber amagic_generation cstring
HEf_SVKEY SVf_POK SVf_ROK SVf_IOK SVf_NOK SVf_IVisUV SVf_READONLY );
BEGIN {
if ($] >= 5.008) {
@B::NV::ISA = 'B::IV'; # add IVX to nv. This fixes test 23 for Perl 5.8
B->import(qw(regex_padav SVp_NOK SVp_IOK CVf_CONST CVf_ANON)); # both unsupported for 5.6
} else {
eval q[
sub SVp_NOK() {0}; # unused
sub SVp_IOK() {0};
sub CVf_ANON() {4};
];
@B::PVMG::ISA = qw(B::PVNV B::RV);
}
if ($] >= 5.010) {require mro; mro->import;}
}
use B::Asmdata qw(@specialsv_name);
use B::C::Flags;
use FileHandle;
use Config;
my $hv_index = 0;
my $gv_index = 0;
my $re_index = 0;
my $pv_index = 0;
my $cv_index = 0;
my $hek_index = 0;
my $anonsub_index = 0;
my $initsub_index = 0;
# exclude all not B::C:: prefixed subs
my %all_bc_subs = map {$_=>1} qw(B::AV::save B::BINOP::save B::BM::save
B::COP::save B::CV::save B::FAKEOP::fake_ppaddr B::FAKEOP::flags
B::FAKEOP::new B::FAKEOP::next B::FAKEOP::ppaddr B::FAKEOP::private
B::FAKEOP::save B::FAKEOP::sibling B::FAKEOP::targ B::FAKEOP::type
B::GV::save B::GV::savecv B::HV::save B::IO::save B::IO::save_data
B::IV::save B::LISTOP::save B::LOGOP::save B::LOOP::save B::NULL::save
B::NV::save B::OBJECT::save B::OP::_save_common B::OP::fake_ppaddr
B::OP::isa B::OP::save B::PADOP::save B::PMOP::save B::PV::save
B::PVIV::save B::PVLV::save B::PVMG::save B::PVMG::save_magic
B::PVNV::save B::PVOP::save B::REGEXP::save B::RV::save B::SPECIAL::save
B::SPECIAL::savecv B::SV::save B::SVOP::save B::UNOP::save B::UV::save
B::REGEXP::EXTFLAGS);
# Track all internally used packages. All others may not be deleted automatically
# - hidden methods. -fdelete-pkg
my %all_bc_pkg = map {$_=>1} qw(B B::AV B::BINOP B::BM B::COP B::CV B::FAKEOP
B::GV B::HV B::IO B::IV B::LISTOP B::LOGOP B::LOOP B::NULL B::NV
B::OBJECT B::OP B::PADOP B::PMOP B::PV B::PVIV B::PVLV B::PVMG B::PVNV
B::PVOP B::REGEXP B::RV B::SPECIAL B::SV B::SVOP B::UNOP B::UV
AnyDBM_File Fcntl Regexp overload Errno Exporter Exporter::Heavy Config
warnings warnings::register DB next maybe maybe::next FileHandle fields
AutoLoader Carp Symbol PerlIO PerlIO::scalar SelectSaver ExtUtils
ExtUtils::Constant ExtUtils::Constant::ProxySubs threads base IO::File
IO::Seekable IO::Handle IO DynaLoader XSLoader O);
# Note: BEGIN-time sideffect-only packages like strict, vars or constant even
# without functions should not be deleted, so they are not listed here.
# Keep: vars strict constant
if (exists $INC{'blib.pm'}) { # http://blogs.perl.org/users/rurban/2012/02/the-unexpected-case-of--mblib.html
for (qw(Cwd File File::Spec File::Spec::Unix Dos EPOC blib Scalar
Scalar::Util VMS VMS::Filespec VMS::Feature Win32)) {
$all_bc_pkg{$_} = 1;
}
}
# B::C stash footprint: mainly caused by blib, warnings, and Carp loaded with DynaLoader
# perl5.15.7d-nt -MO=C,-o/dev/null -MO=Stash -e0
# -umain,-ure,-umro,-ustrict,-uAnyDBM_File,-uFcntl,-uRegexp,-uoverload,-uErrno,-uExporter,-uExporter::Heavy,-uConfig,-uwarnings,-uwarnings::register,-uDB,-unext,-umaybe,-umaybe::next,-uFileHandle,-ufields,-uvars,-uAutoLoader,-uCarp,-uSymbol,-uPerlIO,-uPerlIO::scalar,-uSelectSaver,-uExtUtils,-uExtUtils::Constant,-uExtUtils::Constant::ProxySubs,-uthreads,-ubase
# perl5.15.7d-nt -MErrno -MO=Stash -e0
# -umain,-ure,-umro,-ustrict,-uRegexp,-uoverload,-uErrno,-uExporter,-uExporter::Heavy,-uwarnings,-uwarnings::register,-uConfig,-uDB,-uvars,-uCarp,-uPerlIO,-uthreads
# perl5.15.7d-nt -Mblib -MO=Stash -e0
# -umain,-ure,-umro,-ustrict,-uCwd,-uRegexp,-uoverload,-uFile,-uFile::Spec,-uFile::Spec::Unix,-uDos,-uExporter,-uExporter::Heavy,-uConfig,-uwarnings,-uwarnings::register,-uDB,-uEPOC,-ublib,-uScalar,-uScalar::Util,-uvars,-uCarp,-uVMS,-uVMS::Filespec,-uVMS::Feature,-uWin32,-uPerlIO,-uthreads
# perl -MO=Stash -e0
# -umain,-uTie,-uTie::Hash,-ure,-umro,-ustrict,-uRegexp,-uoverload,-uExporter,-uExporter::Heavy,-uwarnings,-uDB,-uCarp,-uPerlIO,-uthreads
# pb -MB::Stash -e0
# -umain,-ure,-umro,-uRegexp,-uPerlIO,-uExporter,-uDB
my ($package_pv, @package_pv); # global stash for methods since 5.13
my (%symtable, %cvforward, %lexwarnsym);
my (%strtable, %hektable, @static_free, %newpkg);
my %xsub;
my ($warn_undefined_syms, $method_named_warn);
my ($staticxs, $outfile);
my (%include_package, %skip_package, %saved, %isa_cache, %method_cache);
my %static_ext;
my ($use_xsloader);
my $nullop_count = 0;
# options and optimizations shared with B::CC
our ($curcv, $module, $init_name, %savINC, $mainfile);
our ($use_av_undef_speedup, $use_svpop_speedup) = (1, 1);
our ($pv_copy_on_grow, $optimize_ppaddr, $optimize_warn_sv, $use_perl_script_name,
$save_data_fh, $save_sig, $optimize_cop, $av_init, $av_init2, $ro_inc, $destruct,
$fold, $warnings, $const_strings, $stash, $can_delete_pkg);
our $verbose = 0;
our %option_map = (
'cog' => \$B::C::pv_copy_on_grow,
'const-strings' => \$B::C::const_strings,
'save-data' => \$B::C::save_data_fh,
'ppaddr' => \$B::C::optimize_ppaddr,
'warn-sv' => \$B::C::optimize_warn_sv,
'av-init' => \$B::C::av_init,
'av-init2' => \$B::C::av_init2,
'delete-pkg' => \$B::C::can_delete_pkg,
'ro-inc' => \$B::C::ro_inc,
'stash' => \$B::C::stash, # disable with -fno-stash
'destruct' => \$B::C::destruct, # disable with -fno-destruct
'fold' => \$B::C::fold, # disable with -fno-fold
'warnings' => \$B::C::warnings, # disable with -fno-warnings
'use-script-name' => \$use_perl_script_name,
'save-sig-hash' => \$B::C::save_sig,
'cop' => \$optimize_cop, # XXX very unsafe!
# Better do it in CC, but get rid of
# NULL cops also there.
);
our %debug_map = (
'O' => 'op',
'A' => 'av',
'H' => 'hv',
'C' => 'cv',
'M' => 'mg',
'R' => 'rx',
'G' => 'gv',
'S' => 'sv',
'w' => 'walk',
'c' => 'cops',
's' => 'sub',
'p' => 'pkg',
'm' => 'meth',
'u' => 'unused',
);
my @xpvav_sizes;
my ($max_string_len, $in_endav);
my %static_core_pkg; # = map {$_ => 1} static_core_packages();
my $MULTI = $Config{usemultiplicity};
my $ITHREADS = $Config{useithreads};
my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
my $PERL514 = ( $] >= 5.013002 );
my $PERL512 = ( $] >= 5.011 );
my $PERL510 = ( $] >= 5.009005 );
my $PERL56 = ( $] < 5.008001 ); # yes. 5.8.0 is a 5.6.x
# Thanks to Mattia Barbon for the C99 tip to init any union members
my $C99 = $Config{d_c99_variadic_macros}; # http://docs.sun.com/source/819-3688/c99.app.html#pgfId-1003962
my $MAD = $Config{mad};
my $MYMALLOC = $Config{usemymalloc} eq 'define';
my @threadsv_names;
BEGIN {
@threadsv_names = threadsv_names();
}
# This the Carp free workaround for DynaLoader::bootstrap
sub DynaLoader::croak {die @_}
# 5.15.3 workaround [perl #101336], without .bs support
# XSLoader::load_file($module, $modlibname, ...)
sub XSLoader::load_file {
#package DynaLoader;
use Config ();
my $module = shift or die "missing module name";
my $modlibname = shift or die "missing module filepath";
print STDOUT "XSLoader::load_file(\"$module\", \"$modlibname\" @_)\n"
if ${DynaLoader::dl_debug};
push @_, $module;
#if (my $ver = ${$module."::VERSION"}) {
# # XXX Ensure that there is no v-magic attached,. Else xs_version_bootcheck will fail.
# push @_, $ver;
#}
# works with static linking too
my $boots = "$module\::bootstrap";
goto &$boots if defined &$boots;
my @modparts = split(/::/,$module);
my $modfname = $modparts[-1];
my $modpname = join('/',@modparts);
my $c = @modparts;
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
my $file = "$modlibname/auto/$modpname/$modfname.".$Config::Config->{dlext};
# skip the .bs "bullshit" part, needed for some old solaris ages ago
goto \&DynaLoader::bootstrap_inherit if not -f $file;
my $bootname = "boot_$module";
$bootname =~ s/\W/_/g;
@DynaLoader::dl_require_symbols = ($bootname);
my $boot_symbol_ref;
if ($boot_symbol_ref = DynaLoader::dl_find_symbol(0, $bootname)) {
goto boot; #extension library has already been loaded, e.g. darwin
}
# Many dynamic extension loading problems will appear to come from
# this section of code: XYZ failed at line 123 of DynaLoader.pm.
# Often these errors are actually occurring in the initialisation
# C code of the extension XS file. Perl reports the error as being
# in this perl code simply because this was the last perl code
# it executed.
my $libref = DynaLoader::dl_load_file($file, 0) or do {
die("Can't load '$file' for module $module: " . DynaLoader::dl_error());
};
push(@DynaLoader::dl_librefs, $libref); # record loaded object
my @unresolved = DynaLoader::dl_undef_symbols();
if (@unresolved) {
die("Undefined symbols present after loading $file: @unresolved\n");
}
$boot_symbol_ref = DynaLoader::dl_find_symbol($libref, $bootname) or do {
die("Can't find '$bootname' symbol in $file\n");
};
push(@DynaLoader::dl_modules, $module); # record loaded module
boot:
my $xs = DynaLoader::dl_install_xsub($boots, $boot_symbol_ref, $file);
# See comment block above
push(@DynaLoader::dl_shared_objects, $file); # record files loaded
return &$xs(@_);
}
# Code sections
my (
$init, $decl, $symsect, $binopsect, $condopsect,
$copsect, $padopsect, $listopsect, $logopsect, $loopsect,
$opsect, $pmopsect, $pvopsect, $svopsect, $unopsect,
$svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect,
$xpvivsect, $xpvuvsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
$xrvsect, $xpvbmsect, $xpviosect, $heksect, $free
);
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 save_main_rest;
sub verbose { if (@_) { $verbose = shift; } else { $verbose; } }
sub module { if (@_) { $module = shift; } else { $module; } }
sub walk_and_save_optree {
my ( $name, $root, $start ) = @_;
if ($root) {
$verbose ? walkoptree_slow( $root, "save" ) : 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');
my $OP_DBMOPEN = opnumber('dbmopen');
# special handling for nullified COP's.
my %OP_COP = ( opnumber('nextstate') => 1 );
$OP_COP{ opnumber('setstate') } = 1 if $] > 5.005003 and $] < 5.005062;
$OP_COP{ opnumber('dbstate') } = 1 unless $PERL512;
warn %OP_COP if $debug{cops};
# scalar: pv. list: (stash,pv,sv)
# pads are not named, but may be typed
sub padop_name {
my $op = shift;
my $cv = shift;
if ($op->can('name')
and ($op->name eq 'padsv' or $op->name eq 'method_named'
or ref($op) eq 'B::SVOP')) #threaded
{
return () if $cv and ref($cv->PADLIST) eq 'B::SPECIAL';
my @c = $cv ? $cv->PADLIST->ARRAY : comppadlist->ARRAY;
my @pad = $c[1]->ARRAY;
my @types = $c[0]->ARRAY;
my $ix = $op->can('padix') ? $op->padix : $op->targ;
my $sv = $pad[$ix];
my $t = $types[$ix];
if (defined($t) and ref($t) ne 'B::SPECIAL') {
my $pv = $sv->can("PV") ? $sv->PV : ($t->can('PVX') ? $t->PVX : '');
# need to fix B for SVpad_TYPEDI without formal STASH
my $stash = (ref($t) eq 'B::PVMG' and ref($t->SvSTASH) ne 'B::SPECIAL') ? $t->SvSTASH->NAME : '';
return wantarray ? ($stash,$pv,$sv) : $pv;
} elsif ($sv) {
my $pv = $sv->PV if $sv->can("PV");
my $stash = $sv->STASH->NAME if $sv->can("STASH");
return wantarray ? ($stash,$pv,$sv) : $pv;
}
}
}
sub svop_name {
my $op = shift;
my $cv = shift;
my $sv;
if ($op->can('name') and $op->name eq 'padsv') {
my @r = padop_name($op, $cv);
return wantarray ? @r : ($r[1] ? $r[1] : $r[0]);
} else {
if (!$op->can("sv")) {
if (ref($op) eq 'B::PMOP' and $op->pmreplroot->can("sv")) {
$sv = $op->pmreplroot->sv;
} else {
$sv = $op->first->sv unless $op->flags & 4
or ($op->name eq 'const' and $op->flags & 34) or $op->first->can("sv");
}
} else {
$sv = $op->sv;
}
if ($sv and $$sv) {
if ($sv->FLAGS & SVf_ROK) {
return '' if $sv->isa("B::NULL");
my $rv = $sv->RV;
if ($rv->isa("B::PVGV")) {
my $o = $rv->IO;
return $o->STASH->NAME if $$o;
}
return '' if $rv->isa("B::PVMG");
return $rv->STASH->NAME;
} else {
if ($op->name eq 'gvsv') {
return wantarray ? ($sv->STASH->NAME, $sv->NAME) : $sv->STASH->NAME.'::'.$sv->NAME;
} elsif ($op->name eq 'gv') {
return wantarray ? ($sv->STASH->NAME, $sv->NAME) : $sv->STASH->NAME.'::'.$sv->NAME;
} else {
return $sv->can('STASH') ? $sv->STASH->NAME
: $sv->can('NAME') ? $sv->NAME : $sv->PV;
}
}
}
}
}
# Returns a SVOP->pv (const PV or method_named PV mostly). for the symbol and stash name see svop_name
# 1. called from check_entersub/method_named to get the pv
# 2. called from svop before method/method_named to cache the $package_pv
sub svop_pv {
my $op = shift;
my $cv = shift;
my $sv;
if (!$op->can("sv")) {
if ($op->can('name') and $op->name eq 'padsv') {
my $pv = padop_name($op, $cv);
return $pv;
}
if (ref($op) eq 'B::PMOP' and $op->pmreplroot->can("sv")) {
$sv = $op->pmreplroot->sv;
} else {
if ($op->flags & 4 # OPf_KIDS
and !($op->name eq 'const' and $op->flags & 64) # !OPpCONST_BARE
and $op->first->can("sv")) {
$sv = $op->first->sv;
}
}
} else {
$sv = $op->sv;
}
if ($sv and $$sv) {
return $sv->PV if $sv->can("PV");
} else { # threaded
my $pv = padop_name($op, $cv);
return $pv;
}
}
# get or set package name for a variable, defined by
# $obj = bless {}, "Package"; or
# $obj = new Package; resp. $obj = Package->new;
# obj can be a padsv or gvsv
sub cache_svop_pkg {
my $svop = shift;
my $sv;
if ($svop->name eq 'padsv') {
my @c = comppadlist->ARRAY;
my @pad = $c[1]->ARRAY;
my $ix = $svop->can('padix') ? $svop->padix : $svop->targ;
$sv = $pad[$ix];
} elsif ($svop->name eq 'gvsv') {
$sv = $svop->sv;
} elsif ($svop->name eq 'gv') {
$sv = $svop->gv;
}
if ($sv and $$sv) {
if (@_) { # set
$newpkg{$$sv} = shift;
} else { # get
return $newpkg{$$sv};
}
}
}
sub savesym {
my ( $obj, $value ) = @_;
my $sym = sprintf( "s\\_%x", $$obj );
$symtable{$sym} = $value;
return $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
if ( exists $symtable{$sym} ) {
return $symtable{$sym};
}
else {
warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
return "UNUSED";
}
}
sub delsym {
my ( $obj ) = @_;
my $sym = sprintf( "s\\_%x", $$obj );
delete $symtable{$sym};
}
sub savere {
my $re = shift;
my $flags = shift || 0;
my $sym;
my $pv = $re;
my $cur = length $pv;
my $len = 0; # length( pack "a*", $pv ) + 1;
if ($PERL514) {
$xpvsect->add( sprintf( "Nullhv, {0}, %u, %u", $cur, $len ) );
$svsect->add( sprintf( "&xpv_list[%d], 1, %x, {(char*)%s}", $xpvsect->index,
0x4405, savepv($pv) ) );
$sym = sprintf( "&sv_list[%d]", $svsect->index );
}
elsif ($PERL510) {
# BUG! Should be the same as newSVpvn($resym, $relen) but is not
my $s1 = ($PERL514 ? "NULL," : "") . "{0}, %u, %u";
$xpvsect->add( sprintf( $s1, $cur, $len ) );
$svsect->add( sprintf( "&xpv_list[%d], 1, %x, {(char*)%s}", $xpvsect->index,
0x4405, savepv($pv) ) );
my $s = "sv_list[".$svsect->index."]";
$sym = "&$s";
push @static_free, $s if $len and $B::C::pv_copy_on_grow;
}
else {
$sym = sprintf( "re%d", $re_index++ );
$decl->add( sprintf( "Static const char *$sym = %s;", cstring($re) ) );
}
return ( $sym, length( pack "a*", $re ) );
}
sub constpv {
my $pv = pack "a*", shift;
if (exists $strtable{$pv}) {
return $strtable{$pv};
}
my $pvsym = sprintf( "pv%d", $pv_index++ );
$strtable{$pv} = "$pvsym";
my $const = ($B::C::pv_copy_on_grow and $B::C::const_strings) ? " const" : "";
if ( defined $max_string_len && length($pv) > $max_string_len ) {
my $chars = join ', ', map { cchar $_ } split //, $pv;
$decl->add( sprintf( "Static$const char %s[] = { %s };", $pvsym, $chars ) );
} else {
my $cstring = cstring($pv);
if ( $cstring ne "0" ) { # sic
$decl->add( sprintf( "Static$const char %s[] = %s;", $pvsym, $cstring ) );
}
}
return wantarray ? ( $pvsym, length( pack "a*", $pv ) ) : $pvsym;
}
sub savepv {
return constpv($_[0]) if $B::C::const_strings and $B::C::pv_copy_on_grow; # or readonly
my $pv = pack "a*", shift;
my $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 ) );
}
}
my $len = length( pack "a*", $pv ) + 1;
return ( $pvsym, $len );
}
sub save_rv {
my ($sv, $fullname) = @_;
if (!$fullname) {
$fullname = '(unknown)';
}
# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
# 5.6: Can't locate object method "RV" via package "B::PVMG"
my $rv = $sv->RV->save($fullname);
$rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
return $rv;
}
# => savesym, cur, len, pv
sub save_pv_or_rv {
my ($sv, $fullname) = @_;
my $rok = $sv->FLAGS & SVf_ROK;
my $pok = $sv->FLAGS & SVf_POK;
my ( $cur, $len, $savesym, $pv ) = ( 0, 0 );
# overloaded VERSION symbols fail to xs boot: ExtUtils::CBuilder with Fcntl::VERSION (i91)
# 5.6: Can't locate object method "RV" via package "B::PV" Carp::Clan
if ($rok and !$PERL56) {
# this returns us a SV*. 5.8 expects a char* in xpvmg.xpv_pv
warn "save_pv_or_rv: save_rv(",$sv,")\n" if $debug{sv};
$savesym = ($PERL510 ? "" : "(char*)") . save_rv($sv, $fullname);
}
else {
$pv = $pok ? ( pack "a*", $sv->PV ) : undef;
$cur = $pok ? length($pv) : 0;
my $shared_hek = $PERL510 ? (($sv->FLAGS & 0x09000000) == 0x09000000) : undef;
local $B::C::pv_copy_on_grow if $shared_hek;
if ($pok) {
if ($B::C::pv_copy_on_grow) {
( $savesym, $len ) = ($B::C::const_strings and $sv->FLAGS & SVf_READONLY)
? constpv($pv) : savepv($pv);
} else {
( $savesym, $len ) = ( 'ptr_undef', $cur+1 );
}
} else {
( $savesym, $len ) = ( 'ptr_undef', 0 );
}
}
return ( $savesym, $cur, $len, $pv );
}
# Shared global string in PL_strtab.
# Mostly GvNAME and GvFILE but also CV prototypes or bareword hash keys.
sub save_hek {
my $str = shift; # not cstring'ed
my $len = length $str;
# force empty string for CV prototypes
if (!$len and !@_) { wantarray ? return ( "NULL", 0 ) : return "NULL"; }
if (exists $hektable{$str}) {
return wantarray ? ($hektable{$str}, length( pack "a*", $hektable{$str} ))
: $hektable{$str};
}
my $cur = length( pack "a*", $str );
my $sym = sprintf( "hek%d", $hek_index++ );
$hektable{$str} = $sym;
my $cstr = cstring($str);
$decl->add(sprintf("Static HEK *%s;",$sym));
# randomized global shared hash keys:
# share_hek needs a non-zero hash parameter, unlike hv_store.
# Vulnerable to oCERT-2011-003 style DOS attacks?
# user-input (object fields) does not affect strtab, it is pretty safe.
# But we need to randomize them to avoid run-time conflicts
# e.g. "Prototype mismatch: sub bytes::length (_) vs (_)"
$init->add(sprintf("%s = share_hek(%s, %u, %s);",
$sym, $cstr, $cur, '0'));
wantarray ? ( $sym, $cur ) : $sym;
}
sub ivx ($) {
my $ivx = shift;
my $ivdformat = $Config{ivdformat};
$ivdformat =~ s/"//g; #" poor editor
my $intmax = (1 << ($Config{ivsize}*4-1)) - 1;
# LL if INT32_MAX .. INT64_MAX
# UL if > INT32_MAX = 2147483647
my $ll = $Config{d_longlong} ? "LL" : "UL";
my $sval = sprintf("%${ivdformat}%s", $ivx, $ivx > $intmax ? $ll : "");
if ($ivx < -$intmax) {
my $l = $Config{d_longlong} ? "LL" : "L";
$sval = sprintf("%${ivdformat}%s", $ivx, $l); # DateTime
}
$sval = '0' if $sval =~ /(NAN|inf)$/i;
return $sval;
#return $C99 ? ".xivu_uv = $sval" : $sval; # this is version dependent
}
# protect from warning: floating constant exceeds range of ‘double’ [-Woverflow]
sub nvx ($) {
my $nvx = shift;
my $nvgformat = $Config{nvgformat};
$nvgformat =~ s/"//g; #" poor editor
my $dblmax = "1.79769313486232e+308";
# my $ldblmax = "1.18973149535723176502e+4932L"
my $ll = $Config{d_longdbl} ? "LL" : "L";
my $sval = sprintf("%${nvgformat}%s", $nvx, $nvx > $dblmax ? $ll : "");
if ($nvx < -$dblmax) {
$sval = sprintf("%${nvgformat}%s", $nvx, $ll);
}
$sval = '0' if $sval =~ /(NAN|inf)$/i;
$sval .= '.00' if $sval =~ /^-?\d+$/;
return $sval;
}
# See also init_op_ppaddr below; initializes the ppaddr to the
# OpTYPE; init_op_ppaddr iterates over the ops and sets
# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignment
# in perl_init ( ~10 bytes/op with GCC/i386 )
sub B::OP::fake_ppaddr {
return "NULL" unless $_[0]->can('name');
return $B::C::optimize_ppaddr
? sprintf( "INT2PTR(void*,OP_%s)", uc( $_[0]->name ) )
: ( $verbose ? sprintf( "/*OP_%s*/NULL", uc( $_[0]->name ) ) : "NULL" );
}
sub B::FAKEOP::fake_ppaddr { "NULL" }
# XXX HACK! duct-taping around compiler problems
sub B::OP::isa { UNIVERSAL::isa(@_) } # walkoptree_slow misses that
sub B::OP::can { UNIVERSAL::can(@_) }
sub B::OBJECT::name { "" } # B misses that
$isa_cache{'B::OBJECT::can'} = 'UNIVERSAL';
# This pair is needed because B::FAKEOP::save doesn't scalar dereference
# $op->next and $op->sibling
my $opsect_common =
"next, sibling, ppaddr, " . ( $MAD ? "madprop, " : "" ) . "targ, type, ";
{
# 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.
# 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.10 op_seq = -1 is gone, the temp. op_static also, but we
# have something better, we can set op_latefree to 1, which frees the children
# (e.g. savepvn), but not the static op.
# 5.8: U16 op_seq;
# 5.9.4: unsigned op_opt:1; unsigned op_static:1; unsigned op_spare:5;
# 5.10: unsigned op_opt:1; unsigned op_latefree:1; unsigned op_latefreed:1; unsigned op_attached:1; unsigned op_spare:3;
my $static;
if ( $] < 5.009004 ) {
$static = sprintf "%u", 65535;
$opsect_common .= "seq";
}
elsif ( $] < 5.010 ) {
$static = '0, 1, 0';
$opsect_common .= "opt, static, spare";
}
else {
$static = '0, 1, 0, 0, 0';
$opsect_common .= "opt, latefree, latefreed, attached, spare";
}
sub B::OP::_save_common_middle {
my $op = shift;
my $madprop = $MAD ? "0," : "";
# XXX maybe add a ix=opindex string for debugging if $debug{flags}
sprintf( "%s,%s %u, %u, $static, 0x%x, 0x%x",
$op->fake_ppaddr, $madprop, $op->targ, $op->type, $op->flags, $op->private );
}
$opsect_common .= ", flags, private";
}
# run-time loaded package, detected via bless or new.
sub force_dynpackage {
my $pv = shift;
no strict 'refs';
if (!$skip_package{$pv} and $pv !~ /^B::/) { # XXX only loaded at run-time
if (!$INC{inc_packname($pv)}) {
eval "require $pv;";
if (!$@) {
if (!$INC{inc_packname($pv)}) {
warn "Warning: Problem with require \"$pv\" - !\$INC{".inc_packname($pv)."}\n";
} else {
warn "load \"$pv\"\n" if $debug{meth};
}
}
}
mark_package($pv);
}
}
# Heuristic to check method calls for the class to store the full sub name.
# Also associate objects with classes - $obj=new Class; - to resolve method calls later.
# Compile-time method_named packages are always const PV sM/BARE.
# run-time packages ("objects") are in padsv (printed as gvsv).
# my Foo $obj = shift; $obj->bar();
# entersub -> pushmark -> package -> args.. -> method_named|method
# See perl -MO=Terse -e '$foo->bar("var")'
# See also http://www.perl.com/pub/2000/06/dougpatch.html
sub check_entersub {
my $op = shift;
my $cv = shift;
$cv = $B::C::curcv unless $cv;
if ($op->type > 0 and
$op->name eq 'entersub' and $op->first and $op->first->can('name') and
$op->first->name eq 'pushmark' and
# Foo->bar() compile-time lookup, 34 WANT_SCALAR,MOD in all versions
(($op->first->next->name eq 'const' and $op->first->next->flags == 34)
# or $foo->bar() run-time lookup
or ($op->first->next->name eq 'padsv'))) # note that padsv is called gvsv in Concise
{
my $pkgop = $op->first->next; # padsv for objects or const for classes
my $methop = $pkgop; # walk args until method or sub end. This ends
do { $methop = $methop->next; }
while ($methop->name !~ /^method_named|method$/
or ($methop->name eq 'gv' and $methop->next->name ne 'entersub'));
my $methopname = $methop->name;
if (substr($methopname,0,6) eq 'method') {
my $methodname = $methopname eq 'method' ? svop_name($methop, $cv) : svop_pv($methop, $cv);
if ($pkgop->name eq 'const') {
my $pv = svop_pv($pkgop, $cv); # 5.13: need to store away the pkg pv
if ($pv and $pv !~ /[! \(]/) {
warn "check package_pv $pv for $methopname \"$methodname\"\n" if $debug{meth};
# padsv package names are dynamic. They cannot be determined at compile-time,
# unless they are typed.
# We can catch the 'new' method and assign the const package_pv to the symbol
# and compare the padsv then. $foo=new Class;$foo->method; #main::foo => Class
# Note: 'new' is no keyword (yet), but good enough. We check bless also.
if ($methopname eq 'method_named' and 'new' eq svop_pv($methop, $cv)) {
my $objname = svop_name($pkgop);
my $symop = $op->next;
if (($symop->name eq 'padsv' or $symop->name eq 'gvsv')
and $symop->next->name eq 'sassign') {
no strict 'refs';
warn "cache object $objname = new $pv;\n" if $debug{meth};
force_dynpackage($pv);
svref_2object( \&{"$pv\::$methodname"} )->save
if $methodname and defined(&{"$pv\::$methodname"});
cache_svop_pkg($symop, $pv);
}
}
$package_pv = $pv;
push_package($package_pv);
}
} elsif ($pkgop->name eq 'padsv') { # check cached obj class
my $objname = padop_name($pkgop, $cv) || '';
if (my $pv = cache_svop_pkg($pkgop)) {
warn "cached package for $objname->$methodname found: \"$pv\"\n" if $debug{meth};
svref_2object( \&{"$pv\::$methodname"} )->save
if $methodname and defined(&{"$pv\::$methodname"});
$package_pv = $pv;
push_package($package_pv);
} else {
warn "package for $objname->$methodname not found\n" if $debug{meth};
}
} else {
my $methodname = svop_pv($methop, $cv);
warn "XXX package_pv for $methopname $methodname not found\n" if $debug{meth};
}
}
}
}
# $ p -MO=Concise ccode72.pl
# ...
# 8 <2> sassign vKS/2 ->9
# 6 <@> bless sK/2 ->7 <== start at 6
# - <0> ex-pushmark s ->3
# 4 <@> anonhash sK* ->5
# 3 <0> pushmark s ->4
# 5 <$> const(PV "pkg") s ->6 <== pkgop
# 7 <0> padsv[$o:2,3] sRM*/LVINTRO ->8 <== symop
#
# my $o = bless {},"pkg";
sub check_bless {
my $op = shift;
my $cv = shift;
$cv = $B::C::curcv unless $cv;
if ($op->type > 0 and
$op->name eq 'bless' and
$op->first and $op->first->next->name eq 'pushmark' and
$op->first->next->next->next->name eq 'const' and
($op->next->name eq 'padsv' or $op->next->name eq 'gvsv') and
$op->next->next->name eq 'sassign'
)
{
my $pkgop = $op->first->next->next->next;
my $pv = svop_pv($pkgop, $cv);
if ($pv and $pv !~ /[! \(]/) {
my $symop = $op->next;
warn sprintf("cache %s = bless(..., \"$pv\")\n", svop_name($symop, $cv)) if $debug{meth};
cache_svop_pkg($symop, $pv);
force_dynpackage($pv);
$package_pv = $pv;
push_package($package_pv);
}
}
}
# $ p -MO=Concise -e'require MyModule'
# 5 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v:{ ->3
# 4 <1> require sK/1 ->5
# 3 <$> const(PV "MyModule.pm") s/BARE ->4
# require bareword;
sub check_require {
my $op = shift;
my $cv = shift;
$cv = $B::C::curcv unless $cv;
if ($op->type > 0 and
$op->name eq 'require' and
$op->first and $op->first->name eq 'const'
)
{
my $const = $op->first;
my $pv = svop_pv($const, $cv);
if ($pv and $pv !~ /[! \(]/) {
warn "require $pv\n" if $debug{meth};
$pv = packname_inc($pv) if $pv =~ /\.p[lm]$/;
force_dynpackage($pv);
$package_pv = $pv;
push_package($package_pv);
}
}
}
sub B::OP::_save_common {
my $op = shift;
if ($op->type > 0) {
check_entersub($op) if $op->name eq 'entersub';
check_bless($op) if $op->name eq 'bless';
check_require($op) if $op->name eq 'require';
}
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 ] ) )
);
}
if (ref($op) eq 'B::OP') { # check wrong BASEOPs
# [perl #80622] Introducing the entrytry hack, needed since 5.12, fixed with 5.13.8 a425677
# ck_eval upgrades the UNOP entertry to a LOGOP, but B gets us just a B::OP (BASEOP).
# op->other points to the leavetry op, which is needed for the eval scope.
if ($op->name eq 'entertry') {
warn "[perl #80622] Upgrading entertry from BASEOP to LOGOP...\n" if $verbose;
bless $op, 'B::LOGOP';
return $op->save($level);
}
}
# since 5.10 nullified cops free their additional fields
if ( $PERL510 and !$type and $OP_COP{ $op->targ } ) {
warn sprintf( "Null COP: %d\n", $op->targ ) if $debug{cops};
if (0 and $optimize_cop) {
# XXX when is the NULL COP save to skip?
# unsafe after entersub, entereval, anoncode, sort block (pushmark pushmark)
# Rather skip this with CC not with C because we need the context.
# XXX we dont have the prevop, it can be any op type.
if ($verbose or $debug{cops}) {
my $prevop = getsym(sprintf("&op_list[%d]", $opsect->index));
warn sprintf( "Skip Null COP: %d, prev=\\s%x\n",
$op->targ, $prevop);
}
return savesym( $op, $op->next->save );
}
if ($ITHREADS and $] >= 5.015004) {
$copsect->comment(
"$opsect_common, line, stash, file, hints, seq, warnings, hints_hash");
$copsect->add(sprintf("%s, 0, (char *)NULL, NULL, 0, 0, 0, NULL, NULL",
$op->_save_common));
}
elsif ($PERL512) {
$copsect->comment(
"$opsect_common, line, stash, file, hints, seq, warnings, hints_hash");
$copsect->add(sprintf("%s, 0, %s, NULL, 0, 0, NULL, NULL",
$op->_save_common, $ITHREADS ? "(char *)NULL" : "Nullhv"));
}
elsif ($PERL510) {
$copsect->comment("$opsect_common, line, label, seq, warn_int, hints_hash");
$copsect->add(sprintf("%s, %u, NULL, " . "NULL, NULL, 0, " . "%u, %d, NULL",
$op->_save_common, 0, 0, 0));
}
else {
$copsect->comment(
"$opsect_common, label, seq, arybase, line, warnings, hints_hash");
$copsect->add(
sprintf( "%s, NULL, NULL, NULL, 0, 0, 0, NULL", $op->_save_common ) );
}
my $ix = $copsect->index;
$init->add( sprintf( "cop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
savesym( $op, "(OP*)&cop_list[$ix]" );
}
else {
$opsect->comment($opsect_common);
$opsect->add( $op->_save_common );
$opsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $opsect->index;
$init->add( sprintf( "op_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
warn( sprintf( " OP=%s targ=%d flags=0x%x private=0x%x\n",
peekop($op), $op->targ, $op->flags, $op->private ) ) if $debug{op};
savesym( $op, "&op_list[$ix]" );
}
}
# needed for special GV logic: save only stashes for stashes
package B::STASHGV;
our @ISA = ('B::GV');
package B::FAKEOP;
our @ISA = qw(B::OP);
sub new {
my ( $class, %objdata ) = @_;
bless \%objdata, $class;
}
sub 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 $B::C::optimize_ppaddr;
return "&op_list[$ix]";
}
*_save_common_middle = \&B::OP::_save_common_middle;
sub next { $_[0]->{"next"} || 0 }
sub type { $_[0]->{type} || 0 }
sub sibling { $_[0]->{sibling} || 0 }
sub ppaddr { $_[0]->{ppaddr} || 0 }
sub targ { $_[0]->{targ} || 0 }
sub flags { $_[0]->{flags} || 0 }
sub private { $_[0]->{private} || 0 }
package B::C;
# dummy for B::C, only needed for B::CC
sub label {}
# save alternate ops if defined, and also add labels (needed for B::CC)
sub do_labels ($@) {
my $op = shift;
for my $m (@_) {
if ( ${ $op->$m } ) {
label($op->$m);
$op->$m->save if $m ne 'first'; # first is saved by walkoptree, avoid recursion.
# or ($op->flags & 4
# and !($op->name eq 'const' and $op->flags & 64)); #OPpCONST_BARE has no first
}
}
}
sub B::UNOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$unopsect->comment("$opsect_common, first");
$unopsect->add( sprintf( "%s, s\\_%x", $op->_save_common, ${ $op->first } ) );
$unopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $unopsect->index;
$init->add( sprintf( "unop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$sym = savesym( $op, "(OP*)&unop_list[$ix]" );
do_labels ($op, 'first');
$sym;
}
sub B::BINOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$binopsect->comment("$opsect_common, first, last");
$binopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x",
$op->_save_common,
${ $op->first },
${ $op->last }
)
);
$binopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $binopsect->index;
$init->add( sprintf( "binop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$sym = savesym( $op, "(OP*)&binop_list[$ix]" );
do_labels ($op, 'first', 'last');
$sym;
}
sub B::LISTOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$listopsect->comment("$opsect_common, first, last");
$listopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x",
$op->_save_common,
${ $op->first },
${ $op->last }
)
);
$listopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $listopsect->index;
$init->add( sprintf( "listop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$sym = savesym( $op, "(OP*)&listop_list[$ix]" );
if ($op->type == $OP_DBMOPEN) {
mark_package('AnyDBM_File'); # to save ISA and TIEHASH
use strict 'refs';
# resolve it at compile-time, not at run-time
my $dbm = $AnyDBM_File::ISA[0];
svref_2object( \&{"$dbm\::bootstrap"} )->save;
}
do_labels ($op, 'first', 'last');
$sym;
}
sub B::LOGOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$logopsect->comment("$opsect_common, first, other");
$logopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x",
$op->_save_common,
${ $op->first },
${ $op->other }
)
);
$logopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $logopsect->index;
$init->add( sprintf( "logop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$sym = savesym( $op, "(OP*)&logop_list[$ix]" );
do_labels ($op, 'first', 'other');
$sym;
}
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)) if $debug{op};
$loopsect->comment("$opsect_common, first, last, redoop, nextop, lastop");
$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 }
)
);
$loopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $loopsect->index;
$init->add( sprintf( "loop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$sym = savesym( $op, "(OP*)&loop_list[$ix]" );
do_labels($op, qw(first last redoop nextop lastop));
$sym;
}
sub B::PVOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$loopsect->comment("$opsect_common, pv");
$pvopsect->add( sprintf( "%s, %s", $op->_save_common, cstring( $op->pv ) ) );
$pvopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $pvopsect->index;
$init->add( sprintf( "pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
savesym( $op, "(OP*)&pvop_list[$ix]" );
}
# XXX Until we know exactly the package name for a method_call
# we improve the method search heuristics by maintaining this mru list.
sub push_package ($;$) {
my $p = shift or return;
my $soft = shift;
warn "save package_pv \"$p\" for method_name\n"
if $debug{meth} and !grep { $p eq $_ } @package_pv;
@package_pv = grep { $p ne $_ } @package_pv if @package_pv; # remove duplicates at the end
$soft = 1 if $p =~ /^B::/; # improve our chances not to pull in B
if ($soft) {
push @package_pv, $p; # add to the end
} else {
unshift @package_pv, $p; # prepend at the front
mark_package($p);
}
}
sub find_method {
my ($pkg, $name) = @_;
return if $skip_package{$pkg}; # forced to skip
no strict 'refs';
my $method = $pkg . '::' . $name;
if (defined(&{$method})) {
$include_package{$_} = 1; # issue59
$package_pv = $pkg;
mark_package($pkg, 1);
return $method;
}
if (my $parent = try_isa($pkg,$name)) { # this already does mark_package...
$include_package{$parent} = 1;
return $parent . '::' . $name;
}
}
# method_named is in 5.6.1
# Find the package of methods, run-time (heuristic) for objects, compile-time (const) for classes.
# we have a default $package_pv, and several candidates @package_pv.
# Note: Package PV of an object is unacessible at compile-time, only at run-time.
# We only know the symbol name of the object.
# But a classname is a the const after the pushmark, before all args.
# See L<perloptree/"Call a method">
# We check it in op->_save_common
sub method_named {
my $name = shift;
return unless $name;
my $cop = shift;
my $loc = $cop ? " at ".$cop->file." line ".$cop->line : "";
#if (ref($name) eq 'B::CV') {
# warn $name;
# return $name;
#}
my ($method, @candidates);
for my $p ( $package_pv, @package_pv, 'main',
grep{$include_package{$_}} keys %include_package,
map{packname_inc($_)} keys %INC ) {
push @candidates, $p unless grep {$p eq $_} @candidates;
}
CAND:
for my $p (@candidates) {
next if $skip_package{$p}; # forced to skip
no strict 'refs';
$method = $p . '::' . $name;
last CAND if $method_cache{$method};
if (defined(&{$method})) {
$include_package{$p} = 1; # issue59
$package_pv = $p;
mark_package($p, 1);
last CAND;
} else {
return if $method =~ /^threads::(GV|NAME|STASH)$/; # Carp artefact to ignore B
# Without ithreads threads.pm is not loaded. Return none broke 15 and 51 by sideeffect,
# omitting DynaLoader methods, eg.
return svref_2object( \&{'threads::tid'} ) if $method eq 'threads::tid';
return svref_2object( \&{'UNIVERSAL::isa'} ) if $method eq 'B::OP::isa';
if (my $parent = try_isa($p,$name)) {
$method = $parent . '::' . $name;
$include_package{$parent} = 1;
$package_pv = $parent; # looks like a good new default
mark_package($parent, 1);
last CAND;
}
$method = $p.'::'.$name;
#warn "2nd round to find the package for \"$method\"\n" if $debug{cv};
#for (keys %include_package) {
#if ($method = find_method($_, $name)) {
# last CAND;
#}
#}
#$method = $p.'::'.$name;
#warn "3rd desperate round to find the package for \"$method\" in \%INC \n" if $debug{cv};
#for (map{packname_inc($_)} keys %INC) {
#if ($method = find_method($_, $name)) {
# last CAND;
#}
#}
}
}
if (defined(&{$method})) {
unless ($method_cache{$method}) {
$method_cache{$method} = $method;
warn "save found method_name \"$method\"$loc\n" if $debug{meth};
}
return svref_2object( \&{$method} );
}
my $b = $Config{archname}."/B\.pm";
if ($name !~ /^tid|can|isa|pmreplroot$/ and $loc !~ m/$b line / and $package_pv !~ /^B::/) {
# warn "WARNING: method \"$package_pv->$name\" not found"
# . $loc
# . ($verbose ? " in (".join(" ",@candidates).")" : "")
# . ".\n";
# warn "Either need to force a package with -uPackage, or maybe the method is never called at run-time.\n"
# if $verbose and !$method_named_warn++;
return undef if $ITHREADS;
}
$method = $package_pv.'::'.$name;
return svref_2object( \&{$method} );
}
# return the next COP for file and line info
sub nextcop {
my $op = shift;
while ($op and ref($op) ne 'B::COP' and ref($op) ne 'B::NULL') { $op = $op->next; }
return ($op and ref($op) eq 'B::COP') ? $op : undef;
}
sub B::SVOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
my $svsym = 'Nullsv';
# XXX moose1 crash with 5.8.5-nt, Cwd::_perl_abs_path also
if ($op->name eq 'aelemfast' and $op->flags & 128) { #OPf_SPECIAL
$svsym = '&PL_sv_undef'; # pad does not need to be saved
warn sprintf("SVOP->sv aelemfast pad %d\n", $op->flags) if $debug{sv};
} elsif ($op->name eq 'gv' and $op->next and $op->next->name eq 'rv2cv'
and $op->next->next and $op->next->next->name eq 'defined' ) {
my $gv = $op->sv;
my $gvsv = svop_name($op);
if ($gvsv !~ /^DynaLoader::/) {
warn "skip saving defined(&$gvsv)\n" if $debug{gv}; # defer to run-time
$svsym = '(SV*)' . $gv->save( 8 ); # ~Save_CV in B::GV::save
} else {
$svsym = '(SV*)' . $gv->save();
}
} else {
my $sv = $op->sv;
# XXX Deep recursion in recursive functions
$svsym = $sv->save(); #"svop ".$op->name);
if ($svsym !~ /^sv_list/) {
$svsym = '(SV*)'.$svsym;
}
}
if ($op->name eq 'method_named') {
my $cv = method_named(svop_pv($op, $B::C::curcv), nextcop($op));
$cv->save if $cv;
}
my $is_const_addr = $svsym =~ m/Null|\&/;
if ($MULTI and $svsym =~ /\(SV\*\)\&PL_sv_(yes|no)/) { # t/testm.sh Test::Pod
$is_const_addr = 0;
}
$svopsect->comment("$opsect_common, sv");
$svopsect->add(
sprintf( "%s, %s",
$op->_save_common, ( $is_const_addr ? $svsym : 'Nullsv' ) )
);
$svopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $svopsect->index;
$init->add( sprintf( "svop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::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;
if ($op->name eq 'method_named') {
my $cv = method_named(svop_pv($op, $B::C::curcv), nextcop($op));
$cv->save if $cv;
}
# This is saved by curpad syms at the end. But with __DATA__ handles it is better to save earlier
if ($op->name eq 'padsv' or $op->name eq 'gvsv' or $op->name eq 'gv') {
my @c = comppadlist->ARRAY;
my @pad = $c[1]->ARRAY;
my $ix = $op->can('padix') ? $op->padix : $op->targ;
my $sv = $pad[$ix];
$sv->save("padop ".padop_name($op->name, $B::C::curcv)) if $sv and $$sv;
}
$padopsect->comment("$opsect_common, padix");
$padopsect->add( sprintf( "%s, %d", $op->_save_common, $op->padix ) );
$padopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $padopsect->index;
$init->add( sprintf( "padop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
savesym( $op, "(OP*)&padop_list[$ix]" );
}
sub B::COP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
if ($optimize_cop and !$op->label) { # XXX very unsafe!
my $sym = savesym( $op, $op->next->save );
warn sprintf( "Skip COP (0x%x) => %s (0x%x), line %d file %s\n",
$$op, $sym, $op->next, $op->line, $op->file ) if $debug{cops};
return $sym;
}
# TODO: if it is a nullified COP we must save it with all cop fields!
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 = ref($warnings) eq 'B::SPECIAL';
my $warnsvcast = $PERL510 ? "STRLEN*" : "SV*";
if ( $is_special && $$warnings == 4 ) {
# use warnings 'all';
$warn_sv =
$B::C::optimize_warn_sv
? "INT2PTR($warnsvcast,1)".($verbose ?' /*pWARN_ALL*/':'')
: 'pWARN_ALL';
}
elsif ( $is_special && $$warnings == 5 ) {
# no warnings 'all';
$warn_sv =
$B::C::optimize_warn_sv
? "INT2PTR($warnsvcast,2)".($verbose ?' /*pWARN_NONE*/':'')
: 'pWARN_NONE';
}
elsif ($is_special) {
# use warnings;
$warn_sv =
$B::C::optimize_warn_sv
? "INT2PTR($warnsvcast,3)".($verbose ?' /*pWARN_STD*/':'')
: 'pWARN_STD';
}
else {
# LEXWARN_on: Original $warnings->save from 5.8.9 was wrong,
# DUP_WARNINGS copied length PVX bytes.
$warnings = bless $warnings, "B::LEXWARN";
$warn_sv = $warnings->save;
my $ix = $copsect->index + 1;
# XXX No idea how a &sv_list[] came up here, a re-used object. Anyway.
$warn_sv = substr($warn_sv,1) if substr($warn_sv,0,3) eq '&sv';
$warn_sv = "($warnsvcast)&".$warn_sv.($verbose ?' /*lexwarn*/':'');
$free->add( sprintf( " cop_list[%d].cop_warnings = NULL;", $ix ) );
#push @static_free, sprintf("cop_list[%d]", $ix);
}
# Trim the .pl extension, to print the executable name only.
my $file = $op->file;
$file =~ s/\.pl$/.c/;
if ($PERL512) {
if ($ITHREADS and $] >= 5.015004) {
$copsect->comment(
"$opsect_common, line, stashpv, file, stashflags, hints, seq, warnings, hints_hash");
$copsect->add(
sprintf(
"%s, %u, " . "%s, %s, %d, 0, " . "%s, %s, NULL",
$op->_save_common, $op->line,
"(char*)".constpv( $op->stashpv ), # we can store this static
"(char*)".constpv( $file ), $op->stashflags,
ivx($op->cop_seq), $B::C::optimize_warn_sv ? $warn_sv : 'NULL'
));
} else {
# cop_label now in hints_hash (Change #33656)
$copsect->comment(
"$opsect_common, line, stash, file, hints, seq, warn_sv, hints_hash");
$copsect->add(
sprintf(
"%s, %u, " . "%s, %s, 0, " . "%s, %s, NULL",
$op->_save_common, $op->line,
$ITHREADS ? "(char*)".constpv( $op->stashpv ) : "Nullhv",# we can store this static
$ITHREADS ? "(char*)".constpv( $file ) : "Nullgv",
ivx($op->cop_seq),
( $B::C::optimize_warn_sv ? $warn_sv : 'NULL' )
));
}
if ( $op->label ) {
# test 29 and 15,16,21. 44,45
if ($] >= 5.015001) { # officially added with 5.15.1 aebc0cbee
$init->add(
sprintf("Perl_cop_store_label(aTHX_ &cop_list[%d], %s, %d, %d);",
$copsect->index, cstring( $op->label ),
length $op->label, 0));
} elsif ($] > 5.013004) {
$init->add(
sprintf("Perl_store_cop_label(aTHX_ &cop_list[%d], %s, %d, %d);",
$copsect->index, cstring( $op->label ),
length $op->label, 0));
} elsif (!($^O =~ /^(MSWin32|AIX)$/ or $ENV{PERL_DL_NONLAZY})) {
$init->add(
sprintf("cop_list[%d].cop_hints_hash = Perl_store_cop_label(aTHX_ NULL, %s);",
$copsect->index, cstring( $op->label )));
}
}
}
elsif ($PERL510) {
$copsect->comment("$opsect_common, line, label, stash, file, hints, seq, warnings, hints_hash");
$copsect->add(sprintf("%s, %u, %s, " . "%s, %s, 0, " . "%s, %s, NULL",
$op->_save_common, $op->line, 'NULL',
$ITHREADS ? "(char*)".constpv( $op->stashpv ) : "NULL", # we can store this static
$ITHREADS ? "(char*)".constpv( $file ) : "NULL",
ivx($op->cop_seq),
( $B::C::optimize_warn_sv ? $warn_sv : 'NULL' )));
if ($op->label) {
$init->add(sprintf( "CopLABEL_set(&cop_list[%d], CopLABEL_alloc(%s));",
$copsect->index, cstring( $op->label ) ));
}
}
else {
# 5.8 misses cop_io
$copsect->comment("$opsect_common, label, stash, file, seq, arybase, line, warn_sv, io");
$copsect->add(
sprintf(
"%s, %s, %s, %s, %s, %d, %u, %s %s",
$op->_save_common, cstring( $op->label ),
$ITHREADS ? "(char*)".constpv( $op->stashpv ) : "NULL", # we can store this static
$ITHREADS ? "(char*)".constpv( $file ) : "NULL",
ivx($op->cop_seq), $op->arybase,
$op->line, ( $B::C::optimize_warn_sv ? $warn_sv : 'NULL' ),
( $PERL56 ? "" : ", 0" )
)
);
}
$copsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $copsect->index;
$init->add( sprintf( "cop_list[$ix].op_ppaddr = %s;", $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$init->add( sprintf( "cop_list[$ix].cop_warnings = %s;", $warn_sv ) )
unless $B::C::optimize_warn_sv;
push @static_free, "cop_list[$ix]" if $ITHREADS;
$init->add(
sprintf( "CopFILE_set(&cop_list[$ix], %s);", constpv( $file ) ),
) if !$optimize_cop and !$ITHREADS;
$init->add(
sprintf( "CopSTASHPV_set(&cop_list[$ix], %s);", constpv( $op->stashpv ) )
) if !$ITHREADS;
# our root: store all packages from this file
if (!$mainfile) {
$mainfile = $op->file if $op->stashpv eq 'main';
} else {
mark_package($op->stashpv) if $mainfile eq $op->file and $op->stashpv ne 'main';
}
savesym( $op, "(OP*)&cop_list[$ix]" );
}
sub B::PMOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
# 5.8.5-thr crashes here (7) at pushre
if ($] < 5.008008 and $ITHREADS and $$op < 256) { # B bug. split->first->pmreplroot = 0x1
die "Internal B::walkoptree error: invalid PMOP for pushre\n";
return;
}
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. multi not.
$replrootfield = sprintf( "s\\_%x", $$replroot ) if ref $replroot;
if ( $ITHREADS && $op->name eq "pushre" ) {
warn "PMOP::save saving a pp_pushre as int ${replroot}\n" if $debug{gv};
$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" ) {
warn "PMOP::save saving a pp_pushre with GV $gvsym\n" if $debug{gv};
$gvsym = $replroot->save;
$replrootfield = 0;
}
else {
$replstartfield = saveoptree( "*ignore*", $replroot, $replstart );
}
}
my $pmop_pmoffset = $ITHREADS # for >5.10thr (regex_padav) start with 1
? ($] > 5.010 ? $pmopsect->index + 2 : $op->pmoffset)
: 0; # NULL op_pmregexp pointer
# pmnext handling is broken in perl itself, we 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
if ($PERL510) {
$pmopsect->comment(
"$opsect_common, first, last, pmoffset/pmregexp, pmflags, pmreplroot, pmreplstart"
);
$pmopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x, %u, 0x%x, {%s}, {%s}",
$op->_save_common, ${ $op->first },
${ $op->last }, $pmop_pmoffset,
$op->pmflags, $replrootfield,
$replstartfield
)
);
}
elsif ($PERL56) {
# pmdynflags does not exist as B method. It is only used for PMdf_UTF8 dynamically,
# if static we set this already in pmflags.
$pmopsect->comment(
"$opsect_common, first, last, pmreplroot, pmreplstart, pmnext, pmregexp, pmflags, pmpermflags, pmdynflags"
);
$pmopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x, %s, %s, 0, 0, 0x%x, 0x%x",
$op->_save_common,
${ $op->first }, ${ $op->last },
$replrootfield, $replstartfield,
$op->pmflags, $op->pmpermflags, 0 # XXX original 5.6 B::C misses pmdynflags
)
);
} else { # perl5.8.x
$pmopsect->comment(
"$opsect_common, first, last, pmreplroot, pmreplstart, pmoffset/pmregexp, pmflags, pmpermflags, pmdynflags, pmstash"
);
$pmopsect->add(
sprintf(
"%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x, %s",
$op->_save_common, ${ $op->first },
${ $op->last }, $replrootfield,
$replstartfield, $pmop_pmoffset,
$op->pmflags, $op->pmpermflags,
$op->pmdynflags, $ITHREADS ? cstring($op->pmstashpv) : "0"
)
);
if (!$ITHREADS and $op->pmstash) {
my $stash = $op->pmstash->save;
$init->add( sprintf( "pmop_list[%d].op_pmstash = %s;", $pmopsect->index, $stash ) );
}
}
$pmopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $pm = sprintf( "pmop_list[%d]", $pmopsect->index );
$init->add( sprintf( "$pm.op_ppaddr = %s;", $ppaddr ) )
unless $B::C::optimize_ppaddr;
my $re = $op->precomp; #out of memory: Module::Pluggable, Carp::Clan - threaded
if ( defined($re) ) {
$Regexp{$$op} = $op;
if ($PERL510) {
# TODO minor optim: fix savere( $re ) to avoid newSVpvn;
my $resym = cstring($re);
my $relen = length($re);
my $pmflags = $op->pmflags;
# Since 5.13.10 with PMf_FOLD (i) we need to swash_init("utf8::Cased").
if ($] >= 5.013009 and $pmflags & 4) {
# Note: in CORE utf8::SWASHNEW is demand-loaded from utf8 with Perl_load_module()
require "utf8_heavy.pl"; # bypass AUTOLOAD
svref_2object( \&{"utf8\::SWASHNEW"} )->save; # for swash_init(), defined in lib/utf8_heavy.pl
}
if ($] >= 5.011 and $ITHREADS) {
my $pad_len = regex_padav->FILL; # already allocated
if (($pmopsect->index + 1) > $pad_len) {
$init->add("av_push(PL_regex_padav, &PL_sv_undef);",
"$pm.op_pmoffset = av_len(PL_regex_padav);",
"PL_regex_pad = AvARRAY(PL_regex_padav);"
);
}
}
$init->add( # XXX Modification of a read-only value attempted. use DateTime - threaded
"PM_SETRE(&$pm, CALLREGCOMP(newSVpvn($resym, $relen), ".sprintf("0x%x));", $pmflags),
sprintf("RX_EXTFLAGS(PM_GETRE(&$pm)) = 0x%x;", $op->reflags )
);
}
elsif ($PERL56) {
my ( $resym, $relen ) = savere( $re, 0 );
$init->add(
"$pm.op_pmregexp = pregcomp((char*)$resym, (char*)$resym + $relen, &$pm);"
);
}
else { # 5.8
my ( $resym, $relen ) = savere( $re, 0 );
$init->add(
"PM_SETRE(&$pm, CALLREGCOMP(aTHX_ (char*)$resym, (char*)$resym + $relen, &$pm));"
);
}
}
if ( $gvsym ) {
if ($PERL510) {
# XXX need that for subst
$init->add("$pm.op_pmreplrootu.op_pmreplroot = (OP*)$gvsym;");
} else {
$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
@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE)
unless @specialsv_name; # 5.6.2 Exporter quirks
my $sym = $specialsv_name[$$sv];
if ( !defined($sym) ) {
warn "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;
# debug
if ( $$sv == 0 ) {
warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n" if $verbose;
return savesym( $sv, "(void*)Nullsv /* XXX */" );
}
my $i = $svsect->index + 1;
warn "Saving SVt_NULL sv_list[$i]\n" if $debug{sv};
$svsect->add( sprintf( "0, %lu, 0x%x".($PERL510?', {(char*)ptr_undef}':''), $sv->REFCNT, $sv->FLAGS ) );
#$svsect->debug( $sv->flagspv ) if $debug{flags}; # XXX where is this possible?
if ($debug{flags} and $]>5.009 and $DEBUGGING) { # add index to sv_debug_file to easily find the Nullsv
# $svsect->debug( "ix added to sv_debug_file" );
$init->add(sprintf(qq(sv_list[%d].sv_debug_file = savepv("NULL sv_list[%d] 0x%x");),
$svsect->index, $svsect->index, $sv->FLAGS));
}
savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
sub B::UV::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
if ($PERL514) {
$xpvuvsect->add( sprintf( "Nullhv, {0}, 0, 0, {%luU}", $sv->UVX ) );
} elsif ($PERL510) {
$xpvuvsect->add( sprintf( "{0}, 0, 0, {%luU}", $sv->UVX ) );
} else {
$xpvuvsect->add( sprintf( "0, 0, 0, %luU", $sv->UVX ) );
}
$svsect->add(
sprintf(
"&xpvuv_list[%d], %lu, 0x%x".($PERL510?', {(char*)ptr_undef}':''),
$xpvuvsect->index, $sv->REFCNT, $sv->FLAGS
)
);
$svsect->debug( $sv->flagspv ) if $debug{flags};
warn sprintf( "Saving IV(UV) 0x%x to xpvuv_list[%d], sv_list[%d], called from %s:%s\n",
$sv->UVX, $xpvuvsect->index, $svsect->index, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
if $debug{sv};
savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
sub B::IV::save {
my ($sv, $fullname) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
# Since 5.11 the RV is no special SV object anymore, just a IV (test 16)
my $svflags = $sv->FLAGS;
if ($PERL512 and $svflags & SVf_ROK) {
return $sv->B::RV::save($fullname);
}
if ($svflags & SVf_IVisUV) {
return $sv->B::UV::save;
}
my $i = $svsect->index + 1;
if ($svflags & 0xff and !($svflags & (SVf_IOK|SVp_IOK))) { # Not nullified
unless (($PERL510 and $svflags & 0x00010000) # PADSTALE - out of scope lexical is !IOK
or (!$PERL510 and $svflags & 0x00000100) # PADBUSY
or ($] > 5.015002 and $svflags & 0x60002)) { # 5.15.3 changed PAD bits
warn sprintf("Internal warning: IV !IOK $fullname sv_list[$i] 0x%x\n",$svflags);
}
}
if ($PERL514) {
$xpvivsect->add( sprintf( "Nullhv, {0}, 0, 0, {%s}", ivx($sv->IVX) ) );
} elsif ($PERL510) {
$xpvivsect->add( sprintf( "{0}, 0, 0, {%s}", ivx($sv->IVX) ) );
} else {
$xpvivsect->add( sprintf( "0, 0, 0, %s", ivx($sv->IVX) ) );
}
$svsect->add(
sprintf(
"&xpviv_list[%d], %lu, 0x%x".($PERL510?', {(char*)ptr_undef}':''),
$xpvivsect->index, $sv->REFCNT, $svflags
)
);
$svsect->debug( $sv->flagspv ) if $debug{flags};
warn sprintf( "Saving IV 0x%x to xpviv_list[%d], sv_list[%d], called from %s:%s\n",
$sv->IVX, $xpvivsect->index, $svsect->index, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
if $debug{sv};
savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
sub B::NV::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
my $nv = nvx($sv->NV);
$nv .= '.00' if $nv =~ /^-?\d+$/;
# IVX is invalid in B.xs and unused
my $iv = $sv->FLAGS & SVf_IOK ? $sv->IVX : 0;
if ($PERL514) {
$xpvnvsect->comment('STASH, MAGIC, cur, len, IVX, NVX');
$xpvnvsect->add( sprintf( "Nullhv, {0}, 0, 0, {%ld}, {%s}", $iv, $nv ) );
} elsif ($PERL510) { # not fixed by NV isa IV >= 5.8
$xpvnvsect->comment('NVX, cur, len, IVX');
$xpvnvsect->add( sprintf( "{%s}, 0, 0, {%ld}", $nv, $iv ) );
}
else {
$xpvnvsect->comment('PVX, cur, len, IVX, NVX');
$xpvnvsect->add( sprintf( "0, 0, 0, %ld, %s", $iv, $nv ) );
}
$svsect->add(
sprintf(
"&xpvnv_list[%d], %lu, 0x%x %s",
$xpvnvsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {0}' : ''
)
);
$svsect->debug( $sv->flagspv ) if $debug{flags};
warn sprintf( "Saving NV %s to xpvnv_list[%d], sv_list[%d]\n",
$nv, $xpvnvsect->index, $svsect->index )
if $debug{sv};
savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
sub savepvn {
my ( $dest, $pv, $sv ) = @_;
my @init;
# work with byte offsets/lengths
$pv = pack "a*", $pv;
if ( defined $max_string_len && length($pv) > $max_string_len ) {
push @init, sprintf( "New(0,%s,%u,char);", $dest, length($pv) + 1 );
my $offset = 0;
while ( length $pv ) {
my $str = substr $pv, 0, $max_string_len, '';
push @init,
sprintf( "Copy(%s,$dest+$offset,%u,char);",
cstring($str), length($str) );
$offset += length $str;
}
push @init, sprintf( "%s[%u] = '\\0';", $dest, $offset );
warn sprintf( "Copying overlong PV %s to %s\n", cstring($pv), $dest )
if $debug{sv};
}
else {
# If READONLY and FAKE use newSVpvn_share instead. (test 75)
if ($PERL510 and $sv and (($sv->FLAGS & 0x09000000) == 0x09000000)) {
warn sprintf( "Saving shared HEK %s to %s\n", cstring($pv), $dest ) if $debug{sv};
my $hek = save_hek($pv);
push @init, sprintf( "%s = HEK_KEY($hek);", $dest ) unless $hek eq 'NULL';
if ($DEBUGGING) { # we have to bypass a wrong HE->HEK assert in hv.c
push @static_free, $dest;
}
} else {
warn sprintf( "Saving PV %s to %s\n", cstring($pv), $dest ) if $debug{sv};
push @init, sprintf( "%s = savepvn(%s, %u);", $dest, cstring($pv), length($pv) );
}
}
return @init;
}
sub B::PVLV::save {
my ($sv) = @_;
my $sym = objsym($sv);
if (defined $sym) {
if ($in_endav) {
warn "in_endav: static_free without $sym\n" if $debug{av};
@static_free = grep {!/$sym/} @static_free;
}
return $sym;
}
my $pv = $sv->PV;
my $cur = length($pv);
my $shared_hek = $PERL510 ? (($sv->FLAGS & 0x09000000) == 0x09000000) : undef;
my ( $pvsym, $len ) = ($B::C::const_strings and $sv->FLAGS & SVf_READONLY and !$shared_hek)
? constpv($pv) : savepv($pv);
$len = 0 if $B::C::pv_copy_on_grow or $shared_hek;
$pvsym = "(char*)$pvsym";# if $B::C::const_strings and $sv->FLAGS & SVf_READONLY;
my ( $lvtarg, $lvtarg_sym ); # XXX missing
if ($PERL514) {
$xpvlvsect->comment('STASH, MAGIC, CUR, LEN, GvNAME, xnv_u, TARGOFF, TARGLEN, TARG, TYPE');
$xpvlvsect->add(
sprintf("Nullhv, {0}, %u, %d, 0/*GvNAME later*/, %s, %u, %u, Nullsv, %s",
$cur, $len, nvx($sv->NVX),
$sv->TARGOFF, $sv->TARGLEN, cchar( $sv->TYPE ) ));
$svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x, {%s}",
$xpvlvsect->index, $sv->REFCNT, $sv->FLAGS, $pvsym));
} elsif ($PERL510) {
$xpvlvsect->comment('xnv_u, CUR, LEN, GvNAME, MAGIC, STASH, TARGOFF, TARGLEN, TARG, TYPE');
$xpvlvsect->add(
sprintf("%s, %u, %d, 0/*GvNAME later*/, 0, Nullhv, %u, %u, Nullsv, %s",
nvx($sv->NVX), $cur, $len,
$sv->TARGOFF, $sv->TARGLEN, cchar( $sv->TYPE ) ));
$svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x, {%s}",
$xpvlvsect->index, $sv->REFCNT, $sv->FLAGS, $pvsym));
} else {
$xpvlvsect->comment('PVX, CUR, LEN, IVX, NVX, TARGOFF, TARGLEN, TARG, TYPE');
$xpvlvsect->add(
sprintf("%s, %u, %u, %s, %s, 0, 0, %u, %u, Nullsv, %s",
$pvsym, $cur, $len, ivx($sv->IVX), nvx($sv->NVX),
$sv->TARGOFF, $sv->TARGLEN, cchar( $sv->TYPE ) ));
$svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
$xpvlvsect->index, $sv->REFCNT, $sv->FLAGS));
}
$svsect->debug( $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
if ( !$B::C::pv_copy_on_grow ) {
if ($PERL510) {
$init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv ) );
}
else {
$init->add(
savepvn( sprintf( "xpvlv_list[%d].xpv_pv", $xpvlvsect->index ), $pv ) );
}
} else {
if ($shared_hek) { # avoid free of static hek's
$free->add(" SvFAKE_off(&$s);");
} else {
push @static_free, $s if $len and !$in_endav;
}
}
$sv->save_magic;
savesym( $sv, "&".$s );
}
sub B::PVIV::save {
my ($sv) = @_;
my $sym = objsym($sv);
if (defined $sym) {
if ($in_endav) {
warn "in_endav: static_free without $sym\n" if $debug{av};
@static_free = grep {!/$sym/} @static_free;
}
return $sym;
}
my $shared_hek = $PERL510 ? (($sv->FLAGS & 0x09000000) == 0x09000000) : undef;
local $B::C::pv_copy_on_grow;
$B::C::pv_copy_on_grow = 1 if $B::C::const_strings and $sv->FLAGS & SVf_READONLY;
my ( $savesym, $cur, $len, $pv ) = save_pv_or_rv($sv);
$savesym = "(char*)$savesym";
$len = 0 if $B::C::pv_copy_on_grow or $shared_hek;
if ($PERL514) {
$xpvivsect->comment('STASH, MAGIC, cur, len, IVX');
$xpvivsect->add( sprintf( "Nullhv, {0}, %u, %u, {%s}", $cur, $len, ivx($sv->IVX) ) ); # IVTYPE long
} elsif ($PERL510) {
$xpvivsect->comment('xnv_u, cur, len, IVX');
$xpvivsect->add( sprintf( "{0}, %u, %u, {%s}", $cur, $len, ivx($sv->IVX) ) ); # IVTYPE long
} else {
#$iv = 0 if $sv->FLAGS & (SVf_IOK|SVp_IOK);
$xpvivsect->comment('PVX, cur, len, IVX');
$xpvivsect->add( sprintf( "%s, %u, %u, %s",
$savesym, $cur, $len, ivx($sv->IVX) ) ); # IVTYPE long
}
$svsect->add(
sprintf("&xpviv_list[%d], %u, 0x%x %s",
$xpvivsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {(char*)ptr_undef}' : '' ) );
$svsect->debug( $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
if ( defined($pv) ) {
if ( !$B::C::pv_copy_on_grow ) {
if ($PERL510) {
$init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv ) );
} else {
$init->add
(savepvn( sprintf( "xpviv_list[%d].xpv_pv", $xpvivsect->index ), $pv ) );
}
} else {
if ($shared_hek) { # avoid free of static hek's
$free->add(" SvFAKE_off(&$s);");
} else {
push @static_free, $s if $len and !$in_endav;
}
}
}
savesym( $sv, "&".$s );
}
sub B::PVNV::save {
my ($sv) = @_;
my $sym = objsym($sv);
if (defined $sym) {
if ($in_endav) {
warn "in_endav: static_free without $sym\n" if $debug{av};
@static_free = grep {!/$sym/} @static_free;
}
return $sym;
}
my $shared_hek = $PERL510 ? (($sv->FLAGS & 0x09000000) == 0x09000000) : undef;
local $B::C::pv_copy_on_grow;
$B::C::pv_copy_on_grow = 1 if $B::C::const_strings
and !$shared_hek
and $sv->FLAGS & SVf_READONLY;
my ( $savesym, $cur, $len, $pv ) = save_pv_or_rv($sv);
$savesym = substr($savesym,0,1) ne "(" ? "(char*)".$savesym : $savesym;
$len = 0 if $B::C::pv_copy_on_grow or $shared_hek;
my $nvx;
my $ivx = $sv->IVX; # here must be IVX!
if ($sv->FLAGS & (SVf_NOK|SVp_NOK)) {
# it could be a double, or it could be 2 ints - union xpad_cop_seq
$nvx = nvx($sv->NV);
} else {
if ($PERL510 and $C99) {
$nvx = sprintf(".xpad_cop_seq.xlow = %s, .xpad_cop_seq.xhigh = %s",
ivx($sv->COP_SEQ_RANGE_LOW), ivx($sv->COP_SEQ_RANGE_HIGH),
);
} else {
$nvx = nvx($sv->NVX);
}
}
if ($PERL510) {
# For some time the stringification works of NVX double to two ints worked ok.
if ($PERL514) {
$xpvnvsect->comment('STASH, MAGIC, cur, len, IVX, NVX');
$xpvnvsect->add(sprintf( "Nullhv, {0}, %u, %u, {%ld}, {%s}", $cur, $len, $ivx, $nvx) );
} else {
$xpvnvsect->comment('NVX, cur, len, IVX');
$xpvnvsect->add(sprintf( "{%s}, %u, %u, {%ld}", $nvx, $cur, $len, $ivx ) );
}
unless ($C99 or $sv->FLAGS & (SVf_NOK|SVp_NOK)) {
warn "NV => run-time union xpad_cop_seq init\n" if $debug{sv};
$init->add(sprintf("xpvnv_list[%d].xnv_u.xpad_cop_seq.xlow = %s;",
$xpvnvsect->index, ivx($sv->COP_SEQ_RANGE_LOW)),
# pad.c: PAD_MAX = I32_MAX (4294967295)
# U suffix <= "warning: this decimal constant is unsigned only in ISO C90"
sprintf("xpvnv_list[%d].xnv_u.xpad_cop_seq.xhigh = %s;",
$xpvnvsect->index, ivx($sv->COP_SEQ_RANGE_HIGH)));
}
}
else {
$xpvnvsect->comment('PVX, cur, len, IVX, NVX');
if ($savesym =~ /^\(char\*\)get_cv\("/) { #" Moose 5.8.9d Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef
$xpvnvsect->add(sprintf( "%s, %u, %u, %d, %s", 'NULL', $cur, $len, $ivx, $nvx ) );
$init->add(sprintf("xpvnv_list[%d].xpv_pv = %s;", $xpvnvsect->index, $savesym));
} else {
$xpvnvsect->add(sprintf( "%s, %u, %u, %d, %s", $savesym, $cur, $len, $ivx, $nvx ) );
}
}
$svsect->add(
sprintf("&xpvnv_list[%d], %lu, 0x%x %s",
$xpvnvsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {(char*)ptr_undef}' : '' ) );
$svsect->debug( $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
if ( defined($pv) ) {
if ( !$B::C::pv_copy_on_grow or $] < 5.010) {
if ($PERL510) {
$init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv ) );
}
else {
$init->add(
savepvn( sprintf( "xpvnv_list[%d].xpv_pv", $xpvnvsect->index ), $pv ) );
}
} else {
if ($shared_hek) { # avoid free of static hek's
$free->add(" SvFAKE_off(&$s);");
} else {
push @static_free, $s if $len and !$in_endav;
}
}
}
savesym( $sv, "&".$s );
}
sub B::BM::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if !$PERL510 and defined $sym;
$sv = bless $sv, "B::BM" if $PERL510;
my $pv = pack "a*", ( $sv->PV . "\0" . $sv->TABLE );
my $len = length($sv->PV);
if ($PERL510) {
warn "Saving FBM for GV $sym\n" if $debug{gv};
$init->add( sprintf( "$sym = (GV*)newSV_type(SVt_PVGV);" ),
sprintf( "SvFLAGS($sym) = 0x%x;", $sv->FLAGS),
sprintf( "SvREFCNT($sym) = %u;", $sv->REFCNT + 1 ),
sprintf( "SvPVX($sym) = %s;", cstring($pv) ),
sprintf( "SvLEN_set($sym, %d);", $len ),
sprintf( "BmRARE($sym) = %d;", $sv->RARE ),
sprintf( "BmPREVIOUS($sym) = %d;", $sv->PREVIOUS ),
sprintf( "BmUSEFUL($sym) = %d;", $sv->USEFUL )
);
} else {
local $B::C::pv_copy_on_grow;
$B::C::pv_copy_on_grow = 1
if $B::C::const_strings and $sv->FLAGS & SVf_READONLY and $] != 5.008009;
$xpvbmsect->comment('pvx,cur,len(+258),IVX,NVX,MAGIC,STASH,USEFUL,PREVIOUS,RARE');
$xpvbmsect->add(
sprintf("%s, %u, %u, %s, %s, 0, 0, %d, %u, 0x%x",
defined($pv) && $B::C::pv_copy_on_grow ? cstring($pv) : "(char*)ptr_undef",
$len, $len + 258, ivx($sv->IVX), nvx($sv->NVX),
$sv->USEFUL, $sv->PREVIOUS, $sv->RARE
));
$svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
$xpvbmsect->index, $sv->REFCNT, $sv->FLAGS));
$svsect->debug( $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
if (!$B::C::pv_copy_on_grow) {
$init->add(savepvn( sprintf( "xpvbm_list[%d].xpv_pv", $xpvbmsect->index ), $pv ) );
} else {
push @static_free, $s if defined($pv) and !$in_endav;
}
}
# Restore possible additional magic. fbm_compile adds just 'B'.
$sv->save_magic;
if ($PERL510) {
return $sym;
} else {
if ($] == 5.008009) { # XXX 5.8.9 needs more. TODO test 5.8.0 - 5.8.7
$init->add( sprintf( "fbm_compile(&sv_list[%d], 0);", $svsect->index ) );
}
# cur+len was broken on all B::C versions
#$init->add(sprintf( "xpvbm_list[%d].xpv_cur = %u;", $xpvbmsect->index, $len ) );
return savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
}
sub B::PV::save {
my ($sv, $fullname) = @_;
my $sym = objsym($sv);
if (defined $sym) {
if ($in_endav) {
warn "in_endav: static_free without $sym\n" if $debug{av};
@static_free = grep {!/$sym/} @static_free;
}
return $sym;
}
my $flags = $sv->FLAGS;
my $shared_hek = $PERL510 ? (($flags & 0x09000000) == 0x09000000) : undef;
local $B::C::pv_copy_on_grow;
$B::C::pv_copy_on_grow = 1 if $B::C::const_strings
and !$shared_hek
and $flags & SVf_READONLY;
# XSLoader reuses this SV, so it must be dynamic
$B::C::pv_copy_on_grow = 0 if !($flags & SVf_ROK) and $sv->PV and $sv->PV =~ /::bootstrap$/;
my ( $savesym, $cur, $len, $pv ) = save_pv_or_rv($sv, $fullname);
my $refcnt = $sv->REFCNT;
# $refcnt-- if $B::C::pv_copy_on_grow;
# static pv, do not destruct. test 13 with pv0 "3".
$len = 0 if $B::C::pv_copy_on_grow or $shared_hek;
if ($PERL510) {
if ($B::C::const_strings and !$shared_hek and $flags & SVf_READONLY and !$len) {
#=> constpv: turnoff SVf_FAKE
$flags &= ~0x01000000;
}
$xpvsect->add( sprintf( "%s{0}, %u, %u", $PERL514 ? "Nullhv, " : "", $cur, $len ) );
$svsect->add( sprintf( "&xpv_list[%d], %lu, 0x%x, {%s}",
$xpvsect->index, $refcnt, $flags,
defined($pv) && $B::C::pv_copy_on_grow ? "(char*)$savesym" : "(char*)ptr_undef"));
if ( defined($pv) and !$B::C::pv_copy_on_grow ) {
$init->add( savepvn( sprintf( "sv_list[%d].sv_u.svu_pv", $svsect->index ), $pv, $sv ) );
}
if ($debug{flags} and $DEBUGGING) { # add sv_debug_file
$init->add(sprintf(qq(sv_list[%d].sv_debug_file = savepv(%s" sv_list[%d] 0x%x");),
$svsect->index, cstring($pv) eq '0' ? '"NULL"' : cstring($pv),
$svsect->index, $sv->FLAGS));
}
}
else {
$xpvsect->add( sprintf( "%s, %u, %u", "(char*)$savesym", $cur, $len ) );
$svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
$xpvsect->index, $refcnt, $flags));
if ( defined($pv) and !$B::C::pv_copy_on_grow ) {
$init->add( savepvn( sprintf( "xpv_list[%d].xpv_pv", $xpvsect->index ), $pv ) );
}
}
my $s = "sv_list[".$svsect->index."]";
if ( $B::C::pv_copy_on_grow ) {
if ($shared_hek) { # avoid free of static hek's
$free->add(" SvFAKE_off(&$s);");
} else {
push @static_free, $s if defined($pv) and !$in_endav;
}
}
$svsect->debug( $sv->flagspv ) if $debug{flags};
savesym( $sv, "&".$s );
}
sub lexwarnsym {
my $iv = shift;
if ($lexwarnsym{$iv}) {
return $lexwarnsym{$iv};
} else {
warn "internal warning: lexwarn value $iv looks wrong\n" if $iv > 66000;
my $sym = sprintf( "iv%d", $pv_index++ );
$decl->add( sprintf( "Static const STRLEN %s = %d;", $sym, $iv ) );
$lexwarnsym{$iv} = $sym;
return $sym;
}
}
# pre vs. post 5.8.9/5.9.4 logic for lexical warnings
@B::LEXWARN::ISA = qw(B::PV B::IV);
sub B::LEXWARN::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
my $iv = $] >= 5.008009 ? length($sv->PVX) : $sv->IV;
if ($] < 5.009004 and $] >= 5.009) { $iv = length($sv->PVX); }
my $ivsym = lexwarnsym($iv); # look for shared const int's
return savesym($sv, $ivsym);
}
# post 5.11: When called from save_rv not from PMOP::save precomp
sub B::REGEXP::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
my $pv = $sv->PV;
my $len = length(pack("a*", $pv));
# Unfortunately this XPV is needed temp. Later replaced by struct regexp.
$xpvsect->add( sprintf( "%s{0}, %u, %u", $PERL514 ? "Nullhv, " : "", $len, 0 ) );
$svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x, {%s}",
$xpvsect->index, $sv->REFCNT, $sv->FLAGS, cstring($pv)));
my $ix = $svsect->index;
warn "Saving RX \"".$sv->PV."\" to sv_list[$ix], called from @{[(caller(1))[3]]}, "
."@{[(caller(2))[3]]}, @{[(caller(3))[3]]}, @{[(caller(4))[3]]}\n" if $debug{rx} or $debug{sv};
if (0) {
my $pkg = $sv->SvSTASH;
if ($$pkg) {
warn sprintf("stash isa class($pkg) 0x%x\n", $$pkg) if $debug{mg} or $debug{gv};
$pkg->save;
$init->add( sprintf( "SvSTASH_set(s\\_%x, s\\_%x);", $$sv, $$pkg ) );
$init->add( sprintf( "SvREFCNT((SV*)s\\_%x) += 1;", $$pkg ) );
}
}
$init->add(# replace XVP with struct regexp. need pv and extflags
sprintf("SvANY(&sv_list[$ix]) = SvANY(CALLREGCOMP(&sv_list[$ix], 0x%x));",
$sv->EXTFLAGS));
$svsect->debug( $sv->flagspv ) if $debug{flags};
$sym = savesym( $sv, sprintf( "&sv_list[%d]", $ix ) );
$sv->save_magic;
return $sym;
}
sub B::PVMG::save {
my ($sv, $fullname) = @_;
my $sym = objsym($sv);
if (defined $sym) {
if ($in_endav) {
warn "in_endav: static_free without $sym\n" if $debug{av};
@static_free = grep {!/$sym/} @static_free;
}
return $sym;
}
# local $B::C::pv_copy_on_grow = 1 if $B::C::const_strings and $flags & SVf_READONLY;
my ( $savesym, $cur, $len, $pv ) = save_pv_or_rv($sv, $fullname);
$savesym = "(char*)$savesym";
my $shared_hek = $PERL510 ? (($sv->FLAGS & 0x09000000) == 0x09000000) : undef;
$len = 0 if $B::C::pv_copy_on_grow or $shared_hek;
#warn sprintf( "PVMG %s (0x%x) $savesym, $len, $cur, $pv\n", $sym, $$sv ) if $debug{mg};
if ($PERL510) {
if ($sv->FLAGS & SVf_ROK) { # sv => sv->RV cannot be initialized static.
$init->add(sprintf("SvRV_set(&sv_list[%d], (SV*)%s);", $svsect->index+1, substr($savesym,7)))
if $savesym ne '(char*)';
$savesym = '0';
} else {
if ( $B::C::pv_copy_on_grow ) {
# comppadnames needs &PL_sv_undef instead of 0
# But threaded PL_sv_undef => my_perl->Isv_undef, and my_perl is not available static
if (!$pv or !$savesym or $savesym eq 'NULL') {
if ($MULTI) {
$savesym = "NULL";
$init->add( sprintf( "sv_list[%d].sv_u.svu_pv = (char*)&PL_sv_undef;",
$svsect->index+1 ) );
} else {
$savesym = '(char*)&PL_sv_undef';
}
}
}
}
my ($ivx,$nvx) = (0, "0");
# since 5.11 REGEXP isa PVMG, but has no IVX and NVX methods
if ($] >= 5.011 and ref($sv) eq 'B::REGEXP') {
return B::REGEXP::save($sv);
}
else {
$ivx = ivx($sv->IVX); # XXX How to detect HEK* namehek?
$nvx = nvx($sv->NVX); # it cannot be xnv_u.xgv_stash ptr (BTW set by GvSTASH later)
}
if ($PERL514) {
$xpvmgsect->comment("STASH, MAGIC, cur, len, xiv_u, xnv_u");
$xpvmgsect->add(sprintf("Nullhv, {0}, %u, %u, {%s}, {%s}",
$cur, $len, $ivx, $nvx));
} else {
$xpvmgsect->comment("xnv_u, cur, len, xiv_u, xmg_u, xmg_stash");
$xpvmgsect->add(sprintf("{%s}, %u, %u, {%s}, {0}, Nullhv",
$nvx, $cur, $len, $ivx));
}
$svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x, {%s}",
$xpvmgsect->index, $sv->REFCNT, $sv->FLAGS, $savesym));
my $s = "sv_list[".$svsect->index."]";
if ($shared_hek) { # avoid free of static hek's
$free->add(" SvFAKE_off(&$s);");
} else {
push @static_free, $s if $len and $B::C::pv_copy_on_grow and !$in_endav;
}
}
else {
# cannot initialize this pointer static
if ($savesym =~ /&(PL|sv)/) { # (char*)&PL_sv_undef | (char*)&sv_list[%d]
$xpvmgsect->add(sprintf("%d, %u, %u, %s, %s, 0, 0",
0, $cur, $len, ivx($sv->IVX), nvx($sv->NVX)));
$init->add( sprintf( "xpvmg_list[%d].xpv_pv = $savesym;",
$xpvmgsect->index ) );
} else {
$xpvmgsect->add(sprintf("%s, %u, %u, %s, %s, 0, 0",
$savesym, $cur, $len, ivx($sv->IVX), nvx($sv->NVX)));
push @static_free, sprintf("sv_list[%d]", $svsect->index+1)
if $len and $B::C::pv_copy_on_grow and !$in_endav;
}
$svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
$xpvmgsect->index, $sv->REFCNT, $sv->FLAGS));
}
$svsect->debug( $sv->flagspv ) if $debug{flags};
if ( !$B::C::pv_copy_on_grow ) {
# comppadnames need &PL_sv_undef instead of 0
if ($PERL510) {
if ($savesym) {
if (!$pv or $savesym eq 'NULL') {
$init->add( sprintf( "sv_list[%d].sv_u.svu_pv = (char*)&PL_sv_undef;",
$svsect->index ) );
} else {
$init->add( savepvn( sprintf( "sv_list[%d].sv_u.svu_pv",
$svsect->index ), $pv, $sv ) );
}
}
} else {
if (!$pv or !$savesym or $savesym eq 'NULL') {
$init->add( sprintf( "xpvmg_list[%d].xpv_pv = (char*)&PL_sv_undef;",
$xpvmgsect->index ) );
} else {
$init->add(savepvn( sprintf( "xpvmg_list[%d].xpv_pv", $xpvmgsect->index ),
$pv ) );
}
}
}
$sym = savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
$sv->save_magic($fullname);
return $sym;
}
# mark threads::shared to be xs-loaded
sub mark_threads {
if ( $threads::VERSION ) {
my $stash = 'threads';
mark_package($stash);
$use_xsloader = 1;
$xsub{$stash} = 'Dynamic-' . $INC{'threads.pm'};
warn "mark threads for 'P' magic\n" if $debug{mg};
} else {
warn "ignore to mark threads for 'P' magic\n" if $debug{mg};
}
if ( $INC{'threads/shared.pm'} ) {
my $stash = 'threads::shared';
mark_package($stash);
# XXX why is this needed? threads::shared should be initialized automatically
$use_xsloader = 1; # ensure threads::shared is initialized
$xsub{$stash} = 'Dynamic-' . $INC{'threads/shared.pm'};
warn "mark threads::shared for 'P' magic\n" if $debug{mg};
} else {
warn "ignore to mark threads::shared for 'P' magic\n" if $debug{mg};
}
}
sub B::PVMG::save_magic {
my ($sv, $fullname) = @_;
my $sv_flags = $sv->FLAGS;
if ($debug{mg}) {
my $flagspv = "";
$fullname = '' unless $fullname;
$flagspv = $sv->flagspv if $debug{flags} and $PERL510 and !$sv->MAGICAL;
warn sprintf( "saving magic for %s $fullname (0x%x) flags=0x%x%s - called from %s:%s\n",
class($sv), $$sv, $sv_flags, $debug{flags} ? "(".$flagspv.")" : "",
@{[(caller(1))[3]]}, @{[(caller(1))[2]]});
}
my $pkg = $sv->SvSTASH;
if ($$pkg) {
warn sprintf("stash isa class(\"%s\") 0x%x\n", $pkg->NAME, $$pkg)
if $debug{mg} or $debug{gv};
$pkg->save($fullname);
no strict 'refs';
warn sprintf( "xmg_stash = \"%s\" (0x%x)\n", $pkg->NAME, $$pkg )
if $debug{mg} or $debug{gv};
# Q: Who is initializing our stash from XS? ->save is missing that.
# A: We only need to init it when we need a CV
$init->add( sprintf( "SvSTASH_set(s\\_%x, s\\_%x);", $$sv, $$pkg ) );
$init->add( sprintf( "SvREFCNT((SV*)s\\_%x) += 1;", $$pkg ) );
push_package($pkg->NAME, 'soft');
}
# Protect our SVs against non-magic or SvPAD_OUR. Fixes tests 16 and 14 + 23
if ($PERL510 and !$sv->MAGICAL) {
warn sprintf("Skipping non-magical PVMG type=%d, flags=0x%x%s\n",
$sv_flags && 0xff, $sv_flags, $debug{flags} ? "(".$sv->flagspv.")" : "")
if $debug{mg};
return '';
}
my @mgchain = $sv->MAGIC;
my ( $mg, $type, $obj, $ptr, $len, $ptrsv );
my $magic = '';
foreach $mg (@mgchain) {
$type = $mg->TYPE;
$ptr = $mg->PTR;
$len = $mg->LENGTH;
$magic .= $type;
if ( $debug{mg} ) {
warn sprintf( "%s magic\n", cchar($type) );
#eval {
# 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 =~ /^[rDn]$/ ) { # r - test 23 / D - Getopt::Long
# 5.10: Can't call method "save" on unblessed reference
#warn "Save MG ". $obj . "\n" if $PERL510;
# 5.11 'P' fix in B::IV::save, IV => RV
$obj = $mg->OBJ;
$obj->save($fullname)
unless $PERL510 and ref $obj eq 'SCALAR';
mark_threads if $type eq 'P';
}
if ( $len == HEf_SVKEY ) {
# The pointer is an SV* ('s' sigelem e.g.)
# XXX On 5.6 ptr might be a SCALAR ref to the PV, which was fixed later
if (ref($ptr) eq 'SCALAR') {
$ptrsv = svref_2object($ptr)->save($fullname);
} else {
$ptrsv = $ptr->save($fullname);
}
warn "MG->PTR is an SV*\n" if $debug{mg};
$init->add(
sprintf(
"sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, (char *)%s, %d);",
$$sv, $$obj, cchar($type), $ptrsv, $len
)
);
}
# coverage $Template::Stash::PRIVATE
elsif ( $type eq 'r' ) { # qr magic, for 5.6 done in C.xs. test 20
my $rx = $PERL56 ? ${$mg->OBJ} : $mg->REGEX;
# stored by some PMOP *pm = cLOGOP->op_other (pp_ctl.c) in C.xs
my $pmop = $Regexp{$rx};
if (!$pmop) {
warn "C.xs Warning: PMOP missing for QR\n";
} else {
my ($resym, $relen);
if ($PERL56) {
($resym, $relen) = savere( $pmop->precomp ); # 5.6 has precomp only in PMOP
($resym, $relen) = savere( $mg->precomp ) unless $relen;
} else {
($resym, $relen) = savere( $mg->precomp );
}
my $pmsym = $pmop->save($fullname);
if ($PERL510) {
push @static_free, $resym;
$init->add( split /\n/,
sprintf <<CODE1, $pmop->pmflags, $$sv, cchar($type), cstring($ptr), $len );
{
REGEXP* rx = CALLREGCOMP((SV* const)$resym, %d);
sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
}
CODE1
}
else {
$pmsym =~ s/\(OP\*\)\&pmop_list/&pmop_list/;
$init->add( split /\n/,
sprintf <<CODE2, $$sv, cchar($type), cstring($ptr), $len );
{
REGEXP* rx = pregcomp((char*)$resym,(char*)($resym + $relen), (PMOP*)$pmsym);
sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
}
CODE2
}
}
}
elsif ( $type eq 'D' ) { # XXX regdata AV - coverage?
if ($obj = $mg->OBJ) {
# see Perl_mg_copy() in mg.c
$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
$$sv, $$sv, "'D'", cstring($ptr), $len ));
}
}
elsif ( $type eq 'n' ) { # shared_scalar is from XS dist/threads-shared
# XXX check if threads is loaded also? otherwise it is only stubbed
mark_threads;
$init->add(sprintf("sv_magic((SV*)s\\_%x, Nullsv, %s, %s, %d);",
$$sv, "'n'", cstring($ptr), $len ));
}
elsif ( $type eq 'c' ) {
$init->add(sprintf(
"/* AMT overload table for the stash s\\_%x is generated dynamically */",
$$sv ));
}
else {
$init->add(sprintf(
"sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
$$sv, $$obj, cchar($type), cstring($ptr), $len
)
)
}
}
$magic;
}
# Since 5.11 also called by IV::save (SV -> IV)
sub B::RV::save {
my ($sv, $fullname) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
warn sprintf( "Saving RV %s (0x%x) - called from %s:%s\n",
class($sv), $$sv, @{[(caller(1))[3]]}, @{[(caller(1))[2]]})
if $debug{sv};
my $rv = save_rv($sv, $fullname);
return '0' unless $rv;
if ($PERL510) {
# 5.10 has no struct xrv anymore, just sv_u.svu_rv. static or dynamic?
# initializer element is computable at load time
$svsect->add( sprintf( "ptr_undef, %lu, 0x%x, {0}", $sv->REFCNT, $sv->FLAGS ) );
$svsect->debug( $sv->flagspv ) if $debug{flags};
$init->add( sprintf( "sv_list[%d].sv_u.svu_rv = (SV*)%s;", $svsect->index, $rv ) );
return savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
else {
# GVs need to be handled at runtime
if ( ref( $sv->RV ) eq 'B::GV' or $rv =~ /^gv_list/) {
$xrvsect->add("(SV*)Nullsv");
$init->add(
sprintf( "xrv_list[%d].xrv_rv = (SV*)%s;", $xrvsect->index, $rv ) );
}
# and stashes, too
elsif ( $sv->RV->isa('B::HV') && $sv->RV->NAME ) {
$xrvsect->add("(SV*)Nullsv");
$init->add(
sprintf( "xrv_list[%d].xrv_rv = (SV*)%s;", $xrvsect->index, $rv ) );
}
# one more: bootstrapped XS CVs (test Class::MOP, no simple testcase yet)
elsif ( $rv =~ /get_cv\(/ ) {
$xrvsect->add("(SV*)Nullsv");
$init->add(
sprintf( "xrv_list[%d].xrv_rv = (SV*)%s;", $xrvsect->index, $rv ) );
}
else {
#$xrvsect->add($rv); # not static initializable (e.g. cv160 for ExtUtils::Install)
$xrvsect->add("(SV*)Nullsv");
$init->add(
sprintf( "xrv_list[%d].xrv_rv = (SV*)%s;", $xrvsect->index, $rv ) );
}
$svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
$xrvsect->index, $sv->REFCNT, $sv->FLAGS));
$svsect->debug( $sv->flagspv ) if $debug{flags};
return savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) );
}
}
sub get_isa ($) {
no strict 'refs';
return $PERL510 ? @{mro::get_linear_isa($_[0])} : @{ $_[0] . '::ISA' };
}
# try_isa($pkg,$name) returns the found $pkg for the method $pkg::$name
# If a method can be called (via UNIVERSAL::can) search the ISA's. No AUTOLOAD needed.
# XXX issue 64, empty @ISA if a package has no subs. in Bytecode ok
sub try_isa {
my $cvstashname = shift;
my $cvname = shift;
if (exists $isa_cache{"$cvstashname\::$cvname"}) {
#warn "cached try_isa $cvstashname\::$cvname => "
# .$isa_cache{"$cvstashname\::$cvname"}."\n" if $debug{meth};
return $isa_cache{"$cvstashname\::$cvname"};
}
# XXX theoretically a valid shortcut. In reality it fails when $cvstashname is not loaded.
# return 0 unless $cvstashname->can($cvname);
my @isa = get_isa($cvstashname);
warn sprintf( " Search %s::%s in (%s)\n",
$cvstashname, $cvname, $cvstashname, join(",",@isa))
if $debug{cv} or $debug{meth};
for (@isa) { # global @ISA or in pad
next if $_ eq $cvstashname;
# warn sprintf( "Try &%s::%s\n", $_, $cvname ) if $debug{cv};
no strict 'refs';
if (defined(&{$_ .'::'. $cvname})) {
svref_2object( \@{$cvstashname . '::ISA'} )->save("$cvstashname\::ISA");
$isa_cache{"$cvstashname\::$cvname"} = $_;
mark_package($_, 1); # force
$package_pv = $_; # locality
warn sprintf( "Found &%s::%s\n", $_, $cvname ) if $debug{meth};
return $_;
} else {
$isa_cache{"$_\::$cvname"} = 0;
if (get_isa($_)) {
my $parent = try_isa($_, $cvname);
if ($parent) {
$isa_cache{"$_\::$cvname"} = $parent;
$isa_cache{"$cvstashname\::$cvname"} = $parent;
warn sprintf( "Found &%s::%s\n", $parent, $cvname ) if $debug{meth};
warn "save \@$parent\::ISA\n" if $debug{pkg};
svref_2object( \@{$parent . '::ISA'} )->save("$parent\::ISA");
warn "save \@$_\::ISA\n" if $debug{pkg};
svref_2object( \@{$_ . '::ISA'} )->save("$_\::ISA");
return $parent;
}
}
}
}
$isa_cache{"$cvstashname\::$cvname"} = 0;
return 0; # not found
}
# If the sub or method is not found:
# 1. try @ISA, mark_package and return.
# 2. try UNIVERSAL::method
# 3. try compile-time expansion of AUTOLOAD to get the goto &sub addresses
sub try_autoload {
my ( $cvstashname, $cvname ) = @_;
no strict 'refs';
return 1 if try_isa($cvstashname, $cvname);
no strict 'refs';
if (defined(&{'UNIVERSAL::'. $cvname})) {
warn "Found UNIVERSAL::$cvname\n" if $debug{cv};
return svref_2object( \&{'UNIVERSAL::'.$cvname} );
}
my $fullname = $cvstashname . '::' . $cvname;
warn sprintf( " Search %s via %s::AUTOLOAD\n",
$fullname, $cvstashname ) if $debug{cv};
# First some exceptions, fooled by goto
if ($cvstashname eq 'Config') {
return svref_2object( \&{'Config::launcher'} );
}
if ($fullname eq 'utf8::SWASHNEW') {
# utf8_heavy was loaded so far, so defer to a demand-loading stub
my $stub = sub { require 'utf8_heavy.pl'; goto &utf8::SWASHNEW; };
return svref_2object( $stub );
}
# Handle AutoLoader classes. Any more general AUTOLOAD
# use should be handled by the class itself.
my @isa = get_isa($cvstashname);
if ( $cvstashname =~ /^POSIX|Storable|DynaLoader|Net::SSLeay|Class::MethodMaker$/
or (exists ${$cvstashname.'::'}{AUTOLOAD} and grep( $_ eq "AutoLoader", @isa ) ) )
{
# Tweaked version of AutoLoader::AUTOLOAD
my $dir = $cvstashname;
$dir =~ s(::)(/)g;
warn "require \"auto/$dir/$cvname.al\"\n" if $debug{cv};
eval { local $SIG{__DIE__}; require "auto/$dir/$cvname.al" };
unless ($@) {
warn "Forced load of \"auto/$dir/$cvname.al\"\n" if $verbose;
return svref_2object( \&$fullname )
if defined &$fullname;
}
}
# XXX Still not found, now it's getting dangerous (until 5.10 only)
# Search and call ::AUTOLOAD (=> ROOT and XSUB) (test 27, 5.8)
# Since 5.10 AUTOLOAD xsubs are already resolved
if (exists ${$cvstashname.'::'}{AUTOLOAD} and !$PERL510) {
my $auto = \&{$cvstashname.'::AUTOLOAD'};
# Tweaked version of __PACKAGE__::AUTOLOAD
$AutoLoader::AUTOLOAD = ${$cvstashname.'::AUTOLOAD'} = "$cvstashname\::$cvname";
# Prevent eval from polluting STDOUT,STDERR and our c code.
# With a debugging perl STDERR is written
local *REALSTDOUT;
local *REALSTDERR unless $DEBUGGING;
open(REALSTDOUT,">&STDOUT");
open(REALSTDERR,">&STDERR") unless $DEBUGGING;
open(STDOUT,">","/dev/null");
open(STDERR,">","/dev/null") unless $DEBUGGING;
warn "eval \&$cvstashname\::AUTOLOAD\n" if $debug{cv};
eval { &$auto };
open(STDOUT,">&REALSTDOUT");
open(STDERR,">&REALSTDERR") unless $DEBUGGING;
unless ($@) {
# we need just the empty auto GV, $cvname->ROOT and $cvname->XSUB,
# but not the whole CV optree. XXX This still fails with 5.8
my $cv = svref_2object( \&{$cvstashname.'::'.$cvname} );
return $cv;
}
}
# XXX TODO Check Selfloader (test 31?)
svref_2object( \*{$cvstashname.'::CLONE'} )->save
if $cvstashname and exists ${$cvstashname.'::'}{CLONE};
svref_2object( \*{$cvstashname.'::AUTOLOAD'} )->save
if $cvstashname and exists ${"$cvstashname\::"}{AUTOLOAD};
}
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 ) if $debug{cv};
return $sym;
}
my $gv = $cv->GV;
my ( $cvname, $cvstashname, $fullname );
if ($$gv) {
$cvstashname = $gv->STASH->NAME;
$cvname = $gv->NAME;
$fullname = $cvstashname.'::'.$cvname;
warn sprintf( "CV [%d] as PVGV %s %s CvFLAGS=0x%x\n",
$svsect->index + 1, objsym($gv), $fullname, $cv->CvFLAGS )
if $debug{cv};
# XXX not needed, we already loaded utf8_heavy
#return if $fullname eq 'utf8::AUTOLOAD';
return '0' if $all_bc_subs{$fullname} or $skip_package{$cvstashname};
mark_package($cvstashname, 1) unless $include_package{$cvstashname};
}
# XXX TODO need to save the gv stash::AUTOLOAD if exists
my $root = $cv->ROOT;
my $cvxsub = $cv->XSUB;
my $isconst;
{ no strict 'subs';
$isconst = $PERL56 ? 0 : $cv->CvFLAGS & CVf_CONST;
}
if ( !$isconst && $cvxsub && ( $cvname ne "INIT" ) ) {
my $egv = $gv->EGV;
my $stashname = $egv->STASH->NAME;
$fullname = $stashname.'::'.$cvname;
if ( $cvname eq "bootstrap" and !$xsub{$stashname} ) {
my $file = $gv->FILE;
$decl->add("/* bootstrap $file */");
warn "Bootstrap $stashname $file\n" if $verbose;
mark_package($stashname);
# Without DynaLoader we must boot and link static
if ( !$Config{usedl} ) {
$xsub{$stashname} = 'Static';
}
# if it not isa('DynaLoader'), it should hopefully be XSLoaded
# ( attributes being an exception, of course )
elsif ( $stashname ne 'attributes'
&& !UNIVERSAL::isa( $stashname, 'DynaLoader' ) )
{
my $stashfile = $stashname;
$stashfile =~ s/::/\//g;
if ($file =~ /XSLoader\.pm$/) { # almost always the case
$file = $INC{$stashfile . ".pm"};
}
unless ($file) { # do the reverse as DynaLoader: soname => pm
my ($laststash) = $stashname =~ /::([^:]+)$/;
$laststash = $stashname unless $laststash;
my $sofile = "auto/" . $stashfile . '/' . $laststash . '\.' . $Config{dlext};
for (@DynaLoader::dl_shared_objects) {
if (m{^(.+/)$sofile$}) {
$file = $1. $stashfile.".pm"; last;
}
}
}
$xsub{$stashname} = 'Dynamic-'.$file;
$use_xsloader = 1;
}
else {
$xsub{$stashname} = 'Dynamic';
}
# 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.
warn $fullname."\n" if $debug{sub};
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
my @IO = qw(IO::File IO::Handle IO::Socket IO::Seekable IO::Poll IO::Select IO::Dir IO::Pipe);
if (grep { $stashname eq $_ } @IO) {
# mark_package('IO', 1);
# $xsub{IO} = 'Dynamic-'. $INC{'IO.pm'}; # XSLoader (issue59)
svref_2object( \&IO::bootstrap )->save;
mark_unused('IO::Select', 1 ); #weak (do not delete)
mark_package('IO::Handle', 1); #strong (force)
mark_package('SelectSaver', 1); #strong (force)
#mark_package('IO::Select', 1 );
#for (@IO) { # mark all IO packages
# mark_package($_, 1);
#}
}
}
warn $fullname."\n" if $debug{sub};
unless ( in_static_core($stashname, $cvname) ) {
no strict 'refs';
warn sprintf( "stub for XSUB $fullname CV 0x%x\n", $$cv )
if $debug{cv};
svref_2object( \*{"$stashname\::bootstrap"} )->save
if $stashname;# and defined ${"$stashname\::bootstrap"};
#mark_package($stashname); # not needed
return qq/get_cv("$fullname", TRUE)/;
} else {
my $xsstash = $stashname;
if ($xsstash =~ /^PerlIO::Layer/) {
$xsstash =~ s/::/__/g; # standard XS names
$xsstash .= '_';
} else {
$xsstash =~ s/::/_/g; # special (shortened) CORE names
}
my $xs = "XS_${xsstash}_${cvname}";
if ($stashname eq 'version') { # exceptions see universal.c:struct xsub_details details[]
my %vtrans = (
'parse' => 'new',
'(""' => 'stringify',
'(0+' => 'numify',
'(cmp' => 'vcmp',
'(<=>' => 'vcmp',
'(bool' => 'boolean',
'declare' => 'qv',
);
if ($vtrans{$cvname}) {
$xs = "XS_version_".$vtrans{$cvname};
} elsif ($cvname =~ /^\(/ ) {
$xs = "XS_version_noop";
}
}
elsif ($fullname eq 'Internals::hv_clear_placeholders') {
$xs = 'XS_Internals_hv_clear_placehold';
}
elsif ($fullname eq 'Tie::Hash::NamedCapture::FIRSTKEY') {
$xs = 'XS_Tie_Hash_NamedCapture_FIRSTK';
}
elsif ($fullname eq 'Tie::Hash::NamedCapture::NEXTKEY') {
$xs = 'XS_Tie_Hash_NamedCapture_NEXTK';
}
warn sprintf( "core XSUB $xs CV 0x%x\n", $$cv )
if $debug{cv};
if (!$ENV{DL_NOWARN} and $stashname eq 'DynaLoader' and $] >= 5.015002 and $] < 5.015004) {
# [perl #100138] DynaLoader symbols are XS_INTERNAL since 5.15.2 (16,29,44,45).
# Not die because the patched libperl is hard to detect (nm libperl|egrep "_XS_Dyna.* t "),