1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8my @expect; 9my $data = ""; 10my @data = (); 11my $test = 1; 12 13sub ok { print "not " unless shift; print "ok ",$test++,"\n"; } 14 15package Implement; 16 17BEGIN { *ok = \*main::ok } 18 19sub 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 32sub TIEHANDLE { 33 compare(TIEHANDLE => @_); 34 my ($class,@val) = @_; 35 return bless \@val,$class; 36} 37 38sub PRINT { 39 compare(PRINT => @_); 40 1; 41} 42 43sub PRINTF { 44 compare(PRINTF => @_); 45 2; 46} 47 48sub READLINE { 49 compare(READLINE => @_); 50 wantarray ? @data : shift @data; 51} 52 53sub GETC { 54 compare(GETC => @_); 55 substr($data,0,1); 56} 57 58sub READ { 59 compare(READ => @_); 60 substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); 61 3; 62} 63 64sub WRITE { 65 compare(WRITE => @_); 66 $data = substr($_[1],$_[3] || 0, $_[2]); 67 length($data); 68} 69 70sub CLOSE { 71 compare(CLOSE => @_); 72 73 5; 74} 75 76package main; 77 78use Symbol; 79 80print "1..33\n"; 81 82my $fh = gensym; 83 84@expect = (TIEHANDLE => 'Implement'); 85my $ob = tie *$fh,'Implement'; 86ok(ref($ob) eq 'Implement'); 87ok(tied(*$fh) == $ob); 88 89@expect = (PRINT => $ob,"some","text"); 90$r = print $fh @expect[2,3]; 91ok($r == 1); 92 93@expect = (PRINTF => $ob,"%s","text"); 94$r = printf $fh @expect[2,3]; 95ok($r == 2); 96 97$text = (@data = ("the line\n"))[0]; 98@expect = (READLINE => $ob); 99$ln = <$fh>; 100ok($ln eq $text); 101 102@expect = (); 103@in = @data = qw(a line at a time); 104@line = <$fh>; 105@expect = @in; 106Implement::compare(@line); 107 108@expect = (GETC => $ob); 109$data = "abc"; 110$ch = getc $fh; 111ok($ch eq "a"); 112 113$buf = "xyz"; 114@expect = (READ => $ob, $buf, 3); 115$data = "abc"; 116$r = read $fh,$buf,3; 117ok($r == 3); 118ok($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; 125ok($r == 3); 126ok($buf eq "xyzabc"); 127 128$buf = "qwerty"; 129@expect = (WRITE => $ob, $buf, 4,1); 130$data = ""; 131$r = syswrite $fh,$buf,4,1; 132ok($r == 4); 133ok($data eq "wert"); 134 135$buf = "qwerty"; 136@expect = (WRITE => $ob, $buf, 4); 137$data = ""; 138$r = syswrite $fh,$buf,4; 139ok($r == 4); 140ok($data eq "qwer"); 141 142$buf = "qwerty"; 143@expect = (WRITE => $ob, $buf, 6); 144$data = ""; 145$r = syswrite $fh,$buf; 146ok($r == 6); 147ok($data eq "qwerty"); 148 149@expect = (CLOSE => $ob); 150$r = close $fh; 151ok($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]; 157ok($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} 168