Commit | Line | Data |
ccc418af |
1 | #!./perl |
2 | |
3 | BEGIN { |
5638aaac |
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 |
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 |
20 | } |
21 | |
22 | $| = 1; |
23 | use warnings; |
24 | use strict; |
5ce57cc0 |
25 | use Test::More tests => 57; |
ccc418af |
26 | |
c5f0f3aa |
27 | BEGIN { use_ok( 'B' ); } |
ccc418af |
28 | |
08c6f5ec |
29 | |
87a42246 |
30 | package Testing::Symtable; |
31 | use vars qw($This @That %wibble $moo %moo); |
32 | my $not_a_sym = 'moo'; |
ccc418af |
33 | |
87a42246 |
34 | sub moo { 42 } |
35 | sub car { 23 } |
ccc418af |
36 | |
f70490b9 |
37 | |
87a42246 |
38 | package Testing::Symtable::Foo; |
39 | sub yarrow { "Hock" } |
f70490b9 |
40 | |
87a42246 |
41 | package Testing::Symtable::Bar; |
42 | sub hock { "yarrow" } |
9b86dfa2 |
43 | |
87a42246 |
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 |
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 |
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 |
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 |
76 | |
5c35adbb |
77 | my $r = qr/foo/; |
78 | my $obj = B::svref_2object($r); |
79 | my $regexp = ($] < 5.011) ? $obj->MAGIC : $obj; |
80 | ok($regexp->precomp() eq 'foo', 'Get string from qr//'); |
81 | like($regexp->REGEX(), qr/\d+/, "REGEX() returns numeric value"); |
01b509b0 |
82 | my $iv = 1; |
83 | my $iv_ref = B::svref_2object(\$iv); |
84 | is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object"); |
85 | is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT"); |
86 | # Flag tests are needed still |
87 | #diag $iv_ref->FLAGS(); |
88 | my $iv_ret = $iv_ref->object_2svref(); |
89 | is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
90 | is($$iv_ret, $iv, "Test object_2svref()"); |
91 | is($iv_ref->int_value, $iv, "Test int_value()"); |
92 | is($iv_ref->IV, $iv, "Test IV()"); |
93 | is($iv_ref->IVX(), $iv, "Test IVX()"); |
94 | is($iv_ref->UVX(), $iv, "Test UVX()"); |
95 | |
96 | my $pv = "Foo"; |
97 | my $pv_ref = B::svref_2object(\$pv); |
98 | is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object"); |
99 | is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT"); |
100 | # Flag tests are needed still |
101 | #diag $pv_ref->FLAGS(); |
102 | my $pv_ret = $pv_ref->object_2svref(); |
103 | is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
104 | is($$pv_ret, $pv, "Test object_2svref()"); |
105 | is($pv_ref->PV(), $pv, "Test PV()"); |
106 | eval { is($pv_ref->RV(), $pv, "Test RV()"); }; |
107 | ok($@, "Test RV()"); |
108 | is($pv_ref->PVX(), $pv, "Test PVX()"); |
109 | |
110 | my $nv = 1.1; |
111 | my $nv_ref = B::svref_2object(\$nv); |
112 | is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object"); |
113 | is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT"); |
114 | # Flag tests are needed still |
115 | #diag $nv_ref->FLAGS(); |
116 | my $nv_ret = $nv_ref->object_2svref(); |
117 | is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
118 | is($$nv_ret, $nv, "Test object_2svref()"); |
119 | is($nv_ref->NV, $nv, "Test NV()"); |
120 | is($nv_ref->NVX(), $nv, "Test NVX()"); |
121 | |
122 | my $null = undef; |
123 | my $null_ref = B::svref_2object(\$null); |
124 | is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object"); |
125 | is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT"); |
126 | # Flag tests are needed still |
127 | #diag $null_ref->FLAGS(); |
128 | my $null_ret = $nv_ref->object_2svref(); |
129 | is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR"); |
130 | is($$null_ret, $nv, "Test object_2svref()"); |
131 | |
4df7f6af |
132 | my $RV_class = $] >= 5.011 ? 'B::IV' : 'B::RV'; |
01b509b0 |
133 | my $cv = sub{ 1; }; |
134 | my $cv_ref = B::svref_2object(\$cv); |
4df7f6af |
135 | is($cv_ref->REFCNT, 1, "Test $RV_class->REFCNT"); |
136 | is(ref $cv_ref, "$RV_class", |
137 | "Test $RV_class return from svref_2object - code"); |
01b509b0 |
138 | my $cv_ret = $cv_ref->object_2svref(); |
139 | is(ref $cv_ret, "REF", "Test object_2svref() return is REF"); |
140 | is($$cv_ret, $cv, "Test object_2svref()"); |
141 | |
142 | my $av = []; |
143 | my $av_ref = B::svref_2object(\$av); |
4df7f6af |
144 | is(ref $av_ref, "$RV_class", |
145 | "Test $RV_class return from svref_2object - array"); |
01b509b0 |
146 | |
147 | my $hv = []; |
148 | my $hv_ref = B::svref_2object(\$hv); |
4df7f6af |
149 | is(ref $hv_ref, "$RV_class", |
150 | "Test $RV_class return from svref_2object - hash"); |
01b509b0 |
151 | |
152 | local *gv = *STDOUT; |
153 | my $gv_ref = B::svref_2object(\*gv); |
154 | is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object"); |
155 | ok(! $gv_ref->is_empty(), "Test is_empty()"); |
156 | is($gv_ref->NAME(), "gv", "Test NAME()"); |
157 | is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()"); |
158 | like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()"); |
2da668d2 |
159 | |
160 | # The following return B::SPECIALs. |
161 | is(ref B::sv_yes(), "B::SPECIAL", "B::sv_yes()"); |
162 | is(ref B::sv_no(), "B::SPECIAL", "B::sv_no()"); |
163 | is(ref B::sv_undef(), "B::SPECIAL", "B::sv_undef()"); |
164 | |
165 | # More utility functions |
166 | is(B::ppname(0), "pp_null", "Testing ppname (this might break if opnames.h is changed)"); |
167 | is(B::opnumber("null"), 0, "Testing opnumber with opname (null)"); |
168 | is(B::opnumber("pp_null"), 0, "Testing opnumber with opname (pp_null)"); |
169 | like(B::hash("wibble"), qr/0x[0-9a-f]*/, "Testing B::hash()"); |
170 | is(B::cstring("wibble"), '"wibble"', "Testing B::cstring()"); |
171 | is(B::perlstring("wibble"), '"wibble"', "Testing B::perlstring()"); |
172 | is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()"); |
173 | is(B::cast_I32(3.14), 3, "Testing B::cast_I32()"); |
fdecdb95 |
174 | is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)"); |
5ce57cc0 |
175 | |
176 | { |
177 | no warnings 'once'; |
178 | my $sg = B::sub_generation(); |
e1a479c5 |
179 | *UNIVERSAL::hand_waving = sub { }; |
5ce57cc0 |
180 | ok( $sg < B::sub_generation, "sub_generation increments" ); |
181 | } |
182 | |
183 | { |
184 | my $ag = B::amagic_generation(); |
185 | { |
186 | |
187 | package Whatever; |
188 | require overload; |
189 | overload->import( '""' => sub {"What? You want more?!"} ); |
190 | } |
191 | ok( $ag < B::amagic_generation, "amagic_generation increments" ); |
192 | } |