MSG_PROXY for GNU/Hurd (previously we believed that
[p5sagit/p5-mst-13.2.git] / 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