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