File Coverage

blib/lib/Tie/Handle/Filter.pm

Criterion	Covered	Total	%
statement	47	48	97.9
branch	11	18	61.1
condition	4	9	44.4
subroutine	19	19	100.0
pod			n/a
total	81	94	86.1

package Tie::Handle::Filter;

# ABSTRACT: filters the output to a filehandle through a coderef

#pod =head1 SYNOPSIS
#pod
#pod     use Tie::Handle::Filter;
#pod
#pod     # prefix output to STDERR with standard Greenwich time
#pod     BEGIN {
#pod         tie *STDERR, 'Tie::Handle::Filter', *STDERR,
#pod             sub { scalar(gmtime) . ': ', @_ };
#pod     }
#pod
#pod =head1 DESCRIPTION
#pod
#pod This is a small module for changing output when it is sent to a given
#pod file handle. By default it passes everything unchanged, but when
#pod provided a code reference, that reference is passed the string being
#pod sent to the tied file handle and may return a transformed result.
#pod
#pod =head1 OTHER INCLUDED MODULES
#pod
#pod =over
#pod
#pod =item L
#pod
#pod Prepends filehandle output with a timestamp, optionally formatted via
#pod L|POSIX/strftime>.
#pod
#pod =item L
#pod
#pod Prepends every line of filehandle output with a timestamp, optionally
#pod formatted via L|POSIX/strftime>.
#pod
#pod =back
#pod
#pod =cut

use 5.008;
use strict;
use warnings;
use base 'Tie::Handle';
use Carp;
use English '-no_match_vars';
use FileHandle::Fmode ':all';
our $VERSION = '0.010';    # TRIAL

#pod =head1 DIAGNOSTICS
#pod
#pod Wherever possible this module attempts to emulate the built-in functions
#pod it ties, so it will return values as expected from whatever function is
#pod called. Certain operations may also L|Carp> (throw a fatal
#pod exception) if they fail, such as aliasing the file handle during a
#pod L|perlfunc/tie> or attempting to perform an
#pod L on a tied file handle.
#pod
#pod =cut

sub TIEHANDLE {
    my ( $class, $handle_glob, $writer_ref ) = @_;

    ## no critic (InputOutput::RequireBriefOpen)
    open my $fh, _get_filehandle_open_mode($handle_glob) . q(&=), $handle_glob
        or croak $OS_ERROR;

    return bless {
        filehandle => $fh,
        writer     => (
            ( defined $writer_ref and 'CODE' eq ref $writer_ref )
            ? $writer_ref
            : sub { return @_ }
        ),
    }, $class;
}

sub _get_filehandle_open_mode {
    my $fh = shift;
    for ($fh) {
        return '>>'  if is_WO($_) and is_A($_);
        return '>'   if is_WO($_);
        return '<'   if is_RO($_);
        return '+>>' if is_RW($_) and is_A($_);
        return '+<'  if is_RW($_);
    }
    return '+>';
}

## no critic (Subroutines::RequireArgUnpacking)
## no critic (Subroutines::RequireFinalReturn)

#pod =method PRINT
#pod
#pod All arguments to L|perlfunc/print> and L|perlfunc/say>
#pod directed at the tied file handle are passed to the user-defined
#pod function, and the result is then passed to L|perlfunc/print>.
#pod
#pod =cut

sub PRINT {
    my $self = shift;
    ## no critic (InputOutput::RequireCheckedSyscalls)
    print { $self->{filehandle} } $self->{writer}->(@_);
}

#pod =method PRINTF
#pod
#pod The second and subsequent arguments to L|perlfunc/printf>
#pod (i.e., everything but the format string) directed at the tied file
#pod handle are passed to the user-defined function, and the result is then
#pod passed preceded by the format string to L|perlfunc/printf>.
#pod
#pod Please note that this does not include calls to
#pod L|perlfunc/sprintf>.
#pod
#pod =cut

sub PRINTF {
    my ( $self, $format ) = splice @_, 0, 2;
    printf { $self->{filehandle} } $format, $self->{writer}->(@_);
}

#pod =method WRITE
#pod
#pod The first argument to L|perlfunc/syswrite> (i.e., the buffer
#pod scalar variable) directed at the tied file handle is passed to the
#pod user-defined function, and the result is then passed along with the
#pod optional second and third arguments (i.e., length of data in bytes and
#pod offset within the string) to L|perlfunc/syswrite>.
#pod
#pod Note that if you do not provide a length argument to
#pod L|perlfunc/syswrite>, it will be computed from the result of
#pod the user-defined function. However, if you do provide a length (and
#pod possibly offset), they will be relative to the results of the
#pod user-defined function, not the input.
#pod
#pod =cut

sub WRITE {
    my ( $self, $original ) = splice @_, 0, 2;
    my $buffer = ( $self->{writer}->($original) )[0];
    syswrite $self->{filehandle}, $buffer,
        ( defined $_[0] ? $_[0] : length $buffer ),
        ( defined $_[1] ? $_[1] : 0 );
}

sub CLOSE {
    my $self = shift;
    ## no critic (InputOutput::RequireCheckedSyscalls)
    ## no critic (InputOutput::RequireCheckedClose)
    close $self->{filehandle};
}

#pod =head1 BUGS AND LIMITATIONS
#pod
#pod If your function needs to know what operation was used to call it,
#pod consider using C<(caller 1)[3]> to determine the method used to call
#pod it, which will return C,
#pod C, or C per
#pod L.
#pod
#pod Currently this module is biased towards write-only file handles, such as
#pod C, C, or ones used for logging. It does not (yet) define
#pod the following methods and their associated functions, so don't do them
#pod with file handles tied to this class.
#pod
#pod =head2 READ
#pod
#pod =over
#pod
#pod =item L|perlfunc/read>
#pod
#pod =item L|perlfunc/sysread>
#pod
#pod =back
#pod
#pod =head2 READLINE
#pod
#pod =over
#pod
#pod =item LHANDLEE>|perlop/"I/O Operators">
#pod
#pod =item L|perlfunc/readline>
#pod
#pod =back
#pod
#pod =head2 GETC
#pod
#pod =over
#pod
#pod =item L|perlfunc/getc>
#pod
#pod =back
#pod
#pod =head2 OPEN
#pod
#pod =over
#pod
#pod =item L|perlfunc/open> (e.g., re-opening the file handle)
#pod
#pod =back
#pod
#pod =head2 BINMODE
#pod
#pod =over
#pod
#pod =item L|perlfunc/binmode>
#pod
#pod =back
#pod
#pod =head2 EOF
#pod
#pod =over
#pod
#pod =item L|perlfunc/eof>
#pod
#pod =back
#pod
#pod =head2 TELL
#pod
#pod =over
#pod
#pod =item L|perlfunc/tell>
#pod
#pod =back
#pod
#pod =head2 SEEK
#pod
#pod =over
#pod
#pod =item L|perlfunc/seek>
#pod
#pod =back
#pod
#pod =cut

my $unimplemented_ref = sub {
## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
    my $package = ( caller 0 )[0];
    my $method  = ( caller 1 )[3];
    $method =~ s/\A ${package} :: //xms;
    croak "$package doesn't define a $method method";
};

sub OPEN    { $unimplemented_ref->() }
sub BINMODE { $unimplemented_ref->() }
sub EOF     { $unimplemented_ref->() }
sub TELL    { $unimplemented_ref->() }
sub SEEK    { $unimplemented_ref->() }

1;

__END__