package App::perlmv;
BEGIN {
  $App::perlmv::VERSION = '0.34';
}
# ABSTRACT: Rename files using Perl code.

use strict;
use warnings;
use Cwd qw(abs_path getcwd);
use File::Copy;
use File::Find;
use File::Path qw(make_path);
use File::Spec;
use Getopt::Long qw(:config no_ignore_case bundling);


sub new {
    my ($class) = @_;

    # determine home
    my $homedir;

    if ( $ENV{'TESTING_HOME'} ) {
        $homedir = $ENV{'TESTING_HOME'};
    } else {
        eval {
            require File::HomeDir;
            $homedir = File::HomeDir->my_home;
        };

        $homedir ||= $ENV{'HOME'};

        die "FATAL: Can't determine home directory\n" unless $homedir;
    }

    my $self = {
        dry_run         => 0,
        homedir         => $homedir,
        overwrite       => 0,
        process_dir     => 1,
        process_symlink => 1,
        recursive       => 0,
        verbose         => 0,
    };

    bless $self, $class;

    return $self;
}


sub parse_opts {
    my $self = shift;

    GetOptions(
        'c|check'         => \$self->{ 'check'         },
        'e|execute=s'     => \$self->{ 'code'          },
        'D|delete=s'      => \$self->{ 'delete'        },
        'd|dry-run'       => \$self->{ 'dry_run'       },
        'l|list'          => \$self->{ 'list'          },
        'M|mode=s'        => \$self->{ 'mode'          },
        'o|overwrite'     => \$self->{ 'overwrite'     },
        'p|parents'       => \$self->{ 'parents'       },
        'R|recursive'     => \$self->{ 'recursive'     },
        'r|reverse'       => \$self->{ 'reverse_order' },
        's|show=s'        => \$self->{ 'show'          },
        'v|verbose'       => \$self->{ 'verbose'       },
        'w|write=s'       => \$self->{ 'write'         },
        'f|files'         => sub { $self->{ 'process_dir'    } = 0 },
        'S|no-symlinks'   => sub { $self->{ 'process_symlink'} = 0 },
        'h|help'          => sub { $self->print_help()             },
        'V|version'       => sub { $self->print_version()          },
        '<>'              => sub { $self->parse_extra_opts(@_)     },
    ) or $self->print_help();
}

sub parse_extra_opts {
    my ( $self, $arg ) = @_;

    # do our own globbing in windows, this is convenient
    if ( $^O =~ /win32/i ) {
        if ( $arg =~ /[*?{}\[\]]/ ) { push @{ $self->{'items'} }, glob "$arg" }
        else { push @{ $self->{'items'} }, "$arg" }
    } else {
        push @{ $self->{'items'} }, "$arg";
    }
}

sub run {
    my $self = shift;

    $self->parse_opts();

    # -m is reserved for file mode
    my $default_mode =
        $0 =~ /perlcp/   ? 'copy'    :
        $0 =~ /perlln_s/ ? 'symlink' :
        $0 =~ /perlln/   ? 'link'    :
        'rename';

    $self->{'dry_run'} and $self->{'verbose'}++;
    $self->{'mode'} ||= $default_mode;

    if ( $self->{'list'} ) {
        $self->load_scriptlets();
        foreach my $key ( sort keys %{ $self->{'scriptlets'} } ) {
            print $self->{'verbose'}                        ?
                $self->format_scriptlet_source($key) . "\n" :
                "$key\n";
        }

        exit 0;
    }

    if ( $self->{'show'} ) {
        print $self->format_scriptlet_source( $self->{'show'} );
        exit 0;
    }

    if ( $self->{'write'} ) {
        $self->store_scriptlet( $self->{'write'}, $self->{'code'} );
        exit 0;
    }

    if ( $self->{'delete'} ) {
        $self->delete_user_scriptlet( $self->{'delete'} );
        exit 0;
    }

    unless ($self->{'code'}) {
        die 'FATAL: Must specify code (-e) or scriptlet name (first argument)'
            unless $self->{'items'};
        $self->{'code'} =
            $self->load_scriptlet( scalar shift @{ $self->{'items'} } );
    }
    exit 0 if $self->{'check'};

    die "FATAL: Please specify some files in arguments\n"
        unless $self->{'items'};

    $self->rename();
}

sub print_version {
    print "perlmv version $App::perlmv::VERSION\n";
    exit 0;
}

