1#!/usr/bin/perl
2#
3# Make sure it works to open the file in read-only mode
4#
5
6use strict;
7use warnings;
8
9my $file = "tf08-$$.txt";
10$: = Tie::File::_default_recsep();
11
12print "1..13\n";
13
14my $N = 1;
15use Tie::File;
16use Fcntl 'O_RDONLY';
17print "ok $N\n"; $N++;
18
19my @items = qw(Gold Frankincense Myrrh Ivory Apes Peacocks);
20init_file(join $:, @items, '');
21
22my @a;
23my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0;
24print $o ? "ok $N\n" : "not ok $N\n";
25$N++;
26
27$#a == $#items ? print "ok $N\n" : print "not ok $N\n";
28$N++;
29
30for my $i (0..$#items) {
31  ("$items[$i]$:" eq $a[$i]) ? print "ok $N\n" : print "not ok $N\n";
32  $N++;
33}
34
35sub init_file {
36  my $data = shift;
37  open F, '>', $file or die $!;
38  binmode F;
39  print F $data;
40  close F;
41}
42
43undef $o; untie @a;
44my $badrec = "Malformed";
45# (10-13) When a record lacks the record seprator, we sneakily try
46# to fix it.  How does that work when the file is read-only?
47if (setup_badly_terminated_file(4)) {
48  my $good = 1;
49  my $warn;
50  local $SIG{__WARN__} = sub { $good = 0; ctrlfix($warn = shift); };
51  local $^W = 1;
52  my $o = tie @a, 'Tie::File', $file, mode => O_RDONLY, autochomp => 0
53    or die "Couldn't tie $file: $!";
54
55  print $a[0] eq "Malformed$:" ? "ok $N\n" : "not ok $N\n";  $N++;
56  print $good ? "ok $N\n" : "not ok $N # $warn\n";  $good = 1; $N++;
57  print $a[0] eq "Malformed$:" ? "ok $N\n" : "not ok $N\n";  $N++;
58  print $good ? "ok $N\n" : "not ok $N # $warn\n";  $good = 1; $N++;
59}
60
61sub setup_badly_terminated_file {
62  my $NTESTS = shift;
63  open F, '>', $file or die "Couldn't open $file: $!";
64  binmode F;
65  print F $badrec;
66  close F;
67  unless (-s $file == length $badrec) {
68    for (1 .. $NTESTS) {
69      print "ok $N \# skipped - can't create improperly terminated file\n";
70      $N++;
71    }
72    return;
73  }
74  return 1;
75}
76
77
78sub ctrlfix {
79  for (@_) {
80    s/\n/\\n/g;
81    s/\r/\\r/g;
82  }
83}
84
85END {
86  undef $o;
87  untie @a;
88  1 while unlink $file;
89}
90
91