add support for TEXMFSYSCONFIG/tlmgr/pinning show the available pins in tlmgr candidate and mark the winning one with * --- texmf/scripts/texlive/tlmgr.pl | 102 +++++++++++++++++++++++++++++++++++++++-- 1 file changed, 99 insertions(+), 3 deletions(-) Index: Master/texmf/scripts/texlive/tlmgr.pl =================================================================== --- Master.orig/texmf/scripts/texlive/tlmgr.pl 2010-05-05 03:22:16.000000000 +0900 +++ Master/texmf/scripts/texlive/tlmgr.pl 2010-05-05 03:22:24.000000000 +0900 @@ -71,6 +71,7 @@ use Cwd qw/abs_path/; use Digest::MD5; +use Text::Glob qw( match_glob); use Pod::Usage; use Getopt::Long qw(:config no_autoabbrev permute); use strict; @@ -90,6 +91,7 @@ binmode(STDERR, ":utf8"); our %config; # hash of config settings from config file +our %Pin; # $pin{$tag}{$package} our $tlmediasrc; # media from which we install/update our %tlmediasrcs; our $tlmediatlpdb; @@ -333,6 +335,9 @@ # load the config file and set the config options # load it BEFORE starting downloads as we seet persistent-downloads there! load_config_file(); + # + # load pinning file + load_pinning_file(); # # if we are asked to use persistent connections try to start it here @@ -3134,18 +3139,28 @@ init_local_db(1); init_tlmedias(); foreach my $pkg (@ARGV) { - my @l = (); + my %pkgpin = (); + my %revs = (); + my $maxsrc = ""; + my $maxpin = "-1"; for my $s (keys %tlmediasrcs) { info("trying $s ...\n"); my $tlp = $tlmediatlpdbs{$s}->get_package($pkg); if ($tlp) { - push @l, "$s (" . $tlp->revision . ")"; + $revs{$s} = $tlp->revision; + $pkgpin{$s} = get_pin($s,$pkg); + if ($maxpin < $pkgpin{$s}) { + $maxsrc = $s; + $maxpin = $pkgpin{$s}; + } } } + my @l = sort keys %pkgpin; if (@l) { info("$pkg:\n"); for my $f (@l) { - info("\t$f\n"); + info(($f eq $maxsrc ? "\t*" : "\t ")); + info("$f ($revs{$f}) [$pkgpin{$f}]\n"); } } else { info("No installation candidate for $pkg\n"); @@ -4541,6 +4556,87 @@ close(TLC); } +# +# pinning file handling +# location +# TEXMFSYSCONFIG/tlmgr/pinning +# (it is only globally useful!) +# format +# # are comments +# empty lines are ignored +# package:tag:pin +# where package is a glob, tag a tag (no * allowed, what for!), +# pin between 0 and 1000 +# tags identify repositories, so they can also be the urls +# +# +# Format in memory: +# $Pin{$tag}{$package} but $tag can NOT be "*" +# +sub load_pinning_file +{ + # + chomp (my $TEXMFSYSCONFIG = `kpsewhich -var-value=TEXMFSYSCONFIG`); + my $fn = "$TEXMFSYSCONFIG/tlmgr/pinning"; + if (-r $fn) { + if (!open(TLC, "<$fn")) { + tlwarn("Cannot open $fn: $!"); + return; + } + while () { + if (m/^\s*$/) { next; } + if (m/^\s*#/) { next; } + # TODO + # check that we can enter all URL chars in [\w-]+ ?! + if (m/^\s*([*\w-]+)\s*:\s*([\w-]+)\s*:\s*([*\w-]+)\s*$/) { + my $package = $1; + my $tag = $2; + my $pin = $3; + if ($pin !~ m/^[0-9]+/) { + tlwarn("Pin $pin is not numeric, ignoring it.\n"); + next; + } + if ($pin < 0 || $pin > 1000) { + tlwarn ("Pin $pin out of range (0-1000), ignoring.\n"); + next; + } + $Pin{$tag}{$package} = $pin; + next; + } + tlwarn("I cannot understand the following line in $fn:\n$_\n"); + next; + } + close(TLC); + } +} + +sub match_package +{ + my ($package, $p) = @_; + return 1 if match_glob( $p, $package); +} + +# +# compute the pin of $package/$tag +sub get_pin +{ + my ($tag, $package) = @_; + # the following three pins collect that pins set by: + my $pin; + if (defined($Pin{$tag})) { + # for this tag some pin specifications are provided, go through + # all of them and check them + my %foo = %{$Pin{$tag}}; + for my $p (keys %foo) { + $pin = $foo{$p} if match_package($package, $p); + } + return $pin if defined($pin); + } + # default pin + return 500; +} + + # if the packagelog variable is set then write to PACKAGELOG filehandle # sub logpackage