File Coverage

blib/lib/Parse/FixedLength.pm

Criterion	Covered	Total	%
statement	260	306	84.9
branch	120	178	67.4
condition	26	54	48.1
subroutine	29	36	80.5
pod	12	12	100.0
total	447	586	76.2

package Parse::FixedLength;
use strict;


#-----------------------------------------------------------------------
#	Public Global Variables
#-----------------------------------------------------------------------
use Carp;
use vars qw($VERSION $DELIM $DEBUG);
$VERSION   = '5.39';
$DELIM = ":";
$DEBUG = 0;

#=======================================================================
sub import {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    for (@_) {
        $class->import($class->_all_modules()), last if $_ eq ':all';
        eval "use ${class}::$_";
        confess $@ if $@;
    }
}

sub _all_modules {
    my $self = shift;
    eval "use File::Spec";
    confess $@ if $@;
    my %modules;
    for my $dir (@INC) {
        my $pfl_dir = File::Spec->catdir($dir, 'Parse', 'FixedLength');
        next unless -d $pfl_dir;
        opendir(DIR, $pfl_dir) or confess "Can't read $pfl_dir: $!";
        for (readdir DIR) {
            my $module = $_;
            next unless $module =~ s/\.pm$//;
            $modules{$module} = undef;
        }
        closedir DIR;
    }
    keys %modules;
}

sub new {
    # Do the cargo cult OO construction thing
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $format = shift;
    unless (ref $format) {
        my $newclass = "${class}::${format}";
        my $result = eval { $newclass->new(@_)};
        return $result unless $@;
        confess $@ unless $@ =~ /Can't locate object method/;
        # Assume we need to require this format
        $class->import($format);
        return $newclass->new(@_);
    }
    confess "Format argument not an array ref"
        unless UNIVERSAL::isa($format, 'ARRAY');
    my $self = bless {}, $class;
    my $params = shift || {};
    confess "Params argument not a hash ref"
        if defined $params and ! UNIVERSAL::isa($params, 'HASH');
    my $delim = exists $params->{'delim'} ? $params->{'delim'} : $DELIM;
    $self->{DELIM} = $delim;
    my $delim_re = qr/\Q$delim/;
    confess "Delimiter argument must be one character" unless length($delim)==1;
    if (exists $$params{all_lengths}) {
        my $all = $$params{all_lengths};
        confess "all_lengths must be a positive integer"
            unless $all and $all =~ /^\d+$/ and $all > 0;
        $format = [ map { local $_=$_; s/$delim_re.*//;
                         "${_}${delim}$$params{all_lengths}"
                        } @$format ];
    }
    my $spaces = $params->{'spaces'} ? 'a' : 'A';
    my $is_hsh = $self->{IS_HSH} = _chk_format_type($format, $delim_re);

    # Convert hash-like array to delimited array
    $format = [ map  { $$format[$_].$delim.$$format[$_+1] }
                grep { not $_ % 2 } 0..$#$format
              ] if $is_hsh;
    my ($names, $alengths, $hlengths, $justify, $length, $fmts) =
        _parse_format($format, $delim_re, $params);

    $self->{NAMES} = $names;
    $self->{UNPACK} = join '', @{$fmts}{@$names};
    ( $self->{PACK} = $self->{UNPACK} ) =~ tr/a/A/;
    $self->{LENGTH} = $length;
    @$self{qw(TFIELDS TNAMES)} = ([], []);
    # Save justify fields no matter what for benefit of dumper()
    if (%$justify) {
        $self->{JFIELDS} = $justify;
        $self->{JUST} = 1 unless $$params{no_justify};
        @$self{qw(TFIELDS TNAMES TPAD)} = _trim_info($self);
        $self->{TRIM} = 1 if $$params{trim};
    }
    $self->{LENGTHS} = $hlengths;
    $self->{FMTS} = $fmts;
    $self->{DEBUG} = exists $$params{'debug'} ?
        ref($$params{'debug'}) ? $$params{'debug'} : \*STDOUT : $DEBUG;

    # Make slot to parse data into
    my $ref = $params->{href} || {};
    @$ref{@{$self->names}} = undef;
    $self->{DATA} = $ref;
    $self->hash_to_obj($self->{DATA}) unless $params->{no_bless};

    $self;
}

