#!/usr/bin/env perl
#
# splitx - like split, but on regular expressions
#
# $Id$

use strict;
use warnings;

use Getopt::Std;

my %opt;
getopts( 'e:F:p:s:ahlnv', \%opt )
 or HELP_MESSAGE("failed to parse command line options: $!");

my $sep = $opt{'F'} // '^\s*$[\r\n]*';
my $sel = $opt{'e'} // '\S';
my $pat = $opt{'p'} // '%d%b-%i%x';
my $repl = $opt{s};

$opt{'h'} and HELP_MESSAGE();

sub HELP_MESSAGE
{
  print STDERR join( ' ', @_ ), "\n" if @_;

  print STDERR <<ZZ;

Usage: $0 [-v] [-l] [-a|-n] [-p fmt] [-F xpr] [-e xpr] [-s repl] [-p fmt] [file1 [file2 [...]]]

to split the input file(s), or standard input, into a collection of files.

Options:

  -v  Write some progress messages to standard error.
  -a  Append to output files instead of overwriting them with each fragment.
  -n  Do not actually write to any output files (useful with -l).
  -l  List the names of the files produced on standard output.
  -F  The Perl regular expression to split on ($sep);
      to make it appear in the output, use lookahead assertions.
  -e  The Perl regular expression a fragment must match ($sel);
      if it contains capturing brackets (()), splitting will not
      only happen on occurrences of $sep, but also before all matches
      of this pattern in which the captured part changes its value
  -s  The replacement for the match specified by -e.  Optional.
  -p  The output filenames ($pat), where
      %s stands for the full input pathname,
      %d for its directory part including trailing separator,
      %b its filename part without extension,
      %x its extension including dot, and
      %i the fragment's sequence number
      %p empty, or the fragment's submatch value, if submatching brackets
         are present in the expression supplied with -e and matched

ZZ
  exit(0);
}

@ARGV or @ARGV = ('-');

undef $/;

while ( my $chunk = <ARGV> )
{
  my ( $dir, $file ) =
   ( $ARGV =~ m#/# ) ? ( $ARGV =~ m#(.*/)(.*)# ) : ( '', $ARGV );
  my ( $base, $ext ) = ( $file =~ m#([^.]*)(.*)# );

  my %x = (
    's' => $ARGV,
    'd' => $dir,
    'b' => $base,
    'x' => $ext,
    'i' => 0
  );

  foreach my $frag ( split( /$sep/m, $chunk ) )
  {
    #warn "frag split with $sep: {$frag}\n";
    # only use $frag if $sel matches, and
    # if $sel contains capturing brackets, split $frag based on
    # whether the captured value is the same in consecutive matches

    my @pos = (0);    # the starting pos of each $subfrag within $frag,
    # surrounded by the start and end+1 of $frag
    my @submatch = ('');    # the submatches for each $subfrag (i.e. $1 // '')

    my $selmatches = 0;

    while ( $frag =~ /$sel/mg )
    {
      $selmatches = 1;

      # $sel matches (once or once more)
      # do we need to split because the submatch value changed?
      my $submatch = $1 // '';

      if ( $submatch ne $submatch[$#submatch] )
      {
        # yes, we do
        #warn "split, submatch is now $submatch\n";
        push( @pos,      $-[0] );
        push( @submatch, $submatch );
      }
      else
      {
        #warn "no split, submatch is still $submatch\n";
      }
    }

    next
     if !$selmatches;    # $sel didn't match at all, so skip this $frag

    push( @pos, length($frag) );

    #warn "subfragments: ", join( ", ", @pos ), " in $frag\n";

    # split $frag on @pos
    foreach my $i ( 0 .. $#pos - 1 )
    {
      my $subfrag = substr( $frag, $pos[$i], $pos[ $i + 1 ] - $pos[$i] );

      #warn "substr($frag, $pos[$i], $pos[$i+1]-$pos[$i]) is $subfrag\n";
      $x{'p'} = $submatch[$i];
      ++$x{'i'};

      my $outfn = $pat;

      while ( my ( $c, $x ) = each %x )
      {
        # warn "replacing %$c with $x in $outfn\n";
        $outfn = join( $x, split( /%$c/, $outfn, -1 ) );
      }

      if ( $outfn eq $ARGV )
      {
        warn "attempt to overwrite input file $ARGV, skipped\n";
      }
      elsif ( !open( OUT, $opt{a} ? '>>' : '>', $outfn ) )
      {
        warn "cannot write to output file $outfn ($!), skipped\n";
      }
      else
      {
        print "$outfn\n" if $opt{l};
        $subfrag =~ s/$sel/$repl/mg if defined $repl;
        my $l = length($subfrag);
        warn "$l bytes for $outfn\n" if $opt{v};

        if ( !$opt{n} )
        {
          print OUT $subfrag;
          close OUT;
          # TO DO: keep the fds open when -a is used!
        }
      }
    }
  }
}