tie.t revision 1
#!./perl
# Add new tests to the end with format:
# ########
#
# # test description
# Test code
# EXPECT
# Warn or die msgs (if any) at - line 1234
#
chdir 't' if -d 't';
@INC = '../lib';
$|=1;
undef $/;
require './test.pl';
for (@prgs){
++$i;
print("not ok $i # bad test format\n"), next
$results =~ s/\n+$//;
$expected =~ s/\n+$//;
}
# standard behaviour, without any extra references
untie %h;
########
# standard behaviour, without any extra references
use base 'Tie::StdHash';
sub UNTIE
{
}
}
untie %h;
########
# standard behaviour, with 1 extra reference
untie %h;
########
# standard behaviour, with 1 extra reference via tied
$a = tied %h;
untie %h;
########
# standard behaviour, with 1 extra reference which is destroyed
$a = 0 ;
untie %h;
########
# standard behaviour, with 1 extra reference via tied which is destroyed
$a = tied %h;
$a = 0 ;
untie %h;
########
# strict behaviour, without any extra references
use warnings 'untie';
untie %h;
########
# strict behaviour, with 1 extra references generating an error
use warnings 'untie';
untie %h;
########
# strict behaviour, with 1 extra references via tied generating an error
use warnings 'untie';
$a = tied %h;
untie %h;
########
# strict behaviour, with 1 extra references which are destroyed
use warnings 'untie';
$a = 0 ;
untie %h;
########
# strict behaviour, with extra 1 references via tied which are destroyed
use warnings 'untie';
$a = tied %h;
$a = 0 ;
untie %h;
########
# strict error behaviour, with 2 extra references
use warnings 'untie';
$b = tied %h ;
untie %h;
########
# strict behaviour, check scope of strictness.
$C = $B = tied %H ;
{
untie %h;
}
untie %H;
########
# Forbidden aggregate self-ties
{
my %c;
}
########
# Allowed scalar self-ties
my $destroyed = 0;
sub Self::DESTROY { $destroyed = 1; }
{
my $c = 42;
}
########
# Allowed glob self-ties
my $destroyed = 0;
my $printed = 0;
sub Self2::DESTROY { $destroyed = 1; }
{
use Symbol;
my $c = gensym;
print $c 'Hello';
}
########
# Allowed IO self-ties
my $destroyed = 0;
sub Self3::DESTROY { $destroyed = 1; }
{
my $c = geniosym;
print $c 'Hello';
}
########
# TODO IO "self-tie" via TEMP glob
my $destroyed = 0;
sub Self3::DESTROY { $destroyed = 1; }
{
my $c = geniosym;
print $c 'Hello';
}
########
# Interaction of tie and vec
my ($a, $b);
$a = $b;
########
# correct unlocalisation of tied hashes (patch #16431)
########
# An attempt at lvalueable barewords broke this
Execution of - aborted due to compilation errors.
########
# localizing tied hash slices
$ENV{FooA} = 1;
$ENV{FooB} = 2;
print exists $ENV{FooA} ? 1 : 0, "\n";
print exists $ENV{FooB} ? 2 : 0, "\n";
print exists $ENV{FooC} ? 3 : 0, "\n";
{
local @ENV{qw(FooA FooC)};
print exists $ENV{FooA} ? 4 : 0, "\n";
print exists $ENV{FooB} ? 5 : 0, "\n";
print exists $ENV{FooC} ? 6 : 0, "\n";
}
print exists $ENV{FooA} ? 7 : 0, "\n";
print exists $ENV{FooB} ? 8 : 0, "\n";
print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
EXPECT
1
2
0
4
5
6
7
8
0
########
#
# FETCH freeing tie'd SV
sub FETCH { *a = \1; 1 }
print $a;
########
# [20020716.007] - nested FETCHES
my @f1;
my @f2;
my %f3;
my %f4;
2
3
########
# test untie() from within FETCH
sub FETCH {
my $self = shift;
}
$a->{foo}; # access once
# the hash element should not be tied anymore
########
# the tmps returned by FETCH should appear to be SCALAR
# (even though they are now implemented using PVLVs.)
package X;
sub FETCH {1}
my (%h, @a);
my $r1 = \$h{1};
my $r2 = \$a[0];
$s=~ s/\(0x\w+\)//g;
print $s, "\n";
########
# [perl #23287] segfault in untie
my $var;
########
# Test case from perlmonks by runrig
# "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
# 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
# is accessed through a closure)."
use strict;
use warnings;
sub TIESCALAR {
}
sub FETCH {
my $self = shift;
print "Untie\n";
}
my $var;
print "One\n";
print "Two\n";
print "Three\n";
4
4
4
########
# [perl #22297] cannot untie scalar from within tied FETCH
my $counter = 0;
my $x = 7;
my $ref = \$x;
my $y;
$y = $x;
$y = $x;
$y = $x;
$y = $x;
#print "WILL EXTERNAL UNTIE $ref\n";
$y = $x;
$y = $x;
$y = $x;
$y = $x;
#print "counter = $counter\n";
sub TIESCALAR
{
my $pkg = shift;
}
sub FETCH
{
my $self = shift;
#print "WILL INTERNAL UNITE $ref\n";
$counter++;
return $val;
}
########
# test SCALAR method
sub TIEHASH {
my $pkg = shift;
}
sub STORE {
$_[0]->{$_[1]} = $_[2];
}
sub FETCH {
$_[0]->{$_[1]}
}
sub CLEAR {
%{ $_[0] } = ();
}
sub SCALAR {
print "SCALAR\n";
return 0 if ! keys %{$_[0]};
}
%h = ();
2/2
0
########
# test scalar on tied hash when no SCALAR method has been given
sub TIEHASH {
my $pkg = shift;
}
sub STORE {
$_[0]->{$_[1]} = $_[2];
}
sub FETCH {
$_[0]->{$_[1]}
}
sub CLEAR {
%{ $_[0] } = ();
}
sub FIRSTKEY {
my $a = keys %{ $_[0] };
print "FIRSTKEY\n";
each %{ $_[0] };
}
if (!%h) {
print "empty\n";
} else {
print "not empty\n";
}
print "not empty\n" if %h;
print "not empty\n" if %h;
print "-->\n";
print "<--\n";
print "not empty\n" if %h;
%h = ();
print "empty\n" if ! %h;
-->
<--