File Coverage

lib/Tie/File/FixedRecLen.pm

Criterion	Covered	Total	%
statement	103	109	94.5
branch	41	58	70.6
condition	2	6	33.3
subroutine	15	16	93.7
pod			n/a
total	161	189	85.1

package Tie::File::FixedRecLen;
{
  $Tie::File::FixedRecLen::VERSION = '2.112531';
}

use strict;
use warnings FATAL => 'all';

use 5.008;

use base 'Tie::File';
# v.0.97 says: "This version promises absolutely nothing about the internals,
# which may change without notice. A future version of the module will have a
# well-defined and stable subclassing API."

my $DEBUG = $ENV{FIXEDRECLEN_DEBUG} || 0;
my @good_opts = qw(record_length pad_dir pad_char);

# ===========================================================================

sub TIEARRAY {
    my ($class, $file, %opts) = @_;
    my %tmp_opts = (); # ugh, Tie::File is broken for subclassing

    for (@good_opts) {
        $tmp_opts{$_} = delete $opts{$_} if exists $opts{$_};
    }
    my $self = $class->SUPER::TIEARRAY(
        $file, %opts, autodefer => 0, memory => 0,
    );
    for (keys %tmp_opts) {
        $self->{$_} = $tmp_opts{$_};
    }

    die "Useless use of Tie::File::FixedRecLen without a record_length\n"
        if !exists $self->{record_length}
            or !defined $self->{record_length}
            or $self->{record_length} !~ m/^\d+$/
            or $self->{record_length} == 0;

    $self->{pad_dir}  = 'left' if !defined $self->{pad_dir};
    $self->{pad_char} = ' '    if !defined $self->{pad_char};
    return $self;
}

# ===========================================================================
# utility methods

sub _add_padding {
    my ($self, $rec) = @_;
    $rec = '' if !defined $rec;
    print STDERR "_add_padding(1) :$rec:\n" if $DEBUG;

    # deferred records may have already been terminated with recsep
    my $has_recsep = 0;
    while (index($rec, $self->{recsep}, (length($rec) - $self->{recseplen})) != -1) {
        substr($rec, - $self->{recseplen}) = ''; # temporary chomp
        $has_recsep = 1;
    }

    my $rl = length($rec);
    die "Record '$rec' ($rl) exceeds record length ($self->{record_length})\n"
        if $rl > $self->{record_length};

    if (length($rec) != $self->{record_length}) {
        my $pad
            = $self->{pad_char} x ($self->{record_length} - length($rec));

        if ($self->{pad_dir} eq 'right') {
            $rec .= $pad;
        }
        else {
            $rec = $pad . $rec;
        }
    }

    $rec .= $self->{recsep} if $has_recsep;
    print STDERR "_add_padding(2) :$rec:\n" if $DEBUG;

    return $rec;
}

sub _del_padding {
    my ($self, $rec) = @_;
    return undef if !defined $rec;
    print STDERR "_del_padding(1) :$rec:\n" if $DEBUG;

    my $has_recsep = 0;
    while (index($rec, $self->{recsep}, (length($rec) - $self->{recseplen})) != -1) {
        substr($rec, - $self->{recseplen}) = ''; # temporary chomp
        $has_recsep = 1;
    }

    my $rl = length($rec);
    die "Record '$rec' ($rl) is not set length ($self->{record_length})\n"
        if $rl != $self->{record_length};

    if ($self->{pad_dir} eq 'right') {
        while (index($rec,$self->{pad_char},(length($rec) - 1))
                    == (length($rec) - 1)) {
            substr($rec, -1, 1) = '';
        }
    }
    else {
        while (index($rec,$self->{pad_char},0) == 0) {
            substr($rec, 0, 1) = '';
        }
    }

    $rec .= $self->{recsep} if $has_recsep;
    print STDERR "_del_padding(2) :$rec:\n" if $DEBUG;

    return $rec;
}

# ===========================================================================

