Upgrade to Tie::File 0.20.
[perl.git] / lib / Tie / File / t / 09_gen_rs.t
1 #!/usr/bin/perl
2
3 my $file = "tf$$.txt";
4
5 print "1..38\n";
6
7 my $N = 1;
8 use Tie::File;
9 print "ok $N\n"; $N++;
10
11 my $o = tie @a, 'Tie::File', $file, recsep => 'blah', autochomp => 0;
12 print $o ? "ok $N\n" : "not ok $N\n";
13 $N++;
14
15
16 # 3-4 create
17 $a[0] = 'rec0';
18 check_contents("rec0");
19
20 # 5-8 append
21 $a[1] = 'rec1';
22 check_contents("rec0", "rec1");
23 $a[2] = 'rec2';
24 check_contents("rec0", "rec1", "rec2");
25
26 # 9-14 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 # 15-24 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 # 25-34 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 # 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
65 # try inserting a record into the middle of an empty file
66
67 use POSIX 'SEEK_SET';
68 sub check_contents {
69   my @c = @_;
70   my $x = join 'blah', @c, '';
71   local *FH = $o->{fh};
72   seek FH, 0, SEEK_SET;
73   my $a;
74   { local $/; $a = <FH> }
75
76   $a = "" unless defined $a;
77   if ($a eq $x) {
78     print "ok $N\n";
79   } else {
80     my $msg = "# expected <$x>, got <$a>";
81     ctrlfix($msg);
82     print "not ok $N $msg\n";
83   }
84   $N++;
85
86   # now check FETCH:
87   my $good = 1;
88   for (0.. $#c) {
89     unless ($a[$_] eq "$c[$_]blah") {
90       $msg = "expected $c[$_]blah, got $a[$_]";
91       ctrlfix($msg);
92       $good = 0;
93     }
94   }
95   print $good ? "ok $N\n" : "not ok $N # fetch @c\n";
96   $N++;
97 }
98
99
100 sub ctrlfix {
101   for (@_) {
102     s/\n/\\n/g;
103     s/\r/\\r/g;
104   }
105 }
106
107
108 END {
109   undef $o;
110   untie @a;
111   1 while unlink $file;
112 }
113