File Coverage

blib/lib/Paranoid/IO/FileMultiplexer/Block/StreamHeader.pm

Criterion	Covered	Total	%
statement	169	209	80.8
branch	25	50	50.0
condition	10	18	55.5
subroutine	30	32	93.7
pod	14	14	100.0
total	248	323	76.7

# Paranoid::IO::FileMultiplexer::Block::StreamHeader -- Stream Header Block
#
# $Id: lib/Paranoid/IO/FileMultiplexer/Block/StreamHeader.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 - 2021, Arthur Corliss ([e-mail])
# (tm) 2008 - 2021, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

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

package Paranoid::IO::FileMultiplexer::Block::StreamHeader;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION);
use base qw(Exporter);
use Paranoid qw(:all);
use Paranoid::IO qw(:all);
use Paranoid::Debug qw(:all);
use Paranoid::Data;
use Fcntl qw(:DEFAULT :flock :mode :seek);

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

use base qw(Paranoid::IO::FileMultiplexer::Block);

# Signature format:
#   PIOFMSTRM Name EOS
#   Z10       Z21  NNx
#     40 bytes
#
# BAT record format:
#   BlockNum
#   NN
#     8 bytes
use constant SIGNATURE => 'Z10Z21NNx';
use constant SIG_LEN   => 40;
use constant SIG_TYPE  => 'PIOFMSTRM';
use constant EOS_POS   => 31;
use constant BATS_POS  => 40;
use constant BATIDX    => 'NN';
use constant BAT_LEN   => 8;

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

sub new {

  # Purpose:  Creates a new stream header object
  # Returns:  Object reference/undef
  # Usage:    $obj =
  #             Paranoid::IO::FileMultiplexer::Block::StreamHeader->new($file,
  #             $blockNo, $blockSize, $strmName);

    my $class = shift;
    my $file  = shift;
    my $bnum  = shift;
    my $bsize = shift;
    my $sname = shift;
    my $self;

    subPreamble( PDLEVEL3, '$$$$', $file, $bnum, $bsize, $sname );

    if ( defined $sname and length $sname and length $sname <= 20 ) {
        $self = __PACKAGE__->SUPER::new( $file, $bnum, $bsize );
    } else {
        pdebug( 'invalid stream name (%s)', PDLEVEL1, $sname );
    }

    if ( defined $self ) {
        $$self{streamName} = $sname;
        $$self{bats}       = [];       # array of blockNum
        $$self{eos}        = 0;        # address of stream EOF
        $$self{maxBATs} = int( ( $$self{blockSize} - SIG_LEN ) / BAT_LEN );
    }

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

    return $self;
}

sub streamName {

    # Purpose:  Returns the current stream name
    # Returns:  String
    # Usage:    $name = $obj->streamName;

    my $self = shift;

    return $$self{streamName};
}

sub maxBATs {

    # Purpose:  Returns the max BAT blocks for the stream
    # Returns:  Integer
    # Usage:    $max = $obj->maxBATs;

    my $self = shift;

    return $$self{maxBATs};
}

sub eos {

    # Purpose:  Returns the current stream EOS
    # Returns:  Integer
    # Usage:    $eos = $obj->eos;

    my $self = shift;

    return $$self{eos};
}

sub bats {

    # Purpose:  Returns an array of bat nums
    # Returns:  Hash
    # Usage:    @bats = $obj->bats;

    my $self = shift;

    return @{ $$self{bats} };
}

sub full {

    # Purpose:  Returns whether the streams's array of BAT blocks is full
    # Returns:  Boolean
    # Usage:    $rv = $obj->full;

    my $self = shift;

    return $self->maxBATs == scalar $self->bats;
}

sub writeSig {

    # Purpose:  Writes the stream signature to the file
    # Returns:  Boolean
    # Usage:    $rv = $obj->writeSig;

    my $self  = shift;
    my $file  = $$self{file};
    my $sname = $$self{streamName};
    my $eos   = $$self{eos};
    my $rv    = 0;
    my $sig   = pack SIGNATURE, SIG_TYPE, $sname, quad2Longs($eos);

    subPreamble(PDLEVEL3);

    $rv = $self->bwrite($sig);

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

    return $rv;
}

sub readSig {

    # Purpose:  Reads the block signature from the file
    # Returns:  Boolean
    # Usage:    $rv = $obj->readSig;

    my $self = shift;
    my $file = $$self{file};
    my $rv   = 0;
    my ( $raw, $type, $sname, $eos, $leos, $ueos );

    subPreamble(PDLEVEL3);

    if ( pflock( $file, LOCK_SH ) ) {
        if ( $self->bread( \$raw, 0, SIG_LEN ) == SIG_LEN ) {
            $rv = 1;

            # Unpack the signature
            ( $type, $sname, $leos, $ueos ) = unpack SIGNATURE, $raw;

            # Validate contents
            #
            # Start with file type
            unless ( $type eq SIG_TYPE ) {
                $rv = 0;
                pdebug( 'Invalid stream header type (%s)', PDLEVEL1, $type );
            }

            # stream name
            unless ( $sname eq $$self{streamName} ) {
                $rv = 0;
                pdebug( 'Invalid stream name (%s)', PDLEVEL1, $sname );
            }

            # Make sure eos is legitimate
            $eos = longs2Quad( $leos, $ueos );
            unless ( defined $eos ) {
                pdebug( 'this platform does not support 64b values for eos',
                    PDLEVEL1 );
                $rv = 0;
            }

            # Update internal values
            if ($rv) {
                $$self{eos} = $eos;
            } else {
                pdebug( 'stream signature verification failure', PDLEVEL1 );
            }

        } else {
            pdebug( 'failed to read stream header signature', PDLEVEL1 );
        }

        pflock( $file, LOCK_UN );
    }

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

    return $rv;
}

