File Coverage

blib/lib/Text/FixedLength.pm

Criterion	Covered	Total	%
statement	62	81	76.5
branch	16	40	40.0
condition	12	28	42.8
subroutine	6	10	60.0
pod	0	8	0.0
total	96	167	57.4

# ----------------------------------------------------------------------------
# Name: Text::FixedLength.pm
# Auth: Dion Almaer (dion)
# Desc: Manipulate fixed length fields, from creating to parsing
# Date Created: Sun Nov 15 17:50:29 1998
# Version: 0.12
# $Modified: Wed Nov 18 16:55:46 CST 1998 by dion $
# ----------------------------------------------------------------------------
package Text::FixedLength;
use strict;
use Exporter;

# ----------------------------------------------------------------------------
#              Package Variables
# ----------------------------------------------------------------------------
@Text::FixedLength::ISA     = qw(Exporter);
@Text::FixedLength::EXPORT  = qw(delim2fixed fixed2delim setJustify setCrop);
$Text::FixedLength::VERSION = '0.12';
my $defaultJustification    = 'L'; # -- left justified by default (setJustify)
my $cropRecords             = 1;   # -- force fixed format by cropping records

# ----------------------------------------------------------------------------
#              Module Subroutines
# ----------------------------------------------------------------------------

# ----------------------------------------------------------------------------
# DELIMITED DATA - > FIXED LENGTH FIELD DATA
# ----------------------------------------------------------------------------

# ----------------------------------------------------------------------------
# Subroutine: delim2fixed - given an array of delimited text, or file with
#                           delimited text, create an array of fixed text
# SEE THE POD DOCUMENTATION BELOW (perldoc Text::FixedLength)
# ----------------------------------------------------------------------------
sub delim2fixed {
  my $delimData = shift || die 'delim2fixed: need data';
  my $delim     = shift || die 'delim2fixed: need a delimiter';
  my $format    = shift || die 'delim2fixed: need a fixed format array';
  my $outfile   = shift; # -- if set then save data to outfile

  my @delimdata = ( ref $delimData eq 'ARRAY' ) ? @{ $delimData }
                                                : getFile($delimData);
  my @fixeddata = map { getFixed($_, $delim, $format) } @delimdata;
  if ($outfile) {
      savetoFile($outfile, \@fixeddata);
  }
  my $w = wantarray;
  return unless defined $w;
  return $w ? @fixeddata : \@fixeddata;
}

# ----------------------------------------------------------------------------
# Subroutine: getFixed - given a string, delimiter, and format return a string
# ----------------------------------------------------------------------------
sub getFixed {
  my $s      = shift || die 'getFixed: need a string';
  my $delim  = shift || die 'getFixed: need a delimiter';
  my $format = shift || die 'getFixed: need a format';
  my $out    = '';
  die "getFixed: no delimiter in $s" unless $s =~ /$delim/;

  # -- get each piece
  my @records = split /$delim/, $s;

  # -- setup the sprintf format (e.g. "%-8s%3s...")
  my $count = 0;
  foreach ( @$format ) {
    my $f = $_; # -- copy the format as we chop it later
    my $just = ($defaultJustification eq 'L') ? '-' : '';
    if ( uc substr($f, -1) =~ /[RL]/ ) {
      my $c = uc chop $f;
      if ( $c eq 'L' ) { $just = '-'; } elsif ( $c eq 'R' ) { $just = ''; }
    }
    $out .= "%${just}${f}s";

    # -- Crop the record if it is longer than it is meant to be
    if ($cropRecords) {
        $records[$count] = substr($records[$count], 0, $f)
          if length $records[$count] > $f;
    }
    $count++;
  }
  return sprintf $out, @records;
}

# ----------------------------------------------------------------------------
# FIXED LENGTH FIELD DATA -> DELIMITED DATA
# ----------------------------------------------------------------------------

# ----------------------------------------------------------------------------
# Subroutine: fixed2delim
# SEE THE POD DOCUMENTATION BELOW (perldoc Text::FixedLength)
# ----------------------------------------------------------------------------
sub fixed2delim {
  my $fixedData   = shift || die 'fixed2delim: need data';
  my $fixedFormat = shift || die 'fixed2delim: need fixed format aref';
  my $delim       = shift || die 'fixed2delim: need the delim you want';
  my $outfile     = shift; # -- the file that you want the data to output to

  my @fixeddata = ( ref $fixedData eq 'ARRAY' ) ? @{ $fixedData }
                                                : getFile($fixedData);

  my @delimdata = map { getDelim($_, $delim, $fixedFormat) } @fixeddata;

  if ($outfile) {
      savetoFile($outfile, \@delimdata);
  }
  my $w = wantarray;
  return unless defined $w;
  return $w ? @delimdata : \@delimdata;
}

# ----------------------------------------------------------------------------
# Subroutine: getDelim - given a string, delimiter, and format return a string
# ----------------------------------------------------------------------------
sub getDelim {
  my $s      = shift || die 'getDelim: need a string';
  my $delim  = shift || die 'getDelim: need a delimiter';
  my $format = shift || die 'getDelim: need a format';
  my @out    = ();

  foreach ( @$format ) {
    s/\D//g; # - save only digits
    my $sub = substr($s,0,$_); $sub =~ s/^\s+//; $sub =~ s/\s+$//;
    push @out, $sub;
    substr($s,0,$_) = '';
  }
  return join $delim, @out;
}

# ----------------------------------------------------------------------------
# UTILITY / SHARED FUNCTIONS
# ----------------------------------------------------------------------------

# ----------------------------------------------------------------------------
# Subroutine: setJustify - given either 'l' 'L' 'r' 'R' set the justification
# ----------------------------------------------------------------------------
sub setJustify {
  my $char = uc shift;
  die 'setJustify: need one of: l, L, r, R' unless $char =~ /[LR]/;
  $defaultJustification = $char;
}

# ----------------------------------------------------------------------------
# Subroutine: setCrop - set the cropRecords value (whether to force the fixed
#             format by constraining a string to the size of its format)
# ----------------------------------------------------------------------------
sub setCrop {
  my $arg = shift; die 'setCrop: need either 1 or 0' unless defined $arg;
  $cropRecords = ($arg) ? 1 : 0;
}

# ----------------------------------------------------------------------------
# Subroutine: savetoFile - save fixeddata array ref to outfile
# ----------------------------------------------------------------------------
sub savetoFile {
  my $outfile = shift || die 'savetoFile: need a filename to save to';
  my $dataref = shift || die 'savetoFile: need data to save';

  open F, "> $outfile" or die "savetoFile: couldn't open $outfile: $!";
  foreach (@$dataref) { print F "$_\n"; }
  close F;
}

# ----------------------------------------------------------------------------
# Subroutine: getFile - given a filename return it lines in an array
# ----------------------------------------------------------------------------
sub getFile {
  my $file = shift;
  open F, $file or die "getDelimData: couldn't open file $file: $!";
  chomp( my @data =  );
  close F;
  return @data;
}

# ----------------------------------------------------------------------------
1; #           End of Text::FixedLength
# ----------------------------------------------------------------------------

__END__