From: Rafael Garcia-Suarez Date: Tue, 6 Jan 2009 08:49:02 +0000 (+0100) Subject: Remove a couple of p4-specific utilities X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=291c4ed918b57e9c4b05608a09c1279556b5b6ec;p=p5sagit%2Fp5-mst-13.2.git Remove a couple of p4-specific utilities --- diff --git a/MANIFEST b/MANIFEST index aa38aab..fe68438 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3497,7 +3497,6 @@ pod/splitman Splits perlfunc into multiple man pages pod/splitpod Splits perlfunc into multiple pod pages Policy_sh.SH Hold site-wide preferences between Configure runs. Porting/add-package.pl Add/Update CPAN modules that are part of Core -Porting/apply Apply patches sent by mail Porting/check83.pl Check whether we are 8.3-friendly Porting/checkansi.pl Check source code for ANSI-C violations Porting/checkARGS_ASSERT.pl Check we use every PERL_ARGS_ASSERT* macro @@ -3528,9 +3527,6 @@ Porting/Maintainers.pm Library to pretty print info in Maintainers.pl Porting/makemeta Create the top-level META.yml Porting/makerel Release making utility Porting/manicheck Check against MANIFEST -Porting/p4d2p Generate patch from p4 diff -Porting/p4genpatch Generate patch from p4 change in repository (obsoletes p4desc) -Porting/patchls Flexible patch file listing utility Porting/podtidy Reformat pod using Pod::Tidy Porting/pumpkin.pod Guidelines and hints for Perl maintainers Porting/README.y2038 Perl notes for the 2038 fix diff --git a/Porting/apply b/Porting/apply deleted file mode 100644 index cfa76e0..0000000 --- a/Porting/apply +++ /dev/null @@ -1,72 +0,0 @@ -#!/usr/bin/perl -w -my $file = pop(@ARGV); -my %meta; -$ENV{'P4PORT'} ||= 'bactrian:1667'; -$ENV{'P4CLIENT'} ||= 'ni-s'; -open(FILE,$file) || die "Cannot open $file:$!"; -while () - { - if (/^(From|Subject|Date|Message-ID):(.*)$/i) - { - $meta{lc($1)} = $2; - } - } -my @results = `patch @ARGV <$file 2>&1`; -warn @results; -my $code = $?; -warn "$code from patch\n"; -foreach (@results) - { - if (/[Pp]atching\s+file\s*(\S+)/) - { - push(@edit,$1); - } - } -my @have = `p4 have @edit`; - -if ($code == 0) - { - System("p4 edit @edit"); - open(PIPE,"|p4 change -i") || die "Cannot open pipe to p4:$!"; - print PIPE "Change: new\n"; - print PIPE "Description:\n"; - foreach my $key (qw(Subject From Date Message-Id)) - { - if (exists $meta{lc($key)}) - { - print PIPE "\t$key: ",$meta{lc($key)},"\n"; - print "$key: ",$meta{lc($key)},"\n"; - } - } - print PIPE "Files:\n"; - foreach (@have) - { - if (m,^(.*)#,) - { - print PIPE "\t$1\n" - } - } - close(PIPE); - } -else - { - if (@edit) - { - System("p4 refresh @edit"); - } - } - -sub System -{ - my $cmd = join(' ',@_); - warn "$cmd\n"; - if (fork) - { - wait; - } - else - { - _exit(exec $cmd); - } -} - diff --git a/Porting/p4d2p b/Porting/p4d2p deleted file mode 100755 index 8003bf7..0000000 --- a/Porting/p4d2p +++ /dev/null @@ -1,84 +0,0 @@ -#!/usr/bin/perl -wspi~ - -# -# reads a perforce style diff on stdin and outputs appropriate headers -# so the diff can be applied with the patch program -# -# Gurusamy Sarathy -# - -BEGIN { - $0 =~ s|.*/||; - if ($h or $help) { - print STDERR < change-123.patch - -USAGE - exit(0); - } - unless (@ARGV) { @ARGV = '-'; undef $^I; } - use vars qw($thisfile $time $file $fnum $v $h $help); - $thisfile = ""; - $time = localtime(time); -} - -my ($cur, $match); -$cur = m<^==== //depot/(.+?)\#\d+.* ====( \w+)?$> ... m<^(\@\@.+\@\@|\*+)$>; - -$match = $1; - -if ($ARGV ne $thisfile) { - warn "processing patchfile [$ARGV]\n" unless $ARGV eq '-'; - $thisfile = $ARGV; -} - -# while we are within range -if ($cur) { - # set the file name after first line - if ($cur == 1) { - $file = $match; - $fnum++; - } - # emit the diff header when we hit last line - elsif ($cur =~ /E0$/) { - my $f = $file; - - # special hack for perl so we can always use "patch -p1" - $f =~ s<^.*?(perl.*?/)><$1>; - - # unified diff - if ($match =~ /^\@/) { - warn "emitting udiff header\n" if $v; - $_ = "Index: $f\n--- $f.~1~\t$time\n+++ $f\t$time\n$_"; - } - # context diff - elsif ($match =~ /^\*/) { - warn "emitting cdiff header\n" if $v; - $_ = "Index: $f\n*** $f.~1~\t$time\n--- $f\t$time\n$_"; - } - } - # see if we hit another patch (i.e. previous patch was empty) - elsif (m<^==== //depot/(.+?)\#\d+.* ====( \w+)?$>) { - $file = $match = $1; - } - # suppress all other lines in the header - else { - $_ = ""; - } - warn "file [$file] line [$cur] file# [$fnum]\n" if $v; -} - -$_ .= "End of Patch.\n" if eof; diff --git a/Porting/p4genpatch b/Porting/p4genpatch deleted file mode 100644 index 543baa9..0000000 --- a/Porting/p4genpatch +++ /dev/null @@ -1,182 +0,0 @@ -#!/usr/bin/perl -w - - -# p4genpatch - Generate a perl patch from the repository - -# Usage: $0 -h - -# andreas.koenig@anima.de - -use strict; -use File::Temp qw(tempdir); -use File::Compare; -use File::Spec; -use File::Spec::Unix; -use Time::Local; -use Getopt::Long; -use Cwd qw(cwd); - -sub correctmtime ($$$); -sub Usage (); - -$0 =~ s|^.*[\\/]||; -my $VERSION = '0.05'; -my $TOPDIR = cwd(); -my @P4opt; -our %OPT = ( "d" => "u", b => "//depot/perl/", "D" => "diff" ); -Getopt::Long::Configure("no_ignore_case"); -GetOptions(\%OPT, "b=s", "p=s", "d=s", "D=s", "h", "v", "V") or die Usage; -print Usage and exit if $OPT{h}; -print "$VERSION\n" and exit if $OPT{V}; -die Usage unless @ARGV == 1 && $ARGV[0] =~ /^\d+$/; -my $CHANGE = shift; - -for my $p4opt (qw(p)) { - push @P4opt, "-$p4opt $OPT{$p4opt}" if $OPT{$p4opt}; -} - -my $system = "p4 @P4opt describe -s $CHANGE |"; -open my $p4, $system or die "Could not run $system"; -my @action; -while (<$p4>) { - print; - next unless m|($OPT{b})|; - my($prefix) = $1; - $prefix =~ s|/$||; - $prefix =~ s|/[^/]+$||; # up to the last "/" in the match is to be stripped - if (my($file,$action) = m|^\.\.\. (//depot.*)\s(\w+)$|) { - next if $action eq "delete"; - push @action, [$action, $file, $prefix]; - } -} -close $p4; - -my $tempdir; -my @unlink; -print "Differences ...\n"; -for my $a (@action) { - $tempdir ||= tempdir( "tmp-XXXX", CLEANUP => 1, TMPDIR => 1 ); - @unlink = (); - my($action,$file,$prefix) = @$a; - my($path,$basename,$number) = $file =~ m|\Q$prefix\E/(.+/)?([^/]+)#(\d+)|; - - my @splitdir = File::Spec::Unix->splitdir($path); - $path = File::Spec->catdir(@splitdir); - - my($depotfile) = $file =~ m|^(.+)#\d+\z|; - die "Panic: Could not parse file[$file]" unless $number; - $path = "" unless defined $path; - my($d1,$d2,$prev,$prevchange,$prevfile,$doadd,$t1,$t2); - $prev = $number-1; - $prevchange = $CHANGE-1; - # can't assume previous rev == $number-1 due to obliterated revisions - $prevfile = "$depotfile\@$prevchange"; - if ($number == 1 or $action =~ /^(add|branch)$/) { - $d1 = $^O eq 'MacOS' ? File::Spec->devnull : "/dev/null"; - $t1 = $d1; - ++$doadd; - } elsif ($action =~ /^(edit|integrate)$/) { - $d1 = File::Spec->catfile($path, "$basename-$prevchange"); - $t1 = File::Spec->catfile($tempdir, $d1); - warn "==> $d1 <==\n" if $OPT{v}; - my $system = qq[p4 @P4opt print -o "$t1" "$prevfile"]; - my $status = `$system`; - if ($?) { - warn "$0: system[$system] failed, status[$?]\n"; - next; - } - chmod 0644, $t1; - if ($status =~ /\#(\d+) \s - \s \w+ \s change \s (\d+) \s /x) { - ($prev,$prevchange) = ($1,$2); - $prevfile = "$depotfile#$prev"; - my $oldd1 = $d1; - $d1 =~ s/-\d+$/#$prev~$prevchange~/; - my $oldt1 = $t1; - $t1 = File::Spec->catfile($tempdir, $d1); - rename $oldt1, $t1; - } - push @unlink, $t1; - } else { - die "Unknown action[$action]"; - } - $d2 = File::Spec->catfile($path, $basename); - $t2 = File::Spec->catfile($tempdir, $d2); - push @unlink, $t2; - warn "==> $d2#$number <==\n" if $OPT{v}; - my $system = qq[p4 @P4opt print -o "$t2" "$file"]; - # warn "system[$system]"; - my $type = `$system`; - if ($?) { - warn "$0: `$system` failed, status[$?]\n"; - next; - } - chmod 0644, $t2; - $type =~ m|^//.*\((.+)\)$| or next; - $type = $1; - if ($doadd or File::Compare::compare($t1, $t2)) { - print "\n==== $file ($type) ====\n"; - unless ($type =~ /text/) { - next; - } - unless ($^O eq 'MacOS') { - $d1 =~ s,\\,/,g; - $d2 =~ s,\\,/,g; - } - print "Index: $d2\n"; - correctmtime($prevfile,$prev,$t1) unless $doadd; - correctmtime($file,$number,$t2); - chdir $tempdir or warn "Could not chdir '$tempdir': $!"; - $system = qq[$OPT{D} -$OPT{d} "$d1" "$d2"]; - system($system); # no return check because diff doesn't always return 0 - chdir $TOPDIR or warn "Could not chdir '$TOPDIR': $!"; - } -} -continue { - for (@unlink) { - unlink or warn "Could not unlink $_: $!" if -f; - } -} -print "End of Patch.\n"; - -my($tz_offset); -sub correctmtime ($$$) { - my($depotfile,$nr,$localfile) = @_; - my %fstat = map { /^\.\.\. (\w+) (.*)$/ } `p4 @P4opt fstat -s "$depotfile"`; - return unless exists($fstat{headRev}) and $fstat{headRev} == $nr; - - if ($^O eq 'MacOS') { # fix epoch ... still off by three hours (EDT->PDT) - require Time::Local; - $tz_offset ||= sprintf "%+0.4d\n", ( - Time::Local::timelocal(localtime) - Time::Local::timelocal(gmtime) - ); - $fstat{headTime} += 2082844801 + $tz_offset; - } - - utime $fstat{headTime}, $fstat{headTime}, $localfile; -} - -sub Usage () { - qq{Usage: $0 [OPTIONS] patchnumber - - -p host:port p4 port (e.g. myhost:1666) - -d diffopt option to pass to diff(1) - -D diff diff(1) to use - -b branch(es) which branches to include (regex); the last - directory within the matched part will be - preserved on the local copy, so that patch -p1 - will work (default: "//depot/perl/") - -v verbose - -h print this help and exit - -V print version number and exit - -Fetches all required files from the repository, puts them into a -temporary directory with sensible names and sensible modification -times and composes a patch to STDOUT using external diff command. -Requires repository access. - -Examples: - perl $0 12345 | gzip -c > 12345.gz - perl $0 -dc 12345 > change-12345.patch - perl $0 -b //depot/maint-5.6/perl -v 8571 > 8571 -}; -} diff --git a/Porting/patchls b/Porting/patchls deleted file mode 100644 index 1803ef7..0000000 --- a/Porting/patchls +++ /dev/null @@ -1,574 +0,0 @@ -#!/usr/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 () { - 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 (); - $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; -} - -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; -} -