dist/Tie-File/t/22_autochomp.t

   1 #!/usr/bin/perl
   2
   3 my $file = "tf$$.txt";
   4 $: = Tie::File::_default_recsep();
   5
   6 print "1..71\n";
   7
   8 my $N = 1;
   9 use Tie::File;
  10 print "ok $N\n"; $N++;
  11
  12 my $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0;
  13 print $o ? "ok $N\n" : "not ok $N\n";
  14 $N++;
  15
  16 # 3-5 create
  17 $a[0] = 'rec0';
  18 check_contents("rec0");
  19
  20 # 6-11 append
  21 $a[1] = 'rec1';
  22 check_contents("rec0", "rec1");
  23 $a[2] = 'rec2';
  24 check_contents("rec0", "rec1", "rec2");
  25
  26 # 12-20 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 # 21-35 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 # 36-50 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 # (51-56) 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 # (57-59) zero out file
  65 @a = ();
  66 check_contents();
  67
  68 # (60-62) insert into the middle of an empty file
  69 $a[3] = "rec3";
  70 check_contents("", "", "", "rec3");
  71
  72 # (63-68) Test the ->autochomp() method
  73 @a = qw(Gold Frankincense Myrrh);
  74 my $ac;
  75 $ac = $o->autochomp();
  76 expect($ac);
  77 # See if that accidentally changed it
  78 $ac = $o->autochomp();
  79 expect($ac);
  80 # Now clear it
  81 $ac = $o->autochomp(0);
  82 expect($ac);
  83 expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:");
  84 # Now set it again
  85 $ac = $o->autochomp(1);
  86 expect(!$ac);
  87 expect(join("-", @a), "Gold-Frankincense-Myrrh");
  88
  89 # (69) Does 'splice' work correctly with autochomp?
  90 my @sr;
  91 @sr = splice @a, 0, 2;
  92 expect(join("-", @sr), "Gold-Frankincense");
  93
  94 # (70-71) Didn't you forget that fetch may return an unchomped cached record?
  95 $a1 = $a[0];                    # populate cache
  96 $a2 = $a[0];
  97 expect($a1, "Myrrh");
  98 expect($a2, "Myrrh");
  99 # Actually no, you didn't---_fetch might return such a record, but
 100 # the chomping is done by FETCH.
 101
 102 use POSIX 'SEEK_SET';
 103 sub check_contents {
 104   my @c = @_;
 105   my $x = join $:, @c, '';
 106   local *FH = $o->{fh};
 107   seek FH, 0, SEEK_SET;
 108 #  my $open = open FH, "< $file";
 109   my $a;
 110   { local $/; $a = <FH> }
 111   $a = "" unless defined $a;
 112   if ($a eq $x) {
 113     print "ok $N\n";
 114   } else {
 115     ctrlfix($a, $x);
 116     print "not ok $N\n# expected <$x>, got <$a>\n";
 117   }
 118   $N++;
 119
 120   # now check FETCH:
 121   my $good = 1;
 122   my $msg;
 123   for (0.. $#c) {
 124     my $aa = $a[$_];
 125     unless ($aa eq $c[$_]) {
 126       $msg = "expected <$c[$_]>, got <$aa>";
 127       ctrlfix($msg);
 128       $good = 0;
 129     }
 130   }
 131   print $good ? "ok $N\n" : "not ok $N # $msg\n";
 132   $N++;
 133
 134   print $o->_check_integrity($file, $ENV{INTEGRITY})
 135       ? "ok $N\n" : "not ok $N\n";
 136   $N++;
 137 }
 138
 139 sub expect {
 140   if (@_ == 1) {
 141     print $_[0] ? "ok $N\n" : "not ok $N\n";
 142   } elsif (@_ == 2) {
 143     my ($a, $x) = @_;
 144     if    (! defined($a) && ! defined($x)) { print "ok $N\n" }
 145     elsif (  defined($a) && ! defined($x)) {
 146       ctrlfix(my $msg = "expected UNDEF, got <$a>");
 147       print "not ok $N \# $msg\n";
 148     }
 149     elsif (! defined($a) &&   defined($x)) {
 150       ctrlfix(my $msg = "expected <$x>, got UNDEF");
 151       print "not ok $N \# $msg\n";
 152     } elsif ($a eq $x) { print "ok $N\n" }
 153     else {
 154       ctrlfix(my $msg = "expected <$x>, got <$a>");
 155       print "not ok $N \# $msg\n";
 156     }
 157   } else {
 158     die "expect() got ", scalar(@_), " args, should have been 1 or 2";
 159   }
 160   $N++;
 161 }
 162
 163 sub ctrlfix {
 164   for (@_) {
 165     s/\n/\\n/g;
 166     s/\r/\\r/g;
 167   }
 168 }
 169
 170 END {
 171   undef $o;
 172   untie @a;
 173   1 while unlink $file;
 174 }
 175