Commit | Line | Data |
---|---|---|
ccc418af GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
1b026014 NIS |
5 | if ($^O eq 'MacOS') { |
6 | @INC = qw(: ::lib ::macos:lib); | |
7 | } else { | |
8 | @INC = '.'; | |
9 | push @INC, '../lib'; | |
db5fd395 | 10 | } |
9cd8f857 NC |
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 GS |
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 MS |
26 | package Testing::Symtable; |
27 | use vars qw($This @That %wibble $moo %moo); | |
28 | my $not_a_sym = 'moo'; | |
ccc418af | 29 | |
87a42246 MS |
30 | sub moo { 42 } |
31 | sub car { 23 } | |
ccc418af | 32 | |
f70490b9 | 33 | |
87a42246 MS |
34 | package Testing::Symtable::Foo; |
35 | sub yarrow { "Hock" } | |
f70490b9 | 36 | |
87a42246 MS |
37 | package Testing::Symtable::Bar; |
38 | sub hock { "yarrow" } | |
9b86dfa2 | 39 | |
87a42246 MS |
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 MS |
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 MS |
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 RGS |
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 SP |
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()"); |