File Coverage

blib/lib/App/Sets.pm

Criterion	Covered	Total	%
statement	99	116	85.3
branch	35	72	48.6
condition	2	11	18.1
subroutine	18	18	100.0
pod	0	5	0.0
total	154	222	69.3

package App::Sets;
$App::Sets::VERSION = '0.978';


use strict;
use warnings;

# ABSTRACT: set operations in Perl

use English qw( -no_match_vars );
use 5.010;
use Getopt::Long
  qw< GetOptionsFromArray :config pass_through no_ignore_case bundling >;
use Pod::Usage qw< pod2usage >;
use Log::Log4perl::Tiny qw< :easy :dead_if_first LOGLEVEL >;
use App::Sets::Parser;
use App::Sets::Iterator;
use App::Sets::Operations;
use App::Sets::Sort qw< sort_filehandle >;

my %config = (
   binmode => ':raw:encoding(UTF-8)',
   loglevel => 'INFO',
   parsedebug => 0,
);

sub populate_config {
   my (@args) = @_;

   $config{sorted} = 1                if $ENV{SETS_SORTED};
   $config{trim}   = 1                if $ENV{SETS_TRIM};
   $config{cache}  = $ENV{SETS_CACHE} if exists $ENV{SETS_CACHE};
   $config{loglevel}  = $ENV{SETS_LOGLEVEL}
      if exists $ENV{SETS_LOGLEVEL};
   $config{parsedebug}  = $ENV{SETS_PARSEDEBUG}
      if exists $ENV{SETS_PARSEDEBUG};
   $config{internal_sort} = $ENV{SETS_INTERNAL_SORT}
      if exists $ENV{SETS_INTERNAL_SORT};
   $config{binmode} = $ENV{SETS_BINMODE} if $ENV{SETS_BINMODE};
   GetOptionsFromArray(
      \@args, \%config, qw< man help usage version
        binmode|b=s
        cache|cache-sorted|S=s
        internal_sort|internal-sort|I!
        loglevel|l=s
        sorted|s!
        trim|t!
        >
     )
     or pod2usage(
      -verbose  => 99,
      -sections => 'USAGE',
     );
   $App::Sets::VERSION
        //= '0.972' unless defined $App::Sets::VERSION;
   pod2usage(message => "$0 $App::Sets::VERSION", -verbose => 99,
       -sections => ' ')
     if $config{version};
   pod2usage(
      -verbose  => 99,
      -sections => 'USAGE'
   ) if $config{usage};
   pod2usage(
      -verbose  => 99,
      -sections => 'USAGE|EXAMPLES|OPTIONS'
   ) if $config{help};
   pod2usage(-verbose => 2) if $config{man};

   LOGLEVEL $config{loglevel};

   $config{cache} = '.sorted'
     if exists $config{cache}
        && !(defined($config{cache}) && length($config{cache}));
   $config{sorted} = 1 if exists $config{cache};

   if (exists $config{cache}) {
      INFO "using sort cache or generating it when not available";
   }
   elsif ($config{sorted}) {
      INFO "assuming input files are sorted";
   }
   INFO "trimming away leading/trailing whitespaces"
     if $config{trim};

   pod2usage(
      -verbose  => 99,
      -sections => 'USAGE',
   ) unless @args;

   return @args;
} ## end sub populate_config

sub run {
   my $package = shift;
   my @args    = populate_config(@_);

   my $input;
   if (@args > 1) {
      shift @args if $args[0] eq '--';
      LOGDIE "only file op file [op file...] "
        . "with multiple parameters (@args)...\n"
        unless @args % 2;
      my @chunks;
      while (@args) {
         push @chunks, escape(shift @args);
         push @chunks, shift @args if @args;
      }
      $input = join ' ', @chunks;
   } ## end if (@args > 1)
   else {
      $input = shift @args;
   }

   LOGLEVEL('DEBUG') if $config{parsedebug};
   DEBUG "parsing >$input<";
   my $expression = App::Sets::Parser::parse($input, 0);
   LOGLEVEL($config{loglevel});

   binmode STDOUT, $config{binmode};

   my $it = expression($expression);
   while (defined(my $item = $it->drop())) {
      print {*STDOUT} $item;
      print {*STDOUT} "\n" if $config{trim};
   }
   return;
} ## end sub run

sub escape {
   my ($text) = @_;
   $text =~ s{(\W)}{\\$1}gmxs;
   return $text;
}

sub expression {
   my ($expression) = @_;
   if (ref $expression) {    # operation
      my ($op, $l, $r) = @$expression;
      my $sub = App::Sets::Operations->can($op);
      return $sub->(expression($l), expression($r));
   }
   else {                    # plain file
      return file($expression);
   }
} ## end sub expression

sub file {
   my ($filename) = @_;
   LOGDIE "invalid file '$filename'\n"
     unless -r $filename && !-d $filename;

   if ($config{cache}) {
      my $cache_filename = $filename . $config{cache};
      if (!-e $cache_filename) {    # generate cache file
         WARN "generating cached sorted file "
           . "'$cache_filename', might wait a bit...";
         my $ifh = sort_filehandle($filename, \%config);
         open my $ofh, '>', $cache_filename
           or LOGDIE "open('$cache_filename') for output: $OS_ERROR";
         while (<$ifh>) {
            print {$ofh} $_;
         }
         close $ofh or LOGDIE "close('$cache_filename'): $OS_ERROR";
      } ## end if (!-e $cache_filename)
      INFO "using '$cache_filename' (assumed to be sorted) "
        . "instead of '$filename'";
      $filename = $cache_filename;
   } ## end if ($config{cache})

   my $fh;
   if ($config{sorted}) {
      INFO "opening '$filename', assuming it is already sorted"
        unless $config{cache};
      open $fh, '<', $filename
        or LOGDIE "open('$filename'): $OS_ERROR";
   } ## end if ($config{sorted})
   else {
      INFO "opening '$filename' and sorting on the fly";
      $fh = sort_filehandle($filename, \%config);
   }
   return App::Sets::Iterator->new(
      sub {
         my $retval = <$fh>;
         return unless defined $retval;
         $retval =~ s{\A\s+|\s+\z}{}gmxs
           if $config{trim};
         return $retval;
      }
   );
} ## end sub file

1;

__END__