bin/patcol

   1 #!/usr/bin/perl
   2         eval "exec perl -S $0 $*"
   3                 if $running_under_some_shell;
   4
   5 # $Id: patcol.SH 1 2006-08-24 12:32:52Z rmanfredi $
   6 #
   7 #  Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
   8 #
   9 #  You may redistribute only under the terms of the Artistic Licence,
  10 #  as specified in the README file that comes with the distribution.
  11 #  You may reuse parts of this distribution only within the terms of
  12 #  that same Artistic Licence; a copy of which may be found at the root
  13 #  of the source tree for dist 4.0.
  14 #
  15 # $Log: patcol.SH,v $
  16 # Revision 3.0.1.3  1994/01/24  14:30:25  ram
  17 # patch16: now prefix error messages with program's name
  18 # patch16: added ~/.dist_profile awareness
  19 #
  20 # Revision 3.0.1.2  1993/08/24  12:16:30  ram
  21 # patch3: new -S option for snapshot check-outs
  22 #
  23 # Revision 3.0.1.1  1993/08/19  06:42:34  ram
  24 # patch1: leading config.sh searching was not aborting properly
  25 #
  26 # Revision 3.0  1993/08/18  12:10:42  ram
  27 # Baseline for dist 3.0 netwide release.
  28 #
  29
  30 $version = '3.5';
  31 $patchlevel = '0';
  32
  33 $progname = &profile;                   # Read ~/.dist_profile
  34 require 'getopts.pl';
  35 &usage unless $#ARGV >= 0;
  36 &usage unless &Getopts("acd:f:hnmsCRS:V");
  37
  38 if ($opt_V) {
  39         print STDERR "$progname $version PL$patchlevel\n";
  40         exit 0;
  41 } elsif ($opt_h) {
  42         &usage;
  43 }
  44
  45 $RCSEXT = ',v' unless $RCSEXT;
  46 $NEWMANI = 'MANIFEST.new' unless $NEWMANI = $opt_f;
  47
  48 chop($pwd = `pwd`) unless -f '.package';
  49 until (-f '.package') {
  50         die "$progname: no .package file!  Run packinit.\n" unless $pwd;
  51         chdir '..' || die "$progname: can't cd ..: $!";
  52         $pwd =~ s|(.*)/(.*)|$1|;
  53         $prefix = $2 . '/' . $prefix;
  54 }
  55 if ($prefix) {
  56         for (@ARGV) {
  57                 s/^/$prefix/ unless m|^[-/]|;
  58         }
  59 }
  60
  61 # We now are at the top level
  62
  63 &readpackage;
  64 undef $opt_C unless -f $copyright;
  65 &copyright'init($copyright) if $opt_C;
  66 &makedir($opt_d) if $opt_d;
  67
  68 undef $opt_c unless $opt_d;             # Disable -c if not -d
  69 undef $opt_R unless $opt_d;             # Disable -R if not -d
  70 push(@sw, '-q') if $opt_s;              # Let RCS work quietly
  71
  72 if ($opt_n) {
  73         &newer;                         # Look for files newer than patchlevel.h
  74 } elsif ($opt_a) {
  75         open(MANI, $NEWMANI) || die "No $NEWMANI found.\n";
  76         @ARGV = ();
  77         while (<MANI>) {
  78                 s|^\./||;
  79                 next if m|^patchlevel.h| && !$opt_d;    # This file is built by hand
  80                 chop;
  81                 ($_) = split(' ');
  82                 next if -d;
  83                 push(@ARGV,$_);
  84         }
  85         close MANI;
  86 } elsif ($opt_m) {
  87         open(MODS,"bugs/.mods$bnum") || die "$progname: no modification found.\n";
  88         @ARGV = ();
  89         while (<MODS>) {
  90                 next if m|^patchlevel.h$|;              # This file is built by hand
  91                 chop;
  92                 ($_) = split(' ');
  93                 next if -d;
  94                 push(@ARGV,$_);
  95         }
  96         close MODS;
  97 } elsif ($opt_S) {
  98         &readsnapshot($opt_S);
  99         foreach $file (sort keys %Snap) {
 100                 push(@ARGV, $file);
 101         }
 102 }
 103
 104 # Now loop over each file specified, doing a 'co -l'
 105 foreach $file (@ARGV) {
 106         if ($opt_c && -f $file) {
 107                 &copy_file($file, $opt_d);
 108                 next;
 109         }
 110         # Continue only if file does not exist or option -d was used.
 111         if (! -f $file || $opt_d) {
 112                 $files = &rcsargs($file);
 113                 @files = split(' ', $files);
 114                 if ($opt_S && ($rev = $Snap{$file}) ne '') {    # Use snapshot file
 115                         &col($rev);
 116                         next;
 117                 }
 118                 $rlog = `rlog -rlastpat- $files 2>&1`;
 119                 ($revs) = ($rlog =~ /selected revisions: (\d+)/);
 120                 if (!$revs) {
 121                         if ($opt_d) {
 122                                 &copy_file($file, $opt_d);
 123                         } else {
 124                                 print STDERR "$progname: $file has never been checked in\n";
 125                         }
 126                 } else {
 127                         # Look whether there is a branch
 128                         if ($revs == 1) {
 129                                 $rlog = `rlog -r$revbranch $files 2>&1`;
 130                                 ($revs) = ($rlog =~ /selected revisions: (\d+)/);
 131                                 $revs++;        # add the base revision (trunk)
 132                         }
 133                         if ($revs == 1) {
 134                                 &col($baserev);
 135                         } else {
 136                                 &col($revbranch);
 137                         }
 138                 }
 139
 140         }
 141 }
 142
 143 # Run co -l on @files, unlock file if it fails and retry.
 144 # If '-d' option was used, we check out in the specified
 145 # directory, after having made all the necessary directories
 146 # in the path name (which should be relative to the top).
 147 sub col {
 148         local($rev) = shift;    # Revision to be checked out.
 149         if (! $opt_d) {
 150                 if (system 'co',  "-l$rev", @sw, @files) {
 151                         print "$progname: unlocking and trying again...\n" unless $opt_s;
 152                         system 'rcs', '-u', @sw, @files;
 153                         system 'co', "-l$rev", @sw, @files unless $?;
 154                 }
 155         } else {
 156                 local($name) = $files[0];       # First element is file name
 157                 $_ = $name;
 158                 s|(.*)/.*|\1| && &makedir("$opt_d/$_");
 159                 if ($opt_C) {
 160                         &copyright'expand("co -p @sw -r$rev $files[1]", "$opt_d/$name");
 161                 } else {
 162                         system "co -p -r$rev @sw $files[1] > $opt_d/$name";
 163                 }
 164                 system 'perl', '-pi', '-e', 's|Lock[e]r:.*\$|\$|;', "$opt_d/$name"
 165                         if $opt_R;
 166                 # If RCS file has x bits set, add them on new file
 167                 -x $files[1] && chmod(0755, "$opt_d/$name");
 168         }
 169 }
 170
 171 # Copy file into directory, eventually performing copyright expansion...
 172 sub copy_file {
 173         local($file, $dir) = @_;
 174         local($base) = $file =~ m|^(.*)/.*|;
 175         &makedir("$dir/$base");
 176         if ($opt_C) {
 177                 &copyright'expand("cat $file", "$dir/$file");
 178         } else {
 179                 system 'cp', "$file", "$dir/$file";
 180         }
 181         system 'perl', '-pi', '-e', 's|Lock[e]r:.*\$|\$|;', "$dir/$file" if $opt_R;
 182         -x $file && chmod(0755, "$dir/$file");
 183         print "$progname: $file has been copied\n" unless $opt_s;
 184 }
 185
 186 sub usage {
 187         print STDERR <<EOM;
 188 Usage: $progname [-achnmsCRV] [-d directory] [-f mani] [-S snap] [filelist]
 189   -a : all the files in MANIFEST.new (see also -f)
 190   -c : copy files if checked-out copy exists (only when -d)
 191   -d : check out (or copy) in the specified directory
 192   -f : use supplied file instead of MANIFEST.new
 193   -h : print this message and exit
 194   -n : all the files newer than patchlevel.h
 195   -m : all the modified files (which have been patciled)
 196   -s : silent mode
 197   -C : perform copyright expansion on checked out (or copied) file
 198   -R : strip out RCS \$Locker marker from checked-out file (only when -d)
 199   -S : use snapshot file to determine file list and RCS revisions
 200   -V : print version number and exit
 201 EOM
 202         exit 1;
 203 }
 204
 205 sub newer {
 206         open(FIND, "find . -type f -newer patchlevel.h -print | sort |") ||
 207         die "Can't run find.\n";
 208         open(NEWER,">.newer") || die "Can't create .newer.\n";
 209         open(MANI,"MANIFEST.new");
 210         while (<MANI>) {
 211                 ($name,$foo) = split;
 212                 $mani{$name} = 1;
 213         }
 214         close MANI;
 215         while (<FIND>) {
 216         s|^\./||;
 217         chop;
 218         next if m|^MANIFEST|;
 219         next if m|^PACKLIST$|;
 220         if (!$mani{$_}) {
 221                 next if m|^MANIFEST.new$|;
 222                 next if m|^Changes$|;
 223                 next if m|^Wanted$|;
 224                 next if m|^.package$|;
 225                 next if m|^bugs|;
 226                 next if m|^users$|;
 227                 next if m|^UU/|;
 228                 next if m|^RCS/|;
 229                 next if m|/RCS/|;
 230                 next if m|^config.sh$|;
 231                 next if m|/config.sh$|;
 232                 next if m|^make.out$|;
 233                 next if m|/make.out$|;
 234                 next if m|^all$|;
 235                 next if m|/all$|;
 236                 next if m|^core$|;
 237                 next if m|/core$|;
 238                 next if m|^toto|;
 239                 next if m|/toto|;
 240                 next if m|^\.|;
 241                 next if m|/\.|;
 242                 next if m|\.o$|;
 243                 next if m|\.old$|;
 244                 next if m|\.orig$|;
 245                 next if m|~$|;
 246                 next if $mani{$_ . ".SH"};
 247                 next if m|(.*)\.c$| && $mani{$1 . ".y"};
 248                 next if m|(.*)\.c$| && $mani{$1 . ".l"};
 249                 next if (-x $_ && !m|^Configure$|);
 250         }
 251         print NEWER $_,"\n";
 252         }
 253         close FIND;
 254         close NEWER;
 255         print "Please remove unwanted files...\n";
 256         sleep(2);
 257         system '${EDITOR-vi} .newer';
 258         die "Aborted.\n" unless -s '.newer' > 1;
 259         @ARGV = split(' ',`cat .newer`);
 260 }
 261
 262 sub readpackage {
 263         if (! -f '.package') {
 264                 if (
 265                         -f '../.package' ||
 266                         -f '../../.package' ||
 267                         -f '../../../.package' ||
 268                         -f '../../../../.package'
 269                 ) {
 270                         die "Run in top level directory only.\n";
 271                 } else {
 272                         die "No .package file!  Run packinit.\n";
 273                 }
 274         }
 275         open(PACKAGE,'.package');
 276         while (<PACKAGE>) {
 277                 next if /^:/;
 278                 next if /^#/;
 279                 if (($var,$val) = /^\s*(\w+)=(.*)/) {
 280                         $val = "\"$val\"" unless $val =~ /^['"]/;
 281                         eval "\$$var = $val;";
 282                 }
 283         }
 284         close PACKAGE;
 285 }
 286
 287 sub rcsargs {
 288         local($result) = '';
 289         local($_);
 290         while ($_ = shift(@_)) {
 291                 if ($_ =~ /^-/) {
 292                         $result .= $_ . ' ';
 293                 } elsif ($#_ >= 0 && do equiv($_,$_[0])) {
 294                         $result .= $_ . ' ' . $_[0] . ' ';
 295                         shift(@_);
 296                 } else {
 297                         $result .= $_ . ' ' . do other($_) . ' ';
 298                 }
 299         }
 300         $result;
 301 }
 302
 303 sub equiv {
 304         local($s1, $s2) = @_;
 305         $s1 =~ s|.*/||;
 306         $s2 =~ s|.*/||;
 307         if ($s1 eq $s2) {
 308                 0;
 309         } elsif ($s1 =~ s/$RCSEXT$// || $s2 =~ s/$RCSEXT$//) {
 310                 $s1 eq $s2;
 311         } else {
 312                 0;
 313         }
 314 }
 315
 316 sub other {
 317         local($s1) = @_;
 318         ($dir,$file) = ('./',$s1) unless local($dir,$file) = ($s1 =~ m|(.*/)(.*)|);
 319         $dir = $TOPDIR . $dir if -d $TOPDIR . "$dir/RCS";
 320         local($wasrcs) = ($file =~ s/$RCSEXT$//);
 321         if ($wasrcs) {
 322                 `mkdir $dir` unless -d $dir;
 323                 $dir =~ s|RCS/||;
 324         } else {
 325                 $dir .= 'RCS/';
 326                 `mkdir $dir` unless -d $dir;
 327                 $file .= $RCSEXT;
 328         }
 329         "$dir$file";
 330 }
 331
 332 package copyright;
 333
 334 # Read in copyright file
 335 sub init {
 336         local($file) = @_;              # Copyright file
 337         undef @copyright;
 338         open(COPYRIGHT, $file) || die "Can't open $file: $!\n";
 339         chop(@copyright = <COPYRIGHT>);
 340         close COPYRIGHT;
 341 }
 342
 343 # Reset the automaton for a new file.
 344 sub reset {
 345         $copyright_seen = @copyright ? 0 : 1;
 346         $marker_seen = 0;
 347 }
 348
 349 # Filter file, line by line, and expand the copyright string. The @COPYRIGHT@
 350 # symbol may be preceded by some random comment. A leader can be defined and
 351 # will be pre-pended to all the input lines.
 352 sub filter {
 353         local($line, $leader) = @_;             # Leader is optional
 354         return $leader . $line if $copyright_seen || $marker_seen;
 355         $marker_seen = 1 if $line =~ /\$Log[:\$]/;
 356         $copyright_seen = 1 if $line =~ /\@COPYRIGHT\@/;
 357         return $leader . $line unless $copyright_seen;
 358         local($comment, $trailer) = $line =~ /^(.*)\@COPYRIGHT\@\s*(.*)/;
 359         $comment = $leader . $comment;
 360         $comment . join("\n$comment", @copyright) . "\n";
 361 }
 362
 363 # Filter output of $cmd redirected into $file by expanding copyright, if any.
 364 sub expand {
 365         local($cmd, $file) = @_;
 366         if (@copyright) {
 367                 open(CMD,"$cmd|") || die "Can't start '$cmd': $!\n";
 368                 open(OUT, ">$file") || die "Can't create $file: $!\n";
 369                 &reset;
 370                 local($_);
 371                 while (<CMD>) {
 372                         print OUT &filter($_);
 373                 }
 374                 close OUT;
 375                 close CMD;
 376         } else {
 377                 system "$cmd > $file";
 378                 die "Command '$cmd' failed!" if $?;
 379         }
 380 }
 381
 382 package main;
 383
 384 # Make directories for files
 385 # E.g, for /usr/lib/perl/foo, it will check for all the
 386 # directories /usr, /usr/lib, /usr/lib/perl and make
 387 # them if they do not exist.
 388 sub makedir {
 389     local($_) = shift;
 390     local($dir) = $_;
 391     if (!-d && $_ ne '') {
 392         # Make dirname first
 393         do makedir($_) if s|(.*)/.*|\1|;
 394                 mkdir($dir, 0700) if ! -d $dir;
 395     }
 396 }
 397
 398 # Read snapshot file and build %Snap, indexed by file name -> RCS revision
 399 sub readsnapshot {
 400         local($snap) = @_;
 401         open(SNAP, $snap) || warn "Can't open $snap: $!\n";
 402         local($_);
 403         local($file, $rev);
 404         while (<SNAP>) {
 405                 next if /^#/;
 406                 ($file, $rev) = split;
 407                 $Snap{$file} = "$rev";
 408         }
 409         close SNAP;
 410 }
 411
 412 # Perform ~name expansion ala ksh...
 413 # (banish csh from your vocabulary ;-)
 414 sub tilda_expand {
 415         local($path) = @_;
 416         return $path unless $path =~ /^~/;
 417         $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;                    # ~name
 418         $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;   # ~
 419         $path;
 420 }
 421
 422 # Set up profile components into %Profile, add any profile-supplied options
 423 # into @ARGV and return the command invocation name.
 424 sub profile {
 425         local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
 426         local($me) = $0;                # Command name
 427         $me =~ s|.*/(.*)|$1|;   # Keep only base name
 428         return $me unless -s $profile;
 429         local(*PROFILE);                # Local file descriptor
 430         local($options) = '';   # Options we get back from profile
 431         unless (open(PROFILE, $profile)) {
 432                 warn "$me: cannot open $profile: $!\n";
 433                 return;
 434         }
 435         local($_);
 436         local($component);
 437         while (<PROFILE>) {
 438                 next if /^\s*#/;        # Skip comments
 439                 next unless /^$me/o;
 440                 if (s/^$me://o) {       # progname: options
 441                         chop;
 442                         $options .= $_; # Merge options if more than one line
 443                 }
 444                 elsif (s/^$me-([^:]+)://o) {    # progname-component: value
 445                         $component = $1;
 446                         chop;
 447                         s/^\s+//;               # Trim leading and trailing spaces
 448                         s/\s+$//;
 449                         $Profile{$component} = $_;
 450                 }
 451         }
 452         close PROFILE;
 453         return unless $options;
 454         require 'shellwords.pl';
 455         local(@opts);
 456         eval '@opts = &shellwords($options)';   # Protect against mismatched quotes
 457         unshift(@ARGV, @opts);
 458         return $me;                             # Return our invocation name
 459 }
 460