summaryrefslogtreecommitdiff
path: root/Porting/patchls
diff options
context:
space:
mode:
Diffstat (limited to 'Porting/patchls')
-rw-r--r--Porting/patchls324
1 files changed, 324 insertions, 0 deletions
diff --git a/Porting/patchls b/Porting/patchls
new file mode 100644
index 0000000000..b3e968de4b
--- /dev/null
+++ b/Porting/patchls
@@ -0,0 +1,324 @@
+#!/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;
+}
+
View Lorry Controller Status