File Coverage

blib/lib/Text/FixedLength/Extra.pm

Criterion	Covered	Total	%
statement	9	56	16.0
branch	0	30	0.0
condition	0	9	0.0
subroutine	3	6	50.0
pod	0	3	0.0
total	12	104	11.5

package Text::FixedLength::Extra;


require 5.005_62;
use strict;
use warnings;

use Text::FixedLength;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Text::FixedLength::Extra ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(fixedlength

);
our $VERSION = '1.1';

our $debug = 0;


# Preloaded methods go here.
# ----------------------------------------------------------------------------
# Subroutine: getFixed - given a string, delimiter, and format return a string
# ----------------------------------------------------------------------------
sub Text::FixedLength::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 my $format ( @$format ) {
    sub assign_just {
      $_[0] eq 'L' ? '-' : '';
    }
    my $just = assign_just $Text::FixedLength::defaultJustification;
    my ($width,$d_or_f,$zero_fill,$decimal_places,$numfmt);


    my $int_re = '([*])?(D)';
    my $flt_re = '([*])?(F)(\d+)?';
    my $numfmt_re = "($int_re|$flt_re)";
    my $format_re =<
    (\\d+)       # width
    (R|L)?       # optional justification
    (            # optional numerical formatting
     $numfmt_re
    )?
RE

  # ----

  if ($format =~ /$format_re/x) {

    $width=$1;
    if ($2) { $just = assign_just $2 }

    warn "$3 =~ /$numfmt_re/" if $debug;
    my $text = $3;
    if ($text =~ /$int_re/i or $text =~ /$flt_re/) {
      warn "RE:$1.$2.$3.$4" if $debug;
      $zero_fill = '0' if ($1);
      $d_or_f = lc $2;
      warn "d_of_f: $d_or_f" if $debug;
      $d_or_f = ".$3$d_or_f" if ($d_or_f eq 'f');

      my $new_out = "%${just}${zero_fill}${width}${d_or_f}";
      warn "num sprintf :$new_out" if $debug;
      $out .= $new_out;

    } else {
      my $new_out = "%${just}${width}s";
      warn "str sprintf: $new_out" if $debug;
      $out .= $new_out;
    }

  } else {
    die "$format did not match $format_re";
  }
    # -- Crop the record if it is longer than it is meant to be
    if ($Text::FixedLength::cropRecords) {
        $records[$count] = substr($records[$count], 0, $width)
          if length $records[$count] > $width;
      }
    $count++;
  }
  warn "sprintf stmt: $out" if $debug;
  return sprintf $out, @records;
}


sub fixedlength {
  my ($format_href, $data_href, $field_order_ref) = @_;

  my $delim = "\t";
  my (@format,@data);

  for (@$field_order_ref) {
    push @format, $format_href->{$_};
    push @data,   $data_href->{$_};
  }

  my $data = join $delim, @data;

  [ delim2fixed([$data], $delim, \@format) ] -> [0];

}
1;
__END__