bin/patlog

   1 #!/usr/bin/perl
   2         eval "exec perl -S $0 $*"
   3                 if $running_under_some_shell;
   4
   5 # $Id: patlog.SH 20 2008-01-04 23:14:00Z 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: patlog.SH,v $
  16 # Revision 3.0.1.2  1997/02/28  16:33:03  ram
  17 # patch61: typo fix
  18 #
  19 # Revision 3.0.1.1  1994/10/29  16:42:26  ram
  20 # patch36: created
  21 #
  22
  23 $defeditor='/usr/bin/vi';
  24 $version = '3.5';
  25 $patchlevel = '0';
  26
  27 $progname = &profile;   # Read ~/.dist_profile
  28 require 'getopts.pl';
  29 &usage unless &Getopts("hnruV");
  30
  31 if ($opt_V) {
  32         print STDERR "$progname $version PL$patchlevel\n";
  33         exit 0;
  34 } elsif ($opt_h) {
  35         &usage;
  36 }
  37
  38 &readpackage;
  39
  40 if (-f 'patchlevel.h') {
  41         open(PL,"patchlevel.h") || die "$progname: can't open patchlevel.h: $!\n";
  42         while (<PL>) {
  43                 if (/^#define\s+PATCHLEVEL\s+(\d+)/) {
  44                         $last = $1;
  45                         $patchline = $.;        # Record PATCHLEVEL line
  46                 }
  47         }
  48         die "$progname: malformed patchlevel.h file.\n" if $last eq '';
  49         $bnum = $last + 1;
  50 }
  51 else {
  52         $patchline = 1;
  53         $bnum = 1;
  54         $last = '';
  55 }
  56
  57 chdir 'bugs' if -d 'bugs';
  58
  59 die "$progname: patch #$bnum already exists.\n" if -f "patch$bnum";
  60
  61 @patlist=<*.$bnum>;
  62 die "$progname: no diff files for patch #$bnum.\n" if
  63         $patlist[0] =~ /^\*/ || $patlist[0] eq '';
  64
  65 # Set up a proper editor, for later perusal
  66 $editor = $ENV{'VISUAL'};
  67 $editor = $ENV{'EDITOR'} unless $editor;
  68 $editor = $defeditor unless $editor;
  69 $editor = 'vi' unless $editor;
  70
  71 # The following used to be done in patmake. Only we do not really need to
  72 # compute the subject lines for the generated patch here, we do it nonetheless
  73 # to avoid code duplication in patmake.
  74
  75 if (-s ".logs$bnum") {
  76         $logs = '';
  77         open(LOGS,".logs$bnum");
  78         while (<LOGS>) {
  79                 unless ($logseen{$_}) {
  80                         $logs .= $_;
  81                         $logseen{$_}++;
  82                         $logsnum++;                     # One more log
  83                 }
  84         }
  85         close LOGS;
  86         $subj = $logs;
  87         $logs =~ s/^patch\d+:\s*/\t/gm;
  88         $logs =~ s/\n/\n\n/gm;
  89         $subj =~ s/^patch\d+:\s*/Subject: /gm;
  90 } else {
  91         $subj = "Subject: \n";
  92 }
  93
  94 # Try to guess the priority of the patch
  95 if (-s ".mods$bnum") {
  96         open(MODS, ".mods$bnum");
  97         while (<MODS>) {
  98                 chop;
  99                 unless ($fileseen{$_}) {
 100                         $fileseen{$_}++;
 101                         $modsnum++;                     # One more modified file
 102                 }
 103         }
 104         close MODS;
 105 }
 106 $modsnum++ unless $modsnum;             # Avoid divisions by zero
 107 $mean = $logsnum / $modsnum;
 108 if ($mean > 0.7 && $mean < 1.3) {
 109         $priority = "MEDIUM";
 110 } elsif ($mean <= 0.7) {
 111         $priority = "HIGH";             # Small changes
 112 } else {
 113         $priority = "LOW";              # Big changes
 114 }
 115
 116 # Save priority for patmake
 117 open(PRIORITY, ">.pri$bnum") || die "$progname: can't create .pri$bnum: $!\n";
 118 print PRIORITY $priority, "\n";
 119 close PRIORITY;
 120
 121 # Save subject lines for patmake
 122 open(SUBJECTS, ">.subj$bnum") || die "$progname: can't create .subj$bnum: $!\n";
 123 print SUBJECTS $subj;
 124 close SUBJECTS;
 125
 126 #
 127 # Generate description file, then edit it so that the user may fixup things.
 128 #
 129
 130 unless (($opt_r && -f ".clog$bnum") || ($opt_u && &uptodate(".clog$bnum"))) {
 131         open(CHANGES, ">.clog$bnum") ||
 132                 die "$progname: can't create .clog$bnum: $!\n";
 133         print CHANGES <<EOM;
 134 Edition of the Description section for patch #$bnum.
 135 Please leave those three lines here, they will be removed automatically.
 136 ------------------------------------------------------------------------
 137 EOM
 138         print CHANGES $logs;
 139         close CHANGES;
 140 }
 141
 142 # If they don't want to maintain a ChangeLog file, that's it. They'll get
 143 # the old behaviour where the description is edited directly from within
 144 # the generated patch.
 145
 146 exit(0) if $changelog =~ /^\s*$/;
 147
 148 system $editor, ".clog$bnum";
 149
 150 #
 151 # Generate RCS log file.
 152 #
 153
 154 if ($changercs) {
 155         unless (
 156                 ($opt_r && -f ".rlog$bnum") || ($opt_u && &uptodate(".rlog$bnum"))
 157         ) {
 158                 &buildlogs;
 159                 open(RCS, ">.rlog$bnum") ||
 160                         die "$progname: can't create .rlog$bnum: $!\n";
 161                 print RCS <<EOM;
 162 Edition of the RCS log section for $changelog (patch #$bnum).
 163 Please leave those three lines here, they will be removed automatically.
 164 ------------------------------------------------------------------------
 165 EOM
 166                 foreach $key (sort keys %rcslog) {
 167                         print RCS &format('* ' . $rcslog{$key}), "\n";
 168                 }
 169                 close RCS;
 170         }
 171         system $editor, ".rlog$bnum";
 172 }
 173
 174 #
 175 # Final logfile entry generation
 176 #
 177
 178 chop($date=`date`);
 179
 180 unless (
 181         ($opt_r && -f ".xlog$bnum") ||
 182         ($opt_u && &uptodate(".xlog$bnum") && !&newertmp)
 183 ) {
 184         open(LOG, ">.xlog$bnum") || die "$progname: can't create .xlog$bnum: $!\n";
 185         print LOG <<EOM;
 186 Edition of the $changelog entry for patch #$bnum.
 187 Please leave those three lines here, they will be removed automatically.
 188 ------------------------------------------------------------------------
 189 EOM
 190         print LOG "$date   $maintname <$maintloc>\n\n";
 191         print LOG ". Description:\n\n";
 192         &addlog(".clog$bnum");
 193         if ($changercs) {
 194                 print LOG ". Files changed:\n\n";
 195                 &addlog(".rlog$bnum");
 196         }
 197         close LOG;
 198 }
 199 system $editor, ".xlog$bnum";
 200 exit(0) if $opt_n;
 201
 202 #
 203 # Changelog file update, checking in and diff computation.
 204 #
 205
 206 print "$progname: updating $changelog...\n";
 207
 208 chdir('..') || die "$progname: can't go back to ..: $!\n";
 209 if (-f $changelog) {
 210         rename($changelog, "$changelog.bak") ||
 211                 die "$progname: can't rename $changelog into $changelog.bak: $!\n";
 212 }
 213
 214 open(LOG, ">$changelog") || die "$progname: can't create $changelog: $!\n";
 215 &addlog("bugs/.xlog$bnum");
 216 if (-f "$changelog.bak") {
 217         open(OLOG, "$changelog.bak") ||
 218                 die "$progname: can't open $changelog.bak: $!\n";
 219         print LOG while <OLOG>;
 220         close OLOG;
 221 }
 222 close LOG;
 223
 224 print "$progname: checking in $changelog and computing diff...\n";
 225
 226 # It is safe to run a patcil and a patdiff now, since the Changelog file has
 227 # been updated anyway: any log done while checking that file in will not
 228 # appear in the patch log nor the Changelog.
 229
 230 system 'perl', '-S', 'patcil', '-p', $changelog;
 231 system 'perl', '-S', 'patdiff', $changelog;
 232
 233 exit 0;         # All done.
 234
 235 # Returns true if .clog and .rlog (it it exists) are newer than .xlog.
 236 sub newertmp {
 237         return 1 unless -f ".xlog$bnum";        # To force regeneration
 238         return 1 if &newer(".clog$bnum", ".xlog$bnum") ||
 239                 (!$changercs || &newer(".rlog$bnum", ".xlog$bnum"));
 240         0;
 241 }
 242
 243 # Returns true if $file is newer than the reference file $ref.
 244 sub newer {
 245         local($file, $ref) = @_;
 246         (stat($file))[9] >= (stat($ref))[9];
 247 }
 248
 249 # Retursn true if $file is up-to-date with respect to .logs and .mods.
 250 sub uptodate {
 251         local($file) = @_;
 252         return 0 unless -f $file;       # Cannot be up-to-date if missing
 253         &newer($file, ".logs$bnum") && &newer($file, ".mods$bnum");
 254 }
 255
 256 # Add file to the LOG descriptor, skipping the first three lines of that file.
 257 sub addlog {
 258         local($file) = @_;
 259         open(FILE, $file) || die "$progname: can't reopen $file: $!\n";
 260         $_ = <FILE>; $_ = <FILE>; $_ = <FILE>;
 261         print LOG while <FILE>;
 262         close FILE;
 263 }
 264
 265 # Build RCS logs, for each file listed in the %fileseen array, into %rcslog.
 266 # Common RCS log messages are grouped under the same entry.
 267 sub buildlogs {
 268         local($log);
 269         local(@files);
 270         local($first);
 271         local(%invertedlog);
 272         foreach $file (keys %fileseen) {
 273                 $log = &rcslog($file);
 274                 next if $log eq '';
 275                 $invertedlog{$log} .= "$file ";
 276         }
 277         foreach $log (keys %invertedlog) {
 278                 @files = split(' ', $invertedlog{$log});
 279                 $first = (sort @files)[0];
 280                 $rcslog{$first} = join(', ', @files) . ': ' . $log;
 281         }
 282 }
 283
 284 # Grab log for a given file by parsing its $Log section. Only comments
 285 # relevant to the patch are kept. This relies on the presence of the patchxx:
 286 # leading string in front of each comment.
 287 # If not sufficient (because people don't use patchxx prefixes), then we'll
 288 # need a more sophisticated algorithm parsing revisions lines to see where we
 289 # left of at the last patch.
 290 sub rcslog {
 291         local($file) = @_;
 292         open(FILE, "../$file") || warn "$me: can't open $file: $!\n";
 293         local($_);
 294         local($comment, $len);
 295         local($pcomment) = "patch$bnum:";
 296         local($plen) = length($pcomment);
 297         local($c);
 298         local($lastnl) = 1;
 299         local($kept);                   # Relevant part of the RCS comment which is kept
 300         file: while (<FILE>) {
 301                 if (/^(.*)\$Log[:\$]/) {
 302                         $comment = $1;
 303                         $comment =~ s/\s+$//;   # Newer RCS chop spaces on emtpy lines
 304                         $len = length($comment);
 305                         while (<FILE>) {
 306                                 $c = substr($_, 0, $len);
 307                                 last file unless $c eq $comment;
 308                                 $_ = substr($_, $len, 9_999);
 309                                 if ($lastnl) {
 310                                         last file unless /^\s*Revision\s+\d/;
 311                                         $lastnl = 0;
 312                                 } elsif (/^\s*$/) {
 313                                         $lastnl = 1;
 314                                 } else {
 315                                         s/^\s*//;       # Older RCS will have space here
 316                                         $c = substr($_, 0, $plen);
 317                                         last file unless $c eq $pcomment;
 318                                         # Comment for that patch is kept after space cleanup
 319                                         $_ = substr($_, $plen, 9_999);
 320                                         s/^\s*//;
 321                                         s/\s*$//;
 322                                         $_ .= '.' unless /\.$/;
 323                                         s/^(.)/\U$1/;   # Ensure upper-cased to start sentence
 324                                         s/^/  / if $kept;
 325                                         $kept .= $_;    # Will be reformatted later on
 326                                 }
 327                         }
 328                 }
 329         }
 330         close FILE;
 331         $kept;
 332 }
 333
 334 # Format line to fit in 80 columns (70 + 8 for the added leading tabs).
 335 # Rudimentary parsing to break lines after a , or a space.
 336 sub format {
 337         local($_) = @_;
 338         local($tmp);
 339         local($msg);
 340         while (length($_) > 70) {
 341                 $tmp = substr($_, 0, 70);
 342                 $tmp =~ s/^(.*)([,\s]).*/$1/;
 343                 $msg .= "\t$tmp" . ($2 eq ',' ? ',' : '') . "\n";
 344                 $_ = substr($_, length($tmp), 9_999);
 345                 $_ =~ s/^\s+//;
 346         }
 347         $msg .= "\t$_\n";
 348         $msg;
 349 }
 350
 351 sub usage {
 352         print STDERR <<EOM;
 353 Usage: $progname [-hnruV]
 354   -h : print this message and exit.
 355   -n : not-really mode: force re-edit, but stop after updating.
 356   -r : reuse existing change file candidate entries (supersedes -u).
 357   -u : update mode, recreate files only when out of date.
 358   -V : print version number and exit.
 359 EOM
 360         exit 1;
 361 }
 362
 363 sub readpackage {
 364         if (! -f '.package') {
 365                 if (
 366                         -f '../.package' ||
 367                         -f '../../.package' ||
 368                         -f '../../../.package' ||
 369                         -f '../../../../.package'
 370                 ) {
 371                         die "Run in top level directory only.\n";
 372                 } else {
 373                         die "No .package file!  Run packinit.\n";
 374                 }
 375         }
 376         open(PACKAGE,'.package');
 377         while (<PACKAGE>) {
 378                 next if /^:/;
 379                 next if /^#/;
 380                 if (($var,$val) = /^\s*(\w+)=(.*)/) {
 381                         $val = "\"$val\"" unless $val =~ /^['"]/;
 382                         eval "\$$var = $val;";
 383                 }
 384         }
 385         close PACKAGE;
 386 }
 387
 388 # Perform ~name expansion ala ksh...
 389 # (banish csh from your vocabulary ;-)
 390 sub tilda_expand {
 391         local($path) = @_;
 392         return $path unless $path =~ /^~/;
 393         $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;                    # ~name
 394         $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;   # ~
 395         $path;
 396 }
 397
 398 # Set up profile components into %Profile, add any profile-supplied options
 399 # into @ARGV and return the command invocation name.
 400 sub profile {
 401         local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
 402         local($me) = $0;                # Command name
 403         $me =~ s|.*/(.*)|$1|;   # Keep only base name
 404         return $me unless -s $profile;
 405         local(*PROFILE);                # Local file descriptor
 406         local($options) = '';   # Options we get back from profile
 407         unless (open(PROFILE, $profile)) {
 408                 warn "$me: cannot open $profile: $!\n";
 409                 return;
 410         }
 411         local($_);
 412         local($component);
 413         while (<PROFILE>) {
 414                 next if /^\s*#/;        # Skip comments
 415                 next unless /^$me/o;
 416                 if (s/^$me://o) {       # progname: options
 417                         chop;
 418                         $options .= $_; # Merge options if more than one line
 419                 }
 420                 elsif (s/^$me-([^:]+)://o) {    # progname-component: value
 421                         $component = $1;
 422                         chop;
 423                         s/^\s+//;               # Trim leading and trailing spaces
 424                         s/\s+$//;
 425                         $Profile{$component} = $_;
 426                 }
 427         }
 428         close PROFILE;
 429         return unless $options;
 430         require 'shellwords.pl';
 431         local(@opts);
 432         eval '@opts = &shellwords($options)';   # Protect against mismatched quotes
 433         unshift(@ARGV, @opts);
 434         return $me;                             # Return our invocation name
 435 }
 436