#!/bin/env perl5
# 
# General file rename program written in Perl (using Tk for an interface).
# Most valuable under Windows, 
# 
# Here are some cookbook examples of what you might want to do:
# 
#   Move all the *.jpg files in a directory to another directory and call them
#   image_034.jpg ... image_067.jpg
# 
#       Unset "Same directory" pick the source and the target directories
#       Set the Ext to "jpg"
#       Set the destination name to "image_$03hwm.jpg"
#       Set the HWM pattern to "33" or
#           set the HWM pattern to "image_(\d+). and have a file called
#           "image_033.jpg" in the destination dir
#       Hit the run button
# 
#   Rename all files called *_tar.gzip to *.tgz
#
#       Pick the source directory
#       Set the ext to "gzip"
#       Set the basename to "(.+)_tar"
#       Set the destination name to "$b1.tgz"
#       Hit the run button
# 
#   Rename all the files which don't have any extension to have a .txt extension
#   in a directory and all its subdirs
# 
#       Pick the source directory
#       Set the ext to the empty string
#       Select "Recurse Subdirs"
#       Set the destination name to "$b0.txt"
#       Hit the run button
#
# This program uses Perl's pattern matching to specify the new names for a set
# of files.  Patterns are specified using Perl's pattern specifications, regex 
# to its freiends.  If you don't know how they work you can look up the syntax 
# in any good Perl book.
# 
# Bracketed elements in the basename pattern are assigned to the variables 
# $b1..$b9 ($b0 is the whole thing), elements in the extension pattern are 
# assigned to $e1..$e9.  $hwm represents the current "high water mark", that is 
# the additional numerical element used in the first example.  If the destination 
# name contains a $unique then the program will keep trying different numerical 
# values for that element until it generates a name that does not clash with an 
# existing file.  Any numerical value like $03hwm or $05unique will force the 
# number to be that number of digits wide preceeded by 0s, but notice the $e1 
# type variables are strings so specifying the width won't work there).
# 
# If you are thinking of using this to do something complex then you should first 
# create a test directory with a few files as examples.  It is amazing how often 
# I have run the program and only after seeing the result realised what I asked 
# it to do!
#
# This is a program I generated for my own use to manipulate groups of files under 
# windows 
#
# You will need the Tk package, assuming youare using ActivePerl (and who isn't?) 
# then PPM will be able to install it for you.
#
    use strict;
    use Tk;
    use Tk::FileSelect;
    require Cwd;

    my($a,$b,$src_dir,$dest_dir,$dir,$same_dir);
    my($recurse_dir,$flatten_dir);
    my($dest_fp,$dest_pat,$src_pat,$src_ext);
    my($dest_overwrite,$rename_dirs);
    my($main_win,$t_frame,$b_frame,$done_but,$cancel_but,$report_lab);
    my($dest_fs,$src_fs);

    # Set some constants first
    $dest_dir = $src_dir = Cwd::getcwd();
    $same_dir = 1;
    $recurse_dir = "";
    $flatten_dir = "";
    
    # Matching elements in the src_pat get assigned to $b1..$b9    
    $src_pat = "(.+)";
    # Matching elements in the $src_ext get assigned to $e1..$e9
    $src_ext = "\\S+";
    # So we can use matches to generate the new filename
    $dest_fp = "\$b1_\$03hwm.\$e0";

    $dest_pat = "image_(\\d+)\.";
    
    $main_win = new MainWindow(
        -title   => "TsorT Multi Rename",
      );

    # The source directory
    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
          );

    $src_fs = $main_win->FileSelect(
            -directory => $src_dir,
          );

    $t_frame->Button(
        -text => "Browse",
        -command => \&select_src_dir,
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $t_frame->Label(
        -text => "Source Directory"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $t_frame->Entry(
        -textvariable => \$src_dir,
      )->pack(
            -fill => 'both',
          );

    # The source name pattern
    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top'
          );

    $t_frame->Label(
        -text => "Basename"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $t_frame->Entry(
        -textvariable => \$src_ext,
        -width => 5,
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $t_frame->Label(
        -text => "Ext",
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $t_frame->Entry(
        -textvariable => \$src_pat,
      )->pack(
            -fill => 'both',
          );

    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
          );

    $t_frame->Checkbutton(
            -text => "Same Destination Dir",
            -variable => \$same_dir,
          )->pack(
                -side => 'left'
              );
    
    $t_frame->Checkbutton(
            -text => "Recurse Subdirs",
            -variable => \$recurse_dir,
          )->pack(
                -side => 'left'
              );
    

    # The destination directory
    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
          );

    $t_frame->Checkbutton(
            -text => "Flatten target dirs",
            -variable => \$flatten_dir,
          )->pack(
                -side => 'left'
              );
    
    $t_frame->Checkbutton(
            -text => "Rename directories",
            -variable => \$rename_dirs,
          )->pack(
                -side => 'left'
              );
    
    # The destination directory
    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top',
          );

    $dest_fs = $main_win->FileSelect(
            -directory => $dest_dir,
          );

    $t_frame->Button(
        -text => "Browse",
        -command => \&select_dest_dir,
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $t_frame->Label(
        -text => "Dest Directory"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $t_frame->Entry(
        -textvariable => \$dest_dir,
      )->pack(
            -fill => 'both',
          );

    # The source name pattern
    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top'
          );

    $t_frame->Label(
        -text => "Dest Name"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $t_frame->Entry(
        -textvariable => \$dest_fp,
      )->pack(
            -fill => 'both',
          );

    # The source name pattern
    $t_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'top'
          );

    $t_frame->Checkbutton(
        -text => "Overwrite",
            -variable => \$dest_overwrite,
          )->pack(
            -side => 'left'
          );

    $t_frame->Label(
        -text => "HWM Pattern"
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $t_frame->Entry(
        -textvariable => \$dest_pat,
      )->pack(
            -fill => 'both',
          );

    # The bottom frame kicks off the program and shows the state
    $b_frame = $main_win->Frame(
      )->pack(
            -fill => 'x',
            -side => 'bottom'
          );

    $done_but = $b_frame->Button(
        -text    => "Start",
        -command => \&do_cmd,
      )->pack(
            -side => 'left',
            -fill => 'y',
          );

    $cancel_but = $b_frame->Button(
        -text    => "Done",
        -command => sub {$main_win->destroy},
      )->pack(
            -side => 'right',
            -fill => 'y',
          );

    $report_lab = $b_frame->Label(
        -text    => "User Input",
      )->pack(
            -fill => 'both',
          );

    # OK all the widgets are in place, lets go
    MainLoop;
    
    # Returns once it is done
    exit(0);
  
sub report
  {
    my($val) = @_;

    $report_lab->configure(-text => $val);
  }

sub select_src_dir
  {
    my($new_dir);

    $src_fs->configure(
        -directory => $src_dir,
      );

    $new_dir = $src_fs->Show;
    if($new_dir)
      {
        # Remove the disk specifier
 #       $new_dir =~ s/^\S://;
        $new_dir =~ s#.+(\S\:[^\:]+)$#\1#;
        if($new_dir =~ s#/+[^/]+$##)
          {
          }
        else
          {
            &report("Cannot parse dir from $new_dir\n");
            return;
          }
        &report("Set source dir $new_dir\n");
        $src_dir = $new_dir;
      }
    else
      {
        &report("Canceled setting source\n");
      }
  }

sub select_dest_dir
  {
    my($new_dir);

    $dest_fs->configure(
        -directory => $dest_dir,
      );

    $new_dir = $dest_fs->Show;
    if($new_dir)
      {
        # Remove the disk specifier
 #       $new_dir =~ s/^\S://;
        $new_dir =~ s#.+(\S\:[^\:]+)$#\1#;
        if($new_dir =~ s#/+[^/]+$##)
          {
          }
        else
          {
            &report("Cannot parse dir from $new_dir\n");
            return;
          }
        &report("Set dest dir $new_dir\n");
        $dest_dir = $new_dir;
      }
    else
      {
        &report("Canceled setting dest\n");
      }
  }

sub do_cmd
  {
    my($isrc_dir,$idest_dir) = @_;

    # Deduce the destination pattern from the fp string
    return if(!$dest_pat);
    
    $dest_dir = $src_dir if($same_dir);

    &do_dir($src_dir,$dest_dir,-1);
    &report("Rename completed");
  }
    
sub do_dir
  {
    my($isrc_dir,$idest_dir,$dest_hwm) = @_;
    my($f,$base,$ext,$dbase,$dbfp,$hh);
    my(@base,@ext,$unique,$uses_unique);
    my(@subdirs,@files,@rename_subdirs);
    local(*DIR);
        
    if(!-r $isrc_dir)
      {
        &report("Cannot open directory $isrc_dir");
        return;
      }

    if($dest_hwm < 0)
      {
        $dest_hwm = &find_hwm($idest_dir,$dest_pat);
        return if($dest_hwm < -1);
        if(!-d $idest_dir)
          {
            &report("Cannot open dir $idest_dir");
            return;
          }
      }
    else
      {
        # Being called recusively on subdir
        if(!-d $idest_dir)
          {
            if($flatten_dir)
              {
                &report("Cannot open dir $idest_dir");
                return;
              }
            mkdir $idest_dir,0755;
          }
      }
    $dest_hwm++;

    # If one of the renames uses $unique they all do!
    $unique = "";
    $uses_unique = "";

    # Read all the files and sort into ASCII order (whatever the OS does)
    opendir(*DIR,$isrc_dir);
    @files = sort(readdir(DIR));
    closedir(DIR);
    
    while($f = shift(@files))
      {
        my($is_subdir);
        
        next if($f =~ /^\./);
        $base = $f;
        $unique = "" if($uses_unique);
        $is_subdir = "";
        
        if($recurse_dir && -d "$isrc_dir/$f")
          {
            push(@subdirs,$f);
            next if(!$rename_dirs);
            $is_subdir = 1;
          }

        if($src_ext)
          {
            if($base =~ s/\.($src_ext)$//)
              {
                # This matches the extension
                @ext = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
              }
            else
              {
                next;
              }
          }
        else
          {
            # $src_ext is empty, expect NO extension
            next if($base =~ /\./);
            @ext = ();
          }

        # The extension matches move to the basename
        if($base =~ /^($src_pat)$/)
          {
            @base = ($1,$2,$3,$4,$5,$6,$7,$8,$9);
          }
        else
          {
            next;
          }

        # We have a total match, work out the destination name

        # Now substitute the $e1..$e9 and $b1..$b9 elements into
        # the target name.  As a special case $b0 matches with the 
        # total name
        while(!$dbfp)
          {
            my($val);
                        
            $dbfp = $dest_fp;
            foreach $hh ("base","ext")
              {
                my($sln,$c);
    
                $sln = substr($hh,0,1);
                for($c=0;$c<=9;$c++)
                  {
                    while($dbfp =~ /\$$sln$c/)
                      {
                        # In theory  $val = ${$hh}[$c]  should
                        # do this, but obviously I don't know my
                        # perl well enough
    
                        $val = eval("\$$hh\[\$c\]");
                        $dbfp =~ s/\$$sln$c/$val/;
                      }
                  }
              }
            while($dbfp =~ /\$(\-?\d*)hwm/)
              {
                $val = sprintf("\%$1d",$dest_hwm);
                $dbfp =~ s/\$(\d*)hwm/$val/;
              }
            while($dbfp =~ /\$(\d*)unique/)
              {
                $uses_unique = 1;
                $val = sprintf("\%$1d",$unique);
                $dbfp =~ s/\$(\d*)unique/$val/;
              }
            
            if(-r "$idest_dir/$dbfp")
              {
                # We have a file called that already
                if($dest_overwrite)
                  {
                    # Just overwrite it
                    # unlink("$idest_dir/$dbfp");
                  }
                elsif($uses_unique)
                  {
                    # Try and generate a different name
                    $unique++;
                    $dbfp = "";
                    next;
                  }
                else
                  {
                    # Give up on this file
                    last;
                  }
              }

            if($is_subdir)
              {
                push(@rename_subdirs,$f,$dbfp);
              }
            else
              {
                rename "$isrc_dir/$f","$idest_dir/$dbfp";
              }
            # printf "$isrc_dir/$f  => $idest_dir/$dbfp\n";

            $dest_hwm++;
          }
        $dbfp = "";
      }

    foreach $f (sort(@subdirs))
      {
        my($d);
        
        $d = "$idest_dir/$f";
        $d = "$idest_dir" if($flatten_dir);
        $dest_hwm = &do_dir("$isrc_dir/$f",
                            $d,$dest_hwm - 1);
      }

    # Finally rename all the matched subdirs
    for($f=0;$f<=$#rename_subdirs;$f+=2)
      {
        rename $isrc_dir."/".$rename_subdirs[$f],
               $idest_dir."/".$rename_subdirs[$f+1];
      }
    return($dest_hwm);
  }

sub find_hwm
  {
    my($dir,$pat) = @_;
    my($hwm,$f);
    local(*DIR);
    
    return($pat) if($pat =~ /^\d+$/);

    if(!-d $dir)
      {
        &report("Cannot find directory $dir");
        return(-2);
      }
    if(!-r $dir)
      {
        &report("Cannot read directory $dir");
        return(-2);
      }
    opendir(DIR,$dir);
    $hwm = -1;
    while($f = readdir(DIR))
      {
        if($f =~ /$pat/)
          {
            $hwm = $1 if($1 > $hwm);
          }
      }
    closedir(DIR);
    return($hwm);
  }