# Determine which format we have, the delimited array ref
# or the hash-like array ref.
# There must be delimiters in either all of the elements or none in
# alternating elements with an even number of elements.
# Assume what we have from the first element.
sub _chk_format_type {
    my ($format, $delim) = @_;
    my $is_hsh = 1 unless $$format[0] =~ $delim;
    confess"Odd number of name/length pairs or missing delimiter on first field"
        if $is_hsh and @$format % 2;
    for my $i (0..$#$format) {
        my $field = $$format[$i];
        if ($field =~ $delim) {
            confess "Field $field contains delimiter" if $is_hsh and not $i % 2;
        } else { confess "Field $field is missing delimiter" unless $is_hsh }
    }
    return $is_hsh;
}

sub _parse_format {
    my ($format, $delim, $params) = @_;
    my (@names, @lengths, %lengths, %justify, %dups, %fmts);
    my $dups_ok = $$params{autonum};
    my $all_dups_ok;
    if ($dups_ok) {
        if (UNIVERSAL::isa($dups_ok, 'ARRAY')) {
            @dups{@$dups_ok} = undef;
        } else { $all_dups_ok = 1 }
    }
    my $length = 0;
    my $nxt = 1;
    for (@$format) {
        my ($name, $tmp_len, $start, $end) = split $delim;
        _chk_start_end($name, $nxt, $start, $end) unless $$params{no_validate};
        $name = _chk_dups(
            $name, \@names, \%fmts,
            \%lengths, \%justify, \%dups, $dups_ok, $all_dups_ok
        );
        push @names, $name;
        # The results of the inner-parens is not guaranteed unless the
        # outer parens match, so we do it this way
        if ( $tmp_len =~ /^\d/ ) {
          my ($len, $is_just, $chr) = $tmp_len =~ /^(\d+)((?:R(.?))?)$/
              or confess "Bad length $tmp_len for field $name";
          $len > 0 or confess "Length must be > 0 for field $name";
          unless ( $$params{no_validate} ) {
            if (defined $end) {
              confess "Bad length or end for field $name"
                unless $end == $start + $len - 1;
            }
          }
          $justify{$name} = ($chr eq '') ? ' ' : $chr if $is_just;
          $lengths{$name} = $len;
          push @lengths, $len;
          $length += $len;
          $nxt = $end + 1 if defined $end;
          $fmts{$name} = ( $params->{spaces} ? "a" : "A" ) . $len;
        } elsif ( $tmp_len =~ /^(\w)((?:\d+)?)$/ ) {
          my ($type, $repeat) = ($1, $2);
          my $len = $type =~ /[AaZ]/ && $repeat
                 || $type =~ /b/i && int((($repeat/16)-.01) + 1)
                 || $type =~ /h/i && int((($repeat/2)-.01) + 1)
                 || $type =~ /c/i && 1
                 || $type =~ /[sSnv]/ && 2
                 || $type =~ /[lLNV]/ && 4
                 || $type =~ /q/i && 8
                 || undef;
          unless ( $$params{no_validate} ) {
            if (defined $end) {
              confess "Bad length or end for field $name"
                unless $end == $start + $len - 1;
            }
          }
          $length += $len;
          $lengths{$name} = $len;
          push @lengths, $len;
          $nxt = $end + 1 if defined $end;
          $fmts{$name} = $tmp_len;
        } else {
          unless ( eval {
            my @foo = unpack($tmp_len, "junk");
            die "Too Many fields" unless @foo == 1;
            1;
          })
          {
            confess "Bad format $tmp_len for field $name";
          }
          $fmts{$name} = $tmp_len;
        }
    }
    return \@names, \@lengths, \%lengths, \%justify, $length, \%fmts;
}

# Check for duplicate field name, and if a duplicate,
# either die or return new autonumbered field name
sub _chk_dups {
    my ($name, $names, $fmts, $lengths,
        $justify, $dups, $dups_ok, $all_dups_ok) = @_;
    if (exists $$lengths{$name}) {
        confess "Duplicate field $name in format"
            if !$dups_ok or !$all_dups_ok && !exists $$dups{$name};
    } else { return $name unless $$dups{$name} }
    # If this is the first duplicate found, fix the previous field
    unless ($$dups{$name}) {
        my $new_name = "${name}_".++$$dups{$name};
        confess "Can't autonumber field $name" if exists $$lengths{$new_name};
        for (@$names) { $_ = $new_name if $_ eq $name }
        $$lengths{$new_name} = $$lengths{$name};
        delete $$lengths{$name};
        $$fmts{$new_name} = $$fmts{$name};
        delete $$fmts{$name};
        if (exists $$justify{$name}) {
            $$justify{$new_name} = $$justify{$name};
            delete $$justify{$name};
        }
    }
    return "${name}_".++$$dups{$name};
}

