File Coverage

blib/lib/File/Process.pm

Criterion	Covered	Total	%
statement	96	142	67.6
branch	40	52	76.9
condition	19	27	70.3
subroutine	15	24	62.5
pod	6	7	85.7
total	176	252	69.8

package File::Process;

use strict;
use warnings;

use parent qw( Exporter );

our @EXPORT = qw( process_file ); ## no critic (ProhibitAutomaticExportation)

our @EXPORT_OK = qw(
  post
  pre
  process
  filter
  next_line
  $TRUE
  $FALSE
  $SUCCESS
  $FAILURE
);

our %EXPORT_TAGS = (
  'booleans' => [qw($TRUE $FALSE $SUCCESS $FAILURE)],
  'all'      => \@EXPORT_OK,
);

use Carp;
use English qw(-no_match_vars);
use IO::Scalar;
use ReadonlyX;
use Scalar::Util qw( reftype openhandle );

Readonly my $SUCCESS => 1;
Readonly my $FAILURE => 0;
Readonly my $TRUE    => 1;
Readonly my $FALSE   => 0;
Readonly my $EMPTY   => q{};
Readonly my $NL      => "\n";

our $VERSION = '0.09';

our %DEFAULT_PROCESSORS = (
  pre       => \&_pre,
  next_line => \&_next_line,
  filter    => \&_filter,
  process   => \&_process,
  post      => \&_post,
);

caller or __PACKAGE__->main();

########################################################################
sub _pre {
########################################################################
  my ( $file, $args ) = @_;

  my $fh;

  if ( openhandle $file ) {
    $fh = $file;

    $args->{file} = ref $fh; # GLOB
  }
  else {
    open $fh, '<', $file     ## no critic (RequireBriefOpen)
      or croak 'could not open ' . $file . $NL;

    $args->{'file'} = $file;
  }

  $args->{'raw_count'}  = 0;
  $args->{'skipped'}    = 0;
  $args->{'start_time'} = time;

  my $lines = $args->{merge_lines} ? IO::Scalar->new : [];

  return ( $fh, $lines );
}

########################################################################
sub _next_line {
########################################################################
  my ( $fh, $all_lines, $args ) = @_;

  my $current_line;

  if ( openhandle $fh ) {
    if ( !eof $fh ) {
      defined( $current_line = readline $fh )
        or croak "readline failed: $OS_ERROR\n";
    }
  }

  return $current_line;
}

########################################################################
sub _filter {
########################################################################
  my ( $fh, $all_lines, $args, $current_line ) = @_;

  if ( $args->{'chomp'} ) {
    chomp $current_line;
  }

  if ( $args->{'trim'} && $args->{'trim'} =~ /(front|both)/xsm ) {
    $current_line =~ s/^\s+//xsm;
  }

  if ( $args->{'trim'} && $args->{'trim'} =~ /(both|back)/xsm ) {
    $current_line =~ s/\s+$//xsm;
  }

  # skip?
  my $skip = $FALSE;

  if ( $args->{'skip_blank_lines'} || $args->{'skip_comments'} ) {

    if ( $args->{'skip_blank_lines'} && "$current_line" eq $EMPTY ) {
      $skip = $TRUE;
    }

    # if we're not chomping, then consider new line a blank line?
    if ( !$args->{chomp} && "$current_line" eq $NL ) {
      $skip = $TRUE;
    }

    if ( $args->{'skip_comments'} && $current_line =~ /^\#/xsm ) {
      $skip = $TRUE;
    }
  }

  $args->{skipped} = $args->{skipped} + $skip ? 1 : 0;

  return $skip ? undef : $current_line;
}

########################################################################
sub _process {
########################################################################
  my ( $fh, $all_lines, $args, $current_line ) = @_;

  return $current_line;
}

########################################################################
sub _post {
########################################################################
  my ( $fh, $all_lines, $args ) = @_;

  $args->{end_time} = time;

  my $retval;

  if ( $args->{merge_lines} ) {
    $retval = ${ $all_lines->sref };
  }
  else {
    $retval = $all_lines;
  }

  if ( !$args->{'keep_open'} ) {
    close $fh
      or croak 'could not close' . $args->{file} . $NL;
  }

  return $retval, %{$args};
}

