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