-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
The following script will try to only remove stale CVS locks when the
--pid option is used. However, it does assume that /usr/bin/ps accepts
the -p switch which may not be true on your platform. It will even try
to clean up locks in the LockDir directory if your repository has been
configured to use one of those instead.
Good luck,
-- Mark
: # use perl -*-Perl-*-
eval 'exec perl -S $0 ${1+"$@"}'
if 0;
=head1 NAME
find-locks.perl - locate and possibly remove stale cvs locks
=head1 SYNOPSIS
find-locks.perl [options]
Options:
-d cvsroot specify the local CVSROOT to be used
-l,--list print an ls-style of lock filenames
-n,--dry-run do not do anything to modify the filesystem
-c,--clean clean up stale locks (implies --pid)
-p,--pid check lock pids for stale processes
-h,--help print a help message
-v,--verbose verbose mode
--man a man page for this program
--debug turn on debugging
=head1 OPTIONS
=over 8
=item B<-d cvsroot>
Specify the pathname on the local system to
the CVSROOT to be searched. The default
cvsroot is /var/cvs which may not exist on
your system.
=item B<--list>
Print an ls-style output for the lock
filename. This is useful to see who owned the
lock files that are present or are about to be
removed.
=item B<--clean>
Try to remove stale locks from the system.
This options implicitly turns on the --pid
option.
=item B<--dry-run>
Do not do anything to modify the filesystem.
If --pid is used, then some locks may be
determined to be stale. This option will
disable actually removing any stale locks.
By default, if a pid is known to be stale for
a lock, the lock will be removed. However,
unless --pid is used, no pids will be examined.
=item B<--pid>
Run the /bin/ps command locally (or, if the
lock appears to have a hostname, remotely on
the given host) in order to determine if the
process id found as a part of the lock name is
still alive or is dead.
Locks associasted with pids that do not exist
are considered to be stale.
Stale lock files will be removed unless the
--dry-run option is given on the command line.
=item B<--verbose>
Add more verbosity to indicate what is
happening.
=item B<--help>
Prints a brief help message and exits.
=item B<--man>
Prints the manual page and exists.
=item B<--debug>
Print some diagnostics that are not generally
useful for normal operation.
=back
=head1 LICENSING
find-locks.perl - locate and possibly remove stale cvs locks
Copyright (c) 2003, 2004 by Mark D. Baushke <[EMAIL PROTECTED]>
All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
=head1 DESCRIPTION
This program -- B<find-locks.perl> -- is provided for cvs repository
administrators to try to detect cvs locks.
If given the C<--pid> option, the program will also attempt
to remove any stale locks associated with pids that no
longer exist according to the C</usr/bin/ps> command.
=head1 ERRORS
=over
=item CVSROOT=/var/cvs/. specifies an invalid repository.
This means that the (default) repository
(/var/cvs) provided does not exist or is not a
valid CVSROOT.
=back
=head1 AUTHOR
Mark D. Baushke E<lt>[EMAIL PROTECTED]<gt>
=cut
require 5.006;
use strict;
use warnings;
use File::Find;
use Sys::Hostname;
use Getopt::Long;
use Pod::Usage;
# Current version of this program
my $VERSION =
sprintf("%s", q$Id: find-locks.perl,v 1.6 2004/10/11 14:50:04 mdb Exp $
=~ /(\d+\.\d+)/);
# Global defaults:
my $repository = '/var/cvs';
my @pscmd_args = ('/bin/ps', '-p');
my $remote_shell = defined($ENV{'CVS_RSH'}) ? $ENV{'CVS_RSH'} : '/usr/bin/rsh';
# Option defaults
my($debug, $dry_run, $help, $filelist, $man, $try_ps, $verbose, $version) =
(0, 0, 0, 0, 0, 0, 1, 0);
GetOptions('clean|c' => sub { $dry_run = 0; $try_ps = 1; },
'debug!' => \$debug,
'dry-run!' => \$dry_run,
'help|h|?' => \$help,
'list|l' => \$filelist,
'man' => \$man,
'n' => sub { $dry_run = 1; },
'pid|p' => \$try_ps,
'quiet|q' => sub { $verbose = 0 },
'cvsroot|d=s' => \$repository,
'verbose|v+' => \$verbose,
'version' => \$version);
pod2usage(1) if $help;
pod2usage(-exitstatus => 0, -verbose => 2) if $man;
# Print the version and exit if the users wants to know
if ($version) {
printf("%s version %s\n", $0 =~ m{.*/(.*)}, $VERSION);
exit 0;
}
sub oneday { 86400; } # in seconds
my $maxtime = oneday;
my $thishost = hostname;
my $found = 0;
my $locksnuked = 0;
my($uid_user, @locks, %oldcvsuser, %uid_user, %lockfiles,
%rfl_lock, %pfl_lock, %wfl_lock, %tfl_lock, %dir_lock);
$repository .= '/.' if (-l $repository); # deal with symbolic links
pod2usage(-message => "'$repository' is an invalid repository",
-exitstatus => 1, -verbose => 0)
if (! -d $repository);
# Cleanup should probably include both the Repository and the LockDir
# even if the LockDir is provided.
my @dirlist;
if ( -d $repository.'/CVSROOT' ) {
push(@dirlist, $repository);
print("Checking CVSROOT=$repository\n") if ($verbose);
} else {
print(STDERR "CVSROOT=$repository points to non-repository.\n");
exit 1;
}
# Check CVSROOT/config for a LockDir directive
print("Attempting to read $repository/CVSROOT/config\n")
if ($debug);
if (open(CONFIG, $repository.'/CVSROOT/config')) {
my $line;
while($line = <CONFIG>) {
if ($line =~ /^LockDir=(.*)$/) {
my $lockdir = $1;
if ( -d $lockdir) {
if ( -l $lockdir ) {
my $link = readlink($lockdir);
print("LockDir=$lockdir is a symlink to $link\n")
if ($verbose);
$lockdir .= '/.';
}
# Found one
if ( -d $lockdir ) {
push(@dirlist, $lockdir);
print("Checking LockDir=$lockdir\n") if ($verbose);
}
}
unless ( -d $lockdir) {
print("Warning: LockDir=$lockdir is not a directory\n");
}
}
}
close(CONFIG);
}
# Do the search.
print("Starting find ", join(' ', @dirlist), "\n")
if ($debug);
File::Find::find(\&wanted, @dirlist);
# Print out uses of ancient versions of cvs when
# lock files were different.
foreach my $key (sort keys %oldcvsuser) {
printf("On %s, %s used an old version of cvs\n",
filetime($oldcvsuser{$key}), $key)
if ($verbose);
}
my $last = '';
foreach my $lock (sort @locks) {
next if ($lock eq $last);
$last = $lock;
my($pid, $host) = split("\t", $lock);
if (do_ps($pid, $host) eq stalelock()) {
my(@delfiles) = split(/\t/, $lockfiles{$lock});
print(join("\n\t",
($dry_run) ? "Need to delete files:" : "Deleting files:",
@delfiles),"\n");
unless ($dry_run) {
foreach my $file (@delfiles) {
print("rm $file\n") if ($verbose > 1);
if (unlink($file)) {
$locksnuked++;
} else {
warn "Unable to rmemove $file: $!";
}
}
}
}
}
# Print the results of the search
print "\n";
foreach my $key (sort keys %rfl_lock) {
print "There were $rfl_lock{$key} read locks owned by uid=$key
($uid_user{$key})\n";
}
foreach my $key (sort keys %pfl_lock) {
print "There were $pfl_lock{$key} promotable read locks owned by uid=$key
($uid_user{$key})\n";
}
foreach my $key (sort keys %wfl_lock) {
print "There were $wfl_lock{$key} write locks owned by uid=$key
($uid_user{$key})\n";
}
foreach my $key (sort keys %tfl_lock) {
print "There were $tfl_lock{$key} temp locks owned by uid=$key
($uid_user{$key})\n";
}
foreach my $key (sort keys %dir_lock) {
print "There were $dir_lock{$key} dir locks owned by uid=$key
($uid_user{$key})\n";
}
print(report_choice($found,
'There are no locks',
'Found a total of 1 lock',
"Found a total of $found locks"),
" in:\n\t", join("\n\t", @dirlist), "\n",
report_choice($locksnuked,
'No locks were',
'A total of 1 lock was',
"A total of $locksnuked locks were"),
" removed from:\n\t", join("\n\t", @dirlist), "\n");
if ($locksnuked > 0) {
$found -= $locksnuked;
print(report_choice($found,
'There are no locks',
'There is a total of 1 lock',
"There are a total of $found locks"),
" remaining in:\n\t", join("\n\t", @dirlist), "\n");
}
exit 0;
sub stalelock {"Lock is stale";}
sub activelock {"Lock still active";}
sub unknownlock {"Lock may or may not be present";}
sub report_choice {
my($cnt, @list) = @_;
$cnt = 0 if ($cnt < 0);
$cnt = 2 if ($cnt > 1);
$list[$cnt];
}
# when wanted() is called
# $dir - current directory name
# $_ - the current filename within $dir
# $name - "$dir/$_"
# current directory is $dir
# $prune - may be set to prune the tree
sub wanted {
my($dir) = $File::Find::dir;
my($name) = $File::Find::name;
my($file) = $_;
my($username);
if ($verbose > 1 && ($name !~ /Attic$/) && -d $_ ) {
print "find-locks scanning directory ", $name, "\n";
}
if ($file =~ /^\#cvs/) {
$found++;
print $name,"\n" if ($debug || (!$filelist));
do_ls($name) if ($filelist);
my($uid,$gid,$rdev,$size,$atime,$mtime) = (stat($name))[4..9];
# Transient lock files go away very fast, use the
# cached stat handle "_" to see if it already gone.
return if (! -e _);
my($user, $igd, $username, $lock, $mach, $proc);
($user, undef, undef, $gid, undef, undef, $username) = getpwuid($uid);
$user = "uid$uid" if ($user eq '');
$uid_user{$uid} = $user;
my(@parts) = split(/\./, $file);
$proc = pop(@parts);
shift(@parts);
$lock = shift(@parts);
$mach = join('.',@parts);
printf(STDERR "lock=%s, uid=%s (%s:%s), machine=%s, pid=%s\n",
$lock, $uid, $user, $username, $mach, $proc) if ($debug);
my($time) = time;
if ($file =~ /\#cvs\.wfl/) { # write file lock
$wfl_lock{$uid}++;
}
elsif ($file =~ /\#cvs\.rfl/) { # read file lock
$rfl_lock{$uid}++;
}
elsif ($file =~ /\#cvs\.pfl/) { # promotable read file lock
$pfl_lock{$uid}++;
}
elsif ($file =~ /\#cvs\.tfl/) { # transient file lock
$tfl_lock{$uid}++;
}
elsif ( $file =~ /\#cvs\.lock/ ) {
$dir_lock{$uid}++;
}
if (($time - $mtime) > $maxtime) {
print("lock is more than $maxtime seconds old!\n")
if ($verbose > 1);
}
if ($proc ne '') {
push(@locks, "$proc\t$mach") if ($try_ps);
if (!defined($lockfiles{"$proc\t$mach"})) {
$lockfiles{"$proc\t$mach"} = $name;
} else {
$lockfiles{"$proc\t$mach"} .= "\t".$name;
}
}
elsif ($file ne "\#cvs.lock") {
my $key = "\"$username\" <$user> (uid=$uid)";
$oldcvsuser{$key} = $mtime if ($oldcvsuser{$key} < $mtime);
}
}
}
# This function does its own 'ls' command implementation because
# transient lock files go away very quickly and firing up an 'ls'
# for every lock that the find saw can really pound your cvs server.
sub do_ls {
my($filename) = @_;
my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
$atime, $mtime) = lstat($filename);
# Transient lock files go away very fast, use the cached
# lstat handle "_" to see if it already gone.
return if (! -e _);
my $user = (getpwuid($uid))[0];
my $group = (getgrgid($gid))[0];
return if (! -e $filename); # transient lock files go away very fast
my $modebuf = filemode($mode);
my $timebuf = filetime($mtime);
$user = $uid if ($user eq '');
$group = $gid if ($group eq '');
printf("%s%3d %-8.8s %-8.8s %8d %s %s", $modebuf, $nlink, $user,
$group, $size, $timebuf, $filename);
if (S_ISLNK($mode)) {
printf("-> %s\n", readlink($filename));
($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
$atime, $mtime) = stat($filename);
$user = (getpwuid($uid))[0];
$group = (getgrgid($gid))[0];
$modebuf = filemode($mode);
$timebuf = filetime($mtime);
printf("%s%3d %-8.8s %-8.8s %8d %s %s", $modebuf, $nlink, $user,
$group, $size, $timebuf, readlink($filename));
}
print("\n");
}
# There are probably better ways to do this
sub do_ps {
my($pid, $host) = @_;
my @text;
my $res;
if ($host eq $thishost) {
print(join(' ', @pscmd_args, $pid), "\n")
if ($verbose);
open(PSCMD, "-|") || exec @pscmd_args, $pid;
@text = <PSCMD>;
close(PSCMD);
} else {
print(join(' ',$remote_shell, $host, @pscmd_args, $pid), "\n")
if ($verbose);
open(PSCMD, "-|") || exec $remote_shell, $host, @pscmd_args, $pid;
@text = <PSCMD>;
close(PSCMD);
}
if (scalar(@text)) {
print(@text) if ($verbose);
my($line) = pop(@text);
if ($line =~ /^\s*$pid\s/) {
$res = activelock();
} else {
$res = stalelock();
}
} else {
$res = unknownlock();
}
$res
}
sub filetime {
my($time) = @_;
my($current_time) = time;
my($sixmonths) = 6 * 30 * 24 * 60 * 60;
my(@MoY) = ('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');
my($sec, $min, $hour, $mday, $mon, $year) = localtime($time);
my($res);
$year += 1900;
if (($current_time > ($time + $sixmonths)) ||
($current_time < ($time - (60 * 60)))) {
$res = sprintf("%s %2d %d", $MoY[$mon], $mday, $year);
}
else {
$res = sprintf("%s %2d %02d:%02d", $MoY[$mon], $mday, $hour, $min);
}
$res;
}
sub filemode {
my($mode) = @_;
my @digits = (split(//,sprintf("%o",$mode)));
my $o = pop(@digits);
my $g = pop(@digits);
my $u = pop(@digits);
my $s = pop(@digits);
my $modebuf = '?';
$modebuf = 'b' if S_IFBLK($mode); # for block special
$modebuf = 'c' if S_ISCHR($mode); # for character
$modebuf = 'd' if S_ISDIR($mode); # for directory
$modebuf = '-' if S_ISREG($mode); # for regular file
$modebuf = 'p' if S_ISFIFO($mode); # for fifo
$modebuf = 'l' if S_ISLNK($mode); # for symbolic link
$modebuf = 's' if S_ISSOCK($mode); # for socket
$modebuf = 'w' if S_ISWHT($mode); # for whiteout
$modebuf .= modebits($u, ($mode & 04000), 's', 'S');
$modebuf .= modebits($g, ($mode & 02000), 's', 'S');
$modebuf .= modebits($o, ($mode & 01000), 't', 'T');
$modebuf;
}
sub modebits {
my($oct, $bit, $x1, $x2) = @_;
my($res);
if ($oct & 04) { $res = 'r'; } else { $res = '-'; }
if ($oct & 02) { $res .= 'w'; } else { $res .= '-'; }
if (($oct & 01) && $bit) { $res .= $x1; }
elsif (($oct & 01) && (!$bit)) { $res .= 'x'; }
elsif ($bit) { $res .= $x2; }
else { $res .= '-'; }
$res;
}
sub S_IFMT { 0170000; } # type of file
sub S_IFIFO { 0010000; } # FIFO special
sub S_IFCHR { 0020000; } # character special
sub S_IFDIR { 0040000; } # directory
sub S_IFBLK { 0060000; } # block special
sub S_IFREG { 0100000; } # regular file
sub S_IFLNK { 0120000; } # symbolic link
sub S_IFSOCK { 0140000; } # socket
sub S_IFWHT { 0160000; } # whiteout
sub S_ISDIR { my($m) = @_; ((S_IFMT() & $m) == S_IFDIR()); }
sub S_ISCHR { my($m) = @_; ((S_IFMT() & $m) == S_IFCHR()); }
sub S_ISBLK { my($m) = @_; ((S_IFMT() & $m) == S_IFBLK()); }
sub S_ISREG { my($m) = @_; ((S_IFMT() & $m) == S_IFREG()); }
sub S_ISLNK { my($m) = @_; ((S_IFMT() & $m) == S_IFLNK()); }
sub S_ISSOCK { my($m) = @_; ((S_IFMT() & $m) == S_IFSOCK()); }
sub S_ISFIFO { my($m) = @_; ((S_IFMT() & $m) == S_IFIFO()); }
sub S_ISWHT { my($m) = @_; ((S_IFMT() & $m) == S_IFWHT()); }
__END__
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.3 (FreeBSD)
iD8DBQFCuxjj3x41pRYZE/gRAvw1AKCJ0fIPhQLgtcSLQciv9aFInNaxXwCgqdmu
hPJ/gVTajOCFTOYvKWtZLQA=
=HZIg
-----END PGP SIGNATURE-----
_______________________________________________
Info-cvs mailing list
Info-cvs@gnu.org
http://lists.gnu.org/mailman/listinfo/info-cvs
