view release on metacpan or  search on metacpan

OutputFilter.pm  view on Meta::CPAN

    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 {
	eval { $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,
        sb	=> $ref,
        io	=> $fh,

        line	=> "",

        closed	=> 0,
        }, $class;
    } # TIEHANDLE

sub BINMODE {
    my $self = shift;
    $self->{closed} and croak "Cannot set binmode on closed filehandle";
    if (@_) {
	my $mode = shift;
	binmode $self->{io}, $mode;
	}
    else {
	binmode $self->{io};
	}
    } # BINMODE

sub FILENO {
    my $self = shift;
    fileno $self->{io};
    } # FILENO

sub _Filter_ {
    my ($nl, $pfx, $sub, $line) = @_;
    my $l = $sub->($line);
    defined $l ? $pfx . $l . ($nl ? "\n" : "") : "";
    } # _Filter_

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

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

    my $fsep = defined $, ? $, : "";
    my $rsep = defined $\ ? $\ : "";
    my $line = $self->{line} . (join $fsep => @_) . $rsep;
    my @line = split m/\n/, $line, -1;
    $self->{line} = pop @line;
    print { $io } map { _Filter_ (1, $pfx, $sub, $_) } @line;
    } # PRINT

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

    # Do not delegate this to PRINT, so we can prevent sprintf side effects
    $self->{closed} and croak "Cannot print to closed filehandle";

    my $fmt = shift;
    $self->PRINT (sprintf $fmt, @_);
    } # PRINTF

sub TELL {
    my $self = shift;
    $self->{closed} and croak "Cannot tell from a closed filehandle";
    tell $self->{io};
    } # TELL

sub EOF {
    my $self = shift;
    $self->{closed};
    } # EOF

sub CLOSE {
    my $self = shift;
    my ($pfx, $io, $sub, $line) = @{$self}{qw( pfx io sb line )};
    defined $line && $line ne "" and
	print { $io } _Filter_ (0, $pfx, $sub, $line);
    $self->{closed} or close $io;
    $self->{line} = "";
    $self->{closed} = 1;
    } # 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

### ###########################################################################

sub _outputOnly {
    my $name = shift;
    sub { croak "No support for $name method: File is output only" };
    } # _outputOnly

*read		= _outputOnly ("read");
*READ		= _outputOnly ("READ");
*readline	= _outputOnly ("readline");
*READLINE	= _outputOnly ("READLINE");