1#!./perl 2 3BEGIN { 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; 13use warnings; 14use strict; 15use Test::More tests => 57; 16 17BEGIN { use_ok( 'B' ); } 18 19 20package Testing::Symtable; 21use vars qw($This @That %wibble $moo %moo); 22my $not_a_sym = 'moo'; 23 24sub moo { 42 } 25sub car { 23 } 26 27 28package Testing::Symtable::Foo; 29sub yarrow { "Hock" } 30 31package Testing::Symtable::Bar; 32sub hock { "yarrow" } 33 34package main; 35use vars qw(%Subs); 36local %Subs = (); 37B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ }, 38 'Testing::Symtable::'); 39 40sub B::GV::find_syms { 41 my($symbol) = @_; 42 43 $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++; 44} 45 46my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car 47 BEGIN); 48push @syms, "Testing::Symtable::Foo::yarrow"; 49 50# Make sure we hit all the expected symbols. 51ok( join('', sort @syms) eq join('', sort keys %Subs), 'all symbols found' ); 52 53# Make sure we only hit them each once. 54ok( (!grep $_ != 1, values %Subs), '...and found once' ); 55 56# Tests for MAGIC / MOREMAGIC 57ok( 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 67my $r = qr/foo/; 68my $obj = B::svref_2object($r); 69my $regexp = ($] < 5.011) ? $obj->MAGIC : $obj; 70ok($regexp->precomp() eq 'foo', 'Get string from qr//'); 71like($regexp->REGEX(), qr/\d+/, "REGEX() returns numeric value"); 72my $iv = 1; 73my $iv_ref = B::svref_2object(\$iv); 74is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); 75is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT"); 76# Flag tests are needed still 77#diag $iv_ref->FLAGS(); 78my $iv_ret = $iv_ref->object_2svref(); 79is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); 80is($$iv_ret, $iv, "Test object_2svref()"); 81is($iv_ref->int_value, $iv, "Test int_value()"); 82is($iv_ref->IV, $iv, "Test IV()"); 83is($iv_ref->IVX(), $iv, "Test IVX()"); 84is($iv_ref->UVX(), $iv, "Test UVX()"); 85 86my $pv = "Foo"; 87my $pv_ref = B::svref_2object(\$pv); 88is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object"); 89is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT"); 90# Flag tests are needed still 91#diag $pv_ref->FLAGS(); 92my $pv_ret = $pv_ref->object_2svref(); 93is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); 94is($$pv_ret, $pv, "Test object_2svref()"); 95is($pv_ref->PV(), $pv, "Test PV()"); 96eval { is($pv_ref->RV(), $pv, "Test RV()"); }; 97ok($@, "Test RV()"); 98is($pv_ref->PVX(), $pv, "Test PVX()"); 99 100my $nv = 1.1; 101my $nv_ref = B::svref_2object(\$nv); 102is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object"); 103is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT"); 104# Flag tests are needed still 105#diag $nv_ref->FLAGS(); 106my $nv_ret = $nv_ref->object_2svref(); 107is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); 108is($$nv_ret, $nv, "Test object_2svref()"); 109is($nv_ref->NV, $nv, "Test NV()"); 110is($nv_ref->NVX(), $nv, "Test NVX()"); 111 112my $null = undef; 113my $null_ref = B::svref_2object(\$null); 114is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object"); 115is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT"); 116# Flag tests are needed still 117#diag $null_ref->FLAGS(); 118my $null_ret = $nv_ref->object_2svref(); 119is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); 120is($$null_ret, $nv, "Test object_2svref()"); 121 122my $RV_class = $] >= 5.011 ? 'B::IV' : 'B::RV'; 123my $cv = sub{ 1; }; 124my $cv_ref = B::svref_2object(\$cv); 125is($cv_ref->REFCNT, 1, "Test $RV_class->REFCNT"); 126is(ref $cv_ref, "$RV_class", 127 "Test $RV_class return from svref_2object - code"); 128my $cv_ret = $cv_ref->object_2svref(); 129is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); 130is($$cv_ret, $cv, "Test object_2svref()"); 131 132my $av = []; 133my $av_ref = B::svref_2object(\$av); 134is(ref $av_ref, "$RV_class", 135 "Test $RV_class return from svref_2object - array"); 136 137my $hv = []; 138my $hv_ref = B::svref_2object(\$hv); 139is(ref $hv_ref, "$RV_class", 140 "Test $RV_class return from svref_2object - hash"); 141 142local *gv = *STDOUT; 143my $gv_ref = B::svref_2object(\*gv); 144is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object"); 145ok(! $gv_ref->is_empty(), "Test is_empty()"); 146is($gv_ref->NAME(), "gv", "Test NAME()"); 147is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()"); 148like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()"); 149 150# The following return B::SPECIALs. 151is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()"); 152is(ref B::sv_no(), "B::SPECIAL", "B::sv_no()"); 153is(ref B::sv_undef(), "B::SPECIAL", "B::sv_undef()"); 154 155# More utility functions 156is(B::ppname(0), "pp_null", "Testing ppname (this might break if opnames.h is changed)"); 157is(B::opnumber("null"), 0, "Testing opnumber with opname (null)"); 158is(B::opnumber("pp_null"), 0, "Testing opnumber with opname (pp_null)"); 159like(B::hash("wibble"), qr/0x[0-9a-f]*/, "Testing B::hash()"); 160is(B::cstring("wibble"), '"wibble"', "Testing B::cstring()"); 161is(B::perlstring("wibble"), '"wibble"', "Testing B::perlstring()"); 162is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()"); 163is(B::cast_I32(3.14), 3, "Testing B::cast_I32()"); 164is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)"); 165 166{ 167 no warnings 'once'; 168 my $sg = B::sub_generation(); 169 *UNIVERSAL::hand_waving = sub { }; 170 ok( $sg < B::sub_generation, "sub_generation increments" ); 171} 172 173{ 174 my $ag = B::amagic_generation(); 175 { 176 177 package Whatever; 178 require overload; 179 overload->import( '""' => sub {"What? You want more?!"} ); 180 } 181 ok( $ag < B::amagic_generation, "amagic_generation increments" ); 182} 183