Porting/patchls

   1 #!/bin/perl -w
   2 #
   3 # Originally from Tom Horsley. Generally hacked and extended by Tim Bunce.
   4 #
   5 # Input is one or more patchfiles, output is a list of files to be patched.
   6 #
   7 # $Id: patchls,v 1.3 1997/06/10 21:38:45 timbo Exp $
   8
   9 require "getopts.pl";
  10
  11 use Text::Wrap qw(wrap $columns);
  12 use Text::Tabs qw(expand unexpand);
  13 use strict;
  14
  15 $columns = 70;
  16
  17 $::opt_p = undef;       # like patch -pN, strip off N dir levels from file names
  18 $::opt_d = 0;
  19 $::opt_v = 0;
  20 $::opt_m = 0;
  21 $::opt_i = 0;
  22 $::opt_h = 0;
  23 $::opt_l = 0;
  24 $::opt_c = 0;
  25
  26 die qq{
  27
  28   patchls [options] patchfile [ ... ]
  29
  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     -i     Invert: for each patched file list which patch files patch it
  33     -h     no filename headers (like grep), only the listing
  34     -l     no listing (like grep), only the filename headers
  35     -c     attempt to Categorise the patch (sort by category with -m)
  36     -v     more verbose
  37     -d     still more verbosity for debugging
  38
  39 } unless @ARGV;
  40
  41 &Getopts("mihlvcp:");
  42
  43 my %ls;
  44
  45 # Style 1:
  46 #       *** perl-5.004/embed.h  Sat May 10 03:39:32 1997
  47 #       --- perl-5.004.fixed/embed.h    Thu May 29 19:48:46 1997
  48 #       ***************
  49 #       *** 308,313 ****
  50 #       --- 308,314 ----
  51 #
  52 # Style 2:
  53 #       --- perl5.004001/mg.c   Sun Jun 08 12:26:24 1997
  54 #       +++ perl5.004-bc/mg.c   Sun Jun 08 11:56:08 1997
  55 #       @@ -656,9 +656,27 @@
  56 # or (rcs, note the different date format)
  57 #       --- 1.18        1997/05/23 19:22:04
  58 #       +++ ./pod/perlembed.pod 1997/06/03 21:41:38
  59 #
  60 # Variation:
  61 #       Index: embed.h
  62
  63 my($in, $prevline, $prevtype, $ls);
  64
  65 foreach my $argv (@ARGV) {
  66     $in = $argv;
  67     unless (open F, "<$in") {
  68         warn "Unable to open $in: $!\n";
  69         next;
  70     }
  71     print "Reading $in...\n" if $::opt_v and @ARGV > 1;
  72     $ls = $ls{$in} ||= { in => $in };
  73     my $type;
  74     while (<F>) {
  75         unless (/^([-+*]{3}) / || /^(Index):/) {
  76             # not an interesting patch line but possibly meta-information
  77             next unless $::opt_m;
  78             $ls->{From}{$1}=1       if /^From: (.*\S)/i;
  79             $ls->{Title}{$1}=1      if /^Subject: (?:Re: )?(.*\S)/i;
  80             $ls->{'Msg-ID'}{$1}=1   if /^Message-Id: (.*\S)/i;
  81             $ls->{Date}{$1}=1       if /^Date: (.*\S)/i;
  82             next;
  83         }
  84         $type = $1;
  85         next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
  86
  87         print "Last: $prevline","This: ${_}Got:  $1\n\n" if $::opt_d;
  88
  89         # Some patches have Index lines but not diff headers
  90         # Patch copes with this, so must we
  91         add_file($ls, $1), next if /^Index:\s+(.*)/;
  92
  93         if (    ($type eq '---' and $prevtype eq '***') # Style 1
  94             or  ($type eq '+++' and $prevtype eq '---') # Style 2
  95         ) {
  96             if (/^[-+*]{3} (\S+)\s+.*\d\d:\d\d:\d\d/) { # double check
  97                 add_file($ls, $1);
  98             }
  99             else {
 100                 warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
 101             }
 102         }
 103     }
 104     continue {
 105         $prevline = $_;
 106         $prevtype = $type;
 107         $type = '';
 108     }
 109     $ls->{Title}{$in}=1 if !$ls->{Title} and $::opt_m and $::opt_c
 110                                 and $ls->{files_by_patch};
 111     $ls->{category} = intuit_category($ls, $::opt_v) if $::opt_c;
 112 }
 113 print "All files read.\n" if $::opt_v and @ARGV > 1;
 114
 115 unless ($::opt_c and $::opt_m) {
 116     foreach $in (sort keys %ls) {
 117         $ls = $ls{$in};
 118         list_files_by_patch($ls);
 119     }
 120 }
 121 else {
 122     my $c = '';
 123     foreach $ls (sort { $a->{category} cmp $b->{category} } values %ls) {
 124         print "\n  $ls->{category}\n" if $ls->{category} ne $c;
 125         $c = $ls->{category};
 126         list_files_by_patch($ls);
 127     }
 128     print "\n";
 129 }
 130
 131
 132 sub add_file {
 133     my $ls = shift;
 134     my $out = trim_name(shift);
 135     ($ls, $out) = ($ls{$out} ||= { in => $out }, $in) if $::opt_i;
 136     $ls->{files_by_patch}->{$out} = 1;
 137 }
 138
 139
 140 sub trim_name {         # reduce/tidy file paths from diff lines
 141     my $name = shift;
 142     $name = "$name ($in)" if $name eq "/dev/null";
 143     if (defined $::opt_p) {
 144         # strip on -p levels of directory prefix
 145         my $dc = $::opt_p;
 146         $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
 147     }
 148     else {      # try to strip off leading path to perl directory
 149         # if absolute path, strip down to any *perl* directory first
 150         $name =~ s:^/.*?perl.*?/::i;
 151         $name =~ s:.*perl[-_]?5\.[-_a-z0-9.]+/::i;
 152         $name =~ s:^\./::;
 153     }
 154     return $name;
 155 }
 156
 157
 158 sub list_files_by_patch {
 159     my $ls = shift;
 160     my $name = $ls->{in};
 161     my @meta;
 162     if ($::opt_m) {
 163         foreach(qw(Title From Msg-ID)) {
 164             next unless $ls->{$_};
 165             my @list = sort keys %{$ls->{$_}};
 166             push @meta, sprintf "%7s:  ", $_;
 167             @list = map { "\"$_\"" } @list if $_ eq 'Title';
 168             push @meta, my_wrap("","          ", join(", ",@list)."\n");
 169         }
 170         $name = "\n$name" if @meta;
 171     }
 172     # don't print the header unless the file contains something interesting
 173     return if !@meta and !$ls->{files_by_patch};
 174     print("$ls->{in}\n"),return  if $::opt_l;   # -l = no listing
 175
 176         # a twisty maze of little options
 177     my $cat = ($ls->{category} and !$::opt_m) ? " $ls->{category}" : "";
 178     print "$name$cat: " unless $::opt_h and !$::opt_v;
 179     print join('',"\n",@meta) if @meta;
 180
 181     my @v = sort PATORDER keys %{ $ls->{files_by_patch} };
 182     my $v = "@v\n";
 183     print $::opt_m ? "  Files:  ".my_wrap("","          ",$v) : $v;
 184 }
 185
 186
 187 sub my_wrap {
 188     return expand(wrap(@_));
 189 }
 190
 191
 192
 193 # CORE LANGUAGE CHANGES
 194 # CORE PORTABILITY
 195 # OTHER CORE CHANGES
 196 # BUILD PROCESS
 197 # LIBRARY AND EXTENSIONS
 198 # TESTS
 199 # UTILITIES
 200 # DOCUMENTATION
 201
 202 sub intuit_category {
 203     my($ls, $verb) = @_;
 204     return 'OTHER' unless $ls->{files_by_patch};
 205     my(%c, $refine);
 206     foreach (keys %{ $ls->{files_by_patch} }) {
 207         ++$c{'DOCUMENTATION'},next
 208             if m:^pod/:;
 209         ++$c{'UTILITIES'},next
 210             if m:^(utils|x2p|h2pl)/:;
 211         ++$c{'PORTABILITY'},next
 212             if m:^(cygwin32|os2|plan9|qnx|vms|win32)/:
 213             or m:^(hints|Porting|ext/DynaLoader)/:
 214             or m:^README\.:;
 215         ++$c{'LIBRARY AND EXTENSIONS'},next
 216             if m:^(lib|ext)/:;
 217         ++$c{'TESTS'},next
 218             if m:^t/:;
 219         ++$c{'CORE LANGUAGE'},next
 220             if m:^[^/]+\.([chH]|sym)$:;
 221         ++$c{'BUILD PROCESS'},next
 222             if m:^[A-Z]+$: or m:^[^/]+\.SH$:
 223             or m:^(install|configure):i;
 224         print "Couldn't categorise $_\n" if $::opt_v;
 225         ++$c{OTHER};
 226     }
 227 refine:
 228     ++$refine;
 229     my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
 230     my @v = map  { $c{$_} } @c;
 231     if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
 232             and $c[0] =~ m/^(DOC|TESTS|OTHER)/) {
 233         print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
 234         ++$c{$c[1]};
 235         goto refine;
 236     }
 237     print "  ", join(", ", map { "$_: $c{$_}" } @c),".\n"
 238         if $verb and @v > 1;
 239     return $c[0];
 240 }
 241
 242
 243 sub PATORDER {          # PATORDER sort by Chip Salzenberg
 244     my ($i, $j);
 245
 246     $i = ($a =~ m#^[A-Z]+$#);
 247     $j = ($b =~ m#^[A-Z]+$#);
 248     return $j - $i if $i != $j;
 249
 250     $i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
 251     $j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
 252     return $j - $i if $i != $j;
 253
 254     $i = ($a =~ m#\.pod$#);
 255     $j = ($b =~ m#\.pod$#);
 256     return $j - $i if $i != $j;
 257
 258     $i = ($a =~ m#include/#);
 259     $j = ($b =~ m#include/#);
 260     return $j - $i if $i != $j;
 261
 262     if ((($i = $a) =~ s#/+[^/]*$##)
 263         && (($j = $b) =~ s#/+[^/]*$##)) {
 264             return $i cmp $j if $i ne $j;
 265     }
 266
 267     $i = ($a =~ m#\.h$#);
 268     $j = ($b =~ m#\.h$#);
 269     return $j - $i if $i != $j;
 270
 271     return $a cmp $b;
 272 }
 273