develooper Front page | perl.perl5.porters | Postings from April 2000

Re: [PATCH] eg/rename

From:
Tom Christiansen
Date:
April 3, 2000 19:39
Subject:
Re: [PATCH] eg/rename
Message ID:
7682.954815913@chthon
>On Sun, Apr 02, 2000 at 10:53:58PM -0700, Jan Dubois wrote:
>> On Sun, 2 Apr 2000 22:11:50 -0700 (PDT), Ask Bjoern Hansen
>> <ask@valueclick.com> wrote:
>> >
>> >I modernized eg/rename a little. (use strict, podified the documentation,
>> >added a few options, fixed the one bug it had).
>> >
>> >I'm not sure we care. If we do then I'll look into fixing up some more in
>> >that directory. If we don't then it should all go away.
>> 
>> Yes, eg/ should have been deleted for the 5.6 release:

>But the work on rename is much appreciated. It's something that belongs
>in a Unix toolbox. Debian even installs it in /usr/bin as part of the
>perl package.

I'm not sure about "modernized" there.  What about this approach?

    ($op = shift)               || die "Usage: rename expr [files]\n";
    *func = eval "sub { $op }"  || die;
    chomp(@ARGV = <STDIN>)      unless @ARGV; # names on stdin instead 
    for (@ARGV) {
        my $had_been = $_;
        func();
        rename($had_been,$_)    || die "can't rename $had_been to $_: $!"
            unless $had_been eq $_;
    }

Or this one...

