File Coverage

blib/lib/Text/OutputFilter.pm

Criterion	Covered	Total	%
statement	85	87	97.7
branch	41	44	93.1
condition	10	12	83.3
subroutine	20	20	100.0
pod			n/a
total	156	163	95.7

package Text::OutputFilter;

use strict;
use warnings;

our $VERSION = "0.25";

=head1 NAME

OutputFilter - Enable post processing of output without fork

=head1 SYNOPSIS

 use Text::OutputFilter;

 my $bucket = "";
 tie *STDOUT, "Text::OutputFilter";
 tie *HANDLE, "Text::OutputFilter", 4;
 tie *HANDLE, "Text::OutputFilter", 4,  *STDOUT;
 tie *STDOUT, "Text::OutputFilter", 4, \$bucket;
 tie *OUTPUT, "Text::OutputFilter", 4,  *STDOUT, sub { "$_[0]" };

=head1 DESCRIPTION

This interface enables some post-processing on output streams,
like adding a left margin.

The tied filehandle is opened unbuffered, but the output is line
buffered. The C takes three optional arguments:

=over 4

=item Left Margin

The left margin must be a positive integer and defaults to C<4> spaces.

=item Output Stream

The output stream must be an already open stream, with writing
enabled. The default is C<*STDOUT>. All input methods on the new
stream are disabled. If a reference to a scalar is passed, it will
be opened as PerlIO::scalar - in-memory IO, scalar IO. No checks
performed to see if your perl supports it. If you want it, and your
perl does not, upgrade.

Using C on the new stream is allowed and supported.

OPEN, SEEK, and WRITE are not (yet) implemented.

=item Line Modifying Function

The output is line buffered, to enable line-modifier functions.
The line (without newline) is passed as the only argument to the
sub-ref, whose output is printed after the prefix from the first
argument. A newline is printed after the sub-ref's output.

To B a line, as in I it from the stream, make the
sub return I.

=back

=head1 TODO

Tests, tests, tests.
Tests with older perls

=head1 AUTHOR

H.Merijn Brand

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006-2023 H.Merijn Brand for PROCURA B.V.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

perl(1), perlopen(1), 'open STDOUT, "|-"', Text::Filter

=cut

use Carp;

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

    defined $lm  or $lm  = 4;
    defined $io  or $io  = *STDOUT;
    defined $ref or $ref = sub { shift };

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

    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");
*getc		= _outputOnly ("getc");
*GETC		= _outputOnly ("GETC");

sub _NYI {
    my $name = shift;
    sub { croak "Support for $name method NYI" };
    } # _NYI

*open		= _NYI ("open");
*OPEN		= _NYI ("OPEN");
*seek		= _NYI ("seek");
*SEEK		= _NYI ("SEEK");
*write		= _NYI ("write");
*WRITE		= _NYI ("WRITE");

=begin comment

We do not want to document these:

=over 4

=item getc

=item open

=item read

=item readline

=item seek

=item write

=back

=end comment

=cut

1;