"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/TeXLive/TLPDB.pm" (13 May 2020, 86417 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 # $Id: TLPDB.pm 55126 2020-05-13 17:27:10Z karl $
    2 # TeXLive::TLPDB.pm - tlpdb plain text database files.
    3 # Copyright 2007-2020 Norbert Preining
    4 # This file is licensed under the GNU General Public License version 2
    5 # or any later version.
    6 
    7 package TeXLive::TLPDB;
    8 
    9 my $svnrev = '$Revision: 55126 $';
   10 my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
   11 sub module_revision { return $_modulerevision; }
   12 
   13 =pod
   14 
   15 =head1 NAME
   16 
   17 C<TeXLive::TLPDB> -- A database of TeX Live Packages
   18 
   19 =head1 SYNOPSIS
   20 
   21   use TeXLive::TLPDB;
   22 
   23   TeXLive::TLPDB->new ();
   24   TeXLive::TLPDB->new (root => "/path/to/texlive/installation/root");
   25 
   26   $tlpdb->root("/path/to/root/of/texlive/installation");
   27   $tlpdb->copy;
   28   $tlpdb->from_file($filename);
   29   $tlpdb->writeout;
   30   $tlpdb->writeout(FILEHANDLE);
   31   $tlpdb->as_json;
   32   $tlpdb->save;
   33   $tlpdb->media;
   34   $tlpdb->available_architectures();
   35   $tlpdb->add_tlpobj($tlpobj);
   36   $tlpdb->needed_by($pkg);
   37   $tlpdb->remove_tlpobj($pkg);
   38   $tlpdb->get_package("packagename");
   39   $tlpdb->list_packages ( [$tag] );
   40   $tlpdb->expand_dependencies(["-only-arch",] $totlpdb, @list);
   41   $tlpdb->expand_dependencies(["-no-collections",] $totlpdb, @list);
   42   $tlpdb->find_file("filename");
   43   $tlpdb->collections;
   44   $tlpdb->schemes;
   45   $tlpdb->updmap_cfg_lines;
   46   $tlpdb->fmtutil_cnf_lines;
   47   $tlpdb->language_dat_lines;
   48   $tlpdb->language_def_lines;
   49   $tlpdb->language_lua_lines;
   50   $tlpdb->package_revision("packagename");
   51   $tlpdb->location;
   52   $tlpdb->platform;
   53   $tlpdb->is_verified;
   54   $tlpdb->verification_status;
   55   $tlpdb->config_src_container;
   56   $tlpdb->config_doc_container;
   57   $tlpdb->config_container_format;
   58   $tlpdb->config_release;
   59   $tlpdb->config_minrelease;
   60   $tlpdb->config_revision;
   61   $tlpdb->config_frozen;
   62   $tlpdb->options;
   63   $tlpdb->option($key, [$value]);
   64   $tlpdb->reset_options();
   65   $tlpdb->add_default_options();
   66   $tlpdb->settings;
   67   $tlpdb->setting($key, [$value]);
   68   $tlpdb->setting([-clear], $key, [$value]);
   69   $tlpdb->sizes_of_packages($opt_src, $opt_doc, $ref_arch_list [, @packs ]);
   70   $tlpdb->sizes_of_packages_with_deps($opt_src, $opt_doc, $ref_arch_list [, @packs ]);
   71   $tlpdb->install_package($pkg, $dest_tlpdb);
   72   $tlpdb->remove_package($pkg, %options);
   73   $tlpdb->install_package_files($file [, $file ]);
   74 
   75   TeXLive::TLPDB->listdir([$dir]);
   76   $tlpdb->generate_listfiles([$destdir]);
   77 
   78   $tlpdb->make_virtual;
   79   $tlpdb->is_virtual;
   80   $tlpdb->virtual_add_tlpdb($tlpdb, $tag);
   81   $tlpdb->virtual_remove_tlpdb($tag);
   82   $tlpdb->virtual_get_tags();
   83   $tlpdb->virtual_get_tlpdb($tag);
   84   $tlpdb->virtual_get_package($pkg, $tag);
   85   $tlpdb->candidates($pkg);
   86   $tlpdb->virtual_candidate($pkg);
   87   $tlpdb->virtual_pinning( [ $pin_file_TLConfFile ] );
   88 
   89 =head1 DESCRIPTION
   90 
   91 =cut
   92 
   93 use TeXLive::TLConfig qw($CategoriesRegexp $DefaultCategory $InfraLocation
   94       $DatabaseName $DatabaseLocation $MetaCategoriesRegexp $Archive
   95       $DefaultCompressorFormat %Compressors $CompressorExtRegexp
   96       %TLPDBOptions %TLPDBSettings $ChecksumExtension
   97       $RelocPrefix $RelocTree);
   98 use TeXLive::TLCrypto;
   99 use TeXLive::TLPOBJ;
  100 use TeXLive::TLUtils qw(dirname mkdirhier member win32 info log debug ddebug
  101                         tlwarn basename download_file merge_into tldie system_pipe);
  102 use TeXLive::TLWinGoo;
  103 
  104 use Cwd 'abs_path';
  105 
  106 my $_listdir;
  107 
  108 =pod
  109 
  110 =over 4
  111 
  112 =item C<< TeXLive::TLPDB->new >>
  113 
  114 =item C<< TeXLive::TLPDB->new( [root => "$path"] ) >>
  115 
  116 C<< TeXLive::TLPDB->new >> creates a new C<TLPDB> object. If the
  117 argument C<root> is given it will be initialized from the respective
  118 location starting at $path. If C<$path> begins with C<http://>, C<https://>,
  119 C<ftp://>, C<scp://>, C<ssh://> or C<I<user>@I<host>:>, the respective file
  120 is downloaded.  The C<$path> can also start with C<file:/> in which case it
  121 is treated as a file on the filesystem in the usual way.
  122 
  123 Returns an object of type C<TeXLive::TLPDB>, or undef if the root was
  124 given but no package could be read from that location.
  125 
  126 =cut
  127 
  128 sub new { 
  129   my $class = shift;
  130   my %params = @_;
  131   my $self = {
  132     root => $params{'root'},
  133     tlps => $params{'tlps'},
  134     verified => 0
  135   };
  136   my $verify = defined($params{'verify'}) ? $params{'verify'} : 0;
  137   ddebug("TLPDB new: verify=$verify\n");
  138   $_listdir = $params{'listdir'} if defined($params{'listdir'});
  139   bless $self, $class;
  140   if (defined($params{'tlpdbfile'})) {
  141     my $nr_packages_read = $self->from_file($params{'tlpdbfile'}, 
  142       'from-file' => 1, 'verify' => $verify);
  143     if ($nr_packages_read == 0) {
  144       # that is bad, we didn't read anything, so return undef.
  145       return undef;
  146     }
  147     return $self;
  148   } 
  149   if (defined($self->{'root'})) {
  150     my $nr_packages_read
  151       = $self->from_file("$self->{'root'}/$DatabaseLocation",
  152         'verify' => $verify);
  153     if ($nr_packages_read == 0) {
  154       # that is bad, we didn't read anything, so return undef.
  155       return undef;
  156     }
  157   }
  158   return $self;
  159 }
  160 
  161 
  162 sub copy {
  163   my $self = shift;
  164   my $bla = {};
  165   %$bla = %$self;
  166   bless $bla, "TeXLive::TLPDB";
  167   return $bla;
  168 }
  169 
  170 =pod
  171 
  172 =item C<< $tlpdb->add_tlpobj($tlpobj) >>
  173 
  174 The C<add_tlpobj> adds an object of the type TLPOBJ to the TLPDB.
  175 
  176 =cut
  177 
  178 sub add_tlpobj {
  179   my ($self,$tlp) = @_;
  180   if ($self->is_virtual) {
  181     tlwarn("TLPDB: cannot add tlpobj to a virtual tlpdb\n");
  182     return 0;
  183   }
  184   $self->{'tlps'}{$tlp->name} = $tlp;
  185 }
  186 
  187 =pod
  188 
  189 =item C<< $tlpdb->needed_by($pkg) >>
  190 
  191 Returns an array of package names depending on $pkg.
  192 
  193 =cut
  194 
  195 sub needed_by {
  196   my ($self,$pkg) = @_;
  197   my @ret;
  198   for my $p ($self->list_packages) {
  199     my $tlp = $self->get_package($p);
  200     DEPENDS: for my $d ($tlp->depends) {
  201       # exact match
  202       if ($d eq $pkg) {
  203         push @ret, $p;
  204         last DEPENDS;  # of the for loop on all depends
  205       }
  206       # 
  207       if ($d =~ m/^(.*)\.ARCH$/) {
  208         my $parent = $1;
  209         for my $a ($self->available_architectures) {
  210           if ($pkg eq "$parent.$a") {
  211             push @ret, $p;
  212             last DEPENDS;
  213           }
  214         }
  215       }
  216     }
  217   }
  218   return @ret;
  219 }
  220 
  221 =pod
  222 
  223 =item C<< $tlpdb->remove_tlpobj($pkg) >>
  224 
  225 Remove the package named C<$pkg> from the tlpdb. Gives a warning if the
  226 package is not present
  227 
  228 =cut
  229 
  230 sub remove_tlpobj {
  231   my ($self,$pkg) = @_;
  232   if ($self->is_virtual) {
  233     tlwarn("TLPDB: cannot remove tlpobj from a virtual tlpdb\n");
  234     return 0;
  235   }
  236   if (defined($self->{'tlps'}{$pkg})) {
  237     delete $self->{'tlps'}{$pkg};
  238   } else {
  239     tlwarn("TLPDB: package to be removed not found: $pkg\n");
  240   }
  241 }
  242 
  243 =pod
  244 
  245 =item C<< $tlpdb->from_file($filename, @args) >>
  246 
  247 The C<from_file> function initializes the C<TLPDB> if the root was not
  248 given at generation time.  See L<TLPDB::new> for more information.
  249 
  250 It returns the actual number of packages (TLPOBJs) read from
  251 C<$filename>, and zero if there are problems (and gives warnings).
  252 
  253 =cut
  254 
  255 sub from_file {
  256   my ($self, $path, @args) = @_;
  257   my %params = @args;
  258   if ($self->is_virtual) {
  259     tlwarn("TLPDB: cannot initialize a virtual tlpdb from_file\n");
  260     return 0;
  261   }
  262   if (@_ < 2) {
  263     die "$0: from_file needs filename for initialization";
  264   }
  265   my $root_from_path = dirname(dirname($path));
  266   if (defined($self->{'root'})) {
  267     if ($self->{'root'} ne $root_from_path) {
  268      if (!$params{'from-file'}) {
  269       tlwarn("TLPDB: initialization from different location than original;\n");
  270       tlwarn("TLPDB: hope you are sure!\n");
  271       tlwarn("TLPDB: root=$self->{'root'}, root_from_path=$root_from_path\n");
  272      }
  273     }
  274   } else {
  275     $self->root($root_from_path);
  276   }
  277   $self->verification_status($VS_UNKNOWN);
  278   my $retfh;
  279   my $tlpdbfile;
  280   my $is_verified = 0;
  281   # do media detection
  282   my $rootpath = $self->root;
  283   if ($rootpath =~ m,https?://|ftp://,) {
  284     $media = 'NET';
  285   } elsif ($rootpath =~ m,$TeXLive::TLUtils::SshURIRegex,) {
  286     $media = 'NET';
  287   } else {
  288     if ($rootpath =~ m,file://*(.*)$,) {
  289       $rootpath = "/$1";
  290     }
  291     if ($params{'media'}) {
  292       $media = $params{'media'};
  293     } elsif (! -d $rootpath) {
  294       # no point in going on if we don't even have a directory.
  295       tlwarn("TLPDB: not a directory, not loading: $rootpath\n");
  296       return 0;
  297     } elsif (-d "$rootpath/texmf-dist/web2c") {
  298       $media = 'local_uncompressed';
  299     } elsif (-d "$rootpath/texmf/web2c") { # older
  300       $media = 'local_uncompressed';
  301     } elsif (-d "$rootpath/web2c") {
  302       $media = 'local_uncompressed';
  303     } elsif (-d "$rootpath/$Archive") {
  304       $media = 'local_compressed';
  305     } else {
  306       # we cannot find the right type, return zero, hope people notice
  307       tlwarn("TLPDB: Cannot determine type of tlpdb from $rootpath!\n");
  308       return 0;
  309     }
  310   }
  311   $self->{'media'} = $media;
  312   #
  313   # actually load the TLPDB
  314   if ($path =~ m;^((https?|ftp)://|file:\/\/*); || $path =~ m;$TeXLive::TLUtils::SshURIRegex;) {
  315     debug("TLPDB.pm: trying to initialize from $path\n");
  316     # now $xzfh filehandle is open, the file created
  317     # TLUtils::download_file will just overwrite what is there
  318     # on windows that doesn't work, so we close the fh immediately
  319     # this creates a short loophole, but much better than before anyway
  320     my $tlpdbfh;
  321     ($tlpdbfh, $tlpdbfile) = TeXLive::TLUtils::tl_tmpfile();
  322     # same as above
  323     close($tlpdbfh);
  324     # if we have xz available we try the xz file
  325     my $xz_succeeded = 0 ;
  326     my $compressorextension = "<UNSET>";
  327     if (defined($::progs{$DefaultCompressorFormat})) {
  328       # we first try the xz compressed file
  329       my ($xzfh, $xzfile) = TeXLive::TLUtils::tl_tmpfile();
  330       close($xzfh);
  331       my $decompressor = $::progs{$DefaultCompressorFormat};
  332       $compressorextension = $Compressors{$DefaultCompressorFormat}{'extension'};
  333       my @decompressorArgs = @{$Compressors{$DefaultCompressorFormat}{'decompress_args'}};
  334       debug("trying to download $path.$compressorextension to $xzfile\n");
  335       my $ret = TeXLive::TLUtils::download_file("$path.$compressorextension", "$xzfile");
  336       # better to check both, the return value AND the existence of the file
  337       if ($ret && (-r "$xzfile")) {
  338         # ok, let the fun begin
  339         debug("decompressing $xzfile to $tlpdbfile\n");
  340         # xz *hopefully* returns 0 on success and anything else on failure
  341         # we don't have to negate since not zero means error in the shell
  342         # and thus in perl true
  343         if (!system_pipe($decompressor, $xzfile, $tlpdbfile, 1, @decompressorArgs)) {
  344           debug("$decompressor $xzfile failed, trying plain file\n");
  345           unlink($xzfile); # the above command only removes in case of success
  346         } else {
  347           $xz_succeeded = 1;
  348           debug("found the uncompressed $DefaultCompressorFormat file\n");
  349         }
  350       } 
  351     } else {
  352       debug("no $DefaultCompressorFormat defined ...\n");
  353     }
  354     if (!$xz_succeeded) {
  355       debug("TLPDB: downloading $path.$compressorextension didn't succeed, try $path\n");
  356       my $ret = TeXLive::TLUtils::download_file($path, $tlpdbfile);
  357       # better to check both, the return value AND the existence of the file
  358       if ($ret && (-r $tlpdbfile)) {
  359         # do nothing
  360       } else {
  361         unlink($tlpdbfile);
  362         tldie(  "$0: TLPDB::from_file could not initialize from: $path\n"
  363               . "$0: Maybe the repository setting should be changed.\n"
  364               . "$0: More info: https://tug.org/texlive/acquire.html\n");
  365       }
  366     }
  367     # if we are still here, then either the xz version was downloaded
  368     # and unpacked, or the non-xz version was downloaded, and in both
  369     # cases the result, i.e., the unpackaged tlpdb, is in $tlpdbfile
  370     #
  371     # before we open and proceed, verify the downloaded file
  372     if ($params{'verify'} && $media ne 'local_uncompressed') {
  373       my ($verified, $status) = TeXLive::TLCrypto::verify_checksum_and_check_return($tlpdbfile, $path);
  374       $is_verified = $verified;
  375       $self->verification_status($status);
  376     }
  377     open($retfh, "<$tlpdbfile") || die "$0: open($tlpdbfile) failed: $!";
  378   } else {
  379     if ($params{'verify'} && $media ne 'local_uncompressed') {
  380       my ($verified, $status) = TeXLive::TLCrypto::verify_checksum_and_check_return($path, $path);
  381       $is_verified = $verified;
  382       $self->verification_status($status);
  383     }
  384     open(TMP, "<$path") || die "$0: open($path) failed: $!";
  385     $retfh = \*TMP;
  386   }
  387   my $found = 0;
  388   my $ret = 0;
  389   do {
  390     my $tlp = TeXLive::TLPOBJ->new;
  391     $ret = $tlp->from_fh($retfh,1);
  392     if ($ret) {
  393       $self->add_tlpobj($tlp);
  394       $found++;
  395     }
  396   } until (!$ret);
  397   if (! $found) {
  398     debug("$0: Could not load packages from\n");
  399     debug("  $path\n");
  400   }
  401 
  402   $self->{'verified'} = $is_verified;
  403 
  404   close($retfh);
  405   return($found);
  406 }
  407 
  408 =pod
  409 
  410 =item C<< $tlpdb->writeout >>
  411 
  412 =item C<< $tlpdb->writeout(FILEHANDLE) >>
  413 
  414 The C<writeout> function writes the database to C<STDOUT>, or 
  415 the file handle given as argument.
  416 
  417 =cut
  418 
  419 sub writeout {
  420   my $self = shift;
  421   if ($self->is_virtual) {
  422     tlwarn("TLPDB: cannot writeout a virtual tlpdb\n");
  423     return 0;
  424   }
  425   my $fd = (@_ ? $_[0] : STDOUT);
  426   foreach (sort keys %{$self->{'tlps'}}) {
  427     ddebug("writeout: tlpname=$_  ", $self->{'tlps'}{$_}->name, "\n");
  428     $self->{'tlps'}{$_}->writeout($fd);
  429     print $fd "\n";
  430   }
  431 }
  432 
  433 =pod
  434 
  435 =item C<< $tlpdb->as_json >>
  436 
  437 The C<as_json> function returns a JSON UTF8 encoded representation of the
  438 database, that is a JSON array of packages. If the database is virtual,
  439 a JSON array where each element is a hash with two keys, C<tag> giving
  440 the tag of the sub-database, and C<tlpdb> giving the JSON of the database.
  441 
  442 =cut
  443 
  444 sub as_json {
  445   my $self = shift;
  446   my $ret = "{";
  447   if ($self->is_virtual) {
  448     my $firsttlpdb = 1;
  449     for my $k (keys %{$self->{'tlpdbs'}}) {
  450       $ret .= ",\n" if (!$firsttlpdb);
  451       $ret .= "\"$k\":";
  452       $firsttlpdb = 0;
  453       $ret .= $self->{'tlpdbs'}{$k}->_as_json;
  454     }
  455   } else {
  456     $ret .= "\"main\":";
  457     $ret .= $self->_as_json;
  458   }
  459   $ret .= "}\n";
  460   return($ret);
  461 }
  462 
  463 sub options_as_json {
  464   my $self = shift;
  465   die("calling _as_json on virtual is not supported!") if ($self->is_virtual);
  466   my $opts = $self->options;
  467   my @opts;
  468   for my $k (keys %TLPDBOptions) {
  469     my %foo;
  470     $foo{'name'} = $k;
  471     $foo{'tlmgrname'} = $TLPDBOptions{$k}[2];
  472     $foo{'description'} = $TLPDBOptions{$k}[3];
  473     $foo{'format'} = $TLPDBOptions{$k}[0];
  474     $foo{'default'} = "$TLPDBOptions{$k}[1]";
  475     # if ($TLPDBOptions{$k}[0] =~ m/^n/) {
  476     #   if (exists($opts->{$k})) {
  477     #     $foo{'value'} = $opts->{$k};
  478     #     $foo{'value'} += 0;
  479     #   }
  480     #   $foo{'default'} += 0;
  481     # } elsif ($TLPDBOptions{$k}[0] eq "b") {
  482     #   if (exists($opts->{$k})) {
  483     #     $foo{'value'} = ($opts->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
  484     #   }
  485     #   $foo{'default'} = ($foo{'default'} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
  486     # } elsif ($k eq "location") {
  487     #   my %def;
  488     #   $def{'main'} = $TLPDBOptions{$k}[1];
  489     #   $foo{'default'} = \%def;
  490     #   if (exists($opts->{$k})) {
  491     #     my %repos = TeXLive::TLUtils::repository_to_array($opts->{$k});
  492     #     $foo{'value'} = \%repos;
  493     #   }
  494     # } elsif ($TLPDBOptions{$k}[0] eq "p") {
  495     #   # strings/path
  496     #   if (exists($opts->{$k})) {
  497     #     $foo{'value'} = $opts->{$k};
  498     #   }
  499     # } else {
  500     
  501     # TREAT ALL VALUES AS STRINGS, otherwise not parsable JSON
  502       # treat as strings
  503       if (exists($opts->{$k})) {
  504         $foo{'value'} = $opts->{$k};
  505       }
  506     #  }
  507     push @opts, \%foo;
  508   }
  509   return(TeXLive::TLUtils::encode_json(\@opts));
  510 }
  511 
  512 sub settings_as_json {
  513   my $self = shift;
  514   die("calling _as_json on virtual is not supported!") if ($self->is_virtual);
  515   my $sets = $self->settings;
  516   my @json;
  517   for my $k (keys %TLPDBSettings) {
  518     my %foo;
  519     $foo{'name'} = $k;
  520     $foo{'type'} = $TLPDBSettings{$k}[0];
  521     $foo{'description'} = $TLPDBSettings{$k}[1];
  522     # if ($TLPDBSettings{$k}[0] eq "b") {
  523     #   if (exists($sets->{$k})) {
  524     #     $foo{'value'} = ($sets->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
  525     #   }
  526     # } elsif ($TLPDBSettings{$k} eq "available_architectures") {
  527     #   if (exists($sets->{$k})) {
  528     #     my @lof = $self->available_architectures;
  529     #     $foo{'value'} = \@lof;
  530     #   }
  531     # } else {
  532       if (exists($sets->{$k})) {
  533         $foo{'value'} = "$sets->{$k}";
  534       }
  535     # }
  536     push @json, \%foo;
  537   }
  538   return(TeXLive::TLUtils::encode_json(\@json));
  539 }
  540 
  541 sub configs_as_json {
  542   my $self = shift;
  543   die("calling _as_json on virtual is not supported!") if ($self->is_virtual);
  544   my %cfgs;
  545   $cfgs{'container_split_src_files'} = ($self->config_src_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
  546   $cfgs{'container_split_doc_files'} = ($self->config_doc_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
  547   $cfgs{'container_format'} = $self->config_container_format;
  548   $cfgs{'release'} = $self->config_release;
  549   $cfgs{'minrelease'} = $self->config_minrelease;
  550   return(TeXLive::TLUtils::encode_json(\%cfgs));
  551 }
  552 
  553 sub _as_json {
  554   my $self = shift;
  555   die("calling _as_json on virtual is not supported!") if ($self->is_virtual);
  556   my $ret = "{";
  557   $ret .= '"options":';
  558   $ret .= $self->options_as_json();
  559   $ret .= ',"settings":';
  560   $ret .= $self->settings_as_json();
  561   $ret .= ',"configs":';
  562   $ret .= $self->configs_as_json();
  563   $ret .= ',"tlpkgs": [';
  564   my $first = 1;
  565   foreach (keys %{$self->{'tlps'}}) {
  566     $ret .= ",\n" if (!$first);
  567     $first = 0;
  568     $ret .= $self->{'tlps'}{$_}->as_json;
  569   }
  570   $ret .= "]}";
  571   return($ret);
  572 }
  573 
  574 =pod
  575 
  576 =item C<< $tlpdb->save >>
  577 
  578 The C<save> functions saves the C<TLPDB> to the file which has been set
  579 as location. If the location is undefined, die.
  580 
  581 =cut
  582 
  583 sub save {
  584   my $self = shift;
  585   if ($self->is_virtual) {
  586     tlwarn("TLPDB: cannot save a virtual tlpdb\n");
  587     return 0;
  588   }
  589   my $path = $self->location;
  590   mkdirhier(dirname($path));
  591   my $tmppath = "$path.tmp";
  592   open(FOO, ">$tmppath") || die "$0: open(>$tmppath) failed: $!";
  593   $self->writeout(\*FOO);
  594   close(FOO);
  595   # on Windows the renaming sometimes fails, try to copy and unlink the
  596   # .tmp file. This we do for all archs, cannot hurt.
  597   # if we managed that one, we move it over
  598   TeXLive::TLUtils::copy ("-f", $tmppath, $path);
  599   unlink ($tmppath) or tlwarn ("TLPDB: cannot unlink $tmppath: $!\n");
  600 }
  601 
  602 =pod
  603 
  604 =item C<< $tlpdb->media >>
  605 
  606 Returns the media code the respective installation resides on.
  607 
  608 =cut
  609 
  610 sub media { 
  611   my $self = shift ; 
  612   if ($self->is_virtual) {
  613     return "virtual";
  614   }
  615   return $self->{'media'};
  616 }
  617 
  618 =pod
  619 
  620 =item C<< $tlpdb->available_architectures >>
  621 
  622 The C<available_architectures> functions returns the list of available 
  623 architectures as set in the options section 
  624 (i.e., using setting("available_architectures"))
  625 
  626 =cut
  627 
  628 sub available_architectures {
  629   my $self = shift;
  630   my @archs;
  631   if ($self->is_virtual) {
  632     for my $k (keys %{$self->{'tlpdbs'}}) {
  633       TeXLive::TLUtils::push_uniq \@archs, $self->{'tlpdbs'}{$k}->available_architectures;
  634     }
  635     return sort @archs;
  636   } else {
  637     return $self->_available_architectures;
  638   }
  639 }
  640 
  641 sub _available_architectures {
  642   my $self = shift;
  643   my @archs = $self->setting("available_architectures");
  644   if (! @archs) {
  645     # fall back to the old method checking tex\.*
  646     my @packs = $self->list_packages;
  647     map { s/^tex\.// ; push @archs, $_ ; } grep(/^tex\.(.*)$/, @packs);
  648   }
  649   return @archs;
  650 }
  651 
  652 =pod
  653 
  654 =item C<< $tlpdb->get_package("pkgname") >> 
  655 
  656 The C<get_package> function returns a reference to the C<TLPOBJ> object
  657 corresponding to the I<pkgname>, or undef.
  658 
  659 =cut
  660 
  661 sub get_package {
  662   my ($self,$pkg,$tag) = @_;
  663   if ($self->is_virtual) {
  664     if (defined($tag)) {
  665       if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) {
  666         return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'};
  667       } else {
  668         debug("TLPDB::get_package: package $pkg not found in repository $tag\n");
  669         return;
  670       }
  671     } else {
  672       $tag = $self->{'packages'}{$pkg}{'target'};
  673       if (defined($tag)) {
  674         return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'};
  675       } else {
  676         return;
  677       }
  678     }
  679   } else {
  680     return $self->_get_package($pkg);
  681   }
  682 }
  683 
  684 sub _get_package {
  685   my ($self,$pkg) = @_;
  686   return undef if (!$pkg);
  687   if (defined($self->{'tlps'}{$pkg})) {
  688   my $ret = $self->{'tlps'}{$pkg};
  689     return $self->{'tlps'}{$pkg};
  690   } else {
  691     return undef;
  692   }
  693 }
  694 
  695 =pod
  696 
  697 =item C<< $tlpdb->media_of_package($pkg [, $tag]) >>
  698 
  699 returns the media type of the package. In the virtual case a tag can
  700 be given and the media of that repository is used, otherwise the
  701 media of the virtual candidate is given.
  702 
  703 =cut
  704 
  705 sub media_of_package {
  706   my ($self, $pkg, $tag) = @_;
  707   if ($self->is_virtual) {
  708     if (defined($tag)) {
  709       if (defined($self->{'tlpdbs'}{$tag})) {
  710         return $self->{'tlpdbs'}{$tag}->media;
  711       } else {
  712         tlwarn("TLPDB::media_of_package: tag not known: $tag\n");
  713         return;
  714       }
  715     } else {
  716       my (undef,undef,undef,$maxtlpdb) = $self->virtual_candidate($pkg);
  717       return $maxtlpdb->media;
  718     }
  719   } else {
  720     return $self->media;
  721   }
  722 }
  723 
  724 =pod
  725 
  726 =item C<< $tlpdb->list_packages >>
  727 
  728 The C<list_packages> function returns the list of all included packages.
  729 
  730 By default, for virtual tlpdbs only packages that are installable
  731 are listed. That means, packages that are only in subsidiary repositories
  732 but are not specifically pinned to it cannot be installed and are thus
  733 not listed. Adding "-all" argument lists also these packages.
  734 
  735 Finally, if there is another argument, the tlpdb must be virtual,
  736 and the argument must specify a tag/name of a sub-tlpdb. In this
  737 case all packages (without exceptions) from this repository are returned.
  738 
  739 =cut
  740 
  741 sub list_packages {
  742   my $self = shift;
  743   my $arg = shift;
  744   my $tag;
  745   my $showall = 0;
  746   if (defined($arg)) {
  747     if ($arg eq "-all") {
  748       $showall = 1;
  749     } else {
  750       $tag = $arg;
  751     }
  752   }
  753   if ($self->is_virtual) {
  754     if ($showall) {
  755       return (sort keys %{$self->{'packages'}});
  756     }
  757     if ($tag) {
  758       if (defined($self->{'tlpdbs'}{$tag})) {
  759         return $self->{'tlpdbs'}{$tag}->list_packages;
  760       } else {
  761         tlwarn("TLPDB::list_packages: tag not defined: $tag\n");
  762         return 0;
  763       }
  764     }
  765     # we have to be careful here: If a package
  766     # is only present in a subsidiary repository
  767     # and the package is *not* explicitly
  768     # pinned to it, it will not be installable.
  769     # This is what we want. But in this case
  770     # we don't want it to be listed by default.
  771     #
  772     my @pps;
  773     for my $p (keys %{$self->{'packages'}}) {
  774       push @pps, $p if (defined($self->{'packages'}{$p}{'target'}));
  775     }
  776     return (sort @pps);
  777   } else {
  778     return $self->_list_packages;
  779   }
  780 }
  781 
  782 sub _list_packages {
  783   my $self = shift;
  784   return (sort keys %{$self->{'tlps'}});
  785 }
  786 
  787 =pod
  788 
  789 =item C<< $tlpdb->expand_dependencies(["control",] $tlpdb, ($pkgs)) >>
  790 
  791 If the first argument is the string C<"-only-arch">, expands only
  792 dependencies of the form C<.>I<ARCH>.
  793 
  794 If the first argument is C<"-no-collections">, then dependencies between
  795 "same-level" packages (scheme onto scheme, collection onto collection,
  796 package onto package) are ignored.
  797 
  798 C<-only-arch> and C<-no-collections> cannot be specified together; has
  799 to be one or the other.
  800 
  801 The next (or first) argument is the target TLPDB, then a list of
  802 packages.
  803 
  804 In the virtual case, if a package name is tagged with C<@repository-tag>
  805 then all the dependencies will still be expanded between all included
  806 databases.  Only in case of C<.>I<ARCH> dependencies the repository-tag
  807 is sticky.
  808 
  809 We return a list of package names, the closure of the package list with
  810 respect to the depends operator. (Sorry, that was for mathematicians.)
  811 
  812 =cut
  813 
  814 sub expand_dependencies {
  815   my $self = shift;
  816   my $only_arch = 0;
  817   my $no_collections = 0;
  818   my $first = shift;
  819   my $totlpdb;
  820   if ($first eq "-only-arch") {
  821     $only_arch = 1;
  822     $totlpdb = shift;
  823   } elsif ($first eq "-no-collections") {
  824     $no_collections = 1;
  825     $totlpdb = shift;
  826   } else {
  827     $totlpdb = $first;
  828   }
  829   my %install = ();
  830   my @archs = $totlpdb->available_architectures;
  831   for my $p (@_) {
  832     next if ($p =~ m/^\s*$/);
  833     my ($pp, $aa) = split('@', $p);
  834     $install{$pp} = (defined($aa) ? $aa : 0);;
  835   }
  836   my $changed = 1;
  837   while ($changed) {
  838     $changed = 0;
  839     my @pre_select = keys %install;
  840     ddebug("pre_select = @pre_select\n");
  841     for my $p (@pre_select) {
  842       next if ($p =~ m/^00texlive/);
  843       my $pkg = $self->get_package($p, ($install{$p}?$install{$p}:undef));
  844       if (!defined($pkg)) {
  845         ddebug("W: $p is mentioned somewhere but not available, disabling\n");
  846         $install{$p} = 0;
  847         next;
  848       }
  849       for my $p_dep ($pkg->depends) {
  850         ddebug("checking $p_dep in $p\n");
  851         my $tlpdd = $self->get_package($p_dep);
  852         if (defined($tlpdd)) {
  853           # before we ignored all deps of schemes and colls if -no-collections
  854           # was given, but this prohibited auto-install of new collections
  855           # even if the scheme is updated.
  856           # Now we suppress only "same-level dependencies", so scheme -> scheme
  857           # and collections -> collections and package -> package
  858           # hoping that this works out better
  859           # if ($tlpdd->category =~ m/$MetaCategoriesRegexp/) {
  860           if ($tlpdd->category eq $pkg->category) {
  861             # we ignore same-level dependencies if "-no-collections" is given
  862             ddebug("expand_deps: skipping $p_dep in $p due to -no-collections\n");
  863             next if $no_collections;
  864           }
  865         }
  866         if ($p_dep =~ m/^(.*)\.ARCH$/) {
  867           my $foo = "$1";
  868           foreach $a (@archs) {
  869             # install .ARCH packages from the same sub repository as the
  870             # main packages
  871             $install{"$foo.$a"} = $install{$foo}
  872               if defined($self->get_package("$foo.$a"));
  873           }
  874         } elsif ($p_dep =~ m/^(.*)\.win32$/) {
  875           # a win32 package should *only* be installed if we are installing
  876           # the win32 arch
  877           if (grep(/^win32$/,@archs)) {
  878             $install{$p_dep} = 0;
  879           }
  880         } else {
  881           $install{$p_dep} = 0 unless $only_arch;
  882         }
  883       }
  884     }
  885 
  886     # check for newly selected packages
  887     my @post_select = keys %install;
  888     ddebug("post_select = @post_select\n");
  889     if ($#pre_select != $#post_select) {
  890       $changed = 1;
  891     }
  892   }
  893   # create return list
  894   return map { $install{$_} eq "0"?$_:"$_\@" . $install{$_} } keys %install;
  895   #return(keys %install);
  896 }
  897 
  898 =pod
  899 
  900 =item C<< $tlpdb->find_file("filename") >>
  901 
  902 The C<find_file> returns a list of packages:filename
  903 containing a file named C<filename>.
  904 
  905 =cut
  906 
  907 # TODO adapt for searching in *all* tags ???
  908 sub find_file {
  909   my ($self,$fn) = @_;
  910   my @ret = ();
  911   for my $pkg ($self->list_packages) {
  912     for my $f ($self->get_package($pkg)->contains_file($fn)) {
  913       push (@ret, "$pkg:$f");
  914     }
  915   }
  916   return @ret;
  917 }
  918 
  919 =pod
  920 
  921 =item C<< $tlpdb->collections >>
  922 
  923 The C<collections> function returns a list of all collection names.
  924 
  925 =cut
  926 
  927 sub collections {
  928   my $self = shift;
  929   my @ret;
  930   foreach my $p ($self->list_packages) {
  931     if ($self->get_package($p)->category eq "Collection") {
  932       push @ret, $p;
  933     }
  934   }
  935   return @ret;
  936 }
  937 
  938 =pod
  939 
  940 =item C<< $tlpdb->schemes >>
  941 
  942 The C<schemes> function returns a list of all scheme names.
  943 
  944 =cut
  945 
  946 sub schemes {
  947   my $self = shift;
  948   my @ret;
  949   foreach my $p ($self->list_packages) {
  950     if ($self->get_package($p)->category eq "Scheme") {
  951       push @ret, $p;
  952     }
  953   }
  954   return @ret;
  955 }
  956 
  957 
  958 
  959 =pod
  960 
  961 =item C<< $tlpdb->package_revision("packagename") >>
  962 
  963 The C<package_revision> function returns the revision number of the
  964 package named in the first argument.
  965 
  966 =cut
  967 
  968 sub package_revision {
  969   my ($self,$pkg) = @_;
  970   my $tlp = $self->get_package($pkg);
  971   if (defined($tlp)) {
  972     return $tlp->revision;
  973   } else {
  974     return;
  975   }
  976 }
  977 
  978 =pod
  979 
  980 =item C<< $tlpdb->generate_packagelist >>
  981 
  982 The C<generate_packagelist> prints TeX Live package names in the object
  983 database, together with their revisions, to the file handle given in the
  984 first (optional) argument, or C<STDOUT> by default.  It also outputs all
  985 available architectures as packages with revision number -1.
  986 
  987 =cut
  988 
  989 sub generate_packagelist {
  990   my $self = shift;
  991   my $fd = (@_ ? $_[0] : STDOUT);
  992   foreach (sort $self->list_packages) {
  993     print $fd $self->get_package($_)->name, " ",
  994               $self->get_package($_)->revision, "\n";
  995   }
  996   foreach ($self->available_architectures) {
  997     print $fd "$_ -1\n";
  998   }
  999 }
 1000 
 1001 =pod
 1002 
 1003 =item C<< $tlpdb->generate_listfiles >>
 1004 
 1005 =item C<< $tlpdb->generate_listfiles($destdir) >>
 1006 
 1007 The C<generate_listfiles> generates the list files for the old 
 1008 installers. This function will probably go away.
 1009 
 1010 =cut
 1011 
 1012 sub generate_listfiles {
 1013   my ($self,$destdir) = @_;
 1014   if (not(defined($destdir))) {
 1015     $destdir = TeXLive::TLPDB->listdir;
 1016   }
 1017   foreach (sort $self->list_package) {
 1018     $tlp = $self->get_package($_);
 1019     $self->_generate_listfile($tlp, $destdir);
 1020   }
 1021 }
 1022 
 1023 sub _generate_listfile {
 1024   my ($self,$tlp,$destdir) = @_;
 1025   my $listname = $tlp->name;
 1026   my @files = $tlp->all_files;
 1027   @files = TeXLive::TLUtils::sort_uniq(@files);
 1028   &mkpath("$destdir") if (! -d "$destdir");
 1029   my (@lop, @lot);
 1030   foreach my $d ($tlp->depends) {
 1031     my $subtlp = $self->get_package($d);
 1032     if (defined($subtlp)) {
 1033       if ($subtlp->is_meta_package) {
 1034         push @lot, $d;
 1035       } else {
 1036         push @lop, $d;
 1037       }
 1038     } else {
 1039       # pseudo-dependencies on $Package.ARCH can be ignored
 1040       if ($d !~ m/\.ARCH$/) {
 1041         tlwarn("TLPDB: package $tlp->name depends on $d, but this does not exist\n");
 1042       }
 1043     }
 1044   }
 1045   open(TMP, ">$destdir/$listname")
 1046   || die "$0: open(>$destdir/$listname) failed: $!";
 1047 
 1048   # title and size information for collections and schemes in the
 1049   # first two lines, marked with *
 1050     if ($tlp->category eq "Collection") {
 1051     print TMP "*Title: ", $tlp->shortdesc, "\n";
 1052     # collections references Packages, we have to collect the sizes of
 1053     # all the Package-tlps included
 1054     # What is unclear for me is HOW the size is computed for bin-*
 1055     # packages. The collection-basic contains quite a lot of
 1056     # bin-files, but the sizes for the different archs differ.
 1057     # I guess we have to take the maximum?
 1058     my $s = 0;
 1059     foreach my $p (@lop) {
 1060       my $subtlp = $self->get_package($p);
 1061       if (!defined($subtlp)) {
 1062         tlwarn("TLPDB: $listname references $p, but this is not in tlpdb\n");
 1063       }
 1064       $s += $subtlp->total_size;
 1065     }
 1066     # in case the collection itself ships files ...
 1067     $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize;
 1068     print TMP "*Size: $s\n";
 1069   } elsif ($tlp->category eq "Scheme") {
 1070     print TMP "*Title: ", $tlp->shortdesc, "\n";
 1071     my $s = 0;
 1072     # schemes size includes ONLY those packages which are directly
 1073     # included and directly included files, not the size of the
 1074     # included collections. But if a package is included in one of
 1075     # the called for collections AND listed directly, we don't want
 1076     # to count its size two times
 1077     my (@inccol,@incpkg,@collpkg);
 1078     # first we add all the packages tlps that are directly included
 1079     @incpkg = @lop;
 1080     # now we select all collections, and for all collections we
 1081     # again select all non-meta-packages
 1082     foreach my $c (@lot) {
 1083       my $coll = $self->get_package($c);
 1084       foreach my $d ($coll->depends) {
 1085         my $subtlp = $self->get_package($d);
 1086         if (defined($subtlp)) {
 1087           if (!($subtlp->is_meta_package)) {
 1088             TeXLive::TLUtils::push_uniq(\@collpkg,$d);
 1089           }
 1090         } else {
 1091           tlwarn("TLPDB: collection $coll->name depends on $d, but this does not exist\n");
 1092         }
 1093       }
 1094     }
 1095     # finally go through all packages and add the ->total_size
 1096     foreach my $p (@incpkg) {
 1097       if (!TeXLive::TLUtils::member($p,@collpkg)) {
 1098         $s += $self->get_package($p)->total_size;
 1099       }
 1100     } 
 1101     $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize;
 1102     print TMP "*Size: $s\n";
 1103   }
 1104   # dependencies and inclusion of packages
 1105   foreach my $t (@lot) {
 1106     # strange, schemes mark included collections via -, while collections
 1107     # themselves mark deps on other collections with +. collections are
 1108     # never referenced in Packages.
 1109     if ($listname =~ m/^scheme/) {
 1110       print TMP "-";
 1111     } else {
 1112       print TMP "+";
 1113     }
 1114     print TMP "$t\n";
 1115   }
 1116   foreach my $t (@lop) { print TMP "+$t\n"; }
 1117   # included files
 1118   foreach my $f (@files) { print TMP "$f\n"; }
 1119   # also print the listfile itself
 1120   print TMP "$destdir/$listname\n";
 1121   # execute statements
 1122   foreach my $e ($tlp->executes) {
 1123     print TMP "!$e\n";
 1124   }
 1125   # finish
 1126   close(TMP);
 1127 }
 1128 
 1129 =pod
 1130 
 1131 =item C<< $tlpdb->root([ "/path/to/installation" ]) >>
 1132 
 1133 The function C<root> allows to read and set the root of the
 1134 installation. 
 1135 
 1136 =cut
 1137 
 1138 sub root {
 1139   my $self = shift;
 1140   if ($self->is_virtual) {
 1141     tlwarn("TLPDB: cannot set/edit root of a virtual tlpdb\n");
 1142     return 0;
 1143   }
 1144   if (@_) { $self->{'root'} = shift }
 1145   return $self->{'root'};
 1146 }
 1147 
 1148 =pod
 1149 
 1150 =item C<< $tlpdb->location >>
 1151 
 1152 Return the location of the actual C<texlive.tlpdb> file used. This is a
 1153 read-only function; you cannot change the root of the TLPDB using this
 1154 function.
 1155 
 1156 See C<00texlive.installation.tlpsrc> for a description of the
 1157 special value C<__MASTER>.
 1158 
 1159 =cut
 1160 
 1161 sub location {
 1162   my $self = shift;
 1163   if ($self->is_virtual) {
 1164     tlwarn("TLPDB: cannot get location of a virtual tlpdb\n");
 1165     return 0;
 1166   }
 1167   return "$self->{'root'}/$DatabaseLocation";
 1168 }
 1169 
 1170 =pod
 1171 
 1172 =item C<< $tlpdb->platform >>
 1173 
 1174 returns the platform of this installation.
 1175 
 1176 =cut
 1177 
 1178 # deduce the platform of the referenced media as follows:
 1179 # - if the $tlpdb->setting("platform") is there it overrides the detected
 1180 #   setting
 1181 # - if it is not there call TLUtils::platform()
 1182 sub platform {
 1183   # try to deduce the platform
 1184   my $self = shift;
 1185   my $ret = $self->setting("platform");
 1186   return $ret if defined $ret;
 1187   # the platform setting wasn't found in the tlpdb, try TLUtils::platform
 1188   return TeXLive::TLUtils::platform();
 1189 }
 1190 
 1191 =pod
 1192 
 1193 =item C<< $tlpdb->is_verified >>
 1194 
 1195 Returns 0/1 depending on whether the tlpdb was verified by checking
 1196 the cryptographic signature.
 1197 
 1198 =cut
 1199 
 1200 sub is_verified {
 1201   my $self = shift;
 1202   if ($self->is_virtual) {
 1203     tlwarn("TLPDB: cannot set/edit verified property of a virtual tlpdb\n");
 1204     return 0;
 1205   }
 1206   if (@_) { $self->{'verified'} = shift }
 1207   return $self->{'verified'};
 1208 }
 1209 =pod
 1210 
 1211 =item C<< $tlpdb->verification_status >>
 1212 
 1213 Returns the id of the verification status. To obtain a textual representation
 1214 us %TLCrypto::VerificationStatusDescription.
 1215 
 1216 =cut
 1217 
 1218 sub verification_status {
 1219   my $self = shift;
 1220   if ($self->is_virtual) {
 1221     tlwarn("TLPDB: cannot set/edit verification status of a virtual tlpdb\n");
 1222     return 0;
 1223   }
 1224   if (@_) { $self->{'verification_status'} = shift }
 1225   return $self->{'verification_status'};
 1226 }
 1227 
 1228 =pod
 1229 
 1230 =item C<< $tlpdb->listdir >>
 1231 
 1232 The function C<listdir> allows to read and set the packages variable
 1233 specifying where generated list files are created.
 1234 
 1235 =cut
 1236 
 1237 sub listdir {
 1238   my $self = shift;
 1239   if (@_) { $_listdir = $_[0] }
 1240   return $_listdir;
 1241 }
 1242 
 1243 =pod
 1244 
 1245 =item C<< $tlpdb->config_src_container >>
 1246 
 1247 Returns 1 if the texlive config option for src files splitting on 
 1248 container level is set. See Options below.
 1249 
 1250 =cut
 1251 
 1252 sub config_src_container {
 1253   my $self = shift;
 1254   my $tlp;
 1255   if ($self->is_virtual) {
 1256     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1257   } else {
 1258     $tlp = $self->{'tlps'}{'00texlive.config'};
 1259   }
 1260   if (defined($tlp)) {
 1261     foreach my $d ($tlp->depends) {
 1262       if ($d =~ m!^container_split_src_files/(.*)$!) {
 1263         return "$1";
 1264       }
 1265     }
 1266   }
 1267   return 0;
 1268 }
 1269 
 1270 =pod
 1271 
 1272 =item C<< $tlpdb->config_doc_container >>
 1273 
 1274 Returns 1 if the texlive config option for doc files splitting on 
 1275 container level is set. See Options below.
 1276 
 1277 =cut
 1278 
 1279 sub config_doc_container {
 1280   my $self = shift;
 1281   my $tlp;
 1282   if ($self->is_virtual) {
 1283     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1284   } else {
 1285     $tlp = $self->{'tlps'}{'00texlive.config'};
 1286   }
 1287   if (defined($tlp)) {
 1288     foreach my $d ($tlp->depends) {
 1289       if ($d =~ m!^container_split_doc_files/(.*)$!) {
 1290         return "$1";
 1291       }
 1292     }
 1293   }
 1294   return 0;
 1295 }
 1296 
 1297 =pod
 1298 
 1299 =item C<< $tlpdb->config_container_format >>
 1300 
 1301 Returns the currently set default container format. See Options below.
 1302 
 1303 =cut
 1304 
 1305 sub config_container_format {
 1306   my $self = shift;
 1307   my $tlp;
 1308   if ($self->is_virtual) {
 1309     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1310   } else {
 1311     $tlp = $self->{'tlps'}{'00texlive.config'};
 1312   }
 1313   if (defined($tlp)) {
 1314     foreach my $d ($tlp->depends) {
 1315       if ($d =~ m!^container_format/(.*)$!) {
 1316         return "$1";
 1317       }
 1318     }
 1319   }
 1320   return "";
 1321 }
 1322 
 1323 =pod
 1324 
 1325 =item C<< $tlpdb->config_release >>
 1326 
 1327 Returns the currently set release. See Options below.
 1328 
 1329 =cut
 1330 
 1331 sub config_release {
 1332   my $self = shift;
 1333   my $tlp;
 1334   if ($self->is_virtual) {
 1335     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1336   } else {
 1337     $tlp = $self->{'tlps'}{'00texlive.config'};
 1338   }
 1339   if (defined($tlp)) {
 1340     foreach my $d ($tlp->depends) {
 1341       if ($d =~ m!^release/(.*)$!) {
 1342         return "$1";
 1343       }
 1344     }
 1345   }
 1346   return "";
 1347 }
 1348 
 1349 =pod
 1350 
 1351 =item C<< $tlpdb->config_minrelease >>
 1352 
 1353 Returns the currently allowed minimal release. See Options below.
 1354 
 1355 =cut
 1356 
 1357 sub config_minrelease {
 1358   my $self = shift;
 1359   my $tlp;
 1360   if ($self->is_virtual) {
 1361     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1362   } else {
 1363     $tlp = $self->{'tlps'}{'00texlive.config'};
 1364   }
 1365   if (defined($tlp)) {
 1366     foreach my $d ($tlp->depends) {
 1367       if ($d =~ m!^minrelease/(.*)$!) {
 1368         return "$1";
 1369       }
 1370     }
 1371   }
 1372   return;
 1373 }
 1374 
 1375 =pod
 1376 
 1377 =item C<< $tlpdb->config_frozen >>
 1378 
 1379 Returns true if the location is frozen.
 1380 
 1381 =cut
 1382 
 1383 sub config_frozen {
 1384   my $self = shift;
 1385   my $tlp;
 1386   if ($self->is_virtual) {
 1387     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1388   } else {
 1389     $tlp = $self->{'tlps'}{'00texlive.config'};
 1390   }
 1391   if (defined($tlp)) {
 1392     foreach my $d ($tlp->depends) {
 1393       if ($d =~ m!^frozen/(.*)$!) {
 1394         return "$1";
 1395       }
 1396     }
 1397   }
 1398   return;
 1399 }
 1400 
 1401 
 1402 =pod
 1403 
 1404 =item C<< $tlpdb->config_revision >>
 1405 
 1406 Returns the currently set revision. See Options below.
 1407 
 1408 =cut
 1409 
 1410 sub config_revision {
 1411   my $self = shift;
 1412   my $tlp;
 1413   if ($self->is_virtual) {
 1414     $tlp = $self->{'tlpdbs'}{'main'}->get_package('00texlive.config');
 1415   } else {
 1416     $tlp = $self->{'tlps'}{'00texlive.config'};
 1417   }
 1418   if (defined($tlp)) {
 1419     foreach my $d ($tlp->depends) {
 1420       if ($d =~ m!^revision/(.*)$!) {
 1421         return "$1";
 1422       }
 1423     }
 1424   }
 1425   return "";
 1426 }
 1427 
 1428 =pod
 1429 
 1430 =item C<< $tlpdb->sizes_of_packages_with_deps ( $opt_src, $opt_doc, $ref_arch_list, [ @packs ] ) >>
 1431 
 1432 =item C<< $tlpdb->sizes_of_packages ( $opt_src, $opt_doc, $ref_arch_list, [ @packs ] ) >>
 1433 
 1434 These functions return a reference to a hash with package names as keys
 1435 and the sizes in bytes as values. The sizes are computed for the list of
 1436 package names given as the fourth argument, or all packages if not
 1437 specified. The difference between the two functions is that the C<_with_deps>
 1438 gives the size of packages including the size of all depending sizes.
 1439 
 1440 If anything has been computed one additional key is synthesized,
 1441 C<__TOTAL__>, which contains the total size of all packages under
 1442 consideration. In the case of C<_with_deps> this total computation
 1443 does B<not> count packages multiple times, even if they appear
 1444 multiple times as dependencies.
 1445 
 1446 If the third argument is a reference to a list of architectures, then
 1447 only the sizes for the binary packages for these architectures are used,
 1448 otherwise all sizes for all architectures are summed.
 1449 
 1450 =cut
 1451 
 1452 sub sizes_of_packages {
 1453   my ($self, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_;
 1454   return $self->_sizes_of_packages(0, $opt_src, $opt_doc, $arch_list_ref, @packs);
 1455 }
 1456 
 1457 sub sizes_of_packages_with_deps {
 1458   my ($self, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_;
 1459   return $self->_sizes_of_packages(1, $opt_src, $opt_doc, $arch_list_ref, @packs);
 1460 }
 1461 
 1462 
 1463 sub _sizes_of_packages {
 1464   my ($self, $with_deps, $opt_src, $opt_doc, $arch_list_ref, @packs) = @_;
 1465   @packs || ( @packs = $self->list_packages() );
 1466   my @expacks;
 1467   if ($with_deps) {
 1468     # don't expand collection->collection dependencies
 1469     #@exppacks = $self->expand_dependencies('-no-collections', $self, @packs);
 1470     @exppacks = $self->expand_dependencies($self, @packs);
 1471   } else {
 1472     @exppacks = @packs;
 1473   }
 1474   my @archs;
 1475   if ($arch_list_ref) {
 1476     @archs = @$arch_list_ref;
 1477   } else {
 1478     # if nothing is passed on, we use all available archs
 1479     @archs = $self->available_architectures;
 1480   }
 1481   my %tlpsizes;
 1482   my %tlpobjs;
 1483   my $totalsize = 0;
 1484   foreach my $p (@exppacks) {
 1485     $tlpobjs{$p} = $self->get_package($p);
 1486     my $media = $self->media_of_package($p);
 1487     if (!defined($tlpobjs{$p})) {
 1488       warn "STRANGE: $p not to be found in ", $self->root;
 1489       next;
 1490     }
 1491     #
 1492     # in case we are calling the _with_deps variant, we always
 1493     # compute *UNCOMPRESSED* sizes (not the container sizes!!!)
 1494     if ($with_deps) {
 1495       $tlpsizes{$p} = $self->size_of_one_package('local_uncompressed' , $tlpobjs{$p},
 1496                                                  $opt_src, $opt_doc, @archs);
 1497     } else {
 1498       $tlpsizes{$p} = $self->size_of_one_package($media, $tlpobjs{$p},
 1499                                                  $opt_src, $opt_doc, @archs);
 1500     }
 1501     $totalsize += $tlpsizes{$p};
 1502   }
 1503   my %realtlpsizes;
 1504   if ($totalsize) {
 1505     $realtlpsizes{'__TOTAL__'} = $totalsize;
 1506   }
 1507   if (!$with_deps) {
 1508     for my $p (@packs) {
 1509       $realtlpsizes{$p} = $tlpsizes{$p};
 1510     }
 1511   } else { # the case with dependencies
 1512     # make three rounds: for packages, collections, schemes
 1513     # size computations include only those from lower-levels
 1514     # that is, scheme-scheme, collection-collection
 1515     # does not contribute to the size
 1516     for my $p (@exppacks) {
 1517       next if ($p =~ m/scheme-/);
 1518       next if ($p =~ m/collection-/);
 1519       $realtlpsizes{$p} = $tlpsizes{$p};
 1520     }
 1521     for my $p (@exppacks) {
 1522       # only collections
 1523       next if ($p !~ m/collection-/);
 1524       $realtlpsizes{$p} = $tlpsizes{$p};
 1525       ddebug("=== $p adding deps\n");
 1526       for my $d ($tlpobjs{$p}->depends) {
 1527         next if ($d =~ m/^collection-/);
 1528         next if ($d =~ m/^scheme-/);
 1529         ddebug("=== going for $d\n");
 1530         if (defined($tlpsizes{$d})) {
 1531           $realtlpsizes{$p} += $tlpsizes{$d};
 1532           ddebug("=== found $tlpsizes{$d} for $d\n");
 1533         } else {
 1534           # silently ignore missing defined packages - they should have
 1535           # been computed by expand-dependencies
 1536           debug("TLPDB.pm: size with deps: sub package not found main=$d, dep=$p\n");
 1537         }
 1538       }
 1539     }
 1540     for my $p (@exppacks) {
 1541       # only schemes
 1542       next if ($p !~ m/scheme-/);
 1543       $realtlpsizes{$p} = $tlpsizes{$p};
 1544       ddebug("=== $p adding deps\n");
 1545       for my $d ($tlpobjs{$p}->depends) {
 1546         # should not be necessary, we don't have collection -> scheme deps
 1547         next if ($d =~ m/^scheme-/);
 1548         ddebug("=== going for $d\n");
 1549         if (defined($realtlpsizes{$d})) {
 1550           $realtlpsizes{$p} += $realtlpsizes{$d};
 1551           ddebug("=== found $realtlpsizes{$d} for $d\n");
 1552         } else {
 1553           # silently ignore missing defined packages - they should have
 1554           # been computed by expand-dependencies
 1555           debug("TLPDB.pm: size with deps: sub package not found main=$d, dep=$p\n");
 1556         }
 1557       }
 1558     }
 1559   }
 1560   return \%realtlpsizes;
 1561 }
 1562 
 1563 sub size_of_one_package {
 1564   my ($self, $media, $tlpobj, $opt_src, $opt_doc, @used_archs) = @_;
 1565   my $size = 0;
 1566   if ($media ne 'local_uncompressed') {
 1567     # we use the container size as the measuring unit since probably
 1568     # downloading will be the limiting factor
 1569     $size =  $tlpobj->containersize;
 1570     $size += $tlpobj->srccontainersize if $opt_src;
 1571     $size += $tlpobj->doccontainersize if $opt_doc;
 1572   } else {
 1573     # we have to add the respective sizes, that is checking for
 1574     # installation of src and doc file
 1575     $size  = $tlpobj->runsize;
 1576     $size += $tlpobj->srcsize if $opt_src;
 1577     $size += $tlpobj->docsize if $opt_doc;
 1578     my %foo = %{$tlpobj->binsize};
 1579     for my $k (keys %foo) { 
 1580       if (@used_archs && member($k, @used_archs)) {
 1581         $size += $foo{$k};
 1582       }
 1583     }
 1584     # packages sizes are stored in blocks; transform that to bytes.
 1585     $size *= $TeXLive::TLConfig::BlockSize;
 1586   }
 1587   return $size;
 1588 }
 1589 
 1590 =pod
 1591 
 1592 =item C<< $tlpdb->install_package_files($f [, $f]) >>
 1593 
 1594 Install a package from a package file, i.e. a .tar.xz.
 1595 Returns the number of packages actually installed successfully.
 1596 
 1597 =cut
 1598 
 1599 sub install_package_files {
 1600   my ($self, @files) = @_;
 1601 
 1602   my $ret = 0;
 1603 
 1604   my $opt_src = $self->option("install_srcfiles");
 1605   my $opt_doc = $self->option("install_docfiles");
 1606 
 1607   for my $f (@files) {
 1608 
 1609     # - create a tmp directory
 1610     my $tmpdir = TeXLive::TLUtils::tl_tmpdir();
 1611     # - unpack everything there
 1612     {
 1613       my ($ret, $msg) = TeXLive::TLUtils::unpack($f, $tmpdir);
 1614       if (!$ret) {
 1615         tlwarn("TLPDB::install_package_files: $msg\n");
 1616         next;
 1617       }
 1618     }
 1619     # we are  still here, so the files have been unpacked properly
 1620     # we need now to find the tlpobj in $tmpdir/tlpkg/tlpobj/
 1621     my ($tlpobjfile, $anotherfile) = <$tmpdir/tlpkg/tlpobj/*.tlpobj>;
 1622     if (defined($anotherfile)) {
 1623       # we found several tlpobj files, that is not allowed, stop
 1624       tlwarn("TLPDB::install_package_files: several tlpobj files in $what in tlpkg/tlpobj/, stopping!\n");
 1625       next;
 1626     }
 1627     # - read the tlpobj from there
 1628     my $tlpobj = TeXLive::TLPOBJ->new;
 1629     $tlpobj->from_file($tlpobjfile);
 1630     # we didn't die in this process, so that seems to be a proper tlpobj
 1631     # (btw, why didn't I work on proper return values!?!)
 1632 
 1633     #
 1634     # we are now ready for installation
 1635     # if this package existed before, remove it from the tlpdb
 1636     if ($self->get_package($tlpobj->name)) {
 1637       $self->remove_package($tlpobj->name);
 1638     }
 1639 
 1640     # code partially from TLPDB->not_virtual_install_package!!!
 1641     my @installfiles = ();
 1642     my $reloc = 1 if $tlpobj->relocated;
 1643     foreach ($tlpobj->runfiles) { push @installfiles, $_; };
 1644     foreach ($tlpobj->allbinfiles) { push @installfiles, $_; };
 1645     if ($opt_src) { foreach ($tlpobj->srcfiles) { push @installfiles, $_; } }
 1646     if ($opt_doc) { foreach ($tlpobj->docfiles) { push @installfiles, $_; } }
 1647     # 
 1648     # remove the RELOC prefix, but do NOT replace it with RelocTree
 1649     @installfiles = map { s!^$RelocPrefix/!!; $_; } @installfiles;
 1650     # if the first argument of _install_data is scalar, it is the
 1651     # place from where files should be installed
 1652     if (!_install_data ($tmpdir, \@installfiles, $reloc, \@installfiles, $self)) {
 1653       tlwarn("TLPDB::install_package_files: couldn't install $what!\n"); 
 1654       next;
 1655     }
 1656     if ($reloc) {
 1657       if ($self->setting("usertree")) {
 1658         $tlpobj->cancel_reloc_prefix;
 1659       } else {
 1660         $tlpobj->replace_reloc_prefix;
 1661       }
 1662       $tlpobj->relocated(0);
 1663     }
 1664     my $tlpod = $self->root . "/tlpkg/tlpobj";
 1665     mkdirhier( $tlpod );
 1666     open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") or
 1667       die("Cannot open tlpobj file for ".$tlpobj->name);
 1668     $tlpobj->writeout(\*TMP);
 1669     close(TMP);
 1670     $self->add_tlpobj($tlpobj);
 1671     $self->save;
 1672     TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj);
 1673     # do the postinstallation actions
 1674     #
 1675     # Run the post installation code in the postaction tlpsrc entries
 1676     # in case we are on w32 and the admin did install for himself only
 1677     # we switch off admin mode
 1678     if (win32() && admin() && !$self->option("w32_multi_user")) {
 1679       non_admin();
 1680     }
 1681     # for now desktop_integration maps to both installation
 1682     # of desktop shortcuts and menu items, but we can split them later
 1683     &TeXLive::TLUtils::do_postaction("install", $tlpobj,
 1684       $self->option("file_assocs"),
 1685       $self->option("desktop_integration"),
 1686       $self->option("desktop_integration"),
 1687       $self->option("post_code"));
 1688 
 1689     # remember that we installed this package correctly
 1690     $ret++;
 1691   }
 1692   return $ret;
 1693 }
 1694 
 1695 
 1696 =pod
 1697 
 1698 =item C<< $tlpdb->install_package($pkg, $dest_tlpdb [, $tag]) >>
 1699 
 1700 Installs the package $pkg into $dest_tlpdb.
 1701 If C<$tag> is present and the tlpdb is virtual, tries to install $pkg
 1702 from the repository tagged with $tag.
 1703 
 1704 =cut
 1705 
 1706 sub install_package {
 1707   my ($self, $pkg, $totlpdb, $tag) = @_;
 1708   if ($self->is_virtual) {
 1709     if (defined($tag)) {
 1710       if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) {
 1711         return $self->{'tlpdbs'}{$tag}->install_package($pkg, $totlpdb);
 1712       } else {
 1713         tlwarn("TLPDB::install_package: package $pkg not found"
 1714                . " in repository $tag\n");
 1715         return;
 1716       }
 1717     } else {
 1718       my ($maxtag, $maxrev, $maxtlp, $maxtlpdb)
 1719         = $self->virtual_candidate($pkg);
 1720       return $maxtlpdb->install_package($pkg, $totlpdb);
 1721     }
 1722   } else {
 1723     if (defined($tag)) {
 1724       tlwarn("TLPDB: not a virtual tlpdb, ignoring tag $tag"
 1725               . " on installation of $pkg\n");
 1726     }
 1727     return $self->not_virtual_install_package($pkg, $totlpdb);
 1728   }
 1729   return;
 1730 }
 1731 
 1732 sub not_virtual_install_package {
 1733   my ($self, $pkg, $totlpdb) = @_;
 1734   my $fromtlpdb = $self;
 1735   my $ret;
 1736   die("TLPDB not initialized, cannot find tlpdb!")
 1737     unless (defined($fromtlpdb));
 1738 
 1739   my $tlpobj = $fromtlpdb->get_package($pkg);
 1740   if (!defined($tlpobj)) {
 1741     tlwarn("TLPDB::not_virtual_install_package: cannot find package: $pkg\n");
 1742     return 0;
 1743   } else {
 1744     my $container_src_split = $fromtlpdb->config_src_container;
 1745     my $container_doc_split = $fromtlpdb->config_doc_container;
 1746     # get options about src/doc splitting from $totlpdb
 1747     my $opt_src = $totlpdb->option("install_srcfiles");
 1748     my $opt_doc = $totlpdb->option("install_docfiles");
 1749     my $real_opt_doc = $opt_doc;
 1750     my $reloc = 1 if $tlpobj->relocated;
 1751     my $container;
 1752     my @installfiles;
 1753     my $root = $self->root;
 1754     # make sure that there is no terminal / in $root, otherwise we
 1755     # will get double // somewhere
 1756     $root =~ s!/$!!;
 1757     foreach ($tlpobj->runfiles) {
 1758       # s!^!$root/!;
 1759       push @installfiles, $_;
 1760     }
 1761     foreach ($tlpobj->allbinfiles) {
 1762       # s!^!$root/!;
 1763       push @installfiles, $_;
 1764     }
 1765     if ($opt_src) {
 1766       foreach ($tlpobj->srcfiles) {
 1767         # s!^!$root/!;
 1768         push @installfiles, $_;
 1769       }
 1770     }
 1771     if ($real_opt_doc) {
 1772       foreach ($tlpobj->docfiles) {
 1773         # s!^!$root/!;
 1774         push @installfiles, $_;
 1775       }
 1776     }
 1777     my $media = $self->media;
 1778     my $container_is_versioned = 0;
 1779     if ($media eq 'local_uncompressed') {
 1780       $container = \@installfiles;
 1781     } elsif ($media eq 'local_compressed') {
 1782       for my $ext (map { $Compressors{$_}{'extension'} } keys %Compressors) {
 1783         # request versioned containers when local (i.e., ISO image),
 1784         # since the unversioned symlinks cannot be dereferenced
 1785         # on Windows.
 1786         my $rev = $tlpobj->revision;
 1787         if (-r "$root/$Archive/$pkg.r$rev.tar.$ext") {
 1788           $container_is_versioned = 1;
 1789           $container = "$root/$Archive/$pkg.r$rev.tar.$ext";
 1790         } elsif (-r "$root/$Archive/$pkg.tar.$ext") {
 1791           $container_is_versioned = 0;
 1792           $container = "$root/$Archive/$pkg.tar.$ext";
 1793         }
 1794       }
 1795       if (!$container) {
 1796         tlwarn("TLPDB: cannot find package $pkg.tar.$CompressorExtRegexp"
 1797                . " in $root/$Archive\n");
 1798         return(0);
 1799       }
 1800     } elsif (&media eq 'NET') {
 1801       # Since the NET server cannot be a Windows machine,
 1802       # ok to request the unversioned file.
 1803       $container = "$root/$Archive/$pkg.tar."
 1804                    . $Compressors{$DefaultCompressorFormat}{'extension'};
 1805       $container_is_versioned = 0;
 1806     }
 1807     my $container_str = ref $container eq "ARRAY"
 1808                         ? "[" . join (" ", @$container) . "]" : $container;
 1809     ddebug("TLPDB::not_virtual_install_package: installing container: ",
 1810           $container_str, "\n");
 1811     $self->_install_data($container, $reloc, \@installfiles, $totlpdb,
 1812                          $tlpobj->containersize, $tlpobj->containerchecksum)
 1813       || return(0);
 1814     # if we are installing from local_compressed or NET we have to fetch
 1815     # respective source and doc packages $pkg.source and $pkg.doc and
 1816     # install them, too
 1817     if (($media eq 'NET') || ($media eq 'local_compressed')) {
 1818       # we install split containers under the following conditions:
 1819       # - the container were split generated
 1820       # - src/doc files should be installed
 1821       # (- the package is not already a split one (like .i386-linux))
 1822       # the above test has been removed because it would mean that
 1823       #   texlive.infra.doc.tar.xz
 1824       # will never be installed, and we do already check that there
 1825       # are at all src/doc files, which in split packages of the form 
 1826       # foo.ARCH are not present. And if they are present, than that is fine,
 1827       # too (bin-foobar.win32.doc.tar.xz)
 1828       # - there are actually src/doc files present
 1829       if ($container_src_split && $opt_src && $tlpobj->srcfiles) {
 1830         my $srccontainer = $container;
 1831         if ($container_is_versioned) {
 1832           $srccontainer =~ s/\.(r[0-9]*)\.tar\.$CompressorExtRegexp$/.source.$1.tar.$2/;
 1833         } else {
 1834           $srccontainer =~ s/\.tar\.$CompressorExtRegexp$/.source.tar.$1/;
 1835         }
 1836         $self->_install_data($srccontainer, $reloc, \@installfiles, $totlpdb,
 1837                       $tlpobj->srccontainersize, $tlpobj->srccontainerchecksum)
 1838           || return(0);
 1839       }
 1840       if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) {
 1841         my $doccontainer = $container;
 1842         if ($container_is_versioned) {
 1843           $doccontainer =~ s/\.(r[0-9]*)\.tar\.$CompressorExtRegexp$/.doc.$1.tar.$2/;
 1844         } else {
 1845           $doccontainer =~ s/\.tar\.$CompressorExtRegexp$/.doc.tar.$1/;
 1846         }
 1847         $self->_install_data($doccontainer, $reloc, \@installfiles,
 1848             $totlpdb, $tlpobj->doccontainersize, $tlpobj->doccontainerchecksum)
 1849           || return(0);
 1850       }
 1851       #
 1852       # if we installed from NET/local_compressed and we got a relocatable container
 1853       # make sure that the stray texmf-dist/tlpkg directory is removed
 1854       # in USER MODE that should NOT be done because we keep the information
 1855       # there, but for now do it unconditionally
 1856       if ($tlpobj->relocated) {
 1857         my $reloctree = $totlpdb->root . "/" . $RelocTree;
 1858         my $tlpkgdir = $reloctree . "/" . $InfraLocation;
 1859         my $tlpod = $tlpkgdir .  "/tlpobj";
 1860         TeXLive::TLUtils::rmtree($tlpod) if (-d $tlpod);
 1861         # we try to remove the tlpkg directory, that will succeed only
 1862         # if it is empty. So in normal installations it won't be, but
 1863         # if we are installing a relocated package it is texmf-dist/tlpkg
 1864         # which will be (hopefully) empty
 1865         rmdir($tlpkgdir) if (-d "$tlpkgdir");
 1866       }
 1867     }
 1868     # we don't want to have wrong information in the tlpdb, so remove the
 1869     # src/doc files if they are not installed ...
 1870     if (!$opt_src) {
 1871       $tlpobj->clear_srcfiles;
 1872     }
 1873     if (!$real_opt_doc) {
 1874       $tlpobj->clear_docfiles;
 1875     }
 1876     # if a package is relocatable we have to cancel the reloc prefix
 1877     # and unset the relocated setting
 1878     # before we save it to the local tlpdb
 1879     if ($tlpobj->relocated) {
 1880       if ($totlpdb->setting("usertree")) {
 1881         $tlpobj->cancel_reloc_prefix;
 1882       } else {
 1883         $tlpobj->replace_reloc_prefix;
 1884       }
 1885       $tlpobj->relocated(0);
 1886     }
 1887     # we have to write out the tlpobj file since it is contained in the
 1888     # archives (.tar.xz) but at DVD install time we don't have them
 1889     my $tlpod = $totlpdb->root . "/tlpkg/tlpobj";
 1890     mkdirhier($tlpod);
 1891     my $count = 0;
 1892     my $tlpobj_file = ">$tlpod/" . $tlpobj->name . ".tlpobj";
 1893     until (open(TMP, $tlpobj_file)) {
 1894       # The open might fail for no good reason on Windows.
 1895       # Try again for a while, but not forever.
 1896       if ($count++ == 100) { die "$0: open($tlpobj_file) failed: $!"; }
 1897       select (undef, undef, undef, .1);  # sleep briefly
 1898     }
 1899     $tlpobj->writeout(\*TMP);
 1900     close(TMP);
 1901     $totlpdb->add_tlpobj($tlpobj);
 1902     $totlpdb->save;
 1903     # compute the return value
 1904     TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj);
 1905     # do the postinstallation actions
 1906     #
 1907     # Run the post installation code in the postaction tlpsrc entries
 1908     # in case we are on w32 and the admin did install for himself only
 1909     # we switch off admin mode
 1910     if (win32() && admin() && !$totlpdb->option("w32_multi_user")) {
 1911       non_admin();
 1912     }
 1913     # for now desktop_integration maps to both installation
 1914     # of desktop shortcuts and menu items, but we can split them later
 1915     &TeXLive::TLUtils::do_postaction("install", $tlpobj,
 1916       $totlpdb->option("file_assocs"),
 1917       $totlpdb->option("desktop_integration"),
 1918       $totlpdb->option("desktop_integration"),
 1919       $totlpdb->option("post_code"));
 1920   }
 1921   return 1;
 1922 }
 1923 
 1924 #
 1925 # _install_data
 1926 # actually does the installation work
 1927 # returns 1 on success and 0 on error
 1928 #
 1929 # if the first argument is a string, then files are taken from this directory
 1930 # otherwise it is a tlpdb from where to install
 1931 #
 1932 sub _install_data {
 1933   my ($self, $what, $reloc, $filelistref, $totlpdb, $whatsize, $whatcheck) = @_;
 1934 
 1935   my $target = $totlpdb->root;
 1936   my $tempdir = TeXLive::TLUtils::tl_tmpdir();
 1937 
 1938   my @filelist = @$filelistref;
 1939 
 1940   if (ref $what) {
 1941     # determine the root from where we install
 1942     # if the first argument $self is a string, then it should be the
 1943     # root from where to install the files, otherwise it should be 
 1944     # a TLPDB object (installation from DVD)
 1945     my $root;
 1946     if (!ref($self)) {
 1947       $root = $self;
 1948     } else {
 1949       $root = $self->root;
 1950     }
 1951     # if we are installing a reloc, add the RelocTree to the target
 1952     if ($reloc) {
 1953       if (!$totlpdb->setting("usertree")) {
 1954         $target .= "/$RelocTree";
 1955       }
 1956     }
 1957 
 1958     foreach my $file (@$what) {
 1959       # @what is taken, not @filelist!
 1960       # is this still needed?
 1961       my $dn=dirname($file);
 1962       mkdirhier("$target/$dn");
 1963       TeXLive::TLUtils::copy "$root/$file", "$target/$dn";
 1964     }
 1965     # we always assume that copy will work
 1966     return(1);
 1967   } elsif ($what =~ m,\.tar\.$CompressorExtRegexp$,) {
 1968     if ($reloc) {
 1969       if (!$totlpdb->setting("usertree")) {
 1970         $target .= "/$RelocTree";
 1971       }
 1972     }
 1973     my $ww = ($whatsize || "<unset>");
 1974     my $ss = ($whatcheck || "<unset>");
 1975     debug("TLPDB::_install_data: what=$what, target=$target, size=$ww, checksum=$ss, tmpdir=$tempdir\n");
 1976     my ($ret, $pkg) = TeXLive::TLUtils::unpack($what, $target, 'size' => $whatsize, 'checksum' => $whatcheck, 'tmpdir' => $tempdir);
 1977     if (!$ret) {
 1978       tlwarn("TLPDB::_install_data: $pkg for $what\n"); # $pkg is error msg
 1979       return(0);
 1980     }
 1981     # remove the $pkg.tlpobj, we recreate it anyway again
 1982     unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj") 
 1983       if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj");
 1984     return(1);
 1985   } else {
 1986     tlwarn("TLPDB::_install_data: don't know how to install $what\n");
 1987     return(0);
 1988   }
 1989 }
 1990 
 1991 =pod
 1992 
 1993 =item << $tlpdb->remove_package($pkg, %options) >>
 1994 
 1995 Removes a single package with all the files and the entry in the db;
 1996 warns if the package does not exist.
 1997 
 1998 =cut
 1999 
 2000 # remove_package removes a single package with all files (including the
 2001 # tlpobj files) and the entry from the tlpdb.
 2002 sub remove_package {
 2003   my ($self, $pkg, %opts) = @_;
 2004   my $localtlpdb = $self;
 2005   my $tlp = $localtlpdb->get_package($pkg);
 2006   my $usertree = $localtlpdb->setting("usertree");
 2007   if (!defined($tlp)) {
 2008     tlwarn ("TLPDB: package not present, so nothing to remove: $pkg\n");
 2009   } else {
 2010     my $currentarch = $self->platform();
 2011     if ($pkg eq "texlive.infra" || $pkg eq "texlive.infra.$currentarch") {
 2012       log ("Not removing $pkg, it is essential!\n");
 2013       return 0;
 2014     }
 2015     # we have to chdir to $localtlpdb->root
 2016     my $Master = $localtlpdb->root;
 2017     chdir ($Master) || die "chdir($Master) failed: $!";
 2018     my @files = $tlp->all_files;
 2019     # also remove the .tlpobj file
 2020     push @files, "tlpkg/tlpobj/$pkg.tlpobj";
 2021     # and the ones from src/doc splitting
 2022     if (-r "tlpkg/tlpobj/$pkg.source.tlpobj") {
 2023       push @files, "tlpkg/tlpobj/$pkg.source.tlpobj";
 2024     }
 2025     if (-r "tlpkg/tlpobj/$pkg.doc.tlpobj") {
 2026       push @files, "tlpkg/tlpobj/$pkg.doc.tlpobj";
 2027     }
 2028     #
 2029     # some packages might be relocated, thus having the RELOC prefix
 2030     # in user mode we just remove the prefix, in normal mode we
 2031     # replace it with texmf-dist
 2032     # since we don't have user mode 
 2033     if ($tlp->relocated) {
 2034       for (@files) {
 2035         if (!$usertree) {
 2036           s:^$RelocPrefix/:$RelocTree/:;
 2037         }
 2038       }
 2039     }
 2040     #
 2041     # we want to check that a file is only listed in one package, so
 2042     # in case that a file to be removed is listed in another package
 2043     # we will warn and *not* remove it
 2044     my %allfiles;
 2045     for my $p ($localtlpdb->list_packages) {
 2046       next if ($p eq $pkg); # we have to skip the to be removed package
 2047       for my $f ($localtlpdb->get_package($p)->all_files) {
 2048         $allfiles{$f} = $p;
 2049       }
 2050     }
 2051     my @goodfiles = ();
 2052     my @badfiles = ();
 2053     my @debugfiles = ();
 2054     for my $f (@files) {
 2055       # in usermode we have to add texmf-dist again for comparison
 2056       if (defined($allfiles{$f})) {
 2057         # this file should be removed but is mentioned somewhere, too
 2058         # take into account if we got a warn list
 2059         if (defined($opts{'remove-warn-files'})) {
 2060           my %a = %{$opts{'remove-warn-files'}};
 2061           if (defined($a{$f})) {
 2062             push @badfiles, $f;
 2063           } else {
 2064             # NO NOTHING HERE!!!
 2065             # DON'T PUSH IT ON @goodfiles, it will be removed, which we do
 2066             # NOT want. We only want to suppress the warning!
 2067             push @debugfiles, $f;
 2068           }
 2069         } else {
 2070           push @badfiles, $f;
 2071         }
 2072       } else {
 2073         push @goodfiles, $f;
 2074       }
 2075     }
 2076     if ($#debugfiles >= 0) {
 2077       debug("The following files will not be removed due to the removal of $pkg.\n");
 2078       debug("But we do not warn on it because they are moved to other packages.\n");
 2079       for my $f (@debugfiles) {
 2080         debug(" $f - $allfiles{$f}\n");
 2081       }
 2082     }
 2083     if ($#badfiles >= 0) {
 2084       # warn the user
 2085       tlwarn("TLPDB: These files would have been removed due to removal of\n");
 2086       tlwarn("TLPDB: $pkg, but are part of another package:\n");
 2087       for my $f (@badfiles) {
 2088         tlwarn(" $f - $allfiles{$f}\n");
 2089       }
 2090     }
 2091     #
 2092     # Run only the postaction code thing now since afterwards the
 2093     # files will be gone ...
 2094     if (defined($opts{'nopostinstall'}) && $opts{'nopostinstall'}) {
 2095       &TeXLive::TLUtils::do_postaction("remove", $tlp,
 2096         0, # tlpdbopt_file_assocs,
 2097         0, # tlpdbopt_desktop_integration, menu part
 2098         0, # tlpdbopt_desktop_integration, desktop part
 2099         $localtlpdb->option("post_code"));
 2100     }
 2101     # 
 2102     my @removals = &TeXLive::TLUtils::removed_dirs (@goodfiles);
 2103     # now do the removal
 2104     for my $entry (@goodfiles) {
 2105       unlink $entry;
 2106     }
 2107     for my $d (@removals) {
 2108       rmdir $d;
 2109     }
 2110     $localtlpdb->remove_tlpobj($pkg);
 2111     TeXLive::TLUtils::announce_execute_actions("disable", $tlp);
 2112     # should we save at each removal???
 2113     # advantage: the tlpdb actually reflects what is installed
 2114     # disadvantage: removing a collection calls the save routine several times
 2115     # still I consider it better that the tlpdb is in a consistent state
 2116     $localtlpdb->save;
 2117     #
 2118     # Run the post installation code in the postaction tlpsrc entries
 2119     # in case we are on w32 and the admin did install for himself only
 2120     # we switch off admin mode
 2121     if (win32() && admin() && !$localtlpdb->option("w32_multi_user")) {
 2122       non_admin();
 2123     }
 2124     #
 2125     # Run the post installation code in the postaction tlpsrc entries
 2126     # the postaction code part cannot be evaluated now since the
 2127     # files are already removed.
 2128     # Again, desktop integration maps to desktop and menu links
 2129     if (!$opts{'nopostinstall'}) {
 2130       &TeXLive::TLUtils::do_postaction("remove", $tlp,
 2131         $localtlpdb->option("file_assocs"),
 2132         $localtlpdb->option("desktop_integration"),
 2133         $localtlpdb->option("desktop_integration"),
 2134         0);
 2135     }
 2136   }
 2137   return 1;
 2138 }
 2139 
 2140 
 2141 =pod
 2142 
 2143 =item C<< $tlpdb->option($key [, $val]) >>
 2144 =item C<< $tlpdb->setting($key [, $val]) >>
 2145 
 2146 Need to be documented
 2147 
 2148 =cut
 2149 
 2150 sub _set_option_value {
 2151   my $self = shift;
 2152   $self->_set_value_pkg('00texlive.installation', 'opt_', @_);
 2153 }
 2154 sub _set_setting_value {
 2155   my $self = shift;
 2156   $self->_set_value_pkg('00texlive.installation', 'setting_', @_);
 2157 }
 2158 sub _set_value_pkg {
 2159   my ($self,$pkgname,$pre,$key,$value) = @_;
 2160   my $k = "$pre$key";
 2161   my $pkg;
 2162   if ($self->is_virtual) {
 2163     $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname);
 2164   } else {
 2165     $pkg = $self->{'tlps'}{$pkgname};
 2166   }
 2167   my @newdeps;
 2168   if (!defined($pkg)) {
 2169     $pkg = new TeXLive::TLPOBJ;
 2170     $pkg->name($pkgname);
 2171     $pkg->category("TLCore");
 2172     push @newdeps, "$k:$value";
 2173   } else {
 2174     my $found = 0;
 2175     foreach my $d ($pkg->depends) {
 2176       if ($d =~ m!^$k:!) {
 2177         $found = 1;
 2178         push @newdeps, "$k:$value";
 2179       } else {
 2180         push @newdeps, $d;
 2181       }
 2182     }
 2183     if (!$found) {
 2184       push @newdeps, "$k:$value";
 2185     }
 2186   }
 2187   $pkg->depends(@newdeps);
 2188   $self->add_tlpobj($pkg);
 2189 }
 2190 
 2191 sub _clear_option {
 2192   my $self = shift;
 2193   $self->_clear_pkg('00texlive.installation', 'opt_', @_);
 2194 }
 2195 
 2196 sub _clear_setting {
 2197   my $self = shift;
 2198   $self->_clear_pkg('00texlive.installation', 'setting_', @_);
 2199 }
 2200 
 2201 sub _clear_pkg {
 2202   my ($self,$pkgname,$pre,$key) = @_;
 2203   my $k = "$pre$key";
 2204   my $pkg;
 2205   if ($self->is_virtual) {
 2206     $pkg = $self->{'tlpdbs'}{'main'}->get_package($pkgname);
 2207   } else {
 2208     $pkg = $self->{'tlps'}{$pkgname};
 2209   }
 2210   my @newdeps;
 2211   if (!defined($pkg)) {
 2212     return;
 2213   } else {
 2214     foreach my $d ($pkg->depends) {
 2215       if ($d =~ m!^$k:!) {
 2216         # do nothing, we drop the value
 2217       } else {
 2218         push @newdeps, $d;
 2219       }
 2220     }
 2221   }
 2222   $pkg->depends(@newdeps);
 2223   $self->add_tlpobj($pkg);
 2224 }
 2225 
 2226 
 2227 sub _get_option_value {
 2228   my $self = shift;
 2229   $self->_get_value_pkg('00texlive.installation', 'opt_', @_);
 2230 }
 2231 
 2232 sub _get_setting_value {
 2233   my $self = shift;
 2234   $self->_get_value_pkg('00texlive.installation', 'setting_', @_);
 2235 }
 2236 
 2237 sub _get_value_pkg {
 2238   my ($self,$pkg,$pre,$key) = @_;
 2239   my $k = "$pre$key";
 2240   my $tlp;
 2241   if ($self->is_virtual) {
 2242     $tlp = $self->{'tlpdbs'}{'main'}->get_package($pkg);
 2243   } else {
 2244     $tlp = $self->{'tlps'}{$pkg};
 2245   }
 2246   if (defined($tlp)) {
 2247     foreach my $d ($tlp->depends) {
 2248       if ($d =~ m!^$k:(.*)$!) {
 2249         return "$1";
 2250       }
 2251     }
 2252     return;
 2253   }
 2254   tlwarn("TLPDB: $pkg not found, cannot read option $key.\n");
 2255   return;
 2256 }
 2257 
 2258 sub option_pkg {
 2259   my $self = shift;
 2260   my $pkg = shift;
 2261   my $key = shift;
 2262   if (@_) { $self->_set_value_pkg($pkg, "opt_", $key, shift); }
 2263   my $ret = $self->_get_value_pkg($pkg, "opt_", $key);
 2264   # special case for location == __MASTER__
 2265   if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") {
 2266     return $self->root;
 2267   }
 2268   return $ret;
 2269 }
 2270 sub option {
 2271   my $self = shift;
 2272   my $key = shift;
 2273   if (@_) { $self->_set_option_value($key, shift); }
 2274   my $ret = $self->_get_option_value($key);
 2275   # special case for location == __MASTER__
 2276   if (defined($ret) && $ret eq "__MASTER__" && $key eq "location") {
 2277     return $self->root;
 2278   }
 2279   return $ret;
 2280 }
 2281 sub setting_pkg {
 2282   my $self = shift;
 2283   my $pkg = shift;
 2284   my $key = shift;
 2285   if (@_) { 
 2286     if ($TLPDBSettings{$key}->[0] eq "l") {
 2287       $self->_set_value_pkg($pkg, "setting_", $key, "@_"); 
 2288     } else {
 2289       $self->_set_value_pkg($pkg, "setting_", $key, shift); 
 2290     }
 2291   }
 2292   my $ret = $self->_get_value_pkg($pkg, "setting_", $key);
 2293   # check the types of the settings, and if it is a "l" return a list
 2294   if ($TLPDBSettings{$key}->[0] eq "l") {
 2295     my @ret;
 2296     if (defined $ret) {
 2297       @ret = split(" ", $ret);
 2298     } else {
 2299       tlwarn "TLPDB::setting_pkg: no $key, returning empty list\n";
 2300       @ret = ();
 2301     }
 2302     return @ret;
 2303   }
 2304   return $ret;
 2305 }
 2306 sub setting {
 2307   my $self = shift;
 2308   my $key = shift;
 2309   if ($key eq "-clear") {
 2310     my $realkey = shift;
 2311     $self->_clear_setting($realkey);
 2312     return;
 2313   }
 2314   if (@_) { 
 2315     if ($TLPDBSettings{$key}->[0] eq "l") {
 2316       $self->_set_setting_value($key, "@_"); 
 2317     } else {
 2318       $self->_set_setting_value($key, shift); 
 2319     }
 2320   }
 2321   my $ret = $self->_get_setting_value($key);
 2322   # check the types of the settings, and if it is a "l" return a list
 2323   if ($TLPDBSettings{$key}->[0] eq "l") {
 2324     my @ret;
 2325     if (defined $ret) {
 2326       @ret = split(" ", $ret);
 2327     } else {
 2328       tlwarn("TLPDB::setting: no $key, returning empty list\n");
 2329       @ret = ();
 2330     }
 2331     return @ret;
 2332   }
 2333   return $ret;
 2334 }
 2335 
 2336 sub reset_options {
 2337   my $self = shift;
 2338   for my $k (keys %TLPDBOptions) {
 2339     $self->option($k, $TLPDBOptions{$k}->[1]);
 2340   }
 2341 }
 2342 
 2343 sub add_default_options {
 2344   my $self = shift;
 2345   for my $k (sort keys %TLPDBOptions) {
 2346     # if the option is not set already, do set it to defaults
 2347     if (! $self->option($k) ) {
 2348       $self->option($k, $TLPDBOptions{$k}->[1]);
 2349     }
 2350   }
 2351 }
 2352 
 2353 =pod
 2354 
 2355 =item C<< $tlpdb->options >>
 2356 
 2357 Returns a reference to a hash with option names.
 2358 
 2359 =cut
 2360 
 2361 sub _keyshash {
 2362   my ($self, $pre, $hr) = @_;
 2363   my @allowed = keys %$hr;
 2364   my %ret;
 2365   my $pkg;
 2366   if ($self->is_virtual) {
 2367     $pkg = $self->{'tlpdbs'}{'main'}->get_package('00texlive.installation');
 2368   } else {
 2369     $pkg = $self->{'tlps'}{'00texlive.installation'};
 2370   }
 2371   if (defined($pkg)) {
 2372     foreach my $d ($pkg->depends) {
 2373       if ($d =~ m!^$pre([^:]*):(.*)!) {
 2374         if (member($1, @allowed)) {
 2375           $ret{$1} = $2;
 2376         } else {
 2377           tlwarn("TLPDB::_keyshash: Unsupported option/setting $d\n");
 2378         }
 2379       }
 2380     }
 2381   }
 2382   return \%ret;
 2383 }
 2384 
 2385 sub options {
 2386   my $self = shift;
 2387   return ($self->_keyshash('opt_', \%TLPDBOptions));
 2388 }
 2389 sub settings {
 2390   my $self = shift;
 2391   return ($self->_keyshash('setting_', \%TLPDBSettings));
 2392 }
 2393 
 2394 =pod
 2395 
 2396 =item C<< $tlpdb->format_definitions >>
 2397 
 2398 This function returns a list of references to hashes where each hash
 2399 represents a parsed AddFormat line.
 2400 
 2401 =cut
 2402 
 2403 sub format_definitions {
 2404   my $self = shift;
 2405   my @ret;
 2406   foreach my $p ($self->list_packages) {
 2407     my $obj = $self->get_package ($p);
 2408     die "$0: No TeX Live package named $p, strange" if ! $obj;
 2409     push @ret, $obj->format_definitions;
 2410   }
 2411   return(@ret);
 2412 }
 2413 
 2414 =item C<< $tlpdb->fmtutil_cnf_lines >>
 2415 
 2416 The function C<fmtutil_cnf_lines> returns the list of a fmtutil.cnf file
 2417 containing only those formats present in the installation.
 2418 
 2419 Every format listed in the tlpdb but listed in the arguments
 2420 will not be included in the list of lines returned.
 2421 
 2422 =cut
 2423 sub fmtutil_cnf_lines {
 2424   my $self = shift;
 2425   my @lines;
 2426   foreach my $p ($self->list_packages) {
 2427     my $obj = $self->get_package ($p);
 2428     die "$0: No TeX Live package named $p, strange" if ! $obj;
 2429     push @lines, $obj->fmtutil_cnf_lines(@_);
 2430   }
 2431   return(@lines);
 2432 }
 2433 
 2434 =item C<< $tlpdb->updmap_cfg_lines ( [@disabled_maps] ) >>
 2435 
 2436 The function C<updmap_cfg_lines> returns the list of a updmap.cfg file
 2437 containing only those maps present in the installation.
 2438 
 2439 A map file mentioned in the tlpdb but listed in the arguments will not 
 2440 be included in the list of lines returned.
 2441 
 2442 =cut
 2443 sub updmap_cfg_lines {
 2444   my $self = shift;
 2445   my @lines;
 2446   foreach my $p ($self->list_packages) {
 2447     my $obj = $self->get_package ($p);
 2448     die "$0: No TeX Live package named $p, strange" if ! $obj;
 2449     push @lines, $obj->updmap_cfg_lines(@_);
 2450   }
 2451   return(@lines);
 2452 }
 2453 
 2454 =item C<< $tlpdb->language_dat_lines ( [@disabled_hyphen_names] ) >>
 2455 
 2456 The function C<language_dat_lines> returns the list of all
 2457 lines for language.dat that can be generated from the tlpdb.
 2458 
 2459 Every hyphenation pattern listed in the tlpdb but listed in the arguments
 2460 will not be included in the list of lines returned.
 2461 
 2462 =cut
 2463 
 2464 sub language_dat_lines {
 2465   my $self = shift;
 2466   my @lines;
 2467   foreach my $p ($self->list_packages) {
 2468     my $obj = $self->get_package ($p);
 2469     die "$0: No TeX Live package named $p, strange" if ! $obj;
 2470     push @lines, $obj->language_dat_lines(@_);
 2471   }
 2472   return(@lines);
 2473 }
 2474 
 2475 =item C<< $tlpdb->language_def_lines ( [@disabled_hyphen_names] ) >>
 2476 
 2477 The function C<language_def_lines> returns the list of all
 2478 lines for language.def that can be generated from the tlpdb.
 2479 
 2480 Every hyphenation pattern listed in the tlpdb but listed in the arguments
 2481 will not be included in the list of lines returned.
 2482 
 2483 =cut
 2484 
 2485 sub language_def_lines {
 2486   my $self = shift;
 2487   my @lines;
 2488   foreach my $p ($self->list_packages) {
 2489     my $obj = $self->get_package ($p);
 2490     die "$0: No TeX Live package named $p, strange" if ! $obj;
 2491     push @lines, $obj->language_def_lines(@_);
 2492   }
 2493   return(@lines);
 2494 }
 2495 
 2496 =item C<< $tlpdb->language_lua_lines ( [@disabled_hyphen_names] ) >>
 2497 
 2498 The function C<language_lua_lines> returns the list of all
 2499 lines for language.dat.lua that can be generated from the tlpdb.
 2500 
 2501 Every hyphenation pattern listed in the tlpdb but listed in the arguments
 2502 will not be included in the list of lines returned.
 2503 
 2504 =cut
 2505 
 2506 sub language_lua_lines {
 2507   my $self = shift;
 2508   my @lines;
 2509   foreach my $p ($self->list_packages) {
 2510     my $obj = $self->get_package ($p);
 2511     die "$0: No TeX Live package named $p, strange" if ! $obj;
 2512     push @lines, $obj->language_lua_lines(@_);
 2513   }
 2514   return(@lines);
 2515 }
 2516 
 2517 =back
 2518 
 2519 =head1 VIRTUAL DATABASES
 2520 
 2521 The purpose of virtual databases is to collect several data sources
 2522 and present them in one way. The normal functions will always return
 2523 the best candidate for the set of functions.
 2524 
 2525 More docs to be written someday, maybe.
 2526 
 2527 =over 4
 2528 
 2529 =cut
 2530 
 2531 #
 2532 # packages are saved:
 2533 # $self->{'packages'}{$pkgname}{'tags'}{$tag}{'revision'} = $rev
 2534 # $self->{'packages'}{$pkgname}{'tags'}{$tag}{'tlp'} = $tlp
 2535 # $self->{'packages'}{$pkgname}{'target'} = $target_tag
 2536 #
 2537 
 2538 sub is_virtual {
 2539   my $self = shift;
 2540   if (defined($self->{'virtual'}) && $self->{'virtual'}) {
 2541     return 1;
 2542   }
 2543   return 0;
 2544 }
 2545 
 2546 sub make_virtual {
 2547   my $self = shift;
 2548   if (!$self->is_virtual) {
 2549     if ($self->list_packages) {
 2550       tlwarn("TLPDB: cannot convert initialized tlpdb to virtual\n");
 2551       return 0;
 2552     }
 2553     $self->{'virtual'} = 1;
 2554   }
 2555   return 1;
 2556 }
 2557 
 2558 sub virtual_get_tags {
 2559   my $self = shift;
 2560   return keys %{$self->{'tlpdbs'}};
 2561 }
 2562 
 2563 sub virtual_get_tlpdb {
 2564   my ($self, $tag) = @_;
 2565   if (!$self->is_virtual) {
 2566     tlwarn("TLPDB: cannot remove tlpdb from a non-virtual tlpdb!\n");
 2567     return 0;
 2568   }
 2569   if (!defined($self->{'tlpdbs'}{$tag})) {
 2570     tlwarn("TLPDB::virtual_get_tlpdb: unknown tag: $tag\n");
 2571     return 0;
 2572   }
 2573   return $self->{'tlpdbs'}{$tag};
 2574 }
 2575 
 2576 sub virtual_add_tlpdb {
 2577   my ($self, $tlpdb, $tag) = @_;
 2578   if (!$self->is_virtual) {
 2579     tlwarn("TLPDB: cannot virtual_add_tlpdb to a non-virtual tlpdb!\n");
 2580     return 0;
 2581   }
 2582   $self->{'tlpdbs'}{$tag} = $tlpdb;
 2583   for my $p ($tlpdb->list_packages) {
 2584     my $tlp = $tlpdb->get_package($p);
 2585     $self->{'packages'}{$p}{'tags'}{$tag}{'revision'} = $tlp->revision;
 2586     $self->{'packages'}{$p}{'tags'}{$tag}{'tlp'} = $tlp;
 2587   }
 2588   $self->check_evaluate_pinning();
 2589   return 1;
 2590 }
 2591 
 2592 sub virtual_remove_tlpdb {
 2593   my ($self, $tag) = @_;
 2594   if (!$self->is_virtual) {
 2595     tlwarn("TLPDB: Cannot remove tlpdb from a non-virtual tlpdb!\n");
 2596     return 0;
 2597   }
 2598   if (!defined($self->{'tlpdbs'}{$tag})) {
 2599     tlwarn("TLPDB: virtual_remove_tlpdb: unknown tag $tag\n");
 2600     return 0;
 2601   }
 2602   for my $p ($self->{'tlpdbs'}{$tag}->list_packages) {
 2603     delete $self->{'packages'}{$p}{'tags'}{$tag};
 2604   }
 2605   delete $self->{'tlpdbs'}{$tag};
 2606   $self->check_evaluate_pinning();
 2607   return 1;
 2608 }
 2609 
 2610 sub virtual_get_package {
 2611   my ($self, $pkg, $tag) = @_;
 2612   if (defined($self->{'packages'}{$pkg}{'tags'}{$tag})) {
 2613     return $self->{'packages'}{$pkg}{'tags'}{$tag}{'tlp'};
 2614   } else {
 2615     tlwarn("TLPDB: virtual pkg $pkg not found in tag $tag\n");
 2616     return;
 2617   }
 2618 }
 2619 
 2620 =item C<< $tlpdb->candidates ( $pkg ) >>
 2621 
 2622 Returns the list of candidates for the given package in the
 2623 format
 2624 
 2625   tag/revision
 2626 
 2627 If the returned list is empty, then the database was not virtual and
 2628 no install candidate was found.
 2629 
 2630 If the returned list contains undef as first element, the database
 2631 is virtual, and no install candidate was found.
 2632 
 2633 The remaining elements in the list are all repositories that provide
 2634 that package.
 2635 
 2636 Note that there might not be an install candidate, but still the
 2637 package is provided by a sub-repository. This can happen if a package
 2638 is present only in the sub-repository and there is no explicit pin
 2639 for that package in the pinning file.
 2640 
 2641 =cut
 2642 
 2643 sub is_repository {
 2644   my $self = shift;
 2645   my $tag = shift;
 2646   if (!$self->is_virtual) {
 2647     return ( ($tag eq $self->{'root'}) ? 1 : 0 );
 2648   }
 2649   return ( defined($self->{'tlpdbs'}{$tag}) ? 1 : 0 );
 2650 }
 2651 
 2652 
 2653 # returns a list of tag/rev
 2654 sub candidates {
 2655   my $self = shift;
 2656   my $pkg = shift;
 2657   my @ret = ();
 2658   if ($self->is_virtual) {
 2659     if (defined($self->{'packages'}{$pkg})) {
 2660       my $t = $self->{'packages'}{$pkg}{'target'};
 2661       if (defined($t)) {
 2662         push @ret, "$t/" . $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'};
 2663       } else {
 2664         $t = "";
 2665         # no target found, but maybe available somewhere else,
 2666         # we return undef as first one
 2667         push @ret, undef;
 2668       }
 2669       # make sure that we always check for main as repo
 2670       my @repos = keys %{$self->{'packages'}{$pkg}};
 2671       for my $r (sort keys %{$self->{'packages'}{$pkg}{'tags'}}) {
 2672         push @ret, "$r/" . $self->{'packages'}{$pkg}{'tags'}{$r}{'revision'}
 2673           if ($t ne $r);
 2674       }
 2675     }
 2676   } else {
 2677     my $tlp = $self->get_package($pkg);
 2678     if (defined($tlp)) {
 2679       push @ret, "main/" . $tlp->revision;
 2680     }
 2681   }
 2682   return @ret;
 2683 }
 2684 
 2685 =item C<< $tlpdb->candidate ( ) >>
 2686 
 2687 Returns either a list of four undef, if no install candidate is found,
 2688 or the following information on the install candidate as list: the tag
 2689 name of the repository, the revision number of the package in the
 2690 candidate repository, the tlpobj of the package in the candidate
 2691 repository, and the candidate repository's TLPDB itself.
 2692 
 2693 =cut
 2694 
 2695 #
 2696 sub virtual_candidate {
 2697   my ($self, $pkg) = @_;
 2698   my $t = $self->{'packages'}{$pkg}{'target'};
 2699   if (defined($t)) {
 2700     return ($t, $self->{'packages'}{$pkg}{'tags'}{$t}{'revision'},
 2701       $self->{'packages'}{$pkg}{'tags'}{$t}{'tlp'}, $self->{'tlpdbs'}{$t});
 2702   }
 2703   return(undef,undef,undef,undef);
 2704 }
 2705 
 2706 =item C<< $tlpdb->virtual_pinning ( [ $pinfile_TLConfFile] ) >>
 2707 
 2708 Sets or returns the C<TLConfFile> object for the pinning data.
 2709 
 2710 =cut
 2711 
 2712 sub virtual_pindata {
 2713   my $self = shift;
 2714   return ($self->{'pindata'});
 2715 }
 2716 
 2717 sub virtual_update_pins {
 2718   my $self = shift;
 2719   if (!$self->is_virtual) {
 2720     tlwarn("TLPDB::virtual_update_pins: Non-virtual tlpdb can't have pins.\n");
 2721     return 0;
 2722   }
 2723   my $pincf = $self->{'pinfile'};
 2724   my @pins;
 2725   for my $k ($pincf->keys) {
 2726     for my $v ($pincf->value($k)) {
 2727       # we recompose the values into lines again, as we *might* have
 2728       # options later, i.e., lines of the format
 2729       #   repo:pkg:opt
 2730       push (@pins, $self->make_pin_data_from_line("$k:$v"));
 2731     }
 2732   }
 2733   $self->{'pindata'} = \@pins;
 2734   $self->check_evaluate_pinning();
 2735   return ($self->{'pindata'});
 2736 }
 2737 sub virtual_pinning {
 2738   my ($self, $pincf) = @_;
 2739   if (!$self->is_virtual) {
 2740     tlwarn("TLPDB::virtual_pinning: Non-virtual tlpdb can't have pins.\n");
 2741     return 0;
 2742   }
 2743   if (!defined($pincf)) {
 2744     return ($self->{'pinfile'});
 2745   }
 2746   $self->{'pinfile'} = $pincf;
 2747   $self->virtual_update_pins();
 2748   return ($self->{'pinfile'});
 2749 }
 2750 
 2751 #
 2752 # current format:
 2753 # <repo>:<pkg_glob>[,<pkg_glob>,...][:<options>]
 2754 # only supported options for now is
 2755 #   revision
 2756 # meaning that, if for the selected package there is no other
 2757 # "non-revision" pinning, then all repo/package versions are compared
 2758 # using normal revision comparison, and the biggest revision number wins.
 2759 # That allows you to have the same package in several repos:
 2760 #   repo1:foo:revision
 2761 #   repo2:foo:revision
 2762 #   repo1:*
 2763 #   repo2:*
 2764 # means that:
 2765 # for package "foo" the revision numbers of "foo" in the repos "repo1",
 2766 # "repo2", and "main" are numerically compared and biggest number wins.
 2767 # for all other packages of "repo1" and "repo2", other repositories
 2768 # are not considered.
 2769 #
 2770 # NOT IMPLEMENTED YET!!!
 2771 #
 2772 # $pin{'repo'} = $repo;
 2773 # $pin{'glob'} = $glob;
 2774 # $pin{'re'} = $re;
 2775 # $pin{'line'} = $line; # for debug/warning purpose
 2776 sub make_pin_data_from_line {
 2777   my $self = shift;
 2778   my $l = shift;
 2779   my ($a, $b, $c) = split(/:/, $l);
 2780   my @ret;
 2781   my %m;
 2782   $m{'repo'} = $a;
 2783   $m{'line'} = $l;
 2784   if (defined($c)) {
 2785     $m{'options'} = $c;
 2786   }
 2787   # split the package globs
 2788   for (split(/,/, $b)) {
 2789     # remove leading and terminal white space
 2790     s/^\s*//;
 2791     s/\s*$//;
 2792     my %mm = %m;
 2793     $mm{'glob'} = $_;
 2794     $mm{'re'} = glob_to_regex($_);
 2795     push @ret, \%mm;
 2796   }
 2797   return @ret;
 2798 }
 2799 
 2800 sub check_evaluate_pinning {
 2801   my $self = shift;
 2802   my @pins = (defined($self->{'pindata'}) ? @{$self->{'pindata'}} : ());
 2803   #
 2804   # run through the pin lines and make sure that all the conditions
 2805   # and requirements are obeyed
 2806   my %pkgs = %{$self->{'packages'}};
 2807   # main:*
 2808   my ($mainpin) = $self->make_pin_data_from_line("main:*");
 2809   # the default main:* is always considered to be matched
 2810   $mainpin->{'hit'} = 1;
 2811   push @pins, $mainpin;
 2812   # # sort pins so that we first check specific lines without occurrences of
 2813   # # special characters, and then those with special characters.
 2814   # # The definitions are based on glob style rules, saved in $pp->{'glob'}
 2815   # # so we simply check whether there is * or ? in the string
 2816   # @pins = sort {
 2817   #   my $ag = $a->{'glob'};
 2818   #   my $bg = $b->{'glob'};
 2819   #   my $cAs = () = $ag =~ /\*/g; # number of * in glob of $a
 2820   #   my $cBs = () = $bg =~ /\*/g; # number of * in glob of $b
 2821   #   my $cAq = () = $ag =~ /\?/g; # number of ? in glob of $a
 2822   #   my $cBq = () = $bg =~ /\?/g; # number of ? in glob of $b
 2823   #   my $aVal = 2 * $cAs + $cAq;
 2824   #   my $bVal = 2 * $cBs + $cBq;
 2825   #   $aVal <=> $bVal
 2826   # } @pins;
 2827   for my $pkg (keys %pkgs) {
 2828     PINS: for my $pp (@pins) {
 2829       my $pre = $pp->{'re'};
 2830       if (($pkg =~ m/$pre/) &&
 2831           (defined($self->{'packages'}{$pkg}{'tags'}{$pp->{'repo'}}))) {
 2832         $self->{'packages'}{$pkg}{'target'} = $pp->{'repo'};
 2833         # register that this pin was hit
 2834         $pp->{'hit'} = 1;
 2835         last PINS;
 2836       }
 2837     }
 2838   }
 2839   # check that all pinning lines where hit
 2840   # If a repository has a catch-all pin
 2841   #   foo:*
 2842   # then we do not warn about any other pin (foo:abcde) not being hit.
 2843   my %catchall;
 2844   for my $p (@pins) {
 2845     $catchall{$p->{'repo'}} = 1 if ($p->{'glob'} eq "*");
 2846   }
 2847   for my $p (@pins) {
 2848     next if defined($p->{'hit'});
 2849     next if defined($catchall{$p->{'repo'}});
 2850     tlwarn("tlmgr (TLPDB): pinning warning: the package pattern ",
 2851            $p->{'glob'}, " on the line:\n  ", $p->{'line'},
 2852            "\n  does not match any package\n");
 2853   }
 2854 }
 2855 
 2856 
 2857 # implementation copied from Text/Glob.pm (copyright Richard Clamp).
 2858 # changes made:
 2859 # remove $strict_leading_dot and $strict_wildcard_slash if calls
 2860 # and execute the code unconditionally, as we do not change the
 2861 # default settings of 1 of these two variables.
 2862 sub glob_to_regex {
 2863     my $glob = shift;
 2864     my $regex = glob_to_regex_string($glob);
 2865     return qr/^$regex$/;
 2866 }
 2867 
 2868 sub glob_to_regex_string
 2869 {
 2870     my $glob = shift;
 2871     my ($regex, $in_curlies, $escaping);
 2872     local $_;
 2873     my $first_byte = 1;
 2874     for ($glob =~ m/(.)/gs) {
 2875         if ($first_byte) {
 2876             $regex .= '(?=[^\.])' unless $_ eq '.';
 2877             $first_byte = 0;
 2878         }
 2879         if ($_ eq '/') {
 2880             $first_byte = 1;
 2881         }
 2882         if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' ||
 2883             $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) {
 2884             $regex .= "\\$_";
 2885         }
 2886         elsif ($_ eq '*') {
 2887             $regex .= $escaping ? "\\*" : "[^/]*";
 2888         }
 2889         elsif ($_ eq '?') {
 2890             $regex .= $escaping ? "\\?" : "[^/]";
 2891         }
 2892         elsif ($_ eq '{') {
 2893             $regex .= $escaping ? "\\{" : "(";
 2894             ++$in_curlies unless $escaping;
 2895         }
 2896         elsif ($_ eq '}' && $in_curlies) {
 2897             $regex .= $escaping ? "}" : ")";
 2898             --$in_curlies unless $escaping;
 2899         }
 2900         elsif ($_ eq ',' && $in_curlies) {
 2901             $regex .= $escaping ? "," : "|";
 2902         }
 2903         elsif ($_ eq "\\") {
 2904             if ($escaping) {
 2905                 $regex .= "\\\\";
 2906                 $escaping = 0;
 2907             }
 2908             else {
 2909                 $escaping = 1;
 2910             }
 2911             next;
 2912         }
 2913         else {
 2914             $regex .= $_;
 2915             $escaping = 0;
 2916         }
 2917         $escaping = 0;
 2918     }
 2919     print "# $glob $regex\n" if debug;
 2920 
 2921     return $regex;
 2922 }
 2923 
 2924 sub match_glob {
 2925     print "# ", join(', ', map { "'$_'" } @_), "\n" if debug;
 2926     my $glob = shift;
 2927     my $regex = glob_to_regex $glob;
 2928     local $_;
 2929     grep { $_ =~ $regex } @_;
 2930 }
 2931 
 2932 =pod
 2933 
 2934 =back
 2935 
 2936 =head1 OPTIONS
 2937 
 2938 Options regarding the full TeX Live installation to be described are saved
 2939 in a package C<00texlive.config> as values of C<depend> lines. This special
 2940 package C<00texlive.config> does not contain any files, only depend lines
 2941 which set one or more of the following options:
 2942 
 2943 =over 4
 2944 
 2945 =item C<container_split_src_files/[01]>
 2946 
 2947 =item C<container_split_doc_files/[01]>
 2948 
 2949 These options specify that at container generation time the source and
 2950 documentation files for a package have been put into a separate container
 2951 named C<package.source.extension> and C<package.doc.extension>.
 2952 
 2953 =item C<container_format/I<format>>
 2954 
 2955 This option specifies a format for containers. The currently supported 
 2956 formats are C<xz> and C<zip>. But note that C<zip> is untested.
 2957 
 2958 =item C<release/I<relspec>>
 2959 
 2960 This option specifies the current release. The first four characters must
 2961 be a year.
 2962 
 2963 =item C<minrelease/I<relspec>>
 2964 
 2965 This option specifies the minimum release for which this repository is
 2966 valid.
 2967 
 2968 =back
 2969 
 2970 To set these options the respective lines should be added to
 2971 C<00texlive.config.tlpsrc>.
 2972 
 2973 =head1 SEE ALSO
 2974 
 2975 The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>, L<TeXLive::TLTREE>,
 2976 L<TeXLive::TLUtils>, etc., and the documentation in the repository:
 2977 C<Master/tlpkg/doc/>.
 2978 
 2979 =head1 AUTHORS AND COPYRIGHT
 2980 
 2981 This script and its documentation were written for the TeX Live
 2982 distribution (L<http://tug.org/texlive>) and both are licensed under the
 2983 GNU General Public License Version 2 or later.
 2984 
 2985 =cut
 2986 
 2987 1;
 2988 
 2989 ### Local Variables:
 2990 ### perl-indent-level: 2
 2991 ### tab-width: 2
 2992 ### indent-tabs-mode: nil
 2993 ### End:
 2994 # vim:set tabstop=2 expandtab autoindent: #