Commit | Line | Data |
---|---|---|
0b28bc9a AMS |
1 | #!/usr/bin/perl |
2 | ||
3 | my $file = "tf$$.txt"; | |
4 | $: = Tie::File::_default_recsep(); | |
5 | ||
6 | print "1..71\n"; | |
7 | ||
8 | my $N = 1; | |
9 | use Tie::File; | |
10 | print "ok $N\n"; $N++; | |
11 | ||
6fc0ea7e | 12 | my $o = tie @a, 'Tie::File', $file, autochomp => 1, autodefer => 0; |
0b28bc9a AMS |
13 | print $o ? "ok $N\n" : "not ok $N\n"; |
14 | $N++; | |
15 | ||
16 | # 3-5 create | |
17 | $a[0] = 'rec0'; | |
18 | check_contents("rec0"); | |
19 | ||
20 | # 6-11 append | |
21 | $a[1] = 'rec1'; | |
22 | check_contents("rec0", "rec1"); | |
23 | $a[2] = 'rec2'; | |
24 | check_contents("rec0", "rec1", "rec2"); | |
25 | ||
26 | # 12-20 same-length alterations | |
27 | $a[0] = 'new0'; | |
28 | check_contents("new0", "rec1", "rec2"); | |
29 | $a[1] = 'new1'; | |
30 | check_contents("new0", "new1", "rec2"); | |
31 | $a[2] = 'new2'; | |
32 | check_contents("new0", "new1", "new2"); | |
33 | ||
34 | # 21-35 lengthening alterations | |
35 | $a[0] = 'long0'; | |
36 | check_contents("long0", "new1", "new2"); | |
37 | $a[1] = 'long1'; | |
38 | check_contents("long0", "long1", "new2"); | |
39 | $a[2] = 'long2'; | |
40 | check_contents("long0", "long1", "long2"); | |
41 | $a[1] = 'longer1'; | |
42 | check_contents("long0", "longer1", "long2"); | |
43 | $a[0] = 'longer0'; | |
44 | check_contents("longer0", "longer1", "long2"); | |
45 | ||
46 | # 36-50 shortening alterations, including truncation | |
47 | $a[0] = 'short0'; | |
48 | check_contents("short0", "longer1", "long2"); | |
49 | $a[1] = 'short1'; | |
50 | check_contents("short0", "short1", "long2"); | |
51 | $a[2] = 'short2'; | |
52 | check_contents("short0", "short1", "short2"); | |
53 | $a[1] = 'sh1'; | |
54 | check_contents("short0", "sh1", "short2"); | |
55 | $a[0] = 'sh0'; | |
56 | check_contents("sh0", "sh1", "short2"); | |
57 | ||
58 | # (51-56) file with holes | |
59 | $a[4] = 'rec4'; | |
60 | check_contents("sh0", "sh1", "short2", "", "rec4"); | |
61 | $a[3] = 'rec3'; | |
62 | check_contents("sh0", "sh1", "short2", "rec3", "rec4"); | |
63 | ||
64 | # (57-59) zero out file | |
65 | @a = (); | |
66 | check_contents(); | |
67 | ||
68 | # (60-62) insert into the middle of an empty file | |
69 | $a[3] = "rec3"; | |
70 | check_contents("", "", "", "rec3"); | |
71 | ||
72 | # (63-68) Test the ->autochomp() method | |
73 | @a = qw(Gold Frankincense Myrrh); | |
74 | my $ac; | |
75 | $ac = $o->autochomp(); | |
76 | expect($ac); | |
77 | # See if that accidentally changed it | |
78 | $ac = $o->autochomp(); | |
79 | expect($ac); | |
80 | # Now clear it | |
81 | $ac = $o->autochomp(0); | |
82 | expect($ac); | |
83 | expect(join("-", @a), "Gold$:-Frankincense$:-Myrrh$:"); | |
84 | # Now set it again | |
85 | $ac = $o->autochomp(1); | |
86 | expect(!$ac); | |
87 | expect(join("-", @a), "Gold-Frankincense-Myrrh"); | |
88 | ||
89 | # (69) Does 'splice' work correctly with autochomp? | |
90 | my @sr; | |
91 | @sr = splice @a, 0, 2; | |
92 | expect(join("-", @sr), "Gold-Frankincense"); | |
93 | ||
94 | # (70-71) Didn't you forget that fetch may return an unchomped cached record? | |
95 | $a1 = $a[0]; # populate cache | |
96 | $a2 = $a[0]; | |
97 | expect($a1, "Myrrh"); | |
98 | expect($a2, "Myrrh"); | |
99 | # Actually no, you didn't---_fetch might return such a record, but | |
100 | # the chomping is done by FETCH. | |
101 | ||
102 | use POSIX 'SEEK_SET'; | |
103 | sub check_contents { | |
104 | my @c = @_; | |
105 | my $x = join $:, @c, ''; | |
106 | local *FH = $o->{fh}; | |
107 | seek FH, 0, SEEK_SET; | |
108 | # my $open = open FH, "< $file"; | |
109 | my $a; | |
110 | { local $/; $a = <FH> } | |
111 | $a = "" unless defined $a; | |
112 | if ($a eq $x) { | |
113 | print "ok $N\n"; | |
114 | } else { | |
115 | ctrlfix($a, $x); | |
116 | print "not ok $N\n# expected <$x>, got <$a>\n"; | |
117 | } | |
118 | $N++; | |
119 | ||
120 | # now check FETCH: | |
121 | my $good = 1; | |
122 | my $msg; | |
123 | for (0.. $#c) { | |
124 | my $aa = $a[$_]; | |
125 | unless ($aa eq $c[$_]) { | |
126 | $msg = "expected <$c[$_]>, got <$aa>"; | |
127 | ctrlfix($msg); | |
128 | $good = 0; | |
129 | } | |
130 | } | |
131 | print $good ? "ok $N\n" : "not ok $N # $msg\n"; | |
132 | $N++; | |
133 | ||
134 | print $o->_check_integrity($file, $ENV{INTEGRITY}) | |
135 | ? "ok $N\n" : "not ok $N\n"; | |
136 | $N++; | |
137 | } | |
138 | ||
139 | sub expect { | |
140 | if (@_ == 1) { | |
141 | print $_[0] ? "ok $N\n" : "not ok $N\n"; | |
142 | } elsif (@_ == 2) { | |
143 | my ($a, $x) = @_; | |
57c7bc08 AMS |
144 | if (! defined($a) && ! defined($x)) { print "ok $N\n" } |
145 | elsif ( defined($a) && ! defined($x)) { | |
146 | ctrlfix(my $msg = "expected UNDEF, got <$a>"); | |
147 | print "not ok $N \# $msg\n"; | |
148 | } | |
149 | elsif (! defined($a) && defined($x)) { | |
150 | ctrlfix(my $msg = "expected <$x>, got UNDEF"); | |
151 | print "not ok $N \# $msg\n"; | |
152 | } elsif ($a eq $x) { print "ok $N\n" } | |
0b28bc9a AMS |
153 | else { |
154 | ctrlfix(my $msg = "expected <$x>, got <$a>"); | |
57c7bc08 | 155 | print "not ok $N \# $msg\n"; |
0b28bc9a AMS |
156 | } |
157 | } else { | |
158 | die "expect() got ", scalar(@_), " args, should have been 1 or 2"; | |
159 | } | |
160 | $N++; | |
161 | } | |
162 | ||
163 | sub ctrlfix { | |
164 | for (@_) { | |
165 | s/\n/\\n/g; | |
166 | s/\r/\\r/g; | |
167 | } | |
168 | } | |
169 | ||
170 | END { | |
171 | undef $o; | |
172 | untie @a; | |
173 | 1 while unlink $file; | |
174 | } | |
175 |