1#!./perl
2
3#
4# various typeglob tests
5#
6
7BEGIN {
8    chdir 't' if -d 't';
9    @INC = '../lib';
10}
11
12use warnings;
13
14require './test.pl';
15plan( tests => 61 );
16
17# type coersion on assignment
18$foo = 'foo';
19$bar = *main::foo;
20$bar = $foo;
21is(ref(\$bar), 'SCALAR');
22$foo = *main::bar;
23
24# type coersion (not) on misc ops
25
26ok($foo);
27is(ref(\$foo), 'GLOB');
28
29unlike ($foo, qr/abcd/);
30is(ref(\$foo), 'GLOB');
31
32is($foo, '*main::bar');
33is(ref(\$foo), 'GLOB');
34
35# type coersion on substitutions that match
36$a = *main::foo;
37$b = $a;
38$a =~ s/^X//;
39is(ref(\$a), 'GLOB');
40$a =~ s/^\*//;
41is($a, 'main::foo');
42is(ref(\$b), 'GLOB');
43
44# typeglobs as lvalues
45substr($foo, 0, 1) = "XXX";
46is(ref(\$foo), 'SCALAR');
47is($foo, 'XXXmain::bar');
48
49# returning glob values
50sub foo {
51  local($bar) = *main::foo;
52  $foo = *main::bar;
53  return ($foo, $bar);
54}
55
56($fuu, $baa) = foo();
57ok(defined $fuu);
58is(ref(\$fuu), 'GLOB');
59
60
61ok(defined $baa);
62is(ref(\$baa), 'GLOB');
63
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
69{ package Foo::Bar; no warnings 'once'; $test=1; }
70ok(exists $Foo::{'Bar::'});
71is($Foo::{'Bar::'}, '*Foo::Bar::');
72
73
74# test undef operator clearing out entire glob
75$foo = 'stuff';
76@foo = qw(more stuff);
77%foo = qw(even more random stuff);
78undef *foo;
79is ($foo, undef);
80is (scalar @foo, 0);
81is (scalar %foo, 0);
82
83{
84    # test warnings from assignment of undef to glob
85    my $msg = '';
86    local $SIG{__WARN__} = sub { $msg = $_[0] };
87    use warnings;
88    *foo = 'bar';
89    is($msg, '');
90    *foo = undef;
91    like($msg, qr/Undefined value assigned to typeglob/);
92}
93
94my $test = curr_test();
95# test *glob{THING} syntax
96$x = "ok $test\n";
97++$test;
98@x = ("ok $test\n");
99++$test;
100%x = ("ok $test" => "\n");
101++$test;
102sub x { "ok $test\n" }
103print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
104# This needs to go here, after the print, as sub x will return the current
105# value of test
106++$test;
107format x =
108XXX This text isn't used. Should it be?
109.
110curr_test($test);
111
112is (ref *x{FORMAT}, "FORMAT");
113*x = *STDOUT;
114is (*{*x{GLOB}}, "*main::STDOUT");
115
116{
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);
130}
131
132
133{
134    # test if defined() doesn't create any new symbols
135
136    my $a = "SYM000";
137    ok(!defined *{$a});
138
139    ok(!defined @{$a});
140    ok(!defined *{$a});
141
142    ok(!defined %{$a});
143    ok(!defined *{$a});
144
145    ok(!defined ${$a});
146    ok(!defined *{$a});
147
148    ok(!defined &{$a});
149    ok(!defined *{$a});
150
151    my $state = "not";
152    *{$a} = sub { $state = "ok" };
153    ok(defined &{$a});
154    ok(defined *{$a});
155    &{$a};
156    is ($state, 'ok');
157}
158
159{
160    # although it *should* if you're talking about magicals
161
162    my $a = "]";
163    ok(defined ${$a});
164    ok(defined *{$a});
165
166    $a = "1";
167    "o" =~ /(o)/;
168    ok(${$a});
169    ok(defined *{$a});
170    $a = "2";
171    ok(!${$a});
172    ok(defined *{$a});
173    $a = "1x";
174    ok(!defined ${$a});
175    ok(!defined *{$a});
176    $a = "11";
177    "o" =~ /(((((((((((o)))))))))))/;
178    ok(${$a});
179    ok(defined *{$a});
180}
181
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
186is($j, 1);
187is($j{a}, 1);
188is($j[0], 1);
189
190{
191    # does pp_readline() handle glob-ness correctly?
192    my $g = *foo;
193    $g = <DATA>;
194    is ($g, "Perl\n");
195}
196
197{
198    my $w = '';
199    $SIG{__WARN__} = sub { $w = $_[0] };
200    sub abc1 ();
201    local *abc1 = sub { };
202    is ($w, '');
203    sub abc2 ();
204    local *abc2;
205    *abc2 = sub { };
206    is ($w, '');
207    sub abc3 ();
208    *abc3 = sub { };
209    like ($w, qr/Prototype mismatch/);
210}
211
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>;
218    is ($x, "Rules\n");
219}
220
221__END__
222Perl
223Rules
224