17_misc_meth.t revision 1.1.1.1
1#!/usr/bin/perl 2# 3# Check miscellaneous tied-array interface methods 4# EXTEND, CLEAR, DELETE, EXISTS 5# 6 7my $file = "tf$$.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