seen_eval regex field wasn't getting cloned

[p5sagit/p5-mst-13.2.git] / t / op / tiehandle.t

diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index d7e6a78..735a25c 100755 (executable)
--- 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,75 +77,199 @@ package main;
 
 use Symbol;
 
-print "1..29\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];
+is($r, 1);
+
+{
+    use warnings;
+    # Special case of aliasing STDERR, which used
+    # to dump core when warnings were enabled
+    local *STDERR = *$fh;
+    @expect = (PRINT => $ob,"some","text");
+    $r = print STDERR @expect[2,3];
+    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" );
+}
+
+{
+    # 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" }
+}
+