Upgrade to Tie::File 0.20.
[perl.git] / lib / Tie / File / t / 22_autochomp.t
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
12 my $o = tie @a, 'Tie::File', $file, autochomp => 1;
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) = @_;
144     if ($a eq $x) { print "ok $N\n" }
145     else {
146       ctrlfix(my $msg = "expected <$x>, got <$a>");
147       print "not ok $N # $msg\n";
148     }
149   } else {
150     die "expect() got ", scalar(@_), " args, should have been 1 or 2";
151   }
152   $N++;
153 }
154
155 sub ctrlfix {
156   for (@_) {
157     s/\n/\\n/g;
158     s/\r/\\r/g;
159   }
160 }
161
162 END {
163   undef $o;
164   untie @a;
165   1 while unlink $file;
166 }
167