Commit | Line | Data |
---|---|---|
57c7bc08 AMS |
1 | #!/usr/bin/perl |
2 | # | |
3 | # Check behavior of 'autodefer' feature | |
4 | # Mostly this isn't implemented yet | |
5 | # This file is primarily here to make sure that the promised ->autodefer | |
6 | # method doesn't croak. | |
7 | # | |
8 | ||
9 | use POSIX 'SEEK_SET'; | |
6fc0ea7e | 10 | |
57c7bc08 AMS |
11 | my $file = "tf$$.txt"; |
12 | $: = Tie::File::_default_recsep(); | |
13 | my $data = "rec0$:rec1$:rec2$:"; | |
14 | my ($o, $n, @a); | |
15 | ||
6fc0ea7e | 16 | print "1..65\n"; |
57c7bc08 AMS |
17 | |
18 | my $N = 1; | |
19 | use Tie::File; | |
20 | print "ok $N\n"; $N++; | |
21 | ||
22 | open F, "> $file" or die $!; | |
23 | binmode F; | |
24 | print F $data; | |
25 | close F; | |
26 | $o = tie @a, 'Tie::File', $file; | |
27 | print $o ? "ok $N\n" : "not ok $N\n"; | |
28 | $N++; | |
29 | ||
6fc0ea7e JH |
30 | # I am an undocumented feature |
31 | $o->{autodefer_filelen_threshhold} = 0; | |
32 | # Normally autodeferring only works on large files. This disables that. | |
33 | ||
34 | # (3-22) Deferred storage | |
35 | $a[3] = "rec3"; | |
36 | check_autodeferring('OFF'); | |
37 | $a[4] = "rec4"; | |
38 | check_autodeferring('OFF'); | |
39 | $a[5] = "rec5"; | |
40 | check_autodeferring('ON'); | |
41 | check_contents($data . "rec3$:rec4$:"); # only the first two were written | |
42 | $a[6] = "rec6"; | |
43 | check_autodeferring('ON'); | |
44 | check_contents($data . "rec3$:rec4$:"); # still nothing written | |
45 | $a[7] = "rec7"; | |
46 | check_autodeferring('ON'); | |
47 | check_contents($data . "rec3$:rec4$:"); # still nothing written | |
48 | $a[0] = "recX"; | |
49 | check_autodeferring('OFF'); | |
50 | check_contents("recX$:rec1$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:"); | |
51 | $a[1] = "recY"; | |
52 | check_autodeferring('OFF'); | |
53 | check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:"); | |
54 | $a[2] = "recZ"; # it kicks in here | |
55 | check_autodeferring('ON'); | |
56 | check_contents("recX$:recY$:rec2$:rec3$:rec4$:rec5$:rec6$:rec7$:"); | |
57 | ||
58 | # (23-26) Explicitly enabling deferred writing deactivates autodeferring | |
59 | $o->defer; | |
60 | check_autodeferring('OFF'); | |
61 | check_contents("recX$:recY$:recZ$:rec3$:rec4$:rec5$:rec6$:rec7$:"); | |
62 | $o->discard; | |
63 | check_autodeferring('OFF'); | |
64 | ||
65 | # (27-32) Now let's try the CLEAR special case | |
66 | @a = ("r0" .. "r4"); | |
67 | check_autodeferring('ON'); | |
68 | # The file was extended to the right length, but nothing was actually written. | |
69 | check_contents("$:$:$:$:$:"); | |
70 | $a[2] = "fish"; | |
71 | check_autodeferring('OFF'); | |
72 | check_contents("r0$:r1$:fish$:r3$:r4$:"); | |
73 | ||
74 | # (33-47) Now let's try the originally intended application: a 'for' loop. | |
75 | my $it = 0; | |
76 | for (@a) { | |
77 | $_ = "##$_"; | |
78 | if ($it == 0) { | |
79 | check_autodeferring('OFF'); | |
80 | check_contents("##r0$:r1$:fish$:r3$:r4$:"); | |
81 | } elsif ($it == 1) { | |
82 | check_autodeferring('OFF'); | |
83 | check_contents("##r0$:##r1$:fish$:r3$:r4$:"); | |
84 | } else { | |
85 | check_autodeferring('ON'); | |
86 | check_contents("##r0$:##r1$:fish$:r3$:r4$:"); | |
87 | } | |
88 | $it++; | |
89 | } | |
90 | ||
91 | # (48-56) Autodeferring should not become active during explicit defer mode | |
92 | $o->defer(); # This should flush the pending autodeferred records | |
93 | # and deactivate autodeferring | |
94 | check_autodeferring('OFF'); | |
95 | check_contents("##r0$:##r1$:##fish$:##r3$:##r4$:"); | |
96 | @a = ("s0" .. "s4"); | |
97 | check_autodeferring('OFF'); | |
98 | check_contents(""); | |
99 | $o->flush; | |
100 | check_autodeferring('OFF'); | |
101 | check_contents("s0$:s1$:s2$:s3$:s4$:"); | |
102 | ||
103 | undef $o; untie @a; | |
57c7bc08 | 104 | |
6fc0ea7e JH |
105 | # Limit cache+buffer size to 47 bytes |
106 | my $MAX = 47; | |
107 | # -- that's enough space for 5 records, but not 6, on both \n and \r\n systems | |
108 | my $BUF = 20; | |
109 | # -- that's enough space for 2 records, but not 3, on both \n and \r\n systems | |
110 | # Re-tie the object for more tests | |
111 | $o = tie @a, 'Tie::File', $file, autodefer => 0; | |
112 | die $! unless $o; | |
113 | # I am an undocumented feature | |
114 | $o->{autodefer_filelen_threshhold} = 0; | |
115 | # Normally autodeferring only works on large files. This disables that. | |
57c7bc08 | 116 | |
6fc0ea7e JH |
117 | # (57-59) Did the autodefer => 0 option work? |
118 | # (If it doesn't, a whole bunch of the other test files will fail.) | |
119 | @a = (0..3); | |
120 | check_autodeferring('OFF'); | |
121 | check_contents(join("$:", qw(0 1 2 3), "")); | |
122 | ||
123 | # (60-62) Does the ->autodefer method work? | |
124 | $o->autodefer(1); | |
125 | @a = (10..13); | |
126 | check_autodeferring('ON'); | |
127 | check_contents("$:$:$:$:"); # This might be unfortunate. | |
128 | ||
129 | # (63-65) Does the ->autodefer method work? | |
130 | $o->autodefer(0); | |
131 | check_autodeferring('OFF'); | |
132 | check_contents(join("$:", qw(10 11 12 13), "")); | |
133 | ||
134 | ||
135 | sub check_autodeferring { | |
136 | my ($x) = shift; | |
137 | my $a = $o->{autodeferring} ? 'ON' : 'OFF'; | |
138 | if ($x eq $a) { | |
139 | print "ok $N\n"; | |
140 | } else { | |
141 | print "not ok $N \# Autodeferring was $a, expected it to be $x\n"; | |
142 | } | |
143 | $N++; | |
144 | } | |
57c7bc08 AMS |
145 | |
146 | ||
147 | sub check_contents { | |
148 | my $x = shift; | |
6fc0ea7e JH |
149 | # for (values %{$o->{cache}}) { |
150 | # print "# cache=$_"; | |
151 | # } | |
152 | ||
57c7bc08 AMS |
153 | my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); |
154 | local *FH = $o->{fh}; | |
155 | seek FH, 0, SEEK_SET; | |
156 | print $integrity ? "ok $N\n" : "not ok $N\n"; | |
157 | $N++; | |
158 | my $a; | |
159 | { local $/; $a = <FH> } | |
160 | $a = "" unless defined $a; | |
161 | if ($a eq $x) { | |
162 | print "ok $N\n"; | |
163 | } else { | |
164 | ctrlfix(my $msg = "# expected <$x>, got <$a>"); | |
165 | print "not ok $N\n$msg\n"; | |
166 | } | |
167 | $N++; | |
168 | } | |
169 | ||
170 | sub ctrlfix { | |
171 | for (@_) { | |
172 | s/\n/\\n/g; | |
173 | s/\r/\\r/g; | |
174 | } | |
175 | } | |
176 | ||
177 | END { | |
0ec158f4 GS |
178 | undef $o; |
179 | untie @a; | |
57c7bc08 AMS |
180 | 1 while unlink $file; |
181 | } | |
182 |