[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.


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

$VERSION = 2.11;

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.
    -      Read patch from STDIN
  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 PATCHED',
);


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
#	@@ .. @@
# or for deletions
#	--- perl5.004001/mg.c   Sun Jun 08 12:26:24 1997
#	+++ /dev/null   Sun Jun 08 11:56:08 1997
#	@@ ... @@
# 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;
    if (-d $in) {
	warn "Ignored directory $in\n";
	next;
    }
    if ($in eq "-") {
      *F = \*STDIN;
    } elsif (not 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) {
		$added{$1}   = 1    if /^touch\s+(\S+)/;
		$removed{$1} = 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_patched_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
		if ($1 eq "/dev/null") {
		    $prevline =~ /^[-+*]{3} (\S+)\s*/;
		    add_deleted_file($ls, $1);
		}
		else {
		    add_patched_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}{"Untitled: $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" } sort keys %removed if %removed;
    print map { "p4 add    $_$tail\n" } sort keys %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{keys %added};
    my @patched = sort keys %patched;
    foreach(@patched) {
	next if $removed{$_};
	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:   ".join(" ",sort keys %added  )."\n" if %added;
    print "Removed files: ".join(" ",sort keys %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_patched_file {
    my $ls = shift;
	my $raw_name = shift;
    my $action = shift || 1;	# 1==patched, 2==deleted

    my $out = trim_name($raw_name);
    print "add_patched_file '$out' ($raw_name, $action)\n" if $::opt_d;

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

    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 add_deleted_file {
    my $ls = shift;
	my $raw_name = shift;
    my $out = trim_name($raw_name);
    print "add_deleted_file '$out' ($raw_name)\n" if $::opt_d;
	$removed{$out} = 1;
    #add_patched_file(@_[0,1], 2);
}


sub trim_name {		# reduce/tidy file paths from diff lines
    my $name = shift;
    $name =~ s:\\:/:g;	# adjust windows paths
    $name =~ s://:/:g;	# simplify (and make win \\share into absolute path)
    if ($name eq "/dev/null") {
	# do nothing (XXX but we need a way to record deletions)
    }
    elsif (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|maint)[-_]?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";
    my $sep = "\n";
    $sep = "" if @show_meta==1 && $::opt_c && $::opt_h;
    print join('', $sep, @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:^(cygwin|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;
}
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.
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);
fb73857a	19
146174a9	20	$VERSION = 2.11;
08aa1457	21
3e3baf6d	22	sub usage {
43051805	23	die qq{
3e3baf6d	24	patchls [options] patchfile [ ... ]
3e3baf6d	25
84902520	26	-h no filename headers (like grep), only the listing.
84902520	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	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).
b73f5677	33	-n give a count of the number of patches applied to a file if >1.
84902520	34	-f F only list patches which patch files matching regexp F
43051805	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.
146174a9	38	- Read patch from STDIN
fb73857a	39	other options for special uses:
84902520	40	-I just gather and display summary Information about the patches.
fb73857a	41	-4 write to stdout the PerForce commands to prepare for patching.
43051805	42	-5 like -4 but add "\|\| exit 1" after each command
fb73857a	43	-M T Like -m but only output listed meta tags (eg -M 'Title From')
fb73857a	44	-W N set wrap width to N (defaults to 70, use 0 for no wrap)
b73f5677	45	-X list patchfiles that may clash (i.e. patch the same file)
43051805	46
43051805	47	patchls version $VERSION by Tim Bunce
3e3baf6d	48	}
	49	}
	50
3e3baf6d	51	$::opt_p = undef; # undef != 0
08aa1457	52	$::opt_d = 0;
	53	$::opt_v = 0;
	54	$::opt_m = 0;
b73f5677	55	$::opt_n = 0;
08aa1457	56	$::opt_i = 0;
	57	$::opt_h = 0;
	58	$::opt_l = 0;
	59	$::opt_c = 0;
84902520	60	$::opt_f = '';
43051805	61	$::opt_e = 0;
fb73857a	62
fb73857a	63	# special purpose options
84902520	64	$::opt_I = 0;
fb73857a	65	$::opt_4 = 0; # output PerForce commands to prepare for patching
43051805	66	$::opt_5 = 0;
fb73857a	67	$::opt_M = ''; # like -m but only output these meta items (-M Title)
fb73857a	68	$::opt_W = 70; # set wrap width columns (see Text::Wrap module)
43051805	69	$::opt_C = 0; # 'Chip' mode (handle from/tags/article/bug files) undocumented
b73f5677	70	$::opt_X = 0; # list patchfiles that patch the same file
08aa1457	71
3e3baf6d	72	usage unless @ARGV;
08aa1457	73
b73f5677	74	getopts("dmnihlvecC45Xp:f:IM:W:") or usage;
fb73857a	75
	76	$columns = $::opt_W \|\| 9999999;
	77
	78	$::opt_m = 1 if $::opt_M;
43051805	79	$::opt_4 = 1 if $::opt_5;
b73f5677	80	$::opt_i = 1 if $::opt_X;
	81
	82	# see get_meta_info()
	83	my @show_meta = split(' ', $::opt_M \|\| 'Title From Msg-ID Files');
	84	my %show_meta = map { ($_,1) } @show_meta;
08aa1457	85
3e3baf6d	86	my %cat_title = (
84902520	87	'BUILD' => 'BUILD PROCESS',
84902520	88	'CORE' => 'CORE LANGUAGE',
3e3baf6d	89	'DOC' => 'DOCUMENTATION',
b73f5677	90	'LIB' => 'LIBRARY',
84902520	91	'PORT1' => 'PORTABILITY - WIN32',
fb73857a	92	'PORT2' => 'PORTABILITY - GENERAL',
84902520	93	'TEST' => 'TESTS',
	94	'UTIL' => 'UTILITIES',
	95	'OTHER' => 'OTHER CHANGES',
b73f5677	96	'EXT' => 'EXTENSIONS',
a8710ca1	97	'UNKNOWN' => 'UNKNOWN - NO FILES PATCHED',
3e3baf6d	98	);
08aa1457	99
43051805	100
	101	sub get_meta_info {
	102	my $ls = shift;
	103	local($_) = shift;
b73f5677	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	}
43051805	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
08aa1457	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
a8710ca1	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	# @@ ... @@
08aa1457	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
43051805	147	my %ls;
43051805	148
b73f5677	149	my $in;
	150	my $ls;
	151	my $prevline = '';
43051805	152	my $prevtype = '';
a8710ca1	153	my (%removed, %added);
fb73857a	154	my $prologue = 1; # assume prologue till patch or /^exit\b/ seen
08aa1457	155
43051805	156
08aa1457	157	foreach my $argv (@ARGV) {
08aa1457	158	$in = $argv;
a8710ca1	159	if (-d $in) {
	160	warn "Ignored directory $in\n";
	161	next;
	162	}
146174a9	163	if ($in eq "-") {
	164	F = \STDIN;
	165	} elsif (not open F, "<$in") {
08aa1457	166	warn "Unable to open $in: $!\n";
	167	next;
	168	}
	169	print "Reading $in...\n" if $::opt_v and @ARGV > 1;
3e3baf6d	170	$ls = $ls{$in} \|\|= { is_in => 1, in => $in };
08aa1457	171	my $type;
	172	while (<F>) {
	173	unless (/^([-+*]{3}) / \|\| /^(Index):/) {
fb73857a	174	# not an interesting patch line
	175	# but possibly meta-information or prologue
	176	if ($prologue) {
a8710ca1	177	$added{$1} = 1 if /^touch\s+(\S+)/;
a8710ca1	178	$removed{$1} = 1 if /^rm\s+(?:-f)?\s*(\S+)/;
fb73857a	179	$prologue = 0 if /^exit\b/;
fb73857a	180	}
43051805	181	get_meta_info($ls, $_) if $::opt_m;
08aa1457	182	next;
	183	}
	184	$type = $1;
	185	next if /^--- [0-9,]+ ----$/ \|\| /^\\\* [0-9,]+ \\\\$/;
fb73857a	186	$prologue = 0;
08aa1457	187
b73f5677	188	print "Last: $prevline","This: ${_}Got: $type\n\n" if $::opt_d;
08aa1457	189
08aa1457	190	# Some patches have Index lines but not diff headers
3e3baf6d	191	# Patch copes with this, so must we. It's also handy for
3e3baf6d	192	# documenting manual changes by simply adding Index: lines
b73f5677	193	# to the file which describes the problem being fixed.
	194	if (/^Index:\s+(.*)/) {
	195	my $f;
a8710ca1	196	foreach $f (split(/ /, $1)) { add_patched_file($ls, $f) }
b73f5677	197	next;
b73f5677	198	}
08aa1457	199
	200	if ( ($type eq '---' and $prevtype eq '***') # Style 1
	201	or ($type eq '+++' and $prevtype eq '---') # Style 2
	202	) {
fb73857a	203	if (/^[-+]{3} (\S+)\s(.*?\d\d:\d\d:\d\d)?/) { # double check
a8710ca1	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	}
08aa1457	211	}
	212	else {
	213	warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
	214	}
	215	}
	216	}
	217	continue {
	218	$prevline = $_;
b73f5677	219	$prevtype = $type \|\| '';
08aa1457	220	$type = '';
08aa1457	221	}
43051805	222
43051805	223	# special mode for patch sets from Chip
b73f5677	224	if ($in =~ m:[\\/]patch$:) {
b73f5677	225	my $is_chip;
43051805	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>);
b73f5677	230	$is_chip = 1;
43051805	231	}
	232	if (open CHIP,"<$dir/from") {
	233	chop($chip = <CHIP>);
	234	$ls->{From} = { $chip => 1 };
b73f5677	235	$is_chip = 1;
43051805	236	}
	237	if (open CHIP,"<$dir/tag") {
	238	chop($chip = <CHIP>);
	239	$ls->{Title} = { $chip => 1 };
b73f5677	240	$is_chip = 1;
43051805	241	}
b73f5677	242	$ls->{From} = { "Chip Salzenberg" => 1 } if $is_chip && !$ls->{From};
43051805	243	}
43051805	244
3e3baf6d	245	# if we don't have a title for -m then use the file name
a8710ca1	246	$ls->{Title}{"Untitled: $in"}=1 if $::opt_m
3e3baf6d	247	and !$ls->{Title} and $ls->{out};
	248
	249	$ls->{category} = $::opt_c
	250	? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
08aa1457	251	}
3e3baf6d	252	print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
	253
	254
fb73857a	255	# --- Firstly we filter and sort as needed ---
	256
	257	my @ls = values %ls;
08aa1457	258
84902520	259	if ($::opt_f) { # filter out patches based on -f <regexp>
84902520	260	$::opt_f .= '$' unless $::opt_f =~ m:/:;
84902520	261	@ls = grep {
84902520	262	my $match = 0;
b73f5677	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;
84902520	269	}
	270	$match;
	271	} @ls;
	272	}
	273
