From eb33a2d66c3ea70f0631a772a4deb9ba2371da8b Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Tue, 10 May 2011 05:58:33 +0000 Subject: update multi-source-support to be more specific and inform the user on the fact from which a package is installed git-svn-id: svn://tug.org/texlive/trunk@22400 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/dev/dev.multi-source-support-v2.patch | 2186 +++++++++++--------- 1 file changed, 1164 insertions(+), 1022 deletions(-) (limited to 'Master/tlpkg/dev') diff --git a/Master/tlpkg/dev/dev.multi-source-support-v2.patch b/Master/tlpkg/dev/dev.multi-source-support-v2.patch index e87a772a1f3..649177ba952 100644 --- a/Master/tlpkg/dev/dev.multi-source-support-v2.patch +++ b/Master/tlpkg/dev/dev.multi-source-support-v2.patch @@ -1,1140 +1,1282 @@ -Index: tlpkg/TeXLive/TLPDB.pm +Index: texmf/scripts/texlive/tlmgr.pl =================================================================== ---- tlpkg/TeXLive/TLPDB.pm (revision 22343) -+++ tlpkg/TeXLive/TLPDB.pm (working copy) -@@ -73,17 +73,27 @@ - $tlpdb->install_package($pkg, $dest_tlpdb, $nopostinstall, $fallbacktlpdb); - $tlpdb->remove_package($pkg, %options); - -- - TeXLive::TLPDB->listdir([$dir]); - $tlpdb->generate_listfiles([$destdir]); - -+ $tlpdb->make_virtual; -+ $tlpdb->is_virtual; -+ $tlpdb->virtual_add_tlpdb($tlpdb, $tag); -+ $tlpdb->virtual_remove_tlpdb($tag); -+ $tlpdb->virtual_get_package($pkg, $tag); -+ $tlpdb->candidates($pkg); -+ $tlpdb->virtual_candidate($pkg); -+ $tlpdb->virtual_pinning( [@tlpkpins ] ); -+ - =head1 DESCRIPTION - - =cut - --use TeXLive::TLConfig; -+use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory $InfraLocation -+ $DatabaseName $MetaCategoriesRegexp $Archive -+ %TLPDBOptions %TLPDBSettings); - use TeXLive::TLUtils qw(dirname mkdirhier member win32 info log debug ddebug -- tlwarn basename download_file merge_into); -+ tlwarn basename download_file merge_into tldie); - use TeXLive::TLPOBJ; - - use Cwd 'abs_path'; -@@ -158,6 +168,10 @@ - - sub add_tlpobj { - my ($self,$tlp) = @_; -+ if ($self->is_virtual) { -+ tlwarn("cannot add tlpobj to a virtual tlpdb\n"); -+ return 0; -+ } - $self->{'tlps'}{$tlp->name} = $tlp; - } - -@@ -206,6 +220,10 @@ - - sub remove_tlpobj { - my ($self,$pkg) = @_; -+ if ($self->is_virtual) { -+ tlwarn("cannot remove tlpobj from a virtual tlpdb\n"); -+ return 0; -+ } - if (defined($self->{'tlps'}{$pkg})) { - delete $self->{'tlps'}{$pkg}; - } else { -@@ -226,6 +244,10 @@ - - sub from_file { - my ($self, $path) = @_; -+ if ($self->is_virtual) { -+ tlwarn("cannot initialize from file a virtual tlpdb\n"); -+ return 0; -+ } - if (@_ != 2) { - die "$0: from_file needs filename for initialization"; +--- texmf/scripts/texlive/tlmgr.pl (revision 22399) ++++ texmf/scripts/texlive/tlmgr.pl (working copy) +@@ -124,6 +124,7 @@ + "package-logfile" => "=s", + "persistent-downloads" => "!", + "no-execute-actions" => 1, ++ "pin-file" => "=s", + "pause" => 1, + "print-platform|print-arch" => 1, + "version" => 1, +@@ -480,6 +481,12 @@ + } elsif ($action =~ m/^option$/i) { + action_option(); + finish(0); ++ } elsif ($action =~ m/^repository$/i) { ++ action_repository(); ++ finish(0); ++ } elsif ($action =~ m/^candidates$/i) { ++ action_candidates(); ++ finish(0); + } elsif ($action =~ m/^list$/i) { + action_list(); + finish(0); +@@ -1941,7 +1948,12 @@ + # intersection, don't check A\B and B\A + next if $newpkgs_full{$p}; + next if $removals_full{$p}; +- next if ($remotetlpdb->get_package($p)->category ne "Collection"); ++ my $remotetlp = $remotetlpdb->get_package($p); ++ if (!defined($remotetlp)) { ++ tlwarn("Strange, $p mentioned but not found anywhere!\n"); ++ next; ++ } ++ next if ($remotetlp->category ne "Collection"); + my $tlp = $localtlpdb->get_package($p); + if (!defined($tlp)) { + if ($opts{"reinstall-forcibly-removed"}) { +@@ -2042,12 +2054,15 @@ + $ret = 1; + shift; } -@@ -350,6 +372,10 @@ - - sub writeout { - my $self = shift; -+ if ($self->is_virtual) { -+ tlwarn("cannot write out a virtual tlpdb\n"); -+ return 0; -+ } - my $fd = (@_ ? $_[0] : STDOUT); - foreach (sort keys %{$self->{'tlps'}}) { - ddebug("writeout: tlpname=$_ ", $self->{'tlps'}{$_}->name, "\n"); -@@ -369,6 +395,10 @@ - - sub save { - my $self = shift; -+ if ($self->is_virtual) { -+ tlwarn("cannot save a virtual tlpdb\n"); -+ return 0; -+ } - my $path = $self->location; - mkdirhier(dirname($path)); - my $tmppath = "$path.tmp"; -@@ -390,6 +420,9 @@ - - sub media { - my $self = shift ; -+ if ($self->is_virtual) { -+ return "virtual"; -+ } - return $self->{'media'}; +- my ($pkg, $flag, $lrev, $rrev, @args) = @_; ++ my ($pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag) = @_; + $lrev ||= "-"; + $rrev ||= "-"; + $flag ||= "?"; +- my $str = "$pkg\t$flag\t$lrev\t$rrev\t"; +- $str .= join("\t", @args) if (@args); ++ $size ||= "-"; ++ $runtime ||= "-"; ++ $esttot ||= "-"; ++ $tag ||= "-"; ++ my $str = join("\t", $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag); + $str .= "\n"; + return($str) if $ret; + print $str; +@@ -2571,19 +2586,32 @@ + my $unwind_package; + my $remove_unwind_container = 0; + my $rev = $tlp->revision; +- my $mediatlp = $remotetlpdb->get_package($pkg); ++ my $mediatlp; ++ my $maxtag; ++ if ($remotetlpdb->is_virtual) { ++ ($maxtag, undef, $mediatlp, undef) = ++ $remotetlpdb->virtual_candidate($pkg); ++ } else { ++ $mediatlp = $remotetlpdb->get_package($pkg); ++ } + if (!defined($mediatlp)) { + debug("$pkg cannot be found in $location\n"); + next; + } + my $mediarev = $mediatlp->revision; ++ my $mediarevstr = $mediarev; ++ my @addargs = (); ++ if ($remotetlpdb->is_virtual) { ++ push @addargs, $maxtag; ++ $mediarevstr .= "\@$maxtag"; ++ } + $nrupdated++; + if ($opts{"list"}) { + if ($::machinereadable) { +- machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg}); ++ machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg}, "-", "-", @addargs); + } else { + my $kb = int($sizes{$pkg} / 1024) + 1; +- info("$pkg [${kb}k]: local: $rev, source: $mediarev (update)\n"); ++ info("$pkg [${kb}k]: local: $rev, source: $mediarevstr (update)\n"); + } + $updated{$pkg} = 1; + next; +@@ -2624,10 +2652,10 @@ + } + + if ($::machinereadable) { +- machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg}, $estrem, $esttot); ++ machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg}, $estrem, $esttot, @addargs); + } else { + my $kb = int ($sizes{$pkg} / 1024) + 1; +- info("[$currnr/$totalnr, $estrem/$esttot] update: $pkg [${kb}k] ($rev -> $mediarev)"); ++ info("[$currnr/$totalnr, $estrem/$esttot] update: $pkg [${kb}k] ($rev -> $mediarevstr)"); + } + $donesize += $sizes{$pkg}; + $currnr++; +@@ -2670,7 +2698,7 @@ + } + if ($remotetlpdb->install_package($pkg, $localtlpdb)) { + # installation succeeded because we got a reference +- logpackage("update: $pkg ($rev -> $mediarev)"); ++ logpackage("update: $pkg ($rev -> $mediarevstr)"); + unlink($unwind_package) if $remove_unwind_container; + # remember successful update + $updated{$pkg} = 1; +@@ -2698,7 +2726,7 @@ + # now in fact we should do some cleanup, removing files and + # dirs from the new package before re-installing the old one. + # TODO +- logpackage("failed update: $pkg ($rev -> $mediarev)"); ++ logpackage("failed update: $pkg ($rev -> $mediarevstr)"); + tlwarn("\n\nInstallation of new version of $pkg did fail, trying to unwind.\n"); + if (win32()) { + # w32 is notorious for not releasing a file immediately +@@ -2739,12 +2767,25 @@ + unless $::machinereadable; + } else { + # install new packages +- my $mediatlp = $remotetlpdb->get_package($pkg); ++ my $mediatlp; ++ my $maxtag; ++ if ($remotetlpdb->is_virtual) { ++ ($maxtag, undef, $mediatlp, undef) = ++ $remotetlpdb->virtual_candidate($pkg); ++ } else { ++ $mediatlp = $remotetlpdb->get_package($pkg); ++ } + if (!defined($mediatlp)) { + tlwarn("\nShould not happen: $pkg not found in $location"); + next; + } + my $mediarev = $mediatlp->revision; ++ my $mediarevstr; ++ my @addargs; ++ if ($remotetlpdb->is_virtual) { ++ $mediarevstr = "$mediarev\@$maxtag"; ++ push @addargs, $maxtag; ++ } + my ($estrem, $esttot); + if (!$opts{"list"}) { + ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize, +@@ -2754,14 +2795,16 @@ + my @maargs = ($pkg, $FLAG_AUTOINSTALL, "-", $mediatlp->revision, $sizes{$pkg}); + if (!$opts{"list"}) { + push @maargs, $estrem, $esttot; ++ } else { ++ push @maargs, undef, undef; + } +- machine_line(@maargs); ++ machine_line(@maargs, @addargs); + } else { + my $kb = int($sizes{$pkg} / 1024) + 1; + if ($opts{"list"}) { +- info("$pkg [${kb}k]: local: , source: " . $mediatlp->revision . " (auto-install)\n"); ++ info("$pkg [${kb}k]: local: , source: $mediarevstr (auto-install)\n"); + } else { +- info("[$currnr/$totalnr, $estrem/$esttot] auto-install: $pkg [${kb}k]\n"); ++ info("[$currnr/$totalnr, $estrem/$esttot] auto-install: $pkg ($mediarevstr) [${kb}k]\n"); + } + } + $currnr++; +@@ -2769,7 +2812,7 @@ + next if ($opts{"dry-run"} || $opts{"list"}); + if ($remotetlpdb->install_package($pkg, $localtlpdb)) { + # installation succeeded because we got a reference +- logpackage("auto-install new: $pkg ($mediarev)"); ++ logpackage("auto-install new: $pkg ($mediarevstr)"); + $nrupdated++; + } else { + tlwarn("$0: couldn't install new package $pkg\n"); +@@ -2908,6 +2951,7 @@ + if (!(@new || @updated)) { + info("tlmgr: no updates available\n"); + if ($remotetlpdb->media ne "NET" ++ && $remotetlpdb->media ne "virtual" + && !$opts{"dry-run"} + && !$opts{"repository"} + ) { +@@ -3123,7 +3167,150 @@ + return; } -@@ -405,6 +438,18 @@ ++# REPOSITORY ++# ++# this action manages the list of repositories ++# tlmgr repository list -> lists repositories ++# tlmgr repository add path [tag] -> add repository with optional tag ++# tlmgr repository remove [path|tag] -> removes repository or tag ++# tlmgr repository set path[#tag] [path[#tag] ...] -> sets the list ++# - sub available_architectures { - my $self = shift; -+ my @archs; -+ if ($self->is_virtual) { -+ for my $k (keys %{$self->{'tlpdbs'}}) { -+ push @archs, $self->{'tlpdbs'}{$k}->available_architectures; ++sub array_to_repository { ++ my %r = @_; ++ my @ret; ++ for my $k (keys %r) { ++ my $v = $r{$k}; ++ if ($k eq $v) { ++ push @ret, $k; ++ } else { ++ push @ret, "$v#$k"; + } -+ } else { -+ return $self->_available_architectures; -+ } -+} -+ -+sub _available_architectures { -+ my $self = shift; - my @archs = $self->setting("available_architectures"); - if (! @archs) { - # fall back to the old method checking tex\.* -@@ -432,6 +477,10 @@ - - sub add_tlpcontainer { - my ($self, $package, $ziplocation, $archrefs, $dest) = @_; -+ if ($self->is_virtual) { -+ tlwarn("cannot add tlp container to a virtual tlpdb\n"); -+ return 0; -+ } - my @archs; - if (defined($archrefs)) { - @archs = @$archrefs; -@@ -497,6 +546,16 @@ - - sub get_package { - my ($self,$pkg) = @_; -+ if ($self->is_virtual) { -+ my ($maxsrc, $maxrev, $maxtlp, $maxtlmedia) = $self->virtual_candidate($pkg); -+ return $maxtlp; -+ } else { -+ return $self->_get_package($pkg); + } ++ return "@ret"; +} -+ -+sub _get_package { -+ my ($self,$pkg) = @_; - if (defined($self->{'tlps'}{$pkg})) { - my $ret = $self->{'tlps'}{$pkg}; - return $self->{'tlps'}{$pkg}; -@@ -507,6 +566,35 @@ - - =pod - -+=item C<< $tlpdb->media_of_package($pkg [, $tag]); -+ -+returns the media type of the package. In the virtual case a tag can -+be given and the media of that repository is used, otherwise the -+media of the virtual candidate is given. -+ -+=cut -+ -+sub media_of_package { -+ my ($self, $pkg, $tag) = @_; -+ if ($self->is_virtual) { -+ if (defined($tag)) { -+ if (defined($self->{'tlpdbs'}{$tag})) { -+ return $self->{'tlpdbs'}{$tag}->media; -+ } else { -+ tlwarn ("tag $tag is not known.\n"); -+ return; -+ } ++sub repository_to_array { ++ my $r = shift; ++ my %r; ++ for my $rr (split ' ', $r) { ++ if ($rr =~ m/^([^#]+)#(.*)$/) { ++ $r{$2} = $1; + } else { -+ my (undef,undef,undef,$maxtlpdb) = $self->virtual_candidate($pkg); -+ return $maxtlpdb->media; ++ $r{$rr} = $rr; + } -+ } else { -+ return $self->media; + } ++ return %r; +} -+ -+=pod -+ - =item C<< $tlpdb->list_packages >> - - The C function returns the list of all included packages. -@@ -515,6 +603,15 @@ - - sub list_packages { - my $self = shift; -+ if ($self->is_virtual) { -+ return (sort keys %{$self->{'packages'}}); -+ } else { -+ return $self->_list_packages; -+ } -+} -+ -+sub _list_packages { -+ my $self = shift; - return (sort keys %{$self->{'tlps'}}); - } - -@@ -623,6 +720,7 @@ - - =cut - -+# TODO adapt for searching in *all* tags ??? - sub find_file { - my ($self,$fn) = @_; - my @ret; -@@ -856,6 +954,10 @@ - - sub root { - my $self = shift; -+ if ($self->is_virtual) { -+ tlwarn("cannot set/edit root of a virtual tlpdb\n"); -+ return 0; -+ } - if (@_) { $self->{'root'} = shift } - return $self->{'root'}; - } -@@ -874,7 +976,11 @@ - =cut - - sub location { -- my $self = shift; -+ my $self = shift; -+ if ($self->is_virtual) { -+ tlwarn("cannot get location of a virtual tlpdb\n"); -+ return 0; -+ } - return "$self->{'root'}/$InfraLocation/$DatabaseName"; - } - -@@ -925,8 +1031,14 @@ - - sub config_src_container { - my $self = shift; -- if (defined($self->{'tlps'}{'00texlive.config'})) { -- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); -+ } else { -+ $tlp = $self->{'tlps'}{'00texlive.config'}; -+ } -+ if (defined($tlp)) { -+ foreach my $d ($tlp->depends) { - if ($d =~ m!^container_split_src_files/(.*)$!) { - return "$1"; - } -@@ -946,8 +1058,14 @@ - - sub config_doc_container { - my $self = shift; -- if (defined($self->{'tlps'}{'00texlive.config'})) { -- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); -+ } else { -+ $tlp = $self->{'tlps'}{'00texlive.config'}; -+ } -+ if (defined($tlp)) { -+ foreach my $d ($tlp) { - if ($d =~ m!^container_split_doc_files/(.*)$!) { - return "$1"; - } -@@ -966,8 +1084,14 @@ - - sub config_container_format { - my $self = shift; -- if (defined($self->{'tlps'}{'00texlive.config'})) { -- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); -+ } else { -+ $tlp = $self->{'tlps'}{'00texlive.config'}; -+ } -+ if (defined($tlp)) { -+ foreach my $d ($tlp->depends) { - if ($d =~ m!^container_format/(.*)$!) { - return "$1"; - } -@@ -986,8 +1110,14 @@ - - sub config_release { - my $self = shift; -- if (defined($self->{'tlps'}{'00texlive.config'})) { -- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); -+ } else { -+ $tlp = $self->{'tlps'}{'00texlive.config'}; ++sub action_repository { ++ init_local_db(); ++ my $what = shift @ARGV; ++ $what = "list" if !defined($what); ++ my %repos = repository_to_array($localtlpdb->option("location")); ++ if ($what =~ m/^list$/i) { ++ print "List of repositories (with tags if set):\n"; ++ for my $k (keys %repos) { ++ my $v = $repos{$k}; ++ print "\t$v"; ++ if ($k ne $v) { ++ print " ($k)"; ++ } ++ print "\n"; ++ } ++ return; + } -+ if (defined($tlp)) { -+ foreach my $d ($tlp->depends) { - if ($d =~ m!^release/(.*)$!) { - return "$1"; - } -@@ -1006,8 +1136,14 @@ - - sub config_minrelease { - my $self = shift; -- if (defined($self->{'tlps'}{'00texlive.config'})) { -- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); -+ } else { -+ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ if ($what eq "add") { ++ my $p = shift @ARGV; ++ if (!defined($p)) { ++ tlwarn("You need to give a new repository aas argument to add\n"); ++ return; ++ } ++ my $t = shift @ARGV; ++ $t = $p if (!defined($t)); ++ if (defined($repos{$t})) { ++ tlwarn("This repository or its tag is already defined, no action\n"); ++ return; ++ } ++ # TODO more checks needed? ++ # if there was till now only *one* repository and that without ++ # a tag, we give that one the "main" tag which is necessary ++ # for proper operation! ++ my @tags = keys %repos; ++ if ($#tags == 0) { ++ # we have only one repository, check if it has the main tag ++ my $maintag = $tags[0]; ++ if ($maintag ne 'main') { ++ $repos{'main'} = $repos{$maintag}; ++ delete $repos{$maintag}; ++ } ++ } ++ $repos{$t} = $p; ++ $localtlpdb->option("location", array_to_repository(%repos)); ++ $localtlpdb->save; ++ return; + } -+ if (defined($tlp)) { -+ foreach my $d ($tlp->depends) { - if ($d =~ m!^minrelease/(.*)$!) { - return "$1"; - } -@@ -1027,8 +1163,14 @@ - - sub config_revision { - my $self = shift; -- if (defined($self->{'tlps'}{'00texlive.config'})) { -- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); -+ } else { -+ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ if ($what eq "remove") { ++ my $p = shift @ARGV; ++ if (!defined($p)) { ++ tlwarn("Which repository should be removed?\n"); ++ return; ++ } ++ my $found = 0; ++ for my $k (keys %repos) { ++ if ($k eq $p || $repos{$k} eq $p) { ++ $found = 1; ++ delete $repos{$k}; ++ } ++ } ++ if (!$found) { ++ tlwarn("Cannot find the repository $p\n"); ++ } else { ++ $localtlpdb->option("location", array_to_repository(%repos)); ++ $localtlpdb->save; ++ } ++ return; + } -+ if (defined($tlp)) { -+ foreach my $d ($tlp->depends) { - if ($d =~ m!^revision/(.*)$!) { - return "$1"; - } -@@ -1054,12 +1196,12 @@ - sub sizes_of_packages { - my ($self, $opt_src, $opt_doc, @packs) = @_; - @packs || ( @packs = $self->list_packages() ); -- my $media = $self->media; - my %tlpsizes; - my %tlpobjs; - my $totalsize; - foreach my $p (@packs) { - $tlpobjs{$p} = $self->get_package($p); -+ my $media = $self->media_of_package($p); - if (!defined($tlpobjs{$p})) { - warn "STRANGE: $p not to be found in ", $self->root; - next; -@@ -1083,7 +1225,7 @@ - $size += $tlpobj->srccontainersize if $opt_src; - $size += $tlpobj->doccontainersize if $opt_doc; - } else { -- # we have to add the respective sizes, that is checking for -+ # we have to add the respective sizes, that is checking for - # installation of src and doc file - $size = $tlpobj->runsize; - $size += $tlpobj->srcsize if $opt_src; -@@ -1106,6 +1248,16 @@ - - sub install_package { - my ($self, $pkg, $totlpdb, $nopostinstall, $fallbackmedia) = @_; -+ if ($self->is_virtual) { -+ my ($maxtag, $maxrev, $maxtlp, $maxtlpdb) = $self->virtual_candidate($pkg); -+ return $maxtlpdb->install_package($pkg, $totlpdb, $nopostinstall, $fallbackmedia); -+ } else { -+ return $self->not_virtual_install_package($pkg, $totlpdb, $nopostinstall, $fallbackmedia); ++ if ($what eq "set") { ++ %repos = repository_to_array("@ARGV"); ++ $localtlpdb->option("location", array_to_repository(%repos)); ++ $localtlpdb->save; ++ return; + } ++ # we are still here, unknown command to repository ++ tlwarn("tlmgr: unknown directive to tlmgr repository: $what\n"); ++ return; +} + -+sub not_virtual_install_package { -+ my ($self, $pkg, $totlpdb, $nopostinstall, $fallbackmedia) = @_; - my $fromtlpdb = $self; - my $ret; - die("TLPDB not initialized, cannot find tlpdb!") unless (defined($fromtlpdb)); -@@ -1170,7 +1322,7 @@ - next; - } - } elsif (&media eq 'NET') { -- $container = "$root/$Archive/$pkg.$DefaultContainerExtension"; -+ $container = "$root/$Archive/$pkg.$TeXLive::TLConfig::DefaultContainerExtension"; - } - $self->_install_package ($container, $reloc, \@installfiles, $totlpdb) - || return(0); -@@ -1545,7 +1697,12 @@ - sub _set_value_pkg { - my ($self,$pkgname,$pre,$key,$value) = @_; - my $k = "$pre$key"; -- my $pkg = $self->{'tlps'}{$pkgname}; -+ my $pkg; -+ if ($self->is_virtual) { -+ $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname); -+ } else { -+ $pkg = $self->{'tlps'}{$pkgname}; -+ } - my @newdeps; - if (!defined($pkg)) { - $pkg = new TeXLive::TLPOBJ; -@@ -1583,8 +1740,14 @@ - sub _value_pkg { - my ($self,$pkg,$pre,$key) = @_; - my $k = "$pre$key"; -- if (defined($self->{'tlps'}{$pkg})) { -- foreach my $d ($self->{'tlps'}{$pkg}->depends) { -+ my $tlp; -+ if ($self->is_virtual) { -+ $tlp = $self->{'tlpdbs'}{'main'}->get_package($pkg); -+ } else { -+ $tlp = $self->{'tlps'}{$pkg}; ++sub action_candidates { ++ my $what = shift @ARGV; ++ if (!defined($what)) { ++ tlwarn("tlmgr: action candidates needs a package name as argument\n"); ++ return; + } -+ if (defined($tlp)) { -+ foreach my $d ($tlp->depends) { - if ($d =~ m!^$k:(.*)$!) { - return "$1"; - } -@@ -1697,7 +1860,12 @@ - my ($self, $pre, $hr) = @_; - my @allowed = keys %$hr; - my %ret; -- my $pkg = $self->{'tlps'}{'00texlive.installation'}; -+ my $pkg; -+ if ($self->is_virtual) { -+ $pkg = $self->{'tlpdbs'}{'main'}->get_package('00texlive.installation'); ++ init_local_db(); ++ init_tlmedia(); ++ my @cand = $remotetlpdb->candidates($what); ++ if (@cand) { ++ my $first = shift @cand; ++ if (defined($first)) { ++ my ($t,$r) = split(/\//, $first, 2); ++ print "Install candidate for $what from $t ($r)\n"; ++ } else { ++ print "No install candidate for $what found.\n"; ++ } ++ # already shifted away the first element ++ if ($#cand >= 0) { ++ print "Other repositories providing this package:\n"; ++ for my $a (@cand) { ++ my ($t,$r) = split(/\//, $a, 2); ++ print "$t ($r)\n"; ++ } ++ } + } else { -+ $pkg = $self->{'tlps'}{'00texlive.installation'}; ++ print "Package $what not found.\n"; + } - if (defined($pkg)) { - foreach my $d ($pkg->depends) { - if ($d =~ m!^$pre([^:]*):(.*)!) { -@@ -1846,6 +2014,326 @@ - - =back - -+=head1 VIRTUAL DATABASES -+ -+The purpose of virtual databases is to collect several data sources -+and present them in one way. The normal functions will always return -+the best candidate for the set of functions. -+ -+More docs to be written -+ -+=cut -+ -+# -+# packages are saved: -+# $self->{$pkgname}{'tags'}{$tag}{'revision'} = $rev -+# $self->{$pkgname}{'tags'}{$tag}{'tlp'} = $tlp -+# $self->{$pkgname}{'target'} = $target_tag -+# -+ -+sub is_virtual { -+ my $self = shift; -+ if (defined($self->{'virtual'}) && $self->{'virtual'}) { -+ return 1; -+ } -+ return 0; ++ return; +} + -+sub make_virtual { -+ my $self = shift; -+ if (!$self->is_virtual) { -+ if ($self->list_packages) { -+ tlerror("Cannot convert a initialized tlpdb to virtual for now!\n"); -+ return 0; -+ } -+ $self->{'virtual'} = 1; + # OPTION + # + sub action_option { +@@ -4470,6 +4657,74 @@ + # + sub init_tlmedia + { ++ # first check if $location contains multiple locations ++ # in this case we go to virtual mode ++ #my %repos = repository_to_array($localtlpdb->option("location")); ++ my %repos = repository_to_array($location); ++ my @tags = keys %repos; ++ # check if we are only one tag/repo ++ if ($#tags == 0) { ++ # go to normal mode ++ _init_tlmedia(); ++ return; + } -+ return 1; -+} ++ # we are still here, so we have more tags + -+sub virtual_add_tlpdb { -+ my ($self, $tlpdb, $tag) = @_; -+ if (!$self->is_virtual) { -+ tlerror("Cannot add tlpdb to a non-virtual tlpdb!\n"); -+ return 0; -+ } -+ $self->{'tlpdbs'}{$tag} = $tlpdb; -+ for my $p ($tlpdb->list_packages) { -+ my $tlp = $tlpdb->get_package($p); -+ $self->{'packages'}{$p}{'tags'}{$tag}{'revision'} = $tlp->revision; -+ $self->{'packages'}{$p}{'tags'}{$tag}{'tlp'} = $tlp; ++ # check that there is a main repository ++ if (!TeXLive::TLUtils::member('main', @tags)) { ++ tldie("Cannot find main repository, you have to tag one as main!\n"); + } -+ $self->check_evaluate_pinning(); -+ return 1; -+} + -+sub virtual_remove_tlpdb { -+ my ($self, $tag) = @_; -+ if (!$self->is_virtual) { -+ tlerror("Cannot remove tlpdb from a non-virtual tlpdb!\n"); -+ return 0; -+ } -+ if (!defined($self->{'tlpdbs'}{$tag})) { -+ tlwarn("TLPDB virtual_remove_tlpdb: unknown tag $tag\n"); -+ return 0; -+ } -+ for my $p ($self->{'tlpdbs'}{$tag}->list_packages) { -+ delete $self->{'packages'}{$p}{'tags'}{$tag}; -+ } -+ delete $self->{'tlpdbs'}{$tag}; -+ $self->check_evaluate_pinning(); -+ return 1; -+} ++ # TODO TODO ++ # - abstract the set up of a single media tlpdb ++ # - make clear how to check for a already loaded remotetlpdb ++ $remotetlpdb = TeXLive::TLPDB->new(); ++ $remotetlpdb->make_virtual; + -+sub virtual_get_package { -+ my ($self, $pkg, $tag) = @_; -+ if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { -+ return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; -+ } else { -+ tlwarn("pkg $pkg not found in tag $tag\n"); -+ return; ++ my $locstr = $repos{'main'}; ++ my $tlmdb = setup_one_remotetlpdb($locstr); ++ $remotetlpdb->virtual_add_tlpdb($tlmdb, "main"); ++ for my $t (@tags) { ++ if ($t ne 'main') { ++ my $tlmdb = setup_one_remotetlpdb($repos{$t}); ++ $remotetlpdb->virtual_add_tlpdb($tlmdb, $t); ++ $locstr .= " $repos{$t}"; ++ } + } -+} -+ -+=item C<< $tlpdb->candidates ( $pkg ) >> -+ -+Returns the list of candidates for the given package in the -+format -+ -+ tag/revision -+ -+If the returned list is empty, then the database was not virtual and -+no install candidate was found. -+ -+If the returned list contains undef as first element, the database -+is virtual, and no install candidate was found. -+ -+The remaining elements in the list are all repositories that provide -+that package. -+ -+Note that there might not be an install candidate, but still the -+package is provided by a sub-repository. This can happen if a package -+is present only in the sub-repository and there is no explicit pin -+for that package in the pinning file. + -+=cut -+ -+ -+# returns a list of tag/rev -+sub candidates { -+ my $self = shift; -+ my $pkg = shift; -+ my @ret = (); -+ if ($self->is_virtual) { -+ if (defined($self->{'packages'}{$pkg})) { -+ my $t = $self->{'packages'}{$pkg}{'target'}; -+ if (defined($t)) { -+ push @ret, "$t/" . $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}; -+ } else { -+ $t = ""; -+ # no target found, but maybe available somewhere else, -+ # we return undef as first one -+ push @ret, undef; -+ } -+ # make sure that we always check for main as repo -+ my @repos = keys %{$self->{'packages'}{$pkg}}; -+ for my $r (sort keys %{$self->{'packages'}{$pkg}{'tags'}}) { -+ push @ret, "$r/" . $self->{'packages'}{$pkg}{'tags'}{$r}{'revision'} -+ if ($t ne $r); -+ } ++ # now check/setup pinning ++ # TODO for now no default pinning file! ++ if ($opts{"pin-file"}) { ++ my @pins = read_pinning_file($opts{"pin-file"}); ++ if (@pins) { ++ $remotetlpdb->virtual_pinning(@pins); + } + } else { -+ my $tlp = $self->get_package($pkg); -+ if (defined($tlp)) { -+ push @ret, "main/" . $tlp->revision; ++ # check for pinning file in TEXMFLOCAL/tlpkg/pinning.txt ++ chomp (my $TEXMFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`); ++ debug("trying to load pinning file $TEXMFLOCAL/tlpkg/pinning.txt\n"); ++ if (-r "$TEXMFLOCAL/tlpkg/pinning.txt") { ++ my @pins = read_pinning_file("$TEXMFLOCAL/tlpkg/pinning.txt"); ++ if (@pins) { ++ info("tlmgr: using pinning file $TEXMFLOCAL/tlpkg/pinning.txt\n"); ++ $remotetlpdb->virtual_pinning(@pins); ++ } + } + } -+ return @ret; ++ ++ ++ # this "location-url" line should not be changed since GUI programs ++ # depend on it: ++ print "location-url\t$locstr\n" if $::machinereadable; ++ info("tlmgr: package repository $locstr\n"); ++ +} + -+=item C<< $tlpdb->candidate ( ) >> + -+Returns either a list of four undef, if no install candidate is found, -+or the following information on the install candidate as list: the tag -+name of the repository, the revision number of the package in the -+candidate repository, the tlpobj of the package in the candidate -+repository, and the candidate repository's TLPDB itself. + -+=cut + -+# -+sub virtual_candidate { -+ my ($self, $pkg) = @_; -+ my $t = $self->{'packages'}{$pkg}{'target'}; -+ if (defined($t)) { -+ return ($t, $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}, -+ $self->{'packages'}{$pkg}{'tags'}{$t}{'tlp'}, $self->{'tlpdbs'}{$t}); -+ } -+ return(undef,undef,undef,undef); ++sub _init_tlmedia ++{ + if (defined($remotetlpdb) && ($remotetlpdb->root eq $location)) { + # nothing to be done + return; +@@ -4483,11 +4738,29 @@ + $location =~ s,^$TeXLiveServerURL,$mirrorbase,; + } + ++ $remotetlpdb = setup_one_remotetlpdb($location); + # this "location-url" line should not be changed since GUI programs + # depend on it: + print "location-url\t$location\n" if $::machinereadable; + info("tlmgr: package repository $location\n"); +} + ++sub setup_one_remotetlpdb ++{ ++ my $location = shift; ++ my $remotetlpdb; + -+=item C<< $tlpdb->virtual_pinning ( [@pinning_data] ) >> ++ # TODO ++ # check if that is already loaded!!! + -+Without any argument returns the pinning data, or undef. Be reminded that an -+empty pinning data will behave differently to no pinning data. ++ # choose a mirror if we are asked. ++ if ($location =~ m/^ctan$/i) { ++ $location = give_ctan_mirror(); ++ } elsif ($location =~ m,^$TeXLiveServerURL,) { ++ my $mirrorbase = TeXLive::TLUtils::give_ctan_mirror_base(); ++ $location =~ s,^$TeXLiveServerURL,$mirrorbase,; ++ } + -+With an argument it must be a list of pins, where each pin -+must be one hash ref with the following keys: -+C the tag of the repository, -+C the glob for matching a package -+C the regexp which corresponds to the glob -+C the line where the glob was found (for warning purpose). + # if we talk about a net location try to download the hash of the tlpdb + # - if that is possible, check for the locally saved file and if the hash + # agrees load the local copy if present instead of the remote one, +@@ -4632,8 +4905,30 @@ + close($tlfh); + } + } + -+=cut ++ return($remotetlpdb); + } + ++sub read_pinning_file { ++ my $pf = shift; ++ my @pins; ++ my $pfh; ++ if (!open($pfh, "<$pf")) { ++ tlwarn("Pinning file $pf cannot be read: $!\n"); ++ return; ++ } ++ debug("Reading pinning file $pf\n"); ++ while (my $l = TeXLive::TLUtils::get_full_line($pfh)) { ++ chomp($l); ++ # comments and empty lines are allowed ++ next if ($l =~ m/^\s*#/); ++ next if ($l =~ m/^\s*$/); ++ my ($a, $b) = split(/:/, $l); ++ push @pins, $remotetlpdb->make_pin_data_from_line($l); ++ } ++ close($pfh); ++ return @pins; ++} + + + # finish handles the -pause option (wait for input from stdin), +Index: tlpkg/TeXLive/TLPDB.pm +=================================================================== +--- tlpkg/TeXLive/TLPDB.pm (revision 22399) ++++ tlpkg/TeXLive/TLPDB.pm (working copy) +@@ -73,17 +73,27 @@ + $tlpdb->install_package($pkg, $dest_tlpdb, $nopostinstall, $fallbacktlpdb); + $tlpdb->remove_package($pkg, %options); + +- + TeXLive::TLPDB->listdir([$dir]); + $tlpdb->generate_listfiles([$destdir]); + ++ $tlpdb->make_virtual; ++ $tlpdb->is_virtual; ++ $tlpdb->virtual_add_tlpdb($tlpdb, $tag); ++ $tlpdb->virtual_remove_tlpdb($tag); ++ $tlpdb->virtual_get_package($pkg, $tag); ++ $tlpdb->candidates($pkg); ++ $tlpdb->virtual_candidate($pkg); ++ $tlpdb->virtual_pinning( [@tlpkpins ] ); + -+sub virtual_pinning { -+ my $self = shift; -+ my (@pins) = @_; -+ if (!$self->is_virtual) { -+ tlerror("Not-virtual databases cannot have pinning data.\n"); + =head1 DESCRIPTION + + =cut + +-use TeXLive::TLConfig; ++use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory $InfraLocation ++ $DatabaseName $MetaCategoriesRegexp $Archive ++ %TLPDBOptions %TLPDBSettings); + use TeXLive::TLUtils qw(dirname mkdirhier member win32 info log debug ddebug +- tlwarn basename download_file merge_into); ++ tlwarn basename download_file merge_into tldie); + use TeXLive::TLPOBJ; + + use Cwd 'abs_path'; +@@ -158,6 +168,10 @@ + + sub add_tlpobj { + my ($self,$tlp) = @_; ++ if ($self->is_virtual) { ++ tlwarn("cannot add tlpobj to a virtual tlpdb\n"); + return 0; + } -+ if (!@pins) { -+ if (!defined($self->{'pindata'})) { -+ my @foo = (); -+ $self->{'pindata'} = \@foo; + $self->{'tlps'}{$tlp->name} = $tlp; + } + +@@ -206,6 +220,10 @@ + + sub remove_tlpobj { + my ($self,$pkg) = @_; ++ if ($self->is_virtual) { ++ tlwarn("cannot remove tlpobj from a virtual tlpdb\n"); ++ return 0; ++ } + if (defined($self->{'tlps'}{$pkg})) { + delete $self->{'tlps'}{$pkg}; + } else { +@@ -226,6 +244,10 @@ + + sub from_file { + my ($self, $path) = @_; ++ if ($self->is_virtual) { ++ tlwarn("cannot initialize from file a virtual tlpdb\n"); ++ return 0; ++ } + if (@_ != 2) { + die "$0: from_file needs filename for initialization"; + } +@@ -350,6 +372,10 @@ + + sub writeout { + my $self = shift; ++ if ($self->is_virtual) { ++ tlwarn("cannot write out a virtual tlpdb\n"); ++ return 0; ++ } + my $fd = (@_ ? $_[0] : STDOUT); + foreach (sort keys %{$self->{'tlps'}}) { + ddebug("writeout: tlpname=$_ ", $self->{'tlps'}{$_}->name, "\n"); +@@ -369,6 +395,10 @@ + + sub save { + my $self = shift; ++ if ($self->is_virtual) { ++ tlwarn("cannot save a virtual tlpdb\n"); ++ return 0; ++ } + my $path = $self->location; + mkdirhier(dirname($path)); + my $tmppath = "$path.tmp"; +@@ -390,6 +420,9 @@ + + sub media { + my $self = shift ; ++ if ($self->is_virtual) { ++ return "virtual"; ++ } + return $self->{'media'}; + } + +@@ -405,6 +438,18 @@ + + sub available_architectures { + my $self = shift; ++ my @archs; ++ if ($self->is_virtual) { ++ for my $k (keys %{$self->{'tlpdbs'}}) { ++ push @archs, $self->{'tlpdbs'}{$k}->available_architectures; + } -+ return (@{$self->{'pindata'}}); + } else { -+ $self->{'pindata'} = \@pins; -+ $self->check_evaluate_pinning(); -+ return ($self->{'pindata'}); -+ } -+} -+ -+# $pin{'repo'} = $repo; -+# $pin{'glob'} = $glob; -+# $pin{'re'} = $re; -+# $pin{'line'} = $line; # for debug/warning purpose -+sub make_pin_data_from_line { -+ my $self = shift; -+ my $l = shift; -+ my ($a, $b) = split(/:/, $l); -+ my @ret; -+ my %m; -+ $m{'repo'} = $a; -+ $m{'line'} = $l; -+ # split the package globs -+ for (split(/,/, $b)) { -+ my %mm = %m; -+ $mm{'glob'} = $_; -+ $mm{'re'} = glob_to_regex($_); -+ push @ret, \%mm; ++ return $self->_available_architectures; + } -+ return @ret; +} + -+sub check_evaluate_pinning { ++sub _available_architectures { + my $self = shift; -+ my @pins = (defined($self->{'pindata'}) ? @{$self->{'pindata'}} : ()); -+ # -+ # run through the pin lines and make sure that all the conditions -+ # and requirements are obeyed -+ my %pkgs = %{$self->{'packages'}}; -+ # main:* -+ my ($mainpin) = $self->make_pin_data_from_line("main:*"); -+ # the default main:* is always considered to be matched -+ $mainpin->{'hit'} = 1; -+ push @pins, $mainpin; -+ for my $pkg (keys %pkgs) { -+ PINS: for my $pp (@pins) { -+ my $pre = $pp->{'re'}; -+ if (($pkg =~ m/$pre/) && -+ (defined($self->{'packages'}{$pkg}{'tags'}{$pp->{'repo'}}))) { -+ $self->{'packages'}{$pkg}{'target'} = $pp->{'repo'}; -+ # register that this pin was hit -+ $pp->{'hit'} = 1; -+ last PINS; -+ } -+ } + my @archs = $self->setting("available_architectures"); + if (! @archs) { + # fall back to the old method checking tex\.* +@@ -432,6 +477,10 @@ + + sub add_tlpcontainer { + my ($self, $package, $ziplocation, $archrefs, $dest) = @_; ++ if ($self->is_virtual) { ++ tlwarn("cannot add tlp container to a virtual tlpdb\n"); ++ return 0; + } -+ # check that all pinning lines where hit -+ for my $p (@pins) { -+ next if defined($p->{'hit'}); -+ tlwarn("pinning warning: the entry in line\n ", $p->{'line'}, -+ "\nconcerning the package pattern ", $p->{'glob'}, -+ "\nis not matched by any package!\n"); + my @archs; + if (defined($archrefs)) { + @archs = @$archrefs; +@@ -497,6 +546,16 @@ + + sub get_package { + my ($self,$pkg) = @_; ++ if ($self->is_virtual) { ++ my ($maxsrc, $maxrev, $maxtlp, $maxtlmedia) = $self->virtual_candidate($pkg); ++ return $maxtlp; ++ } else { ++ return $self->_get_package($pkg); + } +} + ++sub _get_package { ++ my ($self,$pkg) = @_; + if (defined($self->{'tlps'}{$pkg})) { + my $ret = $self->{'tlps'}{$pkg}; + return $self->{'tlps'}{$pkg}; +@@ -507,6 +566,35 @@ + + =pod + ++=item C<< $tlpdb->media_of_package($pkg [, $tag]); + -+# copied more or less from Text/Glob.pm ++returns the media type of the package. In the virtual case a tag can ++be given and the media of that repository is used, otherwise the ++media of the virtual candidate is given. + -+sub glob_to_regex { -+ my $glob = shift; -+ my $regex = glob_to_regex_string($glob); -+ return qr/^$regex$/; -+} ++=cut + -+sub glob_to_regex_string -+{ -+ my $glob = shift; -+ my ($regex, $in_curlies, $escaping); -+ local $_; -+ my $first_byte = 1; -+ for ($glob =~ m/(.)/gs) { -+ if ($first_byte) { -+ $regex .= '(?=[^\.])' unless $_ eq '.'; -+ $first_byte = 0; -+ } -+ if ($_ eq '/') { -+ $first_byte = 1; -+ } -+ if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || -+ $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { -+ $regex .= "\\$_"; -+ } -+ elsif ($_ eq '*') { -+ $regex .= $escaping ? "\\*" : "[^/]*"; -+ } -+ elsif ($_ eq '?') { -+ $regex .= $escaping ? "\\?" : "[^/]"; -+ } -+ elsif ($_ eq '{') { -+ $regex .= $escaping ? "\\{" : "("; -+ ++$in_curlies unless $escaping; -+ } -+ elsif ($_ eq '}' && $in_curlies) { -+ $regex .= $escaping ? "}" : ")"; -+ --$in_curlies unless $escaping; -+ } -+ elsif ($_ eq ',' && $in_curlies) { -+ $regex .= $escaping ? "," : "|"; -+ } -+ elsif ($_ eq "\\") { -+ if ($escaping) { -+ $regex .= "\\\\"; -+ $escaping = 0; -+ } -+ else { -+ $escaping = 1; -+ } -+ next; -+ } -+ else { -+ $regex .= $_; -+ $escaping = 0; -+ } -+ $escaping = 0; ++sub media_of_package { ++ my ($self, $pkg, $tag) = @_; ++ if ($self->is_virtual) { ++ if (defined($tag)) { ++ if (defined($self->{'tlpdbs'}{$tag})) { ++ return $self->{'tlpdbs'}{$tag}->media; ++ } else { ++ tlwarn ("tag $tag is not known.\n"); ++ return; ++ } ++ } else { ++ my (undef,undef,undef,$maxtlpdb) = $self->virtual_candidate($pkg); ++ return $maxtlpdb->media; + } -+ print "# $glob $regex\n" if debug; -+ -+ return $regex; ++ } else { ++ return $self->media; ++ } +} + -+sub match_glob { -+ print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; -+ my $glob = shift; -+ my $regex = glob_to_regex $glob; -+ local $_; -+ grep { $_ =~ $regex } @_; ++=pod ++ + =item C<< $tlpdb->list_packages >> + + The C function returns the list of all included packages. +@@ -515,6 +603,15 @@ + + sub list_packages { + my $self = shift; ++ if ($self->is_virtual) { ++ return (sort keys %{$self->{'packages'}}); ++ } else { ++ return $self->_list_packages; ++ } +} + - =pod ++sub _list_packages { ++ my $self = shift; + return (sort keys %{$self->{'tlps'}}); + } + +@@ -623,6 +720,7 @@ + + =cut + ++# TODO adapt for searching in *all* tags ??? + sub find_file { + my ($self,$fn) = @_; + my @ret; +@@ -856,6 +954,10 @@ + + sub root { + my $self = shift; ++ if ($self->is_virtual) { ++ tlwarn("cannot set/edit root of a virtual tlpdb\n"); ++ return 0; ++ } + if (@_) { $self->{'root'} = shift } + return $self->{'root'}; + } +@@ -874,7 +976,11 @@ + =cut + + sub location { +- my $self = shift; ++ my $self = shift; ++ if ($self->is_virtual) { ++ tlwarn("cannot get location of a virtual tlpdb\n"); ++ return 0; ++ } + return "$self->{'root'}/$InfraLocation/$DatabaseName"; + } + +@@ -925,8 +1031,14 @@ + + sub config_src_container { + my $self = shift; +- if (defined($self->{'tlps'}{'00texlive.config'})) { +- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); ++ } else { ++ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp->depends) { + if ($d =~ m!^container_split_src_files/(.*)$!) { + return "$1"; + } +@@ -946,8 +1058,14 @@ + + sub config_doc_container { + my $self = shift; +- if (defined($self->{'tlps'}{'00texlive.config'})) { +- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); ++ } else { ++ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp) { + if ($d =~ m!^container_split_doc_files/(.*)$!) { + return "$1"; + } +@@ -966,8 +1084,14 @@ + + sub config_container_format { + my $self = shift; +- if (defined($self->{'tlps'}{'00texlive.config'})) { +- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); ++ } else { ++ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp->depends) { + if ($d =~ m!^container_format/(.*)$!) { + return "$1"; + } +@@ -986,8 +1110,14 @@ + + sub config_release { + my $self = shift; +- if (defined($self->{'tlps'}{'00texlive.config'})) { +- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); ++ } else { ++ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp->depends) { + if ($d =~ m!^release/(.*)$!) { + return "$1"; + } +@@ -1006,8 +1136,14 @@ + + sub config_minrelease { + my $self = shift; +- if (defined($self->{'tlps'}{'00texlive.config'})) { +- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); ++ } else { ++ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp->depends) { + if ($d =~ m!^minrelease/(.*)$!) { + return "$1"; + } +@@ -1027,8 +1163,14 @@ - =head1 OPTIONS -Index: tlpkg/TeXLive/TLUtils.pm -=================================================================== ---- tlpkg/TeXLive/TLUtils.pm (revision 22343) -+++ tlpkg/TeXLive/TLUtils.pm (working copy) -@@ -62,6 +62,7 @@ - TeXLive::TLUtils::setup_programs($bindir, $platform); - TeXLive::TLUtils::tlcmp($file, $file); - TeXLive::TLUtils::nulldev(); -+ TeXLive::TLUtils::get_full_line($fh); + sub config_revision { + my $self = shift; +- if (defined($self->{'tlps'}{'00texlive.config'})) { +- foreach my $d ($self->{'tlps'}{'00texlive.config'}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config'); ++ } else { ++ $tlp = $self->{'tlps'}{'00texlive.config'}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp->depends) { + if ($d =~ m!^revision/(.*)$!) { + return "$1"; + } +@@ -1054,12 +1196,12 @@ + sub sizes_of_packages { + my ($self, $opt_src, $opt_doc, @packs) = @_; + @packs || ( @packs = $self->list_packages() ); +- my $media = $self->media; + my %tlpsizes; + my %tlpobjs; + my $totalsize; + foreach my $p (@packs) { + $tlpobjs{$p} = $self->get_package($p); ++ my $media = $self->media_of_package($p); + if (!defined($tlpobjs{$p})) { + warn "STRANGE: $p not to be found in ", $self->root; + next; +@@ -1083,7 +1225,7 @@ + $size += $tlpobj->srccontainersize if $opt_src; + $size += $tlpobj->doccontainersize if $opt_doc; + } else { +- # we have to add the respective sizes, that is checking for ++ # we have to add the respective sizes, that is checking for + # installation of src and doc file + $size = $tlpobj->runsize; + $size += $tlpobj->srcsize if $opt_src; +@@ -1106,6 +1248,16 @@ - =head2 Installer Functions + sub install_package { + my ($self, $pkg, $totlpdb, $nopostinstall, $fallbackmedia) = @_; ++ if ($self->is_virtual) { ++ my ($maxtag, $maxrev, $maxtlp, $maxtlpdb) = $self->virtual_candidate($pkg); ++ return $maxtlpdb->install_package($pkg, $totlpdb, $nopostinstall, $fallbackmedia); ++ } else { ++ return $self->not_virtual_install_package($pkg, $totlpdb, $nopostinstall, $fallbackmedia); ++ } ++} ++ ++sub not_virtual_install_package { ++ my ($self, $pkg, $totlpdb, $nopostinstall, $fallbackmedia) = @_; + my $fromtlpdb = $self; + my $ret; + die("TLPDB not initialized, cannot find tlpdb!") unless (defined($fromtlpdb)); +@@ -1170,7 +1322,7 @@ + next; + } + } elsif (&media eq 'NET') { +- $container = "$root/$Archive/$pkg.$DefaultContainerExtension"; ++ $container = "$root/$Archive/$pkg.$TeXLive::TLConfig::DefaultContainerExtension"; + } + $self->_install_package ($container, $reloc, \@installfiles, $totlpdb) + || return(0); +@@ -1545,7 +1697,12 @@ + sub _set_value_pkg { + my ($self,$pkgname,$pre,$key,$value) = @_; + my $k = "$pre$key"; +- my $pkg = $self->{'tlps'}{$pkgname}; ++ my $pkg; ++ if ($self->is_virtual) { ++ $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname); ++ } else { ++ $pkg = $self->{'tlps'}{$pkgname}; ++ } + my @newdeps; + if (!defined($pkg)) { + $pkg = new TeXLive::TLPOBJ; +@@ -1583,8 +1740,14 @@ + sub _value_pkg { + my ($self,$pkg,$pre,$key) = @_; + my $k = "$pre$key"; +- if (defined($self->{'tlps'}{$pkg})) { +- foreach my $d ($self->{'tlps'}{$pkg}->depends) { ++ my $tlp; ++ if ($self->is_virtual) { ++ $tlp = $self->{'tlpdbs'}{'main'}->get_package($pkg); ++ } else { ++ $tlp = $self->{'tlps'}{$pkg}; ++ } ++ if (defined($tlp)) { ++ foreach my $d ($tlp->depends) { + if ($d =~ m!^$k:(.*)$!) { + return "$1"; + } +@@ -1697,7 +1860,12 @@ + my ($self, $pre, $hr) = @_; + my @allowed = keys %$hr; + my %ret; +- my $pkg = $self->{'tlps'}{'00texlive.installation'}; ++ my $pkg; ++ if ($self->is_virtual) { ++ $pkg = $self->{'tlpdbs'}{'main'}->get_package('00texlive.installation'); ++ } else { ++ $pkg = $self->{'tlps'}{'00texlive.installation'}; ++ } + if (defined($pkg)) { + foreach my $d ($pkg->depends) { + if ($d =~ m!^$pre([^:]*):(.*)!) { +@@ -1846,6 +2014,326 @@ -@@ -180,6 +181,7 @@ - &setup_persistent_downloads - &mktexupd - &nulldev -+ &get_full_line - ); - @EXPORT = qw(setup_programs download_file process_logging_options - tldie tlwarn info log debug ddebug dddebug debug_hash -@@ -2424,6 +2426,31 @@ - return (&win32)? 'nul' : '/dev/null'; - } + =back -+=item C ++=head1 VIRTUAL DATABASES + -+returns the next line from the file handle $fh, taking -+continuation lines into account (last character of a line is \, and -+no quoting is parsed). ++The purpose of virtual databases is to collect several data sources ++and present them in one way. The normal functions will always return ++the best candidate for the set of functions. + -+=cut ++More docs to be written + -+# open my $f, '<', $file_name or die; -+# while (my $l = get_full_line($f)) { ... } -+# close $f or die; -+sub get_full_line { -+ my ($fh) = @_; -+ my $line = <$fh>; -+ return undef unless defined $line; -+ return $line unless $line =~ s/\\\r?\n$//; -+ my $cont = get_full_line($fh); -+ if (!defined($cont)) { -+ tlwarn('Continuation disallowed at end of file'); -+ $cont = ""; -+ } -+ $cont =~ s/^\s*//; -+ return $line . $cont; -+} ++=cut + - - =back - -Index: texmf/scripts/texlive/tlmgr.pl -=================================================================== ---- texmf/scripts/texlive/tlmgr.pl (revision 22344) -+++ texmf/scripts/texlive/tlmgr.pl (working copy) -@@ -124,6 +124,7 @@ - "package-logfile" => "=s", - "persistent-downloads" => "!", - "no-execute-actions" => 1, -+ "pin-file" => "=s", - "pause" => 1, - "print-platform|print-arch" => 1, - "version" => 1, -@@ -480,6 +481,12 @@ - } elsif ($action =~ m/^option$/i) { - action_option(); - finish(0); -+ } elsif ($action =~ m/^repository$/i) { -+ action_repository(); -+ finish(0); -+ } elsif ($action =~ m/^candidates$/i) { -+ action_candidates(); -+ finish(0); - } elsif ($action =~ m/^list$/i) { - action_list(); - finish(0); -@@ -1941,7 +1948,12 @@ - # intersection, don't check A\B and B\A - next if $newpkgs_full{$p}; - next if $removals_full{$p}; -- next if ($remotetlpdb->get_package($p)->category ne "Collection"); -+ my $remotetlp = $remotetlpdb->get_package($p); -+ if (!defined($remotetlp)) { -+ tlwarn("Strange, $p mentioned but not found anywhere!\n"); -+ next; -+ } -+ next if ($remotetlp->category ne "Collection"); - my $tlp = $localtlpdb->get_package($p); - if (!defined($tlp)) { - if ($opts{"reinstall-forcibly-removed"}) { -@@ -2908,6 +2920,7 @@ - if (!(@new || @updated)) { - info("tlmgr: no updates available\n"); - if ($remotetlpdb->media ne "NET" -+ && $remotetlpdb->media ne "virtual" - && !$opts{"dry-run"} - && !$opts{"repository"} - ) { -@@ -3123,7 +3136,150 @@ - return; - } - -+# REPOSITORY +# -+# this action manages the list of repositories -+# tlmgr repository list -> lists repositories -+# tlmgr repository add path [tag] -> add repository with optional tag -+# tlmgr repository remove [path|tag] -> removes repository or tag -+# tlmgr repository set path[#tag] [path[#tag] ...] -> sets the list ++# packages are saved: ++# $self->{$pkgname}{'tags'}{$tag}{'revision'} = $rev ++# $self->{$pkgname}{'tags'}{$tag}{'tlp'} = $tlp ++# $self->{$pkgname}{'target'} = $target_tag +# - -+sub array_to_repository { -+ my %r = @_; -+ my @ret; -+ for my $k (keys %r) { -+ my $v = $r{$k}; -+ if ($k eq $v) { -+ push @ret, $k; -+ } else { -+ push @ret, "$v#$k"; -+ } -+ } -+ return "@ret"; ++ ++sub is_virtual { ++ my $self = shift; ++ if (defined($self->{'virtual'}) && $self->{'virtual'}) { ++ return 1; ++ } ++ return 0; +} -+sub repository_to_array { -+ my $r = shift; -+ my %r; -+ for my $rr (split ' ', $r) { -+ if ($rr =~ m/^([^#]+)#(.*)$/) { -+ $r{$2} = $1; -+ } else { -+ $r{$rr} = $rr; ++ ++sub make_virtual { ++ my $self = shift; ++ if (!$self->is_virtual) { ++ if ($self->list_packages) { ++ tlerror("Cannot convert a initialized tlpdb to virtual for now!\n"); ++ return 0; + } ++ $self->{'virtual'} = 1; + } -+ return %r; ++ return 1; +} -+sub action_repository { -+ init_local_db(); -+ my $what = shift @ARGV; -+ $what = "list" if !defined($what); -+ my %repos = repository_to_array($localtlpdb->option("location")); -+ if ($what =~ m/^list$/i) { -+ print "List of repositories (with tags if set):\n"; -+ for my $k (keys %repos) { -+ my $v = $repos{$k}; -+ print "\t$v"; -+ if ($k ne $v) { -+ print " ($k)"; -+ } -+ print "\n"; -+ } -+ return; ++ ++sub virtual_add_tlpdb { ++ my ($self, $tlpdb, $tag) = @_; ++ if (!$self->is_virtual) { ++ tlerror("Cannot add tlpdb to a non-virtual tlpdb!\n"); ++ return 0; + } -+ if ($what eq "add") { -+ my $p = shift @ARGV; -+ if (!defined($p)) { -+ tlwarn("You need to give a new repository aas argument to add\n"); -+ return; -+ } -+ my $t = shift @ARGV; -+ $t = $p if (!defined($t)); -+ if (defined($repos{$t})) { -+ tlwarn("This repository or its tag is already defined, no action\n"); -+ return; -+ } -+ # TODO more checks needed? -+ # if there was till now only *one* repository and that without -+ # a tag, we give that one the "main" tag which is necessary -+ # for proper operation! -+ my @tags = keys %repos; -+ if ($#tags == 0) { -+ # we have only one repository, check if it has the main tag -+ my $maintag = $tags[0]; -+ if ($maintag ne 'main') { -+ $repos{'main'} = $repos{$maintag}; -+ delete $repos{$maintag}; -+ } -+ } -+ $repos{$t} = $p; -+ $localtlpdb->option("location", array_to_repository(%repos)); -+ $localtlpdb->save; -+ return; ++ $self->{'tlpdbs'}{$tag} = $tlpdb; ++ for my $p ($tlpdb->list_packages) { ++ my $tlp = $tlpdb->get_package($p); ++ $self->{'packages'}{$p}{'tags'}{$tag}{'revision'} = $tlp->revision; ++ $self->{'packages'}{$p}{'tags'}{$tag}{'tlp'} = $tlp; + } -+ if ($what eq "remove") { -+ my $p = shift @ARGV; -+ if (!defined($p)) { -+ tlwarn("Which repository should be removed?\n"); -+ return; -+ } -+ my $found = 0; -+ for my $k (keys %repos) { -+ if ($k eq $p || $repos{$k} eq $p) { -+ $found = 1; -+ delete $repos{$k}; -+ } -+ } -+ if (!$found) { -+ tlwarn("Cannot find the repository $p\n"); -+ } else { -+ $localtlpdb->option("location", array_to_repository(%repos)); -+ $localtlpdb->save; -+ } -+ return; ++ $self->check_evaluate_pinning(); ++ return 1; ++} ++ ++sub virtual_remove_tlpdb { ++ my ($self, $tag) = @_; ++ if (!$self->is_virtual) { ++ tlerror("Cannot remove tlpdb from a non-virtual tlpdb!\n"); ++ return 0; + } -+ if ($what eq "set") { -+ %repos = repository_to_array("@ARGV"); -+ $localtlpdb->option("location", array_to_repository(%repos)); -+ $localtlpdb->save; -+ return; ++ if (!defined($self->{'tlpdbs'}{$tag})) { ++ tlwarn("TLPDB virtual_remove_tlpdb: unknown tag $tag\n"); ++ return 0; + } -+ # we are still here, unknown command to repository -+ tlwarn("tlmgr: unknown directive to tlmgr repository: $what\n"); -+ return; ++ for my $p ($self->{'tlpdbs'}{$tag}->list_packages) { ++ delete $self->{'packages'}{$p}{'tags'}{$tag}; ++ } ++ delete $self->{'tlpdbs'}{$tag}; ++ $self->check_evaluate_pinning(); ++ return 1; +} + -+sub action_candidates { -+ my $what = shift @ARGV; -+ if (!defined($what)) { -+ tlwarn("tlmgr: action candidates needs a package name as argument\n"); ++sub virtual_get_package { ++ my ($self, $pkg, $tag) = @_; ++ if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { ++ return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; ++ } else { ++ tlwarn("pkg $pkg not found in tag $tag\n"); + return; + } -+ init_local_db(); -+ init_tlmedia(); -+ my @cand = $remotetlpdb->candidates($what); -+ if (@cand) { -+ my $first = shift @cand; -+ if (defined($first)) { -+ my ($t,$r) = split(/\//, $first, 2); -+ print "Install candidate for $what from $t ($r)\n"; -+ } else { -+ print "No install candidate for $what found.\n"; -+ } -+ # already shifted away the first element -+ if ($#cand >= 0) { -+ print "Other repositories providing this package:\n"; -+ for my $a (@cand) { -+ my ($t,$r) = split(/\//, $a, 2); -+ print "$t ($r)\n"; ++} ++ ++=item C<< $tlpdb->candidates ( $pkg ) >> ++ ++Returns the list of candidates for the given package in the ++format ++ ++ tag/revision ++ ++If the returned list is empty, then the database was not virtual and ++no install candidate was found. ++ ++If the returned list contains undef as first element, the database ++is virtual, and no install candidate was found. ++ ++The remaining elements in the list are all repositories that provide ++that package. ++ ++Note that there might not be an install candidate, but still the ++package is provided by a sub-repository. This can happen if a package ++is present only in the sub-repository and there is no explicit pin ++for that package in the pinning file. ++ ++=cut ++ ++ ++# returns a list of tag/rev ++sub candidates { ++ my $self = shift; ++ my $pkg = shift; ++ my @ret = (); ++ if ($self->is_virtual) { ++ if (defined($self->{'packages'}{$pkg})) { ++ my $t = $self->{'packages'}{$pkg}{'target'}; ++ if (defined($t)) { ++ push @ret, "$t/" . $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}; ++ } else { ++ $t = ""; ++ # no target found, but maybe available somewhere else, ++ # we return undef as first one ++ push @ret, undef; ++ } ++ # make sure that we always check for main as repo ++ my @repos = keys %{$self->{'packages'}{$pkg}}; ++ for my $r (sort keys %{$self->{'packages'}{$pkg}{'tags'}}) { ++ push @ret, "$r/" . $self->{'packages'}{$pkg}{'tags'}{$r}{'revision'} ++ if ($t ne $r); + } + } + } else { -+ print "Package $what not found.\n"; ++ my $tlp = $self->get_package($pkg); ++ if (defined($tlp)) { ++ push @ret, "main/" . $tlp->revision; ++ } + } -+ return; ++ return @ret; +} + - # OPTION - # - sub action_option { -@@ -4470,6 +4626,74 @@ - # - sub init_tlmedia - { -+ # first check if $location contains multiple locations -+ # in this case we go to virtual mode -+ #my %repos = repository_to_array($localtlpdb->option("location")); -+ my %repos = repository_to_array($location); -+ my @tags = keys %repos; -+ # check if we are only one tag/repo -+ if ($#tags == 0) { -+ # go to normal mode -+ _init_tlmedia(); -+ return; ++=item C<< $tlpdb->candidate ( ) >> ++ ++Returns either a list of four undef, if no install candidate is found, ++or the following information on the install candidate as list: the tag ++name of the repository, the revision number of the package in the ++candidate repository, the tlpobj of the package in the candidate ++repository, and the candidate repository's TLPDB itself. ++ ++=cut ++ ++# ++sub virtual_candidate { ++ my ($self, $pkg) = @_; ++ my $t = $self->{'packages'}{$pkg}{'target'}; ++ if (defined($t)) { ++ return ($t, $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'}, ++ $self->{'packages'}{$pkg}{'tags'}{$t}{'tlp'}, $self->{'tlpdbs'}{$t}); + } -+ # we are still here, so we have more tags ++ return(undef,undef,undef,undef); ++} + -+ # check that there is a main repository -+ if (!TeXLive::TLUtils::member('main', @tags)) { -+ tldie("Cannot find main repository, you have to tag one as main!\n"); ++=item C<< $tlpdb->virtual_pinning ( [@pinning_data] ) >> ++ ++Without any argument returns the pinning data, or undef. Be reminded that an ++empty pinning data will behave differently to no pinning data. ++ ++With an argument it must be a list of pins, where each pin ++must be one hash ref with the following keys: ++C the tag of the repository, ++C the glob for matching a package ++C the regexp which corresponds to the glob ++C the line where the glob was found (for warning purpose). ++ ++=cut ++ ++sub virtual_pinning { ++ my $self = shift; ++ my (@pins) = @_; ++ if (!$self->is_virtual) { ++ tlerror("Not-virtual databases cannot have pinning data.\n"); ++ return 0; ++ } ++ if (!@pins) { ++ if (!defined($self->{'pindata'})) { ++ my @foo = (); ++ $self->{'pindata'} = \@foo; ++ } ++ return (@{$self->{'pindata'}}); ++ } else { ++ $self->{'pindata'} = \@pins; ++ $self->check_evaluate_pinning(); ++ return ($self->{'pindata'}); + } ++} + -+ # TODO TODO -+ # - abstract the set up of a single media tlpdb -+ # - make clear how to check for a already loaded remotetlpdb -+ $remotetlpdb = TeXLive::TLPDB->new(); -+ $remotetlpdb->make_virtual; -+ -+ my $locstr = $repos{'main'}; -+ my $tlmdb = setup_one_remotetlpdb($locstr); -+ $remotetlpdb->virtual_add_tlpdb($tlmdb, "main"); -+ for my $t (@tags) { -+ if ($t ne 'main') { -+ my $tlmdb = setup_one_remotetlpdb($repos{$t}); -+ $remotetlpdb->virtual_add_tlpdb($tlmdb, $t); -+ $locstr .= " $repos{$t}"; -+ } ++# $pin{'repo'} = $repo; ++# $pin{'glob'} = $glob; ++# $pin{'re'} = $re; ++# $pin{'line'} = $line; # for debug/warning purpose ++sub make_pin_data_from_line { ++ my $self = shift; ++ my $l = shift; ++ my ($a, $b) = split(/:/, $l); ++ my @ret; ++ my %m; ++ $m{'repo'} = $a; ++ $m{'line'} = $l; ++ # split the package globs ++ for (split(/,/, $b)) { ++ my %mm = %m; ++ $mm{'glob'} = $_; ++ $mm{'re'} = glob_to_regex($_); ++ push @ret, \%mm; + } ++ return @ret; ++} + -+ # now check/setup pinning -+ # TODO for now no default pinning file! -+ if ($opts{"pin-file"}) { -+ my @pins = read_pinning_file($opts{"pin-file"}); -+ if (@pins) { -+ $remotetlpdb->virtual_pinning(@pins); -+ } -+ } else { -+ # check for pinning file in TEXMFLOCAL/tlpkg/pinning.txt -+ chomp (my $TEXMFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`); -+ debug("trying to load pinning file $TEXMFLOCAL/tlpkg/pinning.txt\n"); -+ if (-r "$TEXMFLOCAL/tlpkg/pinning.txt") { -+ my @pins = read_pinning_file("$TEXMFLOCAL/tlpkg/pinning.txt"); -+ if (@pins) { -+ info("tlmgr: using pinning file $TEXMFLOCAL/tlpkg/pinning.txt\n"); -+ $remotetlpdb->virtual_pinning(@pins); ++sub check_evaluate_pinning { ++ my $self = shift; ++ my @pins = (defined($self->{'pindata'}) ? @{$self->{'pindata'}} : ()); ++ # ++ # run through the pin lines and make sure that all the conditions ++ # and requirements are obeyed ++ my %pkgs = %{$self->{'packages'}}; ++ # main:* ++ my ($mainpin) = $self->make_pin_data_from_line("main:*"); ++ # the default main:* is always considered to be matched ++ $mainpin->{'hit'} = 1; ++ push @pins, $mainpin; ++ for my $pkg (keys %pkgs) { ++ PINS: for my $pp (@pins) { ++ my $pre = $pp->{'re'}; ++ if (($pkg =~ m/$pre/) && ++ (defined($self->{'packages'}{$pkg}{'tags'}{$pp->{'repo'}}))) { ++ $self->{'packages'}{$pkg}{'target'} = $pp->{'repo'}; ++ # register that this pin was hit ++ $pp->{'hit'} = 1; ++ last PINS; + } + } + } ++ # check that all pinning lines where hit ++ for my $p (@pins) { ++ next if defined($p->{'hit'}); ++ tlwarn("pinning warning: the entry in line\n ", $p->{'line'}, ++ "\nconcerning the package pattern ", $p->{'glob'}, ++ "\nis not matched by any package!\n"); ++ } ++} + + -+ # this "location-url" line should not be changed since GUI programs -+ # depend on it: -+ print "location-url\t$locstr\n" if $::machinereadable; -+ info("tlmgr: package repository $locstr\n"); ++# copied more or less from Text/Glob.pm + ++sub glob_to_regex { ++ my $glob = shift; ++ my $regex = glob_to_regex_string($glob); ++ return qr/^$regex$/; +} + ++sub glob_to_regex_string ++{ ++ my $glob = shift; ++ my ($regex, $in_curlies, $escaping); ++ local $_; ++ my $first_byte = 1; ++ for ($glob =~ m/(.)/gs) { ++ if ($first_byte) { ++ $regex .= '(?=[^\.])' unless $_ eq '.'; ++ $first_byte = 0; ++ } ++ if ($_ eq '/') { ++ $first_byte = 1; ++ } ++ if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || ++ $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { ++ $regex .= "\\$_"; ++ } ++ elsif ($_ eq '*') { ++ $regex .= $escaping ? "\\*" : "[^/]*"; ++ } ++ elsif ($_ eq '?') { ++ $regex .= $escaping ? "\\?" : "[^/]"; ++ } ++ elsif ($_ eq '{') { ++ $regex .= $escaping ? "\\{" : "("; ++ ++$in_curlies unless $escaping; ++ } ++ elsif ($_ eq '}' && $in_curlies) { ++ $regex .= $escaping ? "}" : ")"; ++ --$in_curlies unless $escaping; ++ } ++ elsif ($_ eq ',' && $in_curlies) { ++ $regex .= $escaping ? "," : "|"; ++ } ++ elsif ($_ eq "\\") { ++ if ($escaping) { ++ $regex .= "\\\\"; ++ $escaping = 0; ++ } ++ else { ++ $escaping = 1; ++ } ++ next; ++ } ++ else { ++ $regex .= $_; ++ $escaping = 0; ++ } ++ $escaping = 0; ++ } ++ print "# $glob $regex\n" if debug; + ++ return $regex; ++} + ++sub match_glob { ++ print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; ++ my $glob = shift; ++ my $regex = glob_to_regex $glob; ++ local $_; ++ grep { $_ =~ $regex } @_; ++} + -+sub _init_tlmedia -+{ - if (defined($remotetlpdb) && ($remotetlpdb->root eq $location)) { - # nothing to be done - return; -@@ -4483,11 +4707,29 @@ - $location =~ s,^$TeXLiveServerURL,$mirrorbase,; - } + =pod -+ $remotetlpdb = setup_one_remotetlpdb($location); - # this "location-url" line should not be changed since GUI programs - # depend on it: - print "location-url\t$location\n" if $::machinereadable; - info("tlmgr: package repository $location\n"); -+} + =head1 OPTIONS +Index: tlpkg/TeXLive/TLUtils.pm +=================================================================== +--- tlpkg/TeXLive/TLUtils.pm (revision 22399) ++++ tlpkg/TeXLive/TLUtils.pm (working copy) +@@ -62,6 +62,7 @@ + TeXLive::TLUtils::setup_programs($bindir, $platform); + TeXLive::TLUtils::tlcmp($file, $file); + TeXLive::TLUtils::nulldev(); ++ TeXLive::TLUtils::get_full_line($fh); -+sub setup_one_remotetlpdb -+{ -+ my $location = shift; -+ my $remotetlpdb; -+ -+ # TODO -+ # check if that is already loaded!!! + =head2 Installer Functions + +@@ -180,6 +181,7 @@ + &setup_persistent_downloads + &mktexupd + &nulldev ++ &get_full_line + ); + @EXPORT = qw(setup_programs download_file process_logging_options + tldie tlwarn info log debug ddebug dddebug debug_hash +@@ -2424,6 +2426,31 @@ + return (&win32)? 'nul' : '/dev/null'; + } + ++=item C + -+ # choose a mirror if we are asked. -+ if ($location =~ m/^ctan$/i) { -+ $location = give_ctan_mirror(); -+ } elsif ($location =~ m,^$TeXLiveServerURL,) { -+ my $mirrorbase = TeXLive::TLUtils::give_ctan_mirror_base(); -+ $location =~ s,^$TeXLiveServerURL,$mirrorbase,; -+ } ++returns the next line from the file handle $fh, taking ++continuation lines into account (last character of a line is \, and ++no quoting is parsed). + - # if we talk about a net location try to download the hash of the tlpdb - # - if that is possible, check for the locally saved file and if the hash - # agrees load the local copy if present instead of the remote one, -@@ -4632,8 +4874,30 @@ - close($tlfh); - } - } ++=cut + -+ return($remotetlpdb); - } - -+sub read_pinning_file { -+ my $pf = shift; -+ my @pins; -+ my $pfh; -+ if (!open($pfh, "<$pf")) { -+ tlwarn("Pinning file $pf cannot be read: $!\n"); -+ return; -+ } -+ debug("Reading pinning file $pf\n"); -+ while (my $l = TeXLive::TLUtils::get_full_line($pfh)) { -+ chomp($l); -+ # comments and empty lines are allowed -+ next if ($l =~ m/^\s*#/); -+ next if ($l =~ m/^\s*$/); -+ my ($a, $b) = split(/:/, $l); -+ push @pins, $remotetlpdb->make_pin_data_from_line($l); ++# open my $f, '<', $file_name or die; ++# while (my $l = get_full_line($f)) { ... } ++# close $f or die; ++sub get_full_line { ++ my ($fh) = @_; ++ my $line = <$fh>; ++ return undef unless defined $line; ++ return $line unless $line =~ s/\\\r?\n$//; ++ my $cont = get_full_line($fh); ++ if (!defined($cont)) { ++ tlwarn('Continuation disallowed at end of file'); ++ $cont = ""; + } -+ close($pfh); -+ return @pins; ++ $cont =~ s/^\s*//; ++ return $line . $cont; +} - ++ - # finish handles the -pause option (wait for input from stdin), + =back + -- cgit v1.2.3