t/op/tiehandle.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 my @expect;
   9 my $data = "";
  10 my @data = ();
  11
  12 require './test.pl';
  13 plan(tests => 41);
  14
  15 sub compare {
  16     return unless @expect;
  17     return ::fail() unless(@_ == @expect);
  18
  19     for my $i (0..$#_) {
  20         next if $_[$i] eq $expect[$i];
  21         return ::fail();
  22     }
  23
  24     ::pass();
  25 }
  26
  27
  28 package Implement;
  29
  30 sub TIEHANDLE {
  31     ::compare(TIEHANDLE => @_);
  32     my ($class,@val) = @_;
  33     return bless \@val,$class;
  34 }
  35
  36 sub PRINT {
  37     ::compare(PRINT => @_);
  38     1;
  39 }
  40
  41 sub PRINTF {
  42     ::compare(PRINTF => @_);
  43     2;
  44 }
  45
  46 sub READLINE {
  47     ::compare(READLINE => @_);
  48     wantarray ? @data : shift @data;
  49 }
  50
  51 sub GETC {
  52     ::compare(GETC => @_);
  53     substr($data,0,1);
  54 }
  55
  56 sub READ {
  57     ::compare(READ => @_);
  58     substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
  59     3;
  60 }
  61
  62 sub WRITE {
  63     ::compare(WRITE => @_);
  64     $data = substr($_[1],$_[3] || 0, $_[2]);
  65     length($data);
  66 }
  67
  68 sub CLOSE {
  69     ::compare(CLOSE => @_);
  70
  71     5;
  72 }
  73
  74 package main;
  75
  76 use Symbol;
  77
  78 my $fh = gensym;
  79
  80 @expect = (TIEHANDLE => 'Implement');
  81 my $ob = tie *$fh,'Implement';
  82 is(ref($ob),  'Implement');
  83 is(tied(*$fh), $ob);
  84
  85 @expect = (PRINT => $ob,"some","text");
  86 $r = print $fh @expect[2,3];
  87 is($r, 1);
  88
  89 @expect = (PRINTF => $ob,"%s","text");
  90 $r = printf $fh @expect[2,3];
  91 is($r, 2);
  92
  93 $text = (@data = ("the line\n"))[0];
  94 @expect = (READLINE => $ob);
  95 $ln = <$fh>;
  96 is($ln, $text);
  97
  98 @expect = ();
  99 @in = @data = qw(a line at a time);
 100 @line = <$fh>;
 101 @expect = @in;
 102 compare(@line);
 103
 104 @expect = (GETC => $ob);
 105 $data = "abc";
 106 $ch = getc $fh;
 107 is($ch, "a");
 108
 109 $buf = "xyz";
 110 @expect = (READ => $ob, $buf, 3);
 111 $data = "abc";
 112 $r = read $fh,$buf,3;
 113 is($r, 3);
 114 is($buf, "abc");
 115
 116
 117 $buf = "xyzasd";
 118 @expect = (READ => $ob, $buf, 3,3);
 119 $data = "abc";
 120 $r = sysread $fh,$buf,3,3;
 121 is($r, 3);
 122 is($buf, "xyzabc");
 123
 124 $buf = "qwerty";
 125 @expect = (WRITE => $ob, $buf, 4,1);
 126 $data = "";
 127 $r = syswrite $fh,$buf,4,1;
 128 is($r, 4);
 129 is($data, "wert");
 130
 131 $buf = "qwerty";
 132 @expect = (WRITE => $ob, $buf, 4);
 133 $data = "";
 134 $r = syswrite $fh,$buf,4;
 135 is($r, 4);
 136 is($data, "qwer");
 137
 138 $buf = "qwerty";
 139 @expect = (WRITE => $ob, $buf, 6);
 140 $data = "";
 141 $r = syswrite $fh,$buf;
 142 is($r, 6);
 143 is($data, "qwerty");
 144
 145 @expect = (CLOSE => $ob);
 146 $r = close $fh;
 147 is($r, 5);
 148
 149 # Does aliasing work with tied FHs?
 150 *ALIAS = *$fh;
 151 @expect = (PRINT => $ob,"some","text");
 152 $r = print ALIAS @expect[2,3];
 153 is($r, 1);
 154
 155 {
 156     use warnings;
 157     # Special case of aliasing STDERR, which used
 158     # to dump core when warnings were enabled
 159     local *STDERR = *$fh;
 160     @expect = (PRINT => $ob,"some","text");
 161     $r = print STDERR @expect[2,3];
 162     is($r, 1);
 163 }
 164
 165 {
 166     # Test for change #11536
 167     package Foo;
 168     use strict;
 169     sub TIEHANDLE { bless {} }
 170     my $cnt = 'a';
 171     sub READ {
 172         $_[1] = $cnt++;
 173         1;
 174     }
 175     sub do_read {
 176         my $fh = shift;
 177         read $fh, my $buff, 1;
 178         ::pass();
 179     }
 180     $|=1;
 181     tie *STDIN, 'Foo';
 182     read STDIN, my $buff, 1;
 183     ::pass();
 184     do_read(\*STDIN);
 185     untie *STDIN;
 186 }
 187
 188
 189 {
 190     # test for change 11639: Can't localize *FH, then tie it
 191     {
 192         local *foo;
 193         tie %foo, 'Blah';
 194     }
 195     ok(!tied %foo);
 196
 197     {
 198         local *bar;
 199         tie @bar, 'Blah';
 200     }
 201     ok(!tied @bar);
 202
 203     {
 204         local *BAZ;
 205         tie *BAZ, 'Blah';
 206     }
 207     ok(!tied *BAZ);
 208
 209     package Blah;
 210
 211     sub TIEHANDLE {bless {}}
 212     sub TIEHASH   {bless {}}
 213     sub TIEARRAY  {bless {}}
 214 }
 215
 216 {
 217     # warnings should pass to the PRINT method of tied STDERR
 218     my @received;
 219
 220     local *STDERR = *$fh;
 221     no warnings 'redefine';
 222     local *Implement::PRINT = sub { @received = @_ };
 223
 224     $r = warn("some", "text", "\n");
 225     @expect = (PRINT => $ob,"sometext\n");
 226
 227     compare(PRINT => @received);
 228
 229     use warnings;
 230     print undef;
 231
 232     like($received[1], qr/Use of uninitialized value/);
 233 }
 234
 235 {
 236     # [ID 20020713.001] chomp($data=<tied_fh>)
 237     local *TEST;
 238     tie *TEST, 'CHOMP';
 239     my $data;
 240     chomp($data = <TEST>);
 241     is($data, 'foobar');
 242
 243     package CHOMP;
 244     sub TIEHANDLE { bless {}, $_[0] }
 245     sub READLINE { "foobar\n" }
 246 }
 247
 248