contrib/cvs-1.12.12/contrib/rcslock.in

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