Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine

Moving, copying and renaming files with new tool

by siberia-man (Monk)
on Aug 14, 2019 at 09:22 UTC ( #11104437=CUFP: print w/replies, xml ) Need Help??

Hello Monks,

I re-invented the wheel and decided to share it. This is script that is supposed to be used as a tool for moving, copying and renaming files. In the beginning I called it as "the re-invented wheel" becuase there are a few implementations for such kind of functionality. I found 3 of them at least (all are mentioned in the documentation). While developing the script I borrowed some good ideas from those implementations and adapted for my script. And I applied my vision of the conveniency.

Here I show some scenarios from real life I've really met:

Removing prefixes and suffixes:

file-rename 's/^[^.]+\.//; s/\.[^.]+$//' ...
Enumerate files:
file-rename 's/^/sprintf "%02d. ", $NR/' ...

By default the script implements move files, but it is possible to copy them with the option -c, --copy.

It is posible to include/exclude Perl modules with the option -M for those cases it you need to apply something very specific. It is similar to Perl's own option.

With the -T or --transcode option it is possible to apply encoding over names. For example the following example works fine for filenames in Cyrillic with Perl 5.14 under Cygwin 1.7.25:

file-rename -Tutf8 '$_ = ucfirst' -f ...

Handling with filename component is enabled with the option -N, --filename-only. The is example (prepending filenames with some prefix):

file-rename 's/^/old-/' -N ../*

Verbosity, forcing and dry-run are implemented with the -v, -f and -n options, respectively. The long options are also available

I have still never met the case of using the zero-terminated lines but implemented it with the options -z, -0, --null.

The last thing I developed is renaming in loop with the option -r, --rename. With this option we can:

Rotate files cyclically to left (resulting to file2 file3 file4 file1):

file-rename --rename=rotate-left file1 file2 file3 file4
Rotate files cyclically to right (resulting to file4 file1 file2 file3):
file-rename --rename=rotate-right file1 file2 file3 file4
Swap pair of files (swap nearest, resulting to file2 file1 file4 file3):
file-rename --rename=swap file1 file2 file3 file4
Flip the whole list of files (swap farthest, resulting to file4 file3 file2 file1):
file-rename --rename=flip file1 file2 file3 file4

The script lives in github. Below is the latest version to the moment of the writing.

#!/usr/bin/env perl =head1 NAME file-rename - rename multiple files =head1 SYNOPSIS file-rename [OPTIONS] [[-e|-E CODE]*|CODE] [FILES] =head1 DESCRIPTION C<file-rename> renames the files according to the rule specified as the first argument. The perlexpr argument is a Perl expression which is expected to modify the $_ string in Perl for at least some of the filenames specified. If a given filename is not modified by the expression, it will not be renamed. If no filenames are given on the command line, filenames will be read via standard input. =head1 OPTIONS =over 8 =item B<-h>, B<--help> Outputs this help page. =item B<-e> I<EXPRESSION>, B<-E> I<EXPRESSION>, B<--expr>=I<EXPRESSION +> The code to be executed on filenames. It uses all the power by Perl an +d supplies the mechanism for renaming files. In addition it supplies the special variable C<$NR> as a reference for the current line number to enable enumeration if it's necessary. For example: file-rename 's/^/$NR. /' ... file-rename 's/^/sprintf "%02d. ", $NR/e' ... When the B<-T> option is specified, the C<$ENCODE> and C<$DECODE> variables are used internally for encoding and decoding the processed file names. See the corresponding description below. =item B<-M> I<[-]MODULE[=IMPORT]> Load the module. It's almost similar to Perl's own option B<-M>. It executes C<use MODULE> before executing the expressions. It executes C<no MODULE>, if a dash C<-> is specified before the modul +e name. The comma-separated list C<IMPORT> causes the module to import specifi +c symbols. =item B<-T> I<ENCODE>, B<--transcode>=I<ENCODE> Apply for each filename the decoding before processing and encoding after processing. To encode output in a different encoding than input was decoded, two comma-separated encoding names are supplied. Assuming the script is launched as below: -T ENC1,ENC2 -e '...' in fact, it works as follows: -MEncode -e '$_ = $DECODE->decode($_); ...; $_ = $ENCODE->encode($_) +' where C<$DECODE> and C<$ENCODE> are encoding objects corresponding to the encodings C<ENC1> and C<ENC2>. =item B<-v>, B<--verbose> Be verbose. =item B<-n>, B<--dry-run> Do nothing but print what can be done. =item B<-c>, B<--copy> Copy instead of move. =item B<-f>, B<--force> Overwrite existing files. =item B<-N>, B<--filename-only> Do not rename directories: only rename filename component of path. =item B<-z>, B<-0>, B<--null> Treat the input as a set of lines terminated by a zero byte C<\0>, instead of a newline. =item B<-r> I<RENAME-MODE>, B<--rename>=I<RENAME-MODE> Rename files cyclically. Rotation is implemented by the Perl core func +tion C<rename> and is limited by a single file system. =over 8 =item I<l> or I<rotate-left> Rename files rotating names left: f1 <- f2 <- ... <- fn <- f1 =item I<r> or I<rotate-right> Rename files rotating names right: f1 -> f2 -> ... -> fn -> f1 =item I<s> or I<swap> Rename files by swapping the closest names: f1 <-> f2 f3 <-> f4 ... =item I<f> or I<flip> Rename files by swapping the farthest names: f1 <-> fn f2 <-> fn-1 ... =back =back =head1 SEE ALSO mv(1) cp(1) perldoc -f rename perldoc File::Copy L<> L<> L<> =head1 AUTHORS This script is inspired by codes from Larry Wall and Robin Barker with some other ideas from perlancar and Aristotle Pagaltzis. This work is attempt to rethink the already existing scripts, rework the code, exte +nd (if it's possible) and make the usage more convenient. The last one is my personal vision. Ildar Shaimordanov =head1 COPYRIGHT Copyright 2019 by Ildar Shaimordanov This program is free software; you can redistribute it and/or modify i +t under the same terms as Perl itself. =cut # ==================================================================== +===== use strict; use warnings; use Getopt::Long qw(:config no_ignore_case bundling); use Pod::Usage; use File::Copy; # ==================================================================== +===== my $verbose; my $dry_run; my $force; my $action = "move"; my $filename_only; my $null; my $die_on_error; # Current line number my $NR = 0; my @expr; my @use; my $transcode; my $rename_mode; my %rename_modes = ( "l" => "rotate-left", "r" => "rotate-right", "s" => "swap", "f" => "flip", ); exit 1 unless GetOptions( "h|help" => sub { pod2usage({ -verbose => 2, -noperldoc => +1 }); }, "v|verbose" => \$verbose, "n|dry-run" => sub { $dry_run = $verbose = 1; }, "c|copy" => sub { $action = "copy"; }, "f|force" => \$force, "N|filename-only" => \$filename_only, "z|0|null" => \$null, "e|E|expr=s@" => \@expr, "M=s@" => \@use, "T|transcode=s" => \$transcode, "r|rename=s" => sub { ( $rename_mode ) = $rename_modes{ $_[1] } // grep /\Q$_[1]\E/, + values %rename_modes; die "Bad rename mode: $_[1]\n" unless $rename_mode; }, ); # ==================================================================== +===== sub input { unless ( -t 0 ) { warn "Reading from <stdin>\n" if $verbose; local $/ = "\0" if $null; chop( @ARGV = <STDIN> ); } # globbing only when meet wildcards # so win and unix works the same way @ARGV = map { /[*?]/ ? glob : $_ } @ARGV; } sub act { my ( $x, $y ) = @_; $verbose and warn "$action '$x' '$y'\n"; return if $dry_run; no strict 'refs'; $action->($x, $y) or do { warn "Cannot $action '$x' '$y': $!\n"; exit 255 if $die_on_error; } } # When invoke the core rename function under the no strict refs mode, # Perl dies with the message "Undefined subroutine &main::rename calle +d". # I redeclare the function to avoid this error. sub rename { CORE::rename $_[0], $_[1]; } # ==================================================================== +===== $rename_mode and do { input; # Make sure the files exist for ( @ARGV ) { die "'$_' not found\n" unless -e $_; } # Create a temp filename that doesn't exist my $tmp; while ( 1 ) { $tmp = sprintf "rotate-tmp-%d", rand() * 1_000_000; last unless -e $tmp; } # Prepare replacement list # rotate left : tmp f1 f2 ... fn-1 fn tmp # rotate right : tmp fn fn-1 ... f2 f1 tmp # swap files : tmp f1 f2 tmp ... fn-1 fn tmp # flip files : tmp fn f1 tmp fn-1 f2 tmp ... # # Renaming will be done in the loop, accordingly this way: # rename $argv[$i], $argv[$i-1] my @files; if ( $rename_mode eq "rotate-left" ) { @files = ( $tmp, @ARGV, $tmp ); } elsif ( $rename_mode eq "rotate-right" ) { @files = ( $tmp, reverse(@ARGV), $tmp ); } elsif ( $rename_mode eq "swap" ) { die "Even number of files required\n" if @ARGV % 2; @files = ( $tmp ); for ( my $i = 1; $i < @ARGV; $i += 2 ) { push @files, $ARGV[$i - 1], $ARGV[$i], $tmp; } } elsif ( $rename_mode eq "flip" ) { die "Even number of files required\n" if @ARGV % 2; @files = ( $tmp ); for ( my $i = 0; $i < @ARGV / 2; $i++ ) { push @files, $ARGV[$#ARGV - $i], $ARGV[$i], $tmp; } } $action = "rename"; $die_on_error = 1; # Rename files accordingly the selected mode for ( my $i = 1; $i < @files; $i++ ) { my $x = $files[$i]; my $y = $files[$i - 1]; act $x, $y; } exit; }; # ==================================================================== +===== push @expr, shift if ! @expr && @ARGV; @expr or pod2usage; for ( @use ) { s/^-/no / or s/^/use /; s/=(.*)/ split ",", q{$1}/; } my $DECODE; my $ENCODE; if ( $transcode ) { my @objs; for ( split /,/, $transcode, 2 ) { my $obj = Encode::find_encoding($_) or die "Encoding not found +: $_\n"; push @objs, $obj; } ( $DECODE, $ENCODE ) = @objs; $ENCODE //= $DECODE; push @use, 'use Encode'; unshift @expr, '$_ = $DECODE->decode($_)'; push @expr, '$_ = $ENCODE->encode($_)'; } my $code = join ";", @use, @expr; my $eval = eval sprintf "sub {\n#line 1\n%s\n}", $code or die $@; my $evaluate = ! $filename_only ? $eval : sub { require File::Spec; my ( $vol, $dir, $file ) = File::Spec->splitpath($_); $eval->() for ( $file ); $_ = File::Spec->catpath($vol, $dir, $file); }; # ==================================================================== +===== for ( input ) { $NR++; my $old = $_; $evaluate->(); if ( $old eq $_ ) { warn "'$old' not changed'\n" if $verbose; next; } if ( -e $_ && ! $force ) { warn "'$old' not renamed: '$_' already exists\n"; next; } act $old, $_; } # ==================================================================== +===== # EOF

Replies are listed 'Best First'.
Re: Moving, copying and renaming files with new tool
by FreeBeerReekingMonk (Deacon) on Sep 14, 2019 at 21:22 UTC
    I love the log rotation idea; will grab it for work (thanks for the permissive license).
    I liked to read your code; if syntactic style was a flavour, this one tastes differently to what I use to read.

      See also multilog, part of daemontools, but can be used stand-alone. For more information, see the djb way for a longer description, or this search for my other daemontools-releated postings.


      Today I will gladly share my knowledge and experience, for there are no sweeter words than "I told you so". ;-)
      Thank you for your feedback. I am happy, if it helps in your work. :)
Re: Moving, copying and renaming files with new tool
by siberia-man (Monk) on Sep 16, 2019 at 14:32 UTC
    I've been pointed to use <code> or <pre> tags for code samples due to PerlMnks translates [...] to links. To be honest, the source code of the script is already wrapped by the <pre> tags. I modified the initial post using the combination of both as follows <pre><code>.
      I've been pointed to use <code> or <pre> tags for code samples ... I modified the initial post using the combination of both as follows <pre><code>.

      What problem did you encounter when you used  <code> tags alone? I took a brief look at the OP a while ago and I don't recall noticing so much whitespace in it. Is this the effect you wished to achieve? (Maybe it's just an artifact of the rendering of my browser.)

      Give a man a fish:  <%-{-{-{-<

        Input: просто другой хакер жемчуга


        &#1087;&#1088;&#1086;&#1089;&#1090;&#1086; &#1076;&#1088;&#1091;&#1075 +;&#1086;&#1081; &#1093;&#1072;&#1082;&#1077;&#1088; &#1078;&#1077;&#1 +084;&#1095;&#1091;&#1075;&#1072;
        просто другой хакер жемчуга

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://11104437]
Front-paged by Corion
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chilling in the Monastery: (6)
As of 2020-07-13 21:56 GMT
Find Nodes?
    Voting Booth?

    No recent polls found