bin/patsnap

   1 #!/usr/bin/perl
   2         eval "exec perl -S $0 $*"
   3                 if $running_under_some_shell;
   4
   5 # $Id: patsnap.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: patsnap.SH,v $
  16 # Revision 3.0.1.2  1994/01/24  14:33:08  ram
  17 # patch16: now prefix error messages with program's name
  18 # patch16: added ~/.dist_profile awareness
  19 #
  20 # Revision 3.0.1.1  1993/08/24  12:22:08  ram
  21 # patch3: created
  22 #
  23
  24 $version = '3.5';
  25 $patchlevel = '0';
  26
  27 $progname = &profile;           # Read ~/.dist_profile
  28 require 'getopts.pl';
  29 &usage unless $#ARGV >= 0;
  30 &usage unless &Getopts("aho:V");
  31
  32 $SNAPSHOT = 'SNAPSHOT';         # Default snapshot file name
  33
  34 if ($opt_V) {
  35         print STDERR "$progname $version PL$patchlevel\n";
  36         exit 0;
  37 } elsif ($opt_h) {
  38         &usage;
  39 }
  40
  41 &readpackage;
  42
  43 $RCSEXT = ',v' unless $RCSEXT;
  44 $TOPDIR = '';                   # We are at the top-level directory
  45 $SNAPSHOT = $opt_o if $opt_o;
  46
  47 if ($opt_a) {
  48         open(MANI,"MANIFEST.new") || die "$progname: can't read MANIFEST.new: $!\n";
  49         @ARGV = ();
  50         while (<MANI>) {
  51                 chop;
  52                 s|^\./||;
  53                 next if m|^patchlevel.h|;               # Special file
  54                 ($_) = split(' ');
  55                 next if -d;
  56                 push(@ARGV,$_);
  57         }
  58         close MANI;
  59 }
  60
  61 open(SNAPSHOT, ">$SNAPSHOT") || die "$progname: can't create $SNAPSHOT: $!\n";
  62
  63 foreach $file (@ARGV) {
  64         $files = &rcsargs($file);
  65         @files = split(' ',$files);
  66         $revs=0;
  67         $rlog = `rlog -r$baserev -r$revbranch $files 2>&1`;
  68         ($revs) = ($rlog =~ /selected revisions: (\d+)/);
  69         if (!$revs) {
  70                 print "$progname: $file has never been checked in--skipping\n";
  71                 next;
  72         }
  73         elsif ($revs == 1) {
  74                 print "$progname: last revision for $file is $baserev.\n";
  75                 print SNAPSHOT "$file\t$baserev\n";
  76         }
  77         else {
  78                 ($lastrev) = ($rlog =~ /revision $revbranch\.(\d+)/);
  79                 print "$progname: last revision for $file is $revbranch.$lastrev.\n";
  80                 print SNAPSHOT "$file\t$revbranch.$lastrev\n";
  81         }
  82 }
  83
  84 close SNAPSHOT;
  85
  86 sub usage {
  87         print STDERR <<EOM;
  88 Usage: $progname [-ahV] [-o snapshot] [filelist]
  89   -a : all the files in MANIFEST.new
  90   -h : print this message and exit
  91   -o : specify snapshot file output (default $SNAPSHOT)
  92   -V : print version number and exit
  93 EOM
  94         exit 1;
  95 }
  96
  97 sub readpackage {
  98         if (! -f '.package') {
  99                 if (
 100                         -f '../.package' ||
 101                         -f '../../.package' ||
 102                         -f '../../../.package' ||
 103                         -f '../../../../.package'
 104                 ) {
 105                         die "Run in top level directory only.\n";
 106                 } else {
 107                         die "No .package file!  Run packinit.\n";
 108                 }
 109         }
 110         open(PACKAGE,'.package');
 111         while (<PACKAGE>) {
 112                 next if /^:/;
 113                 next if /^#/;
 114                 if (($var,$val) = /^\s*(\w+)=(.*)/) {
 115                         $val = "\"$val\"" unless $val =~ /^['"]/;
 116                         eval "\$$var = $val;";
 117                 }
 118         }
 119         close PACKAGE;
 120 }
 121
 122 sub rcsargs {
 123         local($result) = '';
 124         local($_);
 125         while ($_ = shift(@_)) {
 126                 if ($_ =~ /^-/) {
 127                         $result .= $_ . ' ';
 128                 } elsif ($#_ >= 0 && do equiv($_,$_[0])) {
 129                         $result .= $_ . ' ' . $_[0] . ' ';
 130                         shift(@_);
 131                 } else {
 132                         $result .= $_ . ' ' . do other($_) . ' ';
 133                 }
 134         }
 135         $result;
 136 }
 137
 138 sub equiv {
 139         local($s1, $s2) = @_;
 140         $s1 =~ s|.*/||;
 141         $s2 =~ s|.*/||;
 142         if ($s1 eq $s2) {
 143                 0;
 144         } elsif ($s1 =~ s/$RCSEXT$// || $s2 =~ s/$RCSEXT$//) {
 145                 $s1 eq $s2;
 146         } else {
 147                 0;
 148         }
 149 }
 150
 151 sub other {
 152         local($s1) = @_;
 153         ($dir,$file) = ('./',$s1) unless local($dir,$file) = ($s1 =~ m|(.*/)(.*)|);
 154         $dir = $TOPDIR . $dir if -d $TOPDIR . "$dir/RCS";
 155         local($wasrcs) = ($file =~ s/$RCSEXT$//);
 156         if ($wasrcs) {
 157                 `mkdir $dir` unless -d $dir;
 158                 $dir =~ s|RCS/||;
 159         } else {
 160                 $dir .= 'RCS/';
 161                 `mkdir $dir` unless -d $dir;
 162                 $file .= $RCSEXT;
 163         }
 164         "$dir$file";
 165 }
 166
 167 sub rcscomment {
 168         local($file) = @_;
 169         local($comment) = '';
 170         open(FILE,$file);
 171         while (<FILE>) {
 172                 if (/^(.*)\$Log[:\$]/) {        # They know better than us (hopefully)
 173                         $comment = $1;
 174                         last;
 175                 }
 176         }
 177         close FILE;
 178         unless ($comment) {
 179                 if ($file =~ /\.SH$|[Mm]akefile/) {     # Makefile template
 180                         $comment = '# ';
 181                 } elsif ($file =~ /\.U$/) {                     # Metaconfig unit
 182                         $comment = '?RCS: ';
 183                 } elsif ($file =~ /\.man$/) {           # Manual page
 184                         $comment = "''' ";
 185                 } elsif ($file =~ /\.\d\w?$/) {         # Manual page
 186                         $comment = "''' ";
 187                 } elsif ($file =~ /\.[chyl]$/) {        # C source
 188                         $comment = " * ";
 189                 } elsif ($file =~ /\.e$/) {                     # Eiffel source
 190                         $comment = "-- ";
 191                 } elsif ($file =~ /\.pl$/) {            # Perl library
 192                         $comment = ";# ";
 193                 }
 194         }
 195         $comment;
 196 }
 197
 198 # Perform ~name expansion ala ksh...
 199 # (banish csh from your vocabulary ;-)
 200 sub tilda_expand {
 201         local($path) = @_;
 202         return $path unless $path =~ /^~/;
 203         $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;                    # ~name
 204         $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;   # ~
 205         $path;
 206 }
 207
 208 # Set up profile components into %Profile, add any profile-supplied options
 209 # into @ARGV and return the command invocation name.
 210 sub profile {
 211         local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
 212         local($me) = $0;                # Command name
 213         $me =~ s|.*/(.*)|$1|;   # Keep only base name
 214         return $me unless -s $profile;
 215         local(*PROFILE);                # Local file descriptor
 216         local($options) = '';   # Options we get back from profile
 217         unless (open(PROFILE, $profile)) {
 218                 warn "$me: cannot open $profile: $!\n";
 219                 return;
 220         }
 221         local($_);
 222         local($component);
 223         while (<PROFILE>) {
 224                 next if /^\s*#/;        # Skip comments
 225                 next unless /^$me/o;
 226                 if (s/^$me://o) {       # progname: options
 227                         chop;
 228                         $options .= $_; # Merge options if more than one line
 229                 }
 230                 elsif (s/^$me-([^:]+)://o) {    # progname-component: value
 231                         $component = $1;
 232                         chop;
 233                         s/^\s+//;               # Trim leading and trailing spaces
 234                         s/\s+$//;
 235                         $Profile{$component} = $_;
 236                 }
 237         }
 238         close PROFILE;
 239         return unless $options;
 240         require 'shellwords.pl';
 241         local(@opts);
 242         eval '@opts = &shellwords($options)';   # Protect against mismatched quotes
 243         unshift(@ARGV, @opts);
 244         return $me;                             # Return our invocation name
 245 }
 246