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