12 # Test glob operations.
39 # Test fake references.
46 # Test real references.
53 # Test references to real arrays.
55 my $test = curr_test();
56 @ary = ($test,$test+1,$test+2,$test+3);
62 push(@{$ref[$i]}, "ok $ary[$i]\n");
70 # Test references to references.
74 is ($$$refref, 'Good');
76 # Test nested anonymous lists.
78 $ref = [[],2,[3,4,5,]];
81 is (${$$ref[2]}[2], 5);
82 is (scalar @{$$ref[0]}, 0);
85 is ($ref->[2]->[0], 3);
87 # Test references to hashes of references.
90 $refref->{"key"} = $ref;
91 is ($refref->{"key"}->[2]->[0], 3);
93 # Test to see if anonymous subarrays spring into existence.
95 $spring[5]->[0] = 123;
96 $spring[5]->[1] = 456;
97 push(@{$spring[5]}, 789);
98 is (join(':',@{$spring[5]}), "123:456:789");
100 # Test to see if anonymous subhashes spring into existence.
102 @{$spring2{"foo"}} = (1,2,3);
103 $spring2{"foo"}->[3] = 4;
104 is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
106 # Test references to subroutines.
110 sub mysub { $called++; }
116 $subrefref = \\&mysub2;
117 is ($$subrefref->("GOOD"), "good");
118 sub mysub2 { lc shift }
120 # Test the ref operator.
122 is (ref $subref, 'CODE');
123 is (ref $ref, 'ARRAY');
124 is (ref $refref, 'HASH');
126 # Test anonymous hash syntax.
129 is (ref $anonhash, 'HASH');
130 $anonhash2 = {FOO => BAR, ABC => XYZ,};
131 is (join('', sort values %$anonhash2), 'BARXYZ');
133 # Test bless operator.
137 $object = bless $main'anonhash2;
138 main::is (ref $object, 'MYHASH');
139 main::is ($object->{ABC}, 'XYZ');
142 main::is (ref $object2, 'MYHASH');
144 # Test ordinary call on object method.
146 &mymethod($object,"argument");
149 local($THIS, @ARGS) = @_;
150 die 'Got a "' . ref($THIS). '" instead of a MYHASH'
151 unless ref $THIS eq MYHASH;
152 main::is ($ARGS[0], "argument");
153 main::is ($THIS->{FOO}, 'BAR');
156 # Test automatic destructor call.
161 $main'anonhash2 = "foo";
165 return unless $string;
166 main::is ($string, 'good');
168 # Test that the object has not already been "cursed".
169 main::isnt (ref shift, 'HASH');
172 # Now test inheritance of methods.
178 $main'object = bless {FOO => foo, BAR => bar};
182 # Test arrow-style method invocation.
184 is ($object->doit("BAR"), bar);
186 # Test indirect-object-style method invocation.
188 $foo = doit $object "FOO";
189 main::is ($foo, foo);
193 die "Not an OBJ" unless ref $ref eq OBJ;
201 sub foo { main::is ($_[1], 'works') }
204 foo WHATEVER "works";
207 # test the \(@foo) construct
212 @baz = \(1,@foo,@bar);
213 is (scalar (@bar), 3);
214 is (scalar grep(ref($_), @bar), 3);
215 is (scalar (@baz), 3);
217 my(@fuu) = \(1..2,3);
219 my(@bzz) = \(1,@fuu,@baa);
220 is (scalar (@baa), 3);
221 is (scalar grep(ref($_), @baa), 3);
222 is (scalar (@bzz), 3);
224 # also, it can't be an lvalue
225 eval '\\($x, $y) = (1, 2);';
226 like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
228 # test for proper destruction of lexical objects
230 sub larry::DESTROY { print "# larry\nok $test\n"; }
231 sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
232 sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; }
235 my ($joe, @curly, %larry);
236 my $moe = bless \$joe, 'moe';
237 my $curly = bless \@curly, 'curly';
238 my $larry = bless \%larry, 'larry';
239 print "# leaving block\n";
242 print "# left block\n";
243 curr_test($test + 3);
249 { local(*bar) = "foo" }
259 # test if reblessing during destruction results in more destruction
263 sub new { bless {}, shift }
264 DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
266 sub new { bless {}, shift }
267 DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
271 curr_test($test + 2);
273 # test if $_[0] is properly protected in DESTROY()
276 my $test = curr_test();
278 local $SIG{'__DIE__'} = sub {
281 print "# infinite recursion, bailing\nnot ok $test\n";
284 like ($m, qr/^Modification of a read-only/);
287 sub new { bless {}, shift }
288 DESTROY { $_[0] = 'foo' }
290 print "# should generate an error...\n";
293 print "# good, didn't recurse\n";
296 # test if refgen behaves with autoviv magic
308 # This test is the reason for postponed destruction in sv_unref
313 # This test used to coredump. The BEGIN block is important as it causes the
314 # op that created the constant reference to be freed. Hence the only
315 # reference to the constant string "pass" is in $a. The hack that made
316 # sure $a = $a->[1] would work didn't work with references to constants.
319 foreach my $lexical ('', 'my $a; ') {
320 my $expect = "pass\n";
321 my $result = runperl (switches => ['-wl'], stderr => 1,
322 prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
325 is ($result, $expect);
328 my $test = curr_test();
329 sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
330 { my $a1 = bless [3],"x";
331 my $a2 = bless [2],"x";
332 { my $a3 = bless [1],"x";
333 my $a4 = bless [0],"x";
339 is (runperl (switches=>['-l'],
340 prog=> 'print 1; print qq-*$\*-;print 1;'),
345 runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
346 is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
348 runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
349 is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
354 runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
355 is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
357 # bug #27268: freeing self-referential typeglobs could trigger
358 # "Attempt to free unreferenced scalar" warnings
361 prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x',
363 ), '', 'freeing self-referential typeglob');
365 # using a regex in the destructor for STDOUT segfaulted because the
366 # REGEX pad had already been freed (ithreads build only). The
367 # object is required to trigger the early freeing of GV refs to to STDOUT
370 prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}',
372 ), qr/^(ok)+$/, 'STDOUT destructor');
374 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
376 curr_test($test + 3);
377 # test global destruction
379 my $test1 = $test + 1;
380 my $test2 = $test + 2;
385 $ref3 = bless ["ok $test2\n"]; # package destruction
386 my $ref2 = bless ["ok $test1\n"]; # lexical destruction
387 local $ref1 = bless ["ok $test\n"]; # dynamic destruction
388 1; # flush any temp values on stack