Commit | Line | Data |
---|---|---|
b9894134 | 1 | #!./perl |
2 | ||
3 | # | |
4 | # various typeglob tests | |
5 | # | |
6 | ||
640b9ef6 | 7 | print "1..23\n"; |
b9894134 | 8 | |
9 | # type coersion on assignment | |
10 | $foo = 'foo'; | |
11 | $bar = *main::foo; | |
12 | $bar = $foo; | |
13 | print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n"; | |
14 | $foo = *main::bar; | |
15 | ||
16 | # type coersion (not) on misc ops | |
17 | ||
18 | if ($foo) { | |
19 | print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n"; | |
20 | } | |
21 | ||
22 | unless ($foo =~ /abcd/) { | |
23 | print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n"; | |
24 | } | |
25 | ||
26 | if ($foo eq '*main::bar') { | |
27 | print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n"; | |
28 | } | |
29 | ||
30 | # type coersion on substitutions that match | |
31 | $a = *main::foo; | |
32 | $b = $a; | |
33 | $a =~ s/^X//; | |
34 | print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n"; | |
35 | $a =~ s/^\*//; | |
36 | print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n"; | |
37 | print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n"; | |
38 | ||
39 | # typeglobs as lvalues | |
40 | substr($foo, 0, 1) = "XXX"; | |
41 | print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n"; | |
42 | print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n"; | |
43 | ||
44 | # returning glob values | |
45 | sub foo { | |
46 | local($bar) = *main::foo; | |
47 | $foo = *main::bar; | |
48 | return ($foo, $bar); | |
49 | } | |
50 | ||
51 | ($fuu, $baa) = foo(); | |
52 | if (defined $fuu) { | |
53 | print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n"; | |
54 | } | |
55 | ||
56 | if (defined $baa) { | |
57 | print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; | |
58 | } | |
59 | ||
85aff577 CS |
60 | # nested package globs |
61 | # NOTE: It's probably OK if these semantics change, because the | |
62 | # fact that %X::Y:: is stored in %X:: isn't documented. | |
63 | # (I hope.) | |
64 | ||
65 | { package Foo::Bar } | |
66 | print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; | |
67 | print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; | |
20408e3c GS |
68 | |
69 | # test undef operator clearing out entire glob | |
70 | $foo = 'stuff'; | |
71 | @foo = qw(more stuff); | |
72 | %foo = qw(even more random stuff); | |
73 | undef *foo; | |
7b8d334a | 74 | print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; |
20408e3c GS |
75 | |
76 | # test warnings from assignment of undef to glob | |
77 | { | |
78 | my $msg; | |
79 | local $SIG{__WARN__} = sub { $msg = $_[0] }; | |
80 | local $^W = 1; | |
81 | *foo = 'bar'; | |
7b8d334a | 82 | print $msg ? "not ok" : "ok", " 15\n"; |
20408e3c | 83 | *foo = undef; |
7b8d334a | 84 | print $msg ? "ok" : "not ok", " 16\n"; |
20408e3c | 85 | } |
640b9ef6 SM |
86 | |
87 | # test *glob{THING} syntax | |
88 | $x = "ok 17\n"; | |
89 | @x = ("ok 18\n"); | |
90 | %x = ("ok 19" => "\n"); | |
91 | sub x { "ok 20\n" } | |
92 | print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; | |
93 | *x = *STDOUT; | |
94 | print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n"; | |
95 | print {*x{IO}} "ok 22\n"; | |
96 | print {*x{FILEHANDLE}} "ok 23\n"; | |
97 | ||
98 |