Commit | Line | Data |
08aa1457 |
1 | #!/bin/perl -w |
2 | # |
3e3baf6d |
3 | # patchls - patch listing utility |
08aa1457 |
4 | # |
5 | # Input is one or more patchfiles, output is a list of files to be patched. |
6 | # |
3e3baf6d |
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 | # |
08aa1457 |
13 | # $Id: patchls,v 1.3 1997/06/10 21:38:45 timbo Exp $ |
14 | |
3e3baf6d |
15 | use Getopt::Std; |
08aa1457 |
16 | use Text::Wrap qw(wrap $columns); |
17 | use Text::Tabs qw(expand unexpand); |
18 | use strict; |
19 | |
3e3baf6d |
20 | sub usage { |
84902520 |
21 | die q{ |
3e3baf6d |
22 | patchls [options] patchfile [ ... ] |
23 | |
84902520 |
24 | -i Invert: for each patched file list which patch files patch it. |
25 | -h no filename headers (like grep), only the listing. |
26 | -l no listing (like grep), only the filename headers. |
27 | -c Categorise the patch and sort by category (perl specific). |
28 | -m print formatted Meta-information (Subject,From,Msg-ID etc). |
29 | -p N strip N levels of directory Prefix (like patch), else automatic. |
30 | -v more verbose (-d for noisy debugging). |
31 | -f F only list patches which patch files matching regexp F |
32 | (F has $ appended unless it contains a /). |
33 | -I just gather and display summary Information about the patches. |
3e3baf6d |
34 | } |
35 | } |
36 | |
08aa1457 |
37 | $columns = 70; |
38 | |
3e3baf6d |
39 | $::opt_p = undef; # undef != 0 |
08aa1457 |
40 | $::opt_d = 0; |
41 | $::opt_v = 0; |
42 | $::opt_m = 0; |
43 | $::opt_i = 0; |
44 | $::opt_h = 0; |
45 | $::opt_l = 0; |
46 | $::opt_c = 0; |
84902520 |
47 | $::opt_f = ''; |
48 | $::opt_I = 0; |
08aa1457 |
49 | |
3e3baf6d |
50 | usage unless @ARGV; |
08aa1457 |
51 | |
84902520 |
52 | getopts("mihlvcp:f:I") or usage; |
08aa1457 |
53 | |
3e3baf6d |
54 | my %cat_title = ( |
84902520 |
55 | 'BUILD' => 'BUILD PROCESS', |
56 | 'CORE' => 'CORE LANGUAGE', |
3e3baf6d |
57 | 'DOC' => 'DOCUMENTATION', |
3e3baf6d |
58 | 'LIB' => 'LIBRARY AND EXTENSIONS', |
84902520 |
59 | 'PORT1' => 'PORTABILITY - WIN32', |
60 | 'PORT2' => 'PORTABILITY - OTHER', |
61 | 'TEST' => 'TESTS', |
62 | 'UTIL' => 'UTILITIES', |
63 | 'OTHER' => 'OTHER CHANGES', |
3e3baf6d |
64 | ); |
08aa1457 |
65 | |
66 | my %ls; |
67 | |
68 | # Style 1: |
69 | # *** perl-5.004/embed.h Sat May 10 03:39:32 1997 |
70 | # --- perl-5.004.fixed/embed.h Thu May 29 19:48:46 1997 |
71 | # *************** |
72 | # *** 308,313 **** |
73 | # --- 308,314 ---- |
74 | # |
75 | # Style 2: |
76 | # --- perl5.004001/mg.c Sun Jun 08 12:26:24 1997 |
77 | # +++ perl5.004-bc/mg.c Sun Jun 08 11:56:08 1997 |
78 | # @@ -656,9 +656,27 @@ |
79 | # or (rcs, note the different date format) |
80 | # --- 1.18 1997/05/23 19:22:04 |
81 | # +++ ./pod/perlembed.pod 1997/06/03 21:41:38 |
82 | # |
83 | # Variation: |
84 | # Index: embed.h |
85 | |
86 | my($in, $prevline, $prevtype, $ls); |
87 | |
88 | foreach my $argv (@ARGV) { |
89 | $in = $argv; |
90 | unless (open F, "<$in") { |
91 | warn "Unable to open $in: $!\n"; |
92 | next; |
93 | } |
94 | print "Reading $in...\n" if $::opt_v and @ARGV > 1; |
3e3baf6d |
95 | $ls = $ls{$in} ||= { is_in => 1, in => $in }; |
08aa1457 |
96 | my $type; |
97 | while (<F>) { |
98 | unless (/^([-+*]{3}) / || /^(Index):/) { |
99 | # not an interesting patch line but possibly meta-information |
100 | next unless $::opt_m; |
84902520 |
101 | $ls->{From}{$1}=1 if /^From:\s+(.*\S)/i; |
102 | $ls->{Title}{$1}=1 if /^Subject:\s+(?:Re: )?(.*\S)/i; |
103 | $ls->{'Msg-ID'}{$1}=1 if /^Message-Id:\s+(.*\S)/i; |
104 | $ls->{Date}{$1}=1 if /^Date:\s+(.*\S)/i; |
08aa1457 |
105 | next; |
106 | } |
107 | $type = $1; |
108 | next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/; |
109 | |
110 | print "Last: $prevline","This: ${_}Got: $1\n\n" if $::opt_d; |
111 | |
112 | # Some patches have Index lines but not diff headers |
3e3baf6d |
113 | # Patch copes with this, so must we. It's also handy for |
114 | # documenting manual changes by simply adding Index: lines |
115 | # to the file which describes the problem bing fixed. |
08aa1457 |
116 | add_file($ls, $1), next if /^Index:\s+(.*)/; |
117 | |
118 | if ( ($type eq '---' and $prevtype eq '***') # Style 1 |
119 | or ($type eq '+++' and $prevtype eq '---') # Style 2 |
120 | ) { |
121 | if (/^[-+*]{3} (\S+)\s+.*\d\d:\d\d:\d\d/) { # double check |
122 | add_file($ls, $1); |
123 | } |
124 | else { |
125 | warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_"; |
126 | } |
127 | } |
128 | } |
129 | continue { |
130 | $prevline = $_; |
131 | $prevtype = $type; |
132 | $type = ''; |
133 | } |
3e3baf6d |
134 | # if we don't have a title for -m then use the file name |
135 | $ls->{Title}{$in}=1 if $::opt_m |
136 | and !$ls->{Title} and $ls->{out}; |
137 | |
138 | $ls->{category} = $::opt_c |
139 | ? categorize_files([keys %{ $ls->{out} }], $::opt_v) : ''; |
08aa1457 |
140 | } |
3e3baf6d |
141 | print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1; |
142 | |
143 | |
144 | my @ls = sort { |
145 | $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in} |
146 | } values %ls; |
08aa1457 |
147 | |
84902520 |
148 | if ($::opt_f) { # filter out patches based on -f <regexp> |
149 | my $out; |
150 | $::opt_f .= '$' unless $::opt_f =~ m:/:; |
151 | @ls = grep { |
152 | my @out = keys %{$_->{out}}; |
153 | my $match = 0; |
154 | for $out (@out) { |
155 | ++$match if $out =~ m/$::opt_f/o; |
156 | } |
157 | $match; |
158 | } @ls; |
159 | } |
160 | |
161 | if ($::opt_I) { |
162 | my $n_patches = 0; |
163 | my($in,$out); |
164 | my %all_out; |
165 | foreach $in (@ls) { |
166 | next unless $in->{is_in}; |
167 | ++$n_patches; |
168 | my @outs = keys %{$in->{out}}; |
169 | @all_out{@outs} = ($in->{in}) x @outs; |
170 | } |
171 | my @all_out = sort keys %all_out; |
172 | my @missing = grep { ! -f $_ } @all_out; |
173 | print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n"; |
174 | if ($::opt_v and @missing) { |
175 | print "Missing files:\n"; |
176 | foreach $out (@missing) { |
177 | printf " %-20s\t%s\n", $out, $all_out{$out}; |
178 | } |
179 | } |
180 | exit 0+@missing; |
181 | } |
182 | |
08aa1457 |
183 | unless ($::opt_c and $::opt_m) { |
3e3baf6d |
184 | foreach $ls (@ls) { |
185 | next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; |
08aa1457 |
186 | list_files_by_patch($ls); |
187 | } |
188 | } |
189 | else { |
190 | my $c = ''; |
3e3baf6d |
191 | foreach $ls (@ls) { |
192 | next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; |
84902520 |
193 | print "\n ------ $cat_title{$ls->{category}} ------\n" |
194 | if $ls->{category} ne $c; |
08aa1457 |
195 | $c = $ls->{category}; |
3e3baf6d |
196 | unless ($::opt_i) { |
197 | list_files_by_patch($ls); |
198 | } |
199 | else { |
200 | my $out = $ls->{in}; |
201 | print "\n$out patched by:\n"; |
202 | # find all the patches which patch $out and list them |
203 | my @p = grep { $_->{out}->{$out} } values %ls; |
204 | foreach $ls (@p) { |
205 | list_files_by_patch($ls, ''); |
206 | } |
207 | } |
08aa1457 |
208 | } |
209 | print "\n"; |
210 | } |
211 | |
3e3baf6d |
212 | exit 0; |
213 | |
214 | |
215 | # --- |
216 | |
08aa1457 |
217 | |
218 | sub add_file { |
219 | my $ls = shift; |
220 | my $out = trim_name(shift); |
3e3baf6d |
221 | |
222 | $ls->{out}->{$out} = 1; |
223 | |
224 | # do the -i inverse as well, even if we're not doing -i |
225 | my $i = $ls{$out} ||= { |
226 | is_out => 1, |
227 | in => $out, |
228 | category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '', |
229 | }; |
230 | $i->{out}->{$in} = 1; |
08aa1457 |
231 | } |
232 | |
233 | |
234 | sub trim_name { # reduce/tidy file paths from diff lines |
235 | my $name = shift; |
236 | $name = "$name ($in)" if $name eq "/dev/null"; |
84902520 |
237 | $name =~ s:\\:/:g; # adjust windows paths |
238 | $name =~ s://:/:g; # simplify (and make win \\share into absolute path) |
08aa1457 |
239 | if (defined $::opt_p) { |
240 | # strip on -p levels of directory prefix |
241 | my $dc = $::opt_p; |
242 | $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0; |
243 | } |
244 | else { # try to strip off leading path to perl directory |
245 | # if absolute path, strip down to any *perl* directory first |
246 | $name =~ s:^/.*?perl.*?/::i; |
84902520 |
247 | $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i; |
08aa1457 |
248 | $name =~ s:^\./::; |
249 | } |
250 | return $name; |
251 | } |
252 | |
253 | |
254 | sub list_files_by_patch { |
3e3baf6d |
255 | my($ls, $name) = @_; |
256 | $name = $ls->{in} unless defined $name; |
08aa1457 |
257 | my @meta; |
258 | if ($::opt_m) { |
259 | foreach(qw(Title From Msg-ID)) { |
260 | next unless $ls->{$_}; |
261 | my @list = sort keys %{$ls->{$_}}; |
262 | push @meta, sprintf "%7s: ", $_; |
263 | @list = map { "\"$_\"" } @list if $_ eq 'Title'; |
264 | push @meta, my_wrap(""," ", join(", ",@list)."\n"); |
265 | } |
3e3baf6d |
266 | $name = "\n$name" if @meta and $name; |
08aa1457 |
267 | } |
268 | # don't print the header unless the file contains something interesting |
3e3baf6d |
269 | return if !@meta and !$ls->{out}; |
08aa1457 |
270 | print("$ls->{in}\n"),return if $::opt_l; # -l = no listing |
271 | |
3e3baf6d |
272 | # a twisty maze of little options |
273 | my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : ""; |
274 | print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat"; |
08aa1457 |
275 | print join('',"\n",@meta) if @meta; |
276 | |
3e3baf6d |
277 | my @v = sort PATORDER keys %{ $ls->{out} }; |
08aa1457 |
278 | my $v = "@v\n"; |
279 | print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v; |
280 | } |
281 | |
282 | |
283 | sub my_wrap { |
84902520 |
284 | my $txt = eval { expand(wrap(@_)) }; # die's on long lines! |
285 | return $txt unless $@; |
286 | return expand("@_"); |
08aa1457 |
287 | } |
288 | |
289 | |
290 | |
3e3baf6d |
291 | sub categorize_files { |
292 | my($files, $verb) = @_; |
08aa1457 |
293 | my(%c, $refine); |
3e3baf6d |
294 | |
295 | foreach (@$files) { # assign a score to a file path |
296 | # the order of some of the tests is important |
297 | $c{TEST} += 5,next if m:^t/:; |
298 | $c{DOC} += 5,next if m:^pod/:; |
299 | $c{UTIL} += 10,next if m:^(utils|x2p|h2pl)/:; |
84902520 |
300 | $c{PORT1}+= 15,next if m:^win32:; |
301 | $c{PORT2} += 15,next |
302 | if m:^(cygwin32|os2|plan9|qnx|vms)/: |
08aa1457 |
303 | or m:^(hints|Porting|ext/DynaLoader)/: |
304 | or m:^README\.:; |
3e3baf6d |
305 | $c{LIB} += 10,next |
08aa1457 |
306 | if m:^(lib|ext)/:; |
3e3baf6d |
307 | $c{'CORE'} += 15,next |
84902520 |
308 | if m:^[^/]+[\._]([chH]|sym|pl)$:; |
3e3baf6d |
309 | $c{BUILD} += 10,next |
08aa1457 |
310 | if m:^[A-Z]+$: or m:^[^/]+\.SH$: |
84902520 |
311 | or m:^(install|configure|configpm):i; |
08aa1457 |
312 | print "Couldn't categorise $_\n" if $::opt_v; |
3e3baf6d |
313 | $c{OTHER} += 1; |
314 | } |
315 | if (keys %c > 1) { # sort to find category with highest score |
316 | refine: |
317 | ++$refine; |
318 | my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c; |
319 | my @v = map { $c{$_} } @c; |
320 | if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/ |
321 | and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare |
322 | print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d; |
323 | ++$c{$c[1]}; |
324 | goto refine; |
325 | } |
326 | print " ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n" |
327 | if $verb; |
328 | return $c[0] || 'OTHER'; |
08aa1457 |
329 | } |
3e3baf6d |
330 | else { |
331 | my($c, $v) = %c; |
332 | $c ||= 'OTHER'; $v ||= 0; |
333 | print " ".@$files." patches: $c: $v\n" if $verb; |
334 | return $c; |
08aa1457 |
335 | } |
08aa1457 |
336 | } |
337 | |
338 | |
339 | sub PATORDER { # PATORDER sort by Chip Salzenberg |
340 | my ($i, $j); |
341 | |
342 | $i = ($a =~ m#^[A-Z]+$#); |
343 | $j = ($b =~ m#^[A-Z]+$#); |
344 | return $j - $i if $i != $j; |
345 | |
346 | $i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#); |
347 | $j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#); |
348 | return $j - $i if $i != $j; |
349 | |
350 | $i = ($a =~ m#\.pod$#); |
351 | $j = ($b =~ m#\.pod$#); |
352 | return $j - $i if $i != $j; |
353 | |
354 | $i = ($a =~ m#include/#); |
355 | $j = ($b =~ m#include/#); |
356 | return $j - $i if $i != $j; |
357 | |
358 | if ((($i = $a) =~ s#/+[^/]*$##) |
359 | && (($j = $b) =~ s#/+[^/]*$##)) { |
360 | return $i cmp $j if $i ne $j; |
361 | } |
362 | |
363 | $i = ($a =~ m#\.h$#); |
364 | $j = ($b =~ m#\.h$#); |
365 | return $j - $i if $i != $j; |
366 | |
367 | return $a cmp $b; |
368 | } |
369 | |