lib/Tie/File/t/01_gen.t

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