Upgrade to Tie::File 0.20.
[perl.git] / lib / Tie / File / t / 16_handle.t
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";
7 $: = Tie::File::_default_recsep();
8
9 if ($^O =~ /vms/i) {
10   print "1..0\n";
11   exit;
12 }
13
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";
23 binmode F;
24
25 my $o = tie @a, 'Tie::File', \*F, autochomp => 0;
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
59 # 25-34 shortening alterations, including truncation
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
81 # Does it correctly detect a non-seekable handle?
82 {  if ($^O =~ /^(MSWin32|dos)$/) {
83      print "ok $N # skipped ($^O has broken pipe semantics)\n";
84      last;
85    }
86    my $pipe_succeeded = eval {pipe *R, *W};
87    if ($@) {
88      chomp $@;
89      print "ok $N # skipped (no pipes: $@)\n";
90      last;
91    } elsif (! $pipe_succeeded) {
92      print "ok $N # skipped (pipe call failed: $!)\n";
93      last;
94    }
95    close R;
96    $o = eval {tie @a, 'Tie::File', \*W};
97    if ($@) {
98      if ($@ =~ /filehandle does not appear to be seekable/) {
99        print "ok $N\n";
100      } else {
101        chomp $@;
102        print "not ok $N \# \$\@ is $@\n";
103      }
104    } else {
105        print "not ok $N \# passing pipe to TIEARRAY didn't abort program\n";
106    }
107    $N++;
108 }
109
110 use POSIX 'SEEK_SET';
111 sub check_contents {
112   my @c = @_;
113   my $x = join $:, @c, '';
114   local *FH = $o->{fh};
115   seek FH, 0, SEEK_SET;
116 #  my $open = open FH, "< $file";
117   my $a;
118   { local $/; $a = <FH> }
119   $a = "" unless defined $a;
120   if ($a eq $x) {
121     print "ok $N\n";
122   } else {
123     ctrlfix(my $msg = "# expected <$x>, got <$a>");
124     print "not ok $N\n$msg\n";
125   }
126   $N++;
127
128   # now check FETCH:
129   my $good = 1;
130   my $msg;
131   for (0.. $#c) {
132     unless ($a[$_] eq "$c[$_]$:") {
133       $msg = "expected $c[$_]$:, got $a[$_]";
134       ctrlfix($msg);
135       $good = 0;
136     }
137   }
138   print $good ? "ok $N\n" : "not ok $N # $msg\n";
139   $N++;
140 }
141
142
143 sub ctrlfix {
144   for (@_) {
145     s/\n/\\n/g;
146     s/\r/\\r/g;
147   }
148 }
149
150 END {
151   undef $o;
152   untie @a;
153   1 while unlink $file;
154 }
155
156