This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Maintenance 5.004_04 changes
[perl5.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.04;
21
22 sub usage {
23 die q{
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     -f F   only list patches which patch files matching regexp F
34            (F has $ appended unless it contains a /).
35   other options for special uses:
36     -I     just gather and display summary Information about the patches.
37     -4     write to stdout the PerForce commands to prepare for patching.
38     -M T   Like -m but only output listed meta tags (eg -M 'Title From')
39     -W N   set wrap width to N (defaults to 70, use 0 for no wrap)
40 }
41 }
42
43 $::opt_p = undef;       # undef != 0
44 $::opt_d = 0;
45 $::opt_v = 0;
46 $::opt_m = 0;
47 $::opt_i = 0;
48 $::opt_h = 0;
49 $::opt_l = 0;
50 $::opt_c = 0;
51 $::opt_f = '';
52
53 # special purpose options
54 $::opt_I = 0;
55 $::opt_4 = 0;   # output PerForce commands to prepare for patching
56 $::opt_M = '';  # like -m but only output these meta items (-M Title)
57 $::opt_W = 70;  # set wrap width columns (see Text::Wrap module)
58
59 usage unless @ARGV;
60
61 getopts("mihlvc4p:f:IM:W:") or usage;
62
63 $columns = $::opt_W || 9999999;
64
65 $::opt_m = 1 if $::opt_M;
66 my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID');
67
68 my %cat_title = (
69     'BUILD'     => 'BUILD PROCESS',
70     'CORE'      => 'CORE LANGUAGE',
71     'DOC'       => 'DOCUMENTATION',
72     'LIB'       => 'LIBRARY AND EXTENSIONS',
73     'PORT1'     => 'PORTABILITY - WIN32',
74     'PORT2'     => 'PORTABILITY - GENERAL',
75     'TEST'      => 'TESTS',
76     'UTIL'      => 'UTILITIES',
77     'OTHER'     => 'OTHER CHANGES',
78 );
79
80 my %ls;
81
82 # Style 1:
83 #       *** perl-5.004/embed.h  Sat May 10 03:39:32 1997
84 #       --- perl-5.004.fixed/embed.h    Thu May 29 19:48:46 1997
85 #       ***************
86 #       *** 308,313 ****
87 #       --- 308,314 ----
88 #
89 # Style 2:
90 #       --- perl5.004001/mg.c   Sun Jun 08 12:26:24 1997
91 #       +++ perl5.004-bc/mg.c   Sun Jun 08 11:56:08 1997
92 #       @@ -656,9 +656,27 @@
93 # or (rcs, note the different date format)
94 #       --- 1.18        1997/05/23 19:22:04
95 #       +++ ./pod/perlembed.pod 1997/06/03 21:41:38
96 #
97 # Variation:
98 #       Index: embed.h
99
100 my($in, $prevline, $prevtype, $ls);
101 my(@removed, @added);
102 my $prologue = 1;       # assume prologue till patch or /^exit\b/ seen
103
104 foreach my $argv (@ARGV) {
105     $in = $argv;
106     unless (open F, "<$in") {
107         warn "Unable to open $in: $!\n";
108         next;
109     }
110     print "Reading $in...\n" if $::opt_v and @ARGV > 1;
111     $ls = $ls{$in} ||= { is_in => 1, in => $in };
112     my $type;
113     while (<F>) {
114         unless (/^([-+*]{3}) / || /^(Index):/) {
115             # not an interesting patch line
116             # but possibly meta-information or prologue
117             if ($prologue) {
118                 push @added, $1     if /^touch\s+(\S+)/;
119                 push @removed, $1   if /^rm\s+(?:-f)?\s*(\S+)/;
120                 $prologue = 0       if /^exit\b/;
121             }
122             next unless $::opt_m;
123             $ls->{From}{$1}=1,next     if /^From:\s+(.*\S)/i;
124             $ls->{Title}{$1}=1,next    if /^Subject:\s+(?:Re: )?(.*\S)/i;
125             $ls->{'Msg-ID'}{$1}=1,next if /^Message-Id:\s+(.*\S)/i;
126             $ls->{Date}{$1}=1,next     if /^Date:\s+(.*\S)/i;
127             $ls->{$1}{$2}=1,next       if /^([-\w]+):\s+(.*\S)/;
128             next;
129         }
130         $type = $1;
131         next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
132         $prologue = 0;
133
134         print "Last: $prevline","This: ${_}Got:  $1\n\n" if $::opt_d;
135
136         # Some patches have Index lines but not diff headers
137         # Patch copes with this, so must we. It's also handy for
138         # documenting manual changes by simply adding Index: lines
139         # to the file which describes the problem bing fixed.
140         add_file($ls, $1), next if /^Index:\s+(\S+)/;
141
142         if (    ($type eq '---' and $prevtype eq '***') # Style 1
143             or  ($type eq '+++' and $prevtype eq '---') # Style 2
144         ) {
145             if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) {     # double check
146                 add_file($ls, $1);
147             }
148             else {
149                 warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
150             }
151         }
152     }
153     continue {
154         $prevline = $_;
155         $prevtype = $type;
156         $type = '';
157     }
158     # if we don't have a title for -m then use the file name
159     $ls->{Title}{$in}=1 if $::opt_m
160         and !$ls->{Title} and $ls->{out};
161
162     $ls->{category} = $::opt_c
163         ? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
164 }
165 print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
166
167
168 # --- Firstly we filter and sort as needed ---
169
170 my @ls  = values %ls;
171
172 if ($::opt_f) {         # filter out patches based on -f <regexp>
173     my $out;
174     $::opt_f .= '$' unless $::opt_f =~ m:/:;
175     @ls = grep {
176         my @out = keys %{$_->{out}};
177         my $match = 0;
178         for $out (@out) {
179             ++$match if $out =~ m/$::opt_f/o;
180         }
181         $match;
182     } @ls;
183 }
184
185 @ls  = sort {
186     $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
187 } @ls;
188
189
190 # --- Handle special modes ---
191
192 if ($::opt_4) {
193     print map { "p4 delete $_\n" } @removed if @removed;
194     print map { "p4 add    $_\n" } @added   if @added;
195     my @patches = grep { $_->{is_in} } @ls;
196     my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
197     delete @patched{@added};
198     my @patched = sort keys %patched;
199     print map { "p4 edit   $_\n" } @patched if @patched;
200     exit 0;
201 }
202
203 if ($::opt_I) {
204     my $n_patches = 0;
205     my($in,$out);
206     my %all_out;
207     foreach $in (@ls) {
208         next unless $in->{is_in};
209         ++$n_patches;
210         my @outs = keys %{$in->{out}};
211         @all_out{@outs} = ($in->{in}) x @outs;
212     }
213     my @all_out = sort keys %all_out;
214     my @missing = grep { ! -f $_ } @all_out;
215     print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n";
216     print "(use -v to list patches which patch 'missing' files)\n"
217             if @missing && !$::opt_v;
218     if ($::opt_v and @missing) {
219         print "Missing files:\n";
220         foreach $out (@missing) {
221             printf "  %-20s\t%s\n", $out, $all_out{$out};
222         }
223     }
224     print "Added files:   @added\n"   if @added;
225     print "Removed files: @removed\n" if @removed;
226     exit 0+@missing;
227 }
228
229 unless ($::opt_c and $::opt_m) {
230     foreach $ls (@ls) {
231         next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
232         list_files_by_patch($ls);
233     }
234 }
235 else {
236     my $c = '';
237     foreach $ls (@ls) {
238         next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
239         print "\n  ------  $cat_title{$ls->{category}}  ------\n"
240             if $ls->{category} ne $c;
241         $c = $ls->{category};
242         unless ($::opt_i) {
243             list_files_by_patch($ls);
244         }
245         else {
246             my $out = $ls->{in};
247             print "\n$out patched by:\n";
248             # find all the patches which patch $out and list them
249             my @p = grep { $_->{out}->{$out} } values %ls;
250             foreach $ls (@p) {
251                 list_files_by_patch($ls, '');
252             }
253         }
254     }
255     print "\n";
256 }
257
258 exit 0;
259
260
261 # ---
262
263
264 sub add_file {
265     my $ls = shift;
266     my $out = trim_name(shift);
267
268     $ls->{out}->{$out} = 1;
269
270     # do the -i inverse as well, even if we're not doing -i
271     my $i = $ls{$out} ||= {
272         is_out   => 1,
273         in       => $out,
274         category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
275     };
276     $i->{out}->{$in} = 1;
277 }
278
279
280 sub trim_name {         # reduce/tidy file paths from diff lines
281     my $name = shift;
282     $name = "$name ($in)" if $name eq "/dev/null";
283     $name =~ s:\\:/:g;  # adjust windows paths
284     $name =~ s://:/:g;  # simplify (and make win \\share into absolute path)
285     if (defined $::opt_p) {
286         # strip on -p levels of directory prefix
287         my $dc = $::opt_p;
288         $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
289     }
290     else {      # try to strip off leading path to perl directory
291         # if absolute path, strip down to any *perl* directory first
292         $name =~ s:^/.*?perl.*?/::i;
293         $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i;
294         $name =~ s:^\./::;
295     }
296     return $name;
297 }
298
299
300 sub list_files_by_patch {
301     my($ls, $name) = @_;
302     $name = $ls->{in} unless defined $name;
303     my @meta;
304     if ($::opt_m) {
305         my $meta;
306         foreach $meta (@show_meta) {
307             next unless $ls->{$meta};
308             my @list = sort keys %{$ls->{$meta}};
309             push @meta, sprintf "%7s:  ", $meta;
310             if ($meta eq 'Title') {
311                 @list = map { s/\[?PATCH\]?:?\s*//g; "\"$_\""; } @list
312             }
313             elsif ($meta eq 'From') {
314                 # fix-up bizzare addresses from japan and ibm :-)
315                 foreach(@list) {
316                     s:\W+=?iso.*?<: <:;
317                     s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//;
318                 }
319             }
320             elsif ($meta eq 'Msg-ID') {
321                 my %from; # limit long threads to one msg-id per site
322                 @list = map {
323                     $from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_);
324                 } @list;
325             }
326             push @meta, my_wrap("","          ", join(", ",@list)."\n");
327         }
328         $name = "\n$name" if @meta and $name;
329     }
330     # don't print the header unless the file contains something interesting
331     return if !@meta and !$ls->{out};
332     print("$ls->{in}\n"),return  if $::opt_l;   # -l = no listing
333
334     # a twisty maze of little options
335     my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
336     print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat";
337     print join('',"\n",@meta) if @meta;
338
339     my @v = sort PATORDER keys %{ $ls->{out} };
340     my $v = "@v\n";
341     print $::opt_m ? "  Files:  ".my_wrap("","          ",$v) : $v;
342 }
343
344
345 sub my_wrap {
346         my $txt = eval { expand(wrap(@_)) };    # die's on long lines!
347     return $txt unless $@;
348         return expand("@_");
349 }
350
351
352
353 sub categorize_files {
354     my($files, $verb) = @_;
355     my(%c, $refine);
356
357     foreach (@$files) { # assign a score to a file path
358         # the order of some of the tests is important
359         $c{TEST} += 5,next   if m:^t/:;
360         $c{DOC}  += 5,next   if m:^pod/:;
361         $c{UTIL} += 10,next  if m:^(utils|x2p|h2pl)/:;
362         $c{PORT1}+= 15,next  if m:^win32:;
363         $c{PORT2} += 15,next
364             if m:^(cygwin32|os2|plan9|qnx|vms)/:
365             or m:^(hints|Porting|ext/DynaLoader)/:
366             or m:^README\.:;
367         $c{LIB}  += 10,next
368             if m:^(lib|ext)/:;
369         $c{'CORE'} += 15,next
370             if m:^[^/]+[\._]([chH]|sym|pl)$:;
371         $c{BUILD} += 10,next
372             if m:^[A-Z]+$: or m:^[^/]+\.SH$:
373             or m:^(install|configure|configpm):i;
374         print "Couldn't categorise $_\n" if $::opt_v;
375         $c{OTHER} += 1;
376     }
377     if (keys %c > 1) {  # sort to find category with highest score
378       refine:
379         ++$refine;
380         my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
381         my @v = map  { $c{$_} } @c;
382         if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
383                 and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare
384             print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
385             ++$c{$c[1]};
386             goto refine;
387         }
388         print "  ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
389             if $verb;
390         return $c[0] || 'OTHER';
391     }
392     else {
393         my($c, $v) = %c;
394         $c ||= 'OTHER'; $v ||= 0;
395         print "  ".@$files." patches: $c: $v\n" if $verb;
396         return $c;
397     }
398 }
399
400
401 sub PATORDER {          # PATORDER sort by Chip Salzenberg
402     my ($i, $j);
403
404     $i = ($a =~ m#^[A-Z]+$#);
405     $j = ($b =~ m#^[A-Z]+$#);
406     return $j - $i if $i != $j;
407
408     $i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
409     $j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
410     return $j - $i if $i != $j;
411
412     $i = ($a =~ m#\.pod$#);
413     $j = ($b =~ m#\.pod$#);
414     return $j - $i if $i != $j;
415
416     $i = ($a =~ m#include/#);
417     $j = ($b =~ m#include/#);
418     return $j - $i if $i != $j;
419
420     if ((($i = $a) =~ s#/+[^/]*$##)
421         && (($j = $b) =~ s#/+[^/]*$##)) {
422             return $i cmp $j if $i ne $j;
423     }
424
425     $i = ($a =~ m#\.h$#);
426     $j = ($b =~ m#\.h$#);
427     return $j - $i if $i != $j;
428
429     return $a cmp $b;
430 }
431