+++ /dev/null
-#!/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
-};
-}
+++ /dev/null
-#!/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 (<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;
-}
-
projects / p5sagit/p5-mst-13.2.git / commitdiff