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, autodefer => 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-38 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 if ($] < 5.006) {
  82   print "ok 39 # skipped - 5.005_03 panics after this test\n";
  83   exit 0;
  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    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
 114 use POSIX 'SEEK_SET';
 115 sub 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
 147 sub ctrlfix {
 148   for (@_) {
 149     s/\n/\\n/g;
 150     s/\r/\\r/g;
 151   }
 152 }
 153
 154 END {
 155   undef $o;
 156   untie @a;
 157   1 while unlink $file;
 158 }
 159
 160