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