B-C
view release on metacpan or search on metacpan
sub name {
my $section = shift;
return $section->[1];
}
sub symtable {
my $section = shift;
return $section->[2];
}
sub default {
my $section = shift;
return $section->[3];
}
sub typename {
my $section = shift;
my $name = $section->name;
my $typename = uc($name);
# -fcog hack to statically initialize PVs (SVPV for 5.10-5.11 only)
$typename = 'SVPV' if $typename eq 'SV' and $] > 5.009005 and $] < 5.012 and !$C99;
# $typename = 'const '.$typename if $name !~ /^(cop_|sv_)/;
$typename = 'UNOP_AUX' if $typename eq 'UNOPAUX';
$typename = 'SV*' if $typename =~ /^AVCO[WG]_/;
#$typename = 'MyPADNAME' if $typename eq 'PADNAME' and $] >= 5.018;
return $typename;
}
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;
return if $B::C::check;
my $i = 0;
my $dodbg = 1 if $debug{flags} and $section->[-1]{dbg};
if ($section->name eq 'sv') { #fixup arenaroot refcnt
my $len = scalar @{ $section->[-1]{values} };
$section->[-1]{values}->[0] =~ s/^NULL, 0/NULL, $len/;
}
foreach ( @{ $section->[-1]{values} } ) {
my $dbg = "";
my $ref = "";
if (m/(s\\_[0-9a-f]+)/) {
if (!exists($sym->{$1}) and $1 ne 's\_0') {
$ref = $1;
$B::C::unresolved_count++;
if ($B::C::verbose) {
my $caller = caller(1);
warn "Warning: unresolved ".$section->name." symbol $ref\n"
if $caller eq 'B::C';
}
}
}
s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
if ($dodbg and $section->[-1]{dbg}->[$i]) {
$dbg = " /* ".$section->[-1]{dbg}->[$i]." ".$ref." */";
}
if ($format eq "\t{ %s }, /* %s_list[%d] %s */%s\n") {
printf $fh $format, $_, $section->name, $i, $ref, $dbg;
} else {
printf $fh $format, $_;
}
++$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]{size} = 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();
}
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$level = 0 unless $level;
$methopsect->comment("$opsect_common, first, rclass");
my $union = $op->name eq 'method' ? "{.op_first=(OP*)%s}" : "{.op_meth_sv=(SV*)%s}";
$union = "%s" unless $C99;
my $s = "%s, $union, ". ($ITHREADS ? "(PADOFFSET)%s" : "(SV*)%s"); # rclass
my $ix = $methopsect->index + 1;
my $rclass = $ITHREADS ? $op->rclass : $op->rclass->save("op_rclass_sv");
if ($rclass =~ /^&sv_list/) {
$init->add( sprintf( "SvREFCNT_inc_simple_NN(%s); /* methop_list[%d].op_rclass_sv */",
$rclass, $ix ));
# Put this simple PV into the PL_stashcache, it has no STASH,
# and initialize the method cache.
# TODO: backref magic for next, init the next::method cache
$init->add( sprintf( "Perl_mro_method_changed_in(aTHX_ gv_stashsv(%s, GV_ADD));",
$rclass ));
}
my $first = $op->name eq 'method' ? $op->first->save : $op->meth_sv->save;
if ($first =~ /^&sv_list/) {
$init->add( sprintf( "SvREFCNT_inc_simple_NN(%s); /* methop_list[%d].op_meth_sv */",
$first, $ix ));
}
$first = 'NULL' if !$C99 and $first eq 'Nullsv';
$methopsect->add(sprintf($s, $op->_save_common, $first, $rclass));
$methopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
$init->add( sprintf( "methop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
$sym = savesym( $op, "(OP*)&methop_list[$ix]" );
if ($op->name eq 'method') {
do_labels($op, $level+1, 'first', 'rclass');
} else {
do_labels($op, $level+1, 'meth_sv', 'rclass');
}
$sym;
}
sub B::PVOP::save {
my ( $op, $level ) = @_;
my $sym = objsym($op);
return $sym if defined $sym;
$level = 0 unless $level;
# op_pv must be dynamic
$pvopsect->comment("$opsect_common, pv");
$pvopsect->add( sprintf( "%s, NULL", $op->_save_common ) );
$pvopsect->debug( $op->name, $op->flagspv ) if $debug{flags};
my $ix = $pvopsect->index;
$init->add( sprintf( "pvop_list[%d].op_ppaddr = %s;", $ix, $op->ppaddr ) )
unless $B::C::optimize_ppaddr;
my ($cstring,$cur,$utf8) = strlen_flags($op->pv); # utf8 in op_private as OPpPV_IS_UTF8 (0x80)
# do not use savepvn here #362
$init->add( sprintf( "pvop_list[%d].op_pv = savesharedpvn(%s, %u);", $ix, $cstring, $cur ));
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;
warn "save package_pv \"$package_pv\" for method_name from @{[(caller(1))[3]]}\n"
if $debug{cv} or $debug{pkg} and !grep { $p eq $_ } @package_pv;
@package_pv = grep { $p ne $_ } @package_pv if @package_pv; # remove duplicates at the end
unshift @package_pv, $p; # prepend at the front
mark_package($p);
}
# method_named is in 5.6.1
sub method_named {
my $name = shift;
return unless $name;
my $cop = shift;
my $loc = $cop ? " at ".$cop->file." line ".$cop->line : "";
# Note: the pkg PV is unacessible(?) at PL_stack_base+TOPMARK+1.
# But it is also at the const or padsv after the pushmark, before all args.
# See L<perloptree/"Call a method">
# We check it in op->_save_common
if (ref($name) eq 'B::CV') {
warn $name;
return $name;
}
my $method;
for ($package_pv, @package_pv, 'main') {
no strict 'refs';
next unless defined $_;
$method = $_ . '::' . $name;
if (defined(&$method)) {
warn sprintf( "Found &%s::%s\n", $_, $name ) if $debug{cv};
$include_package{$_} = 1; # issue59
mark_package($_, 1);
last;
} else {
if (my $parent = try_isa($_,$name)) {
warn sprintf( "Found &%s::%s\n", $parent, $name ) if $debug{cv};
$method = $parent . '::' . $name;
$include_package{$parent} = 1;
last;
}
warn "no definition for method_name \"$method\"\n" if $debug{cv};
}
}
#my $b = $Config{archname}."/B\.pm";
#if ($name !~ /^tid|can|isa|pmreplroot$/ and $loc !~ m/$b line / and $package_pv !~ /^B::/) {
# return undef if $ITHREADS;
#}
$method = $name unless $method;
if (exists &$method) { # Do not try to save non-existing methods
warn "save method_name \"$method\"$loc\n" if $debug{cv};
return svref_2object( \&{$method} );
} else {
return 0;
}
}
# 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')
if ($] >= 5.018 and $op->reflags & RXf_EVAL_SEEN) { # set HINT_RE_EVAL off
$initpm->add(" PL_hints = hints_sav;",
"}");
$initpm->split();
}
# See toke.c:8964
# set in the stash the PERL_MAGIC_symtab PTR to the PMOP: ((PMOP**)mg->mg_ptr) [elements++] = pm;
if ($PERL510 and $op->pmflags & PMf_ONCE()) {
my $stash = $MULTI ? $op->pmstashpv
: ref $op->pmstash eq 'B::HV' ? $op->pmstash->NAME : '__ANON__';
$Regexp{$$op} = $op; #188: restore PMf_ONCE, set PERL_MAGIC_symtab in $stash
}
}
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, $fullname) = @_;
# 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. pWARN_STD was added to B with 5.8.9
# &PL_sv_zero was added with 5.27.2 and was imported
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, $fullname) = @_;
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" );
}
my $i = $svsect->index + 1;
warn "Saving SVt_NULL sv_list[$i]\n" if $debug{sv};
$svsect->add( sprintf( "NULL, $u32fmt, 0x%x".($PERL510?", {0}":''),
$sv->REFCNT, $sv->FLAGS ) );
#$svsect->debug( $fullname, $sv->flagspv ) if $debug{flags}; # XXX where is this possible?
if ($debug{flags} and (!$ITHREADS or $PERL514) and $DEBUG_LEAKING_SCALARS) { # 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 = savesharedpv("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, $fullname) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
my $uvuformat = $Config{uvuformat};
$uvuformat =~ s/["\0]//g; #" poor editor
$uvuformat =~ s/".$/"/; # cperl bug 5.22.2 #61
my $uvx = $sv->UVX;
my $suff = 'U';
$suff .= 'L' if $uvx > 2147483647;
my $i = $svsect->index + 1;
if ($PERL524) {
# since 5.24 we need to point the xpvuv to the head
} elsif ($PERL514) {
# issue 145 warn $sv->UVX, " ", sprintf($u32fmt, $sv->UVX);
$xpvuvsect->comment( "stash, magic, cur, len, xuv_u" );
$xpvuvsect->add( sprintf( "Nullhv, {0}, 0, 0, {%".$uvuformat."$suff}", $uvx ) );
} elsif ($PERL510) {
$xpvuvsect->comment( "stash, magic, cur, len, xuv_u" );
$xpvuvsect->add( sprintf( "{0}, 0, 0, {%".$uvuformat."$suff}", $uvx ) );
} else {
$xpvuvsect->comment( "pv, cur, len, uv" );
$xpvuvsect->add( sprintf( "0, 0, 0, %".$uvuformat.$suff, $uvx ) );
}
if ($PERL524) {
$svsect->add(sprintf( "NULL, $u32fmt, 0x%x".
($PERL510?', {'.($C99?".svu_uv=":"").$uvx."$suff}":''),
$sv->REFCNT, $sv->FLAGS));
#32bit - sizeof(void*), 64bit: - 2*ptrsize
if ($Config{ptrsize} == 4 and !IS_MSVC) {
$init->add(sprintf( "sv_list[%d].sv_any = (void*)&sv_list[%d] - sizeof(void*);", $i, $i));
} else {
$init->add(sprintf( "sv_list[%d].sv_any = (char*)&sv_list[%d] - %d;", $i, $i,
2*$Config{ptrsize}));
}
} else {
$svsect->add(sprintf( "&xpvuv_list[%d], $u32fmt, 0x%x".
($PERL510?', {'.($C99?".svu_uv=":"").$uvx."$suff}":''),
$xpvuvsect->index, $sv->REFCNT, $sv->FLAGS));
}
$svsect->debug( $fullname, $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, $i, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
if $debug{sv};
savesym( $sv, sprintf( "&sv_list[%d]", $i ) );
}
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 $ivx = ivx($sv->IVX);
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 ($PERL524) {
# since 5.24 we need to point the xpviv to the head
} elsif ($PERL514) {
$xpvivsect->comment( "stash, magic, cur, len, xiv_u" );
$xpvivsect->add( sprintf( "Nullhv, {0}, 0, 0, {%s}", $ivx ) );
} elsif ($PERL510) {
$xpvivsect->comment( "stash, magic, cur, len, xiv_u" );
$xpvivsect->add( sprintf( "{0}, 0, 0, {%s}", $ivx ) );
} else {
$xpvivsect->comment( "pv, cur, len, iv" );
$xpvivsect->add( sprintf( "0, 0, 0, %s", $ivx ) );
}
if ($PERL524) {
$svsect->add(sprintf( "NULL, $u32fmt, 0x%x, {".($C99?".svu_iv=":"").$ivx.'}',
$sv->REFCNT, $svflags ));
#32bit - sizeof(void*), 64bit: - 2*ptrsize
if ($Config{ptrsize} == 4 and !IS_MSVC) {
$init->add(sprintf( "sv_list[%d].sv_any = (void*)&sv_list[%d] - sizeof(void*);", $i, $i));
} else {
$init->add(sprintf( "sv_list[%d].sv_any = (char*)&sv_list[%d] - %d;", $i, $i,
2*$Config{ptrsize}));
}
} else {
$svsect->add(sprintf( "&xpviv_list[%d], $u32fmt, 0x%x".($PERL510?', {'.($C99?".svu_iv=":"").$ivx.'}':''),
$xpvivsect->index, $sv->REFCNT, $svflags ));
}
$svsect->debug( $fullname, $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, $i, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} )
if $debug{sv};
savesym( $sv, sprintf( "&sv_list[%d]", $i ) );
}
sub B::NV::save {
my ($sv, $fullname) = @_;
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;
$nv = '0.00' if IS_MSVC and !$nv;
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], $u32fmt, 0x%x %s",
$xpvnvsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {0}' : '' ));
$svsect->debug( $fullname, $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, $cur ) = @_;
my @init;
# work with byte offsets/lengths
$pv = pack "a*", $pv if defined $pv;
if ( defined $max_string_len && length($pv) > $max_string_len ) {
push @init, sprintf( "Newx(%s, %u, char);", $dest, length($pv) + 2 );
my $offset = 0;
while ( length $pv ) {
my $str = substr $pv, 0, $max_string_len, '';
push @init,
sprintf( "Copy(%s, %s+%d, %u, char);",
cstring($str), $dest, $offset, 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} or $debug{pv};
}
else {
# If READONLY and FAKE use newSVpvn_share instead. (test 75)
# XXX IsCOW forgotten here. rather use a helper is_shared_hek()
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,'',1);
if ($pvsym =~ /PL_sv_undef/ and $ITHREADS) {
$pvsym = 'NULL'; # Moose 5.8.9d
}
$xpvmgsect->add(sprintf("(char*)%s, %u, %u, %s, %s, 0, 0",
$pvsym, $cur, $len, $ivx, $nvx));
$svsect->add(sprintf("&xpvmg_list[%d], $u32fmt, 0x%x",
$xpvmgsect->index, $sv->REFCNT, $flags));
}
$svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
if ( !$static ) { # do not overwrite RV slot (#273)
# XXX comppadnames need &PL_sv_undef instead of 0 (?? which testcase?)
if ($PERL510) {
$init->add( savepvn( "$s.sv_u.svu_pv", $pv, $sv, $cur ) );
} else {
$init->add( savepvn( sprintf( "xpvmg_list[%d].xpv_pv", $xpvmgsect->index ),
$pv, $sv, $cur ) );
}
} elsif ($tmp_pvsym eq 'NULL' and $pvsym =~ /^hek/) {
$init->add( sprintf("%s.sv_u.svu_pv = %s.hek_key;", $s, $pvsym ));
}
$sym = savesym( $sv, "&".$s );
$sv->save_magic($fullname);
return $sym;
}
# mark threads::shared to be xs-loaded
sub mark_threads {
if ( $INC{'threads.pm'} ) {
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;
my $pkg;
return if $fullname and $fullname eq '%B::C::';
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 %s (0x%x) flags=0x%x%s - called from %s:%s\n",
B::class($sv), $fullname, $$sv, $sv_flags, $debug{flags} ? "(".$flagspv.")" : "",
@{[(caller(1))[3]]}, @{[(caller(1))[2]]});
}
# crashes on STASH=0x18 with HV PERL_MAGIC_overload_table stash %version:: flags=0x3280000c
# issue267 GetOpt::Long SVf_AMAGIC|SVs_RMG|SVf_OOK
# crashes with %Class::MOP::Instance:: flags=0x2280000c also
if (ref($sv) eq 'B::HV' and $] > 5.018 and $sv->MAGICAL and $fullname =~ /::$/) {
warn sprintf("skip SvSTASH for overloaded HV %s flags=0x%x\n", $fullname, $sv_flags)
if $verbose;
# [cperl #60] not only overloaded, version also
} elsif (ref($sv) eq 'B::HV' and $] > 5.018 and $fullname =~ /(version|File)::$/) {
warn sprintf("skip SvSTASH for %s flags=0x%x\n", $fullname, $sv_flags)
if $verbose;
} else {
my $pkgsym;
$pkg = $sv->SvSTASH;
if ($pkg and $$pkg) {
my $pkgname = $pkg->can('NAME') ? $pkg->NAME : $pkg->NAME_HEK."::DESTROY";
warn sprintf("stash isa class \"%s\" (%s)\n", $pkgname, ref $pkg)
if $debug{mg} or $debug{gv};
# 361 do not force dynaloading IO via IO::Handle upon us
# core already initialized this stash for us
unless ($fullname eq 'main::STDOUT' and $] >= 5.018) {
if (ref $pkg eq 'B::HV') {
if ($fullname !~ /::$/ or $B::C::stash) {
$pkgsym = $pkg->save($fullname);
} else {
$pkgsym = savestashpv($pkgname);
}
} else {
$pkgsym = 'NULL';
}
warn sprintf( "xmg_stash = \"%s\" as %s\n", $pkgname, $pkgsym )
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
# defer for XS loaded stashes with AMT magic
if (ref $pkg eq 'B::HV') {
$init->add( sprintf( "SvSTASH_set(s\\_%x, (HV*)s\\_%x);", $$sv, $$pkg ) );
$init->add( sprintf( "SvREFCNT((SV*)s\\_%x) += 1;", $$pkg ) );
$init->add("++PL_sv_objcount;") unless ref($sv) eq "B::IO";
# XXX
#push_package($pkg->NAME); # correct code, but adds lots of new stashes
}
}
}
}
$init->add(sprintf("SvREADONLY_off((SV*)s\\_%x);", $$sv))
if $sv_flags & SVf_READONLY and ref($sv) ne 'B::HV';
# Protect our SVs against non-magic or SvPAD_OUR. Fixes tests 16 and 14 + 23
if ($PERL510 and !($sv->MAGICAL or $sv_flags & SVf_AMAGIC)) {
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 '';
}
# disabled. testcase: t/testm.sh Path::Class
if (0 and $PERL518 and $sv_flags & SVf_AMAGIC) {
}
CODE2
}
}
}
elsif ( $type eq 'D' ) { # XXX regdata AV - coverage? i95, 903
# see Perl_mg_copy() in mg.c
$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
$$sv, $fullname eq 'main::-' ? 0 : $$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' ) { # and !$PERL518
$init->add(sprintf(
"/* AMT overload table for the stash %s s\\_%x is generated dynamically */",
$fullname, $$sv ));
}
elsif ( $type eq ':' ) { # symtab magic
# search $ptr in list of pmops and replace it. e.g. (char*)&pmop_list[0]
my $pmop_ptr = unpack("J", $mg->PTR);
my $pmop;
$pmop = $B::C::Regexp{$pmop_ptr} if defined $pmop_ptr;
my $pmsym = $pmop ? $pmop->save(0, $fullname)
: ''; #sprintf('&pmop_list[%u]', $pmopsect->index);
warn sprintf("pmop 0x%x not found in our B::C Regexp hash\n", $pmop_ptr || 'undef')
if !$pmop and $verbose;
$init->add("{\tU32 elements;", # toke.c: PL_multi_open == '?'
sprintf("\tMAGIC *mg = sv_magicext((SV*)s\\_%x, 0, ':', 0, 0, 0);", $$sv),
"\telements = mg->mg_len / sizeof(PMOP**);",
"\tRenewc(mg->mg_ptr, elements + 1, PMOP*, char);",
($pmop
? (sprintf("\t((OP**)mg->mg_ptr) [elements++] = (OP*)%s;", $pmsym))
: ( defined $pmop_ptr
? sprintf( "\t((OP**)mg->mg_ptr) [elements++] = (OP*)s\\_%x;", $pmop_ptr ) : '' )),
"\tmg->mg_len = elements * sizeof(PMOP**);", "}");
}
else {
$init->add(sprintf(
"sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
$$sv, $$obj, cchar($type), cstring($ptr), $len));
if (!($mg->FLAGS & 2)) {
mg_RC_off($mg, $sv, $type);
}
}
}
$init->add(sprintf("SvREADONLY_on((SV*)s\\_%x);", $$sv))
if $sv_flags & SVf_READONLY and ref($sv) ne 'B::HV';
$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",
B::class($sv), $$sv, @{[(caller(1))[3]]}, @{[(caller(1))[2]]})
if $debug{sv};
my $rv = save_rv($sv, $fullname);
return '0' unless $rv;
if ($PERL510) {
$svsect->comment( "any, refcnt, flags, sv_u" );
# 5.22 has a wrong RV->FLAGS (https://github.com/perl11/cperl/issues/63)
my $flags = $sv->FLAGS;
$flags = 0x801 if $flags & 9 and $PERL522; # not a GV but a ROK IV (21)
# 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, $u32fmt, 0x%x, {%s}", $sv->REFCNT, $flags,
(($C99 && is_constant($rv)) ? ".svu_rv=$rv" : "0 /*-> $rv */")));
$svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
# 354 defined needs SvANY
$init->add( sprintf("$s.sv_any = (char*)&$s - %d;", $Config{ptrsize}))
if $] > 5.019 or $ITHREADS;
unless ($C99 && is_constant($rv)) {
if ( $rv =~ /get_cv/ ) {
$init2->add( "$s.sv_u.svu_rv = (SV*)$rv;" ) ;
} else {
$init->add( "$s.sv_u.svu_rv = (SV*)$rv;" ) ;
}
}
return savesym( $sv, "&".$s );
}
else {
# GVs need to be handled at runtime
if ( ref( $sv->RV ) eq 'B::GV' or $rv =~ /^gv_list/) {
$xrvsect->add("Nullsv /* $rv */");
$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("Nullsv /* $rv */");
$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)
# dynamic; so we need to inc it
elsif ( $rv =~ /get_cv/ ) {
$xrvsect->add("Nullsv /* $rv */");
$init2->add(
sprintf( "xrv_list[%d].xrv_rv = (SV*)SvREFCNT_inc(%s);", $xrvsect->index, $rv ) );
}
else {
#$xrvsect->add($rv); # not static initializable (e.g. cv160 for ExtUtils::Install)
$xrvsect->add("Nullsv /* $rv */");
$init->add(
sprintf( "xrv_list[%d].xrv_rv = (SV*)SvREFCNT_inc(%s);", $xrvsect->index, $rv ) );
}
$svsect->comment( "any, refcnt, flags" );
$svsect->add(sprintf("&xrv_list[%d], $u32fmt, 0x%x",
$xrvsect->index, $sv->REFCNT, $sv->FLAGS));
$svsect->debug( $fullname, $sv->flagspv ) if $debug{flags};
my $s = "sv_list[".$svsect->index."]";
return savesym( $sv, "&".$s );
}
warn "bootstrapping $stashname added to xs_init\n" if $verbose;
$stashxsub =~ s/::/__/g;
print "\tPUSHMARK(sp);\n";
printf "\tXPUSHp(\"%s\", %d);\n", # "::bootstrap" gets appended, TODO
0 ? "strdup($stashname)" : $stashname, length($stashname);
print "\tPUTBACK;\n";
print "\tboot_$stashxsub(aTHX_ NULL);\n";
print "\tSPAGAIN;\n";
}
}
print "\tFREETMPS;\n/* end XS bootstrapping code */\n";
print "}\n\n";
my ($dl, $xs);
my @dl_modules = @DynaLoader::dl_modules;
my @PERLMODS = split(/\,/, $ENV{'PERLMODS'}) if $ENV{'PERLMODS'}; # from cpanel
foreach my $perlmod (@PERLMODS) {
warn "Extra module ${perlmod}\n";
push @dl_modules, $perlmod unless grep { $_ ne $perlmod } @dl_modules;
}
# filter out unused dynaloaded B modules, used within the compiler only.
for my $c (qw(B B::C)) {
if (!$xsub{$c} and !$include_package{$c}) {
# (hopefully, see test 103)
warn "no dl_init for $c, not marked\n" if $verbose and !$skip_package{$c};
# RT81332 pollute
@dl_modules = grep { $_ ne $c } @dl_modules;
# XXX Be sure to store the new @dl_modules
}
}
for my $c (sort keys %skip_package) {
warn "no dl_init for $c, skipped\n" if $verbose and $xsub{$c};
delete $xsub{$c};
$include_package{$c} = undef;
@dl_modules = grep { $_ ne $c } @dl_modules;
}
@DynaLoader::dl_modules = @dl_modules;
warn "\@dl_modules: ",join(" ",@dl_modules),"\n" if $verbose;
foreach my $stashname (@dl_modules) {
my $incpack = inc_packname($stashname);
#unless (exists $INC{$incpack}) { # skip deleted packages
# warn "XXX skip dl_init for $stashname !\$INC{$incpack}\n" if $debug{pkg};
# delete $xsub{$stashname};
# @dl_modules = grep { $_ ne $stashname } @dl_modules;
#}
if ($stashname eq 'attributes' and $] > 5.011) {
$xsub{$stashname} = 'Dynamic-' . $INC{'attributes.pm'};
}
# actually boot all non-b-c dependent modules here. we assume XSLoader (Moose, List::MoreUtils)
if (!exists( $xsub{$stashname} ) and $include_package{$stashname}) {
$xsub{$stashname} = 'Dynamic-' . $INC{$incpack};
# Class::MOP without Moose: find Moose.pm
$xsub{$stashname} = 'Dynamic-' . $savINC{$incpack} unless $INC{$incpack};
if (!$savINC{$incpack}) {
eval "require $stashname;";
$xsub{$stashname} = 'Dynamic-' . $INC{$incpack};
}
warn "Assuming xs loaded $stashname with $xsub{$stashname}\n" if $verbose;
}
if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic/ ) {
# XSLoader.pm: $modlibname = (caller())[1]; needs a path at caller[1] to find auto,
# otherwise we only have -e
$xs++ if $xsub{$stashname} ne 'Dynamic';
$dl++;
}
my $stashxsub = $stashname;
$stashxsub =~ s/::/__/g;
if ( exists( $xsub{$stashname} ) && $xsub{$stashname} =~ m/^Dynamic-/
and ($PERL522 or $staticxs)) {
print "EXTERN_C void boot_$stashxsub(pTHX_ CV* cv);\n";
}
}
warn "\%xsub: ",join(" ",sort keys %xsub),"\n" if $verbose and $debug{cv};
# XXX Adding DynaLoader is too late here! The sections like $init are already dumped (#125)
if ($dl and ! $curINC{'DynaLoader.pm'}) {
die "Error: DynaLoader required but not dumped. Too late to add it.\n";
} elsif ($xs and ! $curINC{'XSLoader.pm'}) {
die "Error: XSLoader required but not dumped. Too late to add it.\n";
}
print <<'_EOT9';
static void
dl_init(pTHX)
{
char *file = __FILE__;
_EOT9
if ($dl) {
# enforce attributes at the front of dl_init, #259
# also Encode should be booted before PerlIO::encoding
for my $front (qw(Encode attributes)) {
if (grep { $_ eq $front } @dl_modules) {
@dl_modules = grep { $_ ne $front } @dl_modules;
unshift @dl_modules, $front;
}
}
if ($staticxs) {open( XS, ">", $outfile.".lst" ) or return "$outfile.lst: $!\n"}
print "\tdTARG; dSP; dVAR;\n";
print "/* DynaLoader bootstrapping */\n";
print "\tENTER;\n";
print "\t++cxstack_ix; cxstack[cxstack_ix].blk_oldcop = PL_curcop;\n" if $xs;
print "\t/* assert(cxstack_ix == 0); */\n" if $xs;
print "\tSAVETMPS;\n";
print "\ttarg = sv_newmortal();\n" if $] < 5.008008;
if (exists $xsub{"Coro::State"} and grep { $_ eq "Coro::State" } @dl_modules) {
# Coro readonly symbols in BOOT (#293)
# needed before dl_init, and after init
print "\t{\n\t GV *sym;\n";
for my $s (qw(Coro Coro::API Coro::current)) {
print "\t sym = gv_fetchpv(\"$s\",0,SVt_PV);\n";
print "\t if (sym && GvSVn(sym)) SvREADONLY_off(GvSVn(sym));\n";
}
print "\t sym = gv_fetchpv(\"Coro::pool_handler)\",0,SVt_PVCV);\n";
print "\t if (sym && GvCV(sym)) SvREADONLY_off(GvCV(sym));\n";
print "\t}\n";
}
if (exists $xsub{"EV"} and grep { $_ eq "EV" } @dl_modules) {
# EV readonly symbols in BOOT (#368)
print "\t{\n\t GV *sym;\n";
for my $s (qw(EV::API)) {
( run in 1.850 second using v1.01-cache-2.11-cpan-98e64b0badf )