3 # patchls - patch listing utility
5 # Input is one or more patchfiles, output is a list of files to be patched.
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.
11 # With thanks to Tom Horsley for the seed code.
15 use Text::Wrap qw(wrap $columns);
16 use Text::Tabs qw(expand unexpand);
18 use vars qw($VERSION);
24 patchls [options] patchfile [ ... ]
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)
43 $::opt_p = undef; # undef != 0
53 # special purpose options
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)
61 getopts("mihlvc4p:f:IM:W:") or usage;
63 $columns = $::opt_W || 9999999;
65 $::opt_m = 1 if $::opt_M;
66 my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID');
69 'BUILD' => 'BUILD PROCESS',
70 'CORE' => 'CORE LANGUAGE',
71 'DOC' => 'DOCUMENTATION',
72 'LIB' => 'LIBRARY AND EXTENSIONS',
73 'PORT1' => 'PORTABILITY - WIN32',
74 'PORT2' => 'PORTABILITY - GENERAL',
76 'UTIL' => 'UTILITIES',
77 'OTHER' => 'OTHER CHANGES',
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
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
100 my($in, $prevline, $prevtype, $ls);
101 my(@removed, @added);
102 my $prologue = 1; # assume prologue till patch or /^exit\b/ seen
104 foreach my $argv (@ARGV) {
106 unless (open F, "<$in") {
107 warn "Unable to open $in: $!\n";
110 print "Reading $in...\n" if $::opt_v and @ARGV > 1;
111 $ls = $ls{$in} ||= { is_in => 1, in => $in };
114 unless (/^([-+*]{3}) / || /^(Index):/) {
115 # not an interesting patch line
116 # but possibly meta-information or 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/;
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)/;
131 next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
134 print "Last: $prevline","This: ${_}Got: $1\n\n" if $::opt_d;
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+)/;
142 if ( ($type eq '---' and $prevtype eq '***') # Style 1
143 or ($type eq '+++' and $prevtype eq '---') # Style 2
145 if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check
149 warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
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};
162 $ls->{category} = $::opt_c
163 ? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
165 print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
168 # --- Firstly we filter and sort as needed ---
172 if ($::opt_f) { # filter out patches based on -f <regexp>
174 $::opt_f .= '$' unless $::opt_f =~ m:/:;
176 my @out = keys %{$_->{out}};
179 ++$match if $out =~ m/$::opt_f/o;
186 $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
190 # --- Handle special modes ---
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;
208 next unless $in->{is_in};
210 my @outs = keys %{$in->{out}};
211 @all_out{@outs} = ($in->{in}) x @outs;
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};
224 print "Added files: @added\n" if @added;
225 print "Removed files: @removed\n" if @removed;
229 unless ($::opt_c and $::opt_m) {
231 next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
232 list_files_by_patch($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};
243 list_files_by_patch($ls);
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;
251 list_files_by_patch($ls, '');
266 my $out = trim_name(shift);
268 $ls->{out}->{$out} = 1;
270 # do the -i inverse as well, even if we're not doing -i
271 my $i = $ls{$out} ||= {
274 category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
276 $i->{out}->{$in} = 1;
280 sub trim_name { # reduce/tidy file paths from diff lines
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
288 $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
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;
300 sub list_files_by_patch {
302 $name = $ls->{in} unless defined $name;
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
313 elsif ($meta eq 'From') {
314 # fix-up bizzare addresses from japan and ibm :-)
317 s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//;
320 elsif ($meta eq 'Msg-ID') {
321 my %from; # limit long threads to one msg-id per site
323 $from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_);
326 push @meta, my_wrap(""," ", join(", ",@list)."\n");
328 $name = "\n$name" if @meta and $name;
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
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;
339 my @v = sort PATORDER keys %{ $ls->{out} };
341 print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v;
346 my $txt = eval { expand(wrap(@_)) }; # die's on long lines!
347 return $txt unless $@;
353 sub categorize_files {
354 my($files, $verb) = @_;
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:;
364 if m:^(cygwin32|os2|plan9|qnx|vms)/:
365 or m:^(hints|Porting|ext/DynaLoader)/:
369 $c{'CORE'} += 15,next
370 if m:^[^/]+[\._]([chH]|sym|pl)$:;
372 if m:^[A-Z]+$: or m:^[^/]+\.SH$:
373 or m:^(install|configure|configpm):i;
374 print "Couldn't categorise $_\n" if $::opt_v;
377 if (keys %c > 1) { # sort to find category with highest score
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;
388 print " ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
390 return $c[0] || 'OTHER';
394 $c ||= 'OTHER'; $v ||= 0;
395 print " ".@$files." patches: $c: $v\n" if $verb;
401 sub PATORDER { # PATORDER sort by Chip Salzenberg
404 $i = ($a =~ m#^[A-Z]+$#);
405 $j = ($b =~ m#^[A-Z]+$#);
406 return $j - $i if $i != $j;
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;
412 $i = ($a =~ m#\.pod$#);
413 $j = ($b =~ m#\.pod$#);
414 return $j - $i if $i != $j;
416 $i = ($a =~ m#include/#);
417 $j = ($b =~ m#include/#);
418 return $j - $i if $i != $j;
420 if ((($i = $a) =~ s#/+[^/]*$##)
421 && (($j = $b) =~ s#/+[^/]*$##)) {
422 return $i cmp $j if $i ne $j;
425 $i = ($a =~ m#\.h$#);
426 $j = ($b =~ m#\.h$#);
427 return $j - $i if $i != $j;