diff options
Diffstat (limited to 'contrib/perl5/t/op/tiehandle.t')
-rwxr-xr-x | contrib/perl5/t/op/tiehandle.t | 167 |
1 files changed, 0 insertions, 167 deletions
diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t deleted file mode 100755 index b04bdb7..0000000 --- a/contrib/perl5/t/op/tiehandle.t +++ /dev/null @@ -1,167 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my @expect; -my $data = ""; -my @data = (); -my $test = 1; - -sub ok { print "not " unless shift; print "ok ",$test++,"\n"; } - -package Implement; - -BEGIN { *ok = \*main::ok } - -sub compare { - return unless @expect; - return ok(0) unless(@_ == @expect); - - my $i; - for($i = 0 ; $i < @_ ; $i++) { - next if $_[$i] eq $expect[$i]; - return ok(0); - } - - ok(1); -} - -sub TIEHANDLE { - compare(TIEHANDLE => @_); - my ($class,@val) = @_; - return bless \@val,$class; -} - -sub PRINT { - compare(PRINT => @_); - 1; -} - -sub PRINTF { - compare(PRINTF => @_); - 2; -} - -sub READLINE { - compare(READLINE => @_); - wantarray ? @data : shift @data; -} - -sub GETC { - compare(GETC => @_); - substr($data,0,1); -} - -sub READ { - compare(READ => @_); - substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); - 3; -} - -sub WRITE { - compare(WRITE => @_); - $data = substr($_[1],$_[3] || 0, $_[2]); - length($data); -} - -sub CLOSE { - compare(CLOSE => @_); - - 5; -} - -package main; - -use Symbol; - -print "1..33\n"; - -my $fh = gensym; - -@expect = (TIEHANDLE => 'Implement'); -my $ob = tie *$fh,'Implement'; -ok(ref($ob) eq 'Implement'); -ok(tied(*$fh) == $ob); - -@expect = (PRINT => $ob,"some","text"); -$r = print $fh @expect[2,3]; -ok($r == 1); - -@expect = (PRINTF => $ob,"%s","text"); -$r = printf $fh @expect[2,3]; -ok($r == 2); - -$text = (@data = ("the line\n"))[0]; -@expect = (READLINE => $ob); -$ln = <$fh>; -ok($ln eq $text); - -@expect = (); -@in = @data = qw(a line at a time); -@line = <$fh>; -@expect = @in; -Implement::compare(@line); - -@expect = (GETC => $ob); -$data = "abc"; -$ch = getc $fh; -ok($ch eq "a"); - -$buf = "xyz"; -@expect = (READ => $ob, $buf, 3); -$data = "abc"; -$r = read $fh,$buf,3; -ok($r == 3); -ok($buf eq "abc"); - - -$buf = "xyzasd"; -@expect = (READ => $ob, $buf, 3,3); -$data = "abc"; -$r = sysread $fh,$buf,3,3; -ok($r == 3); -ok($buf eq "xyzabc"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4,1); -$data = ""; -$r = syswrite $fh,$buf,4,1; -ok($r == 4); -ok($data eq "wert"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4); -$data = ""; -$r = syswrite $fh,$buf,4; -ok($r == 4); -ok($data eq "qwer"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 6); -$data = ""; -$r = syswrite $fh,$buf; -ok($r == 6); -ok($data eq "qwerty"); - -@expect = (CLOSE => $ob); -$r = close $fh; -ok($r == 5); - -# Does aliasing work with tied FHs? -*ALIAS = *$fh; -@expect = (PRINT => $ob,"some","text"); -$r = print ALIAS @expect[2,3]; -ok($r == 1); - -{ - use warnings; - # Special case of aliasing STDERR, which used - # to dump core when warnings were enabled - *STDERR = *$fh; - @expect = (PRINT => $ob,"some","text"); - $r = print STDERR @expect[2,3]; - ok($r == 1); -} |