# This is a shell archive.  Save it in a file, remove anything before
# this line, and then unpack it by entering "sh file".  Note, it may
# create directories; files and directories will be owned by you and
# have default permissions.
#
# This archive contains:
#
#	pathedit
#	rename (linked to pathedit)
#	relink (linked to pathedit)
#
echo x - pathedit
sed 's/^X//' >pathedit << 'END-of-pathedit'
X#!/usr/bin/perl
X# pathedit/rename/relink -- rename or relink files 
X# original rename and relink were by Larry Wall
X# this version by Tom Christiansen
X
Xuse 5.006;
Xuse strict;
Xuse warnings;
X
Xour(
X    $errcnt,    # how many didn't work
X    $verbose,   # trace actions
X    $nonono,    # but don't do them (implies verbose)
X    $careful,   # ask if target *appears* to exist 
X    $inspect,   # ask about everything
X    $quiet,     # don't carp if target skipped 
X    $force,     # overwrite existing target without prompting
X    $nullpaths, # stdin paths are null terminated, not \n
X    @flist,     # list of magic filenames containing paths to edit
X    $renaming,  # rename paths (disimplies reslinker)
X    $reslinking,# reslink paths (disimplies renamer)
X);
X
X$errcnt = 0;
X
Xopter();
Xcompiler();
Xfixer();
Xexit($errcnt != 0);
X
Xsub usage {
X    warn "@_\n" if @_;
X    die <<EOF;
Xusage: $0 [-ifqI0vnml] [-F file] perlexpr [files]
X    -i          ask about clobbering existent files
X    -f          force clobbers without inquiring
X    -q          quietly skip clobbers without inquiring
X    -I          ask about all changes
X    -0          read null-terminate filenames
X    -v          verbosely says what its doing 
X    -n          don't really do it
X    -m          to always rename
X    -l          to always symlink
X    -F path     read filelist to change from magic path(s)
XEOF
X} 
X
Xsub accesstty {
X    return 1 if defined fileno(TTYIN)  &&
X                defined fileno(TTYOUT);
X
X    unless (open(TTYIN, "</dev/tty") && open(TTYOUT,">/dev/tty")) {
X        return 0;
X    } 
X
X    select((select(TTYOUT),$|=1)[0]);
X    return 1;
X}
X
Xsub compiler {
X    my $op    = shift @ARGV || usage();
X    *pathedit = eval qq{
X        sub () { 
X            use warnings qw/FATAL all/;  # XXX: does not work
X            local \$SIG{__WARN__} = sub { 
X                local \$_ = "\@_";
X                s/at \\(eval.*//;
X                die "FATAL WARNING: \$_";
X            };
X            $op;
X        }   
X    } || do {
X        local $_ = $@;
X        s/at \(eval.*//s;
X        die "$0: can't compile perlexpr $op: $_\n";
X    } 
X} 
X
Xsub get_targets {
X    if (@ARGV) { 
X        usage "-F list exclusive of command line paths" if @flist;
X        return @ARGV;
X    } 
X    @ARGV = @flist ? @flist : '-';
X    local $/ = "\0" if $nullpaths;
X    my @paths = <>;
X    chomp @paths;
X    return @paths;
X} 
X
Xsub fixer {
X
X    my $oldslink;
X
XPATHNAME:
X    for my $oldname (get_targets()) {
X
X        if ($oldname =~ /\0/) {
X            warn "$0: null found in $oldname; did you forget -0?\n";
X            $errcnt++;
X            next PATHNAME;
X        } 
X        if ($renaming && !-e $oldname) {
X            warn "$0: $oldname doesn't exist\n";
X            $errcnt++;
X            next PATHNAME;
X        } 
X
X        if ($reslinking) {
X            unless (-l $oldname) {
X                warn "$0: $oldname ", (-e _) 
X                            ? "not a symbolic link\n"
X                            : "doesn't exist\n"
X                    unless $quiet;
X                $errcnt++;
X                next PATHNAME;
X            } 
X            $oldname = readlink($oldslink = $oldname);
X        } 
X        my $newname = do {
X            local $_ = $oldname;
X            pathedit();
X            $_;
X        };
X        next if $newname eq $oldname;
X
X        local *confirm = sub () { 
X            next PATHNAME unless accesstty();
X            print TTYOUT $renaming 
X                    ? "rename $oldname to $newname? "
X                    : "symlink $oldslink to point to $newname? ";
X            my $answer = <TTYIN>;
X            no warnings 'exiting';   # hush, you: it's in my lexical scope
X            last PATHNAME  unless defined $answer;  # exit?
X            chomp $answer;
X            last PATHNAME  if     "QUIT" =~ /^\Q$answer/i;
X            next PATHNAME  unless "YES"  =~ /^\Q$answer/i;
X        };
X
X        confirm() if $inspect;
X
X        #  "I'd like to teach 
X        #       The world to race 
X        #           In perfect hackery!"
X        my $was_there = do { 
X            no warnings 'newline';
X            -e $newname;
X        };
X
X        if ($renaming) {
X
X            if ($was_there && !$inspect && $careful) {
X                confirm() unless $force || $quiet;
X                next PATHNAME if $quiet;  
X            } 
X
X            unless (vrename($oldname, $newname)) {
X                warn "$0: can't rename $oldname to $newname: $!\n";
X                $errcnt++;
X                next PATHNAME;
X            } 
X
X        } 
X        elsif ($reslinking) {
X            unless ($was_there) {
X                warn "$0: symlinking $oldslink to nonexistent $newname\n" 
X                    unless $quiet;
X            }
X            unless (vunlink($oldslink)) {
X                warn "$0: can't unlink $oldslink: $!\n";
X                $errcnt++;
X                next PATHNAME;
X            }
X            if (!vsymlink($newname, $oldslink)) { 
X                warn "$0: can't symlink $newname to $oldslink: $!\n";
X                $errcnt++;
X                next PATHNAME;
X            }
X        } 
X        else {
X            die "Not reached";
X        } 
X
X    } 
X
X} 
X
Xsub vunlink {
X    my $goner = shift;
X    if ($verbose) {
X        print "unlink $goner\n";
X        return 1 if $nonono;
X    } 
X    unlink $goner;
X} 
X
Xsub vrename {
X    my ($old,$new) = @_;
X    if ($verbose) {
X        print "rename $old $new\n";
X        return 1 if $nonono;
X    } 
X    rename($old,$new);
X} 
X
Xsub vsymlink {
X    my ($new,$old) = @_;
X    if ($verbose) {
X        print "symlink $old -> $new\n";
X        return 1 if $nonono;
X    } 
X    symlink($new,$old);
X} 
X
Xsub opter {
X
XARG: while (@ARGV && $ARGV[0] =~ s/^-(?=.)//) {
XOPT:    for (shift @ARGV) {
X
X            m/^$/        && do {                                 next ARG; };
X            m/^-$/       && do {                                 last ARG; };
X
X            s/^0//       && do { $nullpaths++;                   redo OPT; };
X            s/^f//       && do { $force++;                       redo OPT; };
X            s/^l//       && do { $reslinking++;                  redo OPT; };
X            s/^I//       && do { $inspect++;                     redo OPT; };
X            s/^i//       && do { $careful++;                     redo OPT; };
X            s/^v//       && do { $verbose++;                     redo OPT; };
X            s/^m//       && do { $renaming++;                    redo OPT; };
X            s/^n//       && do { $nonono++;                      redo OPT; };
X            s/^q//       && do { $quiet++;                       redo OPT; };
X
X            s/^F(.*)//s  && do { push @flist, $1 || shift @ARGV; redo OPT; };
X
X            usage("Unknown option: $_");
X        }
X    }
X    unless ($renaming || $reslinking) {
X        $renaming   = $0 =~ /name/; 
X        $reslinking = $0 =~ /link/; 
X    } 
X    if ($renaming && $reslinking) {
X        usage "Can't both rename (-r) and relink (-h)";
X    } 
X    unless ($renaming || $reslinking) {
X        warn "$0: assuming renaming behavior requested\n";
X        $renaming++;
X    } 
X    $verbose++ if $nonono;
X
X    if ($inspect) { 
X        accesstty() || usage "can't inspect without /dev/tty: $!";
X    }
X
X} 
END-of-pathedit

echo chmod +x pathedit 
chmod +x pathedit

echo ln pathedit rename
ln pathedit rename

echo ln pathedit relink
ln pathedit relink

exit



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About