Browse files

new -x option; -e now becomes --eval, --execute is the new -x; multip…

…le -e/-x now allowed; prepare v0.38
  • Loading branch information...
1 parent 4906458 commit 4ded649eecf8d77100bf28b610de0dbe2e98cfb4 Steven Haryanto (on Asus EEEPC) committed Sep 27, 2010
Showing with 235 additions and 61 deletions.
  1. +16 −0 Changes
  2. +54 −7 bin/perlmv
  3. +1 −1 dist.ini
  4. +109 −43 lib/App/perlmv.pm
  5. +4 −1 t/mv.t
  6. +21 −0 t/recursive.t
  7. +29 −8 t/testlib.pl
  8. +1 −1 t/todo.txt
View
16 Changes
@@ -1,5 +1,21 @@
Revision history for App-perlmv
+0.38 2010-09-27
+
+ Multiple scriptlets and/or command-line code can now be specified, a la
+ piping.
+
+ INCOMPATIBLE: -e is now --eval instead of --execute. New -x option is
+ now --execute.
+
+ Some fixes in dryrun handling.
+
+ Allow -e '' (previous version would wrongly assume next argument is
+ scriptlet).
+
+ Add more documentation and examples.
+
+
0.37 2010-07-03
Fix bug: store_scriptlets was broken (Thanks Kurt vom Walde).
View
61 bin/perlmv
@@ -24,20 +24,38 @@ perlmv - Rename files using Perl code
Usage:
+ # Show help
perlmv -h
+ # Execute a single scriptlet
perlmv [options] <scriptlet> <file...>
+
+ # Execute code from command line
perlmv [options] -e <code> <file...>
+ # Execute multiple scriptlets/command-line codes
+ perlmv [options] [ -x <scriptlet> | -e <code> ]+ <file...>
+
+ # Create a new scriptlet
perlmv -e <code> -w <name>
+
+ # List available scriptlets
perlmv -l
+
+ # Show source code of a scriptlet
perlmv -s <name>
+
+ # Delete scriptlet
perlmv -d <name>
=head2 Usage examples
- $ ls
- A.txt B1 c2.txt D3.pl D4.pl
+ $ ls -1
+ A.txt
+ B1
+ c2.txt
+ D3.pl
+ D4.pl
Rename files with prewritten scriptlet (B<ls>) and show (B<-v>) each file as it
is being renamed.
@@ -49,15 +67,27 @@ Specify script in command line (B<-e>) but do not actually rename files (B<-d>,
dry-run mode):
$ perlmv -de 's/\d+//g' *
- `B1` -> `B`
- `c2.txt` -> `c.txt`
- `D3.pl` -> `D.pl`
- `D4.pl` -> `D.pl.1`
+ DRYRUN: `B1` -> `B`
+ DRYRUN: `c2.txt` -> `c.txt`
+ DRYRUN: `D3.pl` -> `D.pl`
+ DRYRUN: `D4.pl` -> `D.pl.1`
Really rename the files this time:
$ perlmv -e 's/\d+//g' *
+Execute multiple scriptlets and/or command-line code:
+
+ $ ls -1
+ a.txt
+ b.html
+ c.ini
+
+ $ perlmv -v -x to-number-ext -e '"file$_"' *
+ `a.txt` -> `1.txt` -> `file1.txt`
+ `b.html` -> `2.html` -> `file2.html`
+ `c.ini` -> `3.ini` -> `file3.ini`
+
Save Perl code as scriptlet (in ~/.perlmv/scriptlets/):
$ perlmv -e 's/\d+//g' -w remove-digits
@@ -78,6 +108,19 @@ Remove scriptlet:
$ perlmv -D remove-digits
+=head2 More examples
+
+From my real-world usage.
+
+Rename .flv partial files from my Firefox browser cache into ordered names
+(part01.flv, part02.flv, and so on):
+
+ $ ls --sort=t -r *01 | xargs perlmv -d -x to-number-ext -e '"part$_.flv"'
+ DRYRUN: `15D9F85Ad01` -> `01` -> `part01.flv`
+ DRYRUN: `FF8EB240d01` -> `02` -> `part02.flv`
+ DRYRUN: `9031E9A8d01` -> `03` -> `part03.flv`
+ ...
+
=head1 DESCRIPTION
Perlmv lets you rename files using Perl code. All the Perl code needs to do is
@@ -102,9 +145,10 @@ L<App::perlmv::scriptlets::std>.
=head1 OPTIONS
-c (--compile) Only test compile code, do not run it on the arguments
- -e <CODE> (--execute) Specify code to rename file (\$_), e.g. 's/\.old\$/\.bak/'
-D <NAME> (--delete) Delete scriptlet
-d (--dry-run) Dry-run (implies -v)
+ -e <CODE> (--execute) Specify Perl code to rename file (\$_). Can be specified
+ multiple times.
-f (--files) Only process files, do not process directories
-h (--help) Show this help
-l (--list) list all scriptlets
@@ -121,6 +165,9 @@ L<App::perlmv::scriptlets::std>.
-V (--version) Print version and exit
-v (--verbose) Verbose
-w <NAME> (--write) Write code specified in -e as scriptlet
+ -x <NAME> Execute a scriptlet. Can be specified multiple times. -x is optional
+ if there is only one scriptlet to execute, and scriptlet name is specified
+ as the first argument, and there is no -e specified.
=head1 FAQ
View
2 dist.ini
@@ -1,5 +1,5 @@
name = App-perlmv
-version = 0.37
+version = 0.38
author = Steven Haryanto <stevenharyanto@gmail.com>
license = Perl_5
copyright_holder = Steven Haryanto
View
152 lib/App/perlmv.pm
@@ -4,6 +4,7 @@ package App::perlmv;
use strict;
use warnings;
use Cwd qw(abs_path getcwd);
+#use Data::Dump qw(dump);
use File::Copy;
use File::Find;
use File::Path qw(make_path);
@@ -33,12 +34,13 @@ sub new {
$homedir = File::HomeDir->my_home;
};
- $homedir ||= $ENV{'HOME'};
+ $homedir //= $ENV{'HOME'};
die "FATAL: Can't determine home directory\n" unless $homedir;
}
my $self = {
+ codes => [],
dry_run => 0,
homedir => $homedir,
overwrite => 0,
@@ -59,9 +61,10 @@ sub parse_opts {
GetOptions(
'c|check' => \$self->{ 'check' },
- 'e|execute=s' => \$self->{ 'code' },
'D|delete=s' => \$self->{ 'delete' },
'd|dry-run' => \$self->{ 'dry_run' },
+ 'e|eval=s' => $self->{ 'codes' },
+ 'h|help' => sub { $self->print_help() },
'l|list' => \$self->{ 'list' },
'M|mode=s' => \$self->{ 'mode' },
'o|overwrite' => \$self->{ 'overwrite' },
@@ -73,8 +76,9 @@ sub parse_opts {
'w|write=s' => \$self->{ 'write' },
'f|files' => sub { $self->{ 'process_dir' } = 0 },
'S|no-symlinks' => sub { $self->{ 'process_symlink'} = 0 },
- 'h|help' => sub { $self->print_help() },
'V|version' => sub { $self->print_version() },
+ # we use \scalar to differentiate between -x and -e
+ 'x|execute=s' => sub { push @{$self->{'codes'}}, \$_[1]},
'<>' => sub { $self->parse_extra_opts(@_) },
) or $self->print_help();
}
@@ -104,7 +108,7 @@ sub run {
'rename';
$self->{'dry_run'} and $self->{'verbose'}++;
- $self->{'mode'} ||= $default_mode;
+ $self->{'mode'} //= $default_mode;
if ( $self->{'list'} ) {
$self->load_scriptlets();
@@ -123,7 +127,9 @@ sub run {
}
if ( $self->{'write'} ) {
- $self->store_scriptlet( $self->{'write'}, $self->{'code'} );
+ die "Please specify code of scriptlet" unless @{ $self->{'codes'} }
+ && !ref( $self->{'codes'}[0] );
+ $self->store_scriptlet( $self->{'write'}, $self->{'codes'}[0] );
exit 0;
}
@@ -132,13 +138,15 @@ sub run {
exit 0;
}
- unless (defined $self->{'code'}) {
- die 'FATAL: Must specify code (-e) or scriptlet name (first argument)'
+ unless (@{ $self->{'codes'} }) {
+ die 'FATAL: Must specify code (-e) or scriptlet name (-x/first argument)'
unless $self->{'items'};
- $self->{'code'} =
- $self->load_scriptlet( scalar shift @{ $self->{'items'} } );
+ push @{ $self->{'codes'} }, \( scalar shift @{ $self->{'items'} } );
+ }
+ # convert all scriptlet names into their code
+ for (@{ $self->{'codes'} }) {
+ $_ = $self->load_scriptlet($$_) if ref($_);
}
- exit 0 if $self->{'check'};
die "FATAL: Please specify some files in arguments\n"
unless $self->{'items'};
@@ -158,22 +166,37 @@ Rename files using Perl code.
Usage:
+ # Show help
perlmv -h
+ # Execute a single scriptlet
perlmv [options] <scriptlet> <file...>
+
+ # Execute code from command line
perlmv [options] -e <code> <file...>
+ # Execute multiple scriptlets/command-line codes
+ perlmv [options] [ -x <scriptlet> | -e <code> ]+ <file...>
+
+ # Create a new scriptlet
perlmv -e <code> -w <name>
+
+ # List available scriptlets
perlmv -l
+
+ # Show source code of a scriptlet
perlmv -s <name>
- perlmv -D <name>
+
+ # Delete scriptlet
+ perlmv -d <name>
Options:
-c (--compile) Only test compile code, do not run it on the arguments
- -e <CODE> (--execute) Specify code to rename file (\$_), e.g. 's/\.old\$/\.bak/'
-D <NAME> (--delete) Delete scriptlet
-d (--dry-run) Dry-run (implies -v)
+ -e <CODE> (--execute) Specify Perl code to rename file (\$_). Can be specified
+ multiple times.
-f (--files) Only process files, do not process directories
-h (--help) Show this help
-l (--list) list all scriptlets
@@ -190,6 +213,9 @@ Options:
-V (--version) Print version and exit
-v (--verbose) Verbose
-w <NAME> (--write) Write code specified in -e as scriptlet
+ -x <NAME> Execute a scriptlet. Can be specified multiple times. -x is optional
+ if there is only one scriptlet to execute, and scriptlet name is specified
+ as the first argument, and there is no -e specified.
USAGE
@@ -206,7 +232,7 @@ sub load_scriptlet {
sub load_scriptlets {
my ($self) = @_;
- $self->{'scriptlets'} ||= $self->find_scriptlets();
+ $self->{'scriptlets'} //= $self->find_scriptlets();
}
sub find_scriptlets {
@@ -287,8 +313,7 @@ sub delete_user_scriptlet {
}
sub compile_code {
- my ($self) = @_;
- my $code = $self->{'code'};
+ my ($self, $code) = @_;
no strict;
no warnings;
local $_ = "-TEST";
@@ -299,8 +324,7 @@ sub compile_code {
}
sub run_code_for_cleaning {
- my ($self) = @_;
- my $code = $self->{'code'};
+ my ($self, $code) = @_;
no strict;
no warnings;
local $_ = "-CLEAN";
@@ -310,59 +334,89 @@ sub run_code_for_cleaning {
}
sub run_code {
- my ($self) = @_;
- my $code = $self->{'code'};
+ my ($self, $code) = @_;
no strict;
no warnings;
+ my $orig_ = $_;
local $App::perlmv::code::TESTING = 0;
local $App::perlmv::code::COMPILING = 0;
- my $orig_ = $_;
# It does need a package declaration to run it in App::perlmv::code
my $res = eval "package App::perlmv::code; $code";
die "FATAL: Code doesn't compile: code=$code, errmsg=$@\n" if $@;
if (defined($res) && length($res) && $_ eq $orig_) { $_ = $res }
}
+sub _sort {
+ my $self = shift;
+ $self->{reverse_order} ? (reverse sort @_) : (sort @_);
+}
+
sub process_items {
- my ($self, @items) = @_;
- @items = $self->{'reverse_order'} ? (reverse sort @items) : (sort @items);
- for my $item (@items) {
- next if !$self->{'process_symlink'} && (-l $item);
- if (-d _) {
+ my ($self, $code, $code_is_final, $items) = @_;
+ my $i = 0;
+ while ($i < @$items) {
+ my $item = $items->[$i];
+ $i++;
+ if ($item->{cwd}) {
+ chdir $item->{cwd} or die "Can't chdir to `$item->{cwd}`: $!";
+ }
+ next if !$self->{'process_symlink'} && (-l $item->{real_name});
+ if (-d $item->{real_name}) {
next unless $self->{'process_dir'};
if ($self->{'recursive'}) {
my $cwd = getcwd();
- if (chdir $item) {
- print "INFO: chdir `$cwd/$item` ...\n" if $self->{'verbose'};
+ if (chdir $item->{real_name}) {
+ print "INFO: chdir `$cwd/$item->{real_name}` ...\n"
+ if $self->{'verbose'};
local *D;
opendir D, ".";
- my @d = grep { $_ ne '.' && $_ ne '..' } readdir D;
+ my @subitems =
+ $self->_sort(
+ map { {name_for_script => $_, real_name => $_} }
+ grep { $_ ne '.' && $_ ne '..' }
+ readdir D
+ );
closedir D;
- $self->process_items(@d);
+ $self->process_items($code, $code_is_final, \@subitems);
+ splice @$items, $i-1, 0, @subitems;
+ $i += scalar(@subitems);
+ $subitems[0]{cwd} = "$cwd/$item->{real_name}";
chdir $cwd or die "FATAL: Can't go back to `$cwd`: $!\n";
} else {
- warn "WARN: Can't chdir to `$cwd/$item`, skipped\n";
+ warn "WARN: Can't chdir to `$cwd/$item->{real_name}`, ".
+ "skipped\n";
}
}
}
- $self->process_item($item, \@items);
+ $self->process_item($code, $code_is_final, $item, $items);
}
}
sub process_item {
- my ($self, $filename, $items) = @_;
+ my ($self, $code, $code_is_final, $item, $items) = @_;
- local $_ = $filename;
- $App::perlmv::code::FILES = $items;
- my $old = $filename;
- $self->run_code();
+ $App::perlmv::code::FILES =
+ [map {ref($_) ? $_->{name_for_script} : $_} @$items];
+ local $_ = $item->{name_for_script};
+ my $old = $item->{real_name};
+ $self->run_code($code);
my $new = $_;
my $aold = abs_path($old);
+ #die "Invalid path $old" unless defined($aold);
+ $aold = "" if !defined($aold);
my $anew = abs_path($new);
+ #die "Invalid path $new" unless defined($anew);
+ $anew = "" if !defined($anew);
$self->{_exists}{$aold}++ if (-e $aold);
return if $aold eq $anew;
+ $item->{name_for_script} = $new;
+ unless ($code_is_final) {
+ push @{ $item->{intermediates} }, $new;
+ return;
+ }
+
my $action;
if (!defined($self->{mode}) || $self->{mode} =~ /^(rename|r)$/) {
$action = "rename";
@@ -393,7 +447,9 @@ sub process_item {
$self->{_exists}{$anew}++;
delete $self->{_exists}{$aold} if $action eq 'rename';
print "DRYRUN: " if $self->{dry_run};
- print "$action `$old` -> `$new`\n" if $self->{verbose};
+ print "$action " . join(" -> ",
+ map {"`$_`"} $old, @{ $item->{intermediates} // []}, $new)."\n"
+ if $self->{verbose};
unless ($self->{dry_run}) {
my $res;
@@ -448,15 +504,25 @@ sub rename {
@items = @{ $self->{'items'} // [] };
}
- # for cleaning between run
+ @items = map { {real_name=>$_, name_for_script=>$_} } $self->_sort(@items);
+
if ($self->{_compiled}) {
- $self->run_code_for_cleaning();
- } else {
- $self->compile_code();
- $self->{_compiled} = 1;
+ # another run, clean first
+ $self->run_code_for_cleaning($_) for @{ $self->{'codes'} };
}
$self->{_exists} = {};
- $self->process_items(@items);
+ local $self->{'recursive'} = $self->{'recursive'};
+ for (my $i=0; $i < @{ $self->{'codes'} }; $i++) {
+ my $code = $self->{'codes'}[$i];
+ $self->compile_code($code) unless $self->{'compiled'};
+ next if $self->{'check'};
+ my $code_is_final = ($i == @{ $self->{'codes'} }-1);
+ $self->{'recursive'} = 0 if $i;
+ #print STDERR "DEBUG: items (before): ".dump(@items)."\n";
+ $self->process_items($code, $code_is_final, \@items);
+ #print STDERR "DEBUG: items (after): ".dump(@items)."\n";
+ }
+ $self->{'compiled'}++;
}
=head1 SEE ALSO
View
5 t/mv.t
@@ -2,7 +2,7 @@
use strict;
use warnings;
-use Test::More tests => 18;
+use Test::More tests => 2*11;
use FindBin '$Bin';
($Bin) = $Bin =~ /(.+)/;
@@ -22,4 +22,7 @@ test_perlmv(["a"], {code=>'"b/c/d"', parents=>1}, ["b"], 'parents on');
test_perlmv([1, 2, 3], {code=>'$_++'}, ["2.1", "3.1", "4"], 'reverse off');
test_perlmv([1, 2, 3], {code=>'$_++', reverse_order=>1}, ["2", "3", "4"], 'reverse on');
+test_perlmv([qw/aab abb acb/], {codes=>[\'remove-common-prefix', \'remove-common-suffix']}, [qw/a b c/], 'multi (scriptlet+scriptlet)');
+test_perlmv([qw/aab abb acb/], {codes=>[\'remove-common-prefix', '"file$_"', \'remove-common-suffix']}, [qw/filea fileb filec/], 'multi (scriptlet+eval+scriptlet)');
+
end_testing();
View
21 t/recursive.t
@@ -0,0 +1,21 @@
+#!perl -T
+
+use strict;
+use warnings;
+#use Test::More tests => 2;
+use Test::More skip_all => 'TODO';
+use FindBin '$Bin';
+($Bin) = $Bin =~ /(.+)/;
+
+our $Perl;
+our $Dir;
+
+require "$Bin/testlib.pl";
+prepare_for_testing();
+
+# TODO: still some problem with tainting in mode=method
+#test_perlmv([3, 4], {recursive=>1, extra_arg=>'a', codes=>['s/(\d+)/"file".($1+2).".ext"/e', 's/\.ext$//']}, [3, 4], '',
+# sub { mkdir "a"; open F, ">3"; open F, ">4"; open F, ">a/1"; open F, ">a/2" },
+# sub { ok((-f "file5") && (-f "file6") && (-d "a") && (-f "a/file3") && (-f "a/file4"), "recursive + multi") });
+
+end_testing();
View
37 t/testlib.pl
@@ -29,15 +29,23 @@ sub end_testing {
# script and then using method
sub test_perlmv {
- my ($files_before, $opts, $files_after, $test_name) = @_;
+ my ($files_before, $opts, $files_after, $test_name, $hook_before, $hook_after) = @_;
for my $which ("method", "binary") {
my $subdir = "rand".int(90_000_000*rand()+10_000_000);
mkdir $subdir or die "Can't mkdir $ENV{TESTING_HOME}/$subdir: $!";
chdir $subdir or die "Can't chdir to $ENV{TESTING_HOME}/$subdir: $!";
- create_files(@$files_before);
+ if ($hook_before) {
+ $hook_before->();
+ } else {
+ create_files(@$files_before);
+ }
run_perlmv($opts, $files_before, $which);
- files_are($files_after, "$test_name ($which)");
+ if ($hook_after) {
+ $hook_after->();
+ } else {
+ files_are($files_after, "$test_name ($which)");
+ }
remove_files();
chdir ".." or die "Can't chdir to ..: $!";
remove_tree($subdir) or die "Can't rmdir $ENV{TESTING_HOME}/$subdir: $!";
@@ -67,37 +75,49 @@ sub run_perlmv {
when ('dry_run') { push @cmd, "-d" }
when ('mode') { } # already processed above
when ('extra_opt') { } # will be processed later
+ when ('extra_arg') { } # will be processed later
when ('before_rmtree') { } # will be processed later
when ('overwrite') { push @cmd, "-o" }
when ('parents') { push @cmd, "-p" }
+ when ('recursive') { push @cmd, "-R" }
when ('reverse_order') { push @cmd, "-r" }
when ('verbose') { push @cmd, "-v" }
+ when ('codes') {
+ push @cmd, (map {ref($_) ? ("-x", $$_) : ("-e", $_)} @$v);
+ }
default { die "BUG: Can't handle opts{$_} yet!" }
}
}
if ($opts->{extra_opt}) { push @cmd, $opts->{extra_opt} }
do { /(.*)/; push @cmd, $1 } for @$files;
- #print "#DEBUG: system(", join(", ", @cmd), ")\n";
+ if ($opts->{extra_arg}) { push @cmd, $opts->{extra_arg} }
+ print "#DEBUG: system(", join(", ", @cmd), ")\n";
system @cmd;
die "Can't system(", join(" ", @cmd), "): $?" if $?;
} else {
my $pmv = App::perlmv->new;
for (keys %$opts) {
my $v = $opts->{$_};
if ($_ eq 'extra_opt') {
- $pmv->{code} = $pmv->load_scriptlet($v);
+ push @{ $pmv->{codes} }, $pmv->load_scriptlet($v);
+ } elsif ($_ eq 'extra_arg') {
+ # later, below
+ } elsif ($_ eq 'code') {
+ push @{ $pmv->{codes} }, $v;
} else {
$pmv->{$_} = $v;
}
}
- print "#DEBUG: {", join(", ", map {"$_=>$opts->{$_}"} sort keys %$opts), "} rename(", join(", ", @$files), ")\n";
+ local $pmv->{codes} = [map { ref($_) ? $pmv->load_scriptlet($$_) : $_ } @{ $pmv->{codes} }];
if ($opts->{compile}) {
- $pmv->compile_code;
+ $pmv->compile_code($_) for @{$pmv->{codes}};
} elsif ($opts->{write}) {
- $pmv->store_scriptlet($opts->{write}, $opts->{code});
+ $pmv->store_scriptlet($opts->{write}, $pmv->{codes}[0]);
} elsif ($opts->{delete}) {
$pmv->delete_user_scriptlet($opts->{delete});
} else {
+ $files = [@$files];
+ push @$files, $opts->{extra_arg} if $opts->{extra_arg};
$pmv->rename(@$files);
}
}
@@ -111,6 +131,7 @@ sub create_files {
do {open F, ">$_"; close F} for map { lc } @_;
}
+
sub remove_files {
for (<*>) { my ($f) = /(.+)/; unlink $f }
}
View
2 t/todo.txt
@@ -1,5 +1,5 @@
+- fix recursive test (-R)
- other options
- + recursive (-R)
+ files (-f)
+ no-symlinks (-S)
- autoglobbing in windows

0 comments on commit 4ded649

Please sign in to comment.