This is the mail archive of the cygwin-apps mailing list for the Cygwin project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: upset, genini: different version ordering


Achim Gratz writes:
> I've just found that upset and genini will order versions differently.

Here's a patch for genini that will take care of the versions in a
better way than before, and it's extensible (in genini) and configurable
(from setup.hint) if you're into that kind of thing.  It's also largely
compatible to how upset treats things, to the extent that I understand
what upset is doing.  The code in genini should be able to be integrated
into upset to have both tools share their world-view, since I fixed some
things that bothered me about upset along the way (treatment of
pre-releases, mostly).  It'll need a bit more polishing, but keep the
comments coming.

? genini.cvs.diff
Index: genini
===================================================================
RCS file: /cvs/cygwin-apps/genini/genini,v
retrieving revision 1.16
diff -u -p -r1.16 genini
--- genini	23 Jun 2015 17:50:00 -0000	1.16
+++ genini	18 Aug 2015 18:25:03 -0000
@@ -9,7 +9,7 @@ use File::Basename;
 use Digest::MD5;
 use Digest::SHA;
 use Getopt::Long;
-
+use version 0.77 qw( is_lax );
 use strict;
 
 sub mywarn(@);
@@ -23,6 +23,8 @@ my $arch = 'x86';
 my $digest = 'sha512';
 my $release;
 my @cmp_fmts = qw(xz bz2 lzma gz);
