Dir::Split - Split files of a directory to subdirectories

 use Dir::Split;

 # example arguments
 $dir = Dir::Split->new(
     mode    =>    'num',

     source  =>    '/source',
     target  =>    '/target',

     verbose     =>        1,
     override    =>        0,

     identifier  =>    'sub',
     file_limit  =>        2,
     file_sort   =>      '+',

     separator   =>      '-',
     continue    =>        1,
     length      =>        5,
 );

 $retval = $dir->split_dir;

 # example arguments
 $dir = Dir::Split->new(
     mode    =>    'num',

     source  =>    '/source',
     target  =>    '/target',

     verbose     =>        1,
     override    =>        0,

     identifier  =>    'sub',
     file_limit  =>        2,
     file_sort   =>      '+',

     separator   =>      '-',
     continue    =>        1,
     length      =>        5,
 );

 $dir = Dir::Split->new(%args);

 $retval = $dir->split_dir;

  1 / $ACTION           Files splitted

  0 / $NOACTION         No action

 -1 / $EXISTS           Files exist
                        (see OPTIONS / debug)

 -2 / $FAILURE          Failure
                        (see OPTIONS / debug)

 %args = (
     mode    =>    'num',

     source  =>    '/source',
     target  =>    '/target',

     verbose     =>        1,
     override    =>        0,

     identifier  =>    'sub',
     file_limit  =>        2,
     file_sort   =>      '+',

     separator   =>      '-',
     continue    =>        1,
     length      =>        5,
 );

 %args = (
     mode    =>    'char',

     source  =>    '/source',
     target  =>    '/target',

     verbose     =>         1,
     override    =>         0,

     identifier  =>     'sub',

     separator   =>       '-',
     case        =>   'upper',
     length      =>         1,
 );

 %Dir::Split::track = (
     source  =>    {  files  =>    512
     },
     target  =>    {  dirs   =>    128,
                      files  =>    512,
     },
 );

 file    @Dir::Split::exists    # Existing files, not attempted to
                                # be overwritten.

 file    @{$Dir::Split::failure{copy}}      # Files that couldn't be copied,
                                            # most often on overriding failures.

         @{$Dir::Split::failure{unlink}}    # Files that could be copied but not unlinked,
                                            # rather seldom.

 # Unlink files in flat source
 $Dir::Split::UNLINK = 1;

 # Traversal mode
 $Dir::Split::TRAVERSE = 1;

 # Unlink files in source
 $Dir::Split::TRAVERSE_UNLINK = 1;

 # Remove directories in source
 $Dir::Split::TRAVERSE_RMDIR = 1;

 # Remove the source directory itself
 $Dir::Split::TRAVERSE_RMDIR_SOURCE = 1;

 +- _123
 +- abcd
 +- efgh
 +- ijkl
 +- mnop

 +- sub-00001
 +-- _123
 +-- abcd
 +- sub-00002
 +-- efgh
 +-- ijkl
 +- sub-00003
 +-- mnop

 +- sub-_
 +-- _123
 +- sub-a
 +-- abcd
 +- sub-e
 +-- efgh
 +- sub-i
 +-- ijkl
 +- sub-m
 +-- mnop

package Dir::Split;

use strict;
use warnings;
use base qw(Exporter);

use Carp qw(croak);
use File::Basename ();
use File::Copy ();
use File::Find ();
use File::Path ();
use File::Spec ();
use SelfLoader;

our ($VERSION,
     @EXPORT,

     $NOACTION,                # return values
     $ACTION,
     $EXISTS,
     $FAILURE,
     $ADJUST,

     $UNLINK,                  # external options
     $TRAVERSE,
     $TRAVERSE_UNLINK,
     $TRAVERSE_RMDIR,
     $TRAVERSE_RMDIR_SOURCE,

     @exists,                  # external data
     %failure,
     %track);

$VERSION = '0.80';

@EXPORT = qw(
    $NOACTION
    $ACTION
    $EXISTS
    $FAILURE
    $ADJUST
);

$NOACTION =    0;
$ACTION   =    1;
$EXISTS   =   -1;
$FAILURE  =   -2;
$ADJUST   = -255;

sub new
{
    my ($self, @opt) = @_;
    my $class = ref($self) || $self;

    my %blessed;
    %{$blessed{OPT}} = @opt;

    return bless(\%blessed, $class);
}

sub split_dir
{
    my $self = shift;

    $self->_sanity_input;
    $self->_gather_files;

    my $RetVal = $NOACTION;

    if ($self->{files}) {
        $RetVal = $ACTION;

        $self->_sort_files if $self->{OPT}{mode} eq 'num';
        $self->_suffix;
        $self->_move;

        $self->_traversed_rmdir
          if $TRAVERSE && $TRAVERSE_RMDIR && $TRAVERSE_UNLINK;

        $RetVal = $EXISTS  if @exists;
        $RetVal = $FAILURE if %failure;
    }

    return $RetVal;
}