sub process_file {
  my ( $file, %args ) = @_;

  my $chomp = $args{'chomp'};

  $args{'file'} = $file || $EMPTY;

  my %processors
    = map { ( $_, $args{$_} ) } qw( pre filter next_line process post );

  foreach (qw( pre filter next_line process post)) {
    if ( !$processors{$_} ) {
      $processors{$_} = $DEFAULT_PROCESSORS{$_};
    }
  }

  $args{'default_processors'} = \%DEFAULT_PROCESSORS;

  my ( $fh, $all_lines ) = $processors{'pre'}->( $file, \%args );

  if ( !$fh || !ref $all_lines || !reftype($all_lines) eq 'ARRAY' ) {
    croak "invalid pre processor return: wanted file handle, array ref\n";
  }

  LINE: while (1) {
    my $current_line = $processors{'next_line'}->( $fh, $all_lines, \%args );
    last LINE if !defined $current_line;

    $args{'raw_count'}++;

    foreach my $p ( @processors{qw( filter process )} ) {
      $current_line
        = eval { return $p->( $fh, $all_lines, \%args, $current_line ); };
      last LINE if $EVAL_ERROR;
      next LINE if !defined $current_line;
    }

    if ( $args{merge_lines} ) {
      $all_lines->print($current_line);
    }
    else {
      push @{$all_lines}, $current_line;
    }
  }

  if ($EVAL_ERROR) {
    croak "$EVAL_ERROR";
  }

  return $processors{'post'}->( $fh, $all_lines, \%args );
}

########################################################################
sub post { ## no critic [Subroutines::RequireArgUnpacking]
########################################################################
  return $_[2]->{default_processors}->{post}->(@_);
}

########################################################################
sub filter { ## no critic [Subroutines::RequireArgUnpacking]
########################################################################
  return $_[2]->{default_processors}->{filter}->(@_);
}

########################################################################
sub pre { ## no critic [Subroutines::RequireArgUnpacking]
########################################################################
  return $_[1]->{default_processors}->{pre}->(@_);
}

########################################################################
sub process { ## no critic [Subroutines::RequireArgUnpacking]
########################################################################
  return $_[2]->{default_processors}->{process}->(@_);
}

########################################################################
sub next_line { ## no critic [Subroutines::RequireArgUnpacking]
########################################################################
  return $_[2]->{default_processors}->{next_line}->(@_);
}

########################################################################
sub main {
########################################################################
  require IO::Scalar;
  require Data::Dumper;
  require JSON::PP;
  require Text::CSV_XS;

  JSON::PP->import('decode_json');

  Data::Dumper->import('Dumper');

  # +------------------+
  # | READ A TEXT FILE |
  # +------------------+

  my $buffer = <<'END_OF_TEXT';
line 1
 line 2

line 4

line 5
END_OF_TEXT

  my $fh = IO::Scalar->new( \$buffer );

  print Dumper(
    process_file(
      $fh,
      skip_blank_lines => $TRUE,
      chomp            => $TRUE,
      trim             => 'both'
    )
  );

  $fh = IO::Scalar->new( \$buffer );
  print Dumper(
    process_file(
      $fh,
      post => sub {
        my @retval = post(@_);
        $retval[0] = join $EMPTY, @{ $_[1] };
        return @retval;
      }
    )
  );

  # +------------------+
  # | READ A JSON FILE |
  # +------------------+

  my $json_text = <<'END_OF_TEXT';
{
  "foo" : "bar",
  "baz" : "buz"
}

END_OF_TEXT

  $fh = IO::Scalar->new( \$json_text );

  print Dumper(
    process_file(
      $fh,
      chomp => 1,
      post  => sub {
        post(@_);
        return decode_json( join $EMPTY, @{ $_[1] } );
      }
    )
  );

  $fh = IO::Scalar->new( \$json_text );

  print Dumper(
    decode_json( process_file( $fh, merge_lines => 1, chomp => 1 ) ) );

  # +-----------------+
  # | READ A CSV FILE |
  # +-----------------+

  my $csv_text = <<'END_OF_TEXT';
"id","first_name","last_name"
0,"Rob","Lauer"
END_OF_TEXT

  $fh = IO::Scalar->new( \$csv_text );

  my $csv = Text::CSV_XS->new;

  my ($csv_lines) = process_file(
    $fh,
    csv         => $csv,
    chomp       => 1,
    has_headers => 1,
    pre         => sub {
      my ( $csv_fh, $args ) = @_;

      if ( $args->{'has_headers'} ) {
        my @column_names = $args->{csv}->getline($csv_fh);
        $args->{csv}->column_names(@column_names);
      }

      return ( pre( $fh, $args ) );
    },
    next_line => sub {
      my ( $csv_fh, $all_lines, $args ) = @_;
      my $ref = $args->{csv}->getline_hr($csv_fh);
      return $ref;
    }
  );

  print Dumper($csv_lines);

  exit 0;
}

1;

__END__