File Coverage

blib/lib/Dir/Split.pm

Criterion	Covered	Total	%
statement	140	189	74.0
branch	13	42	30.9
condition	5	15	33.3
subroutine	29	32	90.6
pod	4	4	100.0
total	191	282	67.7

package Dir::Split;

use strict;
use warnings;
use boolean qw(true false);

use Carp qw(croak);
use File::Basename ();
use File::Copy ();
use File::Find ();
use File::Path ();
use File::Spec ();
use Params::Validate ':all';

our $VERSION = '0.80_02';

validation_options(
    on_fail => sub
{
    my ($error) = @_;
    chomp $error;
    croak $error;
},
    stack_skip => 2,
);

my %num_presets = (
    verbose   => false,
    override  => false,
    sort      => 'asc',
    limit     => 5,
    prefix    => 'sub',
    separator => '-',
    continue  => false,
    length    => 5,
);
my %char_presets = (
    verbose   => false,
    override  => false,
    prefix    => 'sub',
    separator => '-',
    case      => 'upper',
    length    => 1,
);

sub new
{
    my $class = shift;

    my $self = bless {}, ref($class) || $class;

    $self->_init(@_);

    return $self;
}

sub _init
{
    my $self = shift;
    my %opts = @_;

    validate(@_, {
        source => {
            type => SCALAR,
            callbacks => {
                'directory exists' => sub { -d $_[0] }
            },
        },
        target => {
            type => SCALAR,
            callbacks => {
                'directory exists' => sub { -d $_[0] }
            },
        },
    });

    foreach my $opt (qw(source target)) {
        $self->{ucfirst $opt} = $opts{$opt};
    }
}

sub split_num
{
    my $self = shift;

    $self->_validate_num(@_);

    $self->_init_mode(@_, \%num_presets);

    my ($dirs, $files) = $self->_gather_files;
    $self->_sort_files($files);

    my $suffix = $self->_get_num_suffix;
    $self->_move_num($files, $suffix);
}

sub _validate_num
{
    my $self = shift;

    validate(@_, {
        verbose => {
            type => BOOLEAN,
            optional => true,
        },
        override => {
            type => BOOLEAN,
            optional => true,
        },
        sort => {
            type => SCALAR,
            optional => true,
            regex => qr!^(?:asc|desc)$!,
        },
        limit => {
            type => SCALAR,
            optional => true,
            regex => qr!^\d+$!,
        },
        prefix => {
            type => SCALAR,
            optional => true,
            regex => qr!^\S+$!,
        },
        separator => {
            type => SCALAR,
            optional => true,
            regex => qr!^\S+$!,
        },
        continue => {
            type => BOOLEAN,
            optional => true,
        },
        length => {
            type => SCALAR,
            optional => true,
            regex => qr!^\d+$!,
        },
    });
}

sub split_char
{
    my $self = shift;

    $self->_validate_char(@_);

    $self->_init_mode(@_, \%char_presets);

    my ($dirs, $files) = $self->_gather_files;

    my %suffixes;
    $self->_get_char_suffixes($files, \%suffixes);
    $self->_move_char(\%suffixes);
}

sub _validate_char
{
    my $self = shift;

    validate(@_, {
        verbose => {
            type => BOOLEAN,
            optional => true,
        },
        override => {
            type => BOOLEAN,
            optional => true,
        },
        prefix => {
            type => SCALAR,
            optional => true,
            regex => qr!^\S+$!,
        },
        separator => {
            type => SCALAR,
            optional => true,
            regex => qr!^\S+$!,
        },
        case => {
            type => SCALAR,
            optional => true,
            regex => qr!^(?:lower|upper)$!,
        },
        length => {
            type => SCALAR,
            optional => true,
            regex => qr!^\d+$!,
        },
    });
}

sub _init_mode
{
    my $self = shift;
    my $presets = pop;
    my %opts = @_;

    delete @$self{qw(exists failure track)};

    foreach my $opt (keys %num_presets, keys %char_presets) {
        delete $self->{ucfirst $opt};
    }
    foreach my $opt (keys %$presets) {
        $self->{ucfirst $opt} = $presets->{$opt};
    }
    foreach my $opt (keys %opts) {
        $self->{ucfirst $opt} = $opts{$opt};
    }

    $self->{track}{target}{dirs}  = 0;
    $self->{track}{target}{files} = 0;
}

sub _gather_files
{
    my $self = shift;

    my (@dirs, @files);

    File::Find::find({
        wanted => sub {
            push @dirs,  $File::Find::name if -d $_;
            push @files, $File::Find::name if -f $_;
        },
    }, $self->{Source});

    shift @dirs; # remove top-level directory

    $self->{track}{source}{dirs}  = scalar @dirs;
    $self->{track}{source}{files} = scalar @files;

    return (\@dirs, \@files);
}

sub _sort_files
{
    my $self = shift;
    my ($files) = @_;

    my %sort = (
        asc  => 'lc File::Basename::basename($a) cmp lc File::Basename::basename($b)',
        desc => 'lc File::Basename::basename($b) cmp lc File::Basename::basename($a)',
    );

    my $cmp = $sort{$self->{Sort}};

    @$files = sort { eval $cmp } @$files;
}

