-#!./perl
+#!./perl -w
BEGIN {
chdir 't' if -d 't';
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 }
+require './test.pl';
+plan(tests => 41);
sub compare {
return unless @expect;
- return ok(0) unless(@_ == @expect);
+ return ::fail() unless(@_ == @expect);
- my $i;
- for($i = 0 ; $i < @_ ; $i++) {
+ for my $i (0..$#_) {
next if $_[$i] eq $expect[$i];
- return ok(0);
+ return ::fail();
}
- ok(1);
+ ::pass();
}
+
+package Implement;
+
sub TIEHANDLE {
- compare(TIEHANDLE => @_);
+ ::compare(TIEHANDLE => @_);
my ($class,@val) = @_;
return bless \@val,$class;
}
sub PRINT {
- compare(PRINT => @_);
+ ::compare(PRINT => @_);
1;
}
sub PRINTF {
- compare(PRINTF => @_);
+ ::compare(PRINTF => @_);
2;
}
sub READLINE {
- compare(READLINE => @_);
+ ::compare(READLINE => @_);
wantarray ? @data : shift @data;
}
sub GETC {
- compare(GETC => @_);
+ ::compare(GETC => @_);
substr($data,0,1);
}
sub READ {
- compare(READ => @_);
+ ::compare(READ => @_);
substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
3;
}
sub WRITE {
- compare(WRITE => @_);
+ ::compare(WRITE => @_);
$data = substr($_[1],$_[3] || 0, $_[2]);
length($data);
}
sub CLOSE {
- compare(CLOSE => @_);
+ ::compare(CLOSE => @_);
5;
}
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);
+is(ref($ob), 'Implement');
+is(tied(*$fh), $ob);
@expect = (PRINT => $ob,"some","text");
$r = print $fh @expect[2,3];
-ok($r == 1);
+is($r, 1);
@expect = (PRINTF => $ob,"%s","text");
$r = printf $fh @expect[2,3];
-ok($r == 2);
+is($r, 2);
$text = (@data = ("the line\n"))[0];
@expect = (READLINE => $ob);
$ln = <$fh>;
-ok($ln eq $text);
+is($ln, $text);
@expect = ();
@in = @data = qw(a line at a time);
@line = <$fh>;
@expect = @in;
-Implement::compare(@line);
+compare(@line);
@expect = (GETC => $ob);
$data = "abc";
$ch = getc $fh;
-ok($ch eq "a");
+is($ch, "a");
$buf = "xyz";
@expect = (READ => $ob, $buf, 3);
$data = "abc";
$r = read $fh,$buf,3;
-ok($r == 3);
-ok($buf eq "abc");
+is($r, 3);
+is($buf, "abc");
$buf = "xyzasd";
@expect = (READ => $ob, $buf, 3,3);
$data = "abc";
$r = sysread $fh,$buf,3,3;
-ok($r == 3);
-ok($buf eq "xyzabc");
+is($r, 3);
+is($buf, "xyzabc");
$buf = "qwerty";
@expect = (WRITE => $ob, $buf, 4,1);
$data = "";
$r = syswrite $fh,$buf,4,1;
-ok($r == 4);
-ok($data eq "wert");
+is($r, 4);
+is($data, "wert");
$buf = "qwerty";
@expect = (WRITE => $ob, $buf, 4);
$data = "";
$r = syswrite $fh,$buf,4;
-ok($r == 4);
-ok($data eq "qwer");
+is($r, 4);
+is($data, "qwer");
$buf = "qwerty";
@expect = (WRITE => $ob, $buf, 6);
$data = "";
$r = syswrite $fh,$buf;
-ok($r == 6);
-ok($data eq "qwerty");
+is($r, 6);
+is($data, "qwerty");
@expect = (CLOSE => $ob);
$r = close $fh;
-ok($r == 5);
+is($r, 5);
# Does aliasing work with tied FHs?
*ALIAS = *$fh;
@expect = (PRINT => $ob,"some","text");
$r = print ALIAS @expect[2,3];
-ok($r == 1);
+is($r, 1);
{
use warnings;
# Special case of aliasing STDERR, which used
# to dump core when warnings were enabled
- *STDERR = *$fh;
+ local *STDERR = *$fh;
@expect = (PRINT => $ob,"some","text");
$r = print STDERR @expect[2,3];
- ok($r == 1);
+ is($r, 1);
}
+
+{
+ # Test for change #11536
+ package Foo;
+ use strict;
+ sub TIEHANDLE { bless {} }
+ my $cnt = 'a';
+ sub READ {
+ $_[1] = $cnt++;
+ 1;
+ }
+ sub do_read {
+ my $fh = shift;
+ read $fh, my $buff, 1;
+ ::pass();
+ }
+ $|=1;
+ tie *STDIN, 'Foo';
+ read STDIN, my $buff, 1;
+ ::pass();
+ do_read(\*STDIN);
+ untie *STDIN;
+}
+
+
+{
+ # test for change 11639: Can't localize *FH, then tie it
+ {
+ local *foo;
+ tie %foo, 'Blah';
+ }
+ ok(!tied %foo);
+
+ {
+ local *bar;
+ tie @bar, 'Blah';
+ }
+ ok(!tied @bar);
+
+ {
+ local *BAZ;
+ tie *BAZ, 'Blah';
+ }
+ ok(!tied *BAZ);
+
+ package Blah;
+
+ sub TIEHANDLE {bless {}}
+ sub TIEHASH {bless {}}
+ sub TIEARRAY {bless {}}
+}
+
+{
+ # warnings should pass to the PRINT method of tied STDERR
+ my @received;
+
+ local *STDERR = *$fh;
+ no warnings 'redefine';
+ local *Implement::PRINT = sub { @received = @_ };
+
+ $r = warn("some", "text", "\n");
+ @expect = (PRINT => $ob,"sometext\n");
+
+ compare(PRINT => @received);
+
+ use warnings;
+ print undef;
+
+ like($received[1], qr/Use of uninitialized value/);
+}
+
+{
+ # [ID 20020713.001] chomp($data=<tied_fh>)
+ local *TEST;
+ tie *TEST, 'CHOMP';
+ my $data;
+ chomp($data = <TEST>);
+ is($data, 'foobar');
+
+ package CHOMP;
+ sub TIEHANDLE { bless {}, $_[0] }
+ sub READLINE { "foobar\n" }
+}
+
+