#!/usr/bin/perl -w

use strict;
use File::Copy      qw< copy move >;
use File::Spec      qw< >;

my $TmpDir= File::Spec->tmpdir();
my $IsDOS= $^O =~ /Win32/;
my $Editor= $ENV{VISUAL} || $ENV{EDITOR};
my $Quiet= 0;       # Don't echo each operation
my $Ask= 0;         # Ask before overwriting a file
my $Overwrite= 0;   # Default to overwriting files
my $Pause= 0;       # User must hit "Enter" before editor is launched
my $Self= ( $0 =~ m-(?:^|[/\\])([^/\\]+?)(?:\.[^/\\.]*)?$- )[0] || $0;

Main( @ARGV );
exit;


sub Def
{
    my $ret;
    do {
        $ret= shift @_;
    } while(  ! defined $ret  &&  @_  );
    return $ret;
}


sub IllegalName
{
    my( $file )= @_;
    return $file =~ /^\s|\s\s|[^ -~]|\s$/;
}


sub DumpStr
{
    my( $str )= @_;
    require Data::Dumper;
    for(  Data::Dumper->new([$str],['x'])->Terse(1)->Useqq(1)->Dump()  ) {
        s/^"//;
        s/"\s*\z//;
        return $_;
    }
}


sub PreProcessFiles
{
    for my $file (  @_  ) {
        if(  IllegalName( $file )  ) {
            $Pause= 1;
            my $desc= DumpStr( $file );
            ( my $clean= $file ) =~ s/[^ -~]+//g;
            $clean =~ s/(^)? +(\z)?/Def($1,$2,' ')/eg;
            if(  $file !~ /\0/  &&  -e $file  &&  $clean  &&  ! -e $clean  ) {
                warn "Removing bad characters/spaces from filename ($desc)!\n";
                rename( $file, $clean )
                    or  die "Can't clean filename ($desc) to $clean: $!\n";
                $file= $clean;
            } else {
                die "Bad file name ($desc) but won't be renamed!\n";
            }
        }
        if(  ! -e $file  ) {
            $file= "# No such file: $file";
        } else {
            $file .= '/'
                if(  -d $file  &&  $file !~ m-[/\\]$-  );
            $file= "=$file";
        }
    }
}


sub WriteWorkFile
{
    my( $workfile, @files )= @_;

    open TMP, '>', $workfile
        or  die "Can't create $workfile: $!\n";
    print TMP <<"END", join "\n", @files, '';
# Edit to rename file, "D=file" deletes, "L=dest" links, "C=dest" copies.
# Insert "MD=dir" line to make a new directory.
# Save no edits or empty file to abort.
END
    close TMP;
}


sub MakeNewDirs
{
    my( @newDirs )= @_;
    for my $dir (  @newDirs  ) {
        if(  -d $dir  ) {
            warn "mkdir $dir: Already exists.\n";
        } elsif(  mkdir( $dir )  ) {
            warn "mkdir $dir\n";
        } else {
            warn "Can't mkdir $dir: $!\n";
        }
    }
}


sub ReadWorkFile
{
    my( $avNew, $avFiles, $workfile )= @_;

    open TMP, '<', $workfile
        or  die "Can't read $workfile: $!\n";
    s/\s*\z//
        for my @lines= <TMP>;
    close TMP;

    my @newDirs;
    @lines= grep {
        if(  ! /\S/  ||  /^\s*#/  ) {
            0;
        } elsif(  /^\s*MD\s*=\s*(\S.*)/i  ) {
            push @newDirs, $1;
            0;
        } else {
            1;
        }
    } @lines;
    @$avFiles= grep ! /^\s*#/, @$avFiles;
    die "Aborting (further) changes.\n"
        if(  ! @lines  );
    die "Don't delete ", @$avFiles - @lines, " (non-comment) lines!\n"
        if(  @lines < @$avFiles  );
    die "Don't insert ", @lines - @$avFiles, " (non-comment) lines!\n"
        if(  @$avFiles < @lines  );

    MakeNewDirs( @newDirs );

    @$avNew= @lines;
}