sub print_help {
    my $self = shift;
    print <<'USAGE';
Rename files using Perl code.

Usage:

 perlmv -h

 perlmv [options] <scriptlet> <file...>
 perlmv [options] -e <code> <file...>

 perlmv -e <code> -w <name>
 perlmv -l
 perlmv -s <name>
 perlmv -D <name>

Options:

 -c  (--compile) Only test compile code, do not run it on the arguments
 -e <CODE> (--execute) Specify code to rename file (\$_), e.g.
     's/\.old\$/\.bak/'
 -D <NAME> (--delete) Delete scriptlet
 -d  (--dry-run) Dry-run (implies -v)
 -f  (--files) Only process files, do not process directories
 -h  (--help) Show this help
 -l  (--list) list all scriptlets
 -M <MODE> (--mode) Specify mode, default is 'rename' (or 'r'). Use
     'copy' or 'c' to copy instead of rename, 'symlink' or 's' to create
     a symbolic link, and 'link' or 'l' to create a (hard) link.
 -o  (--overwrite) Overwrite (by default, ".1", ".2", and so on will be
     appended to avoid overwriting existing files)
 -p  (--parents) Create intermediate directories
 -R  (--recursive) Recursive
 -r  (--reverse) reverse order of processing (by default order is
     asciibetically)
 -S  (--no-symlinks) Do not process symlinks
 -s <NAME> (--show) Show source code for scriptlet
 -V  (--version) Print version and exit
 -v  (--verbose) Verbose
 -w <NAME> (--write) Write code specified in -e as scriptlet

USAGE

    exit 0;
}

sub load_scriptlet {
    my ( $self, $name ) = @_;
    $self->load_scriptlets();
    die "FATAL: Can't find scriptlet `$name`"
        unless $self->{'scriptlets'}{$name};
    return $self->{'scriptlets'}{$name}{'code'};
}

sub load_scriptlets {
    my ($self) = @_;
    $self->{'scriptlets'} ||= $self->find_scriptlets();
}

sub find_scriptlets {
    my ($self) = @_;
    my $res    = {};

    eval { require App::perlmv::scriptlets::std };
    if (%App::perlmv::scriptlets::std::scriptlets) {
        $res->{$_} = { code => $App::perlmv::scriptlets::std::scriptlets{$_},
                       from => "App::perlmv::scriptlets::std.pm" }
            for keys %App::perlmv::scriptlets::std::scriptlets;
    }

    eval { require App::perlmv::scriptlets };
    if (%App::perlmv::scriptlets::scriptlets) {
        $res->{$_} = { code => $App::perlmv::scriptlets::scriptlets{$_},
                       from => "App::perlmv::scriptlets.pm" }
            for keys %App::perlmv::scriptlets::scriptlets;
    }

    if (-d "/usr/share/perlmv/scriptlets") {
        local $/;
        for (glob "/usr/share/perlmv/scriptlets/*") {
            my $name = $_; $name =~ s!.+/!!;
            open my($fh), $_;
            my $code = <$fh>;
            $res->{$name} = { code => $code, from => $_ }
                if $code;
        }
    }

    if (-d "$self->{homedir}/.perlmv/scriptlets") {
        local $/;
        for (glob "$self->{homedir}/.perlmv/scriptlets/*") {
            my $name = $_; $name =~ s!.+/!!;
            open my($fh), $_;
            my $code = <$fh>;
            $res->{$name} = { code => $code, from => $_ }
                if $code;
        }
    }

    $res;
}

sub valid_scriptlet_name {
    my ($self, $name) = @_;
    $name =~ m/^[A-Za-z_][0-9A-Za-z_-]*$/;
}

sub store_scriptlet {
    my ($self, $name, $code) = @_;
    die "FATAL: Invalid scriptlet name `$name`\n"
        unless $self->valid_scriptlet_name($name);
    die "FATAL: Code not specified\n" unless $code;
    my $path = "$self->{homedir}/.perlmv";
    unless (-d $path) {
        mkdir $path or die "FATAL: Can't mkdir `$path`: $!\n";
    }
    $path .= "/scriptlets";
    unless (-d $path) {
        mkdir $path or die "FATAL: Can't mkdir `$path: $!\n";
    }
    $path .= "/$name";
    unless ((-e $path) && !$self->{'overwrite'}) {
        mkdir $path or die "FATAL: Can't overwrite `$path (use -o)\n";
    }
    open my($fh), ">", $path;
    print $fh $code;
    close $fh or die "FATAL: Can't write to $path: $!\n";
}

sub delete_user_scriptlet {
    my ($self, $name) = @_;
    unlink "$self->{homedir}/.perlmv/scriptlets/$name";
}

sub compile_code {
    my ($self) = @_;
    my $code = $self->{'code'};
    no strict;
    no warnings;
    local $_ = "-TEST";
    $App::perlmv::code::TESTING = 1;
    eval "package App::perlmv::code; $code";
    die "FATAL: Code doesn't compile: code=$code, errmsg=$@\n" if $@;
}