+my $cmp_fmts_grep = join('|', @cmp_fmts);
+my $cmp_fmts_glob = join(',', @cmp_fmts);
 
 GetOptions('okmissing=s'=>\@okmissing,
 	   'output=s'=>\$outfile,
@@ -33,6 +35,81 @@ GetOptions('okmissing=s'=>\@okmissing,
 	   'recursive'=>\$recursive) or usage;
 $help and usage;
 
+my %vercmp;
+%vercmp = (
+    naturally => sub { # mostly from Sort::Naturally
+	my @A = (parsever($a) =~ /([-.]|\d+|[^-.\d]+)/g);
+	my @B = (parsever($b) =~ /([-.]|\d+|[^-.\d]+)/g);
+	my ($A, $B);
+	my ($Adash, $Bdash, $Adot, $Bdot);
+	while (@A and @B) {
+	    $A = shift @A; $B = shift @B;
+	    ($Adash, $Bdash, $Adot, $Bdot) =
+		($A eq '-', $B eq '-', $A eq '.', $B eq '.');
+	    if ($Adash and $Bdash) {
+		next;
+	    } elsif ( $Adash ) {
+		return -1;
+	    } elsif ( $Bdash) {
+		return 1;
+	    } elsif ($Adot and $Bdot) {
+		next;
+	    } elsif ( $Adot ) {
+		return -1;
+	    } elsif ( $Bdot ) {
+		return 1;
+	    } elsif ($A =~ /\A\d+\Z/ and $B =~ /\A\d+\Z/) {
+		my $ab;
+		if ($A =~ /^0/ || $B =~ /^0/) {
+		    $ab = $A cmp $B;
+		} else {
+		    $ab = $A <=> $B;
+		}
+		return $ab if $ab;
+	    } else {
+		$A = uc $A;
+		$B = uc $B;
+		my $ab = $A cmp $B;
+		return $ab if $ab;
+	    }
+	}
+	# all components have compared equal so far, the array with
+	# the larger number of entries wins (at least one is empty)
+	my $ab = @A <=> @B;
+	# however, if it was a pre-release version of some sort, then
+	# it should order before the final
+	$A = ($ab > 0 ) ? shift @A : shift @B;
+	my $Adashdot = ( $A =~ m/-./ );
+	$A = ($ab > 0 ) ? shift @A : shift @B if $Adashdot;
+	my $Arc = ( $A =~ m/\A(pre|rc|alpha|beta|b\d+)/i );
+	return $Arc ? -$ab : $ab;
+    },
+    natural => sub {
+	my (undef, $av, $ar) = parsever($a);
+	my (undef, $bv, $br) = parsever($b);
+	map {
+	    # ISO date most likely
+	    s/g(?:it)?((?:19|20)[0-9]{2}(?:0[1-9]|1[012])(?:0[1-9]|[12][0-9]|3[01]))/\1/ig;
+	    # SHA1 not orderable
+	    s/g(?:it)?[0-9a-f]+/git/ig;
+	    s/[+~_]+/./g;
+	} ( \$av, \$bv );
+	return $vercmp{naturally}($av, $bv) ||
+	    $vercmp{naturally}($ar, $br);
+    },
+    perl => sub {
+	my (undef, $av, $ar) = parsever($a);
+	my (undef, $bv, $br) = parsever($b);
+	return (is_lax($av) && is_lax($bv)
+		? (version->parse($av) <=> version->parse($bv))
+		: $vercmp{natural}($av, $bv)) ||
+	    $vercmp{natural}($ar, $br);
+    },
+    lexical => sub {
+	$a cmp $b;
+    },
+    );
+
 @main::okmissing{@okmissing} = @okmissing;
 
 sub arch_handler (@) {
@@ -81,7 +158,8 @@ for my $p (sort keys %pkg) {
     print "\n@ $p\n";
     for my $key ('sdesc', 'ldesc', 'category', 'requires', 'message') {
 	my $val = $pkg{$p}{''}{$key};
-	if (!defined($val) && $pkg{$p}{''}{'install'} !~ /_obsolete/o) {
+	my $pobsolete = ( $pkg{$p}{''}{'install'} =~ m:/_obsolete/:o );
+	if (!defined($val) && !$pobsolete) {
 	    mywarn "package $p is missing a $key field"
 	      unless defined $main::okmissing{$key};
 	} else {
@@ -128,7 +206,7 @@ sub get {
 	    s/(\S)\s+$/$1/;
 	    $val .= "\n" . $_;
 	}
-    } 
+    }
     $val =~ s/(.)"(.)/$1'$2/mog;
     return $val;
 }
@@ -206,26 +284,30 @@ sub parsedir {
     return unless -e $setup_hint;
     parse("$setup_hint", $pname);
     next unless exists $pkg{$pname};
+    my $pobsolete = ( $d =~ m:/_obsolete/:o );
     my $explicit = 0;
     for my $what ('', "[prev]\n", "[test]\n") {
 	my $x = $pkg{$pname}{$what};
+	$x->{'obsolete'} = $pobsolete;
 	next unless $x->{'version'};
 	$explicit = 1;
 	addfiles($pname, $x, $d);
     }
-
     return if $explicit;
-    my $cmp_fmts_grep = join('|', @cmp_fmts);
-    my $cmp_fmts_glob = join(',', @cmp_fmts);
-    my @files = sort grep{!/-src\.tar\.($cmp_fmts_grep)/} glob("$d/*.tar.{$cmp_fmts_glob}");
+    $pkg{$pname}{''}{'version-order'} //= ($pname =~ m(\Aperl(?:[_-].+)?\Z)) ? "perl" : "natural";
+    my $vercmp = $vercmp{$pkg{$pname}{''}{'version-order'}} //
+	( myerror("unknown version ordering requested by package '$pname'"), $vercmp{'natural'} );
+    my @files = sort $vercmp grep{!/-src\.tar\.($cmp_fmts_grep)/} glob("$d/*.tar.{$cmp_fmts_glob}");
     if (!@files) {
-	myerror "not enough package files in $d";
+	@files = glob("$d/*-src.tar.{$cmp_fmts_glob}"); # source-only package?
+	myerror "not enough package files in $d" unless @files;
 	return;
     }
     for my $what ('', "[prev]\n") {
 	my $f = pop @files or last;
 	$pkg{$pname}{$what}{-unused} = 1;
 	my $x = $pkg{$pname}{$what};
+	$x->{'obsolete'} = $pobsolete;
 	my $p;
 	($p, $x->{'version'}) = getver($f);
 	addfiles($p, $x, $d);
@@ -244,14 +326,20 @@ sub addfiles {
 	$d = finddir($d, $pname) or return;
     }
 
-    my $source  = tarball($d, $pname, $x->{'version'}, 'src');
+    my $source = tarball($d, $pname, $x->{'version'}, 'src');
     filer($x, 'source', $source);
 }
 
 sub getver {
-    my $f = basename($_[0]);
-    my @a = ($f =~ /^(.*?)-(\d.*)\.tar/);
-    return wantarray ? @a : $a[1];
+    my $fn = basename shift;
+    my ($pn, $vr) = ($fn =~ m|\A(.*?)-(\d.*)\.tar\.($cmp_fmts_grep)\Z|);
+    return wantarray ? ($pn, $vr) : $vr;
+}
+
+sub parsever {
+    my ($pn, $vr) = getver(shift);
+    my ($v, $r) = ($vr =~ m|\A(\d.*?)-(\d.*)\Z|);
+    return wantarray ? ($pn, $v//$vr, $r//0) : $vr;
 }
 
 sub filer {
@@ -259,7 +347,8 @@ sub filer {
     my $what = shift;
     my $f = shift;
     open(*F, '<', $f) or do {
-	myerror "can't open $f - $!" unless $main::okmissing{$what};
+	myerror "can't open $f - $!"
+	    unless $main::okmissing{$what} or $x->{'obsolete'};
 	return undef;
     };
     my ( $chk, $sum );
@@ -280,15 +369,9 @@ sub filer {
 
 sub tarball {
     my $d = shift;
-    my $b = join('-', @_) . '.tar.';
-    for my $e (@cmp_fmts) {
-      my $f = "$d/" . "$b" . "$e";
-      if (-e "$f") {
-        return "$f";
-      }
-    }
-    # default to .nf (because we know it is missing)
-    return "$d/" . "$b" . "nf";
+    my $fg = "$d/" . join('-', @_) . ".tar.{$cmp_fmts_glob}";
+    my ($f, undef) = grep {-e} glob($fg);
+    return $f // $fg;
 }
 
 sub fnln {
@@ -306,7 +389,7 @@ sub myerror(@) {
 sub finddir {
     my $d = $_[0];
     my $pname = $_[1];
-    while (($d = dirname($d)) ne '.' && length($d)) {
+    while (($d = dirname($d)) && (length($d) > 1)) {
 	return "$d/$pname" if -d "$d/$pname";
     }
     myerror "couldn't find package directory for external-source '$pname'";

Regards,
Achim.
-- 
+<[Q+ Matrix-12 WAVE#46+305 Neuron microQkb Andromeda XTk Blofeld]>+

Waldorf MIDI Implementation & additional documentation:
http://Synth.Stromeko.net/Downloads.html#WaldorfDocs

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]