--- texmf/scripts/texlive/tlmgr.pl | 916 ++++++++++++++++++++++++++++++++------ texmf/scripts/texlive/tlmgrgui.pl | 394 ++++++++++++++-- tlpkg/TeXLive/TLPDB.pm | 706 ++++++++++++++++++++++++++--- 3 files changed, 1767 insertions(+), 249 deletions(-) Index: tlpkg/TeXLive/TLPDB.pm =================================================================== --- tlpkg/TeXLive/TLPDB.pm.orig 2012-01-30 10:48:02.284183279 +0900 +++ tlpkg/TeXLive/TLPDB.pm 2012-03-24 16:46:21.342566067 +0900 @@ -70,20 +70,31 @@ $tlpdb->settings; $tlpdb->setting($key, [$value]); $tlpdb->sizes_of_packages($opt_src, $opt_doc [, @packs ]); - $tlpdb->install_package($pkg, $dest_tlpdb, $nopostinstall, $fallbacktlpdb); + $tlpdb->install_package($pkg, $dest_tlpdb); $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 + $RelocPrefix $RelocTree); 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 TeXLive::TLWinGoo; @@ -123,8 +134,7 @@ $_listdir = $params{'listdir'} if defined($params{'listdir'}); bless $self, $class; if (defined($params{'tlpdbfile'})) { - my $nr_packages_read - = $self->from_file("$self->{'root'}/$InfraLocation/$DatabaseName"); + my $nr_packages_read = $self->from_file($params{'tlpdbfile'}, '-from-file'); if ($nr_packages_read == 0) { # that is bad, we didn't read anything, so return undef. return undef; @@ -161,6 +171,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; } @@ -209,6 +223,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 { @@ -228,15 +246,22 @@ =cut sub from_file { - my ($self, $path) = @_; - if (@_ != 2) { + my ($self, $path, $arg) = @_; + 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"; } my $root_from_path = dirname(dirname($path)); if (defined($self->{'root'})) { if ($self->{'root'} ne $root_from_path) { - tlwarn("root=$self->{'root'}, root_from_path=$root_from_path\n"); - tlwarn("Initialization from different location as originally given.\nHope you are sure!\n"); + # only warn if we are not given $arg = "-from-file" + if (!defined($arg) || ($arg ne "-from-file")) { + tlwarn("root=$self->{'root'}, root_from_path=$root_from_path\n"); + tlwarn("Initialization from different location as originally given.\nHope you are sure!\n"); + } } } else { $self->root($root_from_path); @@ -362,6 +387,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"); @@ -381,6 +410,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"; @@ -402,6 +435,9 @@ sub media { my $self = shift ; + if ($self->is_virtual) { + return "virtual"; + } return $self->{'media'}; } @@ -417,6 +453,19 @@ sub available_architectures { my $self = shift; + my @archs; + if ($self->is_virtual) { + for my $k (keys %{$self->{'tlpdbs'}}) { + TeXLive::TLUtils::push_uniq \@archs, $self->{'tlpdbs'}{$k}->available_architectures; + } + return sort @archs; + } 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\.* @@ -444,6 +493,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; @@ -508,6 +561,29 @@ =cut sub get_package { + my ($self,$pkg,$tag) = @_; + if ($self->is_virtual) { + if (defined($tag)) { + if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { + return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; + } else { + debug("TLPDB::get_package: package $pkg not found in repository $tag\n"); + return; + } + } else { + $tag = $self->{'packages'}{$pkg}{'target'}; + if (defined($tag)) { + return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'}; + } else { + return; + } + } + } else { + return $self->_get_package($pkg); + } +} + +sub _get_package { my ($self,$pkg) = @_; if (defined($self->{'tlps'}{$pkg})) { my $ret = $self->{'tlps'}{$pkg}; @@ -519,6 +595,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 function returns the list of all included packages. @@ -527,6 +632,34 @@ sub list_packages { my $self = shift; + my $arg = shift; + my $showall = 0; + if (defined($arg) && ($arg eq "-all")) { + $showall = 1; + } + if ($self->is_virtual) { + if ($showall) { + return (sort keys %{$self->{'packages'}}); + } + # we have to be careful here: If a package + # is only present in a subsidiary repository + # and the package is *not* explicitely + # pinned to it, it will not be installable. + # This is what we want. But in this case + # we don't want it to be listed by default. + # + my @pps; + for my $p (keys %{$self->{'packages'}}) { + push @pps, $p if (defined($self->{'packages'}{$p}{'target'})); + } + return (sort @pps); + } else { + return $self->_list_packages; + } +} + +sub _list_packages { + my $self = shift; return (sort keys %{$self->{'tlps'}}); } @@ -544,6 +677,11 @@ The next (or first) argument is the target TLPDB, then a list of packages. +In the virtual case, +if a package name is tagged with C<@repository-tag> then all the +dependencies will still be expanded between all included databases. +Only in case of .ARCH dependencies the repository-tag is sticky. + We return the closure of the package list with respect to the depends operator. (Sorry, that was for mathematicians.) @@ -567,7 +705,8 @@ my %install = (); my @archs = $totlpdb->available_architectures; for my $p (@_) { - $install{$p} = 1; + my ($pp, $aa) = split('@', $p); + $install{$pp} = (defined($aa) ? $aa : 0);; } my $changed = 1; while ($changed) { @@ -576,7 +715,7 @@ ddebug("pre_select = @pre_select\n"); for my $p (@pre_select) { next if ($p =~ m/^00texlive/); - my $pkg = $self->get_package($p); + my $pkg = $self->get_package($p, ($install{$p}?$install{$p}:undef)); if (!defined($pkg)) { debug("W: $p is mentioned somewhere but not available, disabling\n"); $install{$p} = 0; @@ -602,16 +741,19 @@ if ($p_dep =~ m/^(.*)\.ARCH$/) { my $foo = "$1"; foreach $a (@archs) { - $install{"$foo.$a"} = 1 if defined($self->get_package("$foo.$a")); + # install .ARCH packages from the same sub repository as the + # main packages + $install{"$foo.$a"} = $install{$foo} + if defined($self->get_package("$foo.$a")); } } elsif ($p_dep =~ m/^(.*)\.win32$/) { # a win32 package should *only* be installed if we are installing # the win32 arch if (grep(/^win32$/,@archs)) { - $install{$p_dep} = 1; + $install{$p_dep} = 0; } } else { - $install{$p_dep} = 1 unless $only_arch; + $install{$p_dep} = 0 unless $only_arch; } } } @@ -623,7 +765,9 @@ $changed = 1; } } - return(keys %install); + # create return list + return map { $install{$_} eq "0"?$_:"$_\@" . $install{$_} } keys %install; + #return(keys %install); } =pod @@ -635,6 +779,7 @@ =cut +# TODO adapt for searching in *all* tags ??? sub find_file { my ($self,$fn) = @_; my @ret; @@ -868,6 +1013,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'}; } @@ -887,6 +1036,10 @@ sub location { my $self = shift; + if ($self->is_virtual) { + tlwarn("cannot get location of a virtual tlpdb\n"); + return 0; + } return "$self->{'root'}/$InfraLocation/$DatabaseName"; } @@ -937,8 +1090,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"; } @@ -958,8 +1117,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->depends) { if ($d =~ m!^container_split_doc_files/(.*)$!) { return "$1"; } @@ -978,8 +1143,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"; } @@ -998,8 +1169,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"; } @@ -1018,8 +1195,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"; } @@ -1039,8 +1222,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"; } @@ -1066,12 +1255,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; @@ -1110,31 +1299,46 @@ =pod -=item C<< $tlpdb->install_package($pkg, $dest_tlpdb, $nopostinstall, $fallbacktlpdb) >> +=item C<< $tlpdb->install_package($pkg, $dest_tlpdb [, $tag]) >> Installs the package $pkg into $dest_tlpdb. +If C<$tag> is present and the tlpdb is virtual, tries to install $pkg +from the repository tagged with $tag. =cut sub install_package { - my ($self, $pkg, $totlpdb, $nopostinstall, $fallbackmedia) = @_; + my ($self, $pkg, $totlpdb, $tag) = @_; + if ($self->is_virtual) { + if (defined($tag)) { + if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) { + return $self->{'tlpdbs'}{$tag}->install_package($pkg, $totlpdb); + } else { + tlwarn("package $pkg not found in repository $tag\n"); + return; + } + } else { + my ($maxtag, $maxrev, $maxtlp, $maxtlpdb) = $self->virtual_candidate($pkg); + return $maxtlpdb->install_package($pkg, $totlpdb); + } + } else { + if (defined($tag)) { + tlwarn("not a virtual database, ignoring tag $tag on installation of $pkg\n"); + } + return $self->not_virtual_install_package($pkg, $totlpdb); + } + return; +} + +sub not_virtual_install_package { + my ($self, $pkg, $totlpdb) = @_; my $fromtlpdb = $self; my $ret; die("TLPDB not initialized, cannot find tlpdb!") unless (defined($fromtlpdb)); my $tlpobj = $fromtlpdb->get_package($pkg); if (!defined($tlpobj)) { - if (defined($fallbackmedia)) { - if ($ret = $fallbackmedia->install_package($pkg,$totlpdb, $nopostinstall)) { - debug("installed $pkg from fallback\n"); - return $ret; - } else { - tlwarn("$0: Cannot find package $pkg (in fallback, either)\n"); - return 0; - } - } else { - tlwarn("$0: Cannot find package $pkg\n"); - return 0; - } + tlwarn("$0: Cannot find package $pkg\n"); + return 0; } else { my $container_src_split = $fromtlpdb->config_src_container; my $container_doc_split = $fromtlpdb->config_doc_container; @@ -1182,7 +1386,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); @@ -1256,23 +1460,21 @@ $totlpdb->save; # compute the return value TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj); - if (!$nopostinstall) { - # do the postinstallation actions - # - # Run the post installation code in the postaction tlpsrc entries - # in case we are on w32 and the admin did install for himself only - # we switch off admin mode - if (win32() && admin() && !$totlpdb->option("w32_multi_user")) { - non_admin(); - } - # for now desktop_integration maps to both installation - # of desktop shortcuts and menu items, but we can split them later - &TeXLive::TLUtils::do_postaction("install", $tlpobj, - $totlpdb->option("file_assocs"), - $totlpdb->option("desktop_integration"), - $totlpdb->option("desktop_integration"), - $totlpdb->option("post_code")); + # do the postinstallation actions + # + # Run the post installation code in the postaction tlpsrc entries + # in case we are on w32 and the admin did install for himself only + # we switch off admin mode + if (win32() && admin() && !$totlpdb->option("w32_multi_user")) { + non_admin(); } + # for now desktop_integration maps to both installation + # of desktop shortcuts and menu items, but we can split them later + &TeXLive::TLUtils::do_postaction("install", $tlpobj, + $totlpdb->option("file_assocs"), + $totlpdb->option("desktop_integration"), + $totlpdb->option("desktop_integration"), + $totlpdb->option("post_code")); } return 1; } @@ -1525,7 +1727,7 @@ # the postaction code part cannot be evaluated now since the # files are already removed. # Again, desktop integration maps to desktop and menu links - if (!$nopostinstall) { + if (!$opts{'nopostinstall'}) { &TeXLive::TLUtils::do_postaction("remove", $tlp, $localtlpdb->option("file_assocs"), $localtlpdb->option("desktop_integration"), @@ -1557,7 +1759,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; @@ -1595,8 +1802,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"; } @@ -1709,7 +1922,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([^:]*):(.*)!) { @@ -1858,6 +2076,362 @@ =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->{'packages'}{$pkgname}{'tags'}{$tag}{'revision'} = $rev +# $self->{'packages'}{$pkgname}{'tags'}{$tag}{'tlp'} = $tlp +# $self->{'packages'}{$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 + +sub is_repository { + my $self = shift; + my $tag = shift; + if (!$self->is_virtual) { + return ( ($tag eq $self->{'root'}) ? 1 : 0 ); + } + return ( defined($self->{'tlpdbs'}{$tag}) ? 1 : 0 ); +} + + +# 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 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'}); + } +} + +# +# current format: +# :[,,...][:] +# only supported options for now is +# revision +# meaning that, if for the selected package there is no other +# "non-revision" pinning, then all repo/package versions are compared +# using normal revision comparison, and the biggest revision number wins. +# That allows you to have the same package in several repos: +# repo1:foo:revision +# repo2:foo:revision +# repo1:* +# repo2:* +# means that: +# for package "foo" the revision numbers of "foo" in the repos "repo1", +# "repo2", and "main" are numerically compared and biggest number wins. +# for all other packages of "repo1" and "repo2", other other repositories +# are not considered. +# +# NOT IMPLEMENTED YET!!! +# +# $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, $c) = split(/:/, $l); + my @ret; + my %m; + $m{'repo'} = $a; + $m{'line'} = $l; + if (defined($c)) { + $m{'options'} = $c; + } + # 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). +# changes made: +# remove $strict_leading_dot and $strict_wildcard_slash if calls +# and execute the code unconditionally, as we do not change the +# default settings of 1 of these two variables. +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 @@ -1919,4 +2493,4 @@ ### tab-width: 2 ### indent-tabs-mode: nil ### End: -# vim:set tabstop=2 expandtab: # +# vim:set tabstop=2 expandtab autoindent: # Index: texmf/scripts/texlive/tlmgr.pl =================================================================== --- texmf/scripts/texlive/tlmgr.pl.orig 2012-01-31 23:25:04.175697912 +0900 +++ texmf/scripts/texlive/tlmgr.pl 2012-03-24 16:46:15.918561526 +0900 @@ -1,7 +1,7 @@ #!/usr/bin/env perl # $Id: tlmgr.pl 24419 2011-10-27 14:06:37Z preining $ # -# Copyright 2008, 2009, 2010, 2011 Norbert Preining +# Copyright 2008, 2009, 2010, 2011, 2012 Norbert Preining # This file is licensed under the GNU General Public License version 2 # or any later version. @@ -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, @@ -135,6 +136,8 @@ "option" => { }, "conf" => { }, "version" => { }, + "repository" => { }, + "candidate" => { }, "backup" => { "backupdir" => "=s", "clean" => ":-99", "all" => 1, @@ -504,6 +507,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); @@ -533,7 +542,7 @@ action_dumptlpdb(); finish(0); } elsif ($action =~ m/^show$/i) { - action_show(); + action_show(@ARGV); finish(0); } elsif ($action =~ m/^remove$/i) { action_remove(); @@ -1145,7 +1154,8 @@ tlwarn("tlmgr: Cannot load taxonomy file, showing taxonomies not supported.\n"); } } - foreach my $pkg (@ARGV) { + foreach my $ppp (@_) { + my ($pkg, $tag) = split '@', $ppp, 2; my $tlpdb = $localtlpdb; my $tlp = $localtlpdb->get_package($pkg); my $installed = 0; @@ -1153,126 +1163,179 @@ if (!$remotetlpdb) { init_tlmedia(); } - $tlp = $remotetlpdb->get_package($pkg); - $tlpdb = $remotetlpdb; - } else { - $installed = 1; - } - if ($tlp) { - my @colls; - if ($tlp->category ne "Collection" && $tlp->category ne "Scheme") { - @colls = $localtlpdb->needed_by($pkg); - if (!@colls) { - # not referenced in the local tlpdb, so try the remote here, too - if (!$remotetlpdb) { - init_tlmedia(); + if (defined($tag)) { + if (!$remotetlpdb->is_virtual) { + tlwarn("tlmgr: specifying implicite tags is not allowed for non-virtual databases!\n"); + next; + } else { + if (!$remotetlpdb->is_repository($tag)) { + tlwarn("tlmgr: no such repository tag defined: $tag\n"); + next; } - @colls = $remotetlpdb->needed_by($pkg); } } - # some packages might depend on other packages, so do not - # include arbitrary package in the list of collections, but - # only collectons: - @colls = grep {m;^collection-;} @colls; - print "package: ", $tlp->name, "\n"; - print "category: ", $tlp->category, "\n"; - print "shortdesc: ", $tlp->shortdesc, "\n" if ($tlp->shortdesc); - print "longdesc: ", $tlp->longdesc, "\n" if ($tlp->longdesc); - print "installed: ", ($installed ? "Yes" : "No"), "\n"; - print "revision: ", $tlp->revision, "\n" if ($installed); - print "cat-version: ", $tlp->cataloguedata->{'version'}, "\n" - if $tlp->cataloguedata->{'version'}; - print "cat-date: ", $tlp->cataloguedata->{'date'}, "\n" - if $tlp->cataloguedata->{'date'}; - print "cat-license: ", $tlp->cataloguedata->{'license'}, "\n" - if $tlp->cataloguedata->{'license'}; - print "collection: ", @colls, "\n" if (@colls); - if ($opts{"keyword"} || $opts{"taxonomy"}) { - print "keywords: "; - if (defined($taxonomy->{'by-package'}{'keyword'}{$pkg})) { - print join(', ',@{$taxonomy->{'by-package'}{'keyword'}{$pkg}}), "\n"; - } else { - print "(none found)\n"; + $tlp = $remotetlpdb->get_package($pkg, $tag); + if (!$tlp) { + if (defined($tag)) { + # we already searched for the package in a specific tag, don't retry + # all candidates! + tlwarn("tlmgr: Cannot find package $pkg in repository $tag\n"); + next; } - } - if ($opts{"functionality"} || $opts{"taxonomy"}) { - print "function: "; - if (defined($taxonomy->{'by-package'}{'functionality'}{$pkg})) { - print join(', ',@{$taxonomy->{'by-package'}{'functionality'}{$pkg}}), "\n"; - } else { - print "(none found)\n"; + if ($remotetlpdb->is_virtual) { + # we might have a package that is available in a + # subsidiary repository, but not installable + # because it is not pinned + # we will list it but warn about this fact + my @cand = $remotetlpdb->candidates($pkg); + if (@cand) { + my $first = shift @cand; + if (defined($first)) { + tlwarn("strange, we have a first candidate but no tlp: $pkg\n"); + next; + } + # already shifted away the first element + if ($#cand >= 0) { + # recursively showing all tags, but warn + print "package: ", $pkg, "\n"; + print "WARNING: This package is not pinned but present in subsidiary repositories\n"; + print "WARNING: As long as it is not pinned it is not installable.\n"; + print "WARNING: Listing all available copies of the package.\n"; + my @aaa; + for my $a (@cand) { + my ($t,$r) = split(/\//, $a, 2); + push @aaa, "$pkg" . '@' . $t; + } + action_show(@aaa); + next; + } else { + tlwarn("strange, package listed but no residual candidates: $pkg\n"); + next; + } + } else { + tlwarn("strange, package listed but no candidates: $pkg\n"); + next; + } } + tlwarn("tlmgr: cannot find package $pkg\n"); + next; } - if ($opts{"characterization"} || $opts{"taxonomy"}) { - print "primary characterization: "; - if (defined($taxonomy->{'by-package'}{'primary'}{$pkg})) { - print $taxonomy->{'by-package'}{'primary'}{$pkg}, "\n"; - } else { - print "(none found)\n"; - } - print "secondary characterization: "; - if (defined($taxonomy->{'by-package'}{'secondary'}{$pkg})) { - print $taxonomy->{'by-package'}{'secondary'}{$pkg}, "\n"; - } else { - print "(none found)\n"; - } + $tlpdb = $remotetlpdb; + } else { + $installed = 1; + } + my @colls; + if ($tlp->category ne "Collection" && $tlp->category ne "Scheme") { + @colls = $localtlpdb->needed_by($pkg); + if (!@colls) { + # not referenced in the local tlpdb, so try the remote here, too + if (!$remotetlpdb) { + init_tlmedia(); + } + @colls = $remotetlpdb->needed_by($pkg); + } + } + # some packages might depend on other packages, so do not + # include arbitrary package in the list of collections, but + # only collectons: + @colls = grep {m;^collection-;} @colls; + print "package: ", $tlp->name, "\n"; + print "repository: ", $tag, "\n" if (defined($tag)); + print "category: ", $tlp->category, "\n"; + print "shortdesc: ", $tlp->shortdesc, "\n" if ($tlp->shortdesc); + print "longdesc: ", $tlp->longdesc, "\n" if ($tlp->longdesc); + print "installed: ", ($installed ? "Yes" : "No"), "\n"; + print "revision: ", $tlp->revision, "\n" if ($installed); + print "cat-version: ", $tlp->cataloguedata->{'version'}, "\n" + if $tlp->cataloguedata->{'version'}; + print "cat-date: ", $tlp->cataloguedata->{'date'}, "\n" + if $tlp->cataloguedata->{'date'}; + print "cat-license: ", $tlp->cataloguedata->{'license'}, "\n" + if $tlp->cataloguedata->{'license'}; + print "collection: ", @colls, "\n" if (@colls); + if ($opts{"keyword"} || $opts{"taxonomy"}) { + print "keywords: "; + if (defined($taxonomy->{'by-package'}{'keyword'}{$pkg})) { + print join(', ',@{$taxonomy->{'by-package'}{'keyword'}{$pkg}}), "\n"; + } else { + print "(none found)\n"; + } + } + if ($opts{"functionality"} || $opts{"taxonomy"}) { + print "function: "; + if (defined($taxonomy->{'by-package'}{'functionality'}{$pkg})) { + print join(', ',@{$taxonomy->{'by-package'}{'functionality'}{$pkg}}), "\n"; + } else { + print "(none found)\n"; + } + } + if ($opts{"characterization"} || $opts{"taxonomy"}) { + print "primary characterization: "; + if (defined($taxonomy->{'by-package'}{'primary'}{$pkg})) { + print $taxonomy->{'by-package'}{'primary'}{$pkg}, "\n"; + } else { + print "(none found)\n"; + } + print "secondary characterization: "; + if (defined($taxonomy->{'by-package'}{'secondary'}{$pkg})) { + print $taxonomy->{'by-package'}{'secondary'}{$pkg}, "\n"; + } else { + print "(none found)\n"; } - if ($opts{"list"}) { - if ($tlp->category eq "Collection" || $tlp->category eq "Scheme") { - # in the case of collections of schemes we list the deps - my @deps = $tlp->depends; - if (@deps) { - print "depends:\n"; - for my $d (@deps) { - print "\t$d\n"; - } + } + if ($opts{"list"}) { + if ($tlp->category eq "Collection" || $tlp->category eq "Scheme") { + # in the case of collections of schemes we list the deps + my @deps = $tlp->depends; + if (@deps) { + print "depends:\n"; + for my $d (@deps) { + print "\t$d\n"; } } - print "Included files, by type:\n"; - # if the package has a .ARCH dependency we also list the files for - # those packages - my @todo = $tlpdb->expand_dependencies("-only-arch", $tlpdb, ($pkg)); - for my $d (sort @todo) { - my $foo = $tlpdb->get_package($d); - if (!$foo) { - tlwarn ("\nShould not happen, no dependent package $d\n"); - next; - } - if ($d ne $pkg) { - print "depending package $d:\n"; - } - if ($foo->runfiles) { - print "run files:\n"; - for my $f (sort $foo->runfiles) { print " $f\n"; } - } - if ($foo->srcfiles) { - print "source files:\n"; - for my $f (sort $foo->srcfiles) { print " $f\n"; } - } - if ($foo->docfiles) { - print "doc files:\n"; - for my $f (sort $foo->docfiles) { - print " $f"; - my $dfd = $foo->docfiledata; - if (defined($dfd->{$f})) { - for my $k (keys %{$dfd->{$f}}) { - print " $k=\"", $dfd->{$f}->{$k}, '"'; - } + } + print "Included files, by type:\n"; + # if the package has a .ARCH dependency we also list the files for + # those packages + my @todo = $tlpdb->expand_dependencies("-only-arch", $tlpdb, ($pkg)); + for my $d (sort @todo) { + my $foo = $tlpdb->get_package($d); + if (!$foo) { + tlwarn ("\nShould not happen, no dependent package $d\n"); + next; + } + if ($d ne $pkg) { + print "depending package $d:\n"; + } + if ($foo->runfiles) { + print "run files:\n"; + for my $f (sort $foo->runfiles) { print " $f\n"; } + } + if ($foo->srcfiles) { + print "source files:\n"; + for my $f (sort $foo->srcfiles) { print " $f\n"; } + } + if ($foo->docfiles) { + print "doc files:\n"; + for my $f (sort $foo->docfiles) { + print " $f"; + my $dfd = $foo->docfiledata; + if (defined($dfd->{$f})) { + for my $k (keys %{$dfd->{$f}}) { + print " $k=\"", $dfd->{$f}->{$k}, '"'; } - print "\n"; } + print "\n"; } - # in case we have them - if ($foo->allbinfiles) { - print "bin files (all platforms):\n"; - for my $f (sort $foo->allbinfiles) { print " $f\n"; } - } + } + # in case we have them + if ($foo->allbinfiles) { + print "bin files (all platforms):\n"; + for my $f (sort $foo->allbinfiles) { print " $f\n"; } } } - print "\n"; - } else { - printf STDERR "tlmgr: cannot find $pkg\n"; } + print "\n"; } return; } @@ -2048,7 +2111,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"}) { @@ -2149,17 +2217,38 @@ $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; } +sub upd_info { + my ($pkg, $kb, $lrev, $mrev, $txt) = @_; + my $flen = 25; + my $kbstr = ($kb >= 0 ? " [${kb}k]" : ""); + my $kbstrlen = length($kbstr); + my $pkglen = length($pkg); + my $is = sprintf("%-9s ", "$txt:"); + if ($pkglen + $kbstrlen > $flen) { + $is .= "$pkg$kbstr: "; + } else { + $is .= sprintf ('%*2$s', $pkg, -($flen-$kbstrlen)); + $is .= "$kbstr: "; + } + $is .= sprintf("local: %8s, source: %8s", + $lrev, $mrev); + info("$is\n"); +} + sub action_update { init_local_db(1); $opts{"no-depends"} = 1 if $opts{"no-depends-at-all"}; @@ -2414,20 +2503,36 @@ next; } 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"; + } if ($rev < $mediarev) { $updated{$pkg} = 0; # will be changed to one on successful update } elsif ($rev > $mediarev) { if ($::machinereadable) { push @addlines, - machine_line("-ret", $pkg, $FLAG_REVERSED_UPDATE, $rev, $mediarev, "-"); + machine_line("-ret", $pkg, $FLAG_REVERSED_UPDATE, $rev, $mediarev, "-", @addargs); } else { - info("$pkg: local: $rev, source: $mediarev (reverse, keep)\n"); + if ($opts{"list"}) { + # not issueing anything if we keep a package + upd_info($pkg, -1, $rev, $mediarevstr, "keep"); + } } } } @@ -2525,6 +2630,8 @@ } } + # parameters for field width + my $totalnrdigits = length("$totalnr"); # # ORDER OF PACKAGE ACTIONS @@ -2557,7 +2664,7 @@ if ($::machinereadable) { machine_line($p, $FLAG_REMOVE, $rev, "-", "-", "-"); } else { - info("$p: local: $rev, source: (auto-remove)\n"); + upd_info($p, -1, $rev, "", "autorm"); } $currnr++; } else { @@ -2569,7 +2676,8 @@ if ($::machinereadable) { machine_line($p, $FLAG_REMOVE, $rev, "-", "-", "-"); } else { - info("[$currnr/$totalnr] auto-remove: $p\n"); + info("[" . sprintf ('%*2$s', $currnr, $totalnrdigits) . + "/$totalnr] auto-remove: $p ... "); } if (!$opts{"dry-run"}) { if ($opts{"backup"}) { @@ -2585,6 +2693,7 @@ $localtlpdb->remove_package($p); logpackage("remove: $p"); } + info("done\n") unless $::machinereadable; $currnr++; } } @@ -2678,19 +2787,44 @@ 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"); + upd_info($pkg, $kb, $rev, $mediarevstr, "update"); + if ($remotetlpdb->is_virtual) { + my @cand = $remotetlpdb->candidates($pkg); + shift @cand; # remove the top element + if (@cand) { + print "\tother candidates: "; + for my $a (@cand) { + my ($t,$r) = split(/\//, $a, 2); + print $r . '@' . $t . " "; + } + print "\n"; + } + } } $updated{$pkg} = 1; next; @@ -2731,10 +2865,11 @@ } 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("[" . sprintf ('%*2$s', $currnr, $totalnrdigits) . + "/$totalnr, $estrem/$esttot] update: $pkg [${kb}k] ($rev -> $mediarevstr)"); } $donesize += $sizes{$pkg}; $currnr++; @@ -2777,7 +2912,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; @@ -2805,7 +2940,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 @@ -2846,12 +2981,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\n"); next; } my $mediarev = $mediatlp->revision; + my $mediarevstr = $mediarev; + my @addargs; + if ($remotetlpdb->is_virtual) { + $mediarevstr .= "\@$maxtag"; + push @addargs, $maxtag; + } my ($estrem, $esttot); if (!$opts{"list"}) { ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize, @@ -2861,14 +3009,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"); + upd_info($pkg, $kb, "", $mediarevstr, "autoinst"); } 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++; @@ -2876,7 +3026,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"); @@ -3023,6 +3173,7 @@ if (!(@new || @updated)) { info("tlmgr: no updates available\n"); if ($remotetlpdb->media ne "NET" + && $remotetlpdb->media ne "virtual" && !$opts{"dry-run"} && !$opts{"repository"} ) { @@ -3101,6 +3252,14 @@ @packs = $remotetlpdb->expand_dependencies($localtlpdb, @packs) unless $opts{"no-depends"}; } # + # expand dependencies returns a list pkg@tag in case of a virtual + # remote db. + my %packs; + for my $p (@packs) { + my ($pp, $aa) = split('@', $p); + $packs{$pp} = (defined($aa) ? $aa : 0); + } + # # installation order of packages: # first all normal packages, then collections, then schemes # isn't already installed, but the collection already updated, it will @@ -3108,7 +3267,7 @@ my @inst_packs; my @inst_colls; my @inst_schemes; - for my $pkg (sort @packs) { + for my $pkg (sort keys %packs) { # we do name checking here, not to load all tlpobj again and again if ($pkg =~ m/^scheme-/) { push @inst_schemes, $pkg; @@ -3127,7 +3286,11 @@ my @todo; for my $pkg (@inst_packs, @inst_colls, @inst_schemes) { my $pkgrev = 0; - my $mediatlp = $remotetlpdb->get_package($pkg); + # if the package name is asked from a specific repository, use + # that one, otherwise leave the decision to $remotetlpdb by not + # giving a final argument + my $mediatlp = $remotetlpdb->get_package($pkg, + ($packs{$pkg} ? $packs{$pkg} : undef)); if (!defined($mediatlp)) { tlwarn("package $pkg not present in package repository.\n"); next; @@ -3175,13 +3338,26 @@ my ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize, $donesize, $starttime); my $kb = int($sizes{$pkg} / 1024) + 1; + my @addargs = (); + my $tagstr = ""; + if ($remotetlpdb->is_virtual) { + if ($packs{$pkg} ne "0") { + push @addargs, $packs{$pkg}; + $tagstr = " \@" . $packs{$pkg}; + } else { + my ($maxtag,undef,undef,undef) = $remotetlpdb->virtual_candidate($pkg); + push @addargs, $maxtag; + $tagstr = " \@" . $maxtag; + } + } if ($::machinereadable) { - machine_line($pkg, $flag, "-", $revs{$pkg}, $sizes{$pkg}, $estrem, $esttot); + machine_line($pkg, $flag, "-", $revs{$pkg}, $sizes{$pkg}, $estrem, $esttot, @addargs); } else { - info("[$currnr/$totalnr, $estrem/$esttot] ${re}install: $pkg [${kb}k]\n"); + info("[$currnr/$totalnr, $estrem/$esttot] ${re}install: $pkg$tagstr [${kb}k]\n"); } if (!$opts{"dry-run"}) { - $remotetlpdb->install_package($pkg, $localtlpdb); + $remotetlpdb->install_package($pkg, $localtlpdb, + ($packs{$pkg} ? $packs{$pkg} : undef) ); logpackage("${re}install: $pkg"); } $donesize += $sizes{$pkg}; @@ -3204,7 +3380,7 @@ # we list them, otherwise we go direct into tlmgr show $pkg mode if ($what !~ m/^(collection|scheme)/i) { tlwarn("(switching to show mode)\n"); - action_show(); + action_show(@ARGV); return; } } else { @@ -3223,7 +3399,11 @@ } elsif ($what =~ m/^scheme/i) { @whattolist = $tlm->schemes; } else { - @whattolist = $tlm->list_packages; + if ($tlm->is_virtual) { + @whattolist = $tlm->list_packages("-all"); + } else { + @whattolist = $tlm->list_packages; + } } foreach (@whattolist) { next if ($_ =~ m/^00texlive/); @@ -3232,12 +3412,198 @@ } else { print " "; } - my $foo = $tlm->get_package($_)->shortdesc; + my $tlp = $tlm->get_package($_); + if (!$tlp) { + if ($remotetlpdb->is_virtual) { + # we might have the case that a package is present in a + # subsidiary repository, but not pinned, so it will + # not be found by ->get_package + # In this case we list all repositories shipping it, + # but warn that it is not pinned and thus not reachable. + my @cand = $remotetlpdb->candidates($_); + if (@cand) { + my $first = shift @cand; + if (defined($first)) { + tlwarn("strange, we have a first candidate but no tlp: $_\n"); + next; + } + # already shifted away the first element + if ($#cand >= 0) { + print "$_: --- no installable candidate found, \n"; + print " but present in subsidiary repositories without a pin.\n"; + print " This package is not reachable without pinning.\n"; + print " Repositories containing this package:\n"; + for my $a (@cand) { + my ($t,$r) = split(/\//, $a, 2); + my $tlp = $remotetlpdb->get_package($_, $t); + my $foo = $tlp->shortdesc; + print " $t: ", defined($foo) ? $foo : "(shortdesc missing)" , "\n"; + } + next; + } else { + tlwarn("strange, package listed but no residual candidates: $_\n"); + next; + } + } else { + tlwarn("strange, package listed but no candidates: $_\n"); + next; + } + } else { + tlwarn("strange, package cannot be found in remote tlpdb: $_\n"); + next; + } + } + my $foo = $tlp->shortdesc; print "$_: ", defined($foo) ? $foo : "(shortdesc missing)" , "\n"; } 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") { + # TODO TODO + # we have to make sure that there is ONE main repository!!! + %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 # @@ -4601,7 +4967,93 @@ # sub init_tlmedia { - if (defined($remotetlpdb) && ($remotetlpdb->root eq $location)) { + # 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; + # if we have only one repo, but this one contains a name tag #.... + # then we remove it and save the local tlpdb + if ($#tags == 0 && ($location =~ m/#/)) { + $location = $repos{$tags[0]}; + $localtlpdb->option("location", $location); + $localtlpdb->save; + %repos = repository_to_array($location); + } + # 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:\n"); + info("\tmain = " . $repos{'main'} . "\n"); + for my $t (@tags) { + if ($t ne 'main') { + info("\t$t = " . $repos{$t} . "\n"); + } + } +} + + + + +sub _init_tlmedia +{ + + # if we are already initialized to the same location, nothing + # needs to be done. + # if we are initialized to a virtual tlpdb, then we have to + # do in any case an initialization + if (defined($remotetlpdb) && !$remotetlpdb->is_virtual && + ($remotetlpdb->root eq $location)) { # nothing to be done return; } @@ -4614,10 +5066,28 @@ $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 @@ -4763,8 +5233,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), @@ -5561,6 +6053,42 @@ =back +=head2 repositoy + +=over 4 + +=item B + +=item B [I]> + +=item B> + +=item B[#I] [I[#I] ...]> + +This action manages the list of repositories. See L +below for detailed explanations. + +The first form list all configured repositories and the respective tags +if set. The second form adds a repository (and optionally attaching a +tag) to the list of repositories. The third from removes a repository, +either by full path/url, or by tag. The last form sets the list +of repositories to the items given on the command line, not keeping +previous settings. Be reminded that one of the repositories has to +be tagged as B
, otherwise all operations will fail. + +=back + +=head2 candidates + +=over 4 + +=item B> + +Shows the list of available candidates for package I. See +L below for details. + + +=back =head2 option @@ -6198,6 +6726,118 @@ GUI and a simplified GUI with only the important and mostly used settings. +=head1 MULTIPLE REPOSITORIES + +Most packages are distributed via the main TeX Live repository, but +sometimes local repositories are used to provide local packages +(like commercial fonts, internal styles), as well as alternative +package repositories for packages that cannot be included in +proper TeX Live due to license or other reasons. + +Without multiple repository support using these additional repositories +needed an extra invocation and temporarily setting the installation +source to this additional repository. By setting up all the +repositories as sources of packages one does not need to +use multiple invocations of tlmgr anymore. + +B Although support for multiple repositories has been +tested extensively, it does not guarantee proper operation. If you +want to be sure not to break anything, consider continuing +using multiple invocations of tlmgr. + +When using multiple repositories, one has to be the main repository, +which distributes most of the TeX Live packages. If you convert +from a single repository installation to a multiple repository +installation (by calling tlmgr repository add), the previously +set repository will be set as the main repository. + +By default, even if multiple repositories are configured, packages +are B installed from the main repository, as long as +packages are not explicitely pinned to a different repository. +That also means by simply adding another repository you will +B be able to install the packages from there, you first +have to specify which packages should be taken from a +different repository by specifying some pinning rules. + +=head2 Pinning + +Pinning a package is done by editing (adding) a file + + TEXMFLOCAL/tlpkg/pinning.txt + +which contains lines + + repo:pkg[,pkg] + +In this line the C is either the full URL saved in the +list or repositories, or one of the tags given. The C +are shell style globs for packages. + +By default everything is pinned to the main repository, so +you can imagine that at the end of the file pinning.txt there +is a line + + main:* + +If a package C is pinned to a repository, any package +C in any other repository, even if it has a higher +revision number, will not be considered as installable +candidate. + +=head2 Usage example with tlcontrib + +- check current repository: + + $ tlmgr repository list + List of repositories (with tags if set): + /var/www/norbert/tlnet + +- add tlcontrib repository (and give it a short name) + + $ tlmgr repository add http://tlcontrib.metatex.org/2011 tlcontrib + +- check repositories: + + $ tlmgr repository list + List of repositories (with tags if set): + http://tlcontrib.metatex.org/2011 (tlcontrib) + /var/www/norbert/tlnet (main) + + +- add a pinning to get cowfont from tlcontrib: + + $ mkdir -p `kpsewhich -var-value TEXMFLOCAL`/tlpkg + $ echo "tlcontrib:cowfont" > `kpsewhich -var-value TEXMFLOCAL`/tlpkg/pinning.txt + +- check that we can find cowfont: + + $ tlmgr show cowfont + tlmgr: using pinning file .../tlpkg/pinning.txt + tlmgr: package repository /var/www/norbert/tlnet http://tlcontrib.metatex.org/2011 + package: cowfont + category: Package + ... + +- install cowfont and context (which is needed!) + + $ tlmgr install context cowfont + tlmgr: using pinning file .../tlpkg/pinning.txt + tlmgr: package repository /var/www/norbert/tlnet http://tlcontrib.metatex.org/2011 + [1/11, ??:??/??:??] install: context.x86_64-linux @main [84k] + [2/11, 00:00/00:00] install: context @main [4274k] + [3/11, 00:01/00:02] install: cowfont @tlcontrib [655k] + [4/11, 00:05/00:09] install: metapost.x86_64-linux @main [198k] + [5/11, 00:05/00:09] install: metapost @main [72k] + [6/11, 00:05/00:09] install: mptopdf.x86_64-linux @main [1k] + [7/11, 00:06/00:11] install: mptopdf @main [37k] + [8/11, 00:06/00:11] install: stmaryrd @main [163k] + [9/11, 00:07/00:12] install: xetex.x86_64-linux @main [4442k] + [10/11, 00:08/00:08] install: xetex @main [46k] + [11/11, 00:08/00:08] install: xetexconfig @main [13k] + ... + +In the last part you see that the cowfont is installed from +the tlcontrib part (@tlcontrib). =head1 TAXONOMIES Index: texmf/scripts/texlive/tlmgrgui.pl =================================================================== --- texmf/scripts/texlive/tlmgrgui.pl.orig 2011-06-16 21:30:37.000000000 +0900 +++ texmf/scripts/texlive/tlmgrgui.pl 2012-03-29 02:38:57.124639975 +0900 @@ -1,13 +1,17 @@ #!/usr/bin/env perl # $Id: tlmgrgui.pl 23011 2011-06-16 12:30:37Z preining $ # -# Copyright 2009, 2010 Norbert Preining +# Copyright 2009, 2010, 2011, 2012 Norbert Preining # This file is licensed under the GNU General Public License version 2 # or any later version. # # GUI for tlmgr # version 2, completely rewritten GUI # +# +# TODO FOR MULTI SUPPORT +# - colorize the General config tab, if something is changed, show it in RED +# that can actually applied to single repo tlmgrgui, too # TODO: Fix return codes of execute_action sub items and execute_action # so that we can give a decent warning window # TODO: implement path adjustment also for Windows @@ -60,8 +64,17 @@ our @update_function_list; my $tlpdb_location; +my %tlpdb_repos; +my @tlpdb_tags; my $cmdline_location; my @critical_updates = (); + +my $single_repo_mode = 1; +my %repos; +my @tags; + +my $location_button; # uggg, change from far away ... + # # shortcuts for padding, expand/fill, and pack sides, anchors my @p_ii = qw/-padx 2m -pady 2m/; @@ -97,6 +110,7 @@ my $darktext; my $match_entry; my $loaded_text; +my $loaded_text_button; # # communication between filters and the rest @@ -169,6 +183,8 @@ # cmd line > tlpdb # save the two possible location for the menu $tlpdb_location = $localtlpdb->option("location"); + %tlpdb_repos = repository_to_array($tlpdb_location); + @tlpdb_tags = keys %tlpdb_repos; if (defined($opts{"location"})) { $cmdline_location = $opts{"location"}; } @@ -261,14 +277,13 @@ -selectmode => "none"); my $button_frame = $mw->Frame; - my $but; - $but = $button_frame->Button(-text => __("Load default"), - -command => sub { setup_location($tlpdb_location); $but->packForget; }); - $but->pack( + $loaded_text_button = $button_frame->Button(-text => __("Load default"), + -command => sub { setup_location($tlpdb_location); }); + $loaded_text_button->pack( -anchor => 'e', -padx => 0, -pady => 0, -ipadx => 0, -ipady => 0, -side => 'right'); $loaded_text = $button_frame->Label( - -text => __("Loaded repository:") . " " .__("none")); + -text => __("Loaded repository:") . " " . __("none")); $loaded_text->pack(-anchor => 'e', -padx => 0, -pady => 0, -ipadx => 0, -ipady => 0, -side => 'right'); @@ -484,8 +499,14 @@ # # FILE MENU # + my %foo = repository_to_array($tlpdb_location); + my @bar = keys %foo; + my $tlpdb_location_string = $tlpdb_location; + if ($#bar > 0) { + $tlpdb_location_string = __("multiple repositories"); + } $menu_file->add('command', - -label => __("Load default repository:") . " $tlpdb_location", + -label => __("Load default repository:") . " $tlpdb_location_string", -command => sub { setup_location($tlpdb_location); }); if (defined($cmdline_location)) { $menu_file->add('command', -label => __("Load cmd line repository:") . " $cmdline_location", @@ -663,7 +684,7 @@ -sticky => "nw"); } $tf->Label(-text => __("Remote Revision:"))->grid( - $tf->Label(-text => $Packages{$p}{'remoterevision'}), + $tf->Label(-text => $Packages{$p}{'remoterevisionstring'}), -sticky => "nw"); if (defined($Packages{$p}{'remotecatalogueversion'})) { $tf->Label(-text => __("Remote Catalogue Version:"))->grid( @@ -838,7 +859,7 @@ $t .= " ($Packages{$p}{'localcatalogueversion'})"; } $g->itemCreate($p, 2, -itemtype => 'text', -style => $st, -text => $t); - $t = ($Packages{$p}{'remoterevision'} || ''); + $t = ($Packages{$p}{'remoterevisionstring'} || ''); if ($Packages{$p}{'remotecatalogueversion'}) { $t .= " ($Packages{$p}{'remotecatalogueversion'})"; } @@ -905,9 +926,13 @@ return 0; } # check first for the default search type, the descriptions + # also match the remoterevisionstring to get search for repositories if ($match_descriptions) { if ($Packages{$p}{'match_desc'} =~ m/$r/i) { $found = 1; + } elsif (defined($Packages{$p}{'remoterevisionstring'}) && + $Packages{$p}{'remoterevisionstring'} =~ m/$r/i) { + $found = 1; } } if (!$found) { @@ -1046,12 +1071,20 @@ } %changeddefaults = (); for my $k (keys %defaults) { + $changeddefaults{$k}{'changed'} = 0; $changeddefaults{$k}{'value'} = $defaults{$k}; if ($TeXLive::TLConfig::TLPDBOptions{$k}->[0] eq "b") { $changeddefaults{$k}{'display'} = ($defaults{$k} ? __("Yes") : __("No")); } else { if ($k eq "file_assocs") { $changeddefaults{$k}{'display'} = $fileassocdesc[$defaults{$k}]; + } elsif ($k eq "location") { + if ($#tlpdb_tags > 0) { + # we are using multiple repositories + $changeddefaults{$k}{'display'} = __("multiple repositories"); + } else { + $changeddefaults{$k}{'display'} = $defaults{$k}; + } } else { $changeddefaults{$k}{'display'} = $defaults{$k}; } @@ -1075,11 +1108,23 @@ push @config_set_l, $back_config_set->Label(-text => __("Default package repository"), -anchor => "w"); - push @config_set_m, - $back_config_set->Label(-textvariable => \$changeddefaults{"location"}{'display'}); - push @config_set_r, - $back_config_set->Button(-text => __("Change"), - -command => sub { menu_default_location($sw); }); + if ($#tlpdb_tags > 0) { + my @vals = map { "$_:$tlpdb_repos{$_}" } sort sort_main_first @tlpdb_tags; + $location_button = $back_config_set->Button(-relief => 'flat', + -textvariable => \$changeddefaults{"location"}{'display'}); + $location_button->configure( + -command => sub { transient_show_multiple_repos($location_button, @vals); }); + push @config_set_m, $location_button; + push @config_set_r, + $back_config_set->Button(-text => __("Change"), + -command => sub { menu_multi_location($sw); }); + } else { + push @config_set_m, + $back_config_set->Label(-textvariable => \$changeddefaults{"location"}{'display'}); + push @config_set_r, + $back_config_set->Button(-text => __("Change"), + -command => sub { menu_default_location($sw); }); + } if ($mode_expert) { @@ -1383,48 +1428,240 @@ } } -# -# this function is used to edit/change the default tlpdb repository -# we also want to change the menu entry if we change that -sub menu_default_location { - my $mw = shift; +sub ask_one_repository { + my ($mw, $title, $info) = @_; my $val; - my $sw = $mw->Toplevel(-title => __("Change default package repository")); + my $done; + my $sw = $mw->Toplevel(-title => $title); $sw->transient($mw); - $sw->grab(); - $sw->Label(-text => __("New default package repository"))->pack(-padx => "2m", -pady => "2m"); + $sw->withdraw; + $sw->Label(-text => $info)->pack(-padx => "2m", -pady => "2m"); my $f1 = $sw->Frame; - my $entry = $f1->Entry(-text => $val, -width => 50); - $entry->pack(-side => "left",-padx => "2m", -pady => "2m"); + my @mirror_list; + push @mirror_list, " " . __("Default remote repository") . ": http://mirror.ctan.org"; + push @mirror_list, TeXLive::TLUtils::create_mirror_list(); + my $entry = $f1->BrowseEntry( + -listheight => 12, + -listwidth => 400, + -width => 50, + -autolistwidth => 1, + -choices => \@mirror_list, + -browsecmd => + sub { + if ($val !~ m/^ /) { + $val = ""; + } elsif ($val =~ m!(http|ftp)://!) { + $val = TeXLive::TLUtils::extract_mirror_entry($val); + } else { + $val =~ s/^\s*//; + } + }, + -variable => \$val)->pack(-side => "left",-padx => "2m", -pady => "2m"); + + #my $entry = $f1->Entry(-text => $val, -width => 50); + #$entry->pack(-side => "left",-padx => "2m", -pady => "2m"); my $f2 = $sw->Frame; $f2->Button(-text => __("Choose Directory"), -command => sub { - my $var = $sw->chooseDirectory; - if (defined($var)) { - $entry->delete(0,"end"); - $entry->insert(0,$var); - } + $val = $sw->chooseDirectory; + #if (defined($var)) { + # $entry->delete(0,"end"); + # $entry->insert(0,$var); + #} })->pack(-side => "left",-padx => "2m", -pady => "2m"); $f2->Button(-text => __("Default remote repository"), -command => sub { - $entry->delete(0,"end"); - $entry->insert(0,$TeXLiveURL); + #$entry->delete(0,"end"); + #$entry->insert(0,$TeXLiveURL); + $val = $TeXLiveURL; })->pack(-side => "left",-padx => "2m", -pady => "2m"); $f1->pack; $f2->pack; my $f = $sw->Frame; my $okbutton = $f->Button(-text => __("Ok"), + -command => sub { $done = 1; } + )->pack(-side => 'left',-padx => "2m", -pady => "2m"); + my $cancelbutton = $f->Button(-text => __("Cancel"), + -command => sub { $val = undef; $done = 1; } + )->pack(-side => 'right',-padx => "2m", -pady => "2m"); + $f->pack(-expand => 'x'); + $sw->bind('', [ $okbutton, 'Invoke' ]); + $sw->bind('', [ $cancelbutton, 'Invoke' ]); + my $old_focus = $sw->focusSave; + my $old_grab = $sw->grabSave; + $sw->Popup; + $sw->grab; + $sw->waitVariable(\$done); + $sw->grabRelease if Tk::Exists($sw); + $sw->destroy if Tk::Exists($sw); + return $val; +} + +sub menu_default_location { + my $mw = shift; + my $ret = ask_one_repository($mw, __("Change default package repository"), + __("New default package repository")); + if (defined($ret)) { + $changeddefaults{'location'}{'value'} = + $changeddefaults{'location'}{'display'} = $ret; + } +} + +sub sort_main_first { + if ($a eq 'main') { + if ($b eq 'main') { + return 0; + } else { + return -1; + } + } else { + if ($b eq 'main') { + return 1; + } else { + return ($a cmp $b); + } + } +} + +sub menu_multi_location { + my $mw = shift; + my $val; + our $sw = $mw->Toplevel(-title => __("Edit default package repositories")); + $sw->transient($mw); + $sw->grab(); + $sw->Label(-text => __("Specify set of repositories to be used"))->pack(-padx => "2m", -pady => "2m"); + + our $f1 = $sw->Frame; + my @entry_tag; our $tagw = 10; + my @entry_loc; our $locw = 30; + my @entry_del; + my @entry_chg; + + my $addrepo_button; + + + sub add_buttons { + my ($ref) = @_; + my $t = $ref->{'tag'}; + $ref->{'tag_w'} = $f1->Entry(-textvariable => \$ref->{'tag'}, -state => ($t eq "main" ? 'readonly' : 'normal'), -width => $tagw); + $ref->{'val_w'} = $f1->Entry(-textvariable => \$ref->{'val'}, -width => $locw); + $ref->{'del_w'} = $f1->Button(-text => __("Delete"), + -state => ($t eq "main" ? 'disabled' : 'normal'), + -command => sub { + $ref->{'status'} = 0; + $ref->{'tag_w'}->configure(-state => 'disabled'); + $ref->{'val_w'}->configure(-state => 'disabled'); + $ref->{'del_w'}->configure(-state => 'disabled'); + $ref->{'chg_w'}->configure(-state => 'disabled'); + }); + $ref->{'chg_w'} = $f1->Button(-text => __("Change"), + -command => sub { + my $ret = ask_one_repository($sw, __("Change " . ($t eq "main" ? "main" : "subsidiary") . " package repository"), + __(($t eq "main" ? "Change main" : "New subsidiary") . " package repository")); + $ref->{'val'} = $ret if (defined($ret)); + }); + } + + my %changed_repos = repository_to_array($changeddefaults{'location'}{'value'}); + + my @edit_repos; + push @edit_repos, { 'tag' => 'main', 'val' => $changed_repos{'main'}, 'status' => 1}; + for my $k (sort keys %changed_repos) { + next if ($k eq "main"); + push @edit_repos, { 'tag'=> $k, 'val' => $changed_repos{$k}, 'status' => 1 }; + } + for my $ref (@edit_repos) { + add_buttons($ref); + } + for my $ref (@edit_repos) { + my %foo = %$ref; + $foo{'tag_w'}->grid($foo{'val_w'}, $foo{'del_w'}, $foo{'chg_w'}, + -padx => "1m", -pady => "1m", -sticky => "nwe"); + } + $addrepo_button = $f1->Button(-text => __("Add repository") . "...", + -command => sub { + my $ret = ask_one_repository($sw, __("Add package repository"), + __("Add package repository")); + if (defined($ret)) { + $addrepo_button->gridForget; + my %foo = ( 'tag' => $ret, 'val' => $ret, 'status' => 1 ); + add_buttons(\%foo); + $foo{'tag_w'}->grid($foo{'val_w'}, $foo{'del_w'}, $foo{'chg_w'}, + -padx => "1m", -pady => "1m", -sticky => "nwe"); + push @edit_repos, \%foo; + } + $addrepo_button->grid(-columnspan => 2, -column => 2); + }); + $addrepo_button->grid(-columnspan => 2, -column => 2); + + $f1->pack; + + my $f = $sw->Frame; + my $okbutton = $f->Button(-text => __("Ok"), -command => sub { - $changeddefaults{'location'}{'value'} = - $changeddefaults{'location'}{'display'} = $entry->get; + # we have to check if something has changed ... and for consistency!!! + my %new_repos; + for my $ref (@edit_repos) { + my %foo = %$ref; + if ($foo{'status'}) { + if (defined($new_repos{$foo{'tag'}})) { + $sw->Dialog(-title => __("Warning"), + -text => __("Multiple defined tags (first column) are not possible, please fix it."), -buttons => [ __("Ok") ])->Show; + return; + } + $new_repos{$foo{'tag'}} = $foo{'val'}; + } + } + my $differs = 0; + for my $k (keys %changed_repos) { + if (!defined($new_repos{$k})) { + $differs = 1; + last; + } + if ($changed_repos{$k} ne $new_repos{$k}) { + $differs = 1; + last; + } + } + if (!$differs) { + # do the same the other way round + for my $k (keys %new_repos) { + if (!defined($changed_repos{$k})) { + $differs = 1; + last; + } + if ($changed_repos{$k} ne $new_repos{$k}) { + $differs = 1; + last; + } + } + } + if ($differs) { + # print "current repos:\n"; + # for my $ref (@edit_repos) { + # print "tag = $ref->{'tag'}\n"; + # print "val = $ref->{'val'}\n"; + # print "act = $ref->{'status'}\n"; + # } + $changeddefaults{'location'}{'value'} = array_to_repository(%new_repos); + $changeddefaults{'location'}{'display'} = __("multiple repositories"); + my @vals = map { "$_:$new_repos{$_}" } + sort sort_main_first keys %new_repos; + $location_button->configure( + -command => sub { transient_show_multiple_repos($location_button, @vals); }); + } else { + # print "Nothing happend!\n"; + } $sw->destroy; })->pack(-side => 'left',-padx => "2m", -pady => "2m"); my $cancelbutton = $f->Button(-text => __("Cancel"), -command => sub { $sw->destroy })->pack(-side => 'right',-padx => "2m", -pady => "2m"); + my $resetbutton = $f->Button(-text => __("Revert"), + -command => sub { $sw->destroy; menu_multi_location($mw); })->pack(-side => 'right',-padx => "2m", -pady => "2m"); $f->pack(-expand => 'x'); $sw->bind('', [ $okbutton, 'Invoke' ]); $sw->bind('', [ $cancelbutton, 'Invoke' ]); @@ -1554,19 +1791,27 @@ sub setup_location { my $loc = shift; $location = $loc; - update_loaded_location_string(); + # first check if $location contains multiple locations + # in this case we go to virtual mode + %repos = (); + %repos = repository_to_array($location); + @tags = keys %repos; + if ($#tags == 0) { + $single_repo_mode = 1; + } else { + $single_repo_mode = 0; + } run_update_functions(); } sub init_install_media { my $newroot = $location; - if (defined($remotetlpdb) && ($remotetlpdb->root eq $newroot)) { + if (defined($remotetlpdb) && !$remotetlpdb->is_virtual && + ($remotetlpdb->root eq $newroot)) { # nothing to be done } else { $mw->Busy(-recurse => 1); - info(__("Loading remote TeX Live Database\nThis may take some time, please wait!") . "\n"); - $remotetlpdb = TeXLive::TLPDB->new(root => $newroot); - info(__("Completed") . ".\n"); + init_tlmedia(); $mw->Unbusy; if (!defined($remotetlpdb)) { # something went badly wrong, maybe the newroot is wrong? @@ -1725,7 +1970,7 @@ # sub populate_Packages # sub populate_Packages { - my ($mode, $tlp) = @_; + my ($mode, $tlp, $maxtag) = @_; my $p = $tlp->name; $Packages{$p}{'displayname'} = $p; if ($mode eq "local") { @@ -1736,6 +1981,10 @@ $Packages{$p}{'tlp'} = $tlp; } else { $Packages{$p}{'remoterevision'} = $tlp->revision; + $Packages{$p}{'remoterevisionstring'} = $tlp->revision; + if ($remotetlpdb->is_virtual) { + $Packages{$p}{'remoterevisionstring'} .= "\@$maxtag"; + } $Packages{$p}{'selected'} = 0 unless defined $Packages{$p}{'selected'}; if (!defined($Packages{$p}{'tlp'})) { @@ -1865,6 +2114,7 @@ next; } delete $Packages{$p}{'remoterevision'}; + delete $Packages{$p}{'remoterevisionstring'}; delete $Packages{$p}{'remotecatalogueversion'}; } if (defined($remotetlpdb)) { @@ -1875,8 +2125,15 @@ push @do_later_media, $p; next; } - my $tlp = $remotetlpdb->get_package($p); - populate_Packages("remote", $tlp); + my $tlp; + my $maxtag; + if ($remotetlpdb->is_virtual) { + ($maxtag, undef, $tlp, undef) = + $remotetlpdb->virtual_candidate($p); + } else { + $tlp = $remotetlpdb->get_package($p); + } + populate_Packages("remote", $tlp, $maxtag); } } my @avail_arch = $localtlpdb->available_architectures; @@ -1886,9 +2143,16 @@ tlerror("very strange, above it matched and now not anymore?!?! $p\n"); next; } - my $tlp = $remotetlpdb->get_package($p); + my $tlp; + my $maxtag; + if ($remotetlpdb->is_virtual) { + ($maxtag, undef, $tlp, undef) = + $remotetlpdb->virtual_candidate($p); + } else { + $tlp = $remotetlpdb->get_package($p); + } if (!defined($Packages{$mp})) { - populate_Packages("remote", $tlp); + populate_Packages("remote", $tlp, $maxtag); } else { # two cases: # - $mp.$ma where $ma is in available_archs @@ -1926,7 +2190,7 @@ } else { # only show that one if it is locally installed if (defined($Packages{$p})) { - populate_Packages("remote", $tlp); + populate_Packages("remote", $tlp, $maxtag); } } } @@ -2216,7 +2480,47 @@ sub update_loaded_location_string { my $arg = shift; $arg || ($arg = $location); - $loaded_text->configure(-text => __("Loaded repository:") . " " . $arg); + my %repos = repository_to_array($arg); + my @tags = sort keys %repos; + my @vals; + if ($#tags > 0) { + @vals = map { "$_:$repos{$_}" } sort sort_main_first @tags; + } else { + @vals = ( $arg ); + } + my $locstr; + if ($#tags > 0) { + $locstr = $repos{'main'}; + for my $t (keys %repos) { + if ($t ne 'main') { + $locstr .= " $repos{$t}"; + } + } + $loaded_text_button->configure(-text => __("multiple repositories")); + } else { + $loaded_text_button->configure(-text => $arg); + } + $loaded_text->configure(-text => __("Loaded repository:")); + $loaded_text_button->configure( -command => + sub { transient_show_multiple_repos($loaded_text_button, @vals); }); +} + +sub transient_show_multiple_repos { + my ($ref_widget, @vals) = @_; + my $xx = $ref_widget->rootx; + my $yy = $ref_widget->rooty + $ref_widget->reqheight; + my $sw = $mw->Toplevel(-bd => 2); + $sw->geometry("+$xx+$yy"); + $sw->overrideredirect(1); + $sw->transient($mw); + $sw->grab; + # we want to have a global grab, but that somehow does not work! + #$sw->grabGlobal; + $sw->bind('<1>', sub { $sw->grabRelease; $sw->destroy; }); + my $foo = $sw->Listbox(-height => 0, -width => 0, + -listvariable => \@vals, + -state => 'normal'); + $foo->pack; } sub run_update_functions {