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

   1 #!/usr/bin/perl
   2
   3 $| = 1;
   4 my $file = "tf$$.txt";
   5 1 while unlink $file;
   6
   7 print "1..75\n";
   8
   9 my $N = 1;
  10 use Tie::File;
  11 print "ok $N\n"; $N++;
  12
  13 my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0;
  14 print $o ? "ok $N\n" : "not ok $N\n";
  15 $N++;
  16
  17 $: = $o->{recsep};
  18
  19 # 3-5 create
  20 $a[0] = 'rec0';
  21 check_contents("rec0");
  22
  23 # 6-11 append
  24 $a[1] = 'rec1';
  25 check_contents("rec0", "rec1");
  26 $a[2] = 'rec2';
  27 check_contents("rec0", "rec1", "rec2");
  28
  29 # 12-20 same-length alterations
  30 $a[0] = 'new0';
  31 check_contents("new0", "rec1", "rec2");
  32 $a[1] = 'new1';
  33 check_contents("new0", "new1", "rec2");
  34 $a[2] = 'new2';
  35 check_contents("new0", "new1", "new2");
  36
  37 # 21-35 lengthening alterations
  38 $a[0] = 'long0';
  39 check_contents("long0", "new1", "new2");
  40 $a[1] = 'long1';
  41 check_contents("long0", "long1", "new2");
  42 $a[2] = 'long2';
  43 check_contents("long0", "long1", "long2");
  44 $a[1] = 'longer1';
  45 check_contents("long0", "longer1", "long2");
  46 $a[0] = 'longer0';
  47 check_contents("longer0", "longer1", "long2");
  48
  49 # 36-50 shortening alterations, including truncation
  50 $a[0] = 'short0';
  51 check_contents("short0", "longer1", "long2");
  52 $a[1] = 'short1';
  53 check_contents("short0", "short1", "long2");
  54 $a[2] = 'short2';
  55 check_contents("short0", "short1", "short2");
  56 $a[1] = 'sh1';
  57 check_contents("short0", "sh1", "short2");
  58 $a[0] = 'sh0';
  59 check_contents("sh0", "sh1", "short2");
  60
  61 # (51-56) file with holes
  62 $a[4] = 'rec4';
  63 check_contents("sh0", "sh1", "short2", "", "rec4");
  64 $a[3] = 'rec3';
  65 check_contents("sh0", "sh1", "short2", "rec3", "rec4");
  66
  67 # (57-59) zero out file
  68 @a = ();
  69 check_contents();
  70
  71 # (60-62) insert into the middle of an empty file
  72 $a[3] = "rec3";
  73 check_contents("", "", "", "rec3");
  74
  75 # (63-68) 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.  But you
  77 # forgot that records always come back from the cache with the record
  78 # separator attached, so they are unlikely to be false.  The only
  79 # really weird case is when the cached record is empty and the record
  80 # separator is "0".  Test that in 09_gen_rs.t.
  81 $a[1] = "0";
  82 check_contents("", "0", "", "rec3");
  83 $a[1] = "whoops";
  84 check_contents("", "whoops", "", "rec3");
  85
  86 # (69-72) make sure that undefs are treated correctly---they should
  87 # be converted to empty records, and should not raise any warnings.
  88 # (Some of these failed in 0.90.  The change to _fixrec fixed them.)
  89 # 20020331
  90 {
  91   my $good = 1; my $warn;
  92   # If any of these raise warnings, we have a problem.
  93   local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)};
  94   local $^W = 1;
  95   @a = (1);
  96   $a[0] = undef;
  97   print $good ? "ok $N\n" : "not ok $N # $warn\n";
  98   $N++; $good = 1;
  99   print defined($a[0]) ? "ok $N\n" : "not ok $N\n";
 100   $N++; $good = 1;
 101   $a[3] = '3';
 102   print defined($a[1]) ? "ok $N\n" : "not ok $N\n";
 103   $N++; $good = 1;
 104   undef $a[3];
 105   print $good ? "ok $N\n" : "not ok $N # $warn\n";
 106   $N++; $good = 1;
 107 }
 108
 109 # (73-75) What if the user has tampered with $\ ?
 110 { {  local $\ = "stop messing with the funny variables!";
 111      @a = (0..2);
 112    }
 113   check_contents(0..2);
 114 }
 115
 116 use POSIX 'SEEK_SET';
 117 sub check_contents {
 118   my @c = @_;
 119   my $x = join $:, @c, '';
 120   local *FH = $o->{fh};
 121   seek FH, 0, SEEK_SET;
 122 #  my $open = open FH, "< $file";
 123   my $a;
 124   { local $/; $a = <FH> }
 125   $a = "" unless defined $a;
 126   if ($a eq $x) {
 127     print "ok $N\n";
 128   } else {
 129     ctrlfix($a, $x);
 130     print "not ok $N\n# expected <$x>, got <$a>\n";
 131   }
 132   $N++;
 133
 134   # now check FETCH:
 135   my $good = 1;
 136   my $msg;
 137   for (0.. $#c) {
 138     my $aa = $a[$_];
 139     unless ($aa eq "$c[$_]$:") {
 140       $msg = "expected <$c[$_]$:>, got <$aa>";
 141       ctrlfix($msg);
 142       $good = 0;
 143     }
 144   }
 145   print $good ? "ok $N\n" : "not ok $N # $msg\n";
 146   $N++;
 147
 148   print $o->_check_integrity($file, $ENV{INTEGRITY})
 149       ? "ok $N\n" : "not ok $N\n";
 150   $N++;
 151 }
 152
 153 sub ctrlfix {
 154   for (@_) {
 155     s/\n/\\n/g;
 156     s/\r/\\r/g;
 157   }
 158 }
 159
 160 END {
 161   undef $o;
 162   untie @a;
 163   1 while unlink $file;
 164 }
 165