[perl5.git] / Porting / patchls

#!/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.04;

sub usage {
die q{
  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).
    -f F   only list patches which patch files matching regexp F
           (F has $ appended unless it contains a /).
  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.
    -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)
}
}

$::opt_p = undef;	# undef != 0
$::opt_d = 0;
$::opt_v = 0;
$::opt_m = 0;
$::opt_i = 0;
$::opt_h = 0;
$::opt_l = 0;
$::opt_c = 0;
$::opt_f = '';

# special purpose options
$::opt_I = 0;
$::opt_4 = 0;	# output PerForce commands to prepare for patching
$::opt_M = '';	# like -m but only output these meta items (-M Title)
$::opt_W = 70;	# set wrap width columns (see Text::Wrap module)

usage unless @ARGV;

getopts("mihlvc4p:f:IM:W:") or usage;

$columns = $::opt_W || 9999999;

$::opt_m = 1 if $::opt_M;
my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID');

my %cat_title = (
    'BUILD'	=> 'BUILD PROCESS',
    'CORE'	=> 'CORE LANGUAGE',
    'DOC'	=> 'DOCUMENTATION',
    'LIB'	=> 'LIBRARY AND EXTENSIONS',
    'PORT1'	=> 'PORTABILITY - WIN32',
    'PORT2'	=> 'PORTABILITY - GENERAL',
    'TEST'	=> 'TESTS',
    'UTIL'	=> 'UTILITIES',
    'OTHER'	=> 'OTHER CHANGES',
);

my %ls;

# 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($in, $prevline, $prevtype, $ls);
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/;
	    }
	    next unless $::opt_m;
	    $ls->{From}{$1}=1,next     if /^From:\s+(.*\S)/i;
	    $ls->{Title}{$1}=1,next    if /^Subject:\s+(?:Re: )?(.*\S)/i;
	    $ls->{'Msg-ID'}{$1}=1,next if /^Message-Id:\s+(.*\S)/i;
	    $ls->{Date}{$1}=1,next     if /^Date:\s+(.*\S)/i;
	    $ls->{$1}{$2}=1,next       if /^([-\w]+):\s+(.*\S)/;
	    next;
	}
	$type = $1;
	next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
	$prologue = 0;

	print "Last: $prevline","This: ${_}Got:  $1\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 bing fixed.
	add_file($ls, $1), next if /^Index:\s+(\S+)/;

	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 = '';
    }
    # 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>
    my $out;
    $::opt_f .= '$' unless $::opt_f =~ m:/:;
    @ls = grep {
	my @out = keys %{$_->{out}};
	my $match = 0;
	for $out (@out) {
	    ++$match if $out =~ 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) {
    print map { "p4 delete $_\n" } @removed if @removed;
    print map { "p4 add    $_\n" } @added   if @added;
    my @patches = grep { $_->{is_in} } @ls;
    my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
    delete @patched{@added};
    my @patched = sort keys %patched;
    print map { "p4 edit   $_\n" } @patched if @patched;
    exit 0;
}

if ($::opt_I) {
    my $n_patches = 0;
    my($in,$out);
    my %all_out;
    foreach $in (@ls) {
	next unless $in->{is_in};
	++$n_patches;
	my @outs = keys %{$in->{out}};
	@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 "(use -v to list patches which patch 'missing' files)\n"
	    if @missing && !$::opt_v;
    if ($::opt_v and @missing) {
	print "Missing files:\n";
	foreach $out (@missing) {
	    printf "  %-20s\t%s\n", $out, $all_out{$out};
	}
    }
    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};
	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;
    my $out = trim_name(shift);

    $ls->{out}->{$out} = 1;

    # 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 { s/\[?PATCH\]?:?\s*//g; "\"$_\""; } @list
	    }
	    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};
    print("$ls->{in}\n"),return  if $::opt_l;	# -l = no listing

    # 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;

    my @v = sort PATORDER keys %{ $ls->{out} };
    my $v = "@v\n";
    print $::opt_m ? "  Files:  ".my_wrap("","          ",$v) : $v;
}


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{LIB}  += 10,next
	    if m:^(lib|ext)/:;
	$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 ||= 'OTHER'; $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;
}
Commit	Line	Data
08aa1457	1	#!/bin/perl -w
08aa1457	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 TB	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 TB	24	patchls [options] patchfile [ ... ]
3e3baf6d TB	25
84902520 TB	26	-h no filename headers (like grep), only the listing.
84902520 TB	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 TB	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 TB	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
fb73857a	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 TB	69	'BUILD' => 'BUILD PROCESS',
84902520 TB	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 TB	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);
fb73857a	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 TB	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 TB	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 TB	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 TB	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 TB	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"
fb73857a	217	if @missing && !$::opt_v;
84902520 TB	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;
fb73857a	225	print "Removed files: @removed\n" if @removed;
84902520 TB	226	exit 0+@missing;
	227	}
	228
08aa1457	229	unless ($::opt_c and $::opt_m) {
3e3baf6d TB	230	foreach $ls (@ls) {
3e3baf6d TB	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 TB	237	foreach $ls (@ls) {
3e3baf6d TB	238	next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
84902520 TB	239	print "\n ------ $cat_title{$ls->{category}} ------\n"
84902520 TB	240	if $ls->{category} ne $c;
08aa1457	241	$c = $ls->{category};
3e3baf6d TB	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 TB	258	exit 0;
	259
	260
	261	# ---
	262
08aa1457	263
	264	sub add_file {
	265	my $ls = shift;
	266	my $out = trim_name(shift);
3e3baf6d TB	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 TB	283	$name =~ s:\\:/:g; # adjust windows paths
84902520 TB	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 TB	301	my($ls, $name) = @_;
3e3baf6d TB	302	$name = $ls->{in} unless defined $name;
08aa1457	303	my @meta;
08aa1457	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");
08aa1457	327	}
3e3baf6d	328	$name = "\n$name" if @meta and $name;
08aa1457	329	}
08aa1457	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
08aa1457	333
3e3baf6d TB	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;
08aa1457	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 TB	346	my $txt = eval { expand(wrap(@_)) }; # die's on long lines!
	347	return $txt unless $@;
	348	return expand("@_");
08aa1457	349	}
	350
	351
	352
3e3baf6d TB	353	sub categorize_files {
3e3baf6d TB	354	my($files, $verb) = @_;
08aa1457	355	my(%c, $refine);
3e3baf6d TB	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 TB	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)/:
08aa1457	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 TB	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 TB	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