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