fb73857a	274	@ls = sort {
	275	$a->{category} cmp $b->{category} \|\| $a->{in} cmp $b->{in}
	276	} @ls;
	277
	278
	279	# --- Handle special modes ---
	280
	281	if ($::opt_4) {
43051805	282	my $tail = ($::opt_5) ? "\|\| exit 1" : "";
a8710ca1	283	print map { "p4 delete $_$tail\n" } sort keys %removed if %removed;
a8710ca1	284	print map { "p4 add $_$tail\n" } sort keys %added if %added;
b73f5677	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;
a8710ca1	289
fb73857a	290	my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
a8710ca1	291	delete @patched{keys %added};
fb73857a	292	my @patched = sort keys %patched;
b73f5677	293	foreach(@patched) {
a8710ca1	294	next if $removed{$_};
43051805	295	my $edit = ($::opt_e && !-f $_) ? "add " : "edit";
b73f5677	296	print "p4 $edit $_$tail\n";
b73f5677	297	}
43051805	298	exit 0 unless $::opt_C;
fb73857a	299	}
fb73857a	300
b73f5677	301
84902520	302	if ($::opt_I) {
	303	my $n_patches = 0;
	304	my($in,$out);
	305	my %all_out;
b73f5677	306	my @no_outs;
84902520	307	foreach $in (@ls) {
	308	next unless $in->{is_in};
	309	++$n_patches;
	310	my @outs = keys %{$in->{out}};
b73f5677	311	push @no_outs, $in unless @outs;
84902520	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";
b73f5677	317	print @no_outs." patch files don't contain patches.\n" if @no_outs;
fb73857a	318	print "(use -v to list patches which patch 'missing' files)\n"
b73f5677	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	}
84902520	326	if ($::opt_v and @missing) {
	327	print "Missing files:\n";
	328	foreach $out (@missing) {
b73f5677	329	printf " %-20s\t", $out unless $::opt_h;
	330	print $all_out{$out} unless $::opt_l;
	331	print "\n";
84902520	332	}
84902520	333	}
a8710ca1	334	print "Added files: ".join(" ",sort keys %added )."\n" if %added;
a8710ca1	335	print "Removed files: ".join(" ",sort keys %removed)."\n" if %removed;
84902520	336	exit 0+@missing;
	337	}
	338
