Commit | Line | Data |
57c7bc08 |
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 |
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 |
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 |
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 |
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 |
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 |
145 | |
146 | |
147 | sub check_contents { |
148 | my $x = shift; |
6fc0ea7e |
149 | # for (values %{$o->{cache}}) { |
150 | # print "# cache=$_"; |
151 | # } |
152 | |
57c7bc08 |
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 { |
178 | 1 while unlink $file; |
179 | } |
180 | |