#!/usr/bin/env perl
# /Time-stamp: "2008-08-09 12:58:16 leycec"/

=head1 NAME

cp-pcre - Copy files by performing PCRE-style replacement on those files.
mv-pcre - Move files by performing PCRE-style replacement on those files.

=head1 SYNOPSIS

  cp-pcre [options] search-pattern replace-pattern [source-file ...] [target-path]
  mv-pcre [options] search-pattern replace-pattern [source-file ...] [target-path]

  options:

  -h,--help              This help message.
  -q,--quiet             Do not print messages or prompt for interactive input.
  -r,--recursive         Copy or move files recursively.
  -n,-file-names         Perform replacement on filenames. (Default.)
  -c,-file-contents      Perform replacement on file contents.
  --no-file-names        Do not perform replacement on filenames.
  --no-file-contents     Do not perform replacement on file contents. (Default.)
  --mv                   Move files when performing replacement on filenames.
  --cp                   Copy files when performing replacement on filenames.

  search-pattern:  A PCRE-style search pattern ("^(\d+)\s*(\w+)\.mp3$")
  replace-pattern: A PCRE-style replace pattern ("\1 ~ (\2).mp3.bak")

  source-file ...: Source files to be copied or moved.
  target-path: Path to copy or move changed source files to.

=head1 OPTIONS

=over 2

=item B<--help>

Print this help message and exit.

=item B<--quiet>

Do not print informative messages or prompt the user for interactive input. By
default, this script does print informative messages and prompt the user for
interactive input; that is, it behaves B<verbosely>.

=item B<--recursive>

Copy or move files recursively. (See B<DESCRIPTION>, below.)

=item B<--file-names>

Whether or not to perform PCRE-style search-replacement on filenames. By
default, this script does PCRE-style search-replacement on filenames. If you
explicitly specify neither B<--file-names> or B<--file-contents>, this script
automatically assumes and enables B<--file-names>.

If B<--file-contents> is explicitly specified, but B<--file-names> is not, then
this script doesn't automatically assume or enable B<--file-names> -- since, by
specifying B<--file-contents>, you've specified that you cognizently know what
you're doing. (An assumption, of course, that may not bear out...)

If B<--file-contents> and B<--file-names> are both explicitly specified, then
this script performs the same PCRE-style search-replacement on both file
contents and filenames. It performs the file content replacement first; then,
when that's been finished, performs the filename replacement. As it performs
them separately, the files it performs file content replacement on may differ,
entirely, from the files it performs filename replacement on. (Usually, this
is what you want! The only files that should ever be subject to file content
replacement are text files -- while all files, text or binary, may and should
be subject to filename replacement.)

By default, this script automatically discerns whether to copy or move files
when performing PCRE-style search-replacement on filenames, by whether the
filename for the script begins in "mv": if so, it performs filename moving;
otherwise, filename copying. To circumvent this automation, specify the
B<--cp> or B<--mv> options. (The former forces copying; the latter, moving.)

In general, things should simply work -- in simple, context-dependent fashion.

=item B<--file-contents>

Whether or not to perform PCRE-style search-replacement on file-contents. By
default, this script does not perform PCRE-style search-replacement on
file-contents. (That tends to be a destructive operation, particularly when
performed recursively.)

When performing PCRE-style search-replacement on file-contents, this script
ignores binary files and does not preemptively show the user a list of all
files whose contents will be changed by that search-replacement.

  Another day, another breath.
  Another sorrow, another death.

=item B<--cp>

Force this script to perform PCRE-style search-replacement on filenames by copying
files.

=item B<--mv>

Force this script to perform PCRE-style search-replacement on filenames by moving
files.

=back

=head1 ARGUMENTS

=over 2

=item B<search-pattern>

A Perl Compatible Regular Expression (PCRE), specifying which filenames and/or
file-contents to match against. See "man perlre", "man perlrequick", and
"man perlretut" for further details.

This argument is not optional.

=item B<replace-pattern>

A Perl Compatible Regular Expression (PCRE), specifying how and with what to
replace those matched filenames and/or file-contents. As above, see
"man perlre", "man perlrequick", and "man perlretut" for further details.

This argument is not optional.

=item B<source-file ...>