08aa1457	339	unless ($::opt_c and $::opt_m) {
3e3baf6d	340	foreach $ls (@ls) {
3e3baf6d	341	next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
b73f5677	342	next if $::opt_X and keys %{$ls->{out}} <= 1;
08aa1457	343	list_files_by_patch($ls);
	344	}
	345	}
	346	else {
	347	my $c = '';
3e3baf6d	348	foreach $ls (@ls) {
3e3baf6d	349	next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
84902520	350	print "\n ------ $cat_title{$ls->{category}} ------\n"
84902520	351	if $ls->{category} ne $c;
08aa1457	352	$c = $ls->{category};
3e3baf6d	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	}
08aa1457	365	}
	366	print "\n";
	367	}
	368
3e3baf6d	369	exit 0;
	370
	371
	372	# ---
	373
08aa1457	374
a8710ca1	375	sub add_patched_file {
08aa1457	376	my $ls = shift;
a8710ca1	377	my $raw_name = shift;
a8710ca1	378	my $action = shift \|\| 1; # 1==patched, 2==deleted
3e3baf6d	379
a8710ca1	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;
3e3baf6d	384
43051805	385	warn "$out patched but not present\n" if $::opt_e && !-f $out;
43051805	386
3e3baf6d	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;
08aa1457	394	}
08aa1457	395
a8710ca1	396	sub 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
08aa1457	405
	406	sub trim_name { # reduce/tidy file paths from diff lines
	407	my $name = shift;
84902520	408	$name =~ s:\\:/:g; # adjust windows paths
84902520	409	$name =~ s://:/:g; # simplify (and make win \\share into absolute path)
a8710ca1	410	if ($name eq "/dev/null") {
	411	# do nothing (XXX but we need a way to record deletions)
	412	}
	413	elsif (defined $::opt_p) {
08aa1457	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;
a8710ca1	421	$name =~ s:.(perl\|maint)[-_]?5?[._]?[-_a-z0-9.+]/::i;
08aa1457	422	$name =~ s:^\./::;
	423	}
	424	return $name;
	425	}
	426
	427
	428	sub list_files_by_patch {
3e3baf6d	429	my($ls, $name) = @_;
3e3baf6d	430	$name = $ls->{in} unless defined $name;
08aa1457	431	my @meta;
08aa1457	432	if ($::opt_m) {
fb73857a	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') {
b73f5677	439	@list = map { "\"$_\""; } @list;
43051805	440	push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:;
fb73857a	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	}
08aa1457	455	push @meta, my_wrap(""," ", join(", ",@list)."\n");
08aa1457	456	}
3e3baf6d	457	$name = "\n$name" if @meta and $name;
08aa1457	458	}
08aa1457	459	# don't print the header unless the file contains something interesting
b73f5677	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	}
08aa1457	468
3e3baf6d	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";
a8710ca1	472	my $sep = "\n";
	473	$sep = "" if @show_meta==1 && $::opt_c && $::opt_h;
	474	print join('', $sep, @meta) if @meta;
