1240116Smarcel#!/usr/bin/perl
2240116Smarcel#
3240116Smarcel# Check miscellaneous tied-array interface methods
4240116Smarcel# EXTEND, CLEAR, DELETE, EXISTS
5240116Smarcel#
6240116Smarcel
7240116Smarceluse strict;
8240116Smarceluse warnings;
9240116Smarcel
10240116Smarcel
11240116Smarcelmy $file = "tf17-$$.txt";
12240116Smarcel$: = Tie::File::_default_recsep();
13240116Smarcel1 while unlink $file;
14240116Smarcel
15240116Smarcelprint "1..35\n";
16240116Smarcel
17240116Smarcelmy $N = 1;
18240116Smarceluse Tie::File;
19240116Smarcelprint "ok $N\n"; $N++;
20240116Smarcel
21240116Smarcelmy @a;
22240116Smarcelmy $o = tie @a, 'Tie::File', $file, autodefer => 0;
23240116Smarcelprint $o ? "ok $N\n" : "not ok $N\n";
24240116Smarcel$N++;
25240116Smarcel
26275988Sngie# (3-8) EXTEND
27275988Sngie$o->EXTEND(3);
28240116Smarcelcheck_contents("$:$:$:");
29275988Sngie$o->EXTEND(4);
30275988Sngiecheck_contents("$:$:$:$:");
31240116Smarcel$o->EXTEND(3);
32240116Smarcelcheck_contents("$:$:$:$:");
33275988Sngie
34275988Sngie# (9-10) CLEAR
35240116Smarcel@a = ();
36240116Smarcelcheck_contents("");
37240116Smarcel
38240116Smarcel# (11-20) EXISTS
39240116Smarcelif ($] >= 5.006) {
40240116Smarcel  eval << 'TESTS';
41240116Smarcelprint !exists $a[0] ? "ok $N\n" : "not ok $N\n";
42240116Smarcel$N++;
43240116Smarcel$a[0] = "I like pie.";
44240116Smarcelprint exists $a[0] ? "ok $N\n" : "not ok $N\n";
45240116Smarcel$N++;
46240116Smarcelprint !exists $a[1] ? "ok $N\n" : "not ok $N\n";
47240116Smarcel$N++;
48240116Smarcel$a[2] = "GIVE ME PIE";
49275988Sngieprint exists $a[0] ? "ok $N\n" : "not ok $N\n";
50275988Sngie$N++;
51275988Sngie# exists $a[1] is not defined by this module under these circumstances
52275988Sngieprint exists $a[1] ? "ok $N\n" : "ok $N\n";
53275988Sngie$N++;
54275988Sngieprint exists $a[2] ? "ok $N\n" : "not ok $N\n";
55240116Smarcel$N++;
56240116Smarcelprint exists $a[-1] ? "ok $N\n" : "not ok $N\n";
57240116Smarcel$N++;
58240116Smarcelprint exists $a[-2] ? "ok $N\n" : "not ok $N\n";
59240116Smarcel$N++;
60240116Smarcelprint exists $a[-3] ? "ok $N\n" : "not ok $N\n";
61240116Smarcel$N++;
62240116Smarcelprint !exists $a[-4] ? "ok $N\n" : "not ok $N\n";
63240116Smarcel$N++;
64240116SmarcelTESTS
65240116Smarcel  } else {                      # perl 5.005 doesn't have exists $array[1]
66240116Smarcel    for (11..20) {
67240116Smarcel      print "ok $_ \# skipped (no exists for arrays)\n";
68240116Smarcel          $N++;
69240116Smarcel    }
70240116Smarcel  }
71240116Smarcel
72240116Smarcelmy $del;
73240116Smarcel
74240116Smarcel# (21-35) DELETE
75240116Smarcelif ($] >= 5.006) {
76  eval << 'TESTS';
77$del = delete $a[0];
78check_contents("$:$:GIVE ME PIE$:");
79# 20020317 Through 0.20, the 'delete' function returned the wrong values.
80expect($del, "I like pie.");
81$del = delete $a[2];
82check_contents("$:$:");
83expect($del, "GIVE ME PIE");
84$del = delete $a[0];
85check_contents("$:$:");
86expect($del, "");
87$del = delete $a[1];
88check_contents("$:");
89expect($del, "");
90
91# 20020317 Through 0.20, we had a bug where deleting an element past the 
92# end of the array would actually extend the array to that length.
93$del = delete $a[4];
94check_contents("$:");
95expect($del, undef);
96
97
98
99TESTS
100  } else {                      # perl 5.005 doesn't have delete $array[1]
101    for (21..35) {
102      print "ok $_ \# skipped (no delete for arrays)\n";
103          $N++;
104    }
105  }
106
107use POSIX 'SEEK_SET';
108sub check_contents {
109  my $x = shift;
110  local *FH = $o->{fh};
111  seek FH, 0, SEEK_SET;
112  my $a;
113  { local $/; $a = <FH> }
114  $a = "" unless defined $a;
115  if ($a eq $x) {
116    print "ok $N\n";
117  } else {
118    ctrlfix(my $msg = "# expected <$x>, got <$a>");
119    print "not ok $N # $msg\n";
120  }
121  $N++;
122  print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n";
123  $N++;
124}
125
126sub expect {
127  if (@_ == 1) {
128    print $_[0] ? "ok $N\n" : "not ok $N\n";
129  } elsif (@_ == 2) {
130    my ($a, $x) = @_;
131    if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
132    elsif (  defined($a) && ! defined($x)) { 
133      ctrlfix(my $msg = "expected UNDEF, got <$a>");
134      print "not ok $N \# $msg\n";
135    }
136    elsif (! defined($a) &&   defined($x)) { 
137      ctrlfix(my $msg = "expected <$x>, got UNDEF");
138      print "not ok $N \# $msg\n";
139    } elsif ($a eq $x) { print "ok $N\n" }
140    else {
141      ctrlfix(my $msg = "expected <$x>, got <$a>");
142      print "not ok $N \# $msg\n";
143    }
144  } else {
145    die "expect() got ", scalar(@_), " args, should have been 1 or 2";
146  }
147  $N++;
148}
149
150sub ctrlfix {
151  for (@_) {
152    s/\n/\\n/g;
153    s/\r/\\r/g;
154  }
155}
156
157END {
158  undef $o;
159  untie @a;
160  1 while unlink $file;
161}
162
163
164