$| = 1;
use warnings;
use strict;
+BEGIN {
+ eval { require threads; threads->import; }
+}
use Test::More;
BEGIN { use_ok( 'B' ); }
my $regexp = ($] < 5.011) ? $obj->MAGIC : $obj;
ok($regexp->precomp() eq 'foo', 'Get string from qr//');
like($regexp->REGEX(), qr/\d+/, "REGEX() returns numeric value");
+like($regexp->compflags, qr/^\d+\z/, "compflags returns numeric value");
+is B::svref_2object(qr/(?{time})/)->qr_anoncv->ROOT->first->name, 'qr',
+ 'qr_anoncv';
my $iv = 1;
my $iv_ref = B::svref_2object(\$iv);
is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object");
like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()");
is($gv_ref->SvTYPE(), B::SVt_PVGV, "Test SvTYPE()");
is($gv_ref->FLAGS() & B::SVTYPEMASK, B::SVt_PVGV, "Test SVTYPEMASK");
+is($gv_ref->GPFLAGS & B::GPf_ALIASED_SV, 0, 'GPFLAGS are unset');
+{
+ local *gv = \my $x;
+ is($gv_ref->GPFLAGS & B::GPf_ALIASED_SV, B::GPf_ALIASED_SV,
+ 'GPFLAGS gets GPf_ALIASED_SV set');
+}
# The following return B::SPECIALs.
is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()");
is(ref B::sv_no(), "B::SPECIAL", "B::sv_no()");
is(ref B::sv_undef(), "B::SPECIAL", "B::sv_undef()");
+SKIP: {
+ skip('no fork', 1)
+ unless ($Config::Config{d_fork} or $Config::Config{d_pseudofork});
+ my $pid;
+ pipe my $r, my $w or die "Can't pipe: $!";;
+ if ($pid = fork) {
+ close $w;
+ my $type = <$r>;
+ close $r;
+ waitpid($pid,0);
+ is($type, "B::SPECIAL", "special SV table works after psuedofork");
+ }
+ else {
+ close $r;
+ $|++;
+ print $w ref B::svref_2object(\(!!0));
+ close $w;
+ exit;
+ }
+}
# More utility functions
is(B::ppname(0), "pp_null", "Testing ppname (this might break if opnames.h is changed)");
like($hash, qr/\A0x[0-9a-f]+\z/, "Testing B::hash(\"wibble\")");
unlike($hash, qr/\A0x0+\z/, "Testing B::hash(\"wibble\")");
- like(B::hash("\0" x $_), qr/\A0x0+\z/, "Testing B::hash(\"0\" x $_)")
- for 0..19;
+ SKIP: {
+ skip "Nulls don't hash to the same bucket regardless of length with this PERL_HASH implementation", 20
+ if B::hash("") ne B::hash("\0" x 19);
+ like(B::hash("\0" x $_), qr/\A0x0+\z/, "Testing B::hash(\"0\" x $_)")
+ for 0..19;
+ }
$hash = eval {B::hash(chr 256)};
is($hash, undef, "B::hash() refuses non-octets");
while (my ($test, $expect) = splice @tests, 0, 2) {
is(B::perlstring($test), $expect, "B::perlstring($expect)");
utf8::upgrade $test;
- $expect =~ s/\\b/\\x\{8\}/g;
+ $expect =~ s/\\b/sprintf("\\x{%x}", utf8::unicode_to_native(8))/eg;
$expect =~ s/\\([0-7]{3})/sprintf "\\x\{%x\}", oct $1/eg;
is(B::perlstring($test), $expect, "B::perlstring($expect) (Unicode)");
}
is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()");
is(B::cast_I32(3.14), 3, "Testing B::cast_I32()");
-is(B::opnumber("chop"), 39, "Testing opnumber with opname (chop)");
+is(B::opnumber("chop"), $] >= 5.015 ? 39 : 38,
+ "Testing opnumber with opname (chop)");
{
no warnings 'once';
ok 1, 'B knows that UTF trans is a padop in 5.8.9, not an svop';
{
+ my $o = B::svref_2object(sub{0;0})->ROOT->first->first;
+ # Make sure we are testing what we think we are testing. If these two
+ # fail, tweak the test to find a nulled cop a different way.
+ is $o->name, "null", 'first op of sub{0;0} is a null';
+ is B::ppname($o->targ),'pp_nextstate','first op of sub{0;0} was a cop';
+ # Test its class
+ is B::class($o), "COP", 'nulled cops are of class COP';
+}
+
+{
format FOO =
foo
.
can_ok $f, 'LINES';
}
+is B::safename("\cLAST_FH"), "^LAST_FH", 'basic safename test';
+
my $sub1 = sub {die};
+{ no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} }
+my $sub2 = eval 'package Peel; sub {die}';
my $cop = B::svref_2object($sub1)->ROOT->first->first;
+my $bobby = B::svref_2object($sub2)->ROOT->first->first;
is $cop->stash->object_2svref, \%main::, 'COP->stash';
is $cop->stashpv, 'main', 'COP->stashpv';
-if ($Config::Config{useithreads}) {
- like $cop->stashoff, qr/^[1-9]\d*\z/a, 'COP->stashoff'
+
+SKIP: {
+ skip "no nulls in packages before 5.17", 1 if $] < 5.017;
+ is $bobby->stashpv, "Pe\0e\x{142}", 'COP->stashpv with utf8 and nulls';
+}
+
+SKIP: {
+ skip "no stashoff", 2 if $] < 5.017 || !$Config::Config{useithreads};
+ like $cop->stashoff, qr/^[1-9]\d*\z/a, 'COP->stashoff';
+ isnt $cop->stashoff, $bobby->stashoff,
+ 'different COP->stashoff for different stashes';
+}
+
+my $pmop = B::svref_2object(sub{ qr/fit/ })->ROOT->first->first->sibling;
+$regexp = $pmop->pmregexp;
+is B::class($regexp), 'REGEXP', 'B::PMOP::pmregexp returns a regexp';
+is $regexp->precomp, 'fit', 'pmregexp returns the right regexp';
+
+
+# Test $B::overlay
+{
+ my $methods = {
+ BINOP => [ qw(last) ],
+ COP => [ qw(arybase cop_seq file filegv hints hints_hash io
+ label line stash stashpv
+ stashoff warnings) ],
+ LISTOP => [ qw(children) ],
+ LOGOP => [ qw(other) ],
+ LOOP => [ qw(lastop nextop redoop) ],
+ OP => [ qw(desc flags name next opt ppaddr private sibling
+ size spare targ type) ],
+ PADOP => [ qw(gv padix sv) ],
+ PMOP => [ qw(code_list pmflags pmoffset pmreplroot pmreplstart pmstash pmstashpv precomp reflags) ],
+ PVOP => [ qw(pv) ],
+ SVOP => [ qw(gv sv) ],
+ UNOP => [ qw(first) ],
+ };
+
+ my $overlay = {};
+ my $op = B::svref_2object(sub { my $x = 1 })->ROOT;
+
+ for my $class (sort keys %$methods) {
+ for my $meth (@{$methods->{$class}}) {
+ my $full = "B::${class}::$meth";
+ die "Duplicate method '$full'\n"
+ if grep $_ eq $full, @{$overlay->{$meth}};
+ push @{$overlay->{$meth}}, "B::${class}::$meth";
+ }
+ }
+
+ {
+ local $B::overlay; # suppress 'used once' warning
+ local $B::overlay = { $$op => $overlay };
+
+ for my $class (sort keys %$methods) {
+ bless $op, "B::$class"; # naughty
+ for my $meth (@{$methods->{$class}}) {
+ if ($op->can($meth)) {
+ my $list = $op->$meth;
+ ok(defined $list
+ && ref($list) eq "ARRAY"
+ && grep($_ eq "B::${class}::$meth", @$list),
+ "overlay: B::$class $meth");
+ }
+ else {
+ pass("overlay: B::$class $meth (skipped; no method)");
+ }
+ }
+ }
+ }
+ # B::overlay should be disabled again here
+ is($op->name, "leavesub", "overlay: orig name");
+}
+
+{ # [perl #118525]
+ {
+ sub foo {}
+ my $cv = B::svref_2object(\&foo);
+ ok($cv, "make a B::CV from a non-anon sub reference");
+ isa_ok($cv, "B::CV");
+ my $gv = $cv->GV;
+ ok($gv, "we get a GV from a GV on a normal sub");
+ isa_ok($gv, "B::GV");
+ is($gv->NAME, "foo", "check the GV name");
+ SKIP:
+ { # do we need these version checks?
+ skip "no HEK before 5.18", 1 if $] < 5.018;
+ is($cv->NAME_HEK, undef, "no hek for a global sub");
+ }
+ }
+
+SKIP:
+ {
+ skip "no HEK before 5.18", 4 if $] < 5.018;
+ eval <<'EOS'
+ {
+ use feature 'lexical_subs';
+ no warnings 'experimental::lexical_subs';
+ my sub bar {};
+ my $cv = B::svref_2object(\&bar);
+ ok($cv, "make a B::CV from a lexical sub reference");
+ isa_ok($cv, "B::CV");
+ my $hek = $cv->NAME_HEK;
+ is($hek, "bar", "check the NAME_HEK");
+ my $gv = $cv->GV;
+ isa_ok($gv, "B::GV", "GV on a lexical sub");
+ }
+ 1;
+EOS
+ or die "lexical_subs test failed to compile: $@";
+ }
}
+{ # [perl #120535]
+ my %h = ( "\x{100}" => 1 );
+ my $b = B::svref_2object(\%h);
+ my ($k, $v) = $b->ARRAY;
+ is($k, "\x{100}", "check utf8 preserved by B::HV::ARRAY");
+}
+
+# test op_parent
+
+SKIP: {
+ unless ($Config::Config{ccflags} =~ /PERL_OP_PARENT/) {
+ skip "op_parent only present with -DPERL_OP_PARENT builds", 6;
+ }
+ my $lineseq = B::svref_2object(sub{my $x = 1})->ROOT->first;
+ is ($lineseq->type, B::opnumber('lineseq'),
+ 'op_parent: top op is lineseq');
+ my $first = $lineseq->first;
+ my $second = $first->sibling;
+ is(ref $second->sibling, "B::NULL", 'op_parent: second sibling is null');
+ is($first->lastsib, 0 , 'op_parent: first sibling: !lastsib');
+ is($second->lastsib, 1, 'op_parent: second sibling: lastsib');
+ is($$lineseq, ${$first->parent}, 'op_parent: first sibling okay');
+ is($$lineseq, ${$second->parent}, 'op_parent: second sibling okay');
+}
+
+
+# make sure ->sv, -gv methods do the right thing on threaded builds
+{
+
+ # for some reason B::walkoptree only likes a sub name, not a code ref
+ my ($gv, $sv);
+ sub gvsv_const {
+ # make the early pad slots something unlike a threaded const or
+ # gvsv
+ my ($dummy1, $dummy2, $dummy3, $dummy4) = qw(foo1 foo2 foo3 foo4);
+ my $self = shift;
+ if ($self->name eq 'gvsv') {
+ $gv = $self->gv;
+ }
+ elsif ($self->name eq 'const') {
+ $sv = $self->sv;
+ }
+ };
+
+ B::walkoptree(B::svref_2object(sub {our $x = 1})->ROOT, "::gvsv_const");
+ ok(defined $gv, "gvsv->gv seen");
+ ok(defined $sv, "const->sv seen");
+ if ($Config::Config{useithreads}) {
+ # should get NULLs
+ is(ref($gv), "B::SPECIAL", "gvsv->gv is special");
+ is(ref($sv), "B::SPECIAL", "const->sv is special");
+ is($$gv, 0, "gvsv->gv special is 0 (NULL)");
+ is($$sv, 0, "const->sv special is 0 (NULL)");
+ }
+ else {
+ is(ref($gv), "B::GV", "gvsv->gv is GV");
+ is(ref($sv), "B::IV", "const->sv is IV");
+ pass();
+ pass();
+ }
+
+}
+
+
+# Some pad tests
+{
+ my $sub = sub { my main $a; CORE::state @b; our %c };
+ my $padlist = B::svref_2object($sub)->PADLIST;
+ is $padlist->MAX, 1, 'padlist MAX';
+ my @array = $padlist->ARRAY;
+ is @array, 2, 'two items from padlist ARRAY';
+ is ${$padlist->ARRAYelt(0)}, ${$array[0]},
+ 'ARRAYelt(0) is first item from ARRAY';
+ is ${$padlist->ARRAYelt(1)}, ${$array[1]},
+ 'ARRAYelt(1) is second item from ARRAY';
+ is ${$padlist->NAMES}, ${$array[0]},
+ 'NAMES is first item from ARRAY';
+ my @names = $array[0]->ARRAY;
+ cmp_ok @names, ">=", 4, 'at least 4 pad names';
+ is join(" ", map($_->PV//"undef",@names[0..3])), 'undef $a @b %c',
+ 'pad name PVs';
+
+ my @closures;
+ for (1,2) { push @closures, sub { sub { @closures } } }
+ my $sub1 = B::svref_2object($closures[0]);
+ my $sub2 = B::svref_2object($closures[1]);
+ is $sub2->PADLIST->id, $sub1->PADLIST->id, 'padlist id';
+ $sub1 = B::svref_2object(my $lr = $closures[0]());
+ $sub2 = B::svref_2object(my $lr2= $closures[1]());
+ is $sub2->PADLIST->outid, $sub1->PADLIST->outid, 'padlist outid';
+}
+
+
done_testing();
https://perl5.git.perl.org / perl5.git / blobdiff