"Fossies" - the Fresh Open Source Software Archive

Member "littleutils-1.2.5/scripts/lcuc.in" (29 Oct 2021, 4011 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 "lcuc.in": 1.2.4_vs_1.2.5.

    1 #! PROGPERL
    2 # vim: set filetype=perl:
    3 
    4 # PROGNAME: rename files to all PROGNAME filenames
    5 
    6 # Copyright (C) 2005-2021 by Brian Lindholm.  This file is part of the
    7 # littleutils utility set.
    8 #
    9 # The PROGNAME utility is free software; you can redistribute it and/or modify
   10 # it 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 PROGNAME 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 # specify modules
   22 use strict;
   23 use warnings;
   24 use Fcntl;
   25 use Getopt::Std;
   26 use locale;
   27 
   28 # get input arguments
   29 our $opt_h = ''; our $opt_q = ''; our $opt_v = ''; our $opt_x = ''; our $opt_X = '';
   30 my $good_opt = getopts('hqvxX');
   31 
   32 # print help if requested or if bad options used, then quit
   33 if (not ($good_opt) or ($opt_h) or ($#ARGV < 0)) {
   34   print "PROGNAME LU_VERSION\n";
   35   print "usage: PROGNAME [-h(elp)] [-q(uiet)] [-v(erbose)]\n";
   36   print "         [-x(tension_only)] [-X(tensions_only)] file...\n";
   37   exit ($good_opt eq '');
   38 }
   39 
   40 # determine if we're running under DOS or Windows
   41 my $dos_win = (($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'cygwin'));
   42 
   43 # run through list of files
   44 my %path_writeable = ();
   45 LOOP: foreach my $old_name (@ARGV) {
   46   # clean up filename
   47   $old_name =~ s://+:/:;     # collapse multiple "/"
   48   $old_name =~ s:^(\./)+::;  # remove leading "./"
   49   $old_name =~ s:/$::;       # remove trailing "/"
   50   # skip certain cases
   51   next LOOP if (($old_name eq '.') || ($old_name eq '..'));
   52   # split into path and filename
   53   my $path = ''; my $name = '';
   54   if ($old_name =~ /^(.*)\/(.+?)$/) {
   55     $path = $1;
   56     $name = $2;
   57   }
   58   else {
   59     $path = '.';
   60     $name = $old_name;
   61   }
   62   # determine if path is writeable
   63   $path_writeable{$path} = (-w $path) unless (defined($path_writeable{$path}));
   64   unless ($path_writeable{$path}) {
   65     print STDERR "pren warning: you don't have write permissions in $path\n";
   66     next LOOP;
   67   }
   68   # split into base and filename if requested
   69   my $base = ''; my $ext = ''; my $trying = 0;
   70   if ($opt_x) {
   71     if ($name =~ /^(.+)\.([^.]+)$/) {
   72       $base = $1;
   73       $ext = $2;
   74       $trying = 1;
   75     }
   76     else {
   77       $base = $name;
   78       $ext = '';
   79       $trying = 0;
   80     }
   81   }
   82   elsif ($opt_X) {
   83     if ($name =~ /^(.*?)\.(.+)$/) {
   84       $base = $1;
   85       $ext = $2;
   86       $trying = 1;
   87     }
   88     else {
   89       $base = $name;
   90       $ext = '';
   91       $trying = 0;
   92     }
   93   }
   94   # convert to PROGNAME
   95   my $new_name = '';
   96   if ($path eq '.') {
   97     if (($opt_x || $opt_X) && $trying) {
   98       $new_name = $base . '.' . KEYFUNC($ext);
   99     }
  100     else {
  101       $new_name = KEYFUNC($name);
  102     }
  103   }
  104   else {
  105     if (($opt_x || $opt_X) && $trying) {
  106       $new_name = $path . '/' . $base . '.' . KEYFUNC($ext);
  107     }
  108     else {
  109       $new_name = $path . '/' . KEYFUNC($name);
  110     }
  111   }
  112   # determine if rename should actually happen
  113   if (($opt_x || $opt_X) && (not $trying)) {
  114     print STDOUT "PROGNAME message: skipping $old_name\n" if ($opt_v);
  115   }
  116   elsif ($new_name eq $old_name) {
  117     print STDOUT "PROGNAME message: $old_name already PROGNAME\n" if ($opt_v);
  118   }
  119   elsif ((not $dos_win) && (-e $new_name)) {
  120     print STDERR "PROGNAME warning: new name for $old_name already exists\n";
  121   }
  122   else {
  123     if ((not $dos_win) && (-f $old_name)) {
  124       # the sysopen is for security in world-writeable directories
  125       sysopen(HANDLE, $new_name, O_RDWR | O_CREAT | O_EXCL, 0600) or die "PROGNAME ERROR: possible SYMLINK ATTACK!!\n";
  126       close(HANDLE);
  127     }
  128     rename($old_name, $new_name) or die "PROGNAME ERROR: move from $old_name to $new_name FAILED!!\n";
  129     print STDOUT "$old_name moved to $new_name\n" unless ($opt_q);
  130   }
  131 }