17_misc_meth.t revision 1.1.1.2 
1#!/usr/bin/perl
2#
3# Check miscellaneous tied-array interface methods
4# EXTEND, CLEAR, DELETE, EXISTS
5#
6
7use strict;
8use warnings;
9
10
11my $file = "tf17-$$.txt";
12$: = Tie::File::_default_recsep();
131 while unlink $file;
14
15print "1..35\n";
16
17my $N = 1;
18use Tie::File;
19print "ok $N\n"; $N++;
20
21my @a;
22my $o = tie @a, 'Tie::File', $file, autodefer => 0;
23print $o ? "ok $N\n" : "not ok $N\n";
24$N++;
25
26# (3-8) EXTEND
27$o->EXTEND(3);
28check_contents("$:$:$:");
29$o->EXTEND(4);
30check_contents("$:$:$:$:");
31$o->EXTEND(3);
32check_contents("$:$:$:$:");
33
34# (9-10) CLEAR
35@a = ();
36check_contents("");
37
38# (11-20) EXISTS
39if ($] >= 5.006) {
40  eval << 'TESTS';
41print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
42$N++;
43$a[0] = "I like pie.";
44print exists $a[0] ? "ok $N\n" : "not ok $N\n";
45$N++;
46print !exists $a[1] ? "ok $N\n" : "not ok $N\n";
47$N++;
48$a[2] = "GIVE ME PIE";
49print exists $a[0] ? "ok $N\n" : "not ok $N\n";
50$N++;
51# exists $a[1] is not defined by this module under these circumstances
52print exists $a[1] ? "ok $N\n" : "ok $N\n";
53$N++;
54print exists $a[2] ? "ok $N\n" : "not ok $N\n";
55$N++;
56print exists $a[-1] ? "ok $N\n" : "not ok $N\n";
57$N++;
58print exists $a[-2] ? "ok $N\n" : "not ok $N\n";
59$N++;
60print exists $a[-3] ? "ok $N\n" : "not ok $N\n";
61$N++;
62print !exists $a[-4] ? "ok $N\n" : "not ok $N\n";
63$N++;
64TESTS
65  } else {                      # perl 5.005 doesn't have exists $array[1]
66    for (11..20) {
67      print "ok $_ \# skipped (no exists for arrays)\n";
68          $N++;
69    }
70  }
71
72my $del;
73
74# (21-35) DELETE
75if ($] >= 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