sub writeEOS {

    # Purpose:  Updates the EOS counter and writes it to disk
    # Returns:  Boolean
    # Usage:    $rv = $obj->writeEOS($pos);

    my $self = shift;
    my $eos  = shift;
    my ( $raw, $rv );

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

    if ( defined $eos ) {
        $raw = pack 'NN', quad2Longs($eos);
        if ( $self->bwrite( $raw, EOS_POS ) == 8 ) {
            $$self{eos} = $eos;
            $rv = 1;
        }
    } else {
        pdebug( 'invalid value for eos (%s)', PDLEVEL1, $eos );
    }

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

    return $rv;
}

sub readEOS {

    # Purpose:  Reads the EOS counter from disk
    # Returns:  Integer/undef on error
    # Usage:    $pos = $obj->readEOS;

    my $self = shift;
    my ( $rv, $raw );

    subPreamble(PDLEVEL3);

    if ( $self->bread( \$raw, EOS_POS, 8 ) == 8 ) {
        $rv = longs2Quad( unpack 'NN', $raw );
        $rv = PTRUE_ZERO if defined $rv and $rv == 0;
    }

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

    return $rv;
}

sub validateEOS {

    # Purpose:  Compares in-memory EOS counter to what's stored in the file
    # Returns:  Boolean
    # Usage:    $rv = $obj->validateBlocks;

    my $self = shift;
    my $rv   = 0;

    subPreamble(PDLEVEL3);

    $rv = 1 if $$self{eos} == $self->readEOS;

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

    return $rv;
}

sub writeBATs {

    # Purpose:  Writes all the BAT block numbers to the file
    # Returns:  Boolean
    # Usage:    $rv = $obj->writeBATs;

    my $self = shift;
    my $file = $$self{file};
    my $rv   = 0;
    my ( $rec, $i, $pos );

    subPreamble(PDLEVEL3);

    # Hold an exclusive lock for the entire transaction
    if ( pflock( $file, LOCK_EX ) ) {

        $rv = 1;
        $i  = 0;
        foreach $rec ( @{ $$self{bats} } ) {
            $pos = BATS_POS + $i * BAT_LEN;
            $rv  = 0
                unless $self->bwrite( pack( BATIDX, quad2Longs($rec) ), $pos )
                    == BAT_LEN;
            $i++;
            last unless $rv;
        }

        pflock( $file, LOCK_UN );
    }

    pdebug( 'failed to write all BAT block numbers to the stream header',
        PDLEVEL1 )
        unless $rv;

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

    return $rv;
}

sub readBATs {

    # Purpose:  Reads the BAT records from the stream header
    # Returns:  Boolean
    # Usage:    $rv = $obj->readBATs;

    my $self = shift;
    my $rv   = 1;
    my ( $raw, @sraw, $bn, $lbn, $ubn, $prev );
    my @bats;

    subPreamble(PDLEVEL3);

    # Read the BATs section of the block
    if ( $self->bread( \$raw, BATS_POS ) ) {

        @sraw = unpack '(' . BATIDX . ")$$self{maxBATs}", $raw;
        while (@sraw) {

            $lbn = shift @sraw;
            $ubn = shift @sraw;
            $bn  = longs2Quad( $lbn, $ubn );

            # Stop processing when it looks like we're not getting legitmate
            # values
            last unless defined $bn and $bn > $$self{blockNum};

            # Error out if block numbers aren't ascending
            unless ( !defined $prev or $bn > $prev ) {
                pdebug( 'BAT block number appearing out of sequence',
                    PDLEVEL1 );
                $rv = 0;
                last;
            }

            # Save entry
            push @bats, $bn;
            $prev = $bn;
        }

        # Save everything extracted
        $$self{bats} = [@bats];
        pdebug( 'found %s bats', PDLEVEL4, scalar @bats );

    } else {
        pdebug( 'failed to read list of BATs from stream header', PDLEVEL1 );
        $rv = 0;
    }

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

    return $rv;
}

sub addBAT {

    # Purpose:  Adds a BAT block number to the stream header
    # Returns:  Boolean
    # Usage:    $rv = $obj->addBAT($bn);

    my $self = shift;
    my $bn   = shift;
    my $rv   = 1;

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

    if ( defined $bn and $bn > $$self{blockNum} ) {

        # Make sure we're not adding redundant entries
        if ( scalar grep { $_ eq $bn } @{ $$self{bats} } ) {
            $rv = 0;
            pdebug( 'redundant entry for an existing BAT', PDLEVEL1 );
        }

        # Make sure new BAT is a higher block number than all previous BATs
        if ( scalar grep { $_ > $bn } @{ $$self{bats} } ) {
            $rv = 0;
            pdebug( 'BAT block number is lower than previous BATs',
                PDLEVEL1 );
        }

        if ($rv) {
            push @{ $$self{bats} }, $bn;
            $rv = 0
                unless $self->bwrite(
                pack( BATIDX, quad2Longs($bn) ),
                BATS_POS + BAT_LEN * $#{ $$self{bats} } ) == BAT_LEN;
        }

    } else {
        pdebug( 'invalid BAT block number (%s)', PDLEVEL1, $bn );
        $rv = 0;
    }

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

    return $rv;
}

1;

__END__