Commit | Line | Data |
b5aed31e |
1 | #!/usr/bin/perl |
2 | |
6ae23f41 |
3 | $| = 1; |
b5aed31e |
4 | my $file = "tf$$.txt"; |
6ae23f41 |
5 | 1 while unlink $file; |
b5aed31e |
6 | |
bf919750 |
7 | print "1..75\n"; |
b5aed31e |
8 | |
9 | my $N = 1; |
10 | use Tie::File; |
11 | print "ok $N\n"; $N++; |
12 | |
6fc0ea7e |
13 | my $o = tie @a, 'Tie::File', $file, autochomp => 0, autodefer => 0; |
b5aed31e |
14 | print $o ? "ok $N\n" : "not ok $N\n"; |
15 | $N++; |
16 | |
b3fe5a4c |
17 | $: = $o->{recsep}; |
18 | |
fa408a35 |
19 | # 3-5 create |
b5aed31e |
20 | $a[0] = 'rec0'; |
21 | check_contents("rec0"); |
22 | |
fa408a35 |
23 | # 6-11 append |
b5aed31e |
24 | $a[1] = 'rec1'; |
25 | check_contents("rec0", "rec1"); |
26 | $a[2] = 'rec2'; |
27 | check_contents("rec0", "rec1", "rec2"); |
28 | |
fa408a35 |
29 | # 12-20 same-length alterations |
b5aed31e |
30 | $a[0] = 'new0'; |
31 | check_contents("new0", "rec1", "rec2"); |
32 | $a[1] = 'new1'; |
33 | check_contents("new0", "new1", "rec2"); |
34 | $a[2] = 'new2'; |
35 | check_contents("new0", "new1", "new2"); |
36 | |
fa408a35 |
37 | # 21-35 lengthening alterations |
b5aed31e |
38 | $a[0] = 'long0'; |
39 | check_contents("long0", "new1", "new2"); |
40 | $a[1] = 'long1'; |
41 | check_contents("long0", "long1", "new2"); |
42 | $a[2] = 'long2'; |
43 | check_contents("long0", "long1", "long2"); |
44 | $a[1] = 'longer1'; |
45 | check_contents("long0", "longer1", "long2"); |
46 | $a[0] = 'longer0'; |
47 | check_contents("longer0", "longer1", "long2"); |
48 | |
fa408a35 |
49 | # 36-50 shortening alterations, including truncation |
b5aed31e |
50 | $a[0] = 'short0'; |
51 | check_contents("short0", "longer1", "long2"); |
52 | $a[1] = 'short1'; |
53 | check_contents("short0", "short1", "long2"); |
54 | $a[2] = 'short2'; |
55 | check_contents("short0", "short1", "short2"); |
56 | $a[1] = 'sh1'; |
57 | check_contents("short0", "sh1", "short2"); |
58 | $a[0] = 'sh0'; |
59 | check_contents("sh0", "sh1", "short2"); |
60 | |
fa408a35 |
61 | # (51-56) file with holes |
b5aed31e |
62 | $a[4] = 'rec4'; |
63 | check_contents("sh0", "sh1", "short2", "", "rec4"); |
64 | $a[3] = 'rec3'; |
65 | check_contents("sh0", "sh1", "short2", "rec3", "rec4"); |
66 | |
b3fe5a4c |
67 | # (57-59) zero out file |
68 | @a = (); |
69 | check_contents(); |
b5aed31e |
70 | |
b3fe5a4c |
71 | # (60-62) insert into the middle of an empty file |
72 | $a[3] = "rec3"; |
73 | check_contents("", "", "", "rec3"); |
b5aed31e |
74 | |
6fc0ea7e |
75 | # (63-68) 20020326 You thought there would be a bug in STORE where if |
76 | # a cached record was false, STORE wouldn't see it at all. But you |
77 | # forgot that records always come back from the cache with the record |
78 | # separator attached, so they are unlikely to be false. The only |
79 | # really weird case is when the cached record is empty and the record |
80 | # separator is "0". Test that in 09_gen_rs.t. |
81 | $a[1] = "0"; |
82 | check_contents("", "0", "", "rec3"); |
83 | $a[1] = "whoops"; |
84 | check_contents("", "whoops", "", "rec3"); |
85 | |
27531ffb |
86 | # (69-72) make sure that undefs are treated correctly---they should |
87 | # be converted to empty records, and should not raise any warnings. |
88 | # (Some of these failed in 0.90. The change to _fixrec fixed them.) |
89 | # 20020331 |
90 | { |
91 | my $good = 1; my $warn; |
92 | # If any of these raise warnings, we have a problem. |
93 | local $SIG{__WARN__} = sub { $good = 0; $warn = shift(); ctrlfix($warn)}; |
94 | local $^W = 1; |
95 | @a = (1); |
96 | $a[0] = undef; |
97 | print $good ? "ok $N\n" : "not ok $N # $warn\n"; |
98 | $N++; $good = 1; |
99 | print defined($a[0]) ? "ok $N\n" : "not ok $N\n"; |
100 | $N++; $good = 1; |
101 | $a[3] = '3'; |
102 | print defined($a[1]) ? "ok $N\n" : "not ok $N\n"; |
103 | $N++; $good = 1; |
104 | undef $a[3]; |
105 | print $good ? "ok $N\n" : "not ok $N # $warn\n"; |
106 | $N++; $good = 1; |
107 | } |
6fc0ea7e |
108 | |
bf919750 |
109 | # (73-75) What if the user has tampered with $\ ? |
110 | { { local $\ = "stop messing with the funny variables!"; |
111 | @a = (0..2); |
112 | } |
113 | check_contents(0..2); |
114 | } |
115 | |
7b6b3db1 |
116 | use POSIX 'SEEK_SET'; |
b5aed31e |
117 | sub check_contents { |
118 | my @c = @_; |
b3fe5a4c |
119 | my $x = join $:, @c, ''; |
7b6b3db1 |
120 | local *FH = $o->{fh}; |
121 | seek FH, 0, SEEK_SET; |
122 | # my $open = open FH, "< $file"; |
b5aed31e |
123 | my $a; |
124 | { local $/; $a = <FH> } |
7b6b3db1 |
125 | $a = "" unless defined $a; |
126 | if ($a eq $x) { |
127 | print "ok $N\n"; |
128 | } else { |
b3fe5a4c |
129 | ctrlfix($a, $x); |
7b6b3db1 |
130 | print "not ok $N\n# expected <$x>, got <$a>\n"; |
131 | } |
b5aed31e |
132 | $N++; |
133 | |
134 | # now check FETCH: |
135 | my $good = 1; |
7b6b3db1 |
136 | my $msg; |
b5aed31e |
137 | for (0.. $#c) { |
0b28bc9a |
138 | my $aa = $a[$_]; |
139 | unless ($aa eq "$c[$_]$:") { |
140 | $msg = "expected <$c[$_]$:>, got <$aa>"; |
b3fe5a4c |
141 | ctrlfix($msg); |
7b6b3db1 |
142 | $good = 0; |
143 | } |
b5aed31e |
144 | } |
7b6b3db1 |
145 | print $good ? "ok $N\n" : "not ok $N # $msg\n"; |
b5aed31e |
146 | $N++; |
fa408a35 |
147 | |
148 | print $o->_check_integrity($file, $ENV{INTEGRITY}) |
149 | ? "ok $N\n" : "not ok $N\n"; |
150 | $N++; |
b5aed31e |
151 | } |
152 | |
b3fe5a4c |
153 | sub ctrlfix { |
154 | for (@_) { |
155 | s/\n/\\n/g; |
156 | s/\r/\\r/g; |
157 | } |
158 | } |
159 | |
b5aed31e |
160 | END { |
7b6b3db1 |
161 | undef $o; |
162 | untie @a; |
b5aed31e |
163 | 1 while unlink $file; |
164 | } |
165 | |