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