cpan/Tie-File/t/17_misc_meth.t

   1 #!/usr/bin/perl
   2 #
   3 # Check miscellaneous tied-array interface methods
   4 # EXTEND, CLEAR, DELETE, EXISTS
   5 #
   6
   7 my $file = "tf$$.txt";
   8 $: = Tie::File::_default_recsep();
   9 1 while unlink $file;
  10
  11 print "1..35\n";
  12
  13 my $N = 1;
  14 use Tie::File;
  15 print "ok $N\n"; $N++;
  16
  17 my $o = tie @a, 'Tie::File', $file, autodefer => 0;
  18 print $o ? "ok $N\n" : "not ok $N\n";
  19 $N++;
  20
  21 # (3-8) EXTEND
  22 $o->EXTEND(3);
  23 check_contents("$:$:$:");
  24 $o->EXTEND(4);
  25 check_contents("$:$:$:$:");
  26 $o->EXTEND(3);
  27 check_contents("$:$:$:$:");
  28
  29 # (9-10) CLEAR
  30 @a = ();
  31 check_contents("");
  32
  33 # (11-20) EXISTS
  34 if ($] >= 5.006) {
  35   eval << 'TESTS';
  36 print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
  37 $N++;
  38 $a[0] = "I like pie.";
  39 print exists $a[0] ? "ok $N\n" : "not ok $N\n";
  40 $N++;
  41 print !exists $a[1] ? "ok $N\n" : "not ok $N\n";
  42 $N++;
  43 $a[2] = "GIVE ME PIE";
  44 print 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
  47 print exists $a[1] ? "ok $N\n" : "ok $N\n";
  48 $N++;
  49 print exists $a[2] ? "ok $N\n" : "not ok $N\n";
  50 $N++;
  51 print exists $a[-1] ? "ok $N\n" : "not ok $N\n";
  52 $N++;
  53 print exists $a[-2] ? "ok $N\n" : "not ok $N\n";
  54 $N++;
  55 print exists $a[-3] ? "ok $N\n" : "not ok $N\n";
  56 $N++;
  57 print !exists $a[-4] ? "ok $N\n" : "not ok $N\n";
  58 $N++;
  59 TESTS
  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
  67 my $del;
  68
  69 # (21-35) DELETE
  70 if ($] >= 5.006) {
  71   eval << 'TESTS';
  72 $del = delete $a[0];
  73 check_contents("$:$:GIVE ME PIE$:");
  74 # 20020317 Through 0.20, the 'delete' function returned the wrong values.
  75 expect($del, "I like pie.");
  76 $del = delete $a[2];
  77 check_contents("$:$:");
  78 expect($del, "GIVE ME PIE");
  79 $del = delete $a[0];
  80 check_contents("$:$:");
  81 expect($del, "");
  82 $del = delete $a[1];
  83 check_contents("$:");
  84 expect($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];
  89 check_contents("$:");
  90 expect($del, undef);
  91
  92
  93
  94 TESTS
  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
 102 use POSIX 'SEEK_SET';
 103 sub 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
 121 sub 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
 145 sub ctrlfix {
 146   for (@_) {
 147     s/\n/\\n/g;
 148     s/\r/\\r/g;
 149   }
 150 }
 151
 152 END {
 153   undef $o;
 154   untie @a;
 155   1 while unlink $file;
 156 }
 157
 158