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

   1 #!/usr/bin/perl
   2
   3 my $file = "tf$$.txt";
   4
   5 print "1..38\n";
   6
   7 my $N = 1;
   8 use Tie::File;
   9 print "ok $N\n"; $N++;
  10
  11 my $o = tie @a, 'Tie::File', $file, recsep => 'blah', autochomp => 0;
  12 print $o ? "ok $N\n" : "not ok $N\n";
  13 $N++;
  14
  15
  16 # 3-4 create
  17 $a[0] = 'rec0';
  18 check_contents("rec0");
  19
  20 # 5-8 append
  21 $a[1] = 'rec1';
  22 check_contents("rec0", "rec1");
  23 $a[2] = 'rec2';
  24 check_contents("rec0", "rec1", "rec2");
  25
  26 # 9-14 same-length alterations
  27 $a[0] = 'new0';
  28 check_contents("new0", "rec1", "rec2");
  29 $a[1] = 'new1';
  30 check_contents("new0", "new1", "rec2");
  31 $a[2] = 'new2';
  32 check_contents("new0", "new1", "new2");
  33
  34 # 15-24 lengthening alterations
  35 $a[0] = 'long0';
  36 check_contents("long0", "new1", "new2");
  37 $a[1] = 'long1';
  38 check_contents("long0", "long1", "new2");
  39 $a[2] = 'long2';
  40 check_contents("long0", "long1", "long2");
  41 $a[1] = 'longer1';
  42 check_contents("long0", "longer1", "long2");
  43 $a[0] = 'longer0';
  44 check_contents("longer0", "longer1", "long2");
  45
  46 # 25-34 shortening alterations, including truncation
  47 $a[0] = 'short0';
  48 check_contents("short0", "longer1", "long2");
  49 $a[1] = 'short1';
  50 check_contents("short0", "short1", "long2");
  51 $a[2] = 'short2';
  52 check_contents("short0", "short1", "short2");
  53 $a[1] = 'sh1';
  54 check_contents("short0", "sh1", "short2");
  55 $a[0] = 'sh0';
  56 check_contents("sh0", "sh1", "short2");
  57
  58 # file with holes
  59 $a[4] = 'rec4';
  60 check_contents("sh0", "sh1", "short2", "", "rec4");
  61 $a[3] = 'rec3';
  62 check_contents("sh0", "sh1", "short2", "rec3", "rec4");
  63
  64
  65 # try inserting a record into the middle of an empty file
  66
  67 use POSIX 'SEEK_SET';
  68 sub check_contents {
  69   my @c = @_;
  70   my $x = join 'blah', @c, '';
  71   local *FH = $o->{fh};
  72   seek FH, 0, SEEK_SET;
  73   my $a;
  74   { local $/; $a = <FH> }
  75
  76   $a = "" unless defined $a;
  77   if ($a eq $x) {
  78     print "ok $N\n";
  79   } else {
  80     my $msg = "# expected <$x>, got <$a>";
  81     ctrlfix($msg);
  82     print "not ok $N $msg\n";
  83   }
  84   $N++;
  85
  86   # now check FETCH:
  87   my $good = 1;
  88   for (0.. $#c) {
  89     unless ($a[$_] eq "$c[$_]blah") {
  90       $msg = "expected $c[$_]blah, got $a[$_]";
  91       ctrlfix($msg);
  92       $good = 0;
  93     }
  94   }
  95   print $good ? "ok $N\n" : "not ok $N # fetch @c\n";
  96   $N++;
  97 }
  98
  99
 100 sub ctrlfix {
 101   for (@_) {
 102     s/\n/\\n/g;
 103     s/\r/\\r/g;
 104   }
 105 }
 106
 107
 108 END {
 109   undef $o;
 110   untie @a;
 111   1 while unlink $file;
 112 }
 113