"Fossies" - the Fresh Open Source Software Archive

Member "littleutils-1.2.5/extra/pren.in" (29 Oct 2021, 3555 Bytes) of package /linux/privat/littleutils-1.2.5.tar.lz:

As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "pren.in": 1.2.4_vs_1.2.5.

    1 #! PROGPERL
    2 # vim: set filetype=perl:
    3 
    4 # pren: renames files using Perl regular expressions (perl rename)
    5 
    6 # Copyright (C) 2005-2021 by Brian Lindholm.  This file is part of the
    7 # littleutils utility set.
    8 #
    9 # The pren utility is free software; you can redistribute it and/or modify it
   10 # under the terms of the GNU General Public License as published by the Free
   11 # Software Foundation; either version 3, or (at your option) any later version.
   12 #
   13 # The pren utility is distributed in the hope that it will be useful, but
   14 # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   15 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
   16 # more details.
   17 #
   18 # You should have received a copy of the GNU General Public License along with
   19 # the littleutils.  If not, see <https://www.gnu.org/licenses/>.
   20 
   21 use strict;
   22 use warnings;
   23 use Fcntl;
   24 use Getopt::Std;
   25 
   26 # subroutine
   27 sub eval_regex {
   28   my $code = shift;
   29   for (@_) {
   30     eval $code;
   31   }
   32   return;
   33 }
   34 
   35 # get input arguments
   36 our $opt_e = 's/^//'; our $opt_h = ''; our $opt_n = ''; our $opt_q = ''; our $opt_v = '';
   37 my $good_opt = getopts('e:hnqv');
   38 
   39 # print help if requested or if bad options used, then quit
   40 if (not ($good_opt) or ($opt_h) or ($#ARGV < 0)) {
   41   print "pren LU_VERSION\n";
   42   print "usage: pren -e perlre [-h(elp)] [-n(o_rename)] [-q(uiet)] [-v(erbose)]\n";
   43   print "         filenames...\n";
   44   exit ($good_opt eq '');
   45 }
   46 
   47 # determine if we're running under DOS or Windows
   48 my $dos_win = (($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'cygwin'));
   49 
   50 # run through list of files
   51 my %path_writeable = ();
   52 LOOP: foreach my $old_name (@ARGV) {
   53   # clean up filename
   54   $old_name =~ s://+:/:;     # collapse multiple "/"
   55   $old_name =~ s:^(\./)+::;  # remove leading "./"
   56   $old_name =~ s:/$::;       # remove trailing "/"
   57   # skip certain cases
   58   next LOOP if (($old_name eq '.') || ($old_name eq '..'));
   59   # split into path and filename
   60   my $path = ''; my $name = '';
   61   if ($old_name =~ /^(.*)\/(.+?)$/) {
   62     $path = $1;
   63     $name = $2;
   64   }
   65   else {
   66     $path = '.';
   67     $name = $old_name;
   68   }
   69   # determine if path is writeable
   70   $path_writeable{$path} = (-w $path) unless (defined($path_writeable{$path}));
   71   unless ($path_writeable{$path}) {
   72     print STDERR "pren warning: you don't have write permissions in $path\n";
   73     next LOOP;
   74   }
   75   # determine new filename
   76   my $new_name = $name;
   77   eval_regex ($opt_e, $new_name);
   78   $new_name = $path . '/' . $new_name if ($path ne '.');
   79   # determine if rename should actually happen
   80   if ($new_name eq '') {
   81     print STDERR "pren warning: new filename for $name has zero length\n";
   82   }
   83   elsif ($new_name eq $old_name) {
   84     print STDOUT "pren message: old and new filenames for $name are the same\n" if ($opt_v);
   85   }
   86   elsif ((not $dos_win) && (-e $new_name)) {
   87     print STDERR "pren warning: new name for $old_name already exists\n";
   88   }
   89   elsif (($dos_win) && (lc($old_name) ne lc($new_name)) && (-e $new_name)) {
   90     print STDERR "pren warning: new name for $old_name already exists\n";
   91   }
   92   elsif ($opt_n) {
   93     print STDOUT "echo: rename $old_name $new_name\n";
   94   }
   95   else {
   96     if ((not $dos_win) && (-f $old_name)) {
   97       # the sysopen is for security in world-writeable directories
   98       sysopen(HANDLE, $new_name, O_RDWR | O_CREAT | O_EXCL, 0600) or die "pren ERROR: possible SYMLINK ATTACK!!\n";
   99       close(HANDLE);
  100     }
  101     rename($old_name, $new_name) or die "pren ERROR: move from $old_name to $new_name FAILED!!\n";
  102     print STDOUT "$old_name moved to $new_name\n" unless ($opt_q);
  103   }
  104 }