sub DeletedFile
{
    my( $old, $new, $idx, $hvOld, $hvCnt, $op )= @_;
    if(  $new =~ /^\s*D\s*=\s*(\S.*)/i  ) {
        die "Mis-edit from (=$old) to ($new).\n"
            if(  $1 ne $old  );
        warn "rm $old\n"
            if  ! $Quiet;
        if(  ! unlink( $old )  ) {
            warn "Can't delete $old: $!\n";
        } else {
            $hvCnt->{rm}++;
        }
        return 1;
    }
    my $dest= $new;
    if(  $dest !~ s/^\s*(?:([a-z]+)\s*)?=\s*//i  ) {
        warn "Ignoring mis-edit from (=$old) to ($new).\n";
        return 1;
    }
    if(  ! $1  ) {
        return 1
            if(  $old eq $dest  );
        $hvOld->{ $old }= $idx || '00';
    } else {
        $op= uc( $1 );
        if(  $op !~ /^[CL]$/  ) {
            warn "Ignoring unrecognized directive ($op) in ($new)\n";
            return 1;
        }
    }
    if(  IllegalName( $dest )  ) {
        $dest= DumpStr( $dest );
        warn "Bad characters in destination ($dest); skipping.\n";
        return 1;
    }
    $_[1]= $dest;
    $_[-1]= $op;
    return 0;
}


sub DeleteFiles
{
    my( $avFiles, $avNew, $avOp, $hvOld, $hvCnt )= @_;

    s/^=//
        for  @$avFiles;
    my @idx= grep
        ! DeletedFile(
            $avFiles->[$_], $avNew->[$_],
            $_, $hvOld, $hvCnt, $avOp->[$_],
        ),
        0 .. $#$avNew;

    return @idx;
}


sub Summarize
{
    my( $hvCnt )= @_;
    my %desc= (
        mv => 'Renamed',
        ln => 'Linked',
        cp => 'Copied',
        rm => 'Deleted',
    );
    my $sum= '';
    %$hvCnt= ( mv => 0 )
        if  ! %$hvCnt;
    for my $key (  sort keys %$hvCnt  ) {
        my $desc= $desc{$key} || $key;
        $sum .= "$desc $hvCnt->{$key}, ";
    }
    $sum =~ s/, $/ files.\n/;
    warn $sum;
}


sub OverWriteFile
{
    my( $new )= @_;
    my $overwrite= $Overwrite;
    if(  $Ask  ) {
        my $default= $overwrite ? 'Yes/n/a/z/?' : 'y/No/a/z/?';
        my $answer= '?';
        while(  '?' eq $answer  ) {
            print STDERR "Overwrite $new? ($default): ";
            defined( $answer= <STDIN> )
                or  die "Error reading response.\n";
            if(  $answer =~ /^\s*y(es)?\s*$/i  ) {
                $overwrite= 1;
            } elsif(  $answer =~ /^\s*no?\s*$/i  ) {
                $overwrite= 0;
            } elsif(  $answer =~ /^\s*a(lways)?\s*$/i  ) {
                $overwrite= $Overwrite= 1;
                $Ask= 0;
            } elsif(  $answer =~ /^\s*z(ero)?\s*$/i  ) {
                $overwrite= $Overwrite= 0;
                $Ask= 0;
            } elsif(  $answer !~ /\S/  ) {
                ;   # Just use default
            } else {
                $answer= '?';   # Ask again
                warn "Please answer: 'Yes', 'No', 'All', 'Zero', or blank\n";
            }
        }
    }
    if(  ! $overwrite  ) {
        warn "Won't overwrite $new.\n";
        return;
    }
    my $temp= TempFile( $new );
    if(  ! rename( $new, $temp )  ) {
        warn "Can't rename $new to $temp: $!\n";
        warn "Won't overwrite $new.\n";
        return;
    }
    return $temp;
}


