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 => 50);
  14
  15 sub compare {
  16     local $Level = $Level + 1;
  17
  18     return unless @expect;
  19     return ::fail() unless(@_ == @expect);
  20
  21     for my $i (0..$#_) {
  22         next if $_[$i] eq $expect[$i];
  23         return ::fail();
  24     }
  25
  26     ::pass();
  27 }
  28
  29
  30 package Implement;
  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 my $fh = gensym;
  81
  82 @expect = (TIEHANDLE => 'Implement');
  83 my $ob = tie *$fh,'Implement';
  84 is(ref($ob),  'Implement');
  85 is(tied(*$fh), $ob);
  86
  87 @expect = (PRINT => $ob,"some","text");
  88 $r = print $fh @expect[2,3];
  89 is($r, 1);
  90
  91 @expect = (PRINTF => $ob,"%s","text");
  92 $r = printf $fh @expect[2,3];
  93 is($r, 2);
  94
  95 $text = (@data = ("the line\n"))[0];
  96 @expect = (READLINE => $ob);
  97 $ln = <$fh>;
  98 is($ln, $text);
  99
 100 @expect = ();
 101 @in = @data = qw(a line at a time);
 102 @line = <$fh>;
 103 @expect = @in;
 104 compare(@line);
 105
 106 @expect = (GETC => $ob);
 107 $data = "abc";
 108 $ch = getc $fh;
 109 is($ch, "a");
 110
 111 $buf = "xyz";
 112 @expect = (READ => $ob, $buf, 3);
 113 $data = "abc";
 114 $r = read $fh,$buf,3;
 115 is($r, 3);
 116 is($buf, "abc");
 117
 118
 119 $buf = "xyzasd";
 120 @expect = (READ => $ob, $buf, 3,3);
 121 $data = "abc";
 122 $r = sysread $fh,$buf,3,3;
 123 is($r, 3);
 124 is($buf, "xyzabc");
 125
 126 $buf = "qwerty";
 127 @expect = (WRITE => $ob, $buf, 4,1);
 128 $data = "";
 129 $r = syswrite $fh,$buf,4,1;
 130 is($r, 4);
 131 is($data, "wert");
 132
 133 $buf = "qwerty";
 134 @expect = (WRITE => $ob, $buf, 4);
 135 $data = "";
 136 $r = syswrite $fh,$buf,4;
 137 is($r, 4);
 138 is($data, "qwer");
 139
 140 $buf = "qwerty";
 141 @expect = (WRITE => $ob, $buf, 6);
 142 $data = "";
 143 $r = syswrite $fh,$buf;
 144 is($r, 6);
 145 is($data, "qwerty");
 146
 147 @expect = (CLOSE => $ob);
 148 $r = close $fh;
 149 is($r, 5);
 150
 151 # Does aliasing work with tied FHs?
 152 *ALIAS = *$fh;
 153 @expect = (PRINT => $ob,"some","text");
 154 $r = print ALIAS @expect[2,3];
 155 is($r, 1);
 156
 157 {
 158     use warnings;
 159     # Special case of aliasing STDERR, which used
 160     # to dump core when warnings were enabled
 161     local *STDERR = *$fh;
 162     @expect = (PRINT => $ob,"some","text");
 163     $r = print STDERR @expect[2,3];
 164     is($r, 1);
 165 }
 166
 167 {
 168     package Bar::Say;
 169     use feature 'say';
 170     use base qw(Implement);
 171
 172     my $ors;
 173     sub PRINT     {
 174         $ors = $\;
 175         my $self = shift;
 176         return $self->SUPER::PRINT(@_);
 177     }
 178
 179     my $fh = Symbol::gensym;
 180     @expect = (TIEHANDLE => 'Bar::Say');
 181     ::ok( my $obj = tie *$fh, 'Bar::Say' );
 182
 183     local $\ = 'something';
 184     @expect = (PRINT => $obj, "stuff", "and", "things");
 185     ::ok( print $fh @expect[2..4] );
 186     ::is( $ors, 'something' );
 187
 188     ::ok( say $fh @expect[2..4] );
 189     ::is( $ors, "\n",        'say sets $\ to \n in PRINT' );
 190     ::is( $\,   "something", "  and it's localized" );
 191 }
 192
 193 {
 194     # Test for change #11536
 195     package Foo;
 196     use strict;
 197     sub TIEHANDLE { bless {} }
 198     my $cnt = 'a';
 199     sub READ {
 200         $_[1] = $cnt++;
 201         1;
 202     }
 203     sub do_read {
 204         my $fh = shift;
 205         read $fh, my $buff, 1;
 206         ::pass();
 207     }
 208     $|=1;
 209     tie *STDIN, 'Foo';
 210     read STDIN, my $buff, 1;
 211     ::pass();
 212     do_read(\*STDIN);
 213     untie *STDIN;
 214 }
 215
 216
 217 {
 218     # test for change 11639: Can't localize *FH, then tie it
 219     {
 220         local *foo;
 221         tie %foo, 'Blah';
 222     }
 223     ok(!tied %foo);
 224
 225     {
 226         local *bar;
 227         tie @bar, 'Blah';
 228     }
 229     ok(!tied @bar);
 230
 231     {
 232         local *BAZ;
 233         tie *BAZ, 'Blah';
 234     }
 235     ok(!tied *BAZ);
 236
 237     package Blah;
 238
 239     sub TIEHANDLE {bless {}}
 240     sub TIEHASH   {bless {}}
 241     sub TIEARRAY  {bless {}}
 242 }
 243
 244 {
 245     # warnings should pass to the PRINT method of tied STDERR
 246     my @received;
 247
 248     local *STDERR = *$fh;
 249     no warnings 'redefine';
 250     local *Implement::PRINT = sub { @received = @_ };
 251
 252     $r = warn("some", "text", "\n");
 253     @expect = (PRINT => $ob,"sometext\n");
 254
 255     compare(PRINT => @received);
 256
 257     use warnings;
 258     print undef;
 259
 260     like($received[1], qr/Use of uninitialized value/);
 261 }
 262
 263 {
 264     # [ID 20020713.001] chomp($data=<tied_fh>)
 265     local *TEST;
 266     tie *TEST, 'CHOMP';
 267     my $data;
 268     chomp($data = <TEST>);
 269     is($data, 'foobar');
 270
 271     package CHOMP;
 272     sub TIEHANDLE { bless {}, $_[0] }
 273     sub READLINE { "foobar\n" }
 274 }
 275