X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Ftiehandle.t;h=735a25c07109701fba89b05d917a3d9190571b56;hb=1db36481d13cc744ff50a6e79d19885d5071f098;hp=cb9a290de653bd92a6cdf7c0ba4a861d0463611d;hpb=df646e84f898ad88193e38b6a680d118688bafa2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index cb9a290..735a25c 100755
--- a/t/op/tiehandle.t
+++ b/t/op/tiehandle.t
@@ -1,4 +1,4 @@
-#!./perl
+#!./perl -w
 
 BEGIN {
     chdir 't' if -d 't';
@@ -8,67 +8,67 @@ BEGIN {
 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 => 50);
 
 sub compare {
+    local $Level = $Level + 1;
+
     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;
 }
@@ -77,93 +77,117 @@ package main;
 
 use Symbol;
 
-print "1..35\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);
+}
+
+{
+    package Bar::Say;
+    use feature 'say';
+    use base qw(Implement);
+
+    my $ors;
+    sub PRINT     {
+        $ors = $\;
+        my $self = shift;
+        return $self->SUPER::PRINT(@_);
+    }
+
+    my $fh = Symbol::gensym;
+    @expect = (TIEHANDLE => 'Bar::Say');
+    ::ok( my $obj = tie *$fh, 'Bar::Say' );
+
+    local $\ = 'something';
+    @expect = (PRINT => $obj, "stuff", "and", "things");
+    ::ok( print $fh @expect[2..4] );
+    ::is( $ors, 'something' );
+    
+    ::ok( say $fh @expect[2..4] );
+    ::is( $ors, "\n",        'say sets $\ to \n in PRINT' );
+    ::is( $\,   "something", "  and it's localized" );
 }
 
 {
@@ -179,13 +203,73 @@ ok($r == 1);
     sub do_read {
 	my $fh = shift;
 	read $fh, my $buff, 1;
-	main::ok(1);
+	::pass();
     }
     $|=1;
     tie *STDIN, 'Foo';
     read STDIN, my $buff, 1;
-    main::ok(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" }
+}
+