sub ProcessFile
{
    my( $op, $file, $new, $hvOld, $hvCnt )= @_;
    my $temp;
    if(  -e $new  ) {
        $temp= OverWriteFile( $new );
        return
            if  ! $temp;
    }
    my $did= '';
    if(  ! $op  ) {
        # Are there still cases /bin/mv handles that rename() doesn't?
        warn "mv $file $new\n"
            if  ! $Quiet;
        if(  ! rename( $file, $new )  ) {
            warn "Can't rename $file to $new: $!\n";
        } else {
            $did= 'mv';
            delete $hvOld->{ $file };
        }
    } elsif(  'L' eq $op  ) {
        warn "ln $file $new\n"
            if  ! $Quiet;
        if(  ! link( $file, $new )  ) {
            warn "Can't link $file to $new: $!\n";
        } else {
            $did= 'ln';
        }
    } elsif(  'C' eq $op  ) {
        # I'm tempted by system("/bin/cp","-p",...) if -x /bin/cp
        warn "cp $file $new\n"
            if  ! $Quiet;
        if(  ! copy( $file, $new )  ) {
            warn "Can't copy $file to $new: $!\n";
        } else {
            $did= 'cp';
        }
    } else {
        die "Impossible operation ($op) for $file.\n";
    }
    if(  $did  ) {
        $hvCnt->{$did}++;
        unlink( $temp )
            or  warn "Can't delete $temp: $!\n"
            if  $temp;
    } else {
        rename( $temp, $new )
            or  warn "Can't restore $temp to $new: $!\n"
            if  $temp;
    }
}


sub TempFile
{
    my( $path )= @_;
    my( $vol, $dir, $file )= File::Spec->splitpath( $path );
    my $t= 0;
    my $temp;
    do {
        $temp= File::Spec->catpath( $vol, $dir, "mvi$t-$file" );
        $t++
    } while(  -e $temp  );
    return $temp;
}


sub ProcessEdits
{
    my( $workfile, @files )= @_;

    my @new;
    ReadWorkFile( \@new, \@files, $workfile );

    my @op;
    my %old;
    my %cnt;

    my @idx= DeleteFiles( \@files, \@new, \@op, \%old, \%cnt );

    while(  @idx  ) {
        my $count= 0+@idx;
        @idx= grep {
            if(  $old{ $new[$_] }  ) {
                # Delay this op until our destination gets moved
                1;
            } else {
                ProcessFile( $op[$_], $files[$_], $new[$_], \%old, \%cnt );
                0;
            }
        } @idx;
        if(  $count == 0+@idx  ) {
            # Didn't make any progress, so split a rename loop:
            #         a -> mvi0-a
            # a -> b  mvi0-a -> b
            # b -> a
            keys %old;
            my $i= ( each %old )[1];
            my $j= 0+@files;
            $old{ $files[$i] }= $j;
            $files[$j]= $files[$i];
            $new[$j]= TempFile( $files[$i] );
            $files[$i]= $new[$j];
            unshift @idx, $j;
        }
    }
    Summarize( \%cnt );
}


sub BeforeEditor
{
    my( $workfile )= @_;
    if(  $Pause  ) {
        warn "(Exit forthcoming editor to continue.)\n";
        print STDERR "Press Enter to launch $Editor $workfile: ";
        my $wait= <STDIN>;
    } elsif(  ! $Quiet  ) {
        warn " ] $Editor $workfile\n";
        warn "(Exit editor to continue.)\n";
    }
}


sub FindCmd
{
    my( @cmds )= @_;
    my @exts= !$IsDOS ? () :
        split ';', $ENV{PATHEXT} || '.COM;.EXE;.BAT;.CMD';
    for my $bin (  File::Spec->path()  ) {
        for my $cmd (  @cmds  ) {
            my( $file )= split ' ', $cmd;
            $file= File::Spec->catfile( $bin, $file );
            if(  -x $file  ) {
                return $cmd;
            }
            for my $ext (  @exts  ) {
                if(  -f $file.$ext  ) {
                    return $cmd;
                }
            }
        }
    }
    return '';
}


