#
chdir 't' if -d 't';
-@INC = '../lib';
-$ENV{PERL5LIB} = "../lib";
+require './test.pl';
+set_up_inc('../lib');
$|=1;
-undef $/;
-@prgs = split /^########\n/m, <DATA>;
-
-require './test.pl';
-plan(tests => scalar @prgs);
-for (@prgs){
- ++$i;
- my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
- print("not ok $i # bad test format\n"), next
- unless defined $expected;
- my ($testname) = $prog =~ /^# (.*)\n/m;
- $testname ||= '';
- $TODO = $testname =~ s/^TODO //;
- $results =~ s/\n+$//;
- $expected =~ s/\n+$//;
+run_multiple_progs('', \*DATA);
- fresh_perl_is($prog, $expected, {}, $testname);
-}
+done_testing();
__END__
untie %h;
EXPECT
########
+# SKIP ?!defined &DynaLoader::boot_DynaLoader && !eval 'require base'
+# (skip under miniperl if base.pm is not in lib/ yet)
# standard behaviour, without any extra references
use Tie::Hash ;
0
########
#
-# FETCH freeing tie'd SV
+# FETCH freeing tie'd SV still works
sub TIESCALAR { bless [] }
-sub FETCH { *a = \1; 1 }
+sub FETCH { *a = \1; 2 }
tie $a, 'main';
print $a;
EXPECT
+2
########
-# [20020716.007] - nested FETCHES
+# [20020716.007 (#10080)] - nested FETCHES
sub F1::TIEARRAY { bless [], 'F1' }
sub F1::FETCH { 1 }
# Test case from perlmonks by runrig
# http://www.perlmonks.org/index.pl?node_id=273490
# "Here is what I tried. I think its similar to what you've tried
-# above. Its odd but convienient that after untie'ing you are left with
+# above. Its odd but convenient that after untie'ing you are left with
# a variable that has the same value as was last returned from
# FETCH. (At least on my perl v5.6.1). So you don't need to pass a
# reference to the variable in order to set it after the untie (here it
EXPECT
01
########
+# SKIP ? $IS_EBCDIC
+# skipped on EBCDIC because "2" | "8" is 0xFA (not COLON as it is on ASCII),
+# which isn't representable in this file's UTF-8 encoding.
# Bug 53482 (and maybe others)
+
sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
sub FETCH { ${$_[0]} }
tie my $x1, "main", 2;
}
fileno FOO; tie @a, "FOO"
EXPECT
-Can't locate object method "TIEARRAY" via package "FOO" at - line 5.
+Can't locate object method "TIEARRAY" via package "FOO" (perhaps you forgot to load "FOO"?) at - line 5.
+########
+# tie into empty package name
+tie $foo, "";
+EXPECT
+Can't locate object method "TIESCALAR" via package "main" at - line 2.
+########
+# tie into undef package name
+tie $foo, undef;
+EXPECT
+Can't locate object method "TIESCALAR" via package "main" at - line 2.
+########
+# tie into nonexistent glob [RT#130623 assertion failure]
+tie $foo, *FOO;
+EXPECT
+Can't locate object method "TIESCALAR" via package "FOO" at - line 2.
+########
+# tie into glob when package exists but not method: no "*", no "main::"
+{ package PackageWithoutTIESCALAR }
+tie $foo, *PackageWithoutTIESCALAR;
+EXPECT
+Can't locate object method "TIESCALAR" via package "PackageWithoutTIESCALAR" at - line 3.
+########
+# tie into reference [RT#130623 assertion failure]
+eval { tie $foo, \"nope" };
+my $exn = $@ // "";
+print $exn =~ s/0x\w+/0xNNN/rg;
+EXPECT
+Can't locate object method "TIESCALAR" via package "SCALAR(0xNNN)" at - line 2.
+########
+#
+# STORE freeing tie'd AV
+sub TIEARRAY { bless [] }
+sub STORE { *a = []; 1 }
+sub STORESIZE { }
+sub EXTEND { }
+tie @a, 'main';
+$a[0] = 1;
+EXPECT
+########
+#
+# CLEAR freeing tie'd AV
+sub TIEARRAY { bless [] }
+sub CLEAR { *a = []; 1 }
+sub STORESIZE { }
+sub EXTEND { }
+sub STORE { }
+tie @a, 'main';
+@a = (1,2,3);
+EXPECT
+########
+#
+# FETCHSIZE freeing tie'd AV
+sub TIEARRAY { bless [] }
+sub FETCHSIZE { *a = []; 100 }
+sub STORESIZE { }
+sub EXTEND { }
+sub STORE { }
+tie @a, 'main';
+print $#a,"\n"
+EXPECT
+99
+########
+#
+# [perl #86328] Crash when freeing tie magic that can increment the refcnt
+
+eval { require Scalar::Util } or print("ok\n"), exit;
+
+sub TIEHASH {
+ return $_[1];
+}
+*TIEARRAY = *TIEHASH;
+
+sub DESTROY {
+ my ($tied) = @_;
+ my $b = $tied->[0];
+}
+
+my $a = {};
+my $o = bless [];
+Scalar::Util::weaken($o->[0] = $a);
+tie %$a, "main", $o;
+
+my $b = [];
+my $p = bless [];
+Scalar::Util::weaken($p->[0] = $b);
+tie @$b, "main", $p;
+
+# Done setting up the evil data structures
+
+$a = undef;
+$b = undef;
+print "ok\n";
+
+EXPECT
+ok
+########
+#
+# Localising a tied COW scalar should not make it read-only.
+
+sub TIESCALAR { bless [] }
+sub FETCH { __PACKAGE__ }
+sub STORE {}
+tie $x, "";
+"$x";
+{
+ local $x;
+ $x = 3;
+}
+print "ok\n";
+EXPECT
+ok
+########
+#
+# Nor should it be impossible to tie COW scalars that are already PVMGs.
+
+sub TIESCALAR { bless [] }
+$x = *foo; # PVGV
+undef $x; # downgrade to PVMG
+$x = __PACKAGE__; # PVMG + COW
+tie $x, ""; # bang!
+
+print STDERR "ok\n";
+
+# However, one should not be able to tie read-only glob copies, which look
+# a bit like kine internally (FAKE + READONLY).
+$y = *foo;
+Internals::SvREADONLY($y,1);
+tie $y, "";
+
+EXPECT
+ok
+Modification of a read-only value attempted at - line 16.
+########
+#
+# And one should not be able to tie read-only COWs
+for(__PACKAGE__) { tie $_, "" }
+sub TIESCALAR {bless []}
+EXPECT
+Modification of a read-only value attempted at - line 3.
+########
+
+# Similarly, read-only regexps cannot be tied.
+sub TIESCALAR { bless [] }
+$y = ${qr//};
+Internals::SvREADONLY($y,1);
+tie $y, "";
+
+EXPECT
+Modification of a read-only value attempted at - line 6.
########
# tied() should still work on tied scalars after glob assignment
EXPECT
main
f
+########
+
+# (un)tie $glob_copy vs (un)tie *$glob_copy
+sub TIESCALAR { print "TIESCALAR\n"; bless [] }
+sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] }
+sub FETCH { print "never called\n" }
+$f = *foo;
+tie *$f, "";
+tie $f, "";
+untie $f;
+print "ok 1\n" if !tied $f;
+() = $f; # should not call FETCH
+untie *$f;
+print "ok 2\n" if !tied *foo;
+EXPECT
+TIEHANDLE
+TIESCALAR
+ok 1
+ok 2
+########
+
+# RT #8611 mustn't goto outside the magic stack
+sub TIESCALAR { warn "tiescalar\n"; bless [] }
+sub FETCH { warn "fetch()\n"; goto FOO; }
+tie $f, "";
+warn "before fetch\n";
+my $a = "$f";
+warn "before FOO\n";
+FOO:
+warn "after FOO\n";
+EXPECT
+tiescalar
+before fetch
+fetch()
+Can't find label FOO at - line 4.
+########
+
+# RT #8611 mustn't goto outside the magic stack
+sub TIEHANDLE { warn "tiehandle\n"; bless [] }
+sub PRINT { warn "print()\n"; goto FOO; }
+tie *F, "";
+warn "before print\n";
+print F "abc";
+warn "before FOO\n";
+FOO:
+warn "after FOO\n";
+EXPECT
+tiehandle
+before print
+print()
+Can't find label FOO at - line 4.
+########
+
+# \&$tied with $tied holding a reference before the fetch (but not after)
+sub ::72 { 73 };
+sub TIESCALAR {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my $x, "main";
+$x = \$y;
+\&$x;
+print "ok\n";
+EXPECT
+ok
+########
+
+# \&$tied with $tied holding a PVLV glob before the fetch (but not after)
+sub ::72 { 73 };
+sub TIEARRAY {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my @x, "main";
+my $elem = \$x[0];
+$$elem = *bar;
+print &{\&$$elem}, "\n";
+EXPECT
+73
+########
+
+# \&$tied with $tied holding a PVGV glob before the fetch (but not after)
+local *72 = sub { 73 };
+sub TIESCALAR {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my $x, "main";
+$x = *bar;
+print &{\&$x}, "\n";
+EXPECT
+73
+########
+
+# Lexicals should not be visible to magic methods on scope exit
+BEGIN { unless (defined &DynaLoader::boot_DynaLoader) {
+ print "HASH\nHASH\nARRAY\nARRAY\n"; exit;
+}}
+use Scalar::Util 'weaken';
+{ package xoufghd;
+ sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: }
+ *TIEARRAY = *TIEHASH;
+ DESTROY {
+ bless ${$_[0]} || return, 0;
+} }
+for my $sub (
+ # hashes: ties before backrefs
+ sub {
+ my %hash;
+ $ref = ref \%hash;
+ tie %hash, xoufghd::, \%hash;
+ 1;
+ },
+ # hashes: backrefs before ties
+ sub {
+ my %hash;
+ $ref = ref \%hash;
+ weaken(my $x = \%hash);
+ tie %hash, xoufghd::, \%hash;
+ 1;
+ },
+ # arrays: ties before backrefs
+ sub {
+ my @array;
+ $ref = ref \@array;
+ tie @array, xoufghd::, \@array;
+ 1;
+ },
+ # arrays: backrefs before ties
+ sub {
+ my @array;
+ $ref = ref \@array;
+ weaken(my $x = \@array);
+ tie @array, xoufghd::, \@array;
+ 1;
+ },
+) {
+ &$sub;
+ &$sub;
+ print $ref, "\n";
+}
+EXPECT
+HASH
+HASH
+ARRAY
+ARRAY
+########
+
+# Localising a tied variable with a typeglob in it should copy magic
+sub TIESCALAR{bless[]}
+sub FETCH{warn "fetching\n"; *foo}
+sub STORE{}
+tie $x, "";
+local $x;
+warn "before";
+"$x";
+warn "after";
+EXPECT
+fetching
+before at - line 8.
+fetching
+after at - line 10.
+########
+
+# tied returns same value as tie
+sub TIESCALAR{bless[]}
+$tyre = \tie $tied, "";
+print "ok\n" if \tied $tied == $tyre;
+EXPECT
+ok
+########
+
+# tied arrays should always be AvREAL
+$^W=1;
+sub TIEARRAY{bless[]}
+sub {
+ tie @_, "";
+ \@_; # used to produce: av_reify called on tied array at - line 7.
+}->(1);
+EXPECT
+########
+
+# [perl #67490] scalar-tying elements of magic hashes
+sub TIESCALAR{bless[]}
+sub STORE{}
+tie $ENV{foo}, '';
+$ENV{foo} = 78;
+delete $ENV{foo};
+tie $^H{foo}, '';
+$^H{foo} = 78;
+delete $^H{foo};
+EXPECT
+########
+
+# [perl #35865, #43011] autovivification should call FETCH after STORE
+# because perl does not know that the FETCH would have returned the same
+# thing that was just stored.
+
+# This package never likes to take ownership of other people’s refs. It
+# always makes its own copies. (For simplicity, it only accepts hashes.)
+package copier {
+ sub TIEHASH { bless {} }
+ sub FETCH { $_[0]{$_[1]} }
+ sub STORE { $_[0]{$_[1]} = { %{ $_[2] } } }
+}
+tie my %h, copier::;
+$h{i}{j} = 'k';
+print $h{i}{j}, "\n";
+EXPECT
+k
+########
+
+# [perl #8931] FETCH for tied $" called an odd number of times.
+use strict;
+my $i = 0;
+sub A::TIESCALAR {bless [] => 'A'}
+sub A::FETCH {print ++ $i, "\n"}
+my @a = ("", "", "");
+
+tie $" => 'A';
+"@a";
+
+$i = 0;
+tie my $a => 'A';
+join $a, 1..10;
+EXPECT
+1
+1
+########
+
+# [perl #9391] return value from 'tied' not discarded soon enough
+use warnings;
+tie @a, 'T';
+if (tied @a) {
+untie @a;
+}
+
+sub T::TIEARRAY { my $s; bless \$s => "T" }
+EXPECT
+########
+
+# NAME Test that tying a hash does not leak a deleted iterator
+# This produced unbalanced string table warnings under
+# PERL_DESTRUCT_LEVEL=2.
+package l {
+ sub TIEHASH{bless[]}
+}
+$h = {foo=>0};
+each %$h;
+delete $$h{foo};
+tie %$h, 'l';
+EXPECT
+########
+
+# NAME EXISTS on arrays
+sub TIEARRAY{bless[]};
+sub FETCHSIZE { 50 }
+sub EXISTS { print "does $_[1] exist?\n" }
+tie @a, "";
+exists $a[1];
+exists $a[-1];
+$NEGATIVE_INDICES=1;
+exists $a[-1];
+EXPECT
+does 1 exist?
+does 49 exist?
+does -1 exist?
+########
+
+# Crash when using negative index on array tied to non-object
+sub TIEARRAY{bless[]};
+${\tie @a, ""} = undef;
+eval { $_ = $a[-1] }; print $@;
+eval { $a[-1] = '' }; print $@;
+eval { delete $a[-1] }; print $@;
+eval { exists $a[-1] }; print $@;
+
+EXPECT
+Can't call method "FETCHSIZE" on an undefined value at - line 5.
+Can't call method "FETCHSIZE" on an undefined value at - line 6.
+Can't call method "FETCHSIZE" on an undefined value at - line 7.
+Can't call method "FETCHSIZE" on an undefined value at - line 8.
+########
+
+# Crash when reading negative index when NEGATIVE_INDICES stub exists
+sub NEGATIVE_INDICES;
+sub TIEARRAY{bless[]};
+sub FETCHSIZE{}
+tie @a, "";
+print "ok\n" if ! defined $a[-1];
+EXPECT
+ok
+########
+
+# Assigning vstrings to tied scalars
+sub TIESCALAR{bless[]};
+sub STORE { print ref \$_[1], "\n" }
+tie $x, ""; $x = v3;
+EXPECT
+VSTRING
+########
+
+# [perl #27010] Tying deferred elements
+$\="\n";
+sub TIESCALAR{bless[]};
+sub {
+ tie $_[0], "";
+ print ref tied $h{k};
+ tie $h{l}, "";
+ print ref tied $_[1];
+ untie $h{k};
+ print tied $_[0] // 'undef';
+ untie $_[1];
+ print tied $h{l} // 'undef';
+ # check that tied and untie do not autovivify
+ # XXX should they autovivify?
+ tied $_[2];
+ print exists $h{m} ? "yes" : "no";
+ untie $_[2];
+ print exists $h{m} ? "yes" : "no";
+}->($h{k}, $h{l}, $h{m});
+EXPECT
+main
+main
+undef
+undef
+no
+no
+########
+
+# [perl #78194] Passing op return values to tie constructors
+sub TIEARRAY{
+ print \$_[1] == \$_[1] ? "ok\n" : "not ok\n";
+};
+tie @a, "", "$a$b";
+EXPECT
+ok
+########
+
+# Scalar-tied locked hash keys and copy-on-write
+use Tie::Scalar;
+tie $h{foo}, Tie::StdScalar;
+tie $h{bar}, Tie::StdScalar;
+$h{foo} = __PACKAGE__; # COW
+$h{bar} = 1; # not COW
+# Moral equivalent of Hash::Util::lock_whatever, but miniperl-compatible
+Internals::SvREADONLY($h{foo},1);
+Internals::SvREADONLY($h{bar},1);
+print $h{foo}, "\n"; # should not croak
+# Whether the value is COW should make no difference here (whether the
+# behaviour is ultimately correct is another matter):
+local $h{foo};
+local $h{bar};
+print "ok\n" if (eval{ $h{foo} = 1 }||$@) eq (eval{ $h{bar} = 1 }||$@);
+EXPECT
+main
+ok
+########
+# SKIP ? $::IS_EBCDIC
+# skipped on EBCDIC because different from ASCII and results vary depending on
+# code page
+
+# &xsub and goto &xsub with tied @_
+use Tie::Array;
+tie @_, Tie::StdArray;
+@_ = "\xff";
+&utf8::encode;
+printf "%x\n", $_ for map ord, split //, $_[0];
+print "--\n";
+@_ = "\xff";
+& {sub { goto &utf8::encode }};
+printf "%x\n", $_ for map ord, split //, $_[0];
+EXPECT
+c3
+bf
+--
+c3
+bf
+########
+
+# Defelem pointing to nonexistent element of tied array
+
+use Tie::Array;
+# This sub is called with a deferred element. Inside the sub, $_[0] pros-
+# pectively points to element 10000 of @a.
+sub {
+ tie @a, "Tie::StdArray"; # now @a is tied
+ $#a = 20000; # and FETCHSIZE/AvFILL will now return a big number
+ $a[10000] = "crumpets\n";
+ $_ = "$_[0]"; # but defelems don't expect tied arrays and try to read
+ # AvARRAY[10000], which crashes
+}->($a[10000]);
+print
+EXPECT
+crumpets
+########
+
+# tied() in list assignment
+
+sub TIESCALAR : lvalue {
+ ${+pop} = bless [], shift;
+}
+tie $t, "", \$a;
+$a = 7;
+($a, $b) = (3, tied $t);
+print "a is $a\n";
+print "b is $b\n";
+EXPECT
+a is 3
+b is 7
+########
+# when assigning to array/hash, ensure get magic is processed first
+use Tie::Hash;
+my %tied;
+tie %tied, "Tie::StdHash";
+%tied = qw(a foo);
+my @a = values %tied;
+%tied = qw(b bar); # overwrites @a's contents unless magic was called
+print "$a[0]\n";
+my %h = ("x", values %tied);
+%tied = qw(c baz); # overwrites @a's contents unless magic was called
+print "$h{x}\n";
+
+EXPECT
+foo
+bar
+########
+# keys(%tied) in bool context without SCALAR present
+my ($f,$n) = (0,0);
+my %inner = (a =>1, b => 2, c => 3);
+sub TIEHASH { bless \%inner, $_[0] }
+sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { $n++; each %{$_[0]} }
+tie %h, 'main';
+my $x = !keys %h;
+print "[$x][$f][$n]\n";
+%inner = ();
+$x = !keys %h;
+print "[$x][$f][$n]\n";
+EXPECT
+[][1][0]
+[1][2][0]
+########
+# keys(%tied) in bool context with SCALAR present
+my ($f,$n, $s) = (0,0,0);
+my %inner = (a =>1, b => 2, c => 3);
+sub TIEHASH { bless \%inner, $_[0] }
+sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { $n++; each %{$_[0]} }
+sub SCALAR { $s++; scalar %{$_[0]} }
+tie %h, 'main';
+my $x = !keys %h;
+print "[$x][$f][$n][$s]\n";
+%inner = ();
+$x = !keys %h;
+print "[$x][$f][$n][$s]\n";
+EXPECT
+[][0][0][1]
+[1][0][0][2]
+########
+# keys(%tied) in scalar context without SCALAR present
+my ($f,$n) = (0,0);
+my %inner = (a =>1, b => 2, c => 3);
+sub TIEHASH { bless \%inner, $_[0] }
+sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { $n++; each %{$_[0]} }
+tie %h, 'main';
+my $x = keys %h;
+print "[$x][$f][$n]\n";
+%inner = ();
+$x = keys %h;
+print "[$x][$f][$n]\n";
+EXPECT
+[3][1][3]
+[0][2][3]
+########
+# keys(%tied) in scalar context with SCALAR present
+# XXX the behaviour of scalar(keys(%tied)) may change - it currently
+# doesn't make use of SCALAR() if present
+my ($f,$n, $s) = (0,0,0);
+my %inner = (a =>1, b => 2, c => 3);
+sub TIEHASH { bless \%inner, $_[0] }
+sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { $n++; each %{$_[0]} }
+sub SCALAR { $s++; scalar %{$_[0]} }
+tie %h, 'main';
+my $x = keys %h;
+print "[$x][$f][$n][$s]\n";
+%inner = ();
+$x = keys %h;
+print "[$x][$f][$n][$s]\n";
+EXPECT
+[3][1][3][0]
+[0][2][3][0]
https://perl5.git.perl.org / perl5.git / blobdiff