sub _get_num_suffix
{
    my $self = shift;

    if ($self->{Continue}) {
        my @dirs;
        $self->_read_dir($self->{Target}, \@dirs);

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

        my $continue = 0;

        foreach my $dir (@dirs) {
            if ($dir =~ /^(.+?)\Q$self->{Separator}\E([0-9]+)$/) {
                my ($prefix, $suffix) = ($1, $2);
                if ($prefix eq $self->{Prefix}
                 && length $suffix == $self->{Length}
                 && $suffix > $continue
                ) {
                    $continue = $suffix;
                }
            }
        }
        return sprintf "%0.$self->{Length}d", ++$continue;
    }
    else {
        return sprintf "%0.$self->{Length}d", 1;
    }
}

sub _get_char_suffixes
{
    my $self = shift;
    my ($files, $suffixes) = @_;

    my %alter = (
        lower => sub { lc $_[0] },
        upper => sub { uc $_[0] },
    );

    foreach my $file (@$files) {
        my $suffix = do {
            local $_ = File::Basename::fileparse($file, qr/(?<=\S)\.[^.]*/); # returns filename
            s/\s//g;
            $_ = substr($_, 0, $self->{Length});
            $alter{$self->{Case}}->($_);
        };
        push @{$suffixes->{$suffix}}, $file;
    }
}

sub _move_num
{
    my $self = shift;
    my ($files, $suffix) = @_;

    while (@$files) {
        my $target_path = $self->_make_path($suffix);
        my $copied = 0;
        my %seen;
        while ($copied < $self->{Limit} && @$files) {
            my $file = shift @$files;
            my $basename = File::Basename::basename($file);
            if ($seen{$basename}) {
                $self->_copy($file, $self->_make_path($suffix, $seen{$basename}));
            }
            else {
                $self->_copy($file, $target_path);
            }
            $seen{$basename}++;
            $copied++;
        }
        $suffix++;
    }
}

sub _move_char
{
    my $self = shift;
    my ($suffixes) = @_;

    foreach my $suffix (sort keys %$suffixes) {
        my $target_path = $self->_make_path($suffix);
        my %seen;
        while (my $file = shift @{$suffixes->{$suffix}}) {
            my $basename = File::Basename::basename($file);
            if ($seen{$basename}) {
                $self->_copy($file, $self->_make_path($suffix, $seen{$basename}));
            }
            else {
                $self->_copy($file, $target_path);
            }
            $seen{$basename}++;
        }
    }
}

sub _make_path
{
    my $self = shift;
    my ($suffix, $seen) = @_;

    my $target_path = File::Spec->catfile($self->{Target}, "$self->{Prefix}$self->{Separator}$suffix", defined $seen ? $seen : ());

    if (-e $target_path) {
        croak "Target path `$target_path' is not a directory" unless -d $target_path;
        return $target_path;
    }

    if (File::Path::mkpath($target_path, $self->{Verbose})) {
        $self->{track}{target}{dirs}++;
    }
    else {
        croak "Target directory `$target_path' cannot be created: $!";
    }

    return $target_path;
}

sub _copy
{
    my $self = shift;
    my ($file, $target_path) = @_;

    my $source_file = $file;
    my $target_file = File::Spec->catfile($target_path, File::Basename::basename($file));

    if (-e $target_file && !$self->{Override}) {
        push @{$self->{exists}}, $target_file;
        return;
    }

    if (File::Copy::copy($source_file, $target_file)) {
        print "copy $source_file -> $target_file\n" if $self->{Verbose};
        $self->{track}{target}{files}++;
    }
    else {
        push @{$self->{failure}{copy}}, $target_file;
    }
}

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

    opendir(my $dh, $dir) or croak "Cannot open directory `$dir': $!";
    @$files = grep !/^\.\.?$/, readdir($dh);
    closedir($dh) or croak "Cannot close directory `$dir': $!";
}

sub print_summary
{
    my $self = shift;

    return unless exists $self->{track};

    my %track = %{$self->{track}};

    my @output = (
        [ 'dirs',  $track{source}{dirs},  $track{target}{dirs}  ],
        [ 'files', $track{source}{files}, $track{target}{files} ],
    );

    format STDOUT_TOP =
Type      Source    Target
==========================
.
    foreach my $line (@output) {
        format STDOUT =
@<<<<<    @<<<<<    @<<<<<
@$line
.
        write;
    }
    print "\n";

    if (@{$self->{exists} || []}) {
        print <<'EOT';
Existing files
==============
EOT
        foreach my $file (@{$self->{exists}}) {
            print $file, "\n";
        }
        print "\n";
    }
    if (@{$self->{failure}{copy} || []}) {
        print <<'EOT';
Copy failures
=============
EOT
        foreach my $file (@{$self->{failure}{copy}}) {
            print $file, "\n";
        }
    }
}

1;
__END__