rename source

rename.pl

#!/usr/bin/env perl
use strict;
use warnings;

use Getopt::Long 2.24, qw( :config bundling no_ignore_case no_auto_abbrev );

my ( $N, $EXT, @EXT, @USE, $DECODE, $ENCODE );
sub compile { eval shift } # defined early to control the lexical environment

my $msglevel = 0;
sub ERROR (&) { print STDERR $_[0]->(), "\n" if $msglevel > -1 };
sub INFO  (&) { print STDERR $_[0]->(), "\n" if $msglevel >  0 };
sub DEBUG (&) { print STDERR $_[0]->(), "\n" if $msglevel >  1 };

sub pod2usage { require Pod::Usage;     goto &Pod::Usage::pod2usage }
sub mkpath    { require File::Path;     goto &File::Path::mkpath }
sub dirname   { require File::Basename; goto &File::Basename::dirname }

use constant VERB_FOR => {
	link => {
		inf   => 'link',
		pastp => 'linked',
		exec  => sub { link shift, shift },
	},
	symlink => {
		inf   => 'symlink',
		pastp => 'symlinked',
		exec  => sub { symlink shift, shift },
	},
	rename => {
		inf   => 'rename',
		pastp => 'renamed',
		exec  => sub { rename shift, shift },
	},
};

sub argv_to_subst_expr {
	my $modifier = shift || '';
	pod2usage( -verbose => 1 ) if @ARGV < 2;
	my ($from, $to) = map quotemeta, splice @ARGV, 0, 2;
	# the ugly \${\""} construct is necessary because unknown backslash escapes are
	# not treated the same in pattern- vs doublequote-quoting context; only the
	# latter lets us do the right thing with problematic input like
	# ']{ool(haracter$' or maybe '>><//((/>'
	sprintf 's/\Q${\"%s"}/%s/%s', $from, $to, $modifier;
}

sub pipe_through {
	my ( $cmd ) = @_;
	IPC::Open2::open2( my $in, my $out, $cmd ) or do {
		warn "couldn't open pipe to $cmd: $!\n";
		return;
	};
	print $out $_;
	close $out;
	$_ = <$in>;
	chomp;
	close $in;
}

my ( $VERB, @EXPR );

my %library = (
	camelcase => 's/([[:alpha:]]+)/\u$1/g',
	urlesc    => 's/%([0-9A-F][0-9A-F])/chr hex $1/ieg',
	nows      => 's/[_[:blank:]]+/_/g',
	rews      => 'y/_/ /',
	noctrl    => 's/[_[:cntrl:]]+/_/g',
	nometa    => 'tr/_!"&()=?`*\':;<>|$/_/s',
	trim      => 's/\A[ _]+//, s/[ _]+\z//'
);

GetOptions(
	'h|help'                    => sub { pod2usage() },
	'man'                       => sub { pod2usage( -verbose => 2 ) },
	'0|null'                    => \my $opt_null,
	'f|force'                   => \my $opt_force,
	'g|glob'                    => \my $opt_glob,
	'i|interactive'             => \my $opt_interactive,
	'k|backwards|reverse-order' => \my $opt_backwards,
	'l|symlink'                 => sub { $VERB ? pod2usage( -verbose => 1 ) : ( $VERB = VERB_FOR->{ 'symlink' } ) },
	'L|hardlink'                => sub { $VERB ? pod2usage( -verbose => 1 ) : ( $VERB = VERB_FOR->{    'link' } ) },
	'M|use=s'                   => \@USE,
	'n|just-print|dry-run'      => \my $opt_dryrun,
	'N|counter-format=s'        => \my $opt_ntmpl,
	'p|mkpath|make-dirs'        => \my $opt_mkpath,
	'stdin!'                    => \my $opt_stdin,
	't|sort-time'               => \my $opt_time_sort,
	'T|transcode=s'             => \my $opt_transcode,
	'v|verbose+'                => \$msglevel,

	'a|append=s'                => sub { push @EXPR, "\$_ .= qq[${\quotemeta $_[1]}]" },
	'A|prepend=s'               => sub { push @EXPR, "substr \$_, 0, 0, qq[${\quotemeta $_[1]}]" },
	'c|lower-case'              => sub { push @EXPR, 's/([[:upper:]]+)/\L$1/g' },
	'C|upper-case'              => sub { push @EXPR, 's/([[:lower:]]+)/\U$1/g' },
	'd|delete=s'                => sub { push @EXPR, "s/${\quotemeta $_[1]}//" },
	'D|delete-all=s'            => sub { push @EXPR, "s/${\quotemeta $_[1]}//g" },
	'e|expr=s'                  => \@EXPR,
	'P|pipe=s'                  => sub { require IPC::Open2; push @EXPR, "pipe_through '\Q$_[1]\E'" },
	's|subst'                   => sub { push @EXPR, argv_to_subst_expr },
	'S|subst-all'               => sub { push @EXPR, argv_to_subst_expr('g') },
	'x|remove-extension'        => sub { push @EXPR, 's/\. [^.]+ \z//x' },
	'X|keep-extension'          => sub { push @EXPR, 's/\.([^.]+)\z//x and do { push @EXT, $1; $EXT = join ".", reverse @EXT }' },
	'z|sanitize'                => sub { push @EXPR, @library{ qw( nows noctrl nometa trim ) } },

	map { my $recipe = $_; $recipe => sub { push @EXPR, $library{ $recipe } } } keys %library,
) or pod2usage();

