| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | unshift @INC, 't'; |
| 5 | require Config; |
| 6 | if (($Config::Config{'extensions'} !~ /\bB\b/) ){ |
| 7 | print "1..0 # Skip -- Perl configured without B module\n"; |
| 8 | exit 0; |
| 9 | } |
| 10 | } |
| 11 | |
| 12 | $| = 1; |
| 13 | use warnings; |
| 14 | use strict; |
| 15 | use Test::More; |
| 16 | |
| 17 | BEGIN { use_ok( 'B' ); } |
| 18 | |
| 19 | |
| 20 | package Testing::Symtable; |
| 21 | use vars qw($This @That %wibble $moo %moo); |
| 22 | my $not_a_sym = 'moo'; |
| 23 | |
| 24 | sub moo { 42 } |
| 25 | sub car { 23 } |
| 26 | |
| 27 | |
| 28 | package Testing::Symtable::Foo; |
| 29 | sub yarrow { "Hock" } |
| 30 | |
| 31 | package Testing::Symtable::Bar; |
| 32 | sub hock { "yarrow" } |
| 33 | |
| 34 | package main; |
| 35 | use vars qw(%Subs); |
| 36 | local %Subs = (); |
| 37 | B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ }, |
| 38 | 'Testing::Symtable::'); |
| 39 | |
| 40 | sub B::GV::find_syms { |
| 41 | my($symbol) = @_; |
| 42 | |
| 43 | $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++; |
| 44 | } |
| 45 | |
| 46 | my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car |
| 47 | BEGIN); |
| 48 | push @syms, "Testing::Symtable::Foo::yarrow"; |
| 49 | |
| 50 | # Make sure we hit all the expected symbols. |
| 51 | ok( join('', sort @syms) eq join('', sort keys %Subs), 'all symbols found' ); |
| 52 | |
| 53 | # Make sure we only hit them each once. |
| 54 | ok( (!grep $_ != 1, values %Subs), '...and found once' ); |
| 55 | |
| 56 | # Tests for MAGIC / MOREMAGIC |
| 57 | ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' ); |
| 58 | { |
| 59 | my $e = ''; |
| 60 | local $SIG{__DIE__} = sub { $e = $_[0] }; |
| 61 | # Used to dump core, bug #16828 |
| 62 | eval { B::svref_2object(\$.)->MAGIC->MOREMAGIC->TYPE; }; |
| 63 | like( $e, qr/Can't call method "TYPE" on an undefined value/, |
| 64 | '$. has no more magic' ); |
| 65 | } |
| 66 | |
| 67 | { |
| 68 | my $pie = 'Good'; |
| 69 | # This needs to be a package variable, as vars in the pad have some flags. |
| 70 | my $r = B::svref_2object(\$::data2); |
| 71 | is($r->FLAGS(), 0, "uninitialised package variable has flags of 0"); |
| 72 | is($r->SvTYPE(), 0, "uninitialised package variable has type 0"); |
| 73 | is($r->POK(), 0, "POK false"); |
| 74 | is($r->ROK(), 0, "ROK false"); |
| 75 | is($r->MAGICAL(), 0, "MAGICAL false"); |
| 76 | $::data2 = $pie; |
| 77 | isnt($r->FLAGS(), 0, "initialised package variable has nonzero flags"); |
| 78 | isnt($r->SvTYPE(), 0, "initialised package variable has nonzero type"); |
| 79 | isnt($r->POK(), 0, "POK true"); |
| 80 | is($r->ROK(), 0, "ROK false"); |
| 81 | is($r->MAGICAL(), 0, "MAGICAL false"); |
| 82 | |
| 83 | $::data2 = substr $pie, 0, 1; |
| 84 | isnt($r->FLAGS(), 0, "initialised package variable has nonzero flags"); |
| 85 | isnt($r->SvTYPE(), 0, "initialised package variable has nonzero type"); |
| 86 | isnt($r->POK(), 0, "POK true"); |
| 87 | is($r->ROK(), 0, "ROK false"); |
| 88 | is($r->MAGICAL(), 0, "MAGICAL true"); |
| 89 | |
| 90 | $::data2 = \$pie; |
| 91 | isnt($r->FLAGS(), 0, "initialised package variable has nonzero flags"); |
| 92 | isnt($r->SvTYPE(), 0, "initialised package variable has nonzero type"); |
| 93 | is($r->POK(), 0, "POK false"); |
| 94 | isnt($r->ROK(), 0, "ROK true"); |
| 95 | is($r->MAGICAL(), 0, "MAGICAL false"); |
| 96 | |
| 97 | is($r->REFCNT(), 1, "Reference count is 1"); |
| 98 | { |
| 99 | my $ref = \$::data2; |
| 100 | is($r->REFCNT(), 2, "Second reference"); |
| 101 | } |
| 102 | is($r->REFCNT(), 1, "Reference count is 1"); |
| 103 | |
| 104 | } |
| 105 | |
| 106 | my $r = qr/foo/; |
| 107 | my $obj = B::svref_2object($r); |
| 108 | my $regexp = ($] < 5.011) ? $obj->MAGIC : $obj; |
| 109 | ok($regexp->precomp() eq 'foo', 'Get string from qr//'); |
| 110 | like($regexp->REGEX(), qr/\d+/, "REGEX() returns numeric value"); |
| 111 | my $iv = 1; |
| 112 | my $iv_ref = B::svref_2object(\$iv); |
| 113 | is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); |
| 114 | is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT"); |
| 115 | # Flag tests are needed still |
| 116 | #diag $iv_ref->FLAGS(); |
| 117 | my $iv_ret = $iv_ref->object_2svref(); |
| 118 | is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
| 119 | is($$iv_ret, $iv, "Test object_2svref()"); |
| 120 | is($iv_ref->int_value, $iv, "Test int_value()"); |
| 121 | is($iv_ref->IV, $iv, "Test IV()"); |
| 122 | is($iv_ref->IVX(), $iv, "Test IVX()"); |
| 123 | is($iv_ref->UVX(), $iv, "Test UVX()"); |
| 124 | is(eval { $iv_ref->RV() }, undef, 'Test RV() on IV'); |
| 125 | like($@, qr/argument is not SvROK/, 'Test RV() IV'); |
| 126 | $iv = \"Pie"; |
| 127 | my $val = eval { $iv_ref->RV() }; |
| 128 | is(ref $val, 'B::PV', 'Test RV() on a reference'); |
| 129 | is($val->PV(), 'Pie', 'Value expected'); |
| 130 | is($@, '', "Test RV()"); |
| 131 | |
| 132 | my $pv = "Foo"; |
| 133 | my $pv_ref = B::svref_2object(\$pv); |
| 134 | is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object"); |
| 135 | is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT"); |
| 136 | # Flag tests are needed still |
| 137 | #diag $pv_ref->FLAGS(); |
| 138 | my $pv_ret = $pv_ref->object_2svref(); |
| 139 | is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
| 140 | is($$pv_ret, $pv, "Test object_2svref()"); |
| 141 | is($pv_ref->PV(), $pv, "Test PV()"); |
| 142 | is(eval { $pv_ref->RV() }, undef, 'Test RV() on PV'); |
| 143 | like($@, qr/argument is not SvROK/, 'Test RV() on PV'); |
| 144 | is($pv_ref->PVX(), $pv, "Test PVX()"); |
| 145 | $pv = \"Pie"; |
| 146 | $val = eval { $pv_ref->RV() }; |
| 147 | is(ref $val, 'B::PV', 'Test RV() on a reference'); |
| 148 | is($val->PV(), 'Pie', 'Value expected'); |
| 149 | is($@, '', "Test RV()"); |
| 150 | |
| 151 | my $nv = 1.1; |
| 152 | my $nv_ref = B::svref_2object(\$nv); |
| 153 | is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object"); |
| 154 | is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT"); |
| 155 | # Flag tests are needed still |
| 156 | #diag $nv_ref->FLAGS(); |
| 157 | my $nv_ret = $nv_ref->object_2svref(); |
| 158 | is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
| 159 | is($$nv_ret, $nv, "Test object_2svref()"); |
| 160 | is($nv_ref->NV, $nv, "Test NV()"); |
| 161 | is($nv_ref->NVX(), $nv, "Test NVX()"); |
| 162 | is(eval { $nv_ref->RV() }, undef, 'Test RV() on NV'); |
| 163 | like($@, qr/Can't locate object method "RV" via package "B::NV"/, |
| 164 | 'Test RV() on NV'); |
| 165 | |
| 166 | my $null = undef; |
| 167 | my $null_ref = B::svref_2object(\$null); |
| 168 | is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object"); |
| 169 | is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT"); |
| 170 | # Flag tests are needed still |
| 171 | #diag $null_ref->FLAGS(); |
| 172 | my $null_ret = $nv_ref->object_2svref(); |
| 173 | is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
| 174 | is($$null_ret, $nv, "Test object_2svref()"); |
| 175 | |
| 176 | my $RV_class = $] >= 5.011 ? 'B::IV' : 'B::RV'; |
| 177 | my $cv = sub{ 1; }; |
| 178 | my $cv_ref = B::svref_2object(\$cv); |
| 179 | is($cv_ref->REFCNT, 1, "Test $RV_class->REFCNT"); |
| 180 | is(ref $cv_ref, "$RV_class", |
| 181 | "Test $RV_class return from svref_2object - code"); |
| 182 | my $cv_ret = $cv_ref->object_2svref(); |
| 183 | is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); |
| 184 | is($$cv_ret, $cv, "Test object_2svref()"); |
| 185 | |
| 186 | my $av = []; |
| 187 | my $av_ref = B::svref_2object(\$av); |
| 188 | is(ref $av_ref, "$RV_class", |
| 189 | "Test $RV_class return from svref_2object - array"); |
| 190 | |
| 191 | my $hv = []; |
| 192 | my $hv_ref = B::svref_2object(\$hv); |
| 193 | is(ref $hv_ref, "$RV_class", |
| 194 | "Test $RV_class return from svref_2object - hash"); |
| 195 | |
| 196 | local *gv = *STDOUT; |
| 197 | my $gv_ref = B::svref_2object(\*gv); |
| 198 | is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object"); |
| 199 | ok(! $gv_ref->is_empty(), "Test is_empty()"); |
| 200 | ok($gv_ref->isGV_with_GP(), "Test isGV_with_GP()"); |
| 201 | is($gv_ref->NAME(), "gv", "Test NAME()"); |
| 202 | is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()"); |
| 203 | like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()"); |
| 204 | is($gv_ref->SvTYPE(), B::SVt_PVGV, "Test SvTYPE()"); |
| 205 | is($gv_ref->FLAGS() & B::SVTYPEMASK, B::SVt_PVGV, "Test SVTYPEMASK"); |
| 206 | |
| 207 | # The following return B::SPECIALs. |
| 208 | is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()"); |
| 209 | is(ref B::sv_no(), "B::SPECIAL", "B::sv_no()"); |
| 210 | is(ref B::sv_undef(), "B::SPECIAL", "B::sv_undef()"); |
| 211 | |
| 212 | # More utility functions |
| 213 | is(B::ppname(0), "pp_null", "Testing ppname (this might break if opnames.h is changed)"); |
| 214 | is(B::opnumber("null"), 0, "Testing opnumber with opname (null)"); |
| 215 | is(B::opnumber("pp_null"), 0, "Testing opnumber with opname (pp_null)"); |
| 216 | { |
| 217 | my $hash = B::hash("wibble"); |
| 218 | like($hash, qr/\A0x[0-9a-f]+\z/, "Testing B::hash(\"wibble\")"); |
| 219 | unlike($hash, qr/\A0x0+\z/, "Testing B::hash(\"wibble\")"); |
| 220 | |
| 221 | SKIP: { |
| 222 | skip "Nulls don't hash to the same bucket regardless of length with this PERL_HASH implementation", 20 |
| 223 | if B::hash("") ne B::hash("\0" x 19); |
| 224 | like(B::hash("\0" x $_), qr/\A0x0+\z/, "Testing B::hash(\"0\" x $_)") |
| 225 | for 0..19; |
| 226 | } |
| 227 | |
| 228 | $hash = eval {B::hash(chr 256)}; |
| 229 | is($hash, undef, "B::hash() refuses non-octets"); |
| 230 | like($@, qr/^Wide character in subroutine entry/); |
| 231 | |
| 232 | $hash = B::hash(chr 163); |
| 233 | my $str = chr(163) . chr 256; |
| 234 | chop $str; |
| 235 | is(B::hash($str), $hash, 'B::hash() with chr 128-256 is well-behaved'); |
| 236 | } |
| 237 | { |
| 238 | is(B::cstring(undef), '0', "Testing B::cstring(undef)"); |
| 239 | is(B::perlstring(undef), '0', "Testing B::perlstring(undef)"); |
| 240 | |
| 241 | my @common = map {eval $_, $_} |
| 242 | '"wibble"', '"\""', '"\'"', '"\\\\"', '"\\n\\r\\t\\b\\a\\f"', '"\000"', |
| 243 | '"\000\000"', '"\000Bing\000"', ord 'N' == 78 ? '"\\177"' : (); |
| 244 | |
| 245 | my $oct = sprintf "\\%03o", ord '?'; |
| 246 | my @tests = (@common, '$_', '"$_"', '@_', '"@_"', '??N', qq{"$oct?N"}, |
| 247 | ord 'N' == 78 ? (chr 11, '"\v"'): ()); |
| 248 | while (my ($test, $expect) = splice @tests, 0, 2) { |
| 249 | is(B::cstring($test), $expect, "B::cstring($expect)"); |
| 250 | } |
| 251 | |
| 252 | @tests = (@common, '$_', '"\$_"', '@_', '"\@_"', '??N', '"??N"', |
| 253 | chr 256, '"\x{100}"', chr 65536, '"\x{10000}"', |
| 254 | ord 'N' == 78 ? (chr 11, '"\013"'): ()); |
| 255 | while (my ($test, $expect) = splice @tests, 0, 2) { |
| 256 | is(B::perlstring($test), $expect, "B::perlstring($expect)"); |
| 257 | utf8::upgrade $test; |
| 258 | $expect =~ s/\\b/\\x\{8\}/g; |
| 259 | $expect =~ s/\\([0-7]{3})/sprintf "\\x\{%x\}", oct $1/eg; |
| 260 | is(B::perlstring($test), $expect, "B::perlstring($expect) (Unicode)"); |
| 261 | } |
| 262 | } |
| 263 | { |
| 264 | my @tests = ((map {eval(qq{"$_"}), $_} '\\n', '\\r', '\\t', |
| 265 | '\\b', '\\a', '\\f', '\\000', '\\\'', '?'), '"', '"', |
| 266 | ord 'N' == 78 ? (chr 11, '\v', "\177", '\\177') : ()); |
| 267 | |
| 268 | while (my ($test, $expect) = splice @tests, 0, 2) { |
| 269 | is(B::cchar($test), "'${expect}'", "B::cchar(qq{$expect})"); |
| 270 | } |
| 271 | } |
| 272 | |
| 273 | is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()"); |
| 274 | is(B::cast_I32(3.14), 3, "Testing B::cast_I32()"); |
| 275 | is(B::opnumber("chop"), $] >= 5.015 ? 39 : 38, |
| 276 | "Testing opnumber with opname (chop)"); |
| 277 | |
| 278 | { |
| 279 | no warnings 'once'; |
| 280 | my $sg = B::sub_generation(); |
| 281 | *UNIVERSAL::hand_waving = sub { }; |
| 282 | ok( $sg < B::sub_generation, "sub_generation increments" ); |
| 283 | } |
| 284 | |
| 285 | like( B::amagic_generation, qr/^\d+\z/, "amagic_generation" ); |
| 286 | |
| 287 | is(B::svref_2object(sub {})->ROOT->ppaddr, 'PL_ppaddr[OP_LEAVESUB]', |
| 288 | 'OP->ppaddr'); |
| 289 | |
| 290 | # This one crashes from perl 5.8.9 to B 1.24 (perl 5.13.6): |
| 291 | B::svref_2object(sub{y/\x{100}//})->ROOT->first->first->sibling->sv; |
| 292 | ok 1, 'B knows that UTF trans is a padop in 5.8.9, not an svop'; |
| 293 | |
| 294 | { |
| 295 | format FOO = |
| 296 | foo |
| 297 | . |
| 298 | my $f = B::svref_2object(*FOO{FORMAT}); |
| 299 | isa_ok $f, 'B::FM'; |
| 300 | can_ok $f, 'LINES'; |
| 301 | } |
| 302 | |
| 303 | my $sub1 = sub {die}; |
| 304 | { no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} } |
| 305 | my $sub2 = eval 'package Peel; sub {die}'; |
| 306 | my $cop = B::svref_2object($sub1)->ROOT->first->first; |
| 307 | my $bobby = B::svref_2object($sub2)->ROOT->first->first; |
| 308 | is $cop->stash->object_2svref, \%main::, 'COP->stash'; |
| 309 | is $cop->stashpv, 'main', 'COP->stashpv'; |
| 310 | |
| 311 | SKIP: { |
| 312 | skip "no nulls in packages before 5.17", 1 if $] < 5.017; |
| 313 | is $bobby->stashpv, "Pe\0e\x{142}", 'COP->stashpv with utf8 and nulls'; |
| 314 | } |
| 315 | |
| 316 | SKIP: { |
| 317 | skip "no stashoff", 2 if $] < 5.017 || !$Config::Config{useithreads}; |
| 318 | like $cop->stashoff, qr/^[1-9]\d*\z/a, 'COP->stashoff'; |
| 319 | isnt $cop->stashoff, $bobby->stashoff, |
| 320 | 'different COP->stashoff for different stashes'; |
| 321 | } |
| 322 | |
| 323 | done_testing(); |