Commit | Line | Data |
6ae23f41 |
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 = $@; |
79a3c49f |
132 | undef $o; untie @lines; alarm(0); |
6ae23f41 |
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 | |