tiehandle.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
1008N/A#!./perl
1008N/A
1008N/ABEGIN {
1008N/A chdir 't' if -d 't';
1008N/A @INC = '../lib';
1008N/A}
1008N/A
1008N/Amy @expect;
1008N/Amy $data = "";
1008N/Amy @data = ();
1008N/Amy $test = 1;
1008N/A
1008N/Asub ok { print "not " unless shift; print "ok ",$test++,"\n"; }
1008N/A
1008N/Apackage Implement;
1008N/A
1008N/ABEGIN { *ok = \*main::ok }
1008N/A
1008N/Asub compare {
1008N/A return unless @expect;
1008N/A return ok(0) unless(@_ == @expect);
1008N/A
1008N/A my $i;
1008N/A for($i = 0 ; $i < @_ ; $i++) {
1008N/A next if $_[$i] eq $expect[$i];
1008N/A return ok(0);
1008N/A }
1008N/A
1008N/A ok(1);
1008N/A}
1008N/A
1008N/Asub TIEHANDLE {
1008N/A compare(TIEHANDLE => @_);
1008N/A my ($class,@val) = @_;
1008N/A return bless \@val,$class;
1008N/A}
1008N/A
1008N/Asub PRINT {
1008N/A compare(PRINT => @_);
1008N/A 1;
1008N/A}
1008N/A
1008N/Asub PRINTF {
1008N/A compare(PRINTF => @_);
1008N/A 2;
1008N/A}
1008N/A
1008N/Asub READLINE {
1008N/A compare(READLINE => @_);
1008N/A wantarray ? @data : shift @data;
1008N/A}
1008N/A
1008N/Asub GETC {
1008N/A compare(GETC => @_);
1008N/A substr($data,0,1);
1008N/A}
1008N/A
1008N/Asub READ {
1008N/A compare(READ => @_);
1008N/A substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
1008N/A 3;
1008N/A}
1008N/A
1008N/Asub WRITE {
1008N/A compare(WRITE => @_);
1008N/A $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);
}