File Coverage

blib/lib/Paranoid/IO/Line.pm

Criterion	Covered	Total	%
statement	203	216	93.9
branch	59	66	89.3
condition	18	22	81.8
subroutine	25	28	89.2
pod	8	8	100.0
total	313	340	92.0

# Paranoid::IO::Line -- Paranoid Line-based I/O functions
#
# $Id: lib/Paranoid/IO/Line.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::IO::Line;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Fcntl qw(:DEFAULT :seek :flock :mode);
use Paranoid qw(:all);
use Paranoid::Debug qw(:all);
use Paranoid::IO qw(:all);
use Paranoid::Input qw(:all);

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT      = qw(sip nlsip tailf nltailf slurp nlslurp piolClose);
@EXPORT_OK   = ( @EXPORT, qw(PIOMAXLNSIZE) );
%EXPORT_TAGS = ( all => [@EXPORT_OK], );

use constant STAT_INO => 1;
use constant STAT_SIZ => 7;
use constant PDEFLNSZ => 2048;

use constant PBFLAG => 0;
use constant PBBUFF => 1;

use constant PBF_DRAIN  => 0;
use constant PBF_NORMAL => 1;
use constant PBF_DELETE => -1;

#####################################################################
#
# Module code follows
#
#####################################################################

{
    my $mlnsz = PDEFLNSZ;

    sub PIOMAXLNSIZE : lvalue {

        # Purpose:  Gets/sets default line size of I/O
        # Returns:  $mlnsz
        # Usage:    $limit = PIOMAXLNSIZE;
        # Usage:    FSZLIMIT = 100;

        $mlnsz;
    }

    # Manage buffers: $buffers{$name} => [$flag, $content ];
    my %buffers;

    sub _chkBuffer { return exists $buffers{ $_[0] } }

    sub _chkStat {

        # Purpose:  Checks stat data to see if the underlying
        #           file has changed
        # Returns:  Boolean
        # Usage:    $rv = _chkStat($file);

        my $file = shift;
        my $rv   = 0;
        my ( $fh, $fpos, @fstat, @fhstat );

        subPreamble( PDLEVEL3, '$', $file );

        # Check to see if we can get a valid file handle
        if ( defined( $fh = popen( $file, O_RDONLY ) ) ) {
            @fhstat = stat $fh;
            $fpos   = ptell($fh);

            if ( @fhstat and $fpos < $fhstat[STAT_SIZ] ) {

                # Still have content to read, continue on
                pdebug( 'still have content to drain', PDLEVEL3 );
                $rv = 1;

            } else {

                # Check the file system to see if we're still
                # operating on the same file
                @fstat = stat $file;

                if ( scalar @fstat ) {

                    # Check inode
                    if ( $fhstat[STAT_INO] != $fstat[STAT_INO] ) {
                        pdebug( 'file was replaced with a new file',
                            PDLEVEL3 );
                    } else {
                        if ( $fstat[STAT_SIZ] < $fpos ) {
                            pdebug( 'file was truncated', PDLEVEL3 );
                        } else {
                            pdebug( 'file is unchanged', PDLEVEL3 );
                            $rv = 1;
                        }
                    }

                } else {
                    pdebug( 'file was deleted', PDLEVEL3 );
                }
            }
        } else {
            pdebug( 'invalid/non-existent file', PDLEVEL3 );
        }

        subPostamble( PDLEVEL3, '$', $rv );

        return $rv;
    }

    sub piolClose {

        # Purpose:  Closes file handles and deletes the associated
        #           buffer
        # Returns:  Boolean
        # Usage:    $rv = piolClose($file);

        my $file = shift;

        delete $buffers{$file};

        return pclose($file);
    }

    sub sip ($\@;$$) {

        # Purpose:  Reads a chunk from the passwed handle or file name
        # Returns:  Number of lines read or undef critical failures
        # Usage:    $nlines = sip($fh, @lines);
        # Usage:    $nlines = sip($filename, @lines);
        # Usage:    $nlines = sip($filename, @lines, 1);

        my $file    = shift;
        my $aref    = shift;
        my $doChomp = shift;
        my $noLocks = shift;
        my $rv      = 1;
        my ( $buffer, $bflag, $in, $content, $bread, $irv, @tmp, $line );

        subPreamble( PDLEVEL1, '$\@;$$', $file, $aref, $doChomp, $noLocks );

        @$aref = ();

        # Check the file
        piolClose($file) unless _chkStat($file);

        # Get/initialize buffer
        if ( exists $buffers{$file} ) {
            $bflag  = $buffers{$file}[PBFLAG];
            $buffer = $buffers{$file}[PBBUFF];
        } else {
            $buffers{$file} = [ PBF_NORMAL, '' ];
            $buffer         = '';
            $bflag          = PBF_NORMAL;
        }

        # Read what we can
        $content = '';
        $bread   = 0;
        while ( $bread < PIOMAXFSIZE ) {
            $irv = $noLocks ? pnlread( $file, $in ) : pread( $file, $in );
            if ( defined $irv ) {
                $bread += $irv;
                $content .= $in;
                last if $irv < PIOBLKSIZE;
            } else {
                $rv = undef;
                last;
            }
        }

        # Post processing
        if ($rv) {

            if ( length $content ) {

                # Add the buffer
                $content = "$buffer$content";

                # Process buffer drain conditions
                pdebug( 'starting buffer flag: (%s)', PDLEVEL4, $bflag );
                pdebug( 'starting buffer: (%s)',      PDLEVEL4, $buffer );
                if ( !$bflag and $content =~ /@{[NEWLINE_REGEX]}/so ) {
                    pdebug( 'draining to next newline', PDLEVEL4 );
                    $content =~ s/^.*?@{[NEWLINE_REGEX]}//so;
                    $bflag  = PBF_NORMAL;
                    $buffer = '';
                }

                # Check for newlines
                if ( $content =~ /@{[NEWLINE_REGEX]}/so ) {

                    # Split lines along newline boundaries
                    @tmp = split m/(@{[NEWLINE_REGEX]})/so, $content;
                    while ( scalar @tmp > 1 ) {
                        if ( length $tmp[0] > PIOMAXLNSIZE ) {
                            splice @tmp, 0, 2;
                            $line = undef;
                        } else {
                            $line = join '', splice @tmp, 0, 2;
                        }
                        push @$aref, $line;
                    }

                    # Check for undefined lines
                    $rv = scalar @$aref;
                    @$aref = grep {defined} @$aref;
                    if ( $rv != scalar @$aref ) {
                        Paranoid::ERROR =
                            pdebug( 'found %s lines over PIOMAXLNSIZE',
                            PDLEVEL1, $rv - @$aref );
                        $rv = undef;
                    }

                    # Check for an unterminated line at the end and
                    # buffer appropriately
                    if ( scalar @tmp ) {

                        # Content left over, update the buffer
                        if ( length $tmp[0] > PIOMAXLNSIZE ) {
                            $buffer = '';
                            $bflag  = PBF_DRAIN;
                            $rv     = undef;
                            Paranoid::ERROR =
                                pdebug( 'buffer is over PIOMAXLNSIZE',
                                PDLEVEL1 );
                        } else {
                            $buffer = $tmp[0];
                            $bflag  = PBF_NORMAL;
                        }
                    } else {

                        # Nothing left over, make sure the buffer is empty
                        $buffer = '';
                        $bflag  = PBF_NORMAL;
                    }

                } else {

                    # Check buffered block for PIOILNSIZE limit
                    if ( length $content > PIOMAXLNSIZE ) {
                        $buffer = '';
                        $bflag  = PBF_DRAIN;
                        $rv     = undef;
                        Paranoid::ERROR =
                            pdebug( 'block is over PIOMAXLNSIZE', PDLEVEL1 );
                    } else {
                        $rv     = 0;
                        $buffer = $content;
                        $bflag  = PBF_NORMAL;
                    }
                }
                pdebug( 'ending buffer flag: (%s)', PDLEVEL4, $bflag );
                pdebug( 'ending buffer: (%s)',      PDLEVEL4, $buffer );

            } else {
                $rv = 0;
            }
        }

        # Set PTRUE_ZERO if needed
        $rv = PTRUE_ZERO if defined $rv and $rv == 0;

        # Save the buffer
        $buffers{$file}[PBFLAG] = $bflag;
        $buffers{$file}[PBBUFF] = $buffer;

        # Chomp if necessary
        pchomp(@$aref) if $doChomp and scalar @$aref;

        pdebug( 'returning %s lines', PDLEVEL2, scalar @$aref );

        subPostamble( PDLEVEL1, '$', $rv );

        return $rv;
    }

}