sub FETCH {
    my ($self, $n) = @_;

    my $rec = $self->SUPER::FETCH($n);
    return undef if !defined $rec;

    return $self->_del_padding($rec);
}

# SUPER->STORE will append record separator for us
sub STORE {
    my ($self, $n, $rec) = @_;
    $rec = $self->_add_padding($rec);

    return $self->SUPER::STORE($n, $rec);
}

# need to override this as it is called from STORESIZE with $self->{recsep}
# sadly it could be called from STORE as well but that can't be helped.
sub _store_deferred {
    my ($self, $n, $rec) = @_;
    $rec = $self->_add_padding($rec);

    return $self->SUPER::_store_deferred($n, $rec);
}

sub SPLICE {
    my ($self, $pos, $nrecs, @data) = @_;

    map {$_ = $self->_add_padding($_)} @data;
    my @result = $self->SUPER::SPLICE($pos, $nrecs, @data);

    # Yes, the return value of 'splice' *is* actually this complicated
    wantarray
        ? map {$self->_del_padding($_)} @result
        : @result ? $self->_del_padding($result[-1]) : undef;
}

# to work around _extend_file_to being called in many circumstances
sub STORESIZE {
    my ($self, $len) = @_;

    $len += ($len > $self->FETCHSIZE ? 1 : 0);
    print STDERR "STORESIZE $len\n" if $DEBUG;
    return $self->SUPER::STORESIZE($len);
}

sub EXTEND {
    my ($self, $len) = @_;

    $len += ($len > $self->FETCHSIZE ? 1 : 0);
    print STDERR "EXTEND $len\n" if $DEBUG;
    return $self->SUPER::EXTEND($len);
}

# ===========================================================================

# okay, according to the Tie::File code comments, the offset table has one
# more entry than the total number of records. I assume this means the last
# offset table entry is the seek position of the record which is next to be
# written in the file (or put another way, the size of the file).

sub _fill_offsets {
    my ($self) = @_;

    my $fh   = $self->{fh};
    my $size = -s $fh;
    my $off  = $self->{offsets};
    my $totreclen = $self->{record_length} + $self->{recseplen};

    # for development
    # seek $fh,0,0;
    # my $lines = join '',<$fh>;
    # print STDERR "OFFSETS(1) content is :$lines:\n" if $DEBUG;

    die "File ($size) does not appear to be using ".
        "fixed length records ($totreclen)\n" if ($size % $totreclen) != 0;

    @$off = map {$_ * $totreclen} (0 .. ($size / $totreclen));
    print STDERR "OFFSETS(2) offsets :@$off:\n" if $DEBUG;

    $self->_seek(-1); # position after the end of the last record
    $self->{eof} = 1;

    return $#{$off};
}

# populate the offsets table up to the beginning of record $n
# return the offset of record $n
sub _fill_offsets_to {
    my ($self, $n) = @_;

    $self->_fill_offsets;

    my $off = $self->{offsets};
    return undef if $n > $#{$off};
    return $off->[$n];
}

# We have read to the end of the file and have the offsets table
# entirely populated.  Now we need to write a new record beyond
# the end of the file.  We prepare for this by writing
# empty records into the file up to the position we want
#
# assumes that the offsets table already contains the offset of record $n,
# if it exists, and extends to the end of the file if not.
sub _extend_file_to {
    my ($self, $n) = @_;

    my $record = $self->{pad_char} x $self->{record_length};
    my $recs = $self->_fill_offsets;
        # a bit safer to just refresh this now
        # and also positions us at the end of the file
        # and gives us a starting counter for writing records

    print STDERR "_extend_file_to $n (-2)...\n" if $DEBUG;
    for ($recs .. ($n - 2)) {
        print STDERR
            "_extend_file_to $_ writing record '$record$self->{recsep}'\n"
                if $DEBUG;
        $self->_write_record($record . $self->{recsep});
    }
    $self->_fill_offsets; # refresh offsets table

    return undef; # not sure what Tie::File's version wants to return
}

1;

# ABSTRACT: Fixed Length Record support for Tie:File


__END__