sub Usage
{
    my( @message )= @_;
    warn @message, $/
        if  @message;
    $Editor ||= "anEditor";
    my $item= $IsDOS ? "wildcard" : "filename";
    warn <<"END";
Usage: $Self [-aoq] [-] [--] [ $item [...] ]
    Lets you use $Editor to rename (or copy, delete, or link) files.
END
    exit 1
        if(  @message  );
    if(  $Pause  ) {
        warn "Set the EDITOR (or VISUAL) environment variable",
            " to your favorite editor.\n";
    }
    warn <<"END";
     -: Reads filenames from STDIN, one per line
    --: Treats remaining arguments as ${item}s
    -q: Quiet; don't describe each successful operation
    -o: Overwrite existing files (if no -a, then doesn't even ask)
    -a: Ask before overwriting existing files
    By default, refuses to overwrite existing files (and doesn't ask to)
END
    exit 1
}


sub CmdLine
{
    my( @args )= @_;
    while(  @args  &&  $args[0] =~ /^-/  ) {
        my $arg= shift @args;
        if(  '--' eq $arg  ) {
            last;
        }
        if(  '-' eq $arg  ) {
            chomp( my @input= <STDIN> );
            return @input, @args;
        }
        $arg =~ s/^-//;
        while(  '' ne $arg  ) {
            if(  $arg =~ s/^h//  ) {
                Usage( );
            } elsif(  $arg =~ s/^q//  ) {
                $Quiet= 1;
            } elsif(  $arg =~ s/^o//  ) {
                $Overwrite= 1;
            } elsif(  $arg =~ s/^a//  ) {
                $Ask= 1;
            } else {
                Usage( "Unrecognized option (-$arg)." );
            }
        }
    }
    return @args;
}


sub Main
{
    my @files= CmdLine( @_ );
    if(  ! $Editor  ) {
        # User didn't already pick an editor
        $Pause= 1;  # So delay before starting (possibly wrong) editor
        $Editor= FindCmd( "vim", "emacs -nw", "vi", "notepad" )
            or  die "Can't find an editor, ",
                    "please set EDITOR environment variable.\n";
    }
    if(  ! @files  ) {
        Usage( qq<Type "$Self -h" for more help.> );
    }
    if(  $IsDOS  ) {
        require File::Glob;
        File::Glob->import(
            qw< bsd_glob GLOB_NOCASE GLOB_NOCHECK GLOB_BRACE >,
        );
        my $flags= GLOB_NOCASE() | GLOB_NOCHECK() | GLOB_BRACE();
        @files= map bsd_glob($_,$flags), @files;
    }
    PreProcessFiles( @files );
    my $workfile= "$TmpDir/mvi$$.tmp";
    if(  $IsDOS  ) {
        $workfile =~ s-\\-/-g;  # Prevent vim from chdir'ing to $TmpDir
    }
    my $ok= eval {
        WriteWorkFile( $workfile, @files );
        BeforeEditor( $workfile );
        $!= 0;
        my $status= system( "$Editor $workfile" );
        if(  0 != $status  ) {
            my $sig= $status & 127;
            my $core= ( $status & 128 ) ? " (core dumped)" : '';
            my $exit= $status >> 8;
            my $error= "unknown reason";
            if(  -1 == $status  ) {
                $error= "$!" || "unknown error";
            } elsif(  $sig  ) {
                $error= "killed by sig $sig$core";
            } elsif(  $exit  ) {
                warn "Ignoring non-zero exit ($exit) from editor.\n";
                $error= '';
            }
            die "Error running '$Editor $workfile': $error.\n"
                if  $error;
        }
        ProcessEdits( $workfile, @files );
        1;
    };
    if(  ! $ok  ) {
        warn $@ || "Unknown failure!\n";
        sleep( 2 ); # So you can Ctrl-C to prevent unlink($workfile)
    }
    unlink( $workfile )
        or  warn "Can't remove $workfile: $!\n";
    return ! $ok;
}