Commit | Line | Data |
b9894134 |
1 | #!./perl |
2 | |
3 | # |
4 | # various typeglob tests |
5 | # |
6 | |
9f1b1f2d |
7 | BEGIN { |
8 | chdir 't' if -d 't'; |
20822f61 |
9 | @INC = '../lib'; |
98e007d4 |
10 | } |
9f1b1f2d |
11 | |
12 | use warnings; |
13 | |
98e007d4 |
14 | require './test.pl'; |
e15faf7d |
15 | plan( tests => 68 ); |
b9894134 |
16 | |
17 | # type coersion on assignment |
18 | $foo = 'foo'; |
19 | $bar = *main::foo; |
20 | $bar = $foo; |
98e007d4 |
21 | is(ref(\$bar), 'SCALAR'); |
b9894134 |
22 | $foo = *main::bar; |
23 | |
24 | # type coersion (not) on misc ops |
25 | |
98e007d4 |
26 | ok($foo); |
27 | is(ref(\$foo), 'GLOB'); |
b9894134 |
28 | |
98e007d4 |
29 | unlike ($foo, qr/abcd/); |
30 | is(ref(\$foo), 'GLOB'); |
b9894134 |
31 | |
98e007d4 |
32 | is($foo, '*main::bar'); |
33 | is(ref(\$foo), 'GLOB'); |
b9894134 |
34 | |
35 | # type coersion on substitutions that match |
36 | $a = *main::foo; |
37 | $b = $a; |
38 | $a =~ s/^X//; |
98e007d4 |
39 | is(ref(\$a), 'GLOB'); |
b9894134 |
40 | $a =~ s/^\*//; |
98e007d4 |
41 | is($a, 'main::foo'); |
42 | is(ref(\$b), 'GLOB'); |
b9894134 |
43 | |
44 | # typeglobs as lvalues |
45 | substr($foo, 0, 1) = "XXX"; |
98e007d4 |
46 | is(ref(\$foo), 'SCALAR'); |
47 | is($foo, 'XXXmain::bar'); |
b9894134 |
48 | |
49 | # returning glob values |
50 | sub foo { |
51 | local($bar) = *main::foo; |
52 | $foo = *main::bar; |
53 | return ($foo, $bar); |
54 | } |
55 | |
56 | ($fuu, $baa) = foo(); |
98e007d4 |
57 | ok(defined $fuu); |
58 | is(ref(\$fuu), 'GLOB'); |
b9894134 |
59 | |
98e007d4 |
60 | |
61 | ok(defined $baa); |
62 | is(ref(\$baa), 'GLOB'); |
b9894134 |
63 | |
85aff577 |
64 | # nested package globs |
65 | # NOTE: It's probably OK if these semantics change, because the |
66 | # fact that %X::Y:: is stored in %X:: isn't documented. |
67 | # (I hope.) |
68 | |
9f1b1f2d |
69 | { package Foo::Bar; no warnings 'once'; $test=1; } |
98e007d4 |
70 | ok(exists $Foo::{'Bar::'}); |
71 | is($Foo::{'Bar::'}, '*Foo::Bar::'); |
72 | |
20408e3c |
73 | |
74 | # test undef operator clearing out entire glob |
75 | $foo = 'stuff'; |
76 | @foo = qw(more stuff); |
77 | %foo = qw(even more random stuff); |
78 | undef *foo; |
98e007d4 |
79 | is ($foo, undef); |
80 | is (scalar @foo, 0); |
81 | is (scalar %foo, 0); |
20408e3c |
82 | |
20408e3c |
83 | { |
98e007d4 |
84 | # test warnings from assignment of undef to glob |
85 | my $msg = ''; |
20408e3c |
86 | local $SIG{__WARN__} = sub { $msg = $_[0] }; |
9f1b1f2d |
87 | use warnings; |
20408e3c |
88 | *foo = 'bar'; |
98e007d4 |
89 | is($msg, ''); |
20408e3c |
90 | *foo = undef; |
98e007d4 |
91 | like($msg, qr/Undefined value assigned to typeglob/); |
20408e3c |
92 | } |
640b9ef6 |
93 | |
98e007d4 |
94 | my $test = curr_test(); |
640b9ef6 |
95 | # test *glob{THING} syntax |
98e007d4 |
96 | $x = "ok $test\n"; |
97 | ++$test; |
98 | @x = ("ok $test\n"); |
99 | ++$test; |
100 | %x = ("ok $test" => "\n"); |
101 | ++$test; |
102 | sub x { "ok $test\n" } |
640b9ef6 |
103 | print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; |
98e007d4 |
104 | # This needs to go here, after the print, as sub x will return the current |
105 | # value of test |
106 | ++$test; |
f4d13ee9 |
107 | format x = |
98e007d4 |
108 | XXX This text isn't used. Should it be? |
f4d13ee9 |
109 | . |
98e007d4 |
110 | curr_test($test); |
111 | |
112 | is (ref *x{FORMAT}, "FORMAT"); |
640b9ef6 |
113 | *x = *STDOUT; |
98e007d4 |
114 | is (*{*x{GLOB}}, "*main::STDOUT"); |
39b99f21 |
115 | |
29a56bd6 |
116 | { |
98e007d4 |
117 | my $test = curr_test(); |
118 | |
119 | print {*x{IO}} "ok $test\n"; |
120 | ++$test; |
121 | |
122 | my $warn; |
123 | local $SIG{__WARN__} = sub { |
124 | $warn .= $_[0]; |
125 | }; |
126 | my $val = *x{FILEHANDLE}; |
127 | print {*x{IO}} ($warn =~ /is deprecated/ |
128 | ? "ok $test\n" : "not ok $test\n"); |
129 | curr_test(++$test); |
29a56bd6 |
130 | } |
131 | |
35cd451c |
132 | |
133 | { |
98e007d4 |
134 | # test if defined() doesn't create any new symbols |
35cd451c |
135 | |
136 | my $a = "SYM000"; |
98e007d4 |
137 | ok(!defined *{$a}); |
35cd451c |
138 | |
98e007d4 |
139 | ok(!defined @{$a}); |
140 | ok(!defined *{$a}); |
35cd451c |
141 | |
98e007d4 |
142 | ok(!defined %{$a}); |
143 | ok(!defined *{$a}); |
35cd451c |
144 | |
98e007d4 |
145 | ok(!defined ${$a}); |
146 | ok(!defined *{$a}); |
35cd451c |
147 | |
98e007d4 |
148 | ok(!defined &{$a}); |
149 | ok(!defined *{$a}); |
35cd451c |
150 | |
98e007d4 |
151 | my $state = "not"; |
152 | *{$a} = sub { $state = "ok" }; |
153 | ok(defined &{$a}); |
154 | ok(defined *{$a}); |
155 | &{$a}; |
156 | is ($state, 'ok'); |
35cd451c |
157 | } |
640b9ef6 |
158 | |
c9d5ac95 |
159 | { |
98e007d4 |
160 | # although it *should* if you're talking about magicals |
c9d5ac95 |
161 | |
162 | my $a = "]"; |
98e007d4 |
163 | ok(defined ${$a}); |
164 | ok(defined *{$a}); |
c9d5ac95 |
165 | |
166 | $a = "1"; |
167 | "o" =~ /(o)/; |
98e007d4 |
168 | ok(${$a}); |
169 | ok(defined *{$a}); |
c9d5ac95 |
170 | $a = "2"; |
98e007d4 |
171 | ok(!${$a}); |
172 | ok(defined *{$a}); |
c9d5ac95 |
173 | $a = "1x"; |
98e007d4 |
174 | ok(!defined ${$a}); |
175 | ok(!defined *{$a}); |
c9d5ac95 |
176 | $a = "11"; |
177 | "o" =~ /(((((((((((o)))))))))))/; |
98e007d4 |
178 | ok(${$a}); |
179 | ok(defined *{$a}); |
c9d5ac95 |
180 | } |
181 | |
bd2155e9 |
182 | # [ID 20010526.001] localized glob loses value when assigned to |
183 | |
184 | $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{}; |
185 | |
98e007d4 |
186 | is($j, 1); |
187 | is($j{a}, 1); |
188 | is($j[0], 1); |
99491443 |
189 | |
190 | { |
98e007d4 |
191 | # does pp_readline() handle glob-ness correctly? |
99491443 |
192 | my $g = *foo; |
193 | $g = <DATA>; |
98e007d4 |
194 | is ($g, "Perl\n"); |
99491443 |
195 | } |
196 | |
fb24441d |
197 | { |
198 | my $w = ''; |
199 | $SIG{__WARN__} = sub { $w = $_[0] }; |
200 | sub abc1 (); |
201 | local *abc1 = sub { }; |
98e007d4 |
202 | is ($w, ''); |
fb24441d |
203 | sub abc2 (); |
204 | local *abc2; |
205 | *abc2 = sub { }; |
98e007d4 |
206 | is ($w, ''); |
fb24441d |
207 | sub abc3 (); |
208 | *abc3 = sub { }; |
98e007d4 |
209 | like ($w, qr/Prototype mismatch/); |
fb24441d |
210 | } |
211 | |
2b5e58c4 |
212 | { |
213 | # [17375] rcatline to formerly-defined undef was broken. Fixed in |
214 | # do_readline by checking SvOK. AMS, 20020918 |
215 | my $x = "not "; |
216 | $x = undef; |
217 | $x .= <DATA>; |
98e007d4 |
218 | is ($x, "Rules\n"); |
2b5e58c4 |
219 | } |
220 | |
4ce457a6 |
221 | { |
222 | # test the assignment of a GLOB to an LVALUE |
223 | my $e = ''; |
224 | local $SIG{__DIE__} = sub { $e = $_[0] }; |
225 | my $v; |
226 | sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } |
227 | f($v); |
98e007d4 |
228 | is ($v, '*main::DATA'); |
4ce457a6 |
229 | my $x = <$v>; |
98e007d4 |
230 | is ($x, "perl\n"); |
4ce457a6 |
231 | } |
232 | |
98e007d4 |
233 | { |
234 | $e = ''; |
4ce457a6 |
235 | # GLOB assignment to tied element |
236 | local $SIG{__DIE__} = sub { $e = $_[0] }; |
98e007d4 |
237 | sub T::TIEARRAY { bless [] => "T" } |
238 | sub T::STORE { $_[0]->[ $_[1] ] = $_[2] } |
239 | sub T::FETCH { $_[0]->[ $_[1] ] } |
240 | sub T::FETCHSIZE { @{$_[0]} } |
4ce457a6 |
241 | tie my @ary => "T"; |
242 | $ary[0] = *DATA; |
98e007d4 |
243 | is ($ary[0], '*main::DATA'); |
244 | is ($e, ''); |
4ce457a6 |
245 | my $x = readline $ary[0]; |
98e007d4 |
246 | is($x, "rocks\n"); |
4ce457a6 |
247 | } |
248 | |
e15faf7d |
249 | { |
4184c77b |
250 | # Need some sort of die or warn to get the global destruction text if the |
251 | # bug is still present |
5c2a9b31 |
252 | my $output = runperl(prog => <<'EOPROG'); |
e15faf7d |
253 | package M; |
5c2a9b31 |
254 | $| = 1; |
4184c77b |
255 | sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@} |
e15faf7d |
256 | package main; |
257 | |
258 | bless \$A::B, 'M'; |
259 | *A:: = \*B::; |
260 | EOPROG |
261 | like($output, qr/^Farewell M=SCALAR/, "DESTROY was called"); |
262 | unlike($output, qr/global destruction/, |
263 | "unreferenced symbol tables should be cleaned up immediately"); |
264 | } |
99491443 |
265 | __END__ |
98e007d4 |
266 | Perl |
267 | Rules |
268 | perl |
269 | rocks |