540 lines
15 KiB
Plaintext
540 lines
15 KiB
Plaintext
|
#!/bin/perl -w
|
||
|
|
#
|
||
|
|
# patchls - patch listing utility
|
||
|
|
#
|
||
|
|
# Input is one or more patchfiles, output is a list of files to be patched.
|
||
|
|
#
|
||
|
|
# Copyright (c) 1997 Tim Bunce. All rights reserved.
|
||
|
|
# This program is free software; you can redistribute it and/or
|
||
|
|
# modify it under the same terms as Perl itself.
|
||
|
|
#
|
||
|
|
# With thanks to Tom Horsley for the seed code.
|
||
|
|
|
||
|
|
|
||
|
|
use Getopt::Std;
|
||
|
|
use Text::Wrap qw(wrap $columns);
|
||
|
|
use Text::Tabs qw(expand unexpand);
|
||
|
|
use strict;
|
||
|
|
use vars qw($VERSION);
|
||
|
|
|
||
|
|
$VERSION = 2.08;
|
||
|
|
|
||
|
|
sub usage {
|
||
|
|
die qq{
|
||
|
|
patchls [options] patchfile [ ... ]
|
||
|
|
|
||
|
|
-h no filename headers (like grep), only the listing.
|
||
|
|
-l no listing (like grep), only the filename headers.
|
||
|
|
-i Invert: for each patched file list which patch files patch it.
|
||
|
|
-c Categorise the patch and sort by category (perl specific).
|
||
|
|
-m print formatted Meta-information (Subject,From,Msg-ID etc).
|
||
|
|
-p N strip N levels of directory Prefix (like patch), else automatic.
|
||
|
|
-v more verbose (-d for noisy debugging).
|
||
|
|
-n give a count of the number of patches applied to a file if >1.
|
||
|
|
-f F only list patches which patch files matching regexp F
|
||
|
|
(F has \$ appended unless it contains a /).
|
||
|
|
-e Expect patched files to Exist (relative to current directory)
|
||
|
|
Will print warnings for files which don't. Also affects -4 option.
|
||
|
|
other options for special uses:
|
||
|
|
-I just gather and display summary Information about the patches.
|
||
|
|
-4 write to stdout the PerForce commands to prepare for patching.
|
||
|
|
-5 like -4 but add "|| exit 1" after each command
|
||
|
|
-M T Like -m but only output listed meta tags (eg -M 'Title From')
|
||
|
|
-W N set wrap width to N (defaults to 70, use 0 for no wrap)
|
||
|
|
-X list patchfiles that may clash (i.e. patch the same file)
|
||
|
|
|
||
|
|
patchls version $VERSION by Tim Bunce
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$::opt_p = undef; # undef != 0
|
||
|
|
$::opt_d = 0;
|
||
|
|
$::opt_v = 0;
|
||
|
|
$::opt_m = 0;
|
||
|
|
$::opt_n = 0;
|
||
|
|
$::opt_i = 0;
|
||
|
|
$::opt_h = 0;
|
||
|
|
$::opt_l = 0;
|
||
|
|
$::opt_c = 0;
|
||
|
|
$::opt_f = '';
|
||
|
|
$::opt_e = 0;
|
||
|
|
|
||
|
|
# special purpose options
|
||
|
|
$::opt_I = 0;
|
||
|
|
$::opt_4 = 0; # output PerForce commands to prepare for patching
|
||
|
|
$::opt_5 = 0;
|
||
|
|
$::opt_M = ''; # like -m but only output these meta items (-M Title)
|
||
|
|
$::opt_W = 70; # set wrap width columns (see Text::Wrap module)
|
||
|
|
$::opt_C = 0; # 'Chip' mode (handle from/tags/article/bug files) undocumented
|
||
|
|
$::opt_X = 0; # list patchfiles that patch the same file
|
||
|
|
|
||
|
|
usage unless @ARGV;
|
||
|
|
|
||
|
|
getopts("dmnihlvecC45Xp:f:IM:W:") or usage;
|
||
|
|
|
||
|
|
$columns = $::opt_W || 9999999;
|
||
|
|
|
||
|
|
$::opt_m = 1 if $::opt_M;
|
||
|
|
$::opt_4 = 1 if $::opt_5;
|
||
|
|
$::opt_i = 1 if $::opt_X;
|
||
|
|
|
||
|
|
# see get_meta_info()
|
||
|
|
my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID Files');
|
||
|
|
my %show_meta = map { ($_,1) } @show_meta;
|
||
|
|
|
||
|
|
my %cat_title = (
|
||
|
|
'BUILD' => 'BUILD PROCESS',
|
||
|
|
'CORE' => 'CORE LANGUAGE',
|
||
|
|
'DOC' => 'DOCUMENTATION',
|
||
|
|
'LIB' => 'LIBRARY',
|
||
|
|
'PORT1' => 'PORTABILITY - WIN32',
|
||
|
|
'PORT2' => 'PORTABILITY - GENERAL',
|
||
|
|
'TEST' => 'TESTS',
|
||
|
|
'UTIL' => 'UTILITIES',
|
||
|
|
'OTHER' => 'OTHER CHANGES',
|
||
|
|
'EXT' => 'EXTENSIONS',
|
||
|
|
'UNKNOWN' => 'UNKNOWN - NO FILES PATCH',
|
||
|
|
);
|
||
|
|
|
||
|
|
|
||
|
|
sub get_meta_info {
|
||
|
|
my $ls = shift;
|
||
|
|
local($_) = shift;
|
||
|
|
if (/^From:\s+(.*\S)/i) {;
|
||
|
|
my $from = $1; # temporary measure for Chip Salzenberg
|
||
|
|
$from =~ s/chip\@(atlantic\.net|perlsupport\.com)/chip\@pobox.com/;
|
||
|
|
$from =~ s/\(Tim Bunce\) \(Tim Bunce\)/(Tim Bunce)/;
|
||
|
|
$ls->{From}{$from} = 1
|
||
|
|
}
|
||
|
|
if (/^Subject:\s+(?:Re: )?(.*\S)/i) {
|
||
|
|
my $title = $1;
|
||
|
|
$title =~ s/\[(PATCH|PERL)[\w\. ]*\]:?//g;
|
||
|
|
$title =~ s/\b(PATCH|PERL)[\w\.]*://g;
|
||
|
|
$title =~ s/\bRe:\s+/ /g;
|
||
|
|
$title =~ s/\s+/ /g;
|
||
|
|
$title =~ s/^\s*(.*?)\s*$/$1/g;
|
||
|
|
$ls->{Title}{$title} = 1;
|
||
|
|
}
|
||
|
|
$ls->{'Msg-ID'}{$1}=1 if /^Message-Id:\s+(.*\S)/i;
|
||
|
|
$ls->{Date}{$1}=1 if /^Date:\s+(.*\S)/i;
|
||
|
|
$ls->{$1}{$2}=1 if $::opt_M && /^([-\w]+):\s+(.*\S)/;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Style 1:
|
||
|
|
# *** perl-5.004/embed.h Sat May 10 03:39:32 1997
|
||
|
|
# --- perl-5.004.fixed/embed.h Thu May 29 19:48:46 1997
|
||
|
|
# ***************
|
||
|
|
# *** 308,313 ****
|
||
|
|
# --- 308,314 ----
|
||
|
|
#
|
||
|
|
# Style 2:
|
||
|
|
# --- perl5.004001/mg.c Sun Jun 08 12:26:24 1997
|
||
|
|
# +++ perl5.004-bc/mg.c Sun Jun 08 11:56:08 1997
|
||
|
|
# @@ -656,9 +656,27 @@
|
||
|
|
# or (rcs, note the different date format)
|
||
|
|
# --- 1.18 1997/05/23 19:22:04
|
||
|
|
# +++ ./pod/perlembed.pod 1997/06/03 21:41:38
|
||
|
|
#
|
||
|
|
# Variation:
|
||
|
|
# Index: embed.h
|
||
|
|
|
||
|
|
my %ls;
|
||
|
|
|
||
|
|
my $in;
|
||
|
|
my $ls;
|
||
|
|
my $prevline = '';
|
||
|
|
my $prevtype = '';
|
||
|
|
my (@removed, @added);
|
||
|
|
my $prologue = 1; # assume prologue till patch or /^exit\b/ seen
|
||
|
|
|
||
|
|
|
||
|
|
foreach my $argv (@ARGV) {
|
||
|
|
$in = $argv;
|
||
|
|
unless (open F, "<$in") {
|
||
|
|
warn "Unable to open $in: $!\n";
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
print "Reading $in...\n" if $::opt_v and @ARGV > 1;
|
||
|
|
$ls = $ls{$in} ||= { is_in => 1, in => $in };
|
||
|
|
my $type;
|
||
|
|
while (<F>) {
|
||
|
|
unless (/^([-+*]{3}) / || /^(Index):/) {
|
||
|
|
# not an interesting patch line
|
||
|
|
# but possibly meta-information or prologue
|
||
|
|
if ($prologue) {
|
||
|
|
push @added, $1 if /^touch\s+(\S+)/;
|
||
|
|
push @removed, $1 if /^rm\s+(?:-f)?\s*(\S+)/;
|
||
|
|
$prologue = 0 if /^exit\b/;
|
||
|
|
}
|
||
|
|
get_meta_info($ls, $_) if $::opt_m;
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
$type = $1;
|
||
|
|
next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
|
||
|
|
$prologue = 0;
|
||
|
|
|
||
|
|
print "Last: $prevline","This: ${_}Got: $type\n\n" if $::opt_d;
|
||
|
|
|
||
|
|
# Some patches have Index lines but not diff headers
|
||
|
|
# Patch copes with this, so must we. It's also handy for
|
||
|
|
# documenting manual changes by simply adding Index: lines
|
||
|
|
# to the file which describes the problem being fixed.
|
||
|
|
if (/^Index:\s+(.*)/) {
|
||
|
|
my $f;
|
||
|
|
foreach $f (split(/ /, $1)) { add_file($ls, $f) }
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ($type eq '---' and $prevtype eq '***') # Style 1
|
||
|
|
or ($type eq '+++' and $prevtype eq '---') # Style 2
|
||
|
|
) {
|
||
|
|
if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check
|
||
|
|
add_file($ls, $1);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
continue {
|
||
|
|
$prevline = $_;
|
||
|
|
$prevtype = $type || '';
|
||
|
|
$type = '';
|
||
|
|
}
|
||
|
|
|
||
|
|
# special mode for patch sets from Chip
|
||
|
|
if ($in =~ m:[\\/]patch$:) {
|
||
|
|
my $is_chip;
|
||
|
|
my $chip;
|
||
|
|
my $dir; ($dir = $in) =~ s:[\\/]patch$::;
|
||
|
|
if (!$ls->{From} && (open(CHIP,"$dir/article") || open(CHIP,"$dir/bug"))) {
|
||
|
|
get_meta_info($ls, $_) while (<CHIP>);
|
||
|
|
$is_chip = 1;
|
||
|
|
}
|
||
|
|
if (open CHIP,"<$dir/from") {
|
||
|
|
chop($chip = <CHIP>);
|
||
|
|
$ls->{From} = { $chip => 1 };
|
||
|
|
$is_chip = 1;
|
||
|
|
}
|
||
|
|
if (open CHIP,"<$dir/tag") {
|
||
|
|
chop($chip = <CHIP>);
|
||
|
|
$ls->{Title} = { $chip => 1 };
|
||
|
|
$is_chip = 1;
|
||
|
|
}
|
||
|
|
$ls->{From} = { "Chip Salzenberg" => 1 } if $is_chip && !$ls->{From};
|
||
|
|
}
|
||
|
|
|
||
|
|
# if we don't have a title for -m then use the file name
|
||
|
|
$ls->{Title}{$in}=1 if $::opt_m
|
||
|
|
and !$ls->{Title} and $ls->{out};
|
||
|
|
|
||
|
|
$ls->{category} = $::opt_c
|
||
|
|
? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
|
||
|
|
}
|
||
|
|
print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
|
||
|
|
|
||
|
|
|
||
|
|
# --- Firstly we filter and sort as needed ---
|
||
|
|
|
||
|
|
my @ls = values %ls;
|
||
|
|
|
||
|
|
if ($::opt_f) { # filter out patches based on -f <regexp>
|
||
|
|
$::opt_f .= '$' unless $::opt_f =~ m:/:;
|
||
|
|
@ls = grep {
|
||
|
|
my $match = 0;
|
||
|
|
if ($_->{is_in}) {
|
||
|
|
my @out = keys %{ $_->{out} };
|
||
|
|
$match=1 if grep { m/$::opt_f/o } @out;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$match=1 if $_->{in} =~ m/$::opt_f/o;
|
||
|
|
}
|
||
|
|
$match;
|
||
|
|
} @ls;
|
||
|
|
}
|
||
|
|
|
||
|
|
@ls = sort {
|
||
|
|
$a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
|
||
|
|
} @ls;
|
||
|
|
|
||
|
|
|
||
|
|
# --- Handle special modes ---
|
||
|
|
|
||
|
|
if ($::opt_4) {
|
||
|
|
my $tail = ($::opt_5) ? "|| exit 1" : "";
|
||
|
|
print map { "p4 delete $_$tail\n" } @removed if @removed;
|
||
|
|
print map { "p4 add $_$tail\n" } @added if @added;
|
||
|
|
my @patches = sort grep { $_->{is_in} } @ls;
|
||
|
|
my @no_outs = grep { keys %{$_->{out}} == 0 } @patches;
|
||
|
|
warn "Warning: Some files contain no patches:",
|
||
|
|
join("\n\t", '', map { $_->{in} } @no_outs), "\n" if @no_outs;
|
||
|
|
my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
|
||
|
|
delete @patched{@added};
|
||
|
|
my @patched = sort keys %patched;
|
||
|
|
foreach(@patched) {
|
||
|
|
my $edit = ($::opt_e && !-f $_) ? "add " : "edit";
|
||
|
|
print "p4 $edit $_$tail\n";
|
||
|
|
}
|
||
|
|
exit 0 unless $::opt_C;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
if ($::opt_I) {
|
||
|
|
my $n_patches = 0;
|
||
|
|
my($in,$out);
|
||
|
|
my %all_out;
|
||
|
|
my @no_outs;
|
||
|
|
foreach $in (@ls) {
|
||
|
|
next unless $in->{is_in};
|
||
|
|
++$n_patches;
|
||
|
|
my @outs = keys %{$in->{out}};
|
||
|
|
push @no_outs, $in unless @outs;
|
||
|
|
@all_out{@outs} = ($in->{in}) x @outs;
|
||
|
|
}
|
||
|
|
my @all_out = sort keys %all_out;
|
||
|
|
my @missing = grep { ! -f $_ } @all_out;
|
||
|
|
print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n";
|
||
|
|
print @no_outs." patch files don't contain patches.\n" if @no_outs;
|
||
|
|
print "(use -v to list patches which patch 'missing' files)\n"
|
||
|
|
if (@missing || @no_outs) && !$::opt_v;
|
||
|
|
if ($::opt_v and @no_outs) {
|
||
|
|
print "Patch files which don't contain patches:\n";
|
||
|
|
foreach $out (@no_outs) {
|
||
|
|
printf " %-20s\n", $out->{in};
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($::opt_v and @missing) {
|
||
|
|
print "Missing files:\n";
|
||
|
|
foreach $out (@missing) {
|
||
|
|
printf " %-20s\t", $out unless $::opt_h;
|
||
|
|
print $all_out{$out} unless $::opt_l;
|
||
|
|
print "\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
print "Added files: @added\n" if @added;
|
||
|
|
print "Removed files: @removed\n" if @removed;
|
||
|
|
exit 0+@missing;
|
||
|
|
}
|
||
|
|
|
||
|
|
unless ($::opt_c and $::opt_m) {
|
||
|
|
foreach $ls (@ls) {
|
||
|
|
next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
|
||
|
|
next if $::opt_X and keys %{$ls->{out}} <= 1;
|
||
|
|
list_files_by_patch($ls);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $c = '';
|
||
|
|
foreach $ls (@ls) {
|
||
|
|
next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
|
||
|
|
print "\n ------ $cat_title{$ls->{category}} ------\n"
|
||
|
|
if $ls->{category} ne $c;
|
||
|
|
$c = $ls->{category};
|
||
|
|
unless ($::opt_i) {
|
||
|
|
list_files_by_patch($ls);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $out = $ls->{in};
|
||
|
|
print "\n$out patched by:\n";
|
||
|
|
# find all the patches which patch $out and list them
|
||
|
|
my @p = grep { $_->{out}->{$out} } values %ls;
|
||
|
|
foreach $ls (@p) {
|
||
|
|
list_files_by_patch($ls, '');
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
print "\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
exit 0;
|
||
|
|
|
||
|
|
|
||
|
|
# ---
|
||
|
|
|
||
|
|
|
||
|
|
sub add_file {
|
||
|
|
my $ls = shift;
|
||
|
|
print "add_file '$_[0]'\n" if $::opt_d;
|
||
|
|
my $out = trim_name(shift);
|
||
|
|
|
||
|
|
$ls->{out}->{$out} = 1;
|
||
|
|
|
||
|
|
warn "$out patched but not present\n" if $::opt_e && !-f $out;
|
||
|
|
|
||
|
|
# do the -i inverse as well, even if we're not doing -i
|
||
|
|
my $i = $ls{$out} ||= {
|
||
|
|
is_out => 1,
|
||
|
|
in => $out,
|
||
|
|
category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
|
||
|
|
};
|
||
|
|
$i->{out}->{$in} = 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub trim_name { # reduce/tidy file paths from diff lines
|
||
|
|
my $name = shift;
|
||
|
|
$name = "$name ($in)" if $name eq "/dev/null";
|
||
|
|
$name =~ s:\\:/:g; # adjust windows paths
|
||
|
|
$name =~ s://:/:g; # simplify (and make win \\share into absolute path)
|
||
|
|
if (defined $::opt_p) {
|
||
|
|
# strip on -p levels of directory prefix
|
||
|
|
my $dc = $::opt_p;
|
||
|
|
$name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
|
||
|
|
}
|
||
|
|
else { # try to strip off leading path to perl directory
|
||
|
|
# if absolute path, strip down to any *perl* directory first
|
||
|
|
$name =~ s:^/.*?perl.*?/::i;
|
||
|
|
$name =~ s:.*perl[-_]?5?[._]?[-_a-z0-9.+]*/::i;
|
||
|
|
$name =~ s:^\./::;
|
||
|
|
}
|
||
|
|
return $name;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub list_files_by_patch {
|
||
|
|
my($ls, $name) = @_;
|
||
|
|
$name = $ls->{in} unless defined $name;
|
||
|
|
my @meta;
|
||
|
|
if ($::opt_m) {
|
||
|
|
my $meta;
|
||
|
|
foreach $meta (@show_meta) {
|
||
|
|
next unless $ls->{$meta};
|
||
|
|
my @list = sort keys %{$ls->{$meta}};
|
||
|
|
push @meta, sprintf "%7s: ", $meta;
|
||
|
|
if ($meta eq 'Title') {
|
||
|
|
@list = map { "\"$_\""; } @list;
|
||
|
|
push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:;
|
||
|
|
}
|
||
|
|
elsif ($meta eq 'From') {
|
||
|
|
# fix-up bizzare addresses from japan and ibm :-)
|
||
|
|
foreach(@list) {
|
||
|
|
s:\W+=?iso.*?<: <:;
|
||
|
|
s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ($meta eq 'Msg-ID') {
|
||
|
|
my %from; # limit long threads to one msg-id per site
|
||
|
|
@list = map {
|
||
|
|
$from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_);
|
||
|
|
} @list;
|
||
|
|
}
|
||
|
|
push @meta, my_wrap(""," ", join(", ",@list)."\n");
|
||
|
|
}
|
||
|
|
$name = "\n$name" if @meta and $name;
|
||
|
|
}
|
||
|
|
# don't print the header unless the file contains something interesting
|
||
|
|
return if !@meta and !$ls->{out} and !$::opt_v;
|
||
|
|
if ($::opt_l) { # -l = no listing, just names
|
||
|
|
print "$ls->{in}";
|
||
|
|
my $n = keys %{ $ls->{out} };
|
||
|
|
print " ($n patches)" if $::opt_n and $n>1;
|
||
|
|
print "\n";
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# a twisty maze of little options
|
||
|
|
my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
|
||
|
|
print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat";
|
||
|
|
print join('',"\n",@meta) if @meta;
|
||
|
|
|
||
|
|
return if $::opt_m && !$show_meta{Files};
|
||
|
|
my @v = sort PATORDER keys %{ $ls->{out} };
|
||
|
|
my $n = @v;
|
||
|
|
my $v = "@v";
|
||
|
|
print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v;
|
||
|
|
print " ($n patches)" if $::opt_n and $n>1;
|
||
|
|
print "\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub my_wrap {
|
||
|
|
my $txt = eval { expand(wrap(@_)) }; # die's on long lines!
|
||
|
|
return $txt unless $@;
|
||
|
|
return expand("@_");
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
sub categorize_files {
|
||
|
|
my($files, $verb) = @_;
|
||
|
|
my(%c, $refine);
|
||
|
|
|
||
|
|
foreach (@$files) { # assign a score to a file path
|
||
|
|
# the order of some of the tests is important
|
||
|
|
$c{TEST} += 5,next if m:^t/:;
|
||
|
|
$c{DOC} += 5,next if m:^pod/:;
|
||
|
|
$c{UTIL} += 10,next if m:^(utils|x2p|h2pl)/:;
|
||
|
|
$c{PORT1}+= 15,next if m:^win32:;
|
||
|
|
$c{PORT2} += 15,next
|
||
|
|
if m:^(cygwin32|os2|plan9|qnx|vms)/:
|
||
|
|
or m:^(hints|Porting|ext/DynaLoader)/:
|
||
|
|
or m:^README\.:;
|
||
|
|
$c{EXT} += 10,next
|
||
|
|
if m:^(ext|lib/ExtUtils)/:;
|
||
|
|
$c{LIB} += 10,next
|
||
|
|
if m:^(lib)/:;
|
||
|
|
$c{'CORE'} += 15,next
|
||
|
|
if m:^[^/]+[\._]([chH]|sym|pl)$:;
|
||
|
|
$c{BUILD} += 10,next
|
||
|
|
if m:^[A-Z]+$: or m:^[^/]+\.SH$:
|
||
|
|
or m:^(install|configure|configpm):i;
|
||
|
|
print "Couldn't categorise $_\n" if $::opt_v;
|
||
|
|
$c{OTHER} += 1;
|
||
|
|
}
|
||
|
|
if (keys %c > 1) { # sort to find category with highest score
|
||
|
|
refine:
|
||
|
|
++$refine;
|
||
|
|
my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
|
||
|
|
my @v = map { $c{$_} } @c;
|
||
|
|
if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
|
||
|
|
and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare
|
||
|
|
print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
|
||
|
|
++$c{$c[1]};
|
||
|
|
goto refine;
|
||
|
|
}
|
||
|
|
print " ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
|
||
|
|
if $verb;
|
||
|
|
return $c[0] || 'OTHER';
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my($c, $v) = %c;
|
||
|
|
$c ||= 'UNKNOWN'; $v ||= 0;
|
||
|
|
print " ".@$files." patches: $c: $v\n" if $verb;
|
||
|
|
return $c;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub PATORDER { # PATORDER sort by Chip Salzenberg
|
||
|
|
my ($i, $j);
|
||
|
|
|
||
|
|
$i = ($a =~ m#^[A-Z]+$#);
|
||
|
|
$j = ($b =~ m#^[A-Z]+$#);
|
||
|
|
return $j - $i if $i != $j;
|
||
|
|
|
||
|
|
$i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
|
||
|
|
$j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
|
||
|
|
return $j - $i if $i != $j;
|
||
|
|
|
||
|
|
$i = ($a =~ m#\.pod$#);
|
||
|
|
$j = ($b =~ m#\.pod$#);
|
||
|
|
return $j - $i if $i != $j;
|
||
|
|
|
||
|
|
$i = ($a =~ m#include/#);
|
||
|
|
$j = ($b =~ m#include/#);
|
||
|
|
return $j - $i if $i != $j;
|
||
|
|
|
||
|
|
if ((($i = $a) =~ s#/+[^/]*$##)
|
||
|
|
&& (($j = $b) =~ s#/+[^/]*$##)) {
|
||
|
|
return $i cmp $j if $i ne $j;
|
||
|
|
}
|
||
|
|
|
||
|
|
$i = ($a =~ m#\.h$#);
|
||
|
|
$j = ($b =~ m#\.h$#);
|
||
|
|
return $j - $i if $i != $j;
|
||
|
|
|
||
|
|
return $a cmp $b;
|
||
|
|
}
|
||
|
|
|