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; |
2da668d2 |
25 | use Test::More tests => 53; |
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 | |
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 |
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); |