Porting/patchls

   1 #!/bin/perl -w
   2 #
   3 #       patchls - patch listing utility
   4 #
   5 # Input is one or more patchfiles, output is a list of files to be patched.
   6 #
   7 # Copyright (c) 1997 Tim Bunce. All rights reserved.
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the same terms as Perl itself.
  10 #
  11 # With thanks to Tom Horsley for the seed code.
  12 #
  13 # $Id: patchls,v 1.3 1997/06/10 21:38:45 timbo Exp $
  14
  15 use Getopt::Std;
  16 use Text::Wrap qw(wrap $columns);
  17 use Text::Tabs qw(expand unexpand);
  18 use strict;
  19
  20 sub usage {
  21 die qq{
  22
  23   patchls [options] patchfile [ ... ]
  24
  25     -i     Invert: for each patched file list which patch files patch it
  26     -h     no filename headers (like grep), only the listing
  27     -l     no listing (like grep), only the filename headers
  28     -c     Categorise the patch and sort by category (perl specific)
  29     -m     print formatted Meta-information (Subject,From,Msg-ID etc)
  30     -p N   strip N levels of directory Prefix (like patch), else automatic
  31     -v     more verbose (-d for noisy debugging)
  32
  33 }
  34 }
  35
  36 $columns = 70;
  37
  38 $::opt_p = undef;       # undef != 0
  39 $::opt_d = 0;
  40 $::opt_v = 0;
  41 $::opt_m = 0;
  42 $::opt_i = 0;
  43 $::opt_h = 0;
  44 $::opt_l = 0;
  45 $::opt_c = 0;
  46
  47 usage unless @ARGV;
  48
  49 getopts("mihlvcp:") or usage;
  50
  51 my %cat_title = (
  52     'TEST'      => 'TESTS',
  53     'DOC'       => 'DOCUMENTATION',
  54     'UTIL'      => 'UTILITIES',
  55     'PORT'      => 'PORTABILITY',
  56     'LIB'       => 'LIBRARY AND EXTENSIONS',
  57     'CORE'      => 'CORE LANGUAGE',
  58     'BUILD'     => 'BUILD PROCESS',
  59     'OTHER'     => 'OTHER',
  60 );
  61
  62 my %ls;
  63
  64 # Style 1:
  65 #       *** perl-5.004/embed.h  Sat May 10 03:39:32 1997
  66 #       --- perl-5.004.fixed/embed.h    Thu May 29 19:48:46 1997
  67 #       ***************
  68 #       *** 308,313 ****
  69 #       --- 308,314 ----
  70 #
  71 # Style 2:
  72 #       --- perl5.004001/mg.c   Sun Jun 08 12:26:24 1997
  73 #       +++ perl5.004-bc/mg.c   Sun Jun 08 11:56:08 1997
  74 #       @@ -656,9 +656,27 @@
  75 # or (rcs, note the different date format)
  76 #       --- 1.18        1997/05/23 19:22:04
  77 #       +++ ./pod/perlembed.pod 1997/06/03 21:41:38
  78 #
  79 # Variation:
  80 #       Index: embed.h
  81
  82 my($in, $prevline, $prevtype, $ls);
  83
  84 foreach my $argv (@ARGV) {
  85     $in = $argv;
  86     unless (open F, "<$in") {
  87         warn "Unable to open $in: $!\n";
  88         next;
  89     }
  90     print "Reading $in...\n" if $::opt_v and @ARGV > 1;
  91     $ls = $ls{$in} ||= { is_in => 1, in => $in };
  92     my $type;
  93     while (<F>) {
  94         unless (/^([-+*]{3}) / || /^(Index):/) {
  95             # not an interesting patch line but possibly meta-information
  96             next unless $::opt_m;
  97             $ls->{From}{$1}=1       if /^From: (.*\S)/i;
  98             $ls->{Title}{$1}=1      if /^Subject: (?:Re: )?(.*\S)/i;
  99             $ls->{'Msg-ID'}{$1}=1   if /^Message-Id: (.*\S)/i;
 100             $ls->{Date}{$1}=1       if /^Date: (.*\S)/i;
 101             next;
 102         }
 103         $type = $1;
 104         next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
 105
 106         print "Last: $prevline","This: ${_}Got:  $1\n\n" if $::opt_d;
 107
 108         # Some patches have Index lines but not diff headers
 109         # Patch copes with this, so must we. It's also handy for
 110         # documenting manual changes by simply adding Index: lines
 111         # to the file which describes the problem bing fixed.
 112         add_file($ls, $1), next if /^Index:\s+(.*)/;
 113
 114         if (    ($type eq '---' and $prevtype eq '***') # Style 1
 115             or  ($type eq '+++' and $prevtype eq '---') # Style 2
 116         ) {
 117             if (/^[-+*]{3} (\S+)\s+.*\d\d:\d\d:\d\d/) { # double check
 118                 add_file($ls, $1);
 119             }
 120             else {
 121                 warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
 122             }
 123         }
 124     }
 125     continue {
 126         $prevline = $_;
 127         $prevtype = $type;
 128         $type = '';
 129     }
 130     # if we don't have a title for -m then use the file name
 131     $ls->{Title}{$in}=1 if $::opt_m
 132         and !$ls->{Title} and $ls->{out};
 133
 134     $ls->{category} = $::opt_c
 135         ? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
 136 }
 137 print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
 138
 139
 140 my @ls  = sort {
 141     $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
 142 } values %ls;
 143
 144 unless ($::opt_c and $::opt_m) {
 145     foreach $ls (@ls) {
 146         next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
 147         list_files_by_patch($ls);
 148     }
 149 }
 150 else {
 151     my $c = '';
 152     foreach $ls (@ls) {
 153         next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
 154         print "\n  $cat_title{$ls->{category}}\n" if $ls->{category} ne $c;
 155         $c = $ls->{category};
 156         unless ($::opt_i) {
 157             list_files_by_patch($ls);
 158         }
 159         else {
 160             my $out = $ls->{in};
 161             print "\n$out patched by:\n";
 162             # find all the patches which patch $out and list them
 163             my @p = grep { $_->{out}->{$out} } values %ls;
 164             foreach $ls (@p) {
 165                 list_files_by_patch($ls, '');
 166             }
 167         }
 168     }
 169     print "\n";
 170 }
 171
 172 exit 0;
 173
 174
 175 # ---
 176
 177
 178 sub add_file {
 179     my $ls = shift;
 180     my $out = trim_name(shift);
 181
 182     $ls->{out}->{$out} = 1;
 183
 184     # do the -i inverse as well, even if we're not doing -i
 185     my $i = $ls{$out} ||= {
 186         is_out   => 1,
 187         in       => $out,
 188         category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
 189     };
 190     $i->{out}->{$in} = 1;
 191 }
 192
 193
 194 sub trim_name {         # reduce/tidy file paths from diff lines
 195     my $name = shift;
 196     $name = "$name ($in)" if $name eq "/dev/null";
 197     if (defined $::opt_p) {
 198         # strip on -p levels of directory prefix
 199         my $dc = $::opt_p;
 200         $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
 201     }
 202     else {      # try to strip off leading path to perl directory
 203         # if absolute path, strip down to any *perl* directory first
 204         $name =~ s:^/.*?perl.*?/::i;
 205         $name =~ s:.*perl[-_]?5\.[-_a-z0-9.]+/::i;
 206         $name =~ s:^\./::;
 207     }
 208     return $name;
 209 }
 210
 211
 212 sub list_files_by_patch {
 213     my($ls, $name) = @_;
 214     $name = $ls->{in} unless defined $name;
 215     my @meta;
 216     if ($::opt_m) {
 217         foreach(qw(Title From Msg-ID)) {
 218             next unless $ls->{$_};
 219             my @list = sort keys %{$ls->{$_}};
 220             push @meta, sprintf "%7s:  ", $_;
 221             @list = map { "\"$_\"" } @list if $_ eq 'Title';
 222             push @meta, my_wrap("","          ", join(", ",@list)."\n");
 223         }
 224         $name = "\n$name" if @meta and $name;
 225     }
 226     # don't print the header unless the file contains something interesting
 227     return if !@meta and !$ls->{out};
 228     print("$ls->{in}\n"),return  if $::opt_l;   # -l = no listing
 229
 230     # a twisty maze of little options
 231     my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
 232     print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat";
 233     print join('',"\n",@meta) if @meta;
 234
 235     my @v = sort PATORDER keys %{ $ls->{out} };
 236     my $v = "@v\n";
 237     print $::opt_m ? "  Files:  ".my_wrap("","          ",$v) : $v;
 238 }
 239
 240
 241 sub my_wrap {
 242     return expand(wrap(@_));
 243 }
 244
 245
 246
 247 sub categorize_files {
 248     my($files, $verb) = @_;
 249     my(%c, $refine);
 250
 251     foreach (@$files) { # assign a score to a file path
 252         # the order of some of the tests is important
 253         $c{TEST} += 5,next   if m:^t/:;
 254         $c{DOC}  += 5,next   if m:^pod/:;
 255         $c{UTIL} += 10,next  if m:^(utils|x2p|h2pl)/:;
 256         $c{PORT} += 15,next
 257             if m:^(cygwin32|os2|plan9|qnx|vms|win32)/:
 258             or m:^(hints|Porting|ext/DynaLoader)/:
 259             or m:^README\.:;
 260         $c{LIB}  += 10,next
 261             if m:^(lib|ext)/:;
 262         $c{'CORE'} += 15,next
 263             if m:^[^/]+[\._]([chH]|sym)$:;
 264         $c{BUILD} += 10,next
 265             if m:^[A-Z]+$: or m:^[^/]+\.SH$:
 266             or m:^(install|configure):i;
 267         print "Couldn't categorise $_\n" if $::opt_v;
 268         $c{OTHER} += 1;
 269     }
 270     if (keys %c > 1) {  # sort to find category with highest score
 271       refine:
 272         ++$refine;
 273         my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
 274         my @v = map  { $c{$_} } @c;
 275         if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
 276                 and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare
 277             print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
 278             ++$c{$c[1]};
 279             goto refine;
 280         }
 281         print "  ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
 282             if $verb;
 283         return $c[0] || 'OTHER';
 284     }
 285     else {
 286         my($c, $v) = %c;
 287         $c ||= 'OTHER'; $v ||= 0;
 288         print "  ".@$files." patches: $c: $v\n" if $verb;
 289         return $c;
 290     }
 291 }
 292
 293
 294 sub PATORDER {          # PATORDER sort by Chip Salzenberg
 295     my ($i, $j);
 296
 297     $i = ($a =~ m#^[A-Z]+$#);
 298     $j = ($b =~ m#^[A-Z]+$#);
 299     return $j - $i if $i != $j;
 300
 301     $i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
 302     $j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
 303     return $j - $i if $i != $j;
 304
 305     $i = ($a =~ m#\.pod$#);
 306     $j = ($b =~ m#\.pod$#);
 307     return $j - $i if $i != $j;
 308
 309     $i = ($a =~ m#include/#);
 310     $j = ($b =~ m#include/#);
 311     return $j - $i if $i != $j;
 312
 313     if ((($i = $a) =~ s#/+[^/]*$##)
 314         && (($j = $b) =~ s#/+[^/]*$##)) {
 315             return $i cmp $j if $i ne $j;
 316     }
 317
 318     $i = ($a =~ m#\.h$#);
 319     $j = ($b =~ m#\.h$#);
 320     return $j - $i if $i != $j;
 321
 322     return $a cmp $b;
 323 }
 324