view release on metacpan or  search on metacpan

lib/Paranoid/IO/Line.pm  view on Meta::CPAN

        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 );