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 14use Getopt::Std; 15use Text::Wrap qw(wrap $columns); 16use Text::Tabs qw(expand unexpand); 17use strict; 18use vars qw($VERSION); 19 20$VERSION = 2.11; 21 22sub usage { 23die 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 72usage unless @ARGV; 73 74getopts("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() 83my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID Files'); 84my %show_meta = map { ($_,1) } @show_meta; 85 86my %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 101sub 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 147my %ls; 148 149my $in; 150my $ls; 151my $prevline = ''; 152my $prevtype = ''; 153my (%removed, %added); 154my $prologue = 1; # assume prologue till patch or /^exit\b/ seen 155 156 157foreach 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} 252print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1; 253 254 255# --- Firstly we filter and sort as needed --- 256 257my @ls = values %ls; 258 259if ($::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 281if ($::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 302if ($::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 339unless ($::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} 346else { 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 369exit 0; 370 371 372# --- 373 374 375sub 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 396sub 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 406sub 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 428sub 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 486sub my_wrap { 487 my $txt = eval { expand(wrap(@_)) }; # die's on long lines! 488 return $txt unless $@; 489 return expand("@_"); 490} 491 492 493 494sub 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 544sub 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 575