lib/Tie/File/t/29a_upcopy.t

   1 #!/usr/bin/perl
   2 #
   3 # Unit tests of _upcopy function
   4 #
   5 # _upcopy($self, $source, $dest, $len)
   6 #
   7 # Take a block of data of leength $len at $source and copy it
   8 # to $dest, which must be <= $source but which need not be <= $source - $len
   9 # (That is, this will only copy a block to a position earlier in the file,
  10 # but the source and destination regions may overlap.)
  11
  12
  13 my $file = "tf$$.txt";
  14
  15 print "1..55\n";
  16
  17 my $N = 1;
  18 use Tie::File;
  19 print "ok $N\n"; $N++;
  20
  21 $: = Tie::File::_default_recsep();
  22
  23 my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);
  24
  25 $FLEN = 40970;  # 2410 records of 17 chars each
  26
  27 # (2-7) Trivial non-moves at start of file
  28 try(0, 0, 0);
  29 try(0, 0, 10);
  30 try(0, 0, 100);
  31 try(0, 0, 1000);
  32 try(0, 0, 10000);
  33 try(0, 0, 20000);
  34
  35 # (8-13) Trivial non-moves in middle of file
  36 try(100, 100, 0);
  37 try(100, 100, 10);
  38 try(100, 100, 100);
  39 try(100, 100, 1000);
  40 try(100, 100, 10000);
  41 try(100, 100, 20000);
  42
  43 # (14) Trivial non-move at end of file
  44 try($FLEN, $FLEN, 0);
  45
  46 # (15-17) Trivial non-move of tail of file
  47 try(0, 0, undef);
  48 try(100, 100, undef);
  49 try($FLEN, $FLEN, undef);
  50
  51 # (18-24) Moves to start of file
  52 try(100, 0, 0);
  53 try(100, 0, 10);
  54 try(100, 0, 100);
  55 try(100, 0, 1000);
  56 try(100, 0, 10000);
  57 try(100, 0, 20000);
  58 try(100, 0, undef);
  59
  60 # (25-31) Moves in middle of file
  61 try(200, 100, 0);
  62 try(200, 100, 10);
  63 try(200, 100, 100);
  64 try(200, 100, 1000);
  65 try(200, 100, 10000);
  66 try(200, 100, 20000);
  67 try(200, 100, undef);
  68
  69 # (32-43) Moves from end of file
  70 try($FLEN, 10000, 0);
  71 try($FLEN-10, 10000, 10);
  72 try($FLEN-100, 10000, 100);
  73 try($FLEN-1000, 200, 1000);
  74 try($FLEN-10000, 200, 10000);
  75 try($FLEN-20000, 200, 20000);
  76 try($FLEN, 10000, undef);
  77 try($FLEN-10, 10000, undef);
  78 try($FLEN-100, 10000, undef);
  79 try($FLEN-1000, 200, undef);
  80 try($FLEN-10000, 200, undef);
  81 try($FLEN-20000, 200, undef);
  82
  83 $FLEN = 40960;
  84
  85 # (44-55) Moves from end of file when file ends on a block boundary
  86 try($FLEN, 10000, 0);
  87 try($FLEN-10, 10000, 10);
  88 try($FLEN-100, 10000, 100);
  89 try($FLEN-1000, 200, 1000);
  90 try($FLEN-10000, 200, 10000);
  91 try($FLEN-20000, 200, 20000);
  92 try($FLEN, 10000, undef);
  93 try($FLEN-10, 10000, undef);
  94 try($FLEN-100, 10000, undef);
  95 try($FLEN-1000, 200, undef);
  96 try($FLEN-10000, 200, undef);
  97 try($FLEN-20000, 200, undef);
  98
  99 sub try {
 100   my ($src, $dst, $len) = @_;
 101   open F, "> $file" or die "Couldn't open file $file: $!";
 102   binmode F;
 103
 104   # The record has exactly 17 characters.  This will help ensure that
 105   # even if _upcopy screws up, the data doesn't coincidentally
 106   # look good because the remainder accidentally lines up.
 107   my $d = substr("0123456789abcdef$:", -17);
 108   my $recs = defined($FLEN) ?
 109     int($FLEN/length($d))+1 : # enough to make up at least $FLEN
 110     int(8192*5/length($d))+1; # at least 5 blocks' worth
 111   my $oldfile = $d x $recs;
 112   my $flen = defined($FLEN) ? $FLEN : $recs * 17;
 113   substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
 114   print F $oldfile;
 115   close F;
 116
 117   die "wrong length!" unless -s $file == $flen;
 118
 119   # If len is specified, use that.  If it's undef,
 120   # then behave *as if* we had specified the whole rest of the file
 121   my $expected = $oldfile;
 122   if (defined $len) {
 123     substr($expected, $dst, $len) = substr($expected, $src, $len);
 124   } else {
 125     substr($expected, $dst) = substr($expected, $src);
 126   }
 127
 128   my $o = tie my @lines, 'Tie::File', $file or die $!;
 129   local $SIG{ALRM} = sub { die "Alarm clock" };
 130   my $a_retval = eval { alarm(5) unless $^P; $o->_upcopy($src, $dst, $len) };
 131   my $err = $@;
 132   undef $o; untie @lines; alarm(0);
 133   if ($err) {
 134     if ($err =~ /^Alarm clock/) {
 135       print "# Timeout\n";
 136       print "not ok $N\n"; $N++;
 137       return;
 138     } else {
 139       $@ = $err;
 140       die;
 141     }
 142   }
 143
 144   open F, "< $file" or die "Couldn't open file $file: $!";
 145   binmode F;
 146   my $actual;
 147   { local $/;
 148     $actual = <F>;
 149   }
 150   close F;
 151
 152   my ($alen, $xlen) = (length $actual, length $expected);
 153   unless ($alen == $xlen) {
 154     print "# try(@_) expected file length $xlen, actual $alen!\n";
 155   }
 156   print $actual eq $expected ? "ok $N\n" : "not ok $N\n";
 157   $N++;
 158 }
 159
 160
 161
 162 use POSIX 'SEEK_SET';
 163 sub check_contents {
 164   my @c = @_;
 165   my $x = join $:, @c, '';
 166   local *FH = $o->{fh};
 167   seek FH, 0, SEEK_SET;
 168 #  my $open = open FH, "< $file";
 169   my $a;
 170   { local $/; $a = <FH> }
 171   $a = "" unless defined $a;
 172   if ($a eq $x) {
 173     print "ok $N\n";
 174   } else {
 175     ctrlfix($a, $x);
 176     print "not ok $N\n# expected <$x>, got <$a>\n";
 177   }
 178   $N++;
 179
 180   # now check FETCH:
 181   my $good = 1;
 182   my $msg;
 183   for (0.. $#c) {
 184     my $aa = $a[$_];
 185     unless ($aa eq "$c[$_]$:") {
 186       $msg = "expected <$c[$_]$:>, got <$aa>";
 187       ctrlfix($msg);
 188       $good = 0;
 189     }
 190   }
 191   print $good ? "ok $N\n" : "not ok $N # $msg\n";
 192   $N++;
 193
 194   print $o->_check_integrity($file, $ENV{INTEGRITY})
 195       ? "ok $N\n" : "not ok $N\n";
 196   $N++;
 197 }
 198
 199 sub ctrlfix {
 200   for (@_) {
 201     s/\n/\\n/g;
 202     s/\r/\\r/g;
 203   }
 204 }
 205
 206 END {
 207   undef $o;
 208   untie @a;
 209   1 while unlink $file;
 210 }
 211