sub run_code {
    my ($self) = @_;
    my $code = $self->{'code'};
    no strict;
    no warnings;
    $App::perlmv::code::TESTING = 0;
    my $orig_ = $_;
    # It does need a package declaration to run it in App::perlmv::code
    my $res = eval "package App::perlmv::code; $code";
    die "FATAL: Code doesn't compile: code=$code, errmsg=$@\n" if $@;
    if (defined($res) && length($res) && $_ eq $orig_) { $_ = $res }
}

sub process_items {
    my ($self, @items) = @_;
    @items = $self->{'reverse_order'} ? (reverse sort @items) : (sort @items);
    for my $item (@items) {
        next if !$self->{'process_symlink'} && (-l $item);
        if (-d _) {
            next unless $self->{'process_dir'};
            if ($self->{'recursive'}) {
                my $cwd = getcwd();
                if (chdir $item) {
                    print "INFO: chdir `$cwd/$item` ...\n" if $self->{'verbose'};
                    local *D;
                    opendir D, ".";
                    my @d = grep { $_ ne '.' && $_ ne '..' } readdir D;
                    closedir D;
                    $self->process_items(@d);
                    chdir $cwd or die "FATAL: Can't go back to `$cwd`: $!\n";
                } else {
                    warn "WARN: Can't chdir to `$cwd/$item`, skipped\n";
                }
            }
        }
        $self->process_item($item, \@items);
    }
}

sub process_item {
    my ($self, $filename, $items) = @_;

    local $_ = $filename;
    $App::perlmv::code::FILES = $items;
    my $old = $filename;
    $self->run_code();
    my $new = $_;

    return if abs_path($old) eq abs_path($new);

    my $cwd = getcwd();
    my $orig_new = $new;
    unless ($self->{'overwrite'}) {
        my $i = 1;
        while (1) {
            if ((-e $new) || exists $self->{_exists}{"$cwd/$new"}) {
                $new = "$orig_new.$i";
                $i++;
            } else {
                last;
            }
        }
        $self->{_exists}{"$cwd/$new"}++;
    }
    my $action;
    if (!defined($self->{mode}) || $self->{mode} =~ /^(rename|r)$/) {
        $action = "rename";
    } elsif ($self->{mode} =~ /^(copy|c)$/) {
        $action = "copy";
    } elsif ($self->{mode} =~ /^(symlink|sym|s)$/) {
        $action = "symlink";
    } elsif ($self->{mode} =~ /^(hardlink|h|link|l)$/) {
        $action = "link";
    } else {
        die "Unknown mode $self->{mode}, please use one of: ".
            "rename (r), copy (c), symlink (s), or link (l).";
    }
    print "DRYRUN: " if $self->{dry_run};
    print "$action `$old` -> `$new`\n" if $self->{verbose};
    unless ($self->{dry_run}) {
        my $res;

        if ($self->{'parents'}) {
            my ($vol, $dir, $file) = File::Spec->splitpath($new);
            unless (-e $dir) {
                make_path($dir, {error => \my $err});
                for (@$err) {
                    my ($file, $message) = %$_;
                    warn "ERROR: Can't mkdir `$dir`: $message" .
                        ($file eq '' ? '' : " ($file)") . "\n";
                }
                return if @$err;
            }
        }

        my $err = "";
        if ($action eq 'rename') {
            $res = rename $old, $new;
            $err = $! unless $res;
        } elsif ($action eq 'copy') {
            $res = copy $old, $new;
            $err = $! unless $res;
            # XXX copy mtime, ctime, etc
        } elsif ($action eq 'symlink') {
            $res = symlink $old, $new;
            $err = $! unless $res;
        } elsif ($action eq 'link') {
            $res = link $old, $new;
            $err = $! unless $res;
        }
        warn "ERROR: $action failed `$old` -> `$new`: $err\n" unless $res;
    }
}

sub format_scriptlet_source {
    my ($self, $name) = @_;
    $self->load_scriptlets();
    die "FATAL: Scriptlet `$name` not found\n"
        unless $self->{scriptlets}{$name};
    "### Name: $name (from ", $self->{scriptlets}{$name}{from}, ")\n" .
    $self->{scriptlets}{$name}{code} .
    ($self->{scriptlets}{$name}{code} =~ /\n\z/ ? "" : "\n");
}

sub rename {
    my ($self, @args) = @_;
    my @items;
    if (@args) {
        @items = @args;
    } else {
        @items  = @{ $self->{'items'} // [] };
    }

    $self->compile_code();
    $self->{_exists} = {};
    $self->process_items(@items);
}

1;

__END__
=pod

=head1 NAME

App::perlmv - Rename files using Perl code.

=head1 VERSION

version 0.34

=for Pod::Coverage .+

=head1 AUTHOR

  Steven Haryanto <stevenharyanto@gmail.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Steven Haryanto.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

