X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Porting%2Fpatchls;h=8808c20431e3c56bd4d46fff7239f41d3078be72;hb=a9ef352ac26829339bf17aa20568b3bde2fb1dd0;hp=e9e902fc489db54c1e6bd5373a1a2a17672aadc3;hpb=08aa1457cd52a368c210ab76a3da91cfadabea1a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/Porting/patchls b/Porting/patchls index e9e902f..8808c20 100644 --- a/Porting/patchls +++ b/Porting/patchls @@ -1,46 +1,125 @@ #!/bin/perl -w # -# Originally from Tom Horsley. Generally hacked and extended by Tim Bunce. +# patchls - patch listing utility # # Input is one or more patchfiles, output is a list of files to be patched. # -# $Id: patchls,v 1.3 1997/06/10 21:38:45 timbo Exp $ +# 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. -require "getopts.pl"; +use Getopt::Std; use Text::Wrap qw(wrap $columns); use Text::Tabs qw(expand unexpand); use strict; +use vars qw($VERSION); + +$VERSION = 2.10; + +sub usage { +die qq{ + patchls [options] patchfile [ ... ] -$columns = 70; + -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; # like patch -pN, strip off N dir levels from file names +$::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)/; +} -die qq{ - - patchls [options] patchfile [ ... ] - - -m print formatted Meta-information (Subject,From,Msg-ID etc) - -p N strip N levels of directory Prefix (like patch), else automatic - -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 attempt to Categorise the patch (sort by category with -m) - -v more verbose - -d still more verbosity for debugging - -} unless @ARGV; - -&Getopts("mihlvcp:"); - -my %ls; # Style 1: # *** perl-5.004/embed.h Sat May 10 03:39:32 1997 @@ -52,7 +131,11 @@ my %ls; # 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 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 @@ -60,41 +143,68 @@ my %ls; # Variation: # Index: embed.h -my($in, $prevline, $prevtype, $ls); +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; + } unless (open F, "<$in") { warn "Unable to open $in: $!\n"; next; } print "Reading $in...\n" if $::opt_v and @ARGV > 1; - $ls = $ls{$in} ||= { in => $in }; + $ls = $ls{$in} ||= { is_in => 1, in => $in }; my $type; while () { 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; + # 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: $1\n\n" if $::opt_d; + 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 - add_file($ls, $1), next if /^Index:\s+(.*)/; + # 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 - add_file($ls, $1); + 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$_"; @@ -103,44 +213,201 @@ foreach my $argv (@ARGV) { } continue { $prevline = $_; - $prevtype = $type; + $prevtype = $type || ''; $type = ''; } - $ls->{Title}{$in}=1 if !$ls->{Title} and $::opt_m and $::opt_c - and $ls->{files_by_patch}; - $ls->{category} = intuit_category($ls, $::opt_v) if $::opt_c; + + # 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 (); + $is_chip = 1; + } + if (open CHIP,"<$dir/from") { + chop($chip = ); + $ls->{From} = { $chip => 1 }; + $is_chip = 1; + } + if (open CHIP,"<$dir/tag") { + chop($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 + $::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; } -print "All files read.\n" if $::opt_v and @ARGV > 1; unless ($::opt_c and $::opt_m) { - foreach $in (sort keys %ls) { - $ls = $ls{$in}; + 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 (sort { $a->{category} cmp $b->{category} } values %ls) { - print "\n $ls->{category}\n" if $ls->{category} ne $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}; - list_files_by_patch($ls); + 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 { +sub add_patched_file { my $ls = shift; - my $out = trim_name(shift); - ($ls, $out) = ($ls{$out} ||= { in => $out }, $in) if $::opt_i; - $ls->{files_by_patch}->{$out} = 1; + 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 = "$name ($in)" if $name eq "/dev/null"; - if (defined $::opt_p) { + $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; @@ -148,7 +415,7 @@ sub trim_name { # reduce/tidy file paths from diff lines 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:.*(perl|maint)[-_]?5?[._]?[-_a-z0-9.+]*/::i; $name =~ s:^\./::; } return $name; @@ -156,87 +423,118 @@ sub trim_name { # reduce/tidy file paths from diff lines sub list_files_by_patch { - my $ls = shift; - my $name = $ls->{in}; + 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'; + 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; + $name = "\n$name" if @meta and $name; } # don't print the header unless the file contains something interesting - return if !@meta and !$ls->{files_by_patch}; - print("$ls->{in}\n"),return if $::opt_l; # -l = no listing - - # a twisty maze of little options - my $cat = ($ls->{category} and !$::opt_m) ? " $ls->{category}" : ""; - print "$name$cat: " unless $::opt_h and !$::opt_v; - print join('',"\n",@meta) if @meta; + 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; + } - my @v = sort PATORDER keys %{ $ls->{files_by_patch} }; - my $v = "@v\n"; + # 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 { - return expand(wrap(@_)); + my $txt = eval { expand(wrap(@_)) }; # die's on long lines! + return $txt unless $@; + return expand("@_"); } -# CORE LANGUAGE CHANGES -# CORE PORTABILITY -# OTHER CORE CHANGES -# BUILD PROCESS -# LIBRARY AND EXTENSIONS -# TESTS -# UTILITIES -# DOCUMENTATION - -sub intuit_category { - my($ls, $verb) = @_; - return 'OTHER' unless $ls->{files_by_patch}; +sub categorize_files { + my($files, $verb) = @_; my(%c, $refine); - foreach (keys %{ $ls->{files_by_patch} }) { - ++$c{'DOCUMENTATION'},next - if m:^pod/:; - ++$c{'UTILITIES'},next - if m:^(utils|x2p|h2pl)/:; - ++$c{'PORTABILITY'},next - if m:^(cygwin32|os2|plan9|qnx|vms|win32)/: + + 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{'LIBRARY AND EXTENSIONS'},next - if m:^(lib|ext)/:; - ++$c{'TESTS'},next - if m:^t/:; - ++$c{'CORE LANGUAGE'},next - if m:^[^/]+\.([chH]|sym)$:; - ++$c{'BUILD PROCESS'},next + $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):i; + or m:^(install|configure|configpm):i; print "Couldn't categorise $_\n" if $::opt_v; - ++$c{OTHER}; + $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'; } -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)/) { - print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d; - ++$c{$c[1]}; - goto refine; + else { + my($c, $v) = %c; + $c ||= 'UNKNOWN'; $v ||= 0; + print " ".@$files." patches: $c: $v\n" if $verb; + return $c; } - print " ", join(", ", map { "$_: $c{$_}" } @c),".\n" - if $verb and @v > 1; - return $c[0]; }