lib/Tie/File/t/17_misc_meth.t

   1 #!/usr/bin/perl
   2 #
   3 # Check miscellaneous tied-array interface methods
   4 # EXTEND, CLEAR, DELETE, EXISTS
   5 #
   6
   7 use lib '/home/mjd/src/perl/Tie-File2/lib';
   8 my $file = "tf$$.txt";
   9 1 while unlink $file;
  10
  11 print "1..24\n";
  12
  13 my $N = 1;
  14 use Tie::File;
  15 print "ok $N\n"; $N++;
  16
  17 my $o = tie @a, 'Tie::File', $file;
  18 print $o ? "ok $N\n" : "not ok $N\n";
  19 $N++;
  20
  21 # (3-8) EXTEND
  22 $o->EXTEND(3);
  23 check_contents("$/$/$/");
  24 $o->EXTEND(4);
  25 check_contents("$/$/$/$/");
  26 $o->EXTEND(3);
  27 check_contents("$/$/$/$/");
  28
  29 # (9-10) CLEAR
  30 @a = ();
  31 check_contents("");
  32
  33 # (11-16) EXISTS
  34 print !exists $a[0] ? "ok $N\n" : "not ok $N\n";
  35 $N++;
  36 $a[0] = "I like pie.";
  37 print exists $a[0] ? "ok $N\n" : "not ok $N\n";
  38 $N++;
  39 print !exists $a[1] ? "ok $N\n" : "not ok $N\n";
  40 $N++;
  41 $a[2] = "GIVE ME PIE";
  42 print exists $a[0] ? "ok $N\n" : "not ok $N\n";
  43 $N++;
  44 # exists $a[1] is not defined by this module under these circumstances
  45 print exists $a[1] ? "ok $N\n" : "ok $N\n";
  46 $N++;
  47 print exists $a[2] ? "ok $N\n" : "not ok $N\n";
  48 $N++;
  49
  50 # (17-24) DELETE
  51 delete $a[0];
  52 check_contents("$/$/GIVE ME PIE$/");
  53 delete $a[2];
  54 check_contents("$/$/");
  55 delete $a[0];
  56 check_contents("$/$/");
  57 delete $a[1];
  58 check_contents("$/");
  59
  60
  61 use POSIX 'SEEK_SET';
  62 sub check_contents {
  63   my $x = shift;
  64   local *FH = $o->{fh};
  65   seek FH, 0, SEEK_SET;
  66   my $a;
  67   { local $/; $a = <FH> }
  68   $a = "" unless defined $a;
  69   if ($a eq $x) {
  70     print "ok $N\n";
  71   } else {
  72     s{$/}{\\n}g for $a, $x;
  73     print "not ok $N\n# expected <$x>, got <$a>\n";
  74   }
  75   $N++;
  76   print $o->_check_integrity($file, $ENV{INTEGRITY}) ? "ok $N\n" : "not ok $N\n";
  77   $N++;
  78 }
  79
  80 END {
  81   undef $o;
  82   untie @a;
  83   1 while unlink $file;
  84 }
  85
  86