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