lib/Tie/File/t/09_gen_rs.t

   1 #!/usr/bin/perl
   2
   3 my $file = "tf$$.txt";
   4
   5 print "1..47\n";
   6
   7 my $N = 1;
   8 use Tie::File;
   9 print "ok $N\n"; $N++;
  10
  11 $RECSEP = 'blah';
  12 my $o = tie @a, 'Tie::File', $file,
  13     recsep => $RECSEP, autochomp => 0, autodefer => 0;
  14 print $o ? "ok $N\n" : "not ok $N\n";
  15 $N++;
  16
  17
  18 # 3-4 create
  19 $a[0] = 'rec0';
  20 check_contents("rec0");
  21
  22 # 5-8 append
  23 $a[1] = 'rec1';
  24 check_contents("rec0", "rec1");
  25 $a[2] = 'rec2';
  26 check_contents("rec0", "rec1", "rec2");
  27
  28 # 9-14 same-length alterations
  29 $a[0] = 'new0';
  30 check_contents("new0", "rec1", "rec2");
  31 $a[1] = 'new1';
  32 check_contents("new0", "new1", "rec2");
  33 $a[2] = 'new2';
  34 check_contents("new0", "new1", "new2");
  35
  36 # 15-24 lengthening alterations
  37 $a[0] = 'long0';
  38 check_contents("long0", "new1", "new2");
  39 $a[1] = 'long1';
  40 check_contents("long0", "long1", "new2");
  41 $a[2] = 'long2';
  42 check_contents("long0", "long1", "long2");
  43 $a[1] = 'longer1';
  44 check_contents("long0", "longer1", "long2");
  45 $a[0] = 'longer0';
  46 check_contents("longer0", "longer1", "long2");
  47
  48 # 25-34 shortening alterations, including truncation
  49 $a[0] = 'short0';
  50 check_contents("short0", "longer1", "long2");
  51 $a[1] = 'short1';
  52 check_contents("short0", "short1", "long2");
  53 $a[2] = 'short2';
  54 check_contents("short0", "short1", "short2");
  55 $a[1] = 'sh1';
  56 check_contents("short0", "sh1", "short2");
  57 $a[0] = 'sh0';
  58 check_contents("sh0", "sh1", "short2");
  59
  60 # file with holes
  61 $a[4] = 'rec4';
  62 check_contents("sh0", "sh1", "short2", "", "rec4");
  63 $a[3] = 'rec3';
  64 check_contents("sh0", "sh1", "short2", "rec3", "rec4");
  65
  66 # (35-37) zero out file
  67 @a = ();
  68 check_contents();
  69
  70 # (38-40) insert into the middle of an empty file
  71 $a[3] = "rec3";
  72 check_contents("", "", "", "rec3");
  73
  74
  75 # (41-46) 20020326 You thought there would be a bug in STORE where if
  76 # a cached record was false, STORE wouldn't see it at all.  Yup, there is,
  77 # and adding the appropriate defined() test fixes the problem.
  78 undef $o;  untie @a;  1 while unlink $file;
  79 $RECSEP = '0';
  80 $o = tie @a, 'Tie::File', $file,
  81     recsep => $RECSEP, autochomp => 0, autodefer => 0;
  82 print $o ? "ok $N\n" : "not ok $N\n";
  83 $N++;
  84 $#a = 2;
  85 my $z = $a[1];                  # caches "0"
  86 $a[2] = "oops";
  87 check_contents("", "", "oops");
  88 $a[1] = "bah";
  89 check_contents("", "bah", "oops");
  90
  91
  92 use POSIX 'SEEK_SET';
  93 sub check_contents {
  94   my @c = @_;
  95   my $x = join $RECSEP, @c, '';
  96   local *FH = $o->{fh};
  97   seek FH, 0, SEEK_SET;
  98   my $a;
  99   { local $/; $a = <FH> }
 100
 101   $a = "" unless defined $a;
 102   if ($a eq $x) {
 103     print "ok $N\n";
 104   } else {
 105     my $msg = "# expected <$x>, got <$a>";
 106     ctrlfix($msg);
 107     print "not ok $N $msg\n";
 108   }
 109   $N++;
 110
 111   # now check FETCH:
 112   my $good = 1;
 113   for (0.. $#c) {
 114     unless ($a[$_] eq "$c[$_]$RECSEP") {
 115       $msg = "expected $c[$_]$RECSEP, got $a[$_]";
 116       ctrlfix($msg);
 117       $good = 0;
 118     }
 119   }
 120   print $good ? "ok $N\n" : "not ok $N # fetch $msg\n";
 121   $N++;
 122 }
 123
 124
 125 sub ctrlfix {
 126   for (@_) {
 127     s/\n/\\n/g;
 128     s/\r/\\r/g;
 129   }
 130 }
 131
 132
 133 END {
 134   undef $o;
 135   untie @a;
 136   1 while unlink $file;
 137 }
 138