sub _chk_start_end {
    my ($name, $prev, $start, $end) = @_;
    if (defined $start) {
        $start=~/^\d+$/ or confess "Start position not a number in field $name";
        $start == $prev or confess "Bad start position in field $name";
        defined $end    or confess "End position missing in field $name";
        $end =~ /^\d+$/ or confess "End position not a number in field $name";
        $end < $start  and confess "End position < start in field $name";
    }
}

sub _trim_info {
    my $parser = shift;
    my (@tfields, @tnames, @tpad);
    my $i = 0;
    for my $name (@{$parser->names}) {
        if (exists $parser->{JFIELDS}{$name}) {
            push @tfields, $i;
            push @tnames, $name;
            push @tpad, qr/^\Q$parser->{JFIELDS}{$name}\E+/;
        }
    } continue { $i++ }
    return \@tfields, \@tnames, \@tpad;
}

#=======================================================================
sub parse {
    my $parser = shift;
    my $data = $parser->{DATA};
    my $names = $parser->{NAMES};
    @{$data}{@$names} = unpack($parser->{UNPACK}, $_[0]);
    $parser->trim($data) if $parser->{TRIM};
    if (my $fh = $parser->{DEBUG}) {
     print $fh "# Debug parse\n";
     for my $name (@$names) {
         print $fh "[$name][$data->{$name}]\n";
     }
     print $fh "\n";
    }
    wantarray ? @$data{@$names} : $data;
}
#=======================================================================
sub parse_hash {
  return %{ scalar(shift->parse(@_)) };
}
sub parse_newref {
  return { shift->parse_hash(@_) };
}
#=======================================================================
sub pack {
    my $parser = shift;
    my $href = shift || $parser->{DATA};
    if ($parser->{JUST}) {
        while (my ($name, $chr) =  each %{$parser->{JFIELDS}}) {
            (my $field = $$href{$name}) =~ s/^\s+|\s+$//g;
            $field =~ s/^${chr}+// if $chr ne ' ';
            my $len = $parser->length($name);
            # Should we warn if we're truncating the field?
            $$href{$name} = substr(($chr x $len) . $field, -$len);
        }
    }
    # Print debug output after justifying fields
    if ($parser->{DEBUG}) {
     print "# Debug pack\n";
     for my $name (@{$parser->{NAMES}}) {
         print "[$name][$$href{$name}]\n";
     }
     print "\n";
    }
    CORE::pack $parser->{PACK}, @$href{@{$parser->{NAMES}}};
}
#=======================================================================
sub trim {
    my $self = shift;
    my $i;
    if (ref($_[0])) {
        my $href = shift;
        $href->{$_} =~ s/$self->{TPAD}[$i++]// for @{$self->{TNAMES}};
    } else {
        $_[$_] =~ s/$self->{TPAD}[$i++]// for @{$self->{TFIELDS}};
    }
}
#=======================================================================
sub names { shift->{NAMES} }
#=======================================================================
sub length {
    my $self = shift;
    @_ ? $self->{LENGTHS}{$_[0]} : $self->{LENGTH};
}
#=======================================================================
sub hash_to_obj {
    my $self = shift;
    my $href = shift;

    my $class_key = join "~=~", sort keys %$href;
    my $class = $Parse::FixedLength::HashAsObj::classes{$class_key} || do {
      no strict 'refs';
      my $name = $Parse::FixedLength::HashAsObj::classes{$class_key}
        = "Parse::FixedLength::HashAsObj::Href" .
        ++$Parse::FixedLength::HashAsObj::counter;
      @{"${name}::ISA"} = "Parse::FixedLength::HashAsObj";
      $name;
    };
    bless $href, $class;
}
#=======================================================================
sub dumper {
    my $parser = shift;
    my $pos_comment = shift;
    my $start = 1;
    my $end;
    my $delim = $parser->{DELIM};
    my $format = $pos_comment
       ? sub { sprintf("%s => '%s', # %s-%s", @_) }
       : $parser->{IS_HSH}
         ? sub { sprintf("%s => '%s${delim}%s${delim}%s',", @_) }
         : sub { join $delim, @_ };
    my $layout = '';
    my $jfields = $parser->{JFIELDS} || {};
    for my $name (@{$parser->names}) {
        my $len = $parser->length($name);
        $end = $start + $len - 1;
        my $just = exists $jfields->{$name}
          ? $jfields->{$name} eq ' ' ? 'R' : "R$jfields->{$name}"
          : '';
        $len .= $just;
        $layout .= $format->($name, $len, $start, $end) . "\n";
        $start = $end + 1;
    }
    $layout;
}
#=======================================================================
sub format_str { shift->{UNPACK} }
#=======================================================================
sub converter {
    Parse::FixedLength::Converter->new(@_);
}

