develooper Front page | perl.perl5.porters | Postings from March 2007

tied filehandles do not honour write

Thread Next
From:
H.Merijn Brand
Date:
March 5, 2007 10:00
Subject:
tied filehandles do not honour write
Message ID:
20070305185957.700e780f@pc09
OK, I know, nobody uses format/write, but still there is a syncing
problem in using write to a tied file handle, as I discovered while
preparing my DPWS talk. Somewhat cut-down example below.

I get:
--8<---
PRINT OUT 1
FORMAT OUT 1
    PRINT OUT 2
FORMAT OUT 2
PRINT OUT 3
-->8---

I expect:
--8<---
PRINT OUT 1
FORMAT OUT 1
    PRINT OUT 2
    FORMAT OUT 2
PRINT OUT 3
-->8---

--8<--- stdouttie.pl (also attached)
#!/pro/bin/perl

package STDTIE;

use strict;
use Carp;

sub TIEHANDLE
{
    my ($class, $lm, $io, $fno) = @_;

    $lm  //= 4;
    $io  //= *STDOUT;

    ref $lm || $lm !~ m/^\d+$/	and
	croak "OutputFilter tie's 1st arg must be numeric";

    my $fh;
    if (ref $io eq "GLOB" and ref *{$io}{IO} eq "IO::Handle") {
	open $fh, ">&", *{$io}{IO};
	}
    elsif (ref $io eq "SCALAR") {
	open $fh, ">", $io;
	}
    else {
	$fno = fileno $io;
	defined $fno && $fno >= 0 or
	    croak "OutputFilter tie's 2nd arg must be the output handle\n";
	open $fh, ">&", $fno;
	}
    $fh or croak "OutputFilter cannot dup the output handle: $!";
    select ((select ($fh), $| = 1)[0]);

    bless {
        pfx	=> " " x $lm,
        io	=> $fh,
        line	=> "",
        closed	=> 0,
        }, $class;
    } # TIEHANDLE

sub PRINT
{
    my $self = shift;
    my ($pfx, $io) = @{$self}{qw( pfx io )};

    $self->{closed} and croak "Cannot print to closed filehandle";

    my $fsep = $, // "";
    my $line = $self->{line} . (join $fsep => @_) . ($\ // "");
    my @line = split m/\n/, $line, -1;
    $self->{line} = pop @line;
    print { $io } "$pfx$_\n" for @line;
    } # PRINT

sub CLOSE
{
    my $self = shift;
    my ($pfx, $io, $line) = @{$self}{qw( pfx io line )};
    if ($line ne "") {
	print { $io } "$pfx$_" for $line;
	}
    $self->{closed} or close   $io;
    $self->{line} = "";
    $self->{closed}++;
    } # CLOSE

sub UNTIE
{
    my $self = shift;
    $self->{closed} or $self->CLOSE;
    $self;
    } # UNTIE

sub DESTROY
{
    my $self = shift;
    $self->{closed} or $self->CLOSE;
    %$self = ();
    undef $self;
    } # DESTROY

1;

package main;

use strict;
use warnings;

sub wryte ($)
{
    local $~ = shift;
    write;
    } # wryte

format STDOUT1 =
FORMAT OUT 1
.

format STDOUT2 =
FORMAT OUT 2
.

$| = 1;

print "PRINT OUT 1\n";
wryte "STDOUT1";

tie *STDOUT, "STDTIE", 4;

print "PRINT OUT 2\n";
wryte "STDOUT2";

untie *STDOUT;

print "PRINT OUT 3\n";
-->8---

-- 
H.Merijn Brand         Amsterdam Perl Mongers (http://amsterdam.pm.org/)
using & porting perl 5.6.2, 5.8.x, 5.9.x   on HP-UX 10.20, 11.00, 11.11,
& 11.23, SuSE 10.0 & 10.2, AIX 4.3 & 5.2, and Cygwin. http://qa.perl.org
http://mirrors.develooper.com/hpux/            http://www.test-smoke.org
                        http://www.goldmark.org/jeff/stupid-disclaimers/

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About