08aa1457	475
b73f5677	476	return if $::opt_m && !$show_meta{Files};
3e3baf6d	477	my @v = sort PATORDER keys %{ $ls->{out} };
b73f5677	478	my $n = @v;
b73f5677	479	my $v = "@v";
08aa1457	480	print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v;
b73f5677	481	print " ($n patches)" if $::opt_n and $n>1;
b73f5677	482	print "\n";
08aa1457	483	}
	484
	485
	486	sub my_wrap {
84902520	487	my $txt = eval { expand(wrap(@_)) }; # die's on long lines!
	488	return $txt unless $@;
	489	return expand("@_");
08aa1457	490	}
	491
	492
	493
3e3baf6d	494	sub categorize_files {
3e3baf6d	495	my($files, $verb) = @_;
08aa1457	496	my(%c, $refine);
3e3baf6d	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)/:;
84902520	503	$c{PORT1}+= 15,next if m:^win32:;
84902520	504	$c{PORT2} += 15,next
873b149f	505	if m:^(cygwin\|os2\|plan9\|qnx\|vms)/:
08aa1457	506	or m:^(hints\|Porting\|ext/DynaLoader)/:
08aa1457	507	or m:^README\.:;
b73f5677	508	$c{EXT} += 10,next
b73f5677	509	if m:^(ext\|lib/ExtUtils)/:;
3e3baf6d	510	$c{LIB} += 10,next
b73f5677	511	if m:^(lib)/:;
3e3baf6d	512	$c{'CORE'} += 15,next
84902520	513	if m:^[^/]+[\._]([chH]\|sym\|pl)$:;
3e3baf6d	514	$c{BUILD} += 10,next
08aa1457	515	if m:^[A-Z]+$: or m:^[^/]+\.SH$:
84902520	516	or m:^(install\|configure\|configpm):i;
08aa1457	517	print "Couldn't categorise $_\n" if $::opt_v;
3e3baf6d	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';
08aa1457	534	}
3e3baf6d	535	else {
3e3baf6d	536	my($c, $v) = %c;
b73f5677	537	$c \|\|= 'UNKNOWN'; $v \|\|= 0;
3e3baf6d	538	print " ".@$files." patches: $c: $v\n" if $verb;
3e3baf6d	539	return $c;
08aa1457	540	}
08aa1457	541	}
	542
	543
	544	sub 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