package Parse::FixedLength::Converter;
use Carp;

#=======================================================================
sub new {
    # Do the OO cargo cult construction thing
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = bless {}, $class;

    my ($parser1, $parser2, $mappings, $defaults, $parms) = @_;
    $self->{UNPACKER} = $parser1;
    $self->{PACKER}   = $parser2;
    $mappings ||= {};
    confess 'Map arg not a hash or array ref'
        unless UNIVERSAL::isa($mappings, 'ARRAY')
            or UNIVERSAL::isa($mappings, 'HASH');
    $self->{MAP} = { reverse UNIVERSAL::isa($mappings, 'HASH')
        ?  %$mappings : @$mappings
    };
    $defaults ||= {};
    confess 'Defaults arg not a hash ref'
      unless UNIVERSAL::isa($defaults, 'HASH');
    my ($consts, $crefs) = ({}, {});
    while (my ($field, $default) = each %$defaults) {
        confess 'Default for field $field not a constant or code ref'
            unless ! ref $default or UNIVERSAL::isa($default, 'CODE');
        (ref $default ? $$crefs{$field} : $$consts{$field}) = $default;
    }
    $self->{CONSTANTS} = $consts;
    $self->{CODEREFS} = $crefs;
    $self->{NOPACK} = 1 if $parms->{no_pack};
    $self;
}
#=======================================================================
sub convert {
    my $converter = shift;
    my $data_in   = shift;
    my $no_pack   = @_ ? shift : $converter->{NOPACK};
    my $packer    = $converter->{PACKER};
    my $map_to    = $converter->{MAP};

    $data_in = $converter->{UNPACKER}->parse($data_in)
        unless UNIVERSAL::isa($data_in, 'HASH');
    my $names_out = $packer->names;

    # Map the data from input to output
    my $data_out = $packer->{DATA};
    @$data_out{@$names_out} = map {
        exists $map_to->{$_} ? $data_in->{$map_to->{$_}}
      : exists $data_in->{$_} ? $data_in->{$_} : ''
    } @$names_out;

    # Default/Convert the fields
    while (my ($name, $default) = each %{$converter->{CONSTANTS}}) {
        $data_out->{$name} = $default;
    }
    while (my ($name, $default) = each %{$converter->{CODEREFS}}) {
        $data_out->{$name} = eval { $default->($data_out->{$name}, $data_in) };
        confess "Failed to default field $name: $@" if $@;
    }
    $no_pack ? $data_out : $packer->pack($data_out);
}

package Parse::FixedLength::HashAsObj;

use vars qw($AUTOLOAD);
sub DESTROY { 1 }

sub AUTOLOAD : lvalue {
  no strict 'refs';
  my ( $class, $method ) = $AUTOLOAD =~ /^(.*)::(.+)$/
    or Carp::croak "Invalid call to $AUTOLOAD";
  Carp::croak "Can't locate object method $method via package $class"
    unless exists $_[0]->{$method};
  *$AUTOLOAD = sub : lvalue {
    my $self = shift;
    if (@_) {
      $self->{$method} = shift;
      return $self;
    }
    $self->{$method};
  };
  goto &$AUTOLOAD;
  # To placate the compiler you must appear
  # to return an lvalue-able value
  $Parse::FixedLength::HashAsObj::foo;
}
1;
__END__