contrib/perl5/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.08;
  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 PATCH',
  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 #       @@ -656,9 +656,27 @@
 135 # or (rcs, note the different date format)
 136 #       --- 1.18        1997/05/23 19:22:04
 137 #       +++ ./pod/perlembed.pod 1997/06/03 21:41:38
 138 #
 139 # Variation:
 140 #       Index: embed.h
 141
 142 my %ls;
 143
 144 my $in;
 145 my $ls;
 146 my $prevline = '';
 147 my $prevtype = '';
 148 my (@removed, @added);
 149 my $prologue = 1;       # assume prologue till patch or /^exit\b/ seen
 150
 151
 152 foreach my $argv (@ARGV) {
 153     $in = $argv;
 154     unless (open F, "<$in") {
 155         warn "Unable to open $in: $!\n";
 156         next;
 157     }
 158     print "Reading $in...\n" if $::opt_v and @ARGV > 1;
 159     $ls = $ls{$in} ||= { is_in => 1, in => $in };
 160     my $type;
 161     while (<F>) {
 162         unless (/^([-+*]{3}) / || /^(Index):/) {
 163             # not an interesting patch line
 164             # but possibly meta-information or prologue
 165             if ($prologue) {
 166                 push @added, $1     if /^touch\s+(\S+)/;
 167                 push @removed, $1   if /^rm\s+(?:-f)?\s*(\S+)/;
 168                 $prologue = 0       if /^exit\b/;
 169             }
 170             get_meta_info($ls, $_) if $::opt_m;
 171             next;
 172         }
 173         $type = $1;
 174         next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
 175         $prologue = 0;
 176
 177         print "Last: $prevline","This: ${_}Got:  $type\n\n" if $::opt_d;
 178
 179         # Some patches have Index lines but not diff headers
 180         # Patch copes with this, so must we. It's also handy for
 181         # documenting manual changes by simply adding Index: lines
 182         # to the file which describes the problem being fixed.
 183         if (/^Index:\s+(.*)/) {
 184             my $f;
 185             foreach $f (split(/ /, $1)) { add_file($ls, $f) }
 186             next;
 187         }
 188
 189         if (    ($type eq '---' and $prevtype eq '***') # Style 1
 190             or  ($type eq '+++' and $prevtype eq '---') # Style 2
 191         ) {
 192             if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) {     # double check
 193                 add_file($ls, $1);
 194             }
 195             else {
 196                 warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
 197             }
 198         }
 199     }
 200     continue {
 201         $prevline = $_;
 202         $prevtype = $type || '';
 203         $type = '';
 204     }
 205
 206     # special mode for patch sets from Chip
 207     if ($in =~ m:[\\/]patch$:) {
 208         my $is_chip;
 209         my $chip;
 210         my $dir; ($dir = $in) =~ s:[\\/]patch$::;
 211         if (!$ls->{From} && (open(CHIP,"$dir/article") || open(CHIP,"$dir/bug"))) {
 212             get_meta_info($ls, $_) while (<CHIP>);
 213             $is_chip = 1;
 214         }
 215         if (open CHIP,"<$dir/from") {
 216             chop($chip = <CHIP>);
 217             $ls->{From} = { $chip => 1 };
 218             $is_chip = 1;
 219         }
 220         if (open CHIP,"<$dir/tag") {
 221             chop($chip = <CHIP>);
 222             $ls->{Title} = { $chip => 1 };
 223             $is_chip = 1;
 224         }
 225         $ls->{From} = { "Chip Salzenberg" => 1 } if $is_chip && !$ls->{From};
 226     }
 227
 228     # if we don't have a title for -m then use the file name
 229     $ls->{Title}{$in}=1 if $::opt_m
 230         and !$ls->{Title} and $ls->{out};
 231
 232     $ls->{category} = $::opt_c
 233         ? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
 234 }
 235 print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
 236
 237
 238 # --- Firstly we filter and sort as needed ---
 239
 240 my @ls  = values %ls;
 241
 242 if ($::opt_f) {         # filter out patches based on -f <regexp>
 243     $::opt_f .= '$' unless $::opt_f =~ m:/:;
 244     @ls = grep {
 245         my $match = 0;
 246         if ($_->{is_in}) {
 247             my @out = keys %{ $_->{out} };
 248             $match=1 if grep { m/$::opt_f/o } @out;
 249         }
 250         else {
 251             $match=1 if $_->{in} =~ m/$::opt_f/o;
 252         }
 253         $match;
 254     } @ls;
 255 }
 256
 257 @ls  = sort {
 258     $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
 259 } @ls;
 260
 261
 262 # --- Handle special modes ---
 263
 264 if ($::opt_4) {
 265     my $tail = ($::opt_5) ? "|| exit 1" : "";
 266     print map { "p4 delete $_$tail\n" } @removed if @removed;
 267     print map { "p4 add    $_$tail\n" } @added   if @added;
 268     my @patches = sort grep { $_->{is_in} } @ls;
 269     my @no_outs = grep { keys %{$_->{out}} == 0 } @patches;
 270     warn "Warning: Some files contain no patches:",
 271         join("\n\t", '', map { $_->{in} } @no_outs), "\n" if @no_outs;
 272     my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
 273     delete @patched{@added};
 274     my @patched = sort keys %patched;
 275     foreach(@patched) {
 276         my $edit = ($::opt_e && !-f $_) ? "add " : "edit";
 277         print "p4 $edit   $_$tail\n";
 278     }
 279     exit 0 unless $::opt_C;
 280 }
 281
 282
 283 if ($::opt_I) {
 284     my $n_patches = 0;
 285     my($in,$out);
 286     my %all_out;
 287     my @no_outs;
 288     foreach $in (@ls) {
 289         next unless $in->{is_in};
 290         ++$n_patches;
 291         my @outs = keys %{$in->{out}};
 292         push @no_outs, $in unless @outs;
 293         @all_out{@outs} = ($in->{in}) x @outs;
 294     }
 295     my @all_out = sort keys %all_out;
 296     my @missing = grep { ! -f $_ } @all_out;
 297     print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n";
 298     print @no_outs." patch files don't contain patches.\n" if @no_outs;
 299     print "(use -v to list patches which patch 'missing' files)\n"
 300             if (@missing || @no_outs) && !$::opt_v;
 301     if ($::opt_v and @no_outs) {
 302         print "Patch files which don't contain patches:\n";
 303         foreach $out (@no_outs) {
 304             printf "  %-20s\n", $out->{in};
 305         }
 306     }
 307     if ($::opt_v and @missing) {
 308         print "Missing files:\n";
 309         foreach $out (@missing) {
 310             printf "  %-20s\t", $out    unless $::opt_h;
 311             print $all_out{$out}        unless $::opt_l;
 312             print "\n";
 313         }
 314     }
 315     print "Added files:   @added\n"   if @added;
 316     print "Removed files: @removed\n" if @removed;
 317     exit 0+@missing;
 318 }
 319
 320 unless ($::opt_c and $::opt_m) {
 321     foreach $ls (@ls) {
 322         next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
 323         next if $::opt_X and keys %{$ls->{out}} <= 1;
 324         list_files_by_patch($ls);
 325     }
 326 }
 327 else {
 328     my $c = '';
 329     foreach $ls (@ls) {
 330         next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
 331         print "\n  ------  $cat_title{$ls->{category}}  ------\n"
 332             if $ls->{category} ne $c;
 333         $c = $ls->{category};
 334         unless ($::opt_i) {
 335             list_files_by_patch($ls);
 336         }
 337         else {
 338             my $out = $ls->{in};
 339             print "\n$out patched by:\n";
 340             # find all the patches which patch $out and list them
 341             my @p = grep { $_->{out}->{$out} } values %ls;
 342             foreach $ls (@p) {
 343                 list_files_by_patch($ls, '');
 344             }
 345         }
 346     }
 347     print "\n";
 348 }
 349
 350 exit 0;
 351
 352
 353 # ---
 354
 355
 356 sub add_file {
 357     my $ls = shift;
 358         print "add_file '$_[0]'\n" if $::opt_d;
 359     my $out = trim_name(shift);
 360
 361     $ls->{out}->{$out} = 1;
 362
 363     warn "$out patched but not present\n" if $::opt_e && !-f $out;
 364
 365     # do the -i inverse as well, even if we're not doing -i
 366     my $i = $ls{$out} ||= {
 367         is_out   => 1,
 368         in       => $out,
 369         category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
 370     };
 371     $i->{out}->{$in} = 1;
 372 }
 373
 374
 375 sub trim_name {         # reduce/tidy file paths from diff lines
 376     my $name = shift;
 377     $name = "$name ($in)" if $name eq "/dev/null";
 378     $name =~ s:\\:/:g;  # adjust windows paths
 379     $name =~ s://:/:g;  # simplify (and make win \\share into absolute path)
 380     if (defined $::opt_p) {
 381         # strip on -p levels of directory prefix
 382         my $dc = $::opt_p;
 383         $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
 384     }
 385     else {      # try to strip off leading path to perl directory
 386         # if absolute path, strip down to any *perl* directory first
 387         $name =~ s:^/.*?perl.*?/::i;
 388         $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i;
 389         $name =~ s:^\./::;
 390     }
 391     return $name;
 392 }
 393
 394
 395 sub list_files_by_patch {
 396     my($ls, $name) = @_;
 397     $name = $ls->{in} unless defined $name;
 398     my @meta;
 399     if ($::opt_m) {
 400         my $meta;
 401         foreach $meta (@show_meta) {
 402             next unless $ls->{$meta};
 403             my @list = sort keys %{$ls->{$meta}};
 404             push @meta, sprintf "%7s:  ", $meta;
 405             if ($meta eq 'Title') {
 406                 @list = map { "\"$_\""; } @list;
 407                 push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:;
 408             }
 409             elsif ($meta eq 'From') {
 410                 # fix-up bizzare addresses from japan and ibm :-)
 411                 foreach(@list) {
 412                     s:\W+=?iso.*?<: <:;
 413                     s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//;
 414                 }
 415             }
 416             elsif ($meta eq 'Msg-ID') {
 417                 my %from; # limit long threads to one msg-id per site
 418                 @list = map {
 419                     $from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_);
 420                 } @list;
 421             }
 422             push @meta, my_wrap("","          ", join(", ",@list)."\n");
 423         }
 424         $name = "\n$name" if @meta and $name;
 425     }
 426     # don't print the header unless the file contains something interesting
 427     return if !@meta and !$ls->{out} and !$::opt_v;
 428     if ($::opt_l) {     # -l = no listing, just names
 429         print "$ls->{in}";
 430         my $n = keys %{ $ls->{out} };
 431         print " ($n patches)" if $::opt_n and $n>1;
 432         print "\n";
 433         return;
 434     }
 435
 436     # a twisty maze of little options
 437     my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
 438     print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat";
 439     print join('',"\n",@meta) if @meta;
 440
 441     return if $::opt_m && !$show_meta{Files};
 442     my @v = sort PATORDER keys %{ $ls->{out} };
 443     my $n = @v;
 444     my $v = "@v";
 445     print $::opt_m ? "  Files:  ".my_wrap("","          ",$v) : $v;
 446     print " ($n patches)" if $::opt_n and $n>1;
 447     print "\n";
 448 }
 449
 450
 451 sub my_wrap {
 452         my $txt = eval { expand(wrap(@_)) };    # die's on long lines!
 453     return $txt unless $@;
 454         return expand("@_");
 455 }
 456
 457
 458
 459 sub categorize_files {
 460     my($files, $verb) = @_;
 461     my(%c, $refine);
 462
 463     foreach (@$files) { # assign a score to a file path
 464         # the order of some of the tests is important
 465         $c{TEST} += 5,next   if m:^t/:;
 466         $c{DOC}  += 5,next   if m:^pod/:;
 467         $c{UTIL} += 10,next  if m:^(utils|x2p|h2pl)/:;
 468         $c{PORT1}+= 15,next  if m:^win32:;
 469         $c{PORT2} += 15,next
 470             if m:^(cygwin32|os2|plan9|qnx|vms)/:
 471             or m:^(hints|Porting|ext/DynaLoader)/:
 472             or m:^README\.:;
 473         $c{EXT}  += 10,next
 474             if m:^(ext|lib/ExtUtils)/:;
 475         $c{LIB}  += 10,next
 476             if m:^(lib)/:;
 477         $c{'CORE'} += 15,next
 478             if m:^[^/]+[\._]([chH]|sym|pl)$:;
 479         $c{BUILD} += 10,next
 480             if m:^[A-Z]+$: or m:^[^/]+\.SH$:
 481             or m:^(install|configure|configpm):i;
 482         print "Couldn't categorise $_\n" if $::opt_v;
 483         $c{OTHER} += 1;
 484     }
 485     if (keys %c > 1) {  # sort to find category with highest score
 486       refine:
 487         ++$refine;
 488         my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
 489         my @v = map  { $c{$_} } @c;
 490         if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
 491                 and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare
 492             print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
 493             ++$c{$c[1]};
 494             goto refine;
 495         }
 496         print "  ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
 497             if $verb;
 498         return $c[0] || 'OTHER';
 499     }
 500     else {
 501         my($c, $v) = %c;
 502         $c ||= 'UNKNOWN'; $v ||= 0;
 503         print "  ".@$files." patches: $c: $v\n" if $verb;
 504         return $c;
 505     }
 506 }
 507
 508
 509 sub PATORDER {          # PATORDER sort by Chip Salzenberg
 510     my ($i, $j);
 511
 512     $i = ($a =~ m#^[A-Z]+$#);
 513     $j = ($b =~ m#^[A-Z]+$#);
 514     return $j - $i if $i != $j;
 515
 516     $i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
 517     $j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
 518     return $j - $i if $i != $j;
 519
 520     $i = ($a =~ m#\.pod$#);
 521     $j = ($b =~ m#\.pod$#);
 522     return $j - $i if $i != $j;
 523
 524     $i = ($a =~ m#include/#);
 525     $j = ($b =~ m#include/#);
 526     return $j - $i if $i != $j;
 527
 528     if ((($i = $a) =~ s#/+[^/]*$##)
 529         && (($j = $b) =~ s#/+[^/]*$##)) {
 530             return $i cmp $j if $i ne $j;
 531     }
 532
 533     $i = ($a =~ m#\.h$#);
 534     $j = ($b =~ m#\.h$#);
 535     return $j - $i if $i != $j;
 536
 537     return $a cmp $b;
 538 }
 539