sub _sanity_input
{
    my $self = shift;

    if ($UNLINK && ($TRAVERSE || $TRAVERSE_UNLINK ||
        $TRAVERSE_RMDIR || $TRAVERSE_RMDIR_SOURCE)) {
        croak '$UNLINK and $TRAVERSE_* may not be combined';
    }

    my %generic = (
        mode        =>       '^(?:num|char)$',
        source      =>              'defined',
        target      =>              'defined',
        verbose     =>               '^[01]$',
        override    =>               '^[01]$',
        identifier  =>                  '\w+',
        separator   =>              'defined',
        length      =>                  '> 0',
    );

    my %num = (
        file_limit  =>                  '> 0',
        file_sort   =>               '^[+-]$',
        continue    =>               '^[01]$',
    );

    my %char = (
        case        =>    '^(?:lower|upper)$',
    );

    $self->_validate_input(\%generic);

    $self->{OPT}{mode} eq 'num'
      ? $self->_validate_input(\%num)
      : $self->_validate_input(\%char);
}

sub _validate_input
{
    my ($self, $args) = @_;

    while (my ($arg, $prove) = each %$args) {
        my $condition = "\$self->{OPT}{\$arg}";

        if ($prove ne 'defined' && $prove !~ /\d+$/) {
            $condition .= " =~ /$prove/";
        }
        no warnings 'uninitialized';
        my $match = eval "sub { $condition }"
          or die "Couldn't compile $condition: $@";

        croak "Option '$arg' not defined or invalid"
          unless &$match;
    }
}

sub _gather_files
{
    my $self = shift;

    if ($TRAVERSE) {
        $self->_traverse(\@{$self->{dirs}}, \@{$self->{files}});
    }
    else {
        $self->_read_dir(\@{$self->{files}}, $self->{OPT}{source});

        # Leave directories behind as we are in ``flat", non-traversal mode.
        @{$self->{files}} = grep { !-d File::Spec->catfile($self->{OPT}{source}, $_) } @{$self->{files}};
    }
    $track{source}{files} = @{$self->{files}};
}

sub _sort_files
{
    my $self = shift;

    my $cmp =
      $TRAVERSE
        ? $self->{OPT}{file_sort} eq '+'
          ? 'lc File::Basename::basename($a) cmp lc File::Basename::basename($b)'
          : 'lc File::Basename::basename($b) cmp lc File::Basename::basename($a)'
        : $self->{OPT}{file_sort} eq '+'
          ? 'lc $a cmp lc $b'
          : 'lc $b cmp lc $a';

    @{$self->{files}} = sort { eval $cmp } @{$self->{files}};
}

sub _suffix
{
    my $self = shift;

    if ($self->{OPT}{mode} eq 'num') {
        $self->_suffix_num_contin if $self->{continue};
        $self->_suffix_num_sum_up;
    }
    else {
        $self->_suffix_char;
    }
}

sub _suffix_num_contin
{
    my $self = shift;

    my @dirs;
    $self->_read_dir(\@dirs, $self->{OPT}{target});

    # Leave files behind as we need to evaluate names of subdirs.
    @dirs = grep { -d File::Spec->catfile($self->{OPT}{target}, $_) } @dirs;

    $self->{suffix} = 0;

    # Search for the highest numerical suffix of given identifier.
    foreach my $dir (@dirs) {
        my ($ident_cmp, $suff_cmp) = $dir =~ /(.+) \Q$self->{OPT}{separator}\E (.*)/ox;

        if ($self->{OPT}{identifier} eq $ident_cmp && $suff_cmp =~ /[0-9]/o) {
            $self->{suffix} = $suff_cmp if ($suff_cmp > $self->{suffix});
        }
    }
}

sub _suffix_num_sum_up
{
    my $self = shift;

    # In case, no previous suffix has been found,
    # set to 1, otherwise increment.
    $self->{suffix}++;

    if (length $self->{suffix} < $self->{OPT}{length}) {
        $self->{suffix} = sprintf("%0.$self->{OPT}{length}".'d', $self->{suffix});
    }
}

sub _suffix_char
{
    my $self = shift;

    while (my $file = shift @{$self->{files}}) {
        my $suffix = $TRAVERSE
          ? File::Basename::basename($file)
          : $file;

        $suffix =~ s/\s//g;
        $suffix = substr($suffix, 0, $self->{OPT}{length});

        if ($suffix =~ /\w/) {
            $suffix = $self->{OPT}{case} eq 'lower'
              ? lc $suffix : uc $suffix;
        }
        push @{$self->{file_suffix}{$suffix}}, $file;
    }
}

