Commit | Line | Data |
0b28bc9a |
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 |
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 |
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 |
153 | else { |
154 | ctrlfix(my $msg = "expected <$x>, got <$a>"); |
57c7bc08 |
155 | print "not ok $N \# $msg\n"; |
0b28bc9a |
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 | |