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