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