sub nlsip {

    # Purpose:  Wrapper for sip that enables non-locking reads
    # Returns:  Return value from sip
    # Usage:    $nlines = nlsip($file, @lines);

    my $file    = shift;
    my $aref    = shift;
    my $doChomp = shift;

    return sip( $file, @$aref, $doChomp, 1 );
}

sub tailf ($\@;$$$) {

    # Purpose:  Augments sip's tailing abilities by seeking to
    #           the end (or, optionally, backwards)
    # Returns:  Number of lines tailed
    # Usage:    $nlines = tail($filename, @lines);
    # Usage:    $nlines = tail($filename, @lines, $chomp);
    # Usage:    $nlines = tail($filename, @lines, $lnOffset);

    my $file    = shift;
    my $aref    = shift;
    my $doChomp = shift || 0;
    my $offset  = shift || -10;
    my $noLocks = shift;
    my ( $rv, $ofsb, @lines );

    subPreamble( PDLEVEL1, '$\@;$$$', $file, $aref, $doChomp, $offset,
        $noLocks );

    @$aref = ();

    # Check to see if we've already opened this file
    if ( _chkBuffer($file) ) {

        # Offset is only used on the initial open
        $offset = 0;

    } else {

        # TODO: At some point we might want to honor positive offsets to mimic
        # the behavior of UNIX tail

        # Calculate how far back we need to go from the end
        $ofsb = $offset * ( PIOMAXLNSIZE +1 );
        Paranoid::ERROR =
            pdebug( 'WARNING:  called with a positive line offset', PDLEVEL1 )
            unless $ofsb < 0;

        # Open the file and move the cursor
        pseek( $file, $ofsb, SEEK_END ) if popen( $file, O_RDONLY );

    }

    # If $offset is set we have trailing lines to handle
    if ($offset) {

        # Consume everything to the end of the file
        do {
            $noLocks
                ? nlsip( $file, @lines, $doChomp )
                : sip( $file, @lines, $doChomp );
            push @$aref, @lines;
        } while scalar @lines;

        # Trim list to the request size
        if ( scalar @$aref > abs $offset ) {
            splice @$aref, 0, @$aref - abs $offset;
        }
        $rv = scalar @$aref;
        $rv = PTRUE_ZERO unless $rv;

    } else {

        # Do a single sip
        $rv =
            $noLocks
            ? nlsip( $file, @$aref, $doChomp )
            : sip( $file, @$aref, $doChomp );
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub nltailf ($\@;$$$) {

    # Purpose:  Wrapper for sip that enables non-locking reads
    # Returns:  Return value from sip
    # Usage:    $nlines = nlsip($file, @lines);

    my $file    = shift;
    my $aref    = shift;
    my $doChomp = shift;
    my $offset  = shift;

    return tailf( $file, @$aref, $doChomp, $offset, 1 );
}

sub slurp ($\@;$$) {

    # Purpose:  Reads a file into memory
    # Returns:  Number of lines read/undef
    # Usage:    $nlines = slurp($filename, @lines;
    # Usage:    $nlines = slurp($filename, @lines, 1);

    my $file    = shift;
    my $aref    = shift;
    my $doChomp = shift || 0;
    my $noLocks = shift;
    my $rv      = 1;
    my @fstat;

    subPreamble( PDLEVEL1, '$\@;$$', $file, $aref, $doChomp, $noLocks );

    # Start sipping
    $rv = sip( $file, @$aref, $doChomp, $noLocks );
    if ( ref $file eq 'GLOB' ) {
        @fstat = stat $file if fileno $file;
    } else {
        @fstat = stat $file;
    }
    if ( scalar @fstat and $fstat[STAT_SIZ] > PIOMAXFSIZE ) {
        Paranoid::ERROR = pdebug( 'file size exceeds PIOMAXFSIZE', PDLEVEL1 );
        $rv = undef;
    }

    # Count lins if sip never complained
    $rv = scalar @$aref if defined $rv;

    # Close everything out
    piolClose($file);

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub nlslurp ($\@;$$) {

    # Purpose:  Performs a non-locking slurp
    # Returns:  Number of lines/undef
    # Usage:    $nlines = nlslurp($filename, @lines);
    # Usage:    $nlines = nlslurp($filename, @lines, 1);

    my $file    = shift;
    my $aref    = shift;
    my $doChomp = shift || 0;

    return slurp( $file, @$aref, $doChomp, 1 );
}

1;

__END__