An optional list of source files to be copied or moved, separated by whitespace.
If no such list is explicitly specified, this script operates on all files in
the current working directory. (That is, it automatically appends all files in
the current working directory to that list.)

=item B<target-path>

The optional path to copy or move the filename-replaced source files into. If no
such path is explicity specified, this script copies or moves all such files into
the current working directory ("in place," as it were).

=back

=head1 DESCRIPTION

This script copies or moves files by performing Perl Compatible Regular
Expression (PCRE)-style replacement on those files.

When called as "cp" or "cp-pcre", this script copies files; when called as
"mv" or "mv-pcre", this script moves files. (When called as neither, this script
copies files; that seems the safer of the bloody, dangerous two.)

When no optional, explicit list of files to be copied or moved are passed to
this script, this script automatically behaves as if all files in the current
working directory had been passed to it; that is, it automatically performs the
passed PCRE-style replacement on all files in the current directory.

When a path is passed in that optional, explicit list of files to be copied or
moved, this script only performs the passed PCRE-style replacement on that path;
it does not recursively perform the passed PCRE-style replacement on all files
and paths in that path unless the "-r" or "--recursive" options are explicitly
passed on the command-line.

=head1 INSTALLATION

  # Install Perl. (Any decently recent version should do: say, newer than 5.6.0.)
  sudo emerge perl

  # Copy or move this script to some $PATH-accessible path.
  sudo mv cp-pcre /usr/local/bin

