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
CommitLineData
6ae23f41
JH
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
8cd4023b 13my $file = "tf29a-$$.txt";
6ae23f41
JH
14
15print "1..55\n";
16
17my $N = 1;
18use Tie::File;
19print "ok $N\n"; $N++;
20
21$: = Tie::File::_default_recsep();
22
23my @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
28try(0, 0, 0);
29try(0, 0, 10);
30try(0, 0, 100);
31try(0, 0, 1000);
32try(0, 0, 10000);
33try(0, 0, 20000);
34
35# (8-13) Trivial non-moves in middle of file
36try(100, 100, 0);
37try(100, 100, 10);
38try(100, 100, 100);
39try(100, 100, 1000);
40try(100, 100, 10000);
41try(100, 100, 20000);
42
43# (14) Trivial non-move at end of file
44try($FLEN, $FLEN, 0);
45
46# (15-17) Trivial non-move of tail of file
47try(0, 0, undef);
48try(100, 100, undef);
49try($FLEN, $FLEN, undef);
50
51# (18-24) Moves to start of file
52try(100, 0, 0);
53try(100, 0, 10);
54try(100, 0, 100);
55try(100, 0, 1000);
56try(100, 0, 10000);
57try(100, 0, 20000);
58try(100, 0, undef);
59
60# (25-31) Moves in middle of file
61try(200, 100, 0);
62try(200, 100, 10);
63try(200, 100, 100);
64try(200, 100, 1000);
65try(200, 100, 10000);
66try(200, 100, 20000);
67try(200, 100, undef);
68
69# (32-43) Moves from end of file
70try($FLEN, 10000, 0);
71try($FLEN-10, 10000, 10);
72try($FLEN-100, 10000, 100);
73try($FLEN-1000, 200, 1000);
74try($FLEN-10000, 200, 10000);
75try($FLEN-20000, 200, 20000);
76try($FLEN, 10000, undef);
77try($FLEN-10, 10000, undef);
78try($FLEN-100, 10000, undef);
79try($FLEN-1000, 200, undef);
80try($FLEN-10000, 200, undef);
81try($FLEN-20000, 200, undef);
82
83$FLEN = 40960;
84
85# (44-55) Moves from end of file when file ends on a block boundary
86try($FLEN, 10000, 0);
87try($FLEN-10, 10000, 10);
88try($FLEN-100, 10000, 100);
89try($FLEN-1000, 200, 1000);
90try($FLEN-10000, 200, 10000);
91try($FLEN-20000, 200, 20000);
92try($FLEN, 10000, undef);
93try($FLEN-10, 10000, undef);
94try($FLEN-100, 10000, undef);
95try($FLEN-1000, 200, undef);
96try($FLEN-10000, 200, undef);
97try($FLEN-20000, 200, undef);
98
99sub try {
100 my ($src, $dst, $len) = @_;
1ae6ead9 101 open F, '>', $file or die "Couldn't open file $file: $!";
6ae23f41
JH
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 = $@;
79a3c49f 132 undef $o; untie @lines; alarm(0);
6ae23f41
JH
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
1ae6ead9 144 open F, '<', $file or die "Couldn't open file $file: $!";
6ae23f41
JH
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
162use POSIX 'SEEK_SET';
163sub check_contents {
164 my @c = @_;
165 my $x = join $:, @c, '';
166 local *FH = $o->{fh};
167 seek FH, 0, SEEK_SET;
1ae6ead9 168# my $open = open FH, '<', $file;
6ae23f41
JH
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
199sub ctrlfix {
200 for (@_) {
201 s/\n/\\n/g;
202 s/\r/\\r/g;
203 }
204}
205
206END {
207 undef $o;
208 untie @a;
209 1 while unlink $file;
210}
211