t/op/tiehandle.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 my @expect;
   9 my $data = "";
  10 my @data = ();
  11 my $test = 1;
  12
  13 sub ok { print "not " unless shift; print "ok ",$test++,"\n"; }
  14
  15 package Implement;
  16
  17 BEGIN { *ok = \*main::ok }
  18
  19 sub compare {
  20     return unless @expect;
  21     return ok(0) unless(@_ == @expect);
  22
  23     my $i;
  24     for($i = 0 ; $i < @_ ; $i++) {
  25         next if $_[$i] eq $expect[$i];
  26         return ok(0);
  27     }
  28
  29     ok(1);
  30 }
  31
  32 sub TIEHANDLE {
  33     compare(TIEHANDLE => @_);
  34     my ($class,@val) = @_;
  35     return bless \@val,$class;
  36 }
  37
  38 sub PRINT {
  39     compare(PRINT => @_);
  40     1;
  41 }
  42
  43 sub PRINTF {
  44     compare(PRINTF => @_);
  45     2;
  46 }
  47
  48 sub READLINE {
  49     compare(READLINE => @_);
  50     wantarray ? @data : shift @data;
  51 }
  52
  53 sub GETC {
  54     compare(GETC => @_);
  55     substr($data,0,1);
  56 }
  57
  58 sub READ {
  59     compare(READ => @_);
  60     substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
  61     3;
  62 }
  63
  64 sub WRITE {
  65     compare(WRITE => @_);
  66     $data = substr($_[1],$_[3] || 0, $_[2]);
  67     length($data);
  68 }
  69
  70 sub CLOSE {
  71     compare(CLOSE => @_);
  72
  73     5;
  74 }
  75
  76 package main;
  77
  78 use Symbol;
  79
  80 print "1..33\n";
  81
  82 my $fh = gensym;
  83
  84 @expect = (TIEHANDLE => 'Implement');
  85 my $ob = tie *$fh,'Implement';
  86 ok(ref($ob) eq 'Implement');
  87 ok(tied(*$fh) == $ob);
  88
  89 @expect = (PRINT => $ob,"some","text");
  90 $r = print $fh @expect[2,3];
  91 ok($r == 1);
  92
  93 @expect = (PRINTF => $ob,"%s","text");
  94 $r = printf $fh @expect[2,3];
  95 ok($r == 2);
  96
  97 $text = (@data = ("the line\n"))[0];
  98 @expect = (READLINE => $ob);
  99 $ln = <$fh>;
 100 ok($ln eq $text);
 101
 102 @expect = ();
 103 @in = @data = qw(a line at a time);
 104 @line = <$fh>;
 105 @expect = @in;
 106 Implement::compare(@line);
 107
 108 @expect = (GETC => $ob);
 109 $data = "abc";
 110 $ch = getc $fh;
 111 ok($ch eq "a");
 112
 113 $buf = "xyz";
 114 @expect = (READ => $ob, $buf, 3);
 115 $data = "abc";
 116 $r = read $fh,$buf,3;
 117 ok($r == 3);
 118 ok($buf eq "abc");
 119
 120
 121 $buf = "xyzasd";
 122 @expect = (READ => $ob, $buf, 3,3);
 123 $data = "abc";
 124 $r = sysread $fh,$buf,3,3;
 125 ok($r == 3);
 126 ok($buf eq "xyzabc");
 127
 128 $buf = "qwerty";
 129 @expect = (WRITE => $ob, $buf, 4,1);
 130 $data = "";
 131 $r = syswrite $fh,$buf,4,1;
 132 ok($r == 4);
 133 ok($data eq "wert");
 134
 135 $buf = "qwerty";
 136 @expect = (WRITE => $ob, $buf, 4);
 137 $data = "";
 138 $r = syswrite $fh,$buf,4;
 139 ok($r == 4);
 140 ok($data eq "qwer");
 141
 142 $buf = "qwerty";
 143 @expect = (WRITE => $ob, $buf, 6);
 144 $data = "";
 145 $r = syswrite $fh,$buf;
 146 ok($r == 6);
 147 ok($data eq "qwerty");
 148
 149 @expect = (CLOSE => $ob);
 150 $r = close $fh;
 151 ok($r == 5);
 152
 153 # Does aliasing work with tied FHs?
 154 *ALIAS = *$fh;
 155 @expect = (PRINT => $ob,"some","text");
 156 $r = print ALIAS @expect[2,3];
 157 ok($r == 1);
 158
 159 {
 160     use warnings;
 161     # Special case of aliasing STDERR, which used
 162     # to dump core when warnings were enabled
 163     *STDERR = *$fh;
 164     @expect = (PRINT => $ob,"some","text");
 165     $r = print STDERR @expect[2,3];
 166     ok($r == 1);
 167 }