=head1 EXAMPLES

  # Copy all files in "~/tmp" matching pattern "*.tmp" to "*.tmp.old".
  cd ~/tmp
  cp-pcre '\.tmp$' '.tmp.old'

  # Or, more verbosely.
  cp-pcre --file-names --cp '^(.*)\.tmp$' '\1.tmp.old' ~/tmp/*

  # Rename all files and paths in any directories below and including the current
  # directory matching pattern "01--whatis.txt", "02--updoc.txt", etc., to
  # "whatis~01.doc", "updoc~02.doc", etc.; and also change any strings in the
  # contents of any text files in any directories below and including the current
  # directory matching that same pattern to that some replacement text. (Power;
  # glorious, gladdening, rawly maddening power.)
  mv-pcre --recursive --file-names --file-contents '^(\d)--(\w)\.txt$' '\2~\1.doc'

=head1 BUGS

None! (O.K., probably quite a few. It's stably run and run the deathly miles of
maintaining the present author's Oddmuse Wiki installation; but your mileage may
vary.)

=cut

# ....................{ USE STATEMENTS                     }....................
use strict;
use warnings;

use Carp;
use File::Basename;
use File::Copy;
use File::Find;
use File::Spec::Functions qw(curdir abs2rel rel2abs);
use Getopt::Long;
use Pod::Usage;
use Term::ReadLine;

use constant {
	true => '1',
	false=> '',

	success=> 0,
	failure=> 1,
};

# ....................{ VARIABLES                          }....................
my $script_name = basename $0;
my $current_path = rel2abs(curdir()).'/';

my $VERSION = 0.001;

# ....................{ CLI OPTIONS                        }....................
my %options;

# Enable first-level bundling; e.g., auto-expand a passed "-vax" to "-v -a -x";
# all other configuration settings should be reasonably self-explanatory.
Getopt::Long::Configure
	qw(posix_default gnu_compat auto_help auto_version bundling no_ignore_case);

(Getopt::Long::GetOptions(\%options,
												 'help|h|?',
												 'quiet|q',
												 'recursive|r|R',
												 'file-contents|c!',
												 'file-names|n!',
												 'mv',
												 'cp') &&
 defined $ARGV[0] &&
 defined $ARGV[1]) ||
	pod2usage({
						 -exitval=> failure,
						 -message=> qq[${script_name}: v${VERSION}; GNU GPL v3; open, aspiring, and up.],
						 -verbose=> 2
						});

# Define default values for undefined options. This is principally based on the
# script name: e.g., when called as "subst-pcre," this script automatically
# enables the "--file-contents" option and disables the "--file-names" option.
if ($script_name =~ '^sub') {
  if (!defined $options{'file-contents'}) { $options{'file-contents'} = true; }
  if (!defined $options{'file-names'})    { $options{'file-names'} = false; }
}

if (!defined $options{'file-names'} && !defined $options{'file-contents'}) {
	           $options{'file-names'} = true;
}

# ....................{ I/O HANDLING                       }....................
sub mutter(;$) { my $slur = shift || ""; $options{quiet} || print $slur; }
sub utter (;$) { my $slur = shift || ""; $options{quiet} || print "${script_name}: $slur"; }
sub curse (;$) { my $slur = shift || "";                    croak "${script_name}: $slur\n"; }

{
	my $term = new Term::ReadLine $script_name;

	sub query (;$) {
		$options{quiet} && return "";
		my $question = shift || "";

		return $term->readline("${script_name}: ${question} ");
	}
}

sub query_bool(;$) {
	$options{quiet} && return true;
	my $question = shift || "";

	return query("${question} [yes/[no]]") =~ m~^y|ye|yes$~i;
}

# Disable output buffering.
$| = 1;

# ....................{ PROCESS HANDLING                   }....................
sub run($) {
	my $shell_command = shift;

  system($shell_command) == success ||
    curse qq{"$shell_command" failed with: \{$?\} $!};
}

# ....................{ INITIALIZATION                     }....................
my $from_pattern = shift @ARGV;
my $into_pattern = shift @ARGV;

# Protect the replacement pattern from % (hash) or @ (list) interpolation.
$into_pattern =~ s~\@~\\@~g;
$into_pattern =~ s~\%~\\%~g;

# If copying or moving files and the last command-line argument is a path, that
# path signifies the path to which those files should be copied or moved;
# extract now, before extracting further command-line arguments.
my $target_path;
if ($options{'file-names'} && @ARGV && -d $ARGV[-1]) {
	$target_path = pop @ARGV;

	(substr($target_path, -1, 1) eq '/') or
					$target_path     .=     '/';
}

# All remaining command-line arguments refer to source files and paths. As
# this script requires at least one such source file or path to act on, if
# there are no such command-line arguments remaining, fabricate arguments by
# glob-listing all readable files and paths in the current working directory.
if (not @ARGV) { push @ARGV, grep {!m~^\.$|^\.\.$~ } glob('{*,.*}'); }
my @source_files_and_paths = @ARGV;

# ....................{ FILE-CONTENT SUBSTITUTION         }....................
# FIXME: add a new command-line argument: -f/--fork. If set, then do
# perl -pie style substitutions. Otherwise, do the substitutions in
# perl, internally here. For the code, see:
#
# http://www.cclabs.missouri.edu/things/instruction/perl/perlcourse.html
{
	my @source_files;

	sub substitute_file_contents() {
		# ~~~~~~~~~~~~~~~~{ recursion                         }~~~~~~~~~~~~~~~~~~~~
		if ($options{recursive}) {
			my @source_paths = @source_files_and_paths
			? grep { -d $_ }   @source_files_and_paths
			: ($current_path)
			;

			if (@source_paths) {
				utter "recursively searching paths for applicable text files: ";
				find({
							wanted=> \&add_text_files_to_source_files,
							no_chdir=> true
						 }, @source_paths);
				mutter "\n";
			}
			else { @source_files = grep { -T $_ } @source_files_and_paths; }
		} else { @source_files = grep { -T $_ } @source_files_and_paths; }

		# ~~~~~~~~~~~~~~~~{ substitution                      }~~~~~~~~~~~~~~~~~~~~
		if (!@source_files) { curse "no substitutions to make!"; }
		else {
			utter
				qq[substituting "${from_pattern}" for "${into_pattern}" in ].
				qq[file-contents of files:\n\n];

			foreach my $source_file (@source_files) { mutter qq[${source_file}\n]; }

			if (query_bool('would you like to make these file content substitutions?')) {
				utter "substituting...\n\n";

				foreach my $source_file (@source_files) {
					print "$source_file\n";

					# Quote protect filename-embedded quotes and double quotes from
					# shell expansion.
					$source_file =~ s~\'~'\\''~g;  # bizarre quote protection; *shrug*

					run qq[perl -pi -e 's/$from_pattern/$into_pattern/g' '$source_file'];
				}

				utter "substituted.\n";
			}
		}
	}

	sub add_text_files_to_source_files() {
		if (-T $_) {
			mutter ".";
			push @source_files, rel2abs($File::Find::name);
		}
		else {
			mutter "!";
		}
	}
}

# ....................{ FILENAME SUBSTITUTION             }....................
sub substitute_filenames() {
	my $is_moving_files = ($script_name =~ m~^mv~ ? 'mv' : 'cp');
	if ($options{mv}) { $is_moving_files = true;  }
	if ($options{cp}) { $is_moving_files = false; }

	my ($operator_string, $operation_string, $operated_string);
  if ($is_moving_files) {
		$operator_string = "  ->  ";
		$operation_string = "moving";
		$operated_string =  "moved";
	}
	else {
		$operator_string = "  ~>  ";
		$operation_string = "copying";
		$operated_string =  "copied";
	}

	my @source_file_to_target_file_list;
	my ($source_file_name, $source_path);
	my ($target_file_name, $target_file);

	# ~~~~~~~~~~~~~~~~~~{ recursion                         }~~~~~~~~~~~~~~~~~~~~
	if ($options{recursive}) {
		my @source_paths = @source_files_and_paths
		? grep { -d $_ }   @source_files_and_paths
		: ($current_path)
		;

		if (@source_paths) {
			utter "recursively searching paths for applicable files and paths: ";
			find({
						wanted=> \&add_all_files_and_paths_to_source_files_and_paths,
 						no_chdir=> true
					 }, @source_paths);
			mutter "\n";
		}
	}

	# ~~~~~~~~~~~~~~~~~~{ dry run                           }~~~~~~~~~~~~~~~~~~~~
	utter
		qq[substituting "${from_pattern}" for "${into_pattern}" in filenames by ].
		qq[${operation_string} files:\n\n];

	foreach my $source_file (@source_files_and_paths) {
		($source_file_name, $source_path) = fileparse($source_file);

		if ($source_path =~ m~^\.|\./$~) {
				$source_path = $current_path;
		}

		$target_file_name = $source_file_name;
		eval "\$target_file_name =~ s/$from_pattern/$into_pattern/g";

		$source_file = $source_path.$source_file_name;
		$target_file =
			(defined $target_path ? $target_path : $source_path).$target_file_name;

		if ($source_file ne $target_file) {
			mutter qq[${source_file}${operator_string}${target_file}\n];
			push @source_file_to_target_file_list, [ $source_file, $target_file ];
		}
	}

	# ~~~~~~~~~~~~~~~~~~{ real run                          }~~~~~~~~~~~~~~~~~~~~
	if (!@source_file_to_target_file_list) { curse "no substitutions to make!"; }
	else {
		if (query_bool('would you like to make these filename substitutions?')) {
			utter "${operation_string}...\n\n";
			my ($source_file, $target_file);

			foreach my $source_file_to_target_file (@source_file_to_target_file_list) {
				$source_file = @$source_file_to_target_file[0];
				$target_file = @$source_file_to_target_file[1];
				mutter qq[${source_file}${operator_string}${target_file}\n];

				$is_moving_files
				? rename $source_file, $target_file
				: copy   $source_file, $target_file
				;
			}

			mutter "\n";
			utter "${operated_string}.\n";
		}
	}
}

sub add_all_files_and_paths_to_source_files_and_paths() {
	if (-r $_ && (-f $_ || -d $_ || -l $_)) {
		mutter ".";
		push @source_files_and_paths, rel2abs($File::Find::name);
	}
	else {
		mutter "!";
	}
}

# ....................{ EXECUTION                         }....................
# Perform file-content substitution first, since performing filename
# substitution invalidates all of the @source_files array's filenames.
 $options{'file-contents'} && substitute_file_contents();
 $options{'file-names'}    && substitute_filenames();

!$options{'file-contents'} &&
!$options{'file-names'} &&
	die "nothing to do! (not substituting on filenames or file contents)";

  1
__END__

=head1 COPYRIGHT AND LICENSE

The information below applies to everything in this distribution,
except where noted.

Copyleft 2007, 2008, 2009 by B.w.Curry.

  http://www.raiazome.com

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.

=cut