This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Pod nit mentioned in Debian bug #358455.
[perl5.git] / t / op / tie.t
CommitLineData
49d42823
PP
1#!./perl
2
d87ebaca
YST
3# Add new tests to the end with format:
4# ########
5#
6# # test description
7# Test code
8# EXPECT
9# Warn or die msgs (if any) at - line 1234
10#
49d42823
PP
11
12chdir 't' if -d 't';
20822f61 13@INC = '../lib';
49d42823
PP
14$ENV{PERL5LIB} = "../lib";
15
16$|=1;
17
18undef $/;
d87ebaca 19@prgs = split /^########\n/m, <DATA>;
49d42823 20
d87ebaca
YST
21require './test.pl';
22plan(tests => scalar @prgs);
49d42823 23for (@prgs){
d87ebaca
YST
24 ++$i;
25 my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
26 print("not ok $i # bad test format\n"), next
27 unless defined $expected;
28 my ($testname) = $prog =~ /^# (.*)\n/m;
29 $testname ||= '';
30 $TODO = $testname =~ s/^TODO //;
49d42823
PP
31 $results =~ s/\n+$//;
32 $expected =~ s/\n+$//;
d87ebaca
YST
33
34 fresh_perl_is($prog, $expected, {}, $testname);
49d42823
PP
35}
36
37__END__
38
39# standard behaviour, without any extra references
40use Tie::Hash ;
41tie %h, Tie::StdHash;
42untie %h;
43EXPECT
44########
45
a29a5827
NIS
46# standard behaviour, without any extra references
47use Tie::Hash ;
48{package Tie::HashUntie;
49 use base 'Tie::StdHash';
50 sub UNTIE
51 {
52 warn "Untied\n";
53 }
54}
55tie %h, Tie::HashUntie;
56untie %h;
57EXPECT
58Untied
59########
60
49d42823
PP
61# standard behaviour, with 1 extra reference
62use Tie::Hash ;
63$a = tie %h, Tie::StdHash;
64untie %h;
65EXPECT
66########
67
68# standard behaviour, with 1 extra reference via tied
69use Tie::Hash ;
70tie %h, Tie::StdHash;
71$a = tied %h;
72untie %h;
73EXPECT
74########
75
76# standard behaviour, with 1 extra reference which is destroyed
77use Tie::Hash ;
78$a = tie %h, Tie::StdHash;
79$a = 0 ;
80untie %h;
81EXPECT
82########
83
84# standard behaviour, with 1 extra reference via tied which is destroyed
85use Tie::Hash ;
86tie %h, Tie::StdHash;
87$a = tied %h;
88$a = 0 ;
89untie %h;
90EXPECT
91########
92
93# strict behaviour, without any extra references
4438c4b7 94use warnings 'untie';
49d42823
PP
95use Tie::Hash ;
96tie %h, Tie::StdHash;
97untie %h;
98EXPECT
99########
100
101# strict behaviour, with 1 extra references generating an error
4438c4b7 102use warnings 'untie';
49d42823
PP
103use Tie::Hash ;
104$a = tie %h, Tie::StdHash;
105untie %h;
106EXPECT
d87ebaca 107untie attempted while 1 inner references still exist at - line 6.
49d42823
PP
108########
109
110# strict behaviour, with 1 extra references via tied generating an error
4438c4b7 111use warnings 'untie';
49d42823
PP
112use Tie::Hash ;
113tie %h, Tie::StdHash;
114$a = tied %h;
115untie %h;
116EXPECT
d87ebaca 117untie attempted while 1 inner references still exist at - line 7.
49d42823
PP
118########
119
120# strict behaviour, with 1 extra references which are destroyed
4438c4b7 121use warnings 'untie';
49d42823
PP
122use Tie::Hash ;
123$a = tie %h, Tie::StdHash;
124$a = 0 ;
125untie %h;
126EXPECT
127########
128
129# strict behaviour, with extra 1 references via tied which are destroyed
4438c4b7 130use warnings 'untie';
49d42823
PP
131use Tie::Hash ;
132tie %h, Tie::StdHash;
133$a = tied %h;
134$a = 0 ;
135untie %h;
136EXPECT
137########
138
87f0b213 139# strict error behaviour, with 2 extra references
4438c4b7 140use warnings 'untie';
49d42823
PP
141use Tie::Hash ;
142$a = tie %h, Tie::StdHash;
143$b = tied %h ;
144untie %h;
145EXPECT
d87ebaca 146untie attempted while 2 inner references still exist at - line 7.
49d42823
PP
147########
148
149# strict behaviour, check scope of strictness.
4438c4b7 150no warnings 'untie';
49d42823
PP
151use Tie::Hash ;
152$A = tie %H, Tie::StdHash;
153$C = $B = tied %H ;
154{
4438c4b7 155 use warnings 'untie';
49d42823
PP
156 use Tie::Hash ;
157 tie %h, Tie::StdHash;
158 untie %h;
159}
160untie %H;
161EXPECT
33c27489 162########
d87ebaca 163
ae21d580 164# Forbidden aggregate self-ties
33c27489 165sub Self::TIEHASH { bless $_[1], $_[0] }
ae21d580 166{
d87ebaca 167 my %c;
ae21d580
JH
168 tie %c, 'Self', \%c;
169}
170EXPECT
d87ebaca 171Self-ties of arrays and hashes are not supported at - line 6.
ae21d580 172########
d87ebaca 173
ae21d580 174# Allowed scalar self-ties
d87ebaca 175my $destroyed = 0;
ae21d580 176sub Self::TIESCALAR { bless $_[1], $_[0] }
d87ebaca 177sub Self::DESTROY { $destroyed = 1; }
33c27489 178{
ae21d580 179 my $c = 42;
ae21d580 180 tie $c, 'Self', \$c;
33c27489 181}
d87ebaca 182die "self-tied scalar not DESTROYed" unless $destroyed == 1;
7bb043c3 183EXPECT
83f527ec 184########
3ca7705e 185
b5ccf5f2 186# Allowed glob self-ties
87f0b213
JH
187my $destroyed = 0;
188my $printed = 0;
189sub Self2::TIEHANDLE { bless $_[1], $_[0] }
190sub Self2::DESTROY { $destroyed = 1; }
191sub Self2::PRINT { $printed = 1; }
192{
193 use Symbol;
194 my $c = gensym;
195 tie *$c, 'Self2', $c;
196 print $c 'Hello';
197}
198die "self-tied glob not PRINTed" unless $printed == 1;
43bb546a 199die "self-tied glob not DESTROYed" unless $destroyed == 1;
87f0b213
JH
200EXPECT
201########
202
203# Allowed IO self-ties
204my $destroyed = 0;
205sub Self3::TIEHANDLE { bless $_[1], $_[0] }
206sub Self3::DESTROY { $destroyed = 1; }
b5ccf5f2 207sub Self3::PRINT { $printed = 1; }
87f0b213
JH
208{
209 use Symbol 'geniosym';
210 my $c = geniosym;
211 tie *$c, 'Self3', $c;
b5ccf5f2 212 print $c 'Hello';
87f0b213 213}
b5ccf5f2 214die "self-tied IO not PRINTed" unless $printed == 1;
43bb546a 215die "self-tied IO not DESTROYed" unless $destroyed == 1;
87f0b213
JH
216EXPECT
217########
0b2c215a 218
b5ccf5f2
YST
219# TODO IO "self-tie" via TEMP glob
220my $destroyed = 0;
221sub Self3::TIEHANDLE { bless $_[1], $_[0] }
222sub Self3::DESTROY { $destroyed = 1; }
223sub Self3::PRINT { $printed = 1; }
224{
225 use Symbol 'geniosym';
226 my $c = geniosym;
227 tie *$c, 'Self3', \*$c;
228 print $c 'Hello';
229}
230die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
231die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
232EXPECT
233########
234
d87ebaca
YST
235# Interaction of tie and vec
236
237my ($a, $b);
238use Tie::Scalar;
239tie $a,Tie::StdScalar or die;
240vec($b,1,1)=1;
241$a = $b;
242vec($a,1,1)=0;
243vec($b,1,1)=0;
244die unless $a eq $b;
245EXPECT
246########
247
248# correct unlocalisation of tied hashes (patch #16431)
249use Tie::Hash ;
250tie %tied, Tie::StdHash;
251{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
252{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
253{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
254EXPECT
255########
256
257# An attempt at lvalueable barewords broke this
258tie FH, 'main';
259EXPECT
260Can't modify constant item in tie at - line 3, near "'main';"
261Execution of - aborted due to compilation errors.
eb85dfd3
DM
262########
263
264# localizing tied hash slices
265$ENV{FooA} = 1;
266$ENV{FooB} = 2;
267print exists $ENV{FooA} ? 1 : 0, "\n";
268print exists $ENV{FooB} ? 2 : 0, "\n";
269print exists $ENV{FooC} ? 3 : 0, "\n";
270{
271 local @ENV{qw(FooA FooC)};
272 print exists $ENV{FooA} ? 4 : 0, "\n";
273 print exists $ENV{FooB} ? 5 : 0, "\n";
274 print exists $ENV{FooC} ? 6 : 0, "\n";
275}
276print exists $ENV{FooA} ? 7 : 0, "\n";
277print exists $ENV{FooB} ? 8 : 0, "\n";
278print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
279EXPECT
2801
2812
2820
2834
2845
2856
2867
2878
2880
b77f7d40
YST
289########
290#
291# FETCH freeing tie'd SV
292sub TIESCALAR { bless [] }
293sub FETCH { *a = \1; 1 }
294tie $a, 'main';
295print $a;
296EXPECT
dd28f7bb
DM
297########
298
299# [20020716.007] - nested FETCHES
300
301sub F1::TIEARRAY { bless [], 'F1' }
302sub F1::FETCH { 1 }
303my @f1;
304tie @f1, 'F1';
305
306sub F2::TIEARRAY { bless [2], 'F2' }
307sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
308my @f2;
309tie @f2, 'F2';
310
311print $f2[4][0],"\n";
312
313sub F3::TIEHASH { bless [], 'F3' }
314sub F3::FETCH { 1 }
315my %f3;
316tie %f3, 'F3';
317
318sub F4::TIEHASH { bless [3], 'F4' }
319sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
320my %f4;
321tie %f4, 'F4';
322
323print $f4{'foo'}[0],"\n";
324
325EXPECT
3262
3273
38193a09
AM
328########
329# test untie() from within FETCH
330package Foo;
331sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
332sub FETCH {
333 my $self = shift;
334 my ($obj, $field) = @$self;
335 untie $obj->{$field};
336 $obj->{$field} = "Bar";
337}
338package main;
339tie $a->{foo}, "Foo", $a, "foo";
340$a->{foo}; # access once
341# the hash element should not be tied anymore
342print defined tied $a->{foo} ? "not ok" : "ok";
343EXPECT
344ok
be65207d
DM
345########
346# the tmps returned by FETCH should appear to be SCALAR
347# (even though they are now implemented using PVLVs.)
348package X;
349sub TIEHASH { bless {} }
350sub TIEARRAY { bless {} }
351sub FETCH {1}
352my (%h, @a);
353tie %h, 'X';
354tie @a, 'X';
355my $r1 = \$h{1};
356my $r2 = \$a[0];
357my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
358$s=~ s/\(0x\w+\)//g;
359print $s, "\n";
360EXPECT
361SCALAR SCALAR SCALAR SCALAR
b7056d9c
JH
362########
363# [perl #23287] segfault in untie
364sub TIESCALAR { bless $_[1], $_[0] }
365my $var;
366tie $var, 'main', \$var;
367untie $var;
368EXPECT
16e0ce55
JH
369########
370# Test case from perlmonks by runrig
371# http://www.perlmonks.org/index.pl?node_id=273490
372# "Here is what I tried. I think its similar to what you've tried
373# above. Its odd but convienient that after untie'ing you are left with
374# a variable that has the same value as was last returned from
375# FETCH. (At least on my perl v5.6.1). So you don't need to pass a
376# reference to the variable in order to set it after the untie (here it
377# is accessed through a closure)."
378use strict;
379use warnings;
380package MyTied;
381sub TIESCALAR {
382 my ($class,$code) = @_;
383 bless $code, $class;
384}
385sub FETCH {
386 my $self = shift;
387 print "Untie\n";
388 $self->();
389}
390package main;
391my $var;
392tie $var, 'MyTied', sub { untie $var; 4 };
393print "One\n";
394print "$var\n";
395print "Two\n";
396print "$var\n";
397print "Three\n";
398print "$var\n";
399EXPECT
400One
401Untie
4024
403Two
4044
405Three
4064
dd12389b
JH
407########
408# [perl #22297] cannot untie scalar from within tied FETCH
409my $counter = 0;
410my $x = 7;
411my $ref = \$x;
412tie $x, 'Overlay', $ref, $x;
413my $y;
414$y = $x;
415$y = $x;
416$y = $x;
417$y = $x;
418#print "WILL EXTERNAL UNTIE $ref\n";
419untie $$ref;
420$y = $x;
421$y = $x;
422$y = $x;
423$y = $x;
424#print "counter = $counter\n";
425
426print (($counter == 1) ? "ok\n" : "not ok\n");
427
428package Overlay;
429
430sub TIESCALAR
431{
432 my $pkg = shift;
433 my ($ref, $val) = @_;
434 return bless [ $ref, $val ], $pkg;
435}
436
437sub FETCH
438{
439 my $self = shift;
440 my ($ref, $val) = @$self;
441 #print "WILL INTERNAL UNITE $ref\n";
442 $counter++;
443 untie $$ref;
444 return $val;
445}
446EXPECT
447ok
6c0731c3
RC
448########
449
450# TODO [perl #948] cannot meaningfully tie $,
451package TieDollarComma;
452
453sub TIESCALAR {
454 my $pkg = shift;
455 return bless \my $x, $pkg;
456}
457
458sub STORE {
459 my $self = shift;
460 $$self = shift;
461 print "STORE set '$$self'\n";
462}
463
464sub FETCH {
465 my $self = shift;
466 print "FETCH\n";
467 return $$self;
468}
469package main;
470
471tie $,, 'TieDollarComma';
472$, = 'BOBBINS';
473print "join", "things", "up\n";
474EXPECT
475STORE set 'BOBBINS'
476FETCH
477FETCH
478joinBOBBINSthingsBOBBINSup
a3bcc51e
TP
479########
480
481# test SCALAR method
482package TieScalar;
483
484sub TIEHASH {
485 my $pkg = shift;
486 bless { } => $pkg;
487}
488
489sub STORE {
490 $_[0]->{$_[1]} = $_[2];
491}
492
493sub FETCH {
494 $_[0]->{$_[1]}
495}
496
497sub CLEAR {
498 %{ $_[0] } = ();
499}
500
501sub SCALAR {
502 print "SCALAR\n";
503 return 0 if ! keys %{$_[0]};
504 sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
505}
506
507package main;
508tie my %h => "TieScalar";
509$h{key1} = "val1";
510$h{key2} = "val2";
511print scalar %h, "\n";
512%h = ();
513print scalar %h, "\n";
514EXPECT
515SCALAR
5162/2
517SCALAR
5180
519########
520
521# test scalar on tied hash when no SCALAR method has been given
522package TieScalar;
523
524sub TIEHASH {
525 my $pkg = shift;
526 bless { } => $pkg;
527}
528sub STORE {
529 $_[0]->{$_[1]} = $_[2];
530}
531sub FETCH {
532 $_[0]->{$_[1]}
533}
534sub CLEAR {
535 %{ $_[0] } = ();
536}
537sub FIRSTKEY {
538 my $a = keys %{ $_[0] };
539 print "FIRSTKEY\n";
540 each %{ $_[0] };
541}
542
543package main;
544tie my %h => "TieScalar";
545
546if (!%h) {
547 print "empty\n";
548} else {
549 print "not empty\n";
550}
551
552$h{key1} = "val1";
553print "not empty\n" if %h;
554print "not empty\n" if %h;
555print "-->\n";
556my ($k,$v) = each %h;
557print "<--\n";
558print "not empty\n" if %h;
559%h = ();
560print "empty\n" if ! %h;
561EXPECT
562FIRSTKEY
563empty
564FIRSTKEY
565not empty
566FIRSTKEY
567not empty
568-->
569FIRSTKEY
570<--
571not empty
572FIRSTKEY
573empty
2b77b520
YST
574########
575sub TIESCALAR { bless {} }
576sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
577tie $h, "main";
578print $h,"\n";
579EXPECT
5803.3
c75ab21a
RH
581########
582sub TIESCALAR { bless {} }
583sub FETCH { shift()->{i} ++ }
584tie $h, "main";
585print $h.$h;
586EXPECT
58701
64207fde
RB
588########
589sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
590sub FETCH { ${$_[0]} }
591tie my $x, "main", 2;
592tie my $y, "main", 8;
593print $x | $y;
594EXPECT
59510