summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ext/B/B.pm6
-rw-r--r--ext/B/B.xs4
-rw-r--r--ext/B/B/Bblock.pm10
-rw-r--r--ext/B/B/C.pm17
-rw-r--r--ext/B/B/CC.pm11
-rw-r--r--ext/B/B/Stash.pm21
-rw-r--r--t/harness46
7 files changed, 93 insertions, 22 deletions
diff --git a/ext/B/B.pm b/ext/B/B.pm
index f864883b99..0bfceafd7d 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -11,7 +11,7 @@ require Exporter;
@ISA = qw(Exporter DynaLoader);
@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
class peekop cast_I32 cstring cchar hash threadsv_names
- main_root main_start main_cv svref_2object opnumber
+ main_root main_start main_cv svref_2object opnumber amagic_generation
walkoptree walkoptree_slow walkoptree_exec walksymtable
parents comppadlist sv_undef compile_stats timing_info init_av);
sub OPf_KIDS ();
@@ -750,6 +750,10 @@ Returns the SV object corresponding to the C variable C<sv_yes>.
Returns the SV object corresponding to the C variable C<sv_no>.
+=item amagic_generation
+
+Returns the SV object corresponding to the C variable C<amagic_generation>.
+
=item walkoptree(OP, METHOD)
Does a tree-walk of the syntax tree based at OP and calls METHOD on
diff --git a/ext/B/B.xs b/ext/B/B.xs
index dd50d978ac..466091d679 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -454,6 +454,7 @@ BOOT:
#define B_init_av() PL_initav
#define B_main_root() PL_main_root
#define B_main_start() PL_main_start
+#define B_amagic_generation() PL_amagic_generation
#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
#define B_sv_undef() &PL_sv_undef
#define B_sv_yes() &PL_sv_yes
@@ -471,6 +472,9 @@ B_main_root()
B::OP
B_main_start()
+long
+B_amagic_generation()
+
B::AV
B_comppadlist()
diff --git a/ext/B/B/Bblock.pm b/ext/B/B/Bblock.pm
index cb007ff2ba..14001b3c73 100644
--- a/ext/B/B/Bblock.pm
+++ b/ext/B/B/Bblock.pm
@@ -21,8 +21,8 @@ sub mark_leader {
sub find_leaders {
my ($root, $start) = @_;
$bblock = {};
- mark_leader($start);
- walkoptree($root, "mark_if_leader");
+ mark_leader($start) if ( ref $start ne "B::NULL" );
+ walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
return $bblock;
}
@@ -103,6 +103,12 @@ sub B::LISTOP::mark_if_leader {
mark_leader($op->next);
}
+sub B::LISTOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->first);
+ mark_leader($op->next);
+}
+
sub B::PMOP::mark_if_leader {
my $op = shift;
if ($op->ppaddr ne "pp_pushre") {
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index ec39de2674..4aa80a1ae7 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -49,7 +49,7 @@ use Exporter ();
use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
class cstring cchar svref_2object compile_stats comppadlist hash
- threadsv_names main_cv init_av opnumber
+ threadsv_names main_cv init_av opnumber amagic_generation
AVf_REAL HEf_SVKEY);
use B::Asmdata qw(@specialsv_name);
@@ -401,7 +401,9 @@ sub B::NV::save {
my ($sv) = @_;
my $sym = objsym($sv);
return $sym if defined $sym;
- $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
+ my $val= $sv->NVX;
+ $val .= '.00' if $val =~ /^-?\d+$/;
+ $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
$svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
$xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
@@ -453,8 +455,10 @@ sub B::PVNV::save {
$pv = '' unless defined $pv;
my $len = length($pv);
my ($pvsym, $pvmax) = savepv($pv);
+ my $val= $sv->NVX;
+ $val .= '.00' if $val =~ /^-?\d+$/;
$xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
- $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+ $pvsym, $len, $pvmax, $sv->IVX, $val));
$svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
$xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
if (!$pv_copy_on_grow) {
@@ -524,6 +528,7 @@ sub B::PVMG::save_magic {
my ($sv) = @_;
#warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
my $stash = $sv->SvSTASH;
+ $stash->save;
if ($$stash) {
warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
if $debug_mg;
@@ -542,6 +547,7 @@ sub B::PVMG::save_magic {
class($sv), $$sv, class($obj), $$obj,
cchar($type), cstring($ptr));
}
+ $obj->save;
if ($len == HEf_SVKEY){
#The pointer is an SV*
$ptrsv=svref_2object($ptr)->save;
@@ -884,6 +890,7 @@ sub B::HV::save {
}
$init->add("}");
}
+ $hv->save_magic();
return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
}
@@ -1297,11 +1304,13 @@ sub save_context
my $curpad_sym = (comppadlist->ARRAY)[1]->save;
my $inc_hv = svref_2object(\%INC)->save;
my $inc_av = svref_2object(\@INC)->save;
+ my $amagic_generate= amagic_generation;
$init->add( "PL_curpad = AvARRAY($curpad_sym);",
"GvHV(PL_incgv) = $inc_hv;",
"GvAV(PL_incgv) = $inc_av;",
"av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
- "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
+ "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+ "PL_amagic_generation= $amagic_generate;" );
}
sub descend_marked_unused {
diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm
index 143ae41178..649f6e10f7 100644
--- a/ext/B/B/CC.pm
+++ b/ext/B/B/CC.pm
@@ -8,7 +8,7 @@
package B::CC;
use strict;
use B qw(main_start main_root class comppadlist peekop svref_2object
- timing_info init_av sv_undef
+ timing_info init_av sv_undef amagic_generation
OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
@@ -1424,7 +1424,12 @@ sub cc {
warn sprintf("Basic block analysis at %s\n", timing_info);
}
$leaders = find_leaders($root, $start);
- @bblock_todo = ($start, values %$leaders);
+ my @leaders= keys %$leaders;
+ if ($#leaders > -1) {
+ @bblock_todo = ($start, values %$leaders) ;
+ } else{
+ runtime("return PL_op?PL_op->op_next:0;");
+ }
if ($debug_timings) {
warn sprintf("Compilation at %s\n", timing_info);
}
@@ -1488,6 +1493,7 @@ sub cc_main {
my $inc_hv = svref_2object(\%INC)->save;
my $inc_av = svref_2object(\@INC)->save;
+ my $amagic_generate= amagic_generation;
return if $errors;
if (!defined($module)) {
$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
@@ -1498,6 +1504,7 @@ sub cc_main {
"GvAV(PL_incgv) = $inc_av;",
"av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
"av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
+ "PL_amagic_generation= $amagic_generate;",
);
}
diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm
index 42c8bc0fd3..828ffac3c0 100644
--- a/ext/B/B/Stash.pm
+++ b/ext/B/B/Stash.pm
@@ -11,12 +11,15 @@ END {
}
sub scan{
my $start=shift;
+ my $prefix=shift;
+ $prefix = '' unless defined $prefix;
my @return;
foreach my $key ( keys %{$start}){
+# print $prefix,$key,"\n";
if ($key =~ /::$/){
unless ($start eq ${$start}{$key} or $key eq "B::" ){
- push @return, $key ;
- foreach my $subscan ( scan(${$start}{$key})){
+ push @return, $key unless omit($prefix.$key);
+ foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){
push @return, "$key".$subscan;
}
}
@@ -24,6 +27,16 @@ sub scan{
}
return @return;
}
-1;
-
+sub omit{
+ my $module = shift;
+ my %omit=("DynaLoader::" => 1 , "CORE::" => 1 ,
+ "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 );
+ return 1 if $omit{$module};
+ if ($module eq "IO::" or $module eq "IO::Handle::"){
+ $module =~ s/::/\//g;
+ return 1 unless $INC{$module};
+ }
+ return 0;
+}
+1;
diff --git a/t/harness b/t/harness
index 88bcb38fba..174b318576 100644
--- a/t/harness
+++ b/t/harness
@@ -19,15 +19,43 @@ $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v';
@tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests;
Test::Harness::runtests @tests;
-
-%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
+exit(0) unless -e "../testcompile";
+
+%infinite = qw(
+ op/bop.t 1
+ lib/hostname.t 1
+ );
+#fudge DATA for now.
+%datahandle = qw(
+ lib/bigint.t 1
+ lib/bigintpm.t 1
+ lib/bigfloat.t 1
+ lib/bigfloatpm.t 1
+ );
+
+my $dhwrapper = <<'EOT';
+open DATA,"<".__FILE__;
+until (($_=<DATA>) =~ /^__END__/) {};
+EOT
@tests = grep (!$infinite{$_}, @tests);
-
-if (-e "../testcompile")
-{
- print "The tests ", join(' ', keys(%infinite)),
- " generate infinite loops! Skipping!\n";
-
- $ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests;
+@tests = map {
+ my $new = $_;
+ if ($datahandle{$_}) {
+ $new .= '.t';
+ local(*F, *T);
+ open(F,"<$_") or die "Can't open $_: $!";
+ open(T,">$new") or die "Can't open $new: $!";
+ print T $dhwrapper, <F>;
+ close F;
+ close T;
+ }
+ $new;
+ } @tests;
+
+print "The tests ", join(' ', keys(%infinite)),
+ " generate infinite loops! Skipping!\n";
+$ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests;
+foreach (keys %datahandle) {
+ unlink "$_.t";
}
View Lorry Controller Status