This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Win32 the cmd.exe console output doesn't seem to
authorJarkko Hietaniemi <jhi@iki.fi>
Mon, 8 Sep 2003 09:10:47 +0000 (09:10 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Mon, 8 Sep 2003 09:10:47 +0000 (09:10 +0000)
be catchable using the in-memory I/O + select trick,
so use tie-STDOUT trick instead.

p4raw-id: //depot/perl@21078

lib/perl5db/dumpvar.t

index b60afa6..dff7bb2 100644 (file)
@@ -3,10 +3,6 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    unless (find PerlIO::Layer 'perlio') { # PerlIO::scalar
-       print "1..0 # Skip: not perlio\n";
-       exit 0;
-    }
 }
 
 use strict;
 }
 
 use strict;
@@ -50,23 +46,37 @@ for (@prgs) {
     # TODO: dumpvar::stringify() is controlled by a pile of package
     # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify,
     # and so forth.  We need to test with various settings of those.
     # TODO: dumpvar::stringify() is controlled by a pile of package
     # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify,
     # and so forth.  We need to test with various settings of those.
-    open my $select, ">", \my $got or die;
-    select $select;
+    my $out = tie *STDOUT, 'TieOut';
     eval $prog;
     my $ERR = $@;
     eval $prog;
     my $ERR = $@;
-    close $select;
-    select STDOUT;
+    untie $out;
     if ($ERR) {
         ok(0, "$prog - $ERR");
     } else {
        if ($expected =~ m:^/:) {
     if ($ERR) {
         ok(0, "$prog - $ERR");
     } else {
        if ($expected =~ m:^/:) {
-           like($got, $expected, $prog);
+           like($$out, $expected, $prog);
        } else {
        } else {
-           is($got, $expected, $prog);
+           is($$out, $expected, $prog);
        }
     }
 }
 
        }
     }
 }
 
+package TieOut;
+
+sub TIEHANDLE {
+    bless( \(my $self), $_[0] );
+}
+
+sub PRINT {
+    my $self = shift;
+    $$self .= join('', @_);
+}
+
+sub read {
+    my $self = shift;
+    substr( $$self, 0, length($$self), '' );
+}
+
 __END__
 unctrl("A");
 EXPECT
 __END__
 unctrl("A");
 EXPECT