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