$opt_stdin = @ARGV ? 0 : 1 unless defined $opt_stdin;

$VERB ||= VERB_FOR->{ 'rename' };

if ( not @EXPR ) {
	pod2usage() if not @ARGV or -e $ARGV[0];
	push @EXPR, shift;
}

pod2usage( -message => 'Error: --stdin and filename arguments are mutually exclusive' )
	if $opt_stdin and @ARGV;

pod2usage( -message => 'Error: --null only permitted when reading filenames from STDIN' )
	if $opt_null and not $opt_stdin;

pod2usage( -message => 'Error: --interactive and --force are mutually exclusive' )
	if $opt_interactive and $opt_force;

my $n = 1;
my $nwidth = 0;
if ( defined $opt_ntmpl ) {
	$opt_ntmpl =~ /\A(?:(\.\.\.0)|(0+))([0-9]+)\z/
		or pod2usage( -message => "Error: unparseable counter format $opt_ntmpl" );
	$nwidth = (
		defined $1 ? -1 :
		defined $2 ? length $opt_ntmpl :
		0
	);
	$n = $3;
}

++$msglevel if $opt_dryrun;

my $code = do {
	if ( $opt_transcode ) {
		require Encode;
		my ( $in_enc, $out_enc ) = split /:/, $opt_transcode, 2;
		$DECODE = Encode::find_encoding( $in_enc );
		die "No such encoding $in_enc\n" if not ref $DECODE;
		$ENCODE = defined $out_enc ? Encode::find_encoding( $out_enc ) : $ENCODE;
		die "No such encoding $out_enc\n" if not ref $ENCODE;
		unshift @EXPR, '$_ = $DECODE->decode($_)';
		push    @EXPR, '$_ = $ENCODE->encode($_)';
	}

	my $i = $#USE;
	for ( reverse @USE ) {
		s/\A([^=]+)=?//;
		my $use = "use $1";
		$use .= ' split /,/, $USE['.$i--.']' if length;
		unshift @EXPR, $use;
	}

	if ( eval 'require feature' and $^V =~ /^v(5\.[1-9][0-9]+)/ ) {
		unshift @EXPR, "use feature ':$1'";
	}

	my $cat = sprintf 'sub { %s }', join '; ', @EXPR;
	DEBUG { "Using expression: $cat" };

	my $evaled = compile $cat;
	die $@ if $@;
	die "Evaluation to subref failed. Check expression using -nv\n"
		unless 'CODE' eq ref $evaled;

	$evaled;
};

if ( $opt_stdin ) {
	local $/ = $/;
	INFO { "Reading filenames from STDIN" };
	@ARGV = do {
		if ( $opt_null ) {
			INFO { "Splitting on NUL bytes" };
			$/ = chr 0;
		}
		<STDIN>;
	};
	chomp @ARGV;
}

@ARGV = map glob, @ARGV if $opt_glob;

if ( $opt_time_sort ) {
	my @mtime = map { (stat)[9] } @ARGV;
	@ARGV = @ARGV[ sort { $mtime[$a] <=> $mtime[$b] } 0 .. $#ARGV ];
}

@ARGV = reverse @ARGV if $opt_backwards;

$nwidth = length $n+@ARGV if $nwidth < 0;

for ( @ARGV ) {
	my $old = $_;

	$N = sprintf '%0*d', $nwidth, $n++;
	$code->();
	$_ = join '.', $_, reverse splice @EXT if @EXT;

	if ( $old eq $_ ) {
		DEBUG { "'$old' unchanged" };
		next;
	}

	if ( !$opt_force and -e ) {
		ERROR { "'$old' not $VERB->{pastp}: '$_' already exists" };
		next;
	}

	if ( $opt_dryrun ) {
		INFO { "'$old' would be $VERB->{pastp} to '$_'" };
		next;
	}

	if ( $opt_interactive ) {
		print "\u$VERB->{inf} '$old' to '$_'? [n] ";
		if ( <STDIN> !~ /^y(?:es)?$/i ) {
			DEBUG { "Skipping '$old'." };
			next;
		}
	}

	my ( $success, @made_dirs );

	++$success if $VERB->{ 'exec' }->( $old, $_ );

	if ( !$success and $opt_mkpath ) {
		@made_dirs = mkpath( [ dirname( $_ ) ], $msglevel > 1, 0755 );
		++$success if $VERB->{ 'exec' }->( $old, $_ );
	}

	if ( !$success ) {
		ERROR { "Can't $VERB->{inf} '$old' to '$_': $!" };
		rmdir $_ for reverse @made_dirs;
		next;
	}

	INFO { "'$old' $VERB->{pastp} to '$_'" };
}

=head1 AUTHORS

Aristotle Pagaltzis

Idea, inspiration and original code from Larry Wall and Robin Barker.

=head1 COPYRIGHT

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