A slightly better layout for the diagram.
[p5sagit/p5-mst-13.2.git] / Porting / patchls
1 #!/usr/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