path: root/Master/tlpkg/dev/dev.multi-source-support-v2.patch

Index: texmf/scripts/texlive/tlmgr.pl
===================================================================
--- 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;
   }
-  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: <absent>, source: " . $mediatlp->revision . " (auto-install)\n");
+            info("$pkg [${kb}k]: local: <absent>, 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;
 }
 
+#  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 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 repository_to_array {
+  my $r = shift;
+  my %r;
+  for my $rr (split ' ', $r) {
+    if ($rr =~ m/^([^#]+)#(.*)$/) {
+      $r{$2} = $1;
+    } else {
+      $r{$rr} = $rr;
+    }
+  }
+  return %r;
+}
+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 ($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 ($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 ($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 action_candidates {
+  my $what = shift @ARGV;
+  if (!defined($what)) {
+    tlwarn("tlmgr: action candidates needs a package name as argument\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";
+      }
+    }
+  } else {
+    print "Package $what not found.\n";
+  }
+  return;
+}
+
 #  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;
+  }
+  # we are still here, so we have more tags
+
+  # 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");
+  }
+
+  # 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}";
+    }
+  }
+
+  # 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);
+      }
+    }
+  }
+
+
+  # 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");
+
+}
+
+
+
+
+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;
+
+  # TODO
+  # check if that is already loaded!!!
+
+  # 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,;
+  }
+
   # 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);
     }
   }
+
+  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 ] );
+
 =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";
   }
@@ -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;
+    }
+  } 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);
+  }
+}
+
+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;
+      }
+    } else {
+      my (undef,undef,undef,$maxtlpdb) = $self->virtual_candidate($pkg);
+      return $maxtlpdb->media;
+    }
+  } else {
+    return $self->media;
+  }
+}
+
+=pod
+
 =item C<< $tlpdb->list_packages >>
 
 The C<list_packages> 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'};
+  }
+  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 @@
 
 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 @@
 
 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 @@
 
 =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;
+}
+
+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 1;
+}
+
+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;
+  }
+  $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;
+}
+
+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;
+  }
+}
+
+=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 {
+    my $tlp = $self->get_package($pkg);
+    if (defined($tlp)) {
+      push @ret, "main/" . $tlp->revision;
+    }
+  }
+  return @ret;
+}
+
+=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);
+}
+
+=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<repo> the tag of the repository, 
+C<glob> the glob for matching a package
+C<re> the regexp which corresponds to the glob
+C<line> 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'});
+  }
+}
+
+# $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;
+}
+
+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");
+  }
+}
+
+
+# implementation copied from Text/Glob.pm (copyright Richard Clamp).
+
+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 } @_;
+}
+
 =pod
 
 =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);
 
 =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<get_full_line ($fh)>
+
+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).
+
+=cut
+
+#     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;
+}
+
 
 =back