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