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. |
fb73857a |
12 | |
08aa1457 |
13 | |
3e3baf6d |
14 | use Getopt::Std; |
08aa1457 |
15 | use Text::Wrap qw(wrap $columns); |
16 | use Text::Tabs qw(expand unexpand); |
17 | use strict; |
fb73857a |
18 | use vars qw($VERSION); |
19 | |
20 | $VERSION = 2.04; |
08aa1457 |
21 | |
3e3baf6d |
22 | sub usage { |
84902520 |
23 | die q{ |
3e3baf6d |
24 | patchls [options] patchfile [ ... ] |
25 | |
84902520 |
26 | -h no filename headers (like grep), only the listing. |
27 | -l no listing (like grep), only the filename headers. |
fb73857a |
28 | -i Invert: for each patched file list which patch files patch it. |
84902520 |
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 /). |
fb73857a |
35 | other options for special uses: |
84902520 |
36 | -I just gather and display summary Information about the patches. |
fb73857a |
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) |
3e3baf6d |
40 | } |
41 | } |
42 | |
3e3baf6d |
43 | $::opt_p = undef; # undef != 0 |
08aa1457 |
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; |
84902520 |
51 | $::opt_f = ''; |
fb73857a |
52 | |
53 | # special purpose options |
84902520 |
54 | $::opt_I = 0; |
fb73857a |
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) |
08aa1457 |
58 | |
3e3baf6d |
59 | usage unless @ARGV; |
08aa1457 |
60 | |
fb73857a |
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'); |
08aa1457 |
67 | |
3e3baf6d |
68 | my %cat_title = ( |
84902520 |
69 | 'BUILD' => 'BUILD PROCESS', |
70 | 'CORE' => 'CORE LANGUAGE', |
3e3baf6d |
71 | 'DOC' => 'DOCUMENTATION', |
3e3baf6d |
72 | 'LIB' => 'LIBRARY AND EXTENSIONS', |
84902520 |
73 | 'PORT1' => 'PORTABILITY - WIN32', |
fb73857a |
74 | 'PORT2' => 'PORTABILITY - GENERAL', |
84902520 |
75 | 'TEST' => 'TESTS', |
76 | 'UTIL' => 'UTILITIES', |
77 | 'OTHER' => 'OTHER CHANGES', |
3e3baf6d |
78 | ); |
08aa1457 |
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); |
fb73857a |
101 | my(@removed, @added); |
102 | my $prologue = 1; # assume prologue till patch or /^exit\b/ seen |
08aa1457 |
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; |
3e3baf6d |
111 | $ls = $ls{$in} ||= { is_in => 1, in => $in }; |
08aa1457 |
112 | my $type; |
113 | while (<F>) { |
114 | unless (/^([-+*]{3}) / || /^(Index):/) { |
fb73857a |
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 | } |
08aa1457 |
122 | next unless $::opt_m; |
fb73857a |
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)/; |
08aa1457 |
128 | next; |
129 | } |
130 | $type = $1; |
131 | next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/; |
fb73857a |
132 | $prologue = 0; |
08aa1457 |
133 | |
134 | print "Last: $prevline","This: ${_}Got: $1\n\n" if $::opt_d; |
135 | |
136 | # Some patches have Index lines but not diff headers |
3e3baf6d |
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. |
fb73857a |
140 | add_file($ls, $1), next if /^Index:\s+(\S+)/; |
08aa1457 |
141 | |
142 | if ( ($type eq '---' and $prevtype eq '***') # Style 1 |
143 | or ($type eq '+++' and $prevtype eq '---') # Style 2 |
144 | ) { |
fb73857a |
145 | if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check |
08aa1457 |
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 | } |
3e3baf6d |
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) : ''; |
08aa1457 |
164 | } |
3e3baf6d |
165 | print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1; |
166 | |
167 | |
fb73857a |
168 | # --- Firstly we filter and sort as needed --- |
169 | |
170 | my @ls = values %ls; |
08aa1457 |
171 | |
84902520 |
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 | |
fb73857a |
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 | |
84902520 |
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"; |
fb73857a |
216 | print "(use -v to list patches which patch 'missing' files)\n" |
217 | if @missing && !$::opt_v; |
84902520 |
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 | } |
fb73857a |
224 | print "Added files: @added\n" if @added; |
225 | print "Removed files: @removed\n" if @removed; |
84902520 |
226 | exit 0+@missing; |
227 | } |
228 | |
08aa1457 |
229 | unless ($::opt_c and $::opt_m) { |
3e3baf6d |
230 | foreach $ls (@ls) { |
231 | next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; |
08aa1457 |
232 | list_files_by_patch($ls); |
233 | } |
234 | } |
235 | else { |
236 | my $c = ''; |
3e3baf6d |
237 | foreach $ls (@ls) { |
238 | next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in}; |
84902520 |
239 | print "\n ------ $cat_title{$ls->{category}} ------\n" |
240 | if $ls->{category} ne $c; |
08aa1457 |
241 | $c = $ls->{category}; |
3e3baf6d |
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 | } |
08aa1457 |
254 | } |
255 | print "\n"; |
256 | } |
257 | |
3e3baf6d |
258 | exit 0; |
259 | |
260 | |
261 | # --- |
262 | |
08aa1457 |
263 | |
264 | sub add_file { |
265 | my $ls = shift; |
266 | my $out = trim_name(shift); |
3e3baf6d |
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; |
08aa1457 |
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"; |
84902520 |
283 | $name =~ s:\\:/:g; # adjust windows paths |
284 | $name =~ s://:/:g; # simplify (and make win \\share into absolute path) |
08aa1457 |
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; |
84902520 |
293 | $name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i; |
08aa1457 |
294 | $name =~ s:^\./::; |
295 | } |
296 | return $name; |
297 | } |
298 | |
299 | |
300 | sub list_files_by_patch { |
3e3baf6d |
301 | my($ls, $name) = @_; |
302 | $name = $ls->{in} unless defined $name; |
08aa1457 |
303 | my @meta; |
304 | if ($::opt_m) { |
fb73857a |
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 | } |
08aa1457 |
326 | push @meta, my_wrap(""," ", join(", ",@list)."\n"); |
327 | } |
3e3baf6d |
328 | $name = "\n$name" if @meta and $name; |
08aa1457 |
329 | } |
330 | # don't print the header unless the file contains something interesting |
3e3baf6d |
331 | return if !@meta and !$ls->{out}; |
08aa1457 |
332 | print("$ls->{in}\n"),return if $::opt_l; # -l = no listing |
333 | |
3e3baf6d |
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"; |
08aa1457 |
337 | print join('',"\n",@meta) if @meta; |
338 | |
3e3baf6d |
339 | my @v = sort PATORDER keys %{ $ls->{out} }; |
08aa1457 |
340 | my $v = "@v\n"; |
341 | print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v; |
342 | } |
343 | |
344 | |
345 | sub my_wrap { |
84902520 |
346 | my $txt = eval { expand(wrap(@_)) }; # die's on long lines! |
347 | return $txt unless $@; |
348 | return expand("@_"); |
08aa1457 |
349 | } |
350 | |
351 | |
352 | |
3e3baf6d |
353 | sub categorize_files { |
354 | my($files, $verb) = @_; |
08aa1457 |
355 | my(%c, $refine); |
3e3baf6d |
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)/:; |
84902520 |
362 | $c{PORT1}+= 15,next if m:^win32:; |
363 | $c{PORT2} += 15,next |
364 | if m:^(cygwin32|os2|plan9|qnx|vms)/: |
08aa1457 |
365 | or m:^(hints|Porting|ext/DynaLoader)/: |
366 | or m:^README\.:; |
3e3baf6d |
367 | $c{LIB} += 10,next |
08aa1457 |
368 | if m:^(lib|ext)/:; |
3e3baf6d |
369 | $c{'CORE'} += 15,next |
84902520 |
370 | if m:^[^/]+[\._]([chH]|sym|pl)$:; |
3e3baf6d |
371 | $c{BUILD} += 10,next |
08aa1457 |
372 | if m:^[A-Z]+$: or m:^[^/]+\.SH$: |
84902520 |
373 | or m:^(install|configure|configpm):i; |
08aa1457 |
374 | print "Couldn't categorise $_\n" if $::opt_v; |
3e3baf6d |
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'; |
08aa1457 |
391 | } |
3e3baf6d |
392 | else { |
393 | my($c, $v) = %c; |
394 | $c ||= 'OTHER'; $v ||= 0; |
395 | print " ".@$files." patches: $c: $v\n" if $verb; |
396 | return $c; |
08aa1457 |
397 | } |
08aa1457 |
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 | |