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