B-C
view release on metacpan or search on metacpan
# so lexical cop_warnings need to be dynamic.
if ($copw) {
my $dest = "cop_list[$ix].cop_warnings";
# with DEBUGGING savepvn returns ptr + PERL_MEMORY_DEBUG_HEADER_SIZE
# which is not the address which will be freed in S_cop_free.
# Need to use old-style PerlMemShared_, see S_cop_free in op.c (#362)
# lexwarn<n> might be also be STRLEN* 0
$init->no_split;
$init->add("#ifdef PERL_SUPPORT_STATIC_COP /* so far cperl only */",
"$dest = $warn_sv;",
"#else",
sprintf("%s = (STRLEN*)savesharedpvn((const char*)%s, sizeof(%s));",
$dest, $copw, $copw),
"#endif");
$init->split;
}
} else {
$init->add( sprintf( "cop_list[%d].cop_warnings = %s;", $ix, $warn_sv ) )
unless $B::C::optimize_warn_sv;
}
#push @B::C::static_free, "cop_list[$ix]" if $ITHREADS;
if (!$B::C::optimize_cop) {
my $stash = savestashpv($op->stashpv);
$init->add(sprintf( "CopSTASH_set(&cop_list[%d], %s);", $ix, $stash ));
if (!$ITHREADS) {
if ($B::C::const_strings) {
my $constpv = constpv($file);
# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
# cache gv_fetchfile
if ( !$copgvtable{$constpv} ) {
$copgvtable{$constpv} = $gv_index++;
$init->add( sprintf( "gv_list[%d] = gv_fetchfile(%s);", $copgvtable{$constpv}, $constpv ) );
}
$init->add( sprintf( "CopFILEGV_set(&cop_list[%d], gv_list[%d]); /* %s */",
$ix, $copgvtable{$constpv}, cstring($file) ) );
#$init->add(sprintf( "CopFILE_set(&cop_list[%d], %s);", $ix, constpv($file) ));
} else {
$init->add(sprintf( "CopFILE_set(&cop_list[%d], %s);", $ix, cstring($file) ));
}
} else { # cv_undef e.g. in bproto.t and many more core tests with threads
$init->add(sprintf( "CopFILE_set(&cop_list[%d], %s);", $ix, cstring($file) ));
}
}
# our root: store all packages from this file
if (!$mainfile) {
$mainfile = $op->file
if $op->stashpv eq ($module ? $module : 'main');
} else {
mark_package($op->stashpv)
if $mainfile eq $op->file and $op->stashpv ne ($module ? $module : 'main');
}
savesym( $op, "(OP*)&cop_list[$ix]" );
}
# if REGCOMP can be called in init or deferred in init1
sub re_does_swash {
my ($qstr, $pmflags) = @_;
# SWASHNEW, now needing a multideref GV. 0x5000000 is just a hack. can be more
if (($] >= 5.021006 and ($pmflags & 0x5000000 == 0x5000000))
# or any unicode property (#253). Note: \p{} breaks #242
or ($qstr =~ /\\P\{/)
)
{
return 1;
} else {
return 0;
}
}
sub B::PMOP::save {
my ( $op, $level, $fullname ) = @_;
my ($replrootfield, $replstartfield, $gvsym) = ('NULL', 'NULL');
my $sym = objsym($op);
return $sym if defined $sym;
# 5.8.5-thr crashes here (7) at pushre
my $pushre = $PERL5257 ? "split" : "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;
}
$level = 0 unless $level;
my $replroot = $op->pmreplroot;
my $replstart = $op->pmreplstart;
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 (ref $replroot && $$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 = "NULL";
$replstartfield = $replstart->save if $replstart;
}
else {
$replstart->save if $replstart;
$replstartfield = saveoptree( "*ignore*", $replroot, $replstart );
$replstartfield =~ s/^hv/(OP*)hv/;
}
}
# 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, pmflags, pmreplroot, pmreplstart"
);
$pmopsect->add(
sprintf( "%s, s\\_%x, s\\_%x, %u, 0x%x, {%s}, {%s}",
$op->_save_common, ${ $op->first },
${ $op->last }, ( $ITHREADS ? $op->pmoffset : 0 ),
$op->pmflags, $replrootfield, $replstartfield
if (!$PERL510) {
print <<'_EOT12';
#if defined(CSH)
if (!PL_cshlen)
PL_cshlen = strlen(PL_cshname);
#endif
_EOT12
}
# XXX With -e "" we need to fake parse_body() scriptname = BIT_BUCKET
print <<'_EOT13';
#ifdef ALLOW_PERL_OPTIONS
#define EXTRA_OPTIONS 3
#else
#define EXTRA_OPTIONS 4
#endif /* ALLOW_PERL_OPTIONS */
Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *);
fakeargv[0] = argv[0];
fakeargv[1] = "-e";
fakeargv[2] = "";
options_count = 3;
_EOT13
# honour -T
if (!$PERL56 and ${^TAINT}) {
print <<'_EOT14';
fakeargv[options_count] = "-T";
++options_count;
_EOT14
}
print <<'_EOT15';
#ifndef ALLOW_PERL_OPTIONS
fakeargv[options_count] = "--";
++options_count;
#endif /* ALLOW_PERL_OPTIONS */
for (i = 1; i < argc; i++)
fakeargv[i + options_count - 1] = argv[i];
fakeargv[argc + options_count - 1] = 0;
exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
fakeargv, env);
if (exitstatus)
exit( exitstatus );
TAINT;
_EOT15
if ($use_perl_script_name) {
my $dollar_0 = cstring($0);
print sprintf(qq{ sv_setpv_mg(get_svs("0", GV_ADD|GV_NOTQUAL), %s);\n}, $dollar_0);
print sprintf(qq{ CopFILE_set(&PL_compiling, %s);\n}, $dollar_0);
}
else {
#print q{ warn("PL_origalen=%d\n", PL_origalen);},"\n";
print qq{ sv_setpv_mg(get_svs("0", GV_ADD|GV_NOTQUAL), argv[0]);\n};
print qq{ CopFILE_set(&PL_compiling, argv[0]);\n};
}
# more global vars
print " PL_hints = $^H;\n" if $^H;
print " PL_unicode = ${^UNICODE};\n" if ${^UNICODE};
# system-specific needs to be skipped: is set during init_i18nl10n if PerlIO
# is compiled in and on a utf8 locale.
#print " PL_utf8locale = ${^UTF8LOCALE};\n" if ${^UTF8LOCALE};
#print " PL_utf8cache = ${^UTF8CACHE};\n" if ${^UTF8CACHE};
# nomg
print sprintf(qq{ sv_setpv(get_svs(";", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($;)) if $; ne "\34";
print sprintf(qq{ sv_setpv(get_svs("\\"", GV_NOTQUAL), %s); /* \$" */\n}, cstring($")) if $" ne " ";
# global IO vars
if ($PERL56) {
print sprintf(qq{ PL_ofs = %s; PL_ofslen = %u; /* \$, */\n}, cstring($,), length $,) if $,;
print sprintf(qq{ PL_ors = %s; PL_orslen = %u; /* \$\\ */\n}, cstring($\), length $\) if $\;
} else {
print sprintf(qq{ sv_setpv_mg(GvSVn(PL_ofsgv), %s); /* \$, */\n}, cstring($,)) if $,;
print sprintf(qq{ sv_setpv_mg(get_svs("\\\\", GV_ADD|GV_NOTQUAL), %s); /* \$\\ */\n}, cstring($\)) if $\; #ORS
}
print sprintf(qq{ sv_setpv_mg(get_svs("/", GV_NOTQUAL), %s);\n}, cstring($/)) if $/ ne "\n"; #RS
print qq{ sv_setiv_mg(get_svs("|", GV_ADD|GV_NOTQUAL), $|);\n} if $|; #OUTPUT_AUTOFLUSH
# global format vars
print sprintf(qq{ sv_setpv_mg(get_svs("^A", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($^A)) if $^A; #ACCUMULATOR
print sprintf(qq{ sv_setpv_mg(get_svs("^L", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($^L)) if $^L ne "\f"; #FORMFEED
print sprintf(qq{ sv_setpv_mg(get_svs(":", GV_ADD|GV_NOTQUAL), %s);\n}, cstring($:)) if $: ne " \n-"; #LINE_BREAK_CHARACTERS
print sprintf(qq/ sv_setpv_mg(get_svs("^", GV_ADD|GV_NOTQUAL), savepvn(%s, %u));\n/, cstring($^), length($^))
if $^ ne "STDOUT_TOP";
print sprintf(qq/ sv_setpv_mg(get_svs("~", GV_ADD|GV_NOTQUAL), savepvn(%s, %u));\n/, cstring($~), length($~))
if $~ ne "STDOUT";
print qq{ sv_setiv_mg(get_svs("%", GV_ADD|GV_NOTQUAL), $%);\n} if $%; #PAGE_NUMBER
print qq{ sv_setiv_mg(get_svs("-", GV_ADD|GV_NOTQUAL), $-);\n} unless ($- == 0 or $- == 60); #LINES_LEFT
print qq{ sv_setiv_mg(get_svs("=", GV_ADD|GV_NOTQUAL), $=);\n} if $= != 60; #LINES_PER_PAGE
# deprecated global vars
print qq{ {SV* s = get_svs("[",GV_NOTQUAL); sv_setiv(s, $[); mg_set(s);}\n} if $[; #ARRAY_BASE
if ($] < 5.010) { # OFMT and multiline matching
eval q[
print sprintf(qq{ sv_setpv(GvSVn(gv_fetchpv("\$#", GV_ADD|GV_NOTQUAL, SVt_PV)), %s);\n},
cstring($#)) if $#;
print sprintf(qq{ sv_setiv(GvSVn(gv_fetchpv("\$*", GV_ADD|GV_NOTQUAL, SVt_IV)), %d);\n}, $*) if $*;
];
}
print sprintf(qq{ sv_setpv_mg(get_svs("\030", GV_ADD|GV_NOTQUAL), %s); /* \$^X */\n},
cstring($Config{perlpath}));
print <<'EOT';
TAINT_NOT;
#if PERL_VERSION < 10 || ((PERL_VERSION == 10) && (PERL_SUBVERSION < 1))
PL_compcv = 0;
#else
PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
#endif
EOT
output_init();
print " exitstatus = perl_run( my_perl );\n";
output_local_destruct("main");
output_global_destruct();
# XXX endav is called via call_list and so it is freed right after usage.
# Setting dirty here is useless.
( run in 0.524 second using v1.01-cache-2.11-cpan-39bf76dae61 )