This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tie::File: use unique tmp filename in 29a_upcopy.t
[perl5.git] / dist / 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 = "tf29a-$$.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