Commit | Line | Data |
fa408a35 |
1 | #!/usr/bin/perl |
2 | # |
3 | # Basic operation, initializing the object from an already-open handle |
4 | # instead of from a filename |
5 | |
6 | my $file = "tf$$.txt"; |
b3fe5a4c |
7 | $: = Tie::File::_default_recsep(); |
fa408a35 |
8 | |
836d9961 |
9 | if ($^O =~ /vms/i) { |
10 | print "1..0\n"; |
11 | exit; |
12 | } |
13 | |
fa408a35 |
14 | print "1..39\n"; |
15 | |
16 | my $N = 1; |
17 | use Tie::File; |
18 | print "ok $N\n"; $N++; |
19 | |
20 | use Fcntl 'O_CREAT', 'O_RDWR'; |
21 | sysopen F, $file, O_CREAT | O_RDWR |
22 | or die "Couldn't create temp file $file: $!; aborting"; |
b3fe5a4c |
23 | binmode F; |
fa408a35 |
24 | |
6fc0ea7e |
25 | my $o = tie @a, 'Tie::File', \*F, autochomp => 0, autodefer => 0; |
fa408a35 |
26 | print $o ? "ok $N\n" : "not ok $N\n"; |
27 | $N++; |
28 | |
29 | # 3-4 create |
30 | $a[0] = 'rec0'; |
31 | check_contents("rec0"); |
32 | |
33 | # 5-8 append |
34 | $a[1] = 'rec1'; |
35 | check_contents("rec0", "rec1"); |
36 | $a[2] = 'rec2'; |
37 | check_contents("rec0", "rec1", "rec2"); |
38 | |
39 | # 9-14 same-length alterations |
40 | $a[0] = 'new0'; |
41 | check_contents("new0", "rec1", "rec2"); |
42 | $a[1] = 'new1'; |
43 | check_contents("new0", "new1", "rec2"); |
44 | $a[2] = 'new2'; |
45 | check_contents("new0", "new1", "new2"); |
46 | |
47 | # 15-24 lengthening alterations |
48 | $a[0] = 'long0'; |
49 | check_contents("long0", "new1", "new2"); |
50 | $a[1] = 'long1'; |
51 | check_contents("long0", "long1", "new2"); |
52 | $a[2] = 'long2'; |
53 | check_contents("long0", "long1", "long2"); |
54 | $a[1] = 'longer1'; |
55 | check_contents("long0", "longer1", "long2"); |
56 | $a[0] = 'longer0'; |
57 | check_contents("longer0", "longer1", "long2"); |
58 | |
27531ffb |
59 | # 25-38 shortening alterations, including truncation |
fa408a35 |
60 | $a[0] = 'short0'; |
61 | check_contents("short0", "longer1", "long2"); |
62 | $a[1] = 'short1'; |
63 | check_contents("short0", "short1", "long2"); |
64 | $a[2] = 'short2'; |
65 | check_contents("short0", "short1", "short2"); |
66 | $a[1] = 'sh1'; |
67 | check_contents("short0", "sh1", "short2"); |
68 | $a[0] = 'sh0'; |
69 | check_contents("sh0", "sh1", "short2"); |
70 | |
71 | # file with holes |
72 | $a[4] = 'rec4'; |
73 | check_contents("sh0", "sh1", "short2", "", "rec4"); |
74 | $a[3] = 'rec3'; |
75 | check_contents("sh0", "sh1", "short2", "rec3", "rec4"); |
76 | |
77 | close F; |
78 | undef $o; |
79 | untie @a; |
80 | |
27531ffb |
81 | # (39) Does it correctly detect a non-seekable handle? |
dbc1d986 |
82 | { if ($^O =~ /^(MSWin32|dos|beos)$/) { |
b3fe5a4c |
83 | print "ok $N # skipped ($^O has broken pipe semantics)\n"; |
84 | last; |
85 | } |
bf919750 |
86 | if ($] < 5.006) { |
87 | print "ok $N # skipped - 5.005_03 panics after this test\n"; |
88 | last; |
89 | } |
b3fe5a4c |
90 | my $pipe_succeeded = eval {pipe *R, *W}; |
91 | if ($@) { |
92 | chomp $@; |
93 | print "ok $N # skipped (no pipes: $@)\n"; |
94 | last; |
95 | } elsif (! $pipe_succeeded) { |
96 | print "ok $N # skipped (pipe call failed: $!)\n"; |
97 | last; |
98 | } |
99 | close R; |
100 | $o = eval {tie @a, 'Tie::File', \*W}; |
101 | if ($@) { |
102 | if ($@ =~ /filehandle does not appear to be seekable/) { |
103 | print "ok $N\n"; |
104 | } else { |
105 | chomp $@; |
106 | print "not ok $N \# \$\@ is $@\n"; |
107 | } |
108 | } else { |
109 | print "not ok $N \# passing pipe to TIEARRAY didn't abort program\n"; |
110 | } |
111 | $N++; |
fa408a35 |
112 | } |
113 | |
fa408a35 |
114 | use POSIX 'SEEK_SET'; |
115 | sub check_contents { |
116 | my @c = @_; |
b3fe5a4c |
117 | my $x = join $:, @c, ''; |
fa408a35 |
118 | local *FH = $o->{fh}; |
119 | seek FH, 0, SEEK_SET; |
120 | # my $open = open FH, "< $file"; |
121 | my $a; |
122 | { local $/; $a = <FH> } |
123 | $a = "" unless defined $a; |
124 | if ($a eq $x) { |
125 | print "ok $N\n"; |
126 | } else { |
b3fe5a4c |
127 | ctrlfix(my $msg = "# expected <$x>, got <$a>"); |
128 | print "not ok $N\n$msg\n"; |
fa408a35 |
129 | } |
130 | $N++; |
131 | |
132 | # now check FETCH: |
133 | my $good = 1; |
134 | my $msg; |
135 | for (0.. $#c) { |
b3fe5a4c |
136 | unless ($a[$_] eq "$c[$_]$:") { |
137 | $msg = "expected $c[$_]$:, got $a[$_]"; |
138 | ctrlfix($msg); |
fa408a35 |
139 | $good = 0; |
140 | } |
141 | } |
142 | print $good ? "ok $N\n" : "not ok $N # $msg\n"; |
143 | $N++; |
144 | } |
145 | |
b3fe5a4c |
146 | |
147 | sub ctrlfix { |
148 | for (@_) { |
149 | s/\n/\\n/g; |
150 | s/\r/\\r/g; |
151 | } |
152 | } |
153 | |
fa408a35 |
154 | END { |
155 | undef $o; |
156 | untie @a; |
157 | 1 while unlink $file; |
158 | } |
159 | |
160 | |