contrib/cvs-1.12/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 #
  97 require '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`;
 119 chop $pwd;
 120
 121 print "Starting directory is $pwd" if defined $opt_d ;
 122
 123 #
 124 # cd to the repository directory and check on the files.
 125 #
 126 print "Checking directory ", $files[0] if defined $opt_v ;
 127
 128 if ( $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 }
 133 else
 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
 147 print "opening rlog -h @files[1..$#files] |" if defined $opt_d;
 148
 149 open( 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
 166 while (<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
 209 chdir $pwd;
 210
 211 # fo all of the file names (remember $files[0] is the directory name
 212 foreach $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
 237 exit $outstanding_lock;
 238
 239
 240 ### End of main program
 241
 242 sub parse_cvs_entry
 243 { # a very simple minded hack at parsing an entries file.
 244 local ( $file, *entry ) = @_;
 245 local ( @pp );
 246
 247
 248 open(ENTRIES, "< CVS/Entries") || die "Can't open entries file";
 249
 250 while (<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 }