3 # Add new tests to the end with format:
9 # Warn or die msgs (if any) at - line 1234
14 $ENV{PERL5LIB} = "../lib";
19 @prgs = split /^########\n/m, <DATA>;
22 plan(tests => scalar @prgs);
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;
30 $TODO = $testname =~ s/^TODO //;
32 $expected =~ s/\n+$//;
34 fresh_perl_is($prog, $expected, {}, $testname);
39 # standard behaviour, without any extra references
46 # standard behaviour, without any extra references
48 {package Tie::HashUntie;
49 use base 'Tie::StdHash';
55 tie %h, Tie::HashUntie;
61 # standard behaviour, with 1 extra reference
63 $a = tie %h, Tie::StdHash;
68 # standard behaviour, with 1 extra reference via tied
76 # standard behaviour, with 1 extra reference which is destroyed
78 $a = tie %h, Tie::StdHash;
84 # standard behaviour, with 1 extra reference via tied which is destroyed
93 # strict behaviour, without any extra references
101 # strict behaviour, with 1 extra references generating an error
102 use warnings 'untie';
104 $a = tie %h, Tie::StdHash;
107 untie attempted while 1 inner references still exist at - line 6.
110 # strict behaviour, with 1 extra references via tied generating an error
111 use warnings 'untie';
113 tie %h, Tie::StdHash;
117 untie attempted while 1 inner references still exist at - line 7.
120 # strict behaviour, with 1 extra references which are destroyed
121 use warnings 'untie';
123 $a = tie %h, Tie::StdHash;
129 # strict behaviour, with extra 1 references via tied which are destroyed
130 use warnings 'untie';
132 tie %h, Tie::StdHash;
139 # strict error behaviour, with 2 extra references
140 use warnings 'untie';
142 $a = tie %h, Tie::StdHash;
146 untie attempted while 2 inner references still exist at - line 7.
149 # strict behaviour, check scope of strictness.
152 $A = tie %H, Tie::StdHash;
155 use warnings 'untie';
157 tie %h, Tie::StdHash;
164 # Forbidden aggregate self-ties
165 sub Self::TIEHASH { bless $_[1], $_[0] }
171 Self-ties of arrays and hashes are not supported at - line 6.
174 # Allowed scalar self-ties
176 sub Self::TIESCALAR { bless $_[1], $_[0] }
177 sub Self::DESTROY { $destroyed = 1; }
182 die "self-tied scalar not DESTROYed" unless $destroyed == 1;
186 # Allowed glob self-ties
189 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
190 sub Self2::DESTROY { $destroyed = 1; }
191 sub Self2::PRINT { $printed = 1; }
195 tie *$c, 'Self2', $c;
198 die "self-tied glob not PRINTed" unless $printed == 1;
199 die "self-tied glob not DESTROYed" unless $destroyed == 1;
203 # Allowed IO self-ties
205 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
206 sub Self3::DESTROY { $destroyed = 1; }
207 sub Self3::PRINT { $printed = 1; }
209 use Symbol 'geniosym';
211 tie *$c, 'Self3', $c;
214 die "self-tied IO not PRINTed" unless $printed == 1;
215 die "self-tied IO not DESTROYed" unless $destroyed == 1;
219 # TODO IO "self-tie" via TEMP glob
221 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
222 sub Self3::DESTROY { $destroyed = 1; }
223 sub Self3::PRINT { $printed = 1; }
225 use Symbol 'geniosym';
227 tie *$c, 'Self3', \*$c;
230 die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
231 die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
235 # Interaction of tie and vec
239 tie $a,Tie::StdScalar or die;
248 # correct unlocalisation of tied hashes (patch #16431)
250 tie %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'};
257 # An attempt at lvalueable barewords broke this
260 Can't modify constant item in tie at - line 3, near "'main';"
261 Execution of - aborted due to compilation errors.
264 # localizing tied hash slices
267 print exists $ENV{FooA} ? 1 : 0, "\n";
268 print exists $ENV{FooB} ? 2 : 0, "\n";
269 print exists $ENV{FooC} ? 3 : 0, "\n";
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";
276 print exists $ENV{FooA} ? 7 : 0, "\n";
277 print exists $ENV{FooB} ? 8 : 0, "\n";
278 print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
291 # FETCH freeing tie'd SV
292 sub TIESCALAR { bless [] }
293 sub FETCH { *a = \1; 1 }
299 # [20020716.007] - nested FETCHES
301 sub F1::TIEARRAY { bless [], 'F1' }
306 sub F2::TIEARRAY { bless [2], 'F2' }
307 sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
311 print $f2[4][0],"\n";
313 sub F3::TIEHASH { bless [], 'F3' }
318 sub F4::TIEHASH { bless [3], 'F4' }
319 sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
323 print $f4{'foo'}[0],"\n";
329 # test untie() from within FETCH
331 sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
334 my ($obj, $field) = @$self;
335 untie $obj->{$field};
336 $obj->{$field} = "Bar";
339 tie $a->{foo}, "Foo", $a, "foo";
340 my $s = $a->{foo}; # access once
341 # the hash element should not be tied anymore
342 print defined tied $a->{foo} ? "not ok" : "ok";
346 # the tmps returned by FETCH should appear to be SCALAR
347 # (even though they are now implemented using PVLVs.)
349 sub TIEHASH { bless {} }
350 sub TIEARRAY { bless {} }
357 my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
361 SCALAR SCALAR SCALAR SCALAR
363 # [perl #23287] segfault in untie
364 sub TIESCALAR { bless $_[1], $_[0] }
366 tie $var, 'main', \$var;
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)."
382 my ($class,$code) = @_;
392 tie $var, 'MyTied', sub { untie $var; 4 };
408 # [perl #22297] cannot untie scalar from within tied FETCH
412 tie $x, 'Overlay', $ref, $x;
418 #print "WILL EXTERNAL UNTIE $ref\n";
424 #print "counter = $counter\n";
426 print (($counter == 1) ? "ok\n" : "not ok\n");
433 my ($ref, $val) = @_;
434 return bless [ $ref, $val ], $pkg;
440 my ($ref, $val) = @$self;
441 #print "WILL INTERNAL UNITE $ref\n";
450 # [perl #948] cannot meaningfully tie $,
451 package TieDollarComma;
455 return bless \my $x, $pkg;
461 print "STORE set '$$self'\n";
471 tie $,, 'TieDollarComma';
473 print "join", "things", "up\n";
476 join<FETCH>BOBBINSthings<FETCH>BOBBINSup
488 $_[0]->{$_[1]} = $_[2];
501 return 0 if ! keys %{$_[0]};
502 sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
506 tie my %h => "TieScalar";
509 print scalar %h, "\n"
510 if %h; # this should also call SCALAR but implicitly
512 print scalar %h, "\n"
513 if !%h; # this should also call SCALAR but implicitly
523 # test scalar on tied hash when no SCALAR method has been given
531 $_[0]->{$_[1]} = $_[2];
540 my $a = keys %{ $_[0] };
546 tie my %h => "TieScalar";
555 print "not empty\n" if %h;
556 print "not empty\n" if %h;
558 my ($k,$v) = each %h;
560 print "not empty\n" if %h;
562 print "empty\n" if ! %h;
577 sub TIESCALAR { bless {} }
578 sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
584 sub TIESCALAR { bless {} }
585 sub FETCH { shift()->{i} ++ }
591 # Bug 53482 (and maybe others)
592 sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
593 sub FETCH { ${$_[0]} }
594 tie my $x1, "main", 2;
595 tie my $y1, "main", 8;
598 tie my $x2, "main", "2";
599 tie my $y2, "main", "8";
606 sub TIEHASH { bless {}, $_[0] }
607 sub STORE { $_[0]->{$_[1]} = $_[2] }
608 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
609 sub NEXTKEY { each %{$_[0]} }
610 sub DELETE { delete $_[0]->{$_[1]} }
611 sub CLEAR { %{$_[0]} = () }
614 print scalar keys %h, "\n";
619 print scalar keys %h, "\n";
625 sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
626 sub foo::FETCH { $_[0]->{value} }
627 tie my $VAR, 'foo', '42';
628 foreach my $var ($VAR) {
629 print +($var eq $VAR) ? "yes\n" : "no\n";
634 sub TIEARRAY { bless [], 'main' }
639 print "tied\n" if tied @a;
642 sub TIEHASH { bless [], 'main' }
647 print "tied\n" if tied %h;
650 # RT 20727: PL_defoutgv is left as a tied element
651 sub TIESCALAR { return bless {}, 'main' }
656 select(); # this used to coredump or assert fail
662 # RT 23810: eval in die in FETCH can corrupt context stack
664 my $file = 'rt23810.pm';
670 my ($str, $eval) = @_;
671 open my $fh, '>', $file or die "Can't create $file: $!\n";
676 eval { require $pm; $s .= '-ENDE' }
686 sub TIEHASH { bless {} }
689 # 10 or more syntax errors makes yyparse croak()
690 my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
692 if ($_[1] eq 'eval') {
694 eval q[BEGIN { die; $s .= '-X1' }];
696 eval q[BEGIN { $x+ }];
700 $s .= '-S1' while $@ =~ /syntax error at/g;
703 $s .= '-S2' while $@ =~ /syntax error at/g;
705 elsif ($_[1] eq 'require') {
708 q[BEGIN { die; $s .= '-X1' }],
713 for my $i (0..$#text) {
715 do_require($txt[$i], 0) if $e;;
716 do_require($txt[$i], 1);
719 elsif ($_[1] eq 'exit') {
720 eval q[exit(0); print "overshot eval\n"];
723 print "unknown key: '$_[1]'\n";
730 for my $action(qw(eval require)) {
731 $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
732 $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
733 $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
734 $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
736 1 while unlink $file;
739 print "overshot main\n"; # shouldn't reach here
742 eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
743 eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
744 eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
745 eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
746 require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
747 require: s1=REQUIRE-0-RQ
748 require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
749 require: s3=REQUIRE-0-RQ
751 # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
754 sub TIEARRAY { bless [], $_[0] }
755 sub TIEHASH { bless [], $_[0] }
756 sub FETCH { $_[0]->[$_[1]] }
757 sub STORE { $_[0]->[$_[1]] = $_[2] }
766 foreach ($a[0], $h{a}) {
769 # on failure, chucks up 'premature free' etc messages
773 # the initial fix for this bug caused tied scalar FETCH to be called
774 # multiple times when that scalar was an element in an array. Check it
775 # only gets called once now.
777 sub TIESCALAR { bless [], $_[0] }
779 sub FETCH { $c++; 0 }
781 sub STORE { $c += 100; 0 }
789 my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
794 # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
795 sub TIESCALAR { bless {}, __PACKAGE__ };
798 print "fetching... "; # make sure FETCH is called once per op
802 tie $foo, __PACKAGE__;
805 print "+ ", 0 + $foo, "\n";
806 print "** ", $foo**1, "\n";
807 print "* ", $foo*1, "\n";
808 print "/ ", $foo*1, "\n";
809 print "% ", $foo%123457, "\n";
810 print "- ", $foo-0, "\n";
811 print "neg ", - -$foo, "\n";
812 print "int ", int $foo, "\n";
813 print "abs ", abs $foo, "\n";
814 print "== ", 123456 == $foo, "\n";
815 print "< ", 123455 < $foo, "\n";
816 print "> ", 123457 > $foo, "\n";
817 print "<= ", 123456 <= $foo, "\n";
818 print ">= ", 123456 >= $foo, "\n";
819 print "!= ", 0 != $foo, "\n";
820 print "<=> ", 123457 <=> $foo, "\n";
823 fetching... ** 123456
828 fetching... neg 123456
829 fetching... int 123456
830 fetching... abs 123456
839 # Ties returning overloaded objects
843 '*{}' => sub { print '*{}'; \*100 },
844 '@{}' => sub { print '@{}'; \@100 },
845 '%{}' => sub { print '%{}'; \%100 },
846 '${}' => sub { print '${}'; \$100 },
849 $_ => sub { print "$op"; 100 }
850 } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> >
852 $o = bless [], overloaded;
854 sub TIESCALAR { bless {}, "" }
855 sub FETCH { print "fetching... "; $o }
859 $ghew=undef; 1+$ghew; print "\n";
860 $ghew=undef; $ghew**1; print "\n";
861 $ghew=undef; $ghew*1; print "\n";
862 $ghew=undef; $ghew/1; print "\n";
863 $ghew=undef; $ghew%1; print "\n";
864 $ghew=undef; $ghew-1; print "\n";
865 $ghew=undef; -$ghew; print "\n";
866 $ghew=undef; int $ghew; print "\n";
867 $ghew=undef; abs $ghew; print "\n";
868 $ghew=undef; 1 == $ghew; print "\n";
869 $ghew=undef; $ghew<1; print "\n";
870 $ghew=undef; $ghew>1; print "\n";
871 $ghew=undef; $ghew<=1; print "\n";
872 $ghew=undef; $ghew >=1; print "\n";
873 $ghew=undef; $ghew != 1; print "\n";
874 $ghew=undef; $ghew<=>1; print "\n";
875 $ghew=\*shrext; *$ghew; print "\n";
876 $ghew=\@spled; @$ghew; print "\n";
877 $ghew=\%frit; %$ghew; print "\n";
878 $ghew=\$drile; $$ghew; print "\n";