dist/Tie-File/t/09_gen_rs.t

   1 #!/usr/bin/perl
   2
   3 my $file = "tf09-$$.txt";
   4
   5 print "1..59\n";
   6
   7 use Fcntl 'O_RDONLY';
   8
   9 my $N = 1;
  10 use Tie::File;
  11 print "ok $N\n"; $N++;
  12
  13 $RECSEP = 'blah';
  14 my $o = tie @a, 'Tie::File', $file,
  15     recsep => $RECSEP, autochomp => 0, autodefer => 0;
  16 print $o ? "ok $N\n" : "not ok $N\n";
  17 $N++;
  18
  19
  20 # 3-4 create
  21 $a[0] = 'rec0';
  22 check_contents("rec0");
  23
  24 # 5-8 append
  25 $a[1] = 'rec1';
  26 check_contents("rec0", "rec1");
  27 $a[2] = 'rec2';
  28 check_contents("rec0", "rec1", "rec2");
  29
  30 # 9-14 same-length alterations
  31 $a[0] = 'new0';
  32 check_contents("new0", "rec1", "rec2");
  33 $a[1] = 'new1';
  34 check_contents("new0", "new1", "rec2");
  35 $a[2] = 'new2';
  36 check_contents("new0", "new1", "new2");
  37
  38 # 15-24 lengthening alterations
  39 $a[0] = 'long0';
  40 check_contents("long0", "new1", "new2");
  41 $a[1] = 'long1';
  42 check_contents("long0", "long1", "new2");
  43 $a[2] = 'long2';
  44 check_contents("long0", "long1", "long2");
  45 $a[1] = 'longer1';
  46 check_contents("long0", "longer1", "long2");
  47 $a[0] = 'longer0';
  48 check_contents("longer0", "longer1", "long2");
  49
  50 # 25-34 shortening alterations, including truncation
  51 $a[0] = 'short0';
  52 check_contents("short0", "longer1", "long2");
  53 $a[1] = 'short1';
  54 check_contents("short0", "short1", "long2");
  55 $a[2] = 'short2';
  56 check_contents("short0", "short1", "short2");
  57 $a[1] = 'sh1';
  58 check_contents("short0", "sh1", "short2");
  59 $a[0] = 'sh0';
  60 check_contents("sh0", "sh1", "short2");
  61
  62 # (35-38) file with holes
  63 $a[4] = 'rec4';
  64 check_contents("sh0", "sh1", "short2", "", "rec4");
  65 $a[3] = 'rec3';
  66 check_contents("sh0", "sh1", "short2", "rec3", "rec4");
  67
  68 # (39-40) zero out file
  69 @a = ();
  70 check_contents();
  71
  72 # (41-42) insert into the middle of an empty file
  73 $a[3] = "rec3";
  74 check_contents("", "", "", "rec3");
  75
  76 # (43-47) 20020326 You thought there would be a bug in STORE where if
  77 # a cached record was false, STORE wouldn't see it at all.  Yup, there is,
  78 # and adding the appropriate defined() test fixes the problem.
  79 undef $o;  untie @a;  1 while unlink $file;
  80 $RECSEP = '0';
  81 $o = tie @a, 'Tie::File', $file,
  82     recsep => $RECSEP, autochomp => 0, autodefer => 0;
  83 print $o ? "ok $N\n" : "not ok $N\n";
  84 $N++;
  85 $#a = 2;
  86 my $z = $a[1];                  # caches "0"
  87 $a[2] = "oops";
  88 check_contents("", "", "oops");
  89 $a[1] = "bah";
  90 check_contents("", "bah", "oops");
  91 undef $o; untie @a;
  92
  93 # (48-56) 20020331 Make sure we correctly handle the case where the final
  94 # record of the file is not properly terminated, Through version 0.90,
  95 # we would mangle the file.
  96 my $badrec = "Malformed";
  97 $: = $RECSEP = Tie::File::_default_recsep();
  98 # (48-50)
  99 if (setup_badly_terminated_file(3)) {
 100   $o = tie @a, 'Tie::File', $file,
 101     recsep => $RECSEP, autochomp => 0, autodefer => 0
 102     or die "Couldn't tie file: $!";
 103   my $z = $a[0];
 104   print $z eq "$badrec$:" ? "ok $N\n" :
 105                         "not ok $N \# got $z, expected $badrec\n";
 106   $N++;
 107   push @a, "next";
 108   check_contents($badrec, "next");
 109 }
 110 # (51-52)
 111 if (setup_badly_terminated_file(2)) {
 112   $o = tie @a, 'Tie::File', $file,
 113     recsep => $RECSEP, autochomp => 0, autodefer => 0
 114     or die "Couldn't tie file: $!";
 115   splice @a, 1, 0, "x", "y";
 116   check_contents($badrec, "x", "y");
 117 }
 118 # (53-56)
 119 if (setup_badly_terminated_file(4)) {
 120   $o = tie @a, 'Tie::File', $file,
 121     recsep => $RECSEP, autochomp => 0, autodefer => 0
 122     or die "Couldn't tie file: $!";
 123   my @r = splice @a, 0, 1, "x", "y";
 124   my $n = @r;
 125   print $n == 1 ? "ok $N\n" : "not ok $N \# expected 1 elt, got $n\n";
 126   $N++;
 127   print $r[0] eq "$badrec$:" ? "ok $N\n"
 128     : "not ok $N \# expected <$badrec>, got <$r[0]>\n";
 129   $N++;
 130   check_contents("x", "y");
 131 }
 132
 133 # (57-58) 20020402 The modification would have failed if $\ were set wrong.
 134 # I hate $\.
 135 if (setup_badly_terminated_file(2)) {
 136   $o = tie @a, 'Tie::File', $file,
 137     recsep => $RECSEP, autochomp => 0, autodefer => 0
 138     or die "Couldn't tie file: $!";
 139   { local $\ = "I hate \$\\.";
 140     my $z = $a[0];
 141   }
 142   check_contents($badrec);
 143 }
 144
 145 # (59) 20030527 Tom Christiansen pointed out that FETCH returns the wrong
 146 # data on the final record of an unterminated file if the file is opened
 147 # in read-only mode.  Note that the $#a is necessary here.
 148 # There's special-case code to fix the final record when it is read normally.
 149 # But the $#a forces it to be read from the cache, which skips the
 150 # termination.
 151 $badrec = "world${RECSEP}hello";
 152 if (setup_badly_terminated_file(1)) {
 153   tie(@a, "Tie::File", $file, mode => O_RDONLY, recsep => $RECSEP)
 154       or die "Couldn't tie file: $!";
 155   my $z = $#a;
 156   $z = $a[1];
 157   print $z eq "hello" ? "ok $N\n" :
 158       "not ok $N \# got $z, expected hello\n";
 159   $N++;
 160 }
 161
 162 sub setup_badly_terminated_file {
 163   my $NTESTS = shift;
 164   open F, '>', $file or die "Couldn't open $file: $!";
 165   binmode F;
 166   print F $badrec;
 167   close F;
 168   unless (-s $file == length $badrec) {
 169     for (1 .. $NTESTS) {
 170       print "ok $N \# skipped - can't create improperly terminated file\n";
 171       $N++;
 172     }
 173     return;
 174   }
 175   return 1;
 176 }
 177
 178
 179 use POSIX 'SEEK_SET';
 180 sub check_contents {
 181   my @c = @_;
 182   my $x = join $RECSEP, @c, '';
 183   local *FH = $o->{fh};
 184   seek FH, 0, SEEK_SET;
 185   my $a;
 186   { local $/; $a = <FH> }
 187
 188   $a = "" unless defined $a;
 189   if ($a eq $x) {
 190     print "ok $N\n";
 191   } else {
 192     my $msg = "# expected <$x>, got <$a>";
 193     ctrlfix($msg);
 194     print "not ok $N $msg\n";
 195   }
 196   $N++;
 197
 198   # now check FETCH:
 199   my $good = 1;
 200   for (0.. $#c) {
 201     unless ($a[$_] eq "$c[$_]$RECSEP") {
 202       $msg = "expected $c[$_]$RECSEP, got $a[$_]";
 203       ctrlfix($msg);
 204       $good = 0;
 205     }
 206   }
 207   print $good ? "ok $N\n" : "not ok $N # fetch $msg\n";
 208   $N++;
 209 }
 210
 211
 212 sub ctrlfix {
 213   for (@_) {
 214     s/\n/\\n/g;
 215     s/\r/\\r/g;
 216   }
 217 }
 218
 219
 220 END {
 221   undef $o;
 222   untie @a;
 223   1 while unlink $file;
 224 }
 225