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