[p5sagit/p5-mst-13.2.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.
#
# $Id: patchls,v 1.3 1997/06/10 21:38:45 timbo Exp $

use Getopt::Std;
use Text::Wrap qw(wrap $columns);
use Text::Tabs qw(expand unexpand);
use strict;

sub usage {
die qq{

  patchls [options] patchfile [ ... ]

    -i     Invert: for each patched file list which patch files patch it
    -h     no filename headers (like grep), only the listing
    -l     no listing (like grep), only the filename headers
    -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)

}
}

$columns = 70;

$::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;

usage unless @ARGV;

getopts("mihlvcp:") or usage;

my %cat_title = (
    'TEST'	=> 'TESTS',
    'DOC'	=> 'DOCUMENTATION',
    'UTIL'	=> 'UTILITIES',
    'PORT'	=> 'PORTABILITY',
    'LIB'	=> 'LIBRARY AND EXTENSIONS',
    'CORE'	=> 'CORE LANGUAGE',
    'BUILD'	=> 'BUILD PROCESS',
    'OTHER'	=> 'OTHER',
);

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

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

	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+(.*)/;

	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;


my @ls  = sort {
    $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
} values %ls;

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";
    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) {
	foreach(qw(Title From Msg-ID)) {
	    next unless $ls->{$_};
	    my @list = sort keys %{$ls->{$_}};
	    push @meta, sprintf "%7s:  ", $_;
	    @list = map { "\"$_\"" } @list if $_ eq 'Title';
	    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 {
    return expand(wrap(@_));
}


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