source: trunk/third/perl/t/op/gv.t @ 20075

Revision 20075, 5.0 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
  • Property svn:executable set to *
Line 
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
14print "1..48\n";
15
16# type coersion on assignment
17$foo = 'foo';
18$bar = *main::foo;
19$bar = $foo;
20print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n";
21$foo = *main::bar;
22
23# type coersion (not) on misc ops
24
25if ($foo) {
26  print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n";
27}
28
29unless ($foo =~ /abcd/) {
30  print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n";
31}
32
33if ($foo eq '*main::bar') {
34  print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n";
35}
36
37# type coersion on substitutions that match
38$a = *main::foo;
39$b = $a;
40$a =~ s/^X//;
41print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n";
42$a =~ s/^\*//;
43print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n";
44print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n";
45
46# typeglobs as lvalues
47substr($foo, 0, 1) = "XXX";
48print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n";
49print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n";
50
51# returning glob values
52sub foo {
53  local($bar) = *main::foo;
54  $foo = *main::bar;
55  return ($foo, $bar);
56}
57
58($fuu, $baa) = foo();
59if (defined $fuu) {
60  print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n";
61}
62
63if (defined $baa) {
64  print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n";
65}
66
67# nested package globs
68# NOTE:  It's probably OK if these semantics change, because the
69#        fact that %X::Y:: is stored in %X:: isn't documented.
70#        (I hope.)
71
72{ package Foo::Bar; no warnings 'once'; $test=1; }
73print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n";
74print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n";
75
76# test undef operator clearing out entire glob
77$foo = 'stuff';
78@foo = qw(more stuff);
79%foo = qw(even more random stuff);
80undef *foo;
81print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n";
82
83# test warnings from assignment of undef to glob
84{
85    my $msg;
86    local $SIG{__WARN__} = sub { $msg = $_[0] };
87    use warnings;
88    *foo = 'bar';
89    print $msg ? "not ok" : "ok", " 15\n";
90    *foo = undef;
91    print $msg ? "ok" : "not ok", " 16\n";
92}
93
94# test *glob{THING} syntax
95$x = "ok 17\n";
96@x = ("ok 18\n");
97%x = ("ok 19" => "\n");
98sub x { "ok 20\n" }
99print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
100format x =
101ok 21
102.
103print ref *x{FORMAT} eq "FORMAT" ? "ok 21\n" : "not ok 21\n";
104*x = *STDOUT;
105print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 22\n" : "not ok 22\n";
106print {*x{IO}} "ok 23\n";
107
108{
109        my $warn;
110        local $SIG{__WARN__} = sub {
111                $warn .= $_[0];
112        };
113        my $val = *x{FILEHANDLE};
114        print {*x{IO}} ($warn =~ /is deprecated/ ? "ok 24\n" : "not ok 24\n");
115       
116}
117
118# test if defined() doesn't create any new symbols
119
120{
121    my $test = 24;
122
123    my $a = "SYM000";
124    print "not " if defined *{$a};
125    ++$test; print "ok $test\n";
126
127    print "not " if defined @{$a} or defined *{$a};
128    ++$test; print "ok $test\n";
129
130    print "not " if defined %{$a} or defined *{$a};
131    ++$test; print "ok $test\n";
132
133    print "not " if defined ${$a} or defined *{$a};
134    ++$test; print "ok $test\n";
135
136    print "not " if defined &{$a} or defined *{$a};
137    ++$test; print "ok $test\n";
138
139    *{$a} = sub { print "ok $test\n" };
140    print "not " unless defined &{$a} and defined *{$a};
141    ++$test; &{$a};
142}
143
144# although it *should* if you're talking about magicals
145
146{
147    my $test = 30;
148
149    my $a = "]";
150    print "not " unless defined ${$a};
151    ++$test; print "ok $test\n";
152    print "not " unless defined *{$a};
153    ++$test; print "ok $test\n";
154
155    $a = "1";
156    "o" =~ /(o)/;
157    print "not " unless ${$a};
158    ++$test; print "ok $test\n";
159    print "not " unless defined *{$a};
160    ++$test; print "ok $test\n";
161    $a = "2";
162    print "not " if ${$a};
163    ++$test; print "ok $test\n";
164    print "not " unless defined *{$a};
165    ++$test; print "ok $test\n";
166    $a = "1x";
167    print "not " if defined ${$a};
168    ++$test; print "ok $test\n";
169    print "not " if defined *{$a};
170    ++$test; print "ok $test\n";
171    $a = "11";
172    "o" =~ /(((((((((((o)))))))))))/;
173    print "not " unless ${$a};
174    ++$test; print "ok $test\n";
175    print "not " unless defined *{$a};
176    ++$test; print "ok $test\n";
177}
178
179
180# [ID 20010526.001] localized glob loses value when assigned to
181
182$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
183
184print $j    == 1 ? "ok 41\n"  : "not ok 41\n";
185print $j{a} == 1 ? "ok 42\n"  : "not ok 42\n";
186print $j[0] == 1 ? "ok 43\n" : "not ok 43\n";
187
188# does pp_readline() handle glob-ness correctly?
189
190{
191    my $g = *foo;
192    $g = <DATA>;
193    print $g;
194}
195
196{
197    my $w = '';
198    $SIG{__WARN__} = sub { $w = $_[0] };
199    sub abc1 ();
200    local *abc1 = sub { };
201    print $w eq '' ? "ok 45\n" : "not ok 45\n# $w";
202    sub abc2 ();
203    local *abc2;
204    *abc2 = sub { };
205    print $w eq '' ? "ok 46\n" : "not ok 46\n# $w";
206    sub abc3 ();
207    *abc3 = sub { };
208    print $w =~ /Prototype mismatch/ ? "ok 47\n" : "not ok 47\n# $w";
209}
210
211{
212    # [17375] rcatline to formerly-defined undef was broken. Fixed in
213    # do_readline by checking SvOK. AMS, 20020918
214    my $x = "not ";
215    $x  = undef;
216    $x .= <DATA>;
217    print $x;
218}
219
220__END__
221ok 44
222ok 48
Note: See TracBrowser for help on using the repository browser.