Commit | Line | Data |
---|---|---|
ccc418af GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
5638aaac SM |
4 | if ($ENV{PERL_CORE}){ |
5 | chdir('t') if -d 't'; | |
6 | if ($^O eq 'MacOS') { | |
7 | @INC = qw(: ::lib ::macos:lib); | |
8 | } else { | |
9 | @INC = '.'; | |
10 | push @INC, '../lib'; | |
11 | } | |
1b026014 | 12 | } else { |
5638aaac | 13 | unshift @INC, 't'; |
db5fd395 | 14 | } |
9cd8f857 NC |
15 | require Config; |
16 | if (($Config::Config{'extensions'} !~ /\bB\b/) ){ | |
17 | print "1..0 # Skip -- Perl configured without B module\n"; | |
18 | exit 0; | |
19 | } | |
ccc418af GS |
20 | } |
21 | ||
22 | $| = 1; | |
23 | use warnings; | |
24 | use strict; | |
2da668d2 | 25 | use Test::More tests => 53; |
ccc418af | 26 | |
c5f0f3aa | 27 | BEGIN { use_ok( 'B' ); } |
ccc418af | 28 | |
08c6f5ec | 29 | |
87a42246 MS |
30 | package Testing::Symtable; |
31 | use vars qw($This @That %wibble $moo %moo); | |
32 | my $not_a_sym = 'moo'; | |
ccc418af | 33 | |
87a42246 MS |
34 | sub moo { 42 } |
35 | sub car { 23 } | |
ccc418af | 36 | |
f70490b9 | 37 | |
87a42246 MS |
38 | package Testing::Symtable::Foo; |
39 | sub yarrow { "Hock" } | |
f70490b9 | 40 | |
87a42246 MS |
41 | package Testing::Symtable::Bar; |
42 | sub hock { "yarrow" } | |
9b86dfa2 | 43 | |
87a42246 MS |
44 | package main; |
45 | use vars qw(%Subs); | |
46 | local %Subs = (); | |
47 | B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ }, | |
48 | 'Testing::Symtable::'); | |
ccc418af | 49 | |
87a42246 MS |
50 | sub B::GV::find_syms { |
51 | my($symbol) = @_; | |
de3f1649 | 52 | |
87a42246 | 53 | $main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++; |
cfe9256d | 54 | } |
ccc418af | 55 | |
87a42246 MS |
56 | my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car |
57 | BEGIN); | |
58 | push @syms, "Testing::Symtable::Foo::yarrow"; | |
ccc418af | 59 | |
87a42246 | 60 | # Make sure we hit all the expected symbols. |
c5f0f3aa | 61 | ok( join('', sort @syms) eq join('', sort keys %Subs), 'all symbols found' ); |
1e1dbab6 | 62 | |
87a42246 | 63 | # Make sure we only hit them each once. |
c5f0f3aa RGS |
64 | ok( (!grep $_ != 1, values %Subs), '...and found once' ); |
65 | ||
66 | # Tests for MAGIC / MOREMAGIC | |
67 | ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' ); | |
68 | { | |
69 | my $e = ''; | |
70 | local $SIG{__DIE__} = sub { $e = $_[0] }; | |
71 | # Used to dump core, bug #16828 | |
72 | eval { B::svref_2object(\$.)->MAGIC->MOREMAGIC->TYPE; }; | |
73 | like( $e, qr/Can't call method "TYPE" on an undefined value/, | |
74 | '$. has no more magic' ); | |
75 | } | |
01b509b0 SP |
76 | |
77 | my $iv = 1; | |
78 | my $iv_ref = B::svref_2object(\$iv); | |
79 | is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); | |
80 | is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT"); | |
81 | # Flag tests are needed still | |
82 | #diag $iv_ref->FLAGS(); | |
83 | my $iv_ret = $iv_ref->object_2svref(); | |
84 | is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); | |
85 | is($$iv_ret, $iv, "Test object_2svref()"); | |
86 | is($iv_ref->int_value, $iv, "Test int_value()"); | |
87 | is($iv_ref->IV, $iv, "Test IV()"); | |
88 | is($iv_ref->IVX(), $iv, "Test IVX()"); | |
89 | is($iv_ref->UVX(), $iv, "Test UVX()"); | |
90 | ||
91 | my $pv = "Foo"; | |
92 | my $pv_ref = B::svref_2object(\$pv); | |
93 | is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object"); | |
94 | is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT"); | |
95 | # Flag tests are needed still | |
96 | #diag $pv_ref->FLAGS(); | |
97 | my $pv_ret = $pv_ref->object_2svref(); | |
98 | is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); | |
99 | is($$pv_ret, $pv, "Test object_2svref()"); | |
100 | is($pv_ref->PV(), $pv, "Test PV()"); | |
101 | eval { is($pv_ref->RV(), $pv, "Test RV()"); }; | |
102 | ok($@, "Test RV()"); | |
103 | is($pv_ref->PVX(), $pv, "Test PVX()"); | |
104 | ||
105 | my $nv = 1.1; | |
106 | my $nv_ref = B::svref_2object(\$nv); | |
107 | is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object"); | |
108 | is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT"); | |
109 | # Flag tests are needed still | |
110 | #diag $nv_ref->FLAGS(); | |
111 | my $nv_ret = $nv_ref->object_2svref(); | |
112 | is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); | |
113 | is($$nv_ret, $nv, "Test object_2svref()"); | |
114 | is($nv_ref->NV, $nv, "Test NV()"); | |
115 | is($nv_ref->NVX(), $nv, "Test NVX()"); | |
116 | ||
117 | my $null = undef; | |
118 | my $null_ref = B::svref_2object(\$null); | |
119 | is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object"); | |
120 | is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT"); | |
121 | # Flag tests are needed still | |
122 | #diag $null_ref->FLAGS(); | |
123 | my $null_ret = $nv_ref->object_2svref(); | |
124 | is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); | |
125 | is($$null_ret, $nv, "Test object_2svref()"); | |
126 | ||
127 | my $cv = sub{ 1; }; | |
128 | my $cv_ref = B::svref_2object(\$cv); | |
129 | is($cv_ref->REFCNT, 1, "Test B::RV->REFCNT"); | |
130 | is(ref $cv_ref, "B::RV", "Test B::RV return from svref_2object - code"); | |
131 | my $cv_ret = $cv_ref->object_2svref(); | |
132 | is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); | |
133 | is($$cv_ret, $cv, "Test object_2svref()"); | |
134 | ||
135 | my $av = []; | |
136 | my $av_ref = B::svref_2object(\$av); | |
137 | is(ref $av_ref, "B::RV", "Test B::RV return from svref_2object - array"); | |
138 | ||
139 | my $hv = []; | |
140 | my $hv_ref = B::svref_2object(\$hv); | |
141 | is(ref $hv_ref, "B::RV", "Test B::RV return from svref_2object - hash"); | |
142 | ||
143 | local *gv = *STDOUT; | |
144 | my $gv_ref = B::svref_2object(\*gv); | |
145 | is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object"); | |
146 | ok(! $gv_ref->is_empty(), "Test is_empty()"); | |
147 | is($gv_ref->NAME(), "gv", "Test NAME()"); | |
148 | is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()"); | |
149 | like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()"); | |
2da668d2 SP |
150 | |
151 | # The following return B::SPECIALs. | |
152 | is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()"); | |
153 | is(ref B::sv_no(), "B::SPECIAL", "B::sv_no()"); | |
154 | is(ref B::sv_undef(), "B::SPECIAL", "B::sv_undef()"); | |
155 | ||
156 | # More utility functions | |
157 | is(B::ppname(0), "pp_null", "Testing ppname (this might break if opnames.h is changed)"); | |
158 | is(B::opnumber("null"), 0, "Testing opnumber with opname (null)"); | |
159 | is(B::opnumber("pp_null"), 0, "Testing opnumber with opname (pp_null)"); | |
160 | like(B::hash("wibble"), qr/0x[0-9a-f]*/, "Testing B::hash()"); | |
161 | is(B::cstring("wibble"), '"wibble"', "Testing B::cstring()"); | |
162 | is(B::perlstring("wibble"), '"wibble"', "Testing B::perlstring()"); | |
163 | is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()"); | |
164 | is(B::cast_I32(3.14), 3, "Testing B::cast_I32()"); | |
165 | is(B::opnumber("localtime"), 294); |