/contrib/cvs/contrib/rcslock.in

  1#! @PERL@ -T
  2# -*-Perl-*-
  3
  4# Copyright (C) 1994-2005 The Free Software Foundation, Inc.
  5
  6# This program is free software; you can redistribute it and/or modify
  7# it under the terms of the GNU General Public License as published by
  8# the Free Software Foundation; either version 2, or (at your option)
  9# any later version.
 10#
 11# This program is distributed in the hope that it will be useful,
 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 14# GNU General Public License for more details.
 15
 16###############################################################################
 17###############################################################################
 18###############################################################################
 19#
 20# THIS SCRIPT IS PROBABLY BROKEN.  REMOVING THE -T SWITCH ON THE #! LINE ABOVE
 21# WOULD FIX IT, BUT THIS IS INSECURE.  WE RECOMMEND FIXING THE ERRORS WHICH THE
 22# -T SWITCH WILL CAUSE PERL TO REPORT BEFORE RUNNING THIS SCRIPT FROM A CVS
 23# SERVER TRIGGER.  PLEASE SEND PATCHES CONTAINING THE CHANGES YOU FIND
 24# NECESSARY TO RUN THIS SCRIPT WITH THE TAINT-CHECKING ENABLED BACK TO THE
 25# <@PACKAGE_BUGREPORT@> MAILING LIST.
 26#
 27# For more on general Perl security and taint-checking, please try running the
 28# `perldoc perlsec' command.
 29#
 30###############################################################################
 31###############################################################################
 32###############################################################################
 33
 34# Author: John Rouillard (rouilj@cs.umb.edu)
 35# Supported: Yeah right. (Well what do you expect for 2 hours work?)
 36# Blame-to: rouilj@cs.umb.edu
 37# Complaints to: Anybody except Brian Berliner, he's blameless for
 38#		 this script.
 39# Acknowlegements: The base code for this script has been acquired
 40# 		   from the log.pl script.
 41
 42# rcslock.pl - A program to prevent commits when a file to be ckecked
 43# 	       in is locked in the repository.
 44
 45# There are times when you need exclusive access to a file.  This
 46# often occurs when binaries are checked into the repository, since
 47# cvs's (actually rcs's) text based merging mechanism won't work. This
 48# script allows you to use the rcs lock mechanism (rcs -l) to make
 49# sure that no changes to a repository are able to be committed if
 50# those changes would result in a locked file being changed.
 51
 52# WARNING:
 53# This script will work only if locking is set to strict.
 54#
 55
 56# Setup:
 57# Add the following line to the commitinfo file:
 58
 59#         ALL /local/location/for/script/lockcheck [options]
 60
 61# Where ALL is replaced by any suitable regular expression.
 62# Options are -v for verbose info, or -d for debugging info.
 63# The %s will provide the repository directory name and the names of
 64# all changed files.  
 65
 66# Use:
 67# When a developer needs exclusive access to a version of a file, s/he
 68# should use "rcs -l" in the repository tree to lock the version they
 69# are working on.  CVS will automagically release the lock when the
 70# commit is performed.
 71
 72# Method:
 73# An "rlog -h" is exec'ed to give info on all about to be
 74# committed files.  This (header) information is parsed to determine
 75# if any locks are outstanding and what versions of the file are
 76# locked.  This filename, version number info is used to index an
 77# associative array.  All of the files to be committed are checked to
 78# see if any locks are outstanding.  If locks are outstanding, the
 79# version number of the current file (taken from the CVS/Entries
 80# subdirectory) is used in the key to determine if that version is
 81# locked. If the file being checked in is locked by the person doing
 82# the checkin, the commit is allowed, but if the lock is held on that
 83# version of a file by another person, the commit is not allowed.
 84
 85$ext = ",v";  # The extension on your rcs files.
 86
 87$\="\n";  # I hate having to put \n's at the end of my print statements
 88$,=' ';   # Spaces should occur between arguments to print when printed
 89
 90# turn off setgid
 91#
 92$) = $(;
 93
 94#
 95# parse command line arguments
 96#
 97require 'getopts.pl';
 98
 99&Getopts("vd"); # verbose or debugging
100
101# Verbose is useful when debugging
102$opt_v = $opt_d if defined $opt_d;
103
104# $files[0] is really the name of the subdirectory.
105# @files = split(/ /,$ARGV[0]);
106@files = @ARGV[0..$#ARGV];
107$cvsroot = $ENV{'CVSROOT'};
108
109#
110# get login name
111#
112$login = getlogin || (getpwuid($<))[0] || "nobody";
113
114#
115# save the current directory since we have to return here to parse the
116# CVS/Entries file if a lock is found.
117#
118$pwd = `/bin/pwd`;
119chop $pwd;
120
121print "Starting directory is $pwd" if defined $opt_d ;
122
123#
124# cd to the repository directory and check on the files.
125#
126print "Checking directory ", $files[0] if defined $opt_v ;
127
128if ( $files[0] =~ /^\// )
129{
130   print "Directory path is $files[0]" if defined $opt_d ;
131   chdir $files[0] || die "Can't change to repository directory $files[0]" ;
132}
133else
134{
135   print "Directory path is $cvsroot/$files[0]" if defined $opt_d ;
136   chdir ($cvsroot . "/" . $files[0]) || 
137         die "Can't change to repository directory $files[0] in $cvsroot" ;
138}
139
140
141# Open the rlog process and apss all of the file names to that one
142# process to cut down on exec overhead.  This may backfire if there
143# are too many files for the system buffer to handle, but if there are
144# that many files, chances are that the cvs repository is not set up
145# cleanly.
146
147print "opening rlog -h @files[1..$#files] |" if defined $opt_d;
148
149open( RLOG, "rlog -h @files[1..$#files] |") || die "Can't run rlog command" ;
150
151# Create the locks associative array.  The elements in the array are
152# of two types:
153#
154#  The name of the RCS file with a value of the total number of locks found
155#            for that file,
156# or
157#
158# The name of the rcs file concatenated with the version number of the lock.
159# The value of this element is the name of the locker.
160
161# The regular expressions used to split the rcs info may have to be changed.
162# The current ones work for rcs 5.6.
163
164$lock = 0;
165
166while (<RLOG>)
167{
168	chop;
169	next if /^$/; # ditch blank lines
170
171	if ( $_ =~ /^RCS file: (.*)$/ )
172	{
173	   $curfile = $1;
174	   next;
175	}
176
177	if ( $_ =~ /^locks: strict$/ )
178	{
179  	  $lock = 1 ;
180	  next;
181	}
182
183	if ( $lock )
184	{
185	  # access list: is the line immediately following the list of locks.
186	  if ( /^access list:/ )
187	  { # we are done getting lock info for this file.
188	    $lock = 0;
189	  }
190	  else
191	  { # We are accumulating lock info.
192
193	    # increment the lock count
194	    $locks{$curfile}++;
195	    # save the info on the version that is locked. $2 is the
196            # version number $1 is the name of the locker.
197	    $locks{"$curfile" . "$2"} = $1 
198				if /[ 	]*([a-zA-Z._]*): ([0-9.]*)$/;
199
200	    print "lock by $1 found on $curfile version $2" if defined $opt_d;
201
202	  }
203	}
204}
205
206# Lets go back to the starting directory and see if any locked files
207# are ones we are interested in.
208
209chdir $pwd;
210
211# fo all of the file names (remember $files[0] is the directory name
212foreach $i (@files[1..$#files])
213{
214  if ( defined $locks{$i . $ext} )
215  { # well the file has at least one lock outstanding
216
217     # find the base version number of our file
218     &parse_cvs_entry($i,*entry);
219
220     # is our version of this file locked?
221     if ( defined $locks{$i . $ext . $entry{"version"}} )
222     { # if so, it is by us?
223	if ( $login ne ($by = $locks{$i . $ext . $entry{"version"}}) )
224	{# crud somebody else has it locked.
225	   $outstanding_lock++ ;
226	   print "$by has file $i locked for version " , $entry{"version"};
227	}
228	else
229	{ # yeah I have it locked.
230	   print "You have a lock on file $i for version " , $entry{"version"}
231		if defined $opt_v;
232	}
233     }
234  }
235}
236
237exit $outstanding_lock;
238
239
240### End of main program
241
242sub parse_cvs_entry
243{ # a very simple minded hack at parsing an entries file.
244local ( $file, *entry ) = @_;
245local ( @pp );
246
247
248open(ENTRIES, "< CVS/Entries") || die "Can't open entries file";
249
250while (<ENTRIES>)
251 {
252  if ( $_  =~ /^\/$file\// )
253  {
254	@pp = split('/');
255
256	$entry{"name"} = $pp[1];
257	$entry{"version"} = $pp[2];
258	$entry{"dates"} = $pp[3];
259	$entry{"name"} = $pp[4];
260	$entry{"name"} = $pp[5];
261	$entry{"sticky"} = $pp[6];
262	return;
263  }
264 }
265}