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