#!/usr/bin/perl
# Filename:     cpx/mvx
# Author:       David Ljung <dljung>
# Description:  Does a copy or move using regular expressions
use strict;

##################################################
# Setup the variables
##################################################
my $PROGNAME = $0;
$PROGNAME =~ s|.*/||;

##################################################
# Usage
##################################################
sub usage {
  my $msg;
  foreach $msg (@_) { print STDERR "\nERROR:  $msg\n"; }
  print STDERR "\n";
  print STDERR "Usage:\t$PROGNAME <pat1> <pat2>\n";
  print STDERR "      \t$PROGNAME <searchreplace>\n";
  print STDERR "\n";
  print STDERR "\tCopies/Moves files using Perl regular expressions or /search/replace/\n";
  print STDERR "\n";
  print STDERR "Options:\n";
  print STDERR "\t-f\tForce overwrite of existing destinations\n";
  print STDERR "\t-i\tInteractive - ask before overwrite\n";
  print STDERR "\t-v\tVerbose mode - show actions\n";
  print STDERR "\t-d\tDebug mode - just show actions\n";
  print STDERR "\n";
  print STDERR "Examples:\n";
  print STDERR "\n";
  print STDERR "% mvx '(.*)-(.*)' '\$2--\$1'\n";
  print STDERR "  Would move files like 'bob-joe' to 'joe--bob'\n";
  print STDERR "% mvx '104.(.*)' '00104.\$1'\n";
  print STDERR "  Moves files from 104.* to 00104.*\n";
  print STDERR "% mvx /^104/00104/\n";
  print STDERR "  Same as above in /search/replace/ format\n";
  print STDERR "% cpx |^one/foo|two/bar|\n";
  print STDERR "  Copy all files from one/foo* to two/bar*\n";
  print STDERR "% mvx '/([-_])+/\$1/'\n";
  print STDERR "  Reduce multiple dash/underscores\n";
  print STDERR "\n";
  exit -1;
}

sub parse_args {
  my ($pat,$to,%opt);

  # Action
  $opt{'action'} = $PROGNAME =~ /mv/ ? "mv" : "cp";

  # Args
  my $arg;
  while ($#ARGV>=0) {
    $arg=shift(@ARGV);
    if ($arg =~ /^-h$/) { usage(); }
    if ($arg =~ /^-f$/) { $opt{'force'}=1; next; }
    if ($arg =~ /^-i$/) { $opt{'interactive'}=1; next; }
    if ($arg =~ /^-v$/) { $opt{'verbose'}=1; next; }
    if ($arg =~ /^-d$/) { $opt{'debug'}=1; next; }
    if ($arg =~ /^-/) { usage("Unknown option: $arg"); }
    (defined $pat) ? $to = $arg : $pat = $arg;
  }
  usage("No patterns specified") unless $pat;

  unless ($to) {
    # Must be /search/replace/ form
    my $ch=substr($pat,0,1);
    $ch="\\$ch";
    usage("Search/replace patterns must be of the form: /search/replace/\n".
          "        (where '/' can be any character)\n")
      if ($pat !~ /^$ch(.*)$ch(.*)$ch(g)?$/ || $1 =~ /$ch/);
    ($pat,$to)=($1,$2);
    $opt{'global'} = $3 eq "g" ? 1 : 0;
#    if ($pat =~ /\(/) {
#      ;
#    } elsif ($pat =~ m|^/|) {
#      $pat="$pat(.*)";  $to="$to\$1";
#    } else {
#      $pat="(.*)$pat(.*)";  $to="\$1$to\$2";
#    }
  }

  ($pat,$to,\%opt);
}

##################################################
# Find files that match patterns
##################################################
sub find_files {
  my ($pat) = @_;

  # Allow them to use "pat" instead of "^.*pat.*$"
  $pat = ".*$pat" unless ($pat =~ m|^/| || $pat =~ m|^\^|);
  $pat = "$pat.*" unless ($pat =~ m|\$$|);

  my @files;

  # '/' is not allowed as part of the regular expression
  my @els = split(/\//,$pat);
  if ($els[0] eq "") {
    $files[0]="/";
    shift(@els);
  } else {
    $files[0]=".";
  }
  my (@new_files,$el);
  # Look at each element of the pattern
  foreach $el ( @els ) {
    # Compared to all the current paths so far
    my $path;
    foreach $path ( @files ) {
      # Read the current directory - match the current element
      if (opendir(DIR,$path)) {
        push(@new_files,map(($path eq "/" ? "/$_" : $path eq "." ? $_ : "$path/$_"),
                          grep(/^$el$/,readdir(DIR))));
        closedir(DIR);
      }
    }
    @files=@new_files;
    undef @new_files;
  }
  @files;
}

##################################################
# Act on the files (either move or copy)
##################################################
sub act_on {
  my ($from,$to,$pat,$opt_H) = @_;

  my ($old,$new) = ($from);

  while ($old =~ /$pat/) {
    my ($pre,$pat_matched,$post) = ($`,$&,$');

    my $match_to = $to;

    # Replace '$1' in $to with the first match, etc..
    my @matches = ($pat_matched =~ /$pat/g);
    my $num = 1;
    foreach my $paren_match ( @matches ) {
      $match_to =~ s/\$$num/$paren_match/g;
      $num++;
    }

    $new .= $pre.$match_to;
    $old = $post;
    last unless ($opt_H->{'global'});
  }
  $new .= $old;

  print "$opt_H->{'action'} $from $new\n"
    if ($opt_H->{'verbose'} || $opt_H->{'debug'});
  return if ($opt_H->{'debug'});

  # Avoid simple overwrite possibilities:  'mvx "many_files.*" file'
  return print STDERR "[$PROGNAME] ERROR: Multiple use of target $new (must be a directory)\n"
    if (grep($new eq $_,@{$opt_H->{'destinations'}}) && (! -d $new));
  push(@{$opt_H->{'destinations'}},$new);

  # Didn't change?  (i.e.:  'mvx /_+/_/' on 'Kodi__Bear' and 'Dave_Madison')
  return print STDERR "[$PROGNAME] $from not changed\n" if ($from eq $new);

  # Is it an overwrite?  (-f overrides -i)
  if (-f $new && !$opt_H->{'force'}) {
    return print STDERR "[$PROGNAME] $from -> $new failed, file exists\n"
      if (!$opt_H->{'interactive'});
    print STDERR "[$PROGNAME] $from: overwrite $new (yes/no)? ";
    return if (<> !~ /^y/i);
  }

  system("$opt_H->{'action'} \Q$from\E \Q$new\E");
}

##################################################
# Main code
##################################################
sub main {
  my ($pat, $to, $opt_H) = parse_args();

  map(act_on($_,$to,$pat,$opt_H), find_files($pat));
}
main();