1#!/usr/bin/perl
2#
3# Check miscellaneous tied-array interface methods
4# EXTEND, CLEAR, DELETE, EXISTS
5#
6
7my $file = "tf17-$$.txt";
8$: = Tie::File::_default_recsep();
91 while unlink $file;
10
11print "1..35\n";
12
13my $N = 1;
14use Tie::File;
15print "ok $N\n"; $N++;
16
17my $o = tie @a, 'Tie::File', $file, autodefer => 0;
18print $o ? "ok $N\n" : "not ok $N\n";
19$N++;
20
21# (3-8) EXTEND
22$o->EXTEND(3);
23check_contents("$:$:$:");
24$o->EXTEND(4);
25check_contents("$:$:$:$:");
26$o->EXTEND(3);
27check_contents("$:$:$:$:");
28
29# (9-10) CLEAR
30@a = ();
31check_contents("");
32
33# (11-20) EXISTS
34if ($] >= 5.006) {
35  eval << 'TESTS';
36print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
37$N++;
38$a[0] = "I like pie.";
39print exists $a[0] ? "ok $N\n" : "not ok $N\n";
40$N++;
41print !exists $a[1] ? "ok $N\n" : "not ok $N\n";
42$N++;
43$a[2] = "GIVE ME PIE";
44print exists $a[0] ? "ok $N\n" : "not ok $N\n";
45$N++;
46# exists $a[1] is not defined by this module under these circumstances
47print exists $a[1] ? "ok $N\n" : "ok $N\n";
48$N++;
49print exists $a[2] ? "ok $N\n" : "not ok $N\n";
50$N++;
51print exists $a[-1] ? "ok $N\n" : "not ok $N\n";
52$N++;
53print exists $a[-2] ? "ok $N\n" : "not ok $N\n";
54$N++;
55print exists $a[-3] ? "ok $N\n" : "not ok $N\n";
56$N++;
57print !exists $a[-4] ? "ok $N\n" : "not ok $N\n";
58$N++;
59TESTS
60  } else {                      # perl 5.005 doesn't have exists $array[1]
61    for (11..20) {
62      print "ok $_ \# skipped (no exists for arrays)\n";
63          $N++;
64    }
65  }
66
67my $del;
68
69# (21-35) DELETE
70if ($] >= 5.006) {
71  eval << 'TESTS';
72$del = delete $a[0];
73check_contents("$:$:GIVE ME PIE$:");
74# 20020317 Through 0.20, the 'delete' function returned the wrong values.
75expect($del, "I like pie.");
76$del = delete $a[2];
77check_contents("$:$:");
78expect($del, "GIVE ME PIE");
79$del = delete $a[0];
80check_contents("$:$:");
81expect($del, "");
82$del = delete $a[1];
83check_contents("$:");
84expect($del, "");
85
86# 20020317 Through 0.20, we had a bug where deleting an element past the
87# end of the array would actually extend the array to that length.
88$del = delete $a[4];
89check_contents("$:");
90expect($del, undef);
91
92
93
94TESTS
95  } else {                      # perl 5.005 doesn't have delete $array[1]
96    for (21..35) {
97      print "ok $_ \# skipped (no delete for arrays)\n";
98          $N++;
99    }
100  }
101
102use POSIX 'SEEK_SET';
103sub check_contents {
104  my $x = shift;
105  local *FH = $o->{fh};
106  seek FH, 0, SEEK_SET;
107  my $a;
108  { local $/; $a = <FH> }
109  $a = "" unless defined $a;
110  if ($a eq $x) {
111    print "ok $N\n";
112  } else {
113    ctrlfix(my $msg = "# expected <$x>, got <$a>");
114    print "not ok $N # $msg\n";
115  }
116  $N++;
117  print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n";
118  $N++;
119}
120
121sub expect {
122  if (@_ == 1) {
123    print $_[0] ? "ok $N\n" : "not ok $N\n";
124  } elsif (@_ == 2) {
125    my ($a, $x) = @_;
126    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
127    elsif (  defined($a) && ! defined($x)) {
128      ctrlfix(my $msg = "expected UNDEF, got <$a>");
129      print "not ok $N \# $msg\n";
130    }
131    elsif (! defined($a) &&   defined($x)) {
132      ctrlfix(my $msg = "expected <$x>, got UNDEF");
133      print "not ok $N \# $msg\n";
134    } elsif ($a eq $x) { print "ok $N\n" }
135    else {
136      ctrlfix(my $msg = "expected <$x>, got <$a>");
137      print "not ok $N \# $msg\n";
138    }
139  } else {
140    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
141  }
142  $N++;
143}
144
145sub ctrlfix {
146  for (@_) {
147    s/\n/\\n/g;
148    s/\r/\\r/g;
149  }
150}
151
152END {
153  undef $o;
154  untie @a;
155  1 while unlink $file;
156}
157
158
159