sub _move
{
    my $self = shift;

    $track{target}{dirs}  = 0;
    $track{target}{files} = 0;

    if ($self->{OPT}{mode} eq 'num') {
        $self->_move_num;
    }
    else {
        $self->_move_char;
    }
}

sub _move_num
{
    my $self = shift;

    for (; @{$self->{files}}; $self->{suffix}++) {
        $self->{target_path}  = $self->_mkpath;
        %{$self->{duplicate}} = ();

        for (my $copied = 0; $copied < $self->{OPT}{file_limit} && @{$self->{files}}; $copied++) {
            $self->{file} = shift @{$self->{files}};
            $self->_copy_unlink;
            $self->{duplicate}{File::Basename::basename($self->{file})}++;
        }
    }
}

sub _move_char
{
    my $self = shift;

    foreach my $suffix (sort keys %{$self->{file_suffix}}) {
        $self->{suffix}       = $suffix;
        $self->{target_path}  = $self->_mkpath;
        %{$self->{duplicate}} = ();

        while ($self->{file} = shift @{$self->{file_suffix}{$suffix}}) {
            $self->_copy_unlink;
            $self->{duplicate}{File::Basename::basename($self->{file})}++;
        }
    }
}

sub _mkpath
{
    my $self = shift;

    my $target_path = File::Spec->catfile
      ($self->{OPT}{target}, "$self->{OPT}{identifier}$self->{OPT}{separator}$self->{suffix}");

    return $target_path if -e $target_path;

    if (File::Path::mkpath($target_path, $self->{OPT}{verbose})) {
        $track{target}{dirs}++;
    }
    else {
        croak "Dir $target_path couldn't be created: $!";
    }

    return $target_path;
}

sub _copy_unlink
{
    my $self = shift;

    if ($TRAVERSE) {
        $self->{source_file} = $self->{file};
        $self->{target_file} = File::Spec->catfile($self->{target_path}, File::Basename::basename($self->{file}));
    }
    else {
        $self->{source_file} = File::Spec->catfile($self->{OPT}{source}, $self->{file});
        $self->{target_file} = File::Spec->catfile($self->{target_path}, $self->{file});
    }

    $self->{target_file} .= "_$self->{duplicate}{File::Basename::basename($self->{file})}"
      if $self->{duplicate}{File::Basename::basename($self->{file})};

    if ($self->_copy) {
        $track{target}{files}++;
        $self->_unlink;
    }
}

sub _copy
{
    my $self = shift;

    if ($self->_exists_and_not_override) {
        push @exists, $self->{target_file};
        return 0;
    }

    if (!(File::Copy::copy $self->{source_file}, $self->{target_file})) {
        push @{$failure{copy}}, $self->{target_file};
        return 0;
    }
    else {
        return 1;
    }
}

sub _unlink
{
    my $self = shift;

    if (!$UNLINK && !$TRAVERSE) {
        return;
    }
    elsif ($TRAVERSE) {
        return unless $TRAVERSE_UNLINK;
    }
    unless (unlink $self->{source_file}) {
        push @{$failure{unlink}}, $self->{source_file};
    }
}

sub _exists_and_not_override
{
    my $self = shift;

    return (-e $self->{target_file} && !$self->{OPT}{override})
      ? 1 : 0;
}

sub _read_dir
{
    my ($self, $items, $dir) = @_;

    opendir(my $dir_fh, $dir)
      or croak "Couldn't open dir $dir: $!";

    @$items = grep !/^(?:\.|\.\.)$/, readdir($dir_fh);

    closedir($dir_fh)
      or croak "Couldn't close dir $dir: $!";
}

1;
__DATA__

sub _traverse
{
    local ($self, $dirs, $files) = @_;

    my %opts = (
        wanted       =>    $self->can('_eval_files'),
        postprocess  =>    $self->can('_eval_dirs'),
    );

    File::Find::finddepth(\%opts, $self->{OPT}{source});
}

sub _eval_files
{
    my $self = shift;
    push @$files, $File::Find::name if -f $File::Find::name;
}

sub _eval_dirs
{
    my $self = shift;
    push @$dirs, $File::Find::dir;
}

sub _traversed_rmdir
{
    my $self = shift;

    if ($TRAVERSE_RMDIR && $TRAVERSE_UNLINK) {
        foreach my $dir (@{$self->{dirs}}) {
            next if $dir eq $self->{OPT}{source} && !$TRAVERSE_RMDIR_SOURCE;
            File::Path::rmtree($dir, 1, 1);
        }
    }
}

__END__