Commit | Line | Data |
79072805 |
1 | #!./perl |
2 | |
58e0a6ae |
3 | print "1..47\n"; |
79072805 |
4 | |
5 | # Test glob operations. |
6 | |
7 | $bar = "ok 1\n"; |
8 | $foo = "ok 2\n"; |
9 | { |
10 | local(*foo) = *bar; |
11 | print $foo; |
12 | } |
13 | print $foo; |
14 | |
15 | $baz = "ok 3\n"; |
16 | $foo = "ok 4\n"; |
17 | { |
18 | local(*foo) = 'baz'; |
19 | print $foo; |
20 | } |
21 | print $foo; |
22 | |
23 | $foo = "ok 6\n"; |
24 | { |
25 | local(*foo); |
26 | print $foo; |
27 | $foo = "ok 5\n"; |
28 | print $foo; |
29 | } |
30 | print $foo; |
31 | |
32 | # Test fake references. |
33 | |
34 | $baz = "ok 7\n"; |
35 | $bar = 'baz'; |
36 | $foo = 'bar'; |
37 | print $$$foo; |
38 | |
39 | # Test real references. |
40 | |
41 | $FOO = \$BAR; |
42 | $BAR = \$BAZ; |
43 | $BAZ = "ok 8\n"; |
44 | print $$$FOO; |
45 | |
46 | # Test references to real arrays. |
47 | |
48 | @ary = (9,10,11,12); |
49 | $ref[0] = \@a; |
50 | $ref[1] = \@b; |
51 | $ref[2] = \@c; |
52 | $ref[3] = \@d; |
53 | for $i (3,1,2,0) { |
54 | push(@{$ref[$i]}, "ok $ary[$i]\n"); |
55 | } |
56 | print @a; |
57 | print ${$ref[1]}[0]; |
58 | print @{$ref[2]}[0]; |
59 | print @{'d'}; |
60 | |
61 | # Test references to references. |
62 | |
63 | $refref = \\$x; |
64 | $x = "ok 13\n"; |
65 | print $$$refref; |
66 | |
67 | # Test nested anonymous lists. |
68 | |
69 | $ref = [[],2,[3,4,5,]]; |
70 | print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n"; |
71 | print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n"; |
72 | print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; |
73 | print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n"; |
74 | |
75 | print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n"; |
a0d0e21e |
76 | print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; |
79072805 |
77 | |
78 | # Test references to hashes of references. |
79 | |
80 | $refref = \%whatever; |
81 | $refref->{"key"} = $ref; |
82 | print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n"; |
83 | |
93a17b20 |
84 | # Test to see if anonymous subarrays spring into existence. |
79072805 |
85 | |
86 | $spring[5]->[0] = 123; |
87 | $spring[5]->[1] = 456; |
88 | push(@{$spring[5]}, 789); |
89 | print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n"; |
90 | |
93a17b20 |
91 | # Test to see if anonymous subhashes spring into existence. |
79072805 |
92 | |
93 | @{$spring2{"foo"}} = (1,2,3); |
94 | $spring2{"foo"}->[3] = 4; |
95 | print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n"; |
96 | |
97 | # Test references to subroutines. |
98 | |
99 | sub mysub { print "ok 23\n" } |
100 | $subref = \&mysub; |
101 | &$subref; |
102 | |
103 | $subrefref = \\&mysub2; |
104 | &$$subrefref("ok 24\n"); |
105 | sub mysub2 { print shift } |
106 | |
107 | # Test the ref operator. |
108 | |
109 | print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n"; |
110 | print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n"; |
111 | print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n"; |
112 | |
113 | # Test anonymous hash syntax. |
114 | |
115 | $anonhash = {}; |
116 | print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n"; |
117 | $anonhash2 = {FOO => BAR, ABC => XYZ,}; |
118 | print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n"; |
119 | |
120 | # Test bless operator. |
121 | |
122 | package MYHASH; |
123 | |
124 | $object = bless $main'anonhash2; |
125 | print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n"; |
126 | print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n"; |
127 | |
128 | $object2 = bless {}; |
129 | print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n"; |
130 | |
131 | # Test ordinary call on object method. |
132 | |
133 | &mymethod($object,33); |
134 | |
135 | sub mymethod { |
136 | local($THIS, @ARGS) = @_; |
ed6116ce |
137 | die 'Got a "' . ref($THIS). '" instead of a MYHASH' |
138 | unless ref $THIS eq MYHASH; |
79072805 |
139 | print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n"; |
140 | } |
141 | |
142 | # Test automatic destructor call. |
143 | |
144 | $string = "not ok 34\n"; |
145 | $object = "foo"; |
146 | $string = "ok 34\n"; |
147 | $main'anonhash2 = "foo"; |
8990e307 |
148 | $string = ""; |
79072805 |
149 | |
ed6116ce |
150 | DESTROY { |
8990e307 |
151 | return unless $string; |
79072805 |
152 | print $string; |
153 | |
a0d0e21e |
154 | # Test that the object has not already been "cursed". |
155 | print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; |
79072805 |
156 | } |
157 | |
158 | # Now test inheritance of methods. |
159 | |
160 | package OBJ; |
161 | |
162 | @ISA = (BASEOBJ); |
163 | |
164 | $main'object = bless {FOO => foo, BAR => bar}; |
165 | |
166 | package main; |
167 | |
168 | # Test arrow-style method invocation. |
169 | |
170 | print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n"; |
171 | |
172 | # Test indirect-object-style method invocation. |
173 | |
174 | $foo = doit $object "FOO"; |
175 | print $foo eq foo ? "ok 37\n" : "not ok 37\n"; |
176 | |
177 | sub BASEOBJ'doit { |
178 | local $ref = shift; |
179 | die "Not an OBJ" unless ref $ref eq OBJ; |
748a9306 |
180 | $ref->{shift()}; |
79072805 |
181 | } |
8990e307 |
182 | |
a0d0e21e |
183 | package UNIVERSAL; |
184 | @ISA = 'LASTCHANCE'; |
185 | |
186 | package LASTCHANCE; |
187 | sub foo { print $_[1] } |
188 | |
189 | package WHATEVER; |
190 | foo WHATEVER "ok 38\n"; |
191 | |
58e0a6ae |
192 | # |
193 | # test the \(@foo) construct |
194 | # |
195 | package main; |
196 | @foo = (1,2,3); |
197 | @bar = \(@foo); |
198 | @baz = \(1,@foo,@bar); |
199 | print @bar == 3 ? "ok 39\n" : "not ok 39\n"; |
200 | print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n"; |
201 | print @baz == 3 ? "ok 41\n" : "not ok 41\n"; |
202 | |
203 | my(@fuu) = (1,2,3); |
204 | my(@baa) = \(@fuu); |
205 | my(@bzz) = \(1,@fuu,@baa); |
206 | print @baa == 3 ? "ok 42\n" : "not ok 42\n"; |
207 | print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n"; |
208 | print @bzz == 3 ? "ok 44\n" : "not ok 44\n"; |
209 | |
8990e307 |
210 | package FINALE; |
211 | |
212 | { |
58e0a6ae |
213 | $ref3 = bless ["ok 47\n"]; # package destruction |
214 | my $ref2 = bless ["ok 46\n"]; # lexical destruction |
215 | local $ref1 = bless ["ok 45\n"]; # dynamic destruction |
8990e307 |
216 | 1; # flush any temp values on stack |
217 | } |
218 | |
219 | DESTROY { |
220 | print $_[0][0]; |
221 | } |