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} 266