1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use File::Temp ();
7
8#
9# Unit tests of _upcopy function
10#
11# _upcopy($self, $source, $dest, $len)
12#
13# Take a block of data of leength $len at $source and copy it
14# to $dest, which must be <= $source but which need not be <= $source - $len
15# (That is, this will only copy a block to a position earlier in the file,
16# but the source and destination regions may overlap.)
17
18
19# Make a temp dir under the OS's normal temp directory for creating
20# test files in. By using the OS's temp dir rather than the current
21# directory, we increase the chances that the tests are run on a tmpfs
22# file system or similar. This becomes important when the current
23# directory is on a very slow USB drive for example, as this test file
24# does lots of file creating, modifying and deleting.
25
26my $tempdir = File::Temp::tempdir("Tie-File-XXXXXX",
27                                    TMPDIR => 1, CLEANUP => 1);
28
29print "1..55\n";
30
31my $N = 1;
32use Tie::File;
33print "ok $N\n"; $N++;
34
35$: = Tie::File::_default_recsep();
36
37my @subtests = qw(x <x x> x><x <x> <x><x x><x> <x><x> <x><x><x> 0);
38
39my $FLEN = 40970;  # 2410 records of 17 chars each
40
41# (2-7) Trivial non-moves at start of file
42try(0, 0, 0);
43try(0, 0, 10);
44try(0, 0, 100);
45try(0, 0, 1000);
46try(0, 0, 10000);
47try(0, 0, 20000);
48
49# (8-13) Trivial non-moves in middle of file
50try(100, 100, 0);
51try(100, 100, 10);
52try(100, 100, 100);
53try(100, 100, 1000);
54try(100, 100, 10000);
55try(100, 100, 20000);
56
57# (14) Trivial non-move at end of file
58try($FLEN, $FLEN, 0);
59
60# (15-17) Trivial non-move of tail of file
61try(0, 0, undef);
62try(100, 100, undef);
63try($FLEN, $FLEN, undef);
64
65# (18-24) Moves to start of file
66try(100, 0, 0);
67try(100, 0, 10);
68try(100, 0, 100);
69try(100, 0, 1000);
70try(100, 0, 10000);
71try(100, 0, 20000);
72try(100, 0, undef);
73
74# (25-31) Moves in middle of file
75try(200, 100, 0);
76try(200, 100, 10);
77try(200, 100, 100);
78try(200, 100, 1000);
79try(200, 100, 10000);
80try(200, 100, 20000);
81try(200, 100, undef);
82
83# (32-43) Moves from end of file
84try($FLEN, 10000, 0);
85try($FLEN-10, 10000, 10);
86try($FLEN-100, 10000, 100);
87try($FLEN-1000, 200, 1000);
88try($FLEN-10000, 200, 10000);
89try($FLEN-20000, 200, 20000);
90try($FLEN, 10000, undef);
91try($FLEN-10, 10000, undef);
92try($FLEN-100, 10000, undef);
93try($FLEN-1000, 200, undef);
94try($FLEN-10000, 200, undef);
95try($FLEN-20000, 200, undef);
96
97$FLEN = 40960;
98
99# (44-55) Moves from end of file when file ends on a block boundary
100try($FLEN, 10000, 0);
101try($FLEN-10, 10000, 10);
102try($FLEN-100, 10000, 100);
103try($FLEN-1000, 200, 1000);
104try($FLEN-10000, 200, 10000);
105try($FLEN-20000, 200, 20000);
106try($FLEN, 10000, undef);
107try($FLEN-10, 10000, undef);
108try($FLEN-100, 10000, undef);
109try($FLEN-1000, 200, undef);
110try($FLEN-10000, 200, undef);
111try($FLEN-20000, 200, undef);
112
113sub try {
114  my ($src, $dst, $len) = @_;
115
116  my $line = (caller(0))[2];
117  my $desc = sprintf "try(%5s, %5s, %5s) FLEN=%5s called from line %d",
118                map { defined $_ ? $_ : 'undef' }
119                    $src, $dst, $len, $FLEN, $line;
120
121  my ($fh, $file) = File::Temp::tempfile("29A-XXXXX", DIR => $tempdir);
122
123  binmode $fh;
124
125  # The record has exactly 17 characters.  This will help ensure that
126  # even if _upcopy screws up, the data doesn't coincidentally
127  # look good because the remainder accidentally lines up.
128  my $d = substr("0123456789abcdef$:", -17);
129  my $recs = defined($FLEN) ?
130    int($FLEN/length($d))+1 : # enough to make up at least $FLEN
131    int(8192*5/length($d))+1; # at least 5 blocks' worth
132  my $oldfile = $d x $recs;
133  my $flen = defined($FLEN) ? $FLEN : $recs * 17;
134  substr($oldfile, $FLEN) = "" if defined $FLEN;  # truncate
135  print $fh $oldfile;
136  close $fh;
137
138  die "wrong length!" unless -s $file == $flen;
139
140  # If len is specified, use that.  If it's undef,
141  # then behave *as if* we had specified the whole rest of the file
142  my $expected = $oldfile;
143  if (defined $len) {
144    substr($expected, $dst, $len) = substr($expected, $src, $len);
145  } else {
146    substr($expected, $dst) = substr($expected, $src);
147  }
148
149  my $o = tie my @lines, 'Tie::File', $file or die $!;
150  # allocate more time for the test if we are running parallel tests
151  my $alarm_time = ($ENV{TEST_JOBS} || $ENV{HARNESS_OPTIONS}) ? 20 : 10;
152  local $SIG{ALRM} = sub { die "Alarm clock" };
153  my $a_retval = eval { alarm($alarm_time) unless $^P; $o->_upcopy($src, $dst, $len) };
154  my $err = $@;
155  undef $o; untie @lines; alarm(0);
156  if ($err) {
157    if ($err =~ /^Alarm clock/) {
158      print STDERR "# $0 Timeout after $alarm_time seconds at test $N - $desc\n";
159      print "not ok $N - $desc\n"; $N++;
160      return;
161    } else {
162      $@ = $err;
163      die;
164    }
165  }
166
167  open F, '<', $file or die "Couldn't open file $file: $!";
168  binmode F;
169  my $actual;
170  { local $/;
171    $actual = <F>;
172  }
173  close F;
174
175  my ($alen, $xlen) = (length $actual, length $expected);
176  unless ($alen == $xlen) {
177    print "# try(@_) expected file length $xlen, actual $alen!\n";
178  }
179  print $actual eq $expected ? "ok $N - $desc\n" : "not ok $N - $desc\n";
180  $N++;
181}
182
183sub ctrlfix {
184  for (@_) {
185    s/\n/\\n/g;
186    s/\r/\\r/g;
187  }
188}
189