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