"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/texmf-dist/scripts/texlive/tlmgr.pl" (6 Aug 2020, 340933 Bytes) of package /linux/misc/install-tl-unx.tar.gz:


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 #!/usr/bin/env perl
    2 # $Id: tlmgr.pl 56058 2020-08-06 01:41:42Z preining $
    3 #
    4 # Copyright 2008-2020 Norbert Preining
    5 # This file is licensed under the GNU General Public License version 2
    6 # or any later version.
    7 
    8 my $svnrev = '$Revision: 56058 $';
    9 my $datrev = '$Date: 2020-08-06 03:41:42 +0200 (Thu, 06 Aug 2020) $';
   10 my $tlmgrrevision;
   11 my $tlmgrversion;
   12 my $prg;
   13 my $bindir;
   14 if ($svnrev =~ m/: ([0-9]+) /) {
   15   $tlmgrrevision = $1;
   16 } else {
   17   $tlmgrrevision = "unknown";
   18 }
   19 $datrev =~ s/^.*Date: //;
   20 $datrev =~ s/ \(.*$//;
   21 $tlmgrversion = "$tlmgrrevision ($datrev)";
   22 
   23 our $Master;
   24 our $ismain;
   25 our $loadmediasrcerror;
   26 our $packagelogfile;
   27 our $packagelogged;
   28 our $commandlogfile;
   29 our $tlmgr_config_file;
   30 our $pinfile;
   31 our $action; # for the pod2usage -sections call
   32 our %opts;
   33 our $allowed_verify_args_regex = qr/^(none|main|all)$/i;
   34 
   35 END {
   36   if ($opts{"pause"}) {
   37     print "Press Enter to exit the program.\n";
   38     <STDIN>;
   39   }
   40 }
   41 
   42 BEGIN {
   43   $^W = 1;
   44   $ismain = (__FILE__ eq $0);
   45   # WARNING
   46   # The only use anticipated for tlmgr.pl as library for the 2009 release
   47   # is the Windows w32client prototype script.
   48   # Unix-specific problems with use as library will probably go undetected.
   49 
   50   # make subprograms (including kpsewhich) have the right path:
   51   my $kpsewhichname;
   52   if ($^O =~ /^MSWin/i) {
   53     # on w32 $0 and __FILE__ point directly to tlmgr.pl; they can be relative
   54     $Master = __FILE__;
   55     $Master =~ s!\\!/!g;
   56     $Master =~ s![^/]*$!../../..!
   57       unless ($Master =~ s!/texmf-dist/scripts/texlive/tlmgr\.pl$!!i);
   58     $bindir = "$Master/bin/win32";
   59     $kpsewhichname = "kpsewhich.exe";
   60     # path already set by wrapper batchfile
   61   } else {
   62     $Master = __FILE__;
   63     $Master =~ s,/*[^/]*$,,;
   64     if ($ismain) {
   65       $bindir = $Master;
   66       $Master = "$Master/../..";
   67     } else {
   68       # for the time being, this code will not be used or tested
   69       $Master = "$Master/../../..";
   70       # no code yet for $bindir; would have to detect platform
   71     }
   72     # make subprograms (including kpsewhich) have the right path:
   73     $ENV{"PATH"} = "$bindir:$ENV{PATH}";
   74     $kpsewhichname = "kpsewhich";
   75   }
   76   if (-r "$bindir/$kpsewhichname") {
   77     # if not in bootstrapping mode => kpsewhich exists, so use it to get $Master
   78     chomp($Master = `kpsewhich -var-value=SELFAUTOPARENT`);
   79   }
   80 
   81   # if we have no directory in which to find our modules,
   82   # no point in going on.
   83   if (! $Master) {
   84     die ("Could not determine directory of tlmgr executable, "
   85          . "maybe shared library woes?\nCheck for error messages above");
   86   }
   87 
   88   $::installerdir = $Master;  # for config.guess et al., see TLUtils.pm
   89 
   90   # make Perl find our packages first:
   91   unshift (@INC, "$Master/tlpkg");
   92   unshift (@INC, "$Master/texmf-dist/scripts/texlive");
   93 }
   94 
   95 use Cwd qw/abs_path/;
   96 use File::Spec;
   97 use Pod::Usage;
   98 use Getopt::Long qw(:config no_autoabbrev permute);
   99 use strict;
  100 
  101 use TeXLive::TLConfig;
  102 use TeXLive::TLPDB;
  103 use TeXLive::TLPOBJ;
  104 use TeXLive::TLUtils;
  105 use TeXLive::TLWinGoo;
  106 use TeXLive::TLDownload;
  107 use TeXLive::TLConfFile;
  108 use TeXLive::TLCrypto;
  109 TeXLive::TLUtils->import(qw(member info give_ctan_mirror win32 dirname
  110                             mkdirhier copy debug tlcmp repository_to_array));
  111 use TeXLive::TLPaper;
  112 
  113 #
  114 # set up $prg for warning messages
  115 $prg = TeXLive::TLUtils::basename($0);
  116 # for usage in various Perl modules
  117 $::prg = $prg;
  118 
  119 binmode(STDOUT, ":utf8");
  120 binmode(STDERR, ":utf8");
  121 
  122 our %config;       # hash of config settings from config file
  123 our $remotetlpdb;
  124 our $location;     # location from which the new packages come
  125 our $localtlpdb;   # local installation which we are munging
  126 
  127 # flags for machine-readable form
  128 our $FLAG_REMOVE = "d";
  129 our $FLAG_FORCIBLE_REMOVED = "f";
  130 our $FLAG_UPDATE = "u";
  131 our $FLAG_REVERSED_UPDATE = "r";
  132 our $FLAG_AUTOINSTALL = "a";
  133 our $FLAG_INSTALL = "i";
  134 our $FLAG_REINSTALL = "I";
  135 
  136 # keep in sync with install-tl.
  137 our $common_fmtutil_args = 
  138   "--no-error-if-no-engine=$TeXLive::TLConfig::PartialEngineSupport";
  139 
  140 # option variables
  141 $::gui_mode = 0;
  142 $::machinereadable = 0;
  143 
  144 my %action_specification = (
  145   '_include_tlpobj' => {
  146     "run-post" => 0,
  147     "function" => \&action_include_tlpobj
  148   },
  149   "backup" => { 
  150     "options" => {
  151       "all" => 1,
  152       "backupdir" => "=s",
  153       "clean" => ":-99",
  154       "dry-run|n" => 1
  155     },
  156     "run-post" => 1,
  157     "function" => \&action_backup
  158   },
  159   "candidates" => {
  160     "run-post" => 0,
  161     "function" => \&action_candidates
  162   },
  163   "check" => { 
  164     "options"  => { "use-svn" => 1 },
  165     "run-post" => 1,
  166     "function" => \&action_check
  167   },
  168   "conf" => {
  169     "options"  => { 
  170       "conffile" => "=s",
  171       "delete" => 1,
  172     },
  173     "run-post" => 0,
  174     "function" => \&action_conf
  175   },
  176   "dump-tlpdb" => { 
  177     "options"  => { local => 1, remote => 1 },
  178     "run-post" => 0,
  179     "function" => \&action_dumptlpdb
  180   },
  181   "generate" => { 
  182     "options"  => {
  183       "dest" => "=s",
  184       "localcfg" => "=s",
  185       "rebuild-sys" => 1
  186     },
  187     "run-post" => 1,
  188     "function" => \&action_generate
  189   },
  190   "get-mirror" => {
  191     "run-post" => 0,
  192     "function" => \&action_get_mirror
  193   },
  194   "gui" => { 
  195     "options"  => {
  196       "load" => 1,
  197       # Tk::CmdLine options
  198       "background" => "=s",
  199       "class" => "=s",
  200       "display" => "=s",
  201       "font" => "=s",
  202       "foreground" => "=s",
  203       "geometry" => "=s",
  204       "iconic" => 1,
  205       "motif" => 1,
  206       "name" => "=s",
  207       "screen" => "=s",
  208       "synchronous" => 1,
  209       "title" => "=s",
  210       "xrm" => "=s",
  211     },
  212     "run-post" => 1,
  213     "function" => \&action_gui
  214   },
  215   "info" => { 
  216     "options"  => { 
  217       "data" => "=s",
  218       "all" => 1,
  219       "list" => 1, 
  220       "only-installed" => 1,
  221       "only-remote" => 1
  222     },
  223     "run-post" => 0,
  224     "function" => \&action_info
  225   },
  226   "init-usertree" => {
  227     "run-post" => 0,
  228     "function" => \&action_init_usertree
  229   },
  230   "install" => {
  231     "options"  => {
  232       "dry-run|n" => 1,
  233       "file" => 1,
  234       "force" => 1,
  235       "no-depends"        => 1,
  236       "no-depends-at-all" => 1,
  237       "reinstall" => 1,
  238       "with-doc" => 1,
  239       "with-src" => 1,
  240     },
  241     "run-post" => 1,
  242     "function" => \&action_install
  243   },
  244   "key" => {
  245     "run-post" => 0,
  246     "function" => \&action_key
  247   },
  248   "option" => { 
  249     "run-post" => 1,
  250     "function" => \&action_option
  251   },
  252   "paper" => { 
  253     "options"  => { "list" => 1 },
  254     "run-post" => 1,
  255     "function" => \&action_paper
  256   },
  257   "path" => {
  258     "options"  => { "w32mode" => "=s" },
  259     "run-post" => 0,
  260     "function" => \&action_path
  261   },
  262   "pinning" => { 
  263     "options"  => { "all" => 1 },
  264     "run-post" => 1,
  265     "function" => \&action_pinning
  266   },
  267   "platform" => { 
  268     "options"  => { "dry-run|n" => 1 },
  269     "run-post" => 1,
  270     "function" => \&action_platform
  271   },
  272   "postaction" => {
  273     "options" => {
  274       "all" => 1,
  275       "fileassocmode" => "=i",
  276       "w32mode" => "=s",
  277     },
  278     "run-post" => 0,
  279     "function" => \&action_postaction
  280   },
  281   "recreate-tlpdb" => { 
  282     "options"  => { "platform|arch" => "=s" },
  283     "run-post" => 0,
  284     "function" => \&action_recreate_tlpdb
  285   },
  286   "remove" => { 
  287     "options"  => {
  288       "all" => 1,
  289       "backup" => 1,
  290       "backupdir" => "=s",
  291       "dry-run|n" => 1,
  292       "force" => 1,
  293       "no-depends"        => 1,
  294       "no-depends-at-all" => 1,
  295     },
  296     "run-post" => 1,
  297     "function" => \&action_remove
  298   },
  299   repository => {
  300     "options"  => { "with-platforms" => 1 },
  301     "run-post" => 1,
  302     "function" => \&action_repository
  303   },
  304   "restore" => {
  305     "options"  => {
  306       "all" => 1,
  307       "backupdir" => "=s",
  308       "dry-run|n" => 1,
  309       "force" => 1
  310     },
  311     "run-post" => 1,
  312     "function" => \&action_restore
  313   },
  314   "search" => {
  315     "options"  => {
  316       "all" => 1,
  317       "file" => 1,
  318       "global" => 1,
  319       "word" => 1,
  320     },
  321     "run-post" => 1,
  322     "function" => \&action_search
  323   },
  324   "shell" => {
  325     "function" => \&action_shell
  326   },
  327   "update" => {
  328     "options"  => {
  329       "all" => 1,
  330       "backup" => 1,
  331       "backupdir" => "=s",
  332       "dry-run|n" => 1,
  333       "exclude" => "=s@",
  334       "force" => 1,
  335       "list" => 1,
  336       "no-auto-install"            => 1,
  337       "no-auto-remove"             => 1,
  338       "no-depends"                 => 1,
  339       "no-depends-at-all"          => 1,
  340       "no-restart"                 => 1,
  341       "reinstall-forcibly-removed" => 1,
  342       "self" => 1,
  343     },
  344     "run-post" => 1,
  345     "function" => \&action_update
  346   },
  347   "version" => { }, # handled separately
  348 );
  349 
  350 my %globaloptions = (
  351   "gui" => 1,
  352   "gui-lang" => "=s",
  353   "debug-json-timing" => 1,
  354   "debug-translation" => 1,
  355   "h|?" => 1,
  356   "help" => 1,
  357   "json" => 1,
  358   "location|repository|repo" => "=s",
  359   "machine-readable" => 1,
  360   "no-execute-actions" => 1,
  361   "package-logfile" => "=s",
  362   "command-logfile" => "=s",
  363   "persistent-downloads" => "!",
  364   "pause" => 1,
  365   "pin-file" => "=s",
  366   "print-platform|print-arch" => 1,
  367   "print-platform-info" => 1,
  368   "usermode|user-mode" => 1,
  369   "usertree|user-tree" => "=s",
  370   "verify-repo" => "=s",
  371   "verify-downloads" => "!",
  372   "require-verification" => "!",
  373   "version" => 1,
  374 );
  375 
  376 main() if $ismain;
  377 
  378 
  379 ### main ##################################################################
  380 
  381 sub main {
  382   my %options;       # TL options from local tlpdb
  383 
  384   my %optarg;
  385   for my $k (keys %globaloptions) {
  386     if ($globaloptions{$k} eq "1") {
  387       $optarg{$k} = 1;
  388     } else {
  389       $optarg{"$k" . $globaloptions{$k}} = 1;
  390     }
  391   }
  392   for my $v (values %action_specification) {
  393     if (defined($v->{'options'})) {
  394       my %opts = %{$v->{'options'}};
  395       for my $k (keys %opts) {
  396         if ($opts{$k} eq "1") {
  397           $optarg{$k} = 1;
  398         } else {
  399           $optarg{"$k" . $opts{$k}} = 1;
  400         }
  401       }
  402     }
  403   }
  404 
  405   # save command line options for later restart, if necessary
  406   @::SAVEDARGV = @ARGV;
  407 
  408   TeXLive::TLUtils::process_logging_options();
  409 
  410   GetOptions(\%opts, keys(%optarg)) or pod2usage(2);
  411 
  412   $::debug_translation = 0;
  413   $::debug_translation = 1 if $opts{"debug-translation"};
  414 
  415   $::machinereadable = $opts{"machine-readable"}
  416     if (defined($opts{"machine-readable"}));
  417 
  418   $action = shift @ARGV;
  419   if (!defined($action)) {
  420     if ($opts{"gui"}) {   # -gui = gui
  421       $action = "gui";
  422     } elsif ($opts{"print-platform"}) {
  423       $action = "print-platform";
  424     } elsif ($opts{"print-platform-info"}) {
  425       $action = "print-platform-info";
  426     } else {
  427       $action = "";
  428     }
  429   }
  430   $action = lc($action);
  431 
  432   $action = "platform" if ($action eq "arch");
  433 
  434   ddebug("action = $action\n");
  435   for my $k (keys %opts) {
  436     ddebug("$k => $opts{$k}\n");
  437   }
  438   ddebug("arguments: @ARGV\n") if @ARGV;
  439 
  440   if ($opts{"version"} || (defined $action && $action eq "version")) {
  441     if ($::machinereadable) {
  442       # give_version already is machinereadable aware
  443       print give_version();
  444     } else {
  445       info(give_version());
  446     }
  447     exit(0);
  448   }
  449 
  450   if (defined($action) && $action eq "help") {
  451     $opts{"help"} = 1;
  452     $action = undef;  # an option not an action
  453   }
  454 
  455   if (defined($action) && $action eq "print-platform") {
  456     print TeXLive::TLUtils::platform(), "\n";
  457     exit 0;
  458   }
  459 
  460   if (defined($action) && $action eq "print-platform-info") {
  461     print "config.guess  ", `$::installerdir/tlpkg/installer/config.guess`;
  462     my $plat = TeXLive::TLUtils::platform();
  463     print "platform      ", $plat, "\n";
  464     print "platform_desc ", TeXLive::TLUtils::platform_desc($plat), "\n";
  465     exit 0;
  466   }
  467 
  468   # ACTION massaging
  469   # for backward compatibility and usability
  470 
  471   # unify arguments so that the $action contains paper in all cases
  472   # and push the first arg back to @ARGV for action_paper processing
  473   if (defined $action 
  474       && $action =~ /^(paper|xdvi|psutils|pdftex|dvips|dvipdfmx?|context)$/) {
  475     unshift(@ARGV, $action);
  476     $action = "paper";
  477   }
  478 
  479   # backward compatibility with action "show" and "list" from before
  480   if (defined $action && $action =~ /^(show|list)$/) {
  481     $action = "info";
  482   }
  483   # merge actions remove and uninstall
  484   if (defined $action && $action eq "uninstall") {
  485     $action = "remove";
  486   }
  487 
  488   #
  489   # check for correctness of verify-repo argument
  490   if (defined($opts{"verify-repo"}) &&
  491       ($opts{"verify-repo"} !~ m/$allowed_verify_args_regex/)) {
  492     tldie("$prg: unknown value for --verify-repo: $opts{'verify-repo'}\n");
  493   }
  494   # convert command line crypto options
  495   $opts{"verify-repo"}
  496     = convert_crypto_options($opts{"verify-downloads"},
  497                              $opts{"require-verification"},
  498                              $opts{"verify-repo"});
  499   if (defined($opts{"verify-downloads"})
  500       || defined($opts{"require-verification"})) {
  501     tlwarn("$prg: please use -verify-repo options instead of verify-downloads/require-verification\n" .
  502            "$prg: adjusting to --verify-repo=$opts{'verify-repo'}\n");
  503   }
  504   delete $opts{"require-verification"};
  505   delete $opts{"verify-downloads"};
  506 
  507   # now $action should be part of %actionoptions, otherwise this is
  508   # an error
  509   if (defined($action) && $action && !exists $action_specification{$action}) {
  510     die "$prg: unknown action: $action; try --help if you need it.\n";
  511   }
  512 
  513   if ((!defined($action) || !$action) && !$opts{"help"} && !$opts{"h"}) {
  514     die "$prg: no action given; try --help if you need it.\n";
  515   }
  516 
  517   if ($opts{"help"} || $opts{"h"}) {
  518     # perldoc does ASCII emphasis on the output, and runs it through
  519     # $PAGER, so people want it.  But not all Unix platforms have it,
  520     # and on Windows our Config.pm can apparently interfere, so always
  521     # skip it there.  Or if users have NOPERLDOC set in the environment.
  522     my @noperldoc = ();
  523     if (win32() || $ENV{"NOPERLDOC"}) {
  524       @noperldoc = ("-noperldoc", "1");
  525     } else {
  526       if (!TeXLive::TLUtils::which("perldoc")) {
  527         @noperldoc = ("-noperldoc", "1");
  528       } else {
  529         # checking only for the existence of perldoc is not enough
  530         # because Debian/Ubuntu unfortunately ship a stub that does nothing;
  531         # try to check for that, too.
  532         my $ret = system("perldoc -V >/dev/null 2>&1");
  533         if ($ret == 0) {
  534           debug("working perldoc found, using it\n");
  535         } else {
  536           tlwarn("$prg: perldoc seems to be non-functional, not using it.\n");
  537           @noperldoc = ("-noperldoc", "1");
  538         }
  539       }
  540     }
  541     # less can break control characters and thus the output of pod2usage
  542     # is broken.  We add/set LESS=-R in the environment and unset
  543     # LESSPIPE and LESSOPEN to try to help.
  544     # 
  545     if (defined($ENV{'LESS'})) {
  546       $ENV{'LESS'} .= " -R";
  547     } else {
  548       $ENV{'LESS'} = "-R";
  549     }
  550     delete $ENV{'LESSPIPE'};
  551     delete $ENV{'LESSOPEN'};
  552     if ($action && ($action ne "help")) {
  553       # 1) Must use [...] form for -sections arg because otherwise the
  554       #    /$action subsection selector applies to all sections.
  555       #    https://rt.cpan.org/Public/Bug/Display.html?id=102116
  556       # 2) Must use "..." for that so the $action value is interpolated.
  557       pod2usage(-exitstatus => 0, -verbose => 99,
  558                 -sections => [ 'NAME', 'SYNOPSIS', "ACTIONS/$::action.*" ],
  559                 @noperldoc);
  560     } else {
  561       if ($opts{"help"}) {
  562         pod2usage(-exitstatus => 0, -verbose => 2, @noperldoc);
  563       } else {
  564         # give a short message about usage
  565         print "
  566 tlmgr revision $tlmgrversion
  567 usage: tlmgr  OPTION...  ACTION  ARGUMENT...
  568 where ACTION is one of:\n";
  569         for my $k (sort keys %action_specification) {
  570           # don't print internal options
  571           next if ($k =~ m/^_/);
  572           print " $k\n";
  573         }
  574         print "\nUse\n tlmgr ACTION --help
  575 for more details on a specific option, and
  576  tlmgr --help
  577 for the full story.\n";
  578         exit 0;
  579       }
  580     }
  581   }
  582 
  583   # --machine-readable is only supported by update.
  584   if ($::machinereadable && 
  585     $action ne "update" && $action ne "install" && $action ne "option" && $action ne "shell" && $action ne "remove") {
  586     tlwarn("$prg: --machine-readable output not supported for $action\n");
  587   }
  588 
  589   #
  590   # bail out of it is unknown action
  591   if (!defined($action_specification{$action})) {
  592     tlwarn("$prg: action unknown: $action\n");
  593     exit ($F_ERROR);
  594   }
  595 
  596   # check on supported arguments
  597   #
  598   my %suppargs;
  599   %suppargs = %{$action_specification{$action}{'options'}}
  600     if defined($action_specification{$action}{'options'});
  601   my @notvalidargs;
  602   for my $k (keys %opts) {
  603     my @allargs = keys %suppargs;
  604     push @allargs, keys %globaloptions;
  605     my $found = 0;
  606     for my $ok (@allargs) {
  607       my @variants = split '\|', $ok;
  608       if (TeXLive::TLUtils::member($k, @variants)) {
  609         $found = 1;
  610         last;
  611       }
  612     }
  613     push @notvalidargs, $k if !$found;
  614   }
  615   if (@notvalidargs) {
  616     my $msg = "The action $action does not support the following option(s):\n";
  617     for my $c (@notvalidargs) {
  618       $msg .= " $c";
  619     }
  620     tlwarn("$prg: $msg\n");
  621     tldie("$prg: Try --help if you need it.\n");
  622   }
  623 
  624   #
  625   # the main tree we will be working on
  626   $::maintree = $Master;
  627   if ($opts{"usermode"}) {
  628     # we could also try to detect that we don't have write permissions
  629     # and switch to user mode automatically
  630     if (defined($opts{"usertree"})) {
  631       $::maintree = $opts{"usertree"};
  632     } else {
  633       chomp($::maintree = `kpsewhich -var-value TEXMFHOME`);
  634     }
  635   }
  636 
  637   # besides doing normal logging if -logfile is specified, we try to log
  638   # package related actions (install, remove, update) to
  639   # the package-log file TEXMFSYSVAR/web2c/tlmgr.log
  640   $packagelogged = 0;  # how many msgs we logged
  641   chomp (my $texmfsysvar = `kpsewhich -var-value=TEXMFSYSVAR`);
  642   $packagelogfile = $opts{"package-logfile"};
  643   if ($opts{"usermode"}) {
  644     $packagelogfile ||= "$::maintree/web2c/tlmgr.log";
  645   } else {
  646     $packagelogfile ||= "$texmfsysvar/web2c/tlmgr.log";
  647   }
  648   #
  649   # Try to open the packagelog file, but do NOT die when that does not work
  650   if (!open(PACKAGELOG, ">>$packagelogfile")) {
  651     debug("Cannot open package log file for appending: $packagelogfile\n");
  652     debug("Will not log package installation/removal/update for this run\n");
  653     $packagelogfile = "";
  654   } else {
  655     debug("appending to package log file: $packagelogfile\n");
  656   }
  657 
  658   # output of executed commands are put into -command-logfile
  659   $commandlogfile = $opts{"command-logfile"};
  660   if ($opts{"usermode"}) {
  661     $commandlogfile ||= "$::maintree/web2c/tlmgr-commands.log";
  662   } else {
  663     $commandlogfile ||= "$texmfsysvar/web2c/tlmgr-commands.log";
  664   }
  665   # Try to open the packagelog file, but do NOT die when that does not work
  666   if (!open(COMMANDLOG, ">>$commandlogfile")) {
  667     debug("Cannot open command log file for appending: $commandlogfile\n");
  668     debug("Will not log output of executed commands for this run\n");
  669     $commandlogfile = "";
  670   } else {
  671     debug("appending to command log file: $commandlogfile\n");
  672   }
  673 
  674   $loadmediasrcerror = "Cannot load TeX Live database from ";
  675 
  676   # load the config file and set the config options
  677   # load it BEFORE starting downloads as we set persistent-downloads there!
  678   load_config_file();
  679 
  680   # in system mode verify that the selected action is allowed
  681   if (!$opts{"usermode"} && $config{'allowed-actions'}) {
  682     if (!TeXLive::TLUtils::member($action, @{$config{'allowed-actions'}})) {
  683       tlwarn("$prg: action not allowed in system mode: $action\n");
  684       exit ($F_ERROR);
  685     }
  686   }
  687 
  688   # set global variable if execute actions should be suppressed
  689   $::no_execute_actions = 1 if (defined($opts{'no-execute-actions'}));
  690 
  691   # if we are asked to use persistent connections try to start it here
  692   ddebug("tlmgr:main: do persistent downloads = $opts{'persistent-downloads'}\n");
  693   if ($opts{'persistent-downloads'}) {
  694     TeXLive::TLUtils::setup_persistent_downloads() ;
  695   }
  696   if (!defined($::tldownload_server)) {
  697     debug("tlmgr:main: ::tldownload_server not defined\n");
  698   } else {
  699     if ($::opt_verbosity >= 1) {
  700       debug(debug_hash_str("$prg:main: ::tldownload_server hash:",
  701                             $::tldownload_server));
  702     }
  703   }
  704 
  705   my $ret = execute_action($action, @ARGV);
  706 
  707   # close the special log file
  708   if ($packagelogfile && !$::gui_mode) {
  709     info("$prg: package log updated: $packagelogfile\n") if $packagelogged;
  710     close(PACKAGELOG);
  711   }
  712 
  713   # F_ERROR stops processing immediately, and prevents postactions from
  714   # being run (e.g., untar fails).  F_WARNING continues on, including
  715   # postactions (e.g., user tries to install 10 packages and the
  716   # checksum fails for one, but the others are ok), but still ends the
  717   # program by exiting unsuccessfully.  So call them both "errors" 
  718   # as far as the user is concerned.
  719   if ($ret & ($F_ERROR | $F_WARNING)) {
  720     tlwarn("$prg: An error has occurred. See above messages. Exiting.\n");
  721   }
  722 
  723   # end of main program, returns also error codes 
  724   exit ($ret);
  725 
  726 } # end main
  727 
  728 sub give_version {
  729   if (!defined($::version_string)) {
  730     $::version_string = "";
  731     $::mrversion = "";
  732     $::version_string .= "tlmgr revision $tlmgrversion\n";
  733     $::mrversion .= "revision $tlmgrrevision\n";
  734     $::version_string .= "tlmgr using installation: $Master\n";
  735     $::mrversion .= "installation $Master\n";
  736     if (open (REL_TL, "$Master/release-texlive.txt")) {
  737       # print first, which has the TL version info.
  738       my $rel_tl = <REL_TL>;
  739       $::version_string .= $rel_tl;
  740       # for machine readable we only want the last word which is the version
  741       my @foo = split(' ', $rel_tl);
  742       $::mrversion .= "tlversion $foo[$#foo]\n";
  743       close (REL_TL);
  744     }
  745     #
  746     # add the list of revisions
  747     if ($::opt_verbosity > 0) {
  748       $::version_string .= "Revisions of TeXLive:: modules:";
  749       $::version_string .= "\nTLConfig: " . TeXLive::TLConfig->module_revision();
  750       $::version_string .= "\nTLUtils:  " . TeXLive::TLUtils->module_revision();
  751       $::version_string .= "\nTLPOBJ:   " . TeXLive::TLPOBJ->module_revision();
  752       $::version_string .= "\nTLPDB:    " . TeXLive::TLPDB->module_revision();
  753       $::version_string .= "\nTLPaper:  " . TeXLive::TLPaper->module_revision();
  754       $::version_string .= "\nTLWinGoo: " . TeXLive::TLWinGoo->module_revision();
  755       $::version_string .= "\n";
  756     }
  757     $::mrversion      .= "TLConfig "   . TeXLive::TLConfig->module_revision();
  758     $::mrversion      .= "\nTLUtils "  . TeXLive::TLUtils->module_revision();
  759     $::mrversion      .= "\nTLPOBJ "   . TeXLive::TLPOBJ->module_revision();
  760     $::mrversion      .= "\nTLPDB "    . TeXLive::TLPDB->module_revision();
  761     $::mrversion      .= "\nTLPaper "  . TeXLive::TLPaper->module_revision();
  762     $::mrversion      .= "\nTLWinGoo " . TeXLive::TLWinGoo->module_revision();
  763     $::mrversion      .= "\n";
  764   }
  765   if ($::machinereadable) {
  766     return $::mrversion;
  767   } else {
  768     return $::version_string;
  769   }
  770 }
  771 
  772 
  773 sub execute_action {
  774   my ($action, @argv) = @_;
  775 
  776   # we have to set @ARGV to the @argv since many of the action_* subs
  777   # use GetOption
  778   @ARGV = @argv;
  779 
  780   # actions which shouldn't have any lasting effects, such as search or
  781   # list, end by calling finish(0), which skips postinstall actions.
  782   if (!defined($action_specification{$action})) {
  783     tlwarn ("$prg: unknown action: $action; try --help if you need it.\n");
  784     return ($F_ERROR);
  785   }
  786 
  787   if (!defined($action_specification{$action}{"function"})) {
  788     tlwarn ("$prg: action $action defined, but no way to execute it.\n");
  789     return $F_ERROR;
  790   }
  791 
  792   my $ret = $F_OK;
  793   my $foo = &{$action_specification{$action}{"function"}}();
  794   if (defined($foo)) {
  795     if ($foo & $F_ERROR) {
  796       # report of bad messages are given at the top level.
  797       return $foo;
  798     }
  799     if ($foo & $F_WARNING) {
  800       tlwarn("$prg: action $action returned an error; continuing.\n");
  801       $ret = $foo;
  802     }
  803   } else {
  804     $ret = $F_OK;
  805     tlwarn("$prg: no value returned from action $action, assuming ok.\n");
  806   }
  807   my $run_post = 1;
  808   if ($ret & $F_NOPOSTACTION) {
  809     # clear the postaction bit
  810     $ret ^= $F_NOPOSTACTION;
  811     $run_post = 0;
  812   }
  813   if (!$action_specification{$action}{"run-post"}) {
  814     $run_post = 0;
  815   }
  816 
  817   return ($ret) if (!$run_post);
  818 
  819   # run external programs.
  820   $ret |= &handle_execute_actions();
  821 
  822   return $ret;
  823 }
  824 
  825 
  826 
  827 # run CMD with notice to the user and if exit status is nonzero, complain.
  828 # return exit status.
  829 # 
  830 sub do_cmd_and_check {
  831   my $cmd = shift;
  832   # we output the pre-running notice on a separate line so that
  833   # tlmgr front ends (MacOSX's TeX Live Utility) can read it
  834   # and show it to the user before the possibly long delay.
  835   info("running $cmd ...\n");
  836   logcommand("running $cmd");
  837   my ($out, $ret);
  838   if ($opts{"dry-run"}) {
  839     $ret = $F_OK;
  840     $out = "";
  841   } elsif (win32() && (! -r "$Master/bin/win32/luatex.dll")) {
  842     # deal with the case where only scheme-infrastructure is installed
  843     # on Windows, thus no luatex.dll is available and the wrapper cannot be started
  844     tlwarn("Cannot run wrapper due to missing luatex.dll\n");
  845     $ret = $F_OK;
  846     $out = "";
  847   } else {
  848     ($out, $ret) = TeXLive::TLUtils::run_cmd("$cmd 2>&1");
  849   }
  850   $out =~ s/\n+$//; # trailing newlines don't seem interesting
  851   my $outmsg = "output:\n$out\n--end of output of $cmd.\n";
  852   if ($ret == $F_OK) {
  853     info("done running $cmd.\n");
  854     logcommand("success, $outmsg");
  855     ddebug("$cmd $outmsg");
  856     return ($F_OK);
  857   } else {
  858     info("\n");
  859     tlwarn("$prg: $cmd failed (status $ret), output:\n$out\n");
  860     logcommand("error, status: $ret, $outmsg");
  861     return ($F_ERROR);
  862   }
  863 }
  864 
  865 # run external programs (mktexlsr, updmap-sys, etc.) as specified by the
  866 # keys in the RET hash.  We return the number of unsuccessful runs, zero
  867 # if all ok.
  868 #
  869 # If the "map" key is specified, the value may be a reference to a list
  870 # of map command strings to pass to updmap, e.g., "enable Map=ascii.map".
  871 #
  872 sub handle_execute_actions {
  873   my $errors = 0;
  874 
  875   my $sysmode = ($opts{"usermode"} ? "" : "-sys");
  876   my $invoke_fmtutil = "fmtutil$sysmode $common_fmtutil_args";
  877 
  878   if ($::files_changed) {
  879     $errors += do_cmd_and_check("mktexlsr");
  880     if (defined($localtlpdb->get_package('context'))
  881         && (-x "$bindir/texlua" || -x "$bindir/texlua.exe")) {
  882       $errors += do_cmd_and_check("mtxrun --generate");
  883     }
  884     $::files_changed = 0;
  885   }
  886 
  887   chomp(my $TEXMFSYSVAR = `kpsewhich -var-value=TEXMFSYSVAR`);
  888   chomp(my $TEXMFSYSCONFIG = `kpsewhich -var-value=TEXMFSYSCONFIG`);
  889   chomp(my $TEXMFLOCAL = `kpsewhich -var-value=TEXMFLOCAL`);
  890   chomp(my $TEXMFDIST = `kpsewhich -var-value=TEXMFDIST`);
  891 
  892   # maps handling
  893   {
  894     my $updmap_run_needed = 0;
  895     for my $m (keys %{$::execute_actions{'enable'}{'maps'}}) {
  896       $updmap_run_needed = 1;
  897     }
  898     for my $m (keys %{$::execute_actions{'disable'}{'maps'}}) {
  899       $updmap_run_needed = 1;
  900     }
  901     my $dest = $opts{"usermode"} ? "$::maintree/web2c/updmap.cfg" 
  902                : "$TEXMFDIST/web2c/updmap.cfg";
  903     if ($updmap_run_needed) {
  904       TeXLive::TLUtils::create_updmap($localtlpdb, $dest);
  905     }
  906     $errors += do_cmd_and_check("updmap$sysmode") if $updmap_run_needed;
  907   }
  908 
  909   # format relevant things
  910   # we first have to check if the config files, that is fmtutil.cnf 
  911   # or one of the language* files have changed, regenerate them
  912   # if necessary, and then run the necessary fmtutil calls.
  913   {
  914     # first check for language* files
  915     my $regenerate_language = 0;
  916     for my $m (keys %{$::execute_actions{'enable'}{'hyphens'}}) {
  917       $regenerate_language = 1;
  918       last;
  919     }
  920     for my $m (keys %{$::execute_actions{'disable'}{'hyphens'}}) {
  921       $regenerate_language = 1;
  922       last;
  923     }
  924     if ($regenerate_language) {
  925       for my $ext ("dat", "def", "dat.lua") {
  926         my $lang = "language.$ext";
  927         info("regenerating $lang\n");
  928         my $arg1 = "$TEXMFSYSVAR/tex/generic/config/language.$ext";
  929         my $arg2 = "$TEXMFLOCAL/tex/generic/config/language-local.$ext";
  930         if ($ext eq "dat") {
  931           TeXLive::TLUtils::create_language_dat($localtlpdb, $arg1, $arg2);
  932         } elsif ($ext eq "def") {
  933           TeXLive::TLUtils::create_language_def($localtlpdb, $arg1, $arg2);
  934         } else {
  935           TeXLive::TLUtils::create_language_lua($localtlpdb, $arg1, $arg2);
  936         }
  937       }
  938     }
  939 
  940     # format-regenerate is used when the paper size changes.  In that
  941     # case, if option("create_formats") is set, we simply want to generate
  942     # all formats
  943     #
  944     my %done_formats;
  945     my %updated_engines;
  946     my %format_to_engine;
  947     my %do_enable;
  948     my $do_full = 0;
  949     for my $m (keys %{$::execute_actions{'enable'}{'formats'}}) {
  950       $do_full = 1;
  951       $do_enable{$m} = 1;
  952       # here we check whether an engine is updated
  953       my %foo = %{$::execute_actions{'enable'}{'formats'}{$m}};
  954       if (!defined($foo{'name'}) || !defined($foo{'engine'})) {
  955         tlwarn("$prg: Very strange error, please report ", %foo);
  956       } else {
  957         $format_to_engine{$m} = $foo{'engine'};
  958         if ($foo{'name'} eq $foo{'engine'}) {
  959           $updated_engines{$m} = 1;
  960         }
  961       }
  962     }
  963     for my $m (keys %{$::execute_actions{'disable'}{'formats'}}) {
  964       $do_full = 1;
  965     }
  966     my $opt_fmt = $localtlpdb->option("create_formats");
  967     if ($do_full) {
  968       info("regenerating fmtutil.cnf in $TEXMFDIST\n");
  969       TeXLive::TLUtils::create_fmtutil($localtlpdb,
  970                                        "$TEXMFDIST/web2c/fmtutil.cnf");
  971     }
  972     if ($opt_fmt && !$::regenerate_all_formats) {
  973       # first regenerate all formats --byengine 
  974       for my $e (keys %updated_engines) {
  975         debug ("updating formats based on $e\n");
  976         $errors += do_cmd_and_check
  977                     ("$invoke_fmtutil --no-error-if-no-format --byengine $e");
  978       }
  979       # now rebuild all other formats
  980       for my $f (keys %do_enable) {
  981         next if defined($updated_engines{$format_to_engine{$f}});
  982         # ignore disabled formats
  983         next if !$::execute_actions{'enable'}{'formats'}{$f}{'mode'};
  984         debug ("(re)creating format dump $f\n");
  985         $errors += do_cmd_and_check ("$invoke_fmtutil --byfmt $f");
  986         $done_formats{$f} = 1;
  987       }
  988     }
  989 
  990     # now go back to the hyphenation patterns and regenerate formats
  991     # based on the various language files
  992     # this of course will in some cases duplicate fmtutil calls,
  993     # but it is much easier than actually checking which formats
  994     # don't need to be updated
  995 
  996     if ($regenerate_language) {
  997       for my $ext ("dat", "def", "dat.lua") {
  998         my $lang = "language.$ext";
  999         if (! TeXLive::TLUtils::win32()) {
 1000           # Use full path for external command, except on Windows.
 1001           $lang = "$TEXMFSYSVAR/tex/generic/config/$lang";
 1002         }
 1003         if ($localtlpdb->option("create_formats")
 1004             && !$::regenerate_all_formats) {
 1005           $errors += do_cmd_and_check ("$invoke_fmtutil --byhyphen \"$lang\"");
 1006         }
 1007       }
 1008     }
 1009   }
 1010 
 1011   #
 1012   if ($::regenerate_all_formats) {
 1013     info("Regenerating all formats, this may take some time ...");
 1014     $errors += do_cmd_and_check("$invoke_fmtutil --all");
 1015     info("done\n");
 1016     $::regenerate_all_formats = 0;
 1017   }
 1018 
 1019   # undefine the global var, otherwise in GUI mode the actions
 1020   # are accumulating
 1021   undef %::execute_actions;
 1022 
 1023   if ($errors > 0) {
 1024     # should we return warning here?
 1025     return $F_ERROR;
 1026   } else {
 1027     return $F_OK;
 1028   }
 1029 }
 1030 
 1031 
 1032 #  GET_MIRROR
 1033 #
 1034 # just return a mirror
 1035 sub action_get_mirror {
 1036   my $loc = give_ctan_mirror(); 
 1037   print "$loc\n";
 1038   return ($F_OK | $F_NOPOSTACTION);
 1039 }
 1040 
 1041 #
 1042 # includes a .tlpobj in the db, also searchers for sub-tlpobj
 1043 # for doc and source files
 1044 #
 1045 
 1046 #  _INCLUDE_TLPOBJ
 1047 #
 1048 # includes a .tlpobj in the db, also searchers for sub-tlpobj
 1049 # for doc and source files
 1050 #
 1051 sub action_include_tlpobj {
 1052   # this is an internal function that should not be used outside
 1053   init_local_db();
 1054   for my $f (@ARGV) {
 1055     my $tlpobj = TeXLive::TLPOBJ->new;
 1056     $tlpobj->from_file($f);
 1057     # we now have to check whether that is a .doc or .src package, so shipping
 1058     # src or doc files from a different package.
 1059     # We should have that package already installed ...
 1060     my $pkg = $tlpobj->name;
 1061     if ($pkg =~ m/^(.*)\.(source|doc)$/) {
 1062       # got a .src or .doc package
 1063       my $type = $2;
 1064       my $mothership = $1;
 1065       my $mothertlp = $localtlpdb->get_package($mothership);
 1066       if (!defined($mothertlp)) {
 1067         tlwarn("$prg: We are trying to add ${type} files to a nonexistent package $mothership!\n");
 1068         tlwarn("$prg: Trying to continue!\n");
 1069         # the best we can do is rename that package to $mothername and add it!
 1070         $tlpobj->name($mothership);
 1071         # add the src/docfiles tlpobj under the mothership name
 1072         $localtlpdb->add_tlpobj($tlpobj);
 1073       } else {
 1074         if ($type eq "source") {
 1075           $mothertlp->srcfiles($tlpobj->srcfiles);
 1076           $mothertlp->srcsize($tlpobj->srcsize);
 1077         } else {
 1078           # must be "doc"
 1079           $mothertlp->docfiles($tlpobj->docfiles);
 1080           $mothertlp->docsize($tlpobj->docsize);
 1081         }
 1082         # that make sure that the original entry is overwritten
 1083         $localtlpdb->add_tlpobj($mothertlp);
 1084       }
 1085     } else {
 1086       # completely normal package, just add it
 1087       $localtlpdb->add_tlpobj($tlpobj);
 1088     }
 1089     $localtlpdb->save;
 1090   }
 1091   # no error checking here for now
 1092   return ($F_OK);
 1093 }
 1094 
 1095 
 1096 #  REMOVE
 1097 #
 1098 # tlmgr remove foo bar baz
 1099 #   will remove the packages foo bar baz itself
 1100 #   and will remove all .ARCH dependencies, too
 1101 #   and if some of them are collections it will also remove the
 1102 #   depending packages which are NOT Collections|Schemes.
 1103 #   if some of them are referenced somewhere they will not be removed
 1104 #   unless --force given
 1105 #
 1106 # tlmgr remove --no-depends foo bar baz
 1107 #   will remove the packages foo bar baz itself without any dependencies
 1108 #   but it will still remove all .ARCH dependency
 1109 #   if some of them are referenced somewhere they will not be removed
 1110 #   unless --force given
 1111 #
 1112 # tlmgr remove --no-depends-at-all foo bar baz
 1113 #   will absolutely only install foo bar baz not even taking .ARCH into
 1114 #   account
 1115 #
 1116 
 1117 sub backup_and_remove_package {
 1118   my ($pkg, $autobackup) = @_;
 1119   my $tlp = $localtlpdb->get_package($pkg);
 1120   if (!defined($tlp)) {
 1121     info("$pkg: package not present, cannot remove\n");
 1122     return($F_WARNING);
 1123   }
 1124   if ($opts{"backup"}) {
 1125     $tlp->make_container($::progs{'compressor'}, $localtlpdb->root,
 1126                          destdir => $opts{"backupdir"}, 
 1127                          relative => $tlp->relocated,
 1128                          user => 1);
 1129     if ($autobackup) {
 1130       # in case we do auto backups we remove older backups
 1131       clear_old_backups($pkg, $opts{"backupdir"}, $autobackup);
 1132     }
 1133   }
 1134   return($localtlpdb->remove_package($pkg));
 1135 }
 1136 
 1137 sub action_remove {
 1138   # if --all is given, pass on to uninstall_texlive
 1139   if ($opts{'all'}) {
 1140     if (@ARGV) {
 1141       tlwarn("$prg: No additional arguments allowed with --all: @ARGV\n");
 1142       return($F_ERROR);
 1143     }
 1144     exit(uninstall_texlive());
 1145   }
 1146   # we do the following:
 1147   # - (not implemented) order collections such that those depending on
 1148   #   other collections are first removed, and then those which only
 1149   #   depend on packages. Otherwise
 1150   #     remove collection-latex collection-latexrecommended
 1151   #   will not succeed
 1152   # - first loop over all cmd line args and consider only the collections
 1153   # - for each to be removed collection:
 1154   #   . check that no other collections/scheme asks for that collection
 1155   #   . remove the collection
 1156   #   . remove all dependencies
 1157   # - for each normal package not already removed (via the above)
 1158   #   . check that no collection/scheme still depends on this package
 1159   #   . remove the package
 1160   #
 1161   $opts{"no-depends"} = 1 if $opts{"no-depends-at-all"};
 1162   my %already_removed;
 1163   my @more_removal;
 1164   init_local_db();
 1165   return($F_ERROR) if !check_on_writable();
 1166   info("$prg remove: dry run, no changes will be made\n") if $opts{"dry-run"};
 1167 
 1168   my ($ret, $autobackup) = setup_backup_directory();
 1169   return ($ret) if ($ret != $F_OK);
 1170 
 1171   my @packs = @ARGV;
 1172   #
 1173   # we have to be careful not to remove too many packages. The idea is
 1174   # as follows:
 1175   # - let A be the set of all packages to be removed from the cmd line
 1176   # - let A* be the set of A with all dependencies expanded
 1177   # - let B be the set of all packages
 1178   # - let C = B \ A*, ie the set of all packages without those packages
 1179   #   in the set of A*
 1180   # - let C* be the set of C with all dependencies expanded
 1181   # - let D = A* \ C*, ie the set of all packages to be removed (A*)
 1182   #   without all the package that are still needed (C*)
 1183   # - remove all package in D
 1184   # - for any package in A (not in A*, in A, ie on the cmd line) that is
 1185   #   also in C* (so a package that was asked for to be removed on the
 1186   #   cmd line, but it isn't because someone else asks for it), warn the
 1187   #   user that it is still needed
 1188   #
 1189   # remove all .ARCH dependencies, too, unless $opts{"no-depends-at-all"}
 1190   @packs = $localtlpdb->expand_dependencies("-only-arch", $localtlpdb, @packs)
 1191     unless $opts{"no-depends-at-all"}; 
 1192   # remove deps unless $opts{"no-depends"}
 1193   @packs = $localtlpdb->expand_dependencies("-no-collections", $localtlpdb, @packs) unless $opts{"no-depends"};
 1194   my %allpacks;
 1195   for my $p ($localtlpdb->list_packages) { $allpacks{$p} = 1; }
 1196   for my $p (@packs) { delete($allpacks{$p}); }
 1197   my @neededpacks = $localtlpdb->expand_dependencies($localtlpdb, keys %allpacks);
 1198   my %packs;
 1199   my %origpacks;
 1200   my @origpacks = $localtlpdb->expand_dependencies("-only-arch", $localtlpdb, @ARGV) unless $opts{"no-depends-at-all"};
 1201   for my $p (@origpacks) { $origpacks{$p} = 1; }
 1202   for my $p (@packs) { $packs{$p} = 1; }
 1203   for my $p (@neededpacks) {
 1204     if (defined($origpacks{$p})) {
 1205       # that package was asked for to be removed on the cmd line
 1206       my @needed = $localtlpdb->needed_by($p);
 1207       if ($opts{"force"}) {
 1208         info("$prg: $p is needed by " . join(" ", @needed) . "\n");
 1209         info("$prg: removing it anyway, due to --force\n");
 1210       } else {
 1211         delete($packs{$p});
 1212         tlwarn("$prg: not removing $p, needed by " .
 1213           join(" ", @needed) . "\n");
 1214         $ret |= $F_WARNING;
 1215       }
 1216     } else {
 1217       delete($packs{$p});
 1218     }
 1219   }
 1220   @packs = keys %packs;
 1221 
 1222   my %sizes = %{$localtlpdb->sizes_of_packages(
 1223     $localtlpdb->option("install_srcfiles"),
 1224     $localtlpdb->option("install_docfiles"), undef, @packs)};
 1225   defined($sizes{'__TOTAL__'}) || ($sizes{'__TOTAL__'} = 0);
 1226   my $totalsize = $sizes{'__TOTAL__'};
 1227   my $totalnr = $#packs;
 1228   my $currnr = 1;
 1229   my $starttime = time();
 1230   my $donesize = 0;
 1231   
 1232   print "total-bytes\t$sizes{'__TOTAL__'}\n" if $::machinereadable;
 1233   print "end-of-header\n" if $::machinereadable;
 1234 
 1235   foreach my $pkg (sort @packs) {
 1236     my $tlp = $localtlpdb->get_package($pkg);
 1237     next if defined($already_removed{$pkg});
 1238     if (!defined($tlp)) {
 1239       info("$pkg: package not present, cannot remove\n");
 1240       $ret |= $F_WARNING;
 1241     } else {
 1242       my ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize,
 1243                                                               $donesize, $starttime);
 1244 
 1245       # in the first round we only remove collections, nothing else
 1246       # but removing collections will remove all dependencies, too
 1247       # save the information of which packages have already been removed
 1248       # into %already_removed.
 1249       if ($tlp->category eq "Collection") {
 1250         my $foo = 0;
 1251         if ($::machinereadable) {
 1252           machine_line($pkg, "d", $tlp->revision, "-", $sizes{$pkg}, $estrem, $esttot);
 1253         } else {
 1254           # info ("$prg: removing $pkg\n");
 1255           info("[$currnr/$totalnr, $estrem/$esttot] remove: $pkg\n");
 1256         }
 1257         if (!$opts{"dry-run"}) {
 1258           $foo = backup_and_remove_package($pkg, $autobackup);
 1259           logpackage("remove: $pkg");
 1260         }
 1261         $currnr++;
 1262         $donesize += $sizes{$pkg};
 1263         if ($foo) {
 1264           # removal was successful, so the return is at least 0x0001 mktexlsr
 1265           # remove dependencies, too
 1266           $already_removed{$pkg} = 1;
 1267         }
 1268       } else {
 1269         # save all the other packages into the @more_removal list to
 1270         # be removed at the second state. Note that if a package has
 1271         # already been removed due to a removal of a collection
 1272         # it will be marked as such in %already_removed and not tried again
 1273         push (@more_removal, $pkg);
 1274       }
 1275     }
 1276   }
 1277   foreach my $pkg (sort @more_removal) {
 1278     my $tlp = $localtlpdb->get_package($pkg);
 1279     if (!defined($already_removed{$pkg})) {
 1280       my ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize,
 1281                                                               $donesize, $starttime);
 1282       # info ("$prg: removing package $pkg\n");
 1283       if ($::machinereadable) {
 1284         machine_line($pkg, "d", $tlp->revision, "-", $sizes{$pkg}, $estrem, $esttot);
 1285       } else {
 1286         # info ("$prg: removing $pkg\n");
 1287         info("[$currnr/$totalnr, $estrem/$esttot] remove: $pkg\n");
 1288       }
 1289       $currnr++;
 1290       $donesize += $sizes{$pkg};
 1291       if (!$opts{"dry-run"}) {
 1292         if (backup_and_remove_package($pkg, $autobackup)) {
 1293           # removal was successful
 1294           logpackage("remove: $pkg");
 1295           $already_removed{$pkg} = 1;
 1296         }
 1297       }
 1298     }
 1299   }
 1300   print "end-of-updates\n" if $::machinereadable;
 1301   if ($opts{"dry-run"}) {
 1302     # stop here, don't do any postinstall actions
 1303     return ($ret | $F_NOPOSTACTION);
 1304   } else {
 1305     $localtlpdb->save;
 1306     my @foo = sort keys %already_removed;
 1307     if (@foo) {
 1308       info("$prg: ultimately removed these packages: @foo\n")
 1309         if (!$::machinereadable);
 1310     } else {
 1311       info("$prg: no packages removed.\n")
 1312         if (!$::machinereadable);
 1313     }
 1314   }
 1315   return ($ret);
 1316 }
 1317 
 1318 
 1319 #  PAPER
 1320 # 
 1321 # ARGV can look like:
 1322 #   paper a4
 1323 #   paper letter
 1324 #   [xdvi|...|context] paper [help|papersize|--list]
 1325 #
 1326 sub action_paper {
 1327   init_local_db();
 1328   my $texmfconfig;
 1329   if ($opts{"usermode"}) {
 1330     tlwarn("$prg: action `paper' not supported in usermode\n");
 1331     return ($F_ERROR);
 1332   }
 1333   chomp($texmfconfig = `kpsewhich -var-value=TEXMFSYSCONFIG`);
 1334   $ENV{"TEXMFCONFIG"} = $texmfconfig;
 1335 
 1336   my $action = shift @ARGV;
 1337   if (!$action) {
 1338     # can only happen in shell mode, because otherwise we push paper onto the stack before
 1339     # going into the action_paper
 1340     $action = "paper";
 1341   }
 1342 
 1343   if ($action =~ m/^paper$/i) {  # generic paper
 1344     my $newpaper = shift @ARGV;
 1345     if ($opts{"list"}) {  # tlmgr paper --list => complain.
 1346       tlwarn("$prg: ignoring paper setting to $newpaper with --list\n")
 1347         if $newpaper;  # complain if they tried to set, too.
 1348       tlwarn("$prg: please specify a program before paper --list, ",
 1349              "as in: tlmgr pdftex paper --list\n");
 1350       return($F_ERROR)
 1351 
 1352     } elsif (!defined($newpaper)) {  # tlmgr paper => show all current sizes.
 1353       my $ret = $F_OK;
 1354       if ($opts{'json'}) {
 1355         my @foo;
 1356         for my $prog (keys %TeXLive::TLPaper::paper) {
 1357           my $pkg = $TeXLive::TLPaper::paper{$prog}{'pkg'};
 1358           if ($localtlpdb->get_package($pkg)) {
 1359             my $val = TeXLive::TLPaper::do_paper($prog,$texmfconfig,"--json");
 1360             push @foo, $val;
 1361           }
 1362         }
 1363         my $json = TeXLive::TLUtils::encode_json(\@foo);
 1364         print "$json\n";
 1365         return $ret;
 1366       }
 1367       for my $prog (sort keys %TeXLive::TLPaper::paper) {
 1368         my $pkg = $TeXLive::TLPaper::paper{$prog}{'pkg'};
 1369         if ($localtlpdb->get_package($pkg)) {
 1370           $ret |= TeXLive::TLPaper::do_paper($prog,$texmfconfig,undef);
 1371         }
 1372       }
 1373       return($ret);
 1374       # return TeXLive::TLPaper::paper_all($texmfconfig,undef);
 1375 
 1376     } elsif ($newpaper !~ /^(a4|letter)$/) {  # tlmgr paper junk => complain.
 1377       $newpaper = "the empty string" if !defined($newpaper);
 1378       tlwarn("$prg: expected `a4' or `letter' after paper, not $newpaper\n");
 1379       return($F_ERROR);
 1380 
 1381     } else { # tlmgr paper {a4|letter} => do it.
 1382       return ($F_ERROR) if !check_on_writable();
 1383       if ($opts{'json'}) {
 1384         tlwarn("$prg: option --json not supported with other arguments\n");
 1385         return ($F_ERROR);
 1386       }
 1387       my $ret = $F_OK;
 1388       for my $prog (sort keys %TeXLive::TLPaper::paper) {
 1389         my $pkg = $TeXLive::TLPaper::paper{$prog}{'pkg'};
 1390         if ($localtlpdb->get_package($pkg)) {
 1391           $ret |= TeXLive::TLPaper::do_paper($prog,$texmfconfig,$newpaper);
 1392         }
 1393       }
 1394       return($ret);
 1395       # return (TeXLive::TLPaper::paper_all($texmfconfig,$newpaper));
 1396     }
 1397 
 1398   } else {  # program-specific paper
 1399     if ($opts{'json'}) {
 1400       tlwarn("$prg: option --json not supported with other arguments\n");
 1401       return ($F_ERROR);
 1402     }
 1403     my $prog = $action;     # first argument is the program to change
 1404     my $pkg = $TeXLive::TLPaper::paper{$prog}{'pkg'};
 1405     if (!$pkg) {
 1406       tlwarn("Unknown paper configuration program $prog!\n");
 1407       return ($F_ERROR);
 1408     }
 1409     if (!$localtlpdb->get_package($pkg)) {
 1410       tlwarn("$prg: package $prog is not installed - cannot adjust paper size!\n");
 1411       return ($F_ERROR);
 1412     }
 1413     my $arg = shift @ARGV;  # get "paper" argument
 1414     if (!defined($arg) || $arg ne "paper") {
 1415       $arg = "the empty string." if ! $arg;
 1416       tlwarn("$prg: expected `paper' after $prog, not $arg\n");
 1417       return ($F_ERROR);
 1418     }
 1419     # the do_paper progs check for the argument --list, so if given
 1420     # restore it to the cmd line.
 1421     if (@ARGV) {
 1422       return ($F_ERROR) if !check_on_writable();
 1423     }
 1424     unshift(@ARGV, "--list") if $opts{"list"};
 1425     return(TeXLive::TLPaper::do_paper($prog,$texmfconfig,@ARGV));
 1426   }
 1427   # we should not come here anyway
 1428   return($F_OK);
 1429 }
 1430 
 1431 
 1432 #  PATH
 1433 #
 1434 sub action_path {
 1435   if ($opts{"usermode"}) {
 1436     tlwarn("$prg: action `path' not supported in usermode!\n");
 1437     exit 1;
 1438   }
 1439   my $what = shift @ARGV;
 1440   if (!defined($what) || ($what !~ m/^(add|remove)$/i)) {
 1441     $what = "" if ! $what;
 1442     tlwarn("$prg: action path requires add or remove, not: $what\n");
 1443     return ($F_ERROR);
 1444   }
 1445   init_local_db();
 1446   my $winadminmode = 0;
 1447   if (win32()) {
 1448     #
 1449     # for w32 we do system wide vs user setting detection as follows:
 1450     # - if --w32mode is NOT given,
 1451     #   - if admin
 1452     #     --> honor opt_w32_multi_user setting in tlpdb
 1453     #   - if not admin
 1454     #     - if opt_w32_multi_user == NO
 1455     #       --> do user path adjustment
 1456     #     - if opt_w32_multi_user == YES
 1457     #       --> do nothing, warn that the setting is on, suggest --w32mode user
 1458     # - if --w32mode admin
 1459     #   - if admin
 1460     #     --> ignore opt_w32_multi_user and do system path adjustment
 1461     #   - if non-admin
 1462     #     --> do nothing but warn that user does not have privileges
 1463     # - if --w32mode user
 1464     #   - if admin
 1465     #     --> ignore opt_w32_multi_user and do user path adjustment
 1466     #   - if non-admin
 1467     #     --> ignore opt_w32_multi_user and do user path adjustment
 1468     if (!$opts{"w32mode"}) {
 1469       $winadminmode = $localtlpdb->option("w32_multi_user");
 1470       if (!TeXLive::TLWinGoo::admin()) {
 1471         if ($winadminmode) {
 1472           tlwarn("The TLPDB specifies system wide path adjustments\nbut you don't have admin privileges.\nFor user path adjustment please use\n\t--w32mode user\n");
 1473           # and do nothing
 1474           return ($F_ERROR);
 1475         }
 1476       }
 1477     } else {
 1478       # we are in the block where a --w32mode argument is given
 1479       # we reverse the tests:
 1480       if (TeXLive::TLWinGoo::admin()) {
 1481         # in admin mode we simply use what is given on the cmd line
 1482         if ($opts{"w32mode"} eq "user") {
 1483           $winadminmode = 0;
 1484         } elsif ($opts{"w32mode"} eq "admin") {
 1485           $winadminmode = 1;
 1486         } else {
 1487           tlwarn("$prg: unknown --w32admin mode: $opts{w32mode}, should be 'admin' or 'user'\n");
 1488           return ($F_ERROR);
 1489         }
 1490       } else {
 1491         # we are non-admin
 1492         if ($opts{"w32mode"} eq "user") {
 1493           $winadminmode = 0;
 1494         } elsif ($opts{"w32mode"} eq "admin") {
 1495           tlwarn("$prg: You don't have the privileges to work in --w32mode admin\n");
 1496           return ($F_ERROR);
 1497         } else {
 1498           tlwarn("$prg: unknown --w32admin mode: $opts{w32mode}, should be 'admin' or 'user'\n");
 1499           return ($F_ERROR);
 1500         }
 1501       }
 1502     }
 1503   }
 1504   my $ret = $F_OK;
 1505   if ($what =~ m/^add$/i) {
 1506     if (win32()) {
 1507       $ret |= TeXLive::TLUtils::w32_add_to_path(
 1508         $localtlpdb->root . "/bin/win32",
 1509         $winadminmode);
 1510       $ret |= TeXLive::TLWinGoo::broadcast_env();
 1511     } else {
 1512       $ret |= TeXLive::TLUtils::add_symlinks($localtlpdb->root,
 1513         $localtlpdb->platform(),
 1514         $localtlpdb->option("sys_bin"),
 1515         $localtlpdb->option("sys_man"),
 1516         $localtlpdb->option("sys_info"));
 1517     }
 1518   } elsif ($what =~ m/^remove$/i) {
 1519     if (win32()) {
 1520       $ret |= TeXLive::TLUtils::w32_remove_from_path(
 1521         $localtlpdb->root . "/bin/win32",
 1522         $winadminmode);
 1523       $ret |= TeXLive::TLWinGoo::broadcast_env();
 1524     } else {
 1525       # remove symlinks
 1526       $ret |= TeXLive::TLUtils::remove_symlinks($localtlpdb->root,
 1527         $localtlpdb->platform(),
 1528         $localtlpdb->option("sys_bin"),
 1529         $localtlpdb->option("sys_man"),
 1530         $localtlpdb->option("sys_info"));
 1531     }
 1532   } else {
 1533     tlwarn("\n$prg: Should not happen, action_path what=$what\n");
 1534     return ($F_ERROR);
 1535   }
 1536   # we should not need to run any post actions here, since
 1537   # that changes only integrations, but no rebuild of formats etc etc
 1538   # is needed
 1539   return ($ret | $F_NOPOSTACTION);
 1540 }
 1541 
 1542 #  DUMP-TLPDB
 1543 #
 1544 sub action_dumptlpdb {
 1545   init_local_db();
 1546   
 1547   # we are basically doing machine-readable output.
 1548   my $savemr = $::machinereadable;
 1549   $::machinereadable = 1;
 1550   
 1551   if ($opts{"local"} && !$opts{"remote"}) {
 1552     if ($opts{"json"}) {
 1553       print $localtlpdb->as_json;
 1554     } else {
 1555       # for consistency we write out the location of the installation,
 1556       # too, in the same format as when dumping the remote tlpdb
 1557       print "location-url\t", $localtlpdb->root, "\n";
 1558       $localtlpdb->writeout;
 1559     }
 1560 
 1561   } elsif ($opts{"remote"} && !$opts{"local"}) {
 1562     init_tlmedia_or_die(1);
 1563     if ($opts{"json"}) {
 1564       print $remotetlpdb->as_json;
 1565     } else {
 1566       $remotetlpdb->writeout;
 1567     }
 1568 
 1569   } else {
 1570     tlwarn("$prg dump-tlpdb: need exactly one of --local and --remote.\n");
 1571     return ($F_ERROR);
 1572   }
 1573   
 1574   $::machinereadable = $savemr;
 1575   return ($F_OK | $F_NOPOSTACTION);
 1576 }
 1577     
 1578 #  INFO
 1579 #
 1580 sub action_info {
 1581   if ($opts{'only-installed'} && $opts{'only-remote'}) {
 1582     tlwarn("Are you joking? --only-installed and --only-remote cannot both be specified!\n");
 1583     return($F_ERROR);
 1584   }
 1585   init_local_db();
 1586   my ($what,@todo) = @ARGV;
 1587   my $ret = $F_OK | $F_NOPOSTACTION;
 1588   my @datafields;
 1589   my $fmt = "list";
 1590   if ($opts{'data'} && $opts{'json'}) {
 1591     tlwarn("Preferring json output over data output!\n");
 1592     delete($opts{'data'});
 1593   }
 1594   if ($opts{'json'}) {
 1595     $fmt = 'json';
 1596     # the 1 is the silent mode!
 1597     init_tlmedia_or_die(1);
 1598   } elsif ($opts{'data'}) {
 1599     # output format is changed to csv with " as quotes
 1600     # we need to determine the fields
 1601     @datafields = split(',', $opts{'data'});
 1602     # check for correctness of data fields and whether remote is necessary
 1603     my $load_remote = 0;
 1604     for my $d (@datafields) {
 1605       $load_remote = 1 if ($d eq "remoterev");
 1606       if ($d !~ m/^(name|category|localrev|remoterev|shortdesc|longdesc|size|installed|relocatable|depends|cat-version|cat-date|cat-license|cat-contact-.*)$/) {
 1607         tlwarn("unknown data field: $d\n");
 1608         return($F_ERROR);
 1609       }
 1610     }
 1611     $fmt = "csv";
 1612     if ($load_remote) {
 1613       if ($opts{"only-installed"}) {
 1614         tlwarn("requesting only-installed with data field remoterev, loading remote anyway!\n");
 1615         $opts{"only-installed"} = 0;
 1616       }
 1617       # loading of tlpdb is done below
 1618     }
 1619   } elsif (!$what || $what =~ m/^(collections|schemes)$/i) {
 1620     $fmt = "list";
 1621   } else {
 1622     $fmt = "detail";
 1623   }
 1624   my $tlm;
 1625   if ($opts{"only-installed"}) {
 1626     $tlm = $localtlpdb;
 1627   } else {
 1628     # silent mode
 1629     init_tlmedia_or_die(1);
 1630     $tlm = $remotetlpdb;
 1631   }
 1632 
 1633   #
 1634   # tlmgr info
 1635   # tlmgr info collection
 1636   # tlmgr info scheme
 1637   # these commands just list the packages/collections/schemes installed with 
 1638   # a short list
 1639   my @whattolist;
 1640   $what = ($what || "-all");
 1641   if ($what =~ m/^collections$/i) {
 1642     @whattolist = $tlm->collections;
 1643   } elsif ($what =~ m/^schemes$/i) {
 1644     @whattolist = $tlm->schemes;
 1645   } elsif ($what =~ m/^-all$/i) {
 1646     if ($tlm->is_virtual) {
 1647       @whattolist = $tlm->list_packages("-all");
 1648     } else {
 1649       @whattolist = $tlm->list_packages;
 1650     }
 1651     if (!$opts{'only-remote'}) {
 1652       # add also the local packages
 1653       TeXLive::TLUtils::push_uniq(\@whattolist, $localtlpdb->list_packages);
 1654     }
 1655   } else {
 1656     @whattolist = ($what, @todo);
 1657   }
 1658   my @adds;
 1659   if ($opts{'data'}) {
 1660     @adds = @datafields;
 1661   }
 1662   # TIMING OF JSON IMPLEMENTATIONS
 1663   my ($startsec, $startmsec);
 1664   if ($opts{'debug-json-timing'}) {
 1665     require Time::HiRes;
 1666     ($startsec, $startmsec) = Time::HiRes::gettimeofday();
 1667   }
 1668   print "[" if ($fmt eq "json");
 1669   my $first = 1;
 1670   foreach my $ppp (@whattolist) {
 1671     next if ($ppp =~ m/^00texlive\./);
 1672     print "," if ($fmt eq "json" && !$first);
 1673     $first = 0;
 1674     $ret |= show_one_package($ppp, $fmt, @adds);
 1675   }
 1676   print "]\n" if ($fmt eq "json");
 1677   if ($opts{'debug-json-timing'}) {
 1678     my ($endsec, $endmsec) = Time::HiRes::gettimeofday();
 1679     if ($endmsec < $startmsec) {
 1680       $endsec -= 1;
 1681       $endmsec += 1000000;
 1682     }
 1683     print STDERR "JSON (", $TeXLive::TLUtils::jsonmode, ") generation took ", $endsec - $startsec, ".", substr($endmsec - $startmsec,0,2), " sec\n";
 1684   }
 1685   return ($ret);
 1686 }
 1687 
 1688 
 1689 #  SEARCH
 1690 #
 1691 sub action_search {
 1692   my ($r) = @ARGV;
 1693   my $tlpdb;
 1694   # check the arguments
 1695   my $search_type_nr = 0;
 1696   $search_type_nr++ if $opts{"file"};
 1697   $search_type_nr++ if $opts{"all"};
 1698   if ($search_type_nr > 1) {
 1699     tlwarn("$prg: please specify only one thing to search for\n");
 1700     return ($F_ERROR);
 1701   }
 1702   #
 1703   if (!defined($r) || !$r) {
 1704     tlwarn("$prg: nothing to search for.\n");
 1705     return ($F_ERROR);
 1706   }
 1707 
 1708   init_local_db();
 1709   if ($opts{"global"}) {
 1710     init_tlmedia_or_die();
 1711     $tlpdb = $remotetlpdb;
 1712   } else {
 1713     $tlpdb = $localtlpdb;
 1714   }
 1715 
 1716   my ($foundfile, $founddesc) = search_tlpdb($tlpdb, $r, 
 1717     $opts{'file'} || $opts{'all'}, 
 1718     (!$opts{'file'} || $opts{'all'}), 
 1719     $opts{'word'});
 1720  
 1721   print $founddesc;
 1722   print $foundfile;
 1723 
 1724   return ($F_OK | $F_NOPOSTACTION);
 1725 }
 1726 
 1727 sub search_tlpdb {
 1728   my ($tlpdb, $what, $dofile, $dodesc, $inword) = @_;
 1729   my $retfile = '';
 1730   my $retdesc = '';
 1731   foreach my $pkg ($tlpdb->list_packages) {
 1732     my $tlp = $tlpdb->get_package($pkg);
 1733     
 1734     # --file or --all -> search (full) file names
 1735     if ($dofile) {
 1736       my @ret = search_pkg_files($tlp, $what);
 1737       if (@ret) {
 1738         $retfile .= "$pkg:\n";
 1739         foreach (@ret) {
 1740           $retfile .= "\t$_\n";
 1741         }
 1742       }
 1743     }
 1744     #
 1745     # no options or --all -> search package names/descriptions
 1746     if ($dodesc) {
 1747       next if ($pkg =~ m/\./);
 1748       my $matched = search_pkg_desc($tlp, $what, $inword);
 1749       $retdesc .= "$matched\n" if ($matched);
 1750     }
 1751   }
 1752   return($retfile, $retdesc);
 1753 }
 1754 
 1755 sub search_pkg_desc {
 1756   my ($tlp, $what, $inword) = @_;
 1757   my $pkg = $tlp->name;
 1758   my $t = "$pkg\n";
 1759   $t = $t . $tlp->shortdesc . "\n" if (defined($tlp->shortdesc));
 1760   $t = $t . $tlp->longdesc . "\n" if (defined($tlp->longdesc));
 1761   $t = $t . $tlp->cataloguedata->{'topics'} . "\n" if (defined($tlp->cataloguedata->{'topics'}));
 1762   my $pat = $what;
 1763   $pat = '\W' . $what . '\W' if ($inword);
 1764   my $matched = "";
 1765   if ($t =~ m/$pat/i) {
 1766     my $shortdesc = $tlp->shortdesc || "";
 1767     $matched .= "$pkg - $shortdesc";
 1768   }
 1769   return $matched;
 1770 }
 1771 
 1772 sub search_pkg_files {
 1773   my ($tlp, $what) = @_;
 1774   my @files = $tlp->all_files;
 1775   if ($tlp->relocated) {
 1776     for (@files) { s:^$RelocPrefix/:$RelocTree/:; }
 1777   }
 1778   my @ret = grep(m;$what;, @files);
 1779   return @ret;
 1780 }
 1781 
 1782 #  RESTORE
 1783 #
 1784 # read the directory and check what files/package/rev are available
 1785 # for restore
 1786 sub get_available_backups {
 1787   my $bd = shift;
 1788   my $do_stat = shift;
 1789   # initialize the hash(packages) of hash(revisions)
 1790   my %backups;
 1791   opendir (DIR, $bd) || die "opendir($bd) failed: $!";
 1792   my @dirents = readdir (DIR);
 1793   closedir (DIR) || warn "closedir($bd) failed: $!";
 1794   #
 1795   # see below for explanation, this has effects only on W32
 1796   my $oldwsloppy = ${^WIN32_SLOPPY_STAT};
 1797   ${^WIN32_SLOPPY_STAT} = 1;
 1798   #
 1799   my $pkg;
 1800   my $rev;
 1801   my $ext;
 1802   for my $dirent (@dirents) {
 1803     $pkg = "";
 1804     $rev = "";
 1805     $ext = "";
 1806     next if (-d $dirent);
 1807     if ($dirent =~ m/^(.*)\.r([0-9]+)\.tar\.$CompressorExtRegexp$/) {
 1808       $pkg = $1;
 1809       $rev = $2;
 1810       $ext = $3;
 1811     } else {
 1812       next;
 1813     }
 1814     if (!$do_stat) {
 1815       $backups{$pkg}->{$rev} = 1;
 1816       next;
 1817     }
 1818     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 1819       $atime,$mtime,$ctime,$blksize,$blocks) = stat("$bd/$dirent");
 1820     # times: as we want to be portable we try the following times:
 1821     # - first choice is ctime which hopefully works nicely
 1822     # - on UFS (OSX) ctime is not supported, so use mtime
 1823     # furthermore, if we are on W32 we want to be fast and make only
 1824     # a sloppy stat
 1825     # for more on that please see man perlport
 1826     my $usedt = $ctime;
 1827     if (!$usedt) {
 1828       # can happen on 
 1829       $usedt = $mtime;
 1830     }
 1831     if (!$usedt) {
 1832       # stat failed, set key to -1 as a sign that there is a backup
 1833       # but we cannot stat it
 1834       $backups{$pkg}->{$rev} = -1;
 1835     } else {
 1836       $backups{$pkg}->{$rev} = $usedt;
 1837     }
 1838   }
 1839   # reset the original value of the w32 sloppy mode for stating files
 1840   ${^WIN32_SLOPPY_STAT} = $oldwsloppy;
 1841   return %backups;
 1842 }
 1843 
 1844 sub restore_one_package {
 1845   my ($pkg, $rev, $bd) = @_;
 1846   # first remove the package, then reinstall it
 1847   # this way we get rid of useless files
 1848   my $restore_file;
 1849   for my $ext (map {$Compressors{$_}{'extension'}} 
 1850                  sort {$Compressors{$a}{'priority'} <=> $Compressors{$a}{'priority'}} 
 1851                    keys %Compressors) {
 1852     if (-r "$bd/${pkg}.r${rev}.tar.$ext") {
 1853       $restore_file = "$bd/${pkg}.r${rev}.tar.$ext";
 1854       last;
 1855     }
 1856   }
 1857   if (!$restore_file) {
 1858     tlwarn("$prg: cannot find restore file $bd/${pkg}.r${rev}.tar.*, no action taken\n");
 1859     return ($F_ERROR);
 1860   }
 1861   $localtlpdb->remove_package($pkg);
 1862   # the -1 force the TLUtils::unpack to NOT warn about missing checksum/sizes
 1863   TeXLive::TLPDB->_install_data($restore_file , 0, [], $localtlpdb, "-1", "-1");
 1864   logpackage("restore: $pkg ($rev)");
 1865   # now we have to read the .tlpobj file and add it to the DB
 1866   my $tlpobj = TeXLive::TLPOBJ->new;
 1867   $tlpobj->from_file($localtlpdb->root . "/tlpkg/tlpobj/$pkg.tlpobj");
 1868   $localtlpdb->add_tlpobj($tlpobj);
 1869   TeXLive::TLUtils::announce_execute_actions("enable",
 1870                                       $localtlpdb->get_package($pkg));
 1871   $localtlpdb->save;
 1872   # TODO_ERRORCHECKING we should check the return values of the
 1873   # various calls above
 1874   return ($F_OK);
 1875 }
 1876 
 1877 sub setup_backup_directory {
 1878   my $ret = $F_OK;
 1879   my $autobackup = 0;
 1880   # check for the tlpdb option autobackup, and if present and true (!= 0)
 1881   # assume we are doing backups
 1882   if (!$opts{"backup"}) {
 1883     $autobackup = $localtlpdb->option("autobackup");
 1884     if ($autobackup) {
 1885       # check the format, we currently allow only natural numbers, and -1
 1886       if ($autobackup eq "-1") {
 1887         debug ("Automatic backups activated, keeping all backups.\n");
 1888         $opts{"backup"} = 1;
 1889       } elsif ($autobackup eq "0") {
 1890         debug ("Automatic backups disabled.\n");
 1891       } elsif ($autobackup =~ m/^[0-9]+$/) {
 1892         debug ("Automatic backups activated, keeping $autobackup backups.\n");
 1893         $opts{"backup"} = 1;
 1894       } else {
 1895         tlwarn ("$prg: Option autobackup value can only be an integer >= -1.\n");
 1896         tlwarn ("$prg: Disabling auto backups.\n");
 1897         $localtlpdb->option("autobackup", 0);
 1898         $autobackup = 0;
 1899         $ret |= $F_WARNING;
 1900       }
 1901     }
 1902   }
 1903 
 1904   # cmd line --backup, we check for --backupdir, and if that is not given
 1905   # we try to get the default from the tlpdb. If that doesn't work, exit.
 1906   if ($opts{"backup"}) {
 1907     my ($a, $b) = check_backupdir_selection();
 1908     if ($a & $F_ERROR) {
 1909       # in all these cases we want to terminate in the non-gui mode
 1910       tlwarn($b);
 1911       return ($F_ERROR, $autobackup);
 1912     }
 1913   }
 1914 
 1915   # finally, if we have --backupdir, but no --backup, just enable it
 1916   $opts{"backup"} = 1 if $opts{"backupdir"};
 1917 
 1918   my $saving_verb = $opts{"dry-run"} || $opts{"list"} ? "would save" :"saving";
 1919   info("$prg: $saving_verb backups to $opts{'backupdir'}\n")
 1920     if $opts{"backup"} && !$::machinereadable;
 1921   
 1922   return ($ret, $autobackup);
 1923 }
 1924 
 1925 sub check_backupdir_selection {
 1926   my $warntext = "";
 1927   if ($opts{"backupdir"}) {
 1928     my $ob = abs_path($opts{"backupdir"});
 1929     $ob && ($opts{"backupdir"} = $ob);
 1930     if (! -d $opts{"backupdir"}) {
 1931       $warntext .= "$prg: backupdir argument\n";
 1932       $warntext .= "  $opts{'backupdir'}\n";
 1933       $warntext .= "is not a directory.\n";
 1934       return ($F_ERROR, $warntext);
 1935     }
 1936   } else {
 1937     # no argument, check for presence in TLPDB
 1938     init_local_db(1);
 1939     $opts{"backupdir"} = norm_tlpdb_path($localtlpdb->option("backupdir"));
 1940     if (!$opts{"backupdir"}) {
 1941       return (0, "$prg: cannot determine backupdir.\n");
 1942     }
 1943     # we are still here, there is something set in tlpdb
 1944     my $ob = abs_path($opts{"backupdir"});
 1945     $ob && ($opts{"backupdir"} = $ob);
 1946     if (! -d $opts{"backupdir"}) {
 1947       $warntext =  "$prg: backupdir as set in tlpdb\n";
 1948       $warntext .= "  $opts{'backupdir'}\n";
 1949       $warntext .= "is not a directory.\n";
 1950       return ($F_ERROR, $warntext);
 1951     }
 1952   }
 1953   return $F_OK;
 1954 }
 1955 
 1956 sub action_restore {
 1957   # tlmgr restore [--backupdir dir] --all
 1958   #   restores of all packages found in backupdir the latest version
 1959   # tlmgr restore --backupdir dir
 1960   #   lists all packages with all revisions
 1961   # tlmgr restore --backupdir dir pkg
 1962   #   lists all revisions of pkg
 1963   # tlmgr restore --backupdir dir pkg rev
 1964   #   restores pkg to revision rev
 1965   # check the backup dir argument
 1966 
 1967   {
 1968     my ($a, $b) = check_backupdir_selection();
 1969     if ($a & $F_ERROR) {
 1970       # in all these cases we want to terminate in the non-gui mode
 1971       tlwarn($b);
 1972       return ($F_ERROR);
 1973     }
 1974   }
 1975   info("$prg restore: dry run, no changes will be made\n") if $opts{"dry-run"};
 1976 
 1977   # initialize the hash(packages) of hash(revisions), do stat files! (the 1)
 1978   my %backups = get_available_backups($opts{"backupdir"}, 1);
 1979   my ($pkg, $rev) = @ARGV;
 1980   if (defined($pkg) && $opts{"all"}) {
 1981     tlwarn("$prg: Specify either --all or individual package(s) ($pkg)\n");
 1982     tlwarn("$prg: to restore, not both.  Terminating.\n");
 1983     return ($F_ERROR);
 1984   }
 1985   if ($opts{"all"}) {
 1986     init_local_db(1);
 1987     return ($F_ERROR) if !check_on_writable();
 1988     if (!$opts{"force"}) {
 1989       print "Do you really want to restore all packages to the latest revision found in\n\t$opts{'backupdir'}\n===> (y/N): ";
 1990       my $yesno = <STDIN>;
 1991       if ($yesno !~ m/^y(es)?$/i) {
 1992         print "Ok, cancelling the restore!\n";
 1993         return ($F_OK | $F_NOPOSTACTION);
 1994       }
 1995     }
 1996     for my $p (sort keys %backups) {
 1997       my @tmp = sort {$b <=> $a} (keys %{$backups{$p}});
 1998       my $rev = $tmp[0];
 1999       print "Restoring $p, $rev from $opts{'backupdir'}/${p}.r${rev}.tar.*\n";
 2000       if (!$opts{"dry-run"}) {
 2001         # first remove the package, then reinstall it
 2002         # this way we get rid of useless files
 2003         # TODO_ERRORCHECK needs check for return values!!
 2004         restore_one_package($p, $rev, $opts{"backupdir"});
 2005       }
 2006     }
 2007     # localtlpdb already saved, so we are finished
 2008     return ($F_OK);
 2009   }
 2010   #
 2011   # intermediate sub
 2012   sub report_backup_revdate {
 2013     my $p = shift;
 2014     my $mode = shift;
 2015     my %revs = @_;
 2016     my @rs = sort {$b <=> $a} (keys %revs);
 2017     my @outarr;
 2018     for my $rs (@rs) {
 2019       my %jsonkeys;
 2020       $jsonkeys{'name'} = $p;
 2021       my $dstr;
 2022       if ($revs{$rs} == -1) {
 2023         $dstr = "unknown";
 2024       } else {
 2025         my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
 2026           localtime($revs{$rs});
 2027         # localtime returns dates starting from 1900, and the month is 0..11
 2028         $dstr = sprintf "%04d-%02d-%02d %02d:%02d", 
 2029           $year+1900, $mon+1, $mday, $hour, $min;
 2030       }
 2031       if ($mode eq "json") {
 2032         $jsonkeys{'rev'} = "$rs";
 2033         $jsonkeys{'date'} = $dstr;
 2034         push @outarr, \%jsonkeys;
 2035       } else {
 2036         push @outarr, "$rs ($dstr)";
 2037       }
 2038     }
 2039     if ($mode eq "json") {
 2040       return @outarr;
 2041     } else {
 2042       return ( join(" ", @outarr));
 2043     }
 2044   }
 2045   # end sub
 2046   if (!defined($pkg)) {
 2047     if (keys %backups) {
 2048       if ($opts{'json'}) {
 2049         my @bla = map { report_backup_revdate($_, "json", %{$backups{$_}}) } keys %backups;
 2050         my $str = TeXLive::TLUtils::encode_json(\@bla);
 2051         print "$str\n";
 2052       } else {
 2053         print "Available backups:\n";
 2054         foreach my $p (sort keys %backups) {
 2055           print "$p: ";
 2056           print(report_backup_revdate($p, "text", %{$backups{$p}}));
 2057           print "\n";
 2058         }
 2059       }
 2060     } else {
 2061       if ($opts{'json'}) {
 2062         print "[]\n";
 2063       } else {
 2064         print "No backups available in $opts{'backupdir'}\n";
 2065       }
 2066     }
 2067     return ($F_OK | $F_NOPOSTACTION);
 2068   }
 2069   if (!defined($rev)) {
 2070     if ($opts{'json'}) {
 2071       my @bla = report_backup_revdate($pkg, "json", %{$backups{$pkg}});
 2072       my $str = TeXLive::TLUtils::encode_json(\@bla);
 2073       print "$str\n";
 2074     } else {
 2075       print "Available backups for $pkg: ";
 2076       print(report_backup_revdate($pkg, "text", %{$backups{$pkg}}));
 2077       print "\n";
 2078     }
 2079     return ($F_OK | $F_NOPOSTACTION);
 2080   }
 2081   # we did arrive here, so we try to restore ...
 2082   if (defined($backups{$pkg}->{$rev})) {
 2083     return if !check_on_writable();
 2084     if (!$opts{"force"}) {
 2085       print "Do you really want to restore $pkg to revision $rev (y/N): ";
 2086       my $yesno = <STDIN>;
 2087       if ($yesno !~ m/^y(es)?$/i) {
 2088         print "Ok, cancelling the restore!\n";
 2089         return ($F_OK | $F_NOPOSTACTION);
 2090       }
 2091     }
 2092     print "Restoring $pkg, $rev from $opts{'backupdir'}/${pkg}.r${rev}.tar.xz\n";
 2093     if (!$opts{"dry-run"}) {
 2094       init_local_db(1);
 2095       # first remove the package, then reinstall it
 2096       # this way we get rid of useless files
 2097       restore_one_package($pkg, $rev, $opts{"backupdir"});
 2098     }
 2099     # TODO_ERRORCHECKING check return value of restore_one_package
 2100     return ($F_OK);
 2101   } else {
 2102     print "revision $rev for $pkg is not present in $opts{'backupdir'}\n";
 2103     return ($F_ERROR);
 2104   }
 2105 }
 2106 
 2107 sub action_backup {
 2108   init_local_db(1);
 2109   # --clean argument
 2110   # can be either -1 ... don't clean
 2111   #               0  ... remove all backups
 2112   #               N  ... keep only N backups
 2113   # that parallels the value of autoclean in the configuration
 2114   # we have to be careful, because if simply --clean is given, we should
 2115   # check for the value saved in the tlpdb, and if that is not present
 2116   # do nothing.
 2117   # We have set clean to clean:-99 which makes -99 the default value
 2118   # if only --clean is given without any argument
 2119   # !defined($opts{"clean"})  -> no --clean given
 2120   # $opts{"clean"} = -99      -> --clean without argument given, check tlpdb
 2121   # $opts{"clean"} = -1, 0, N -> --clean=N given, check argument
 2122   #
 2123   my $clean_mode = 0;
 2124   $clean_mode = 1 if defined($opts{"clean"});
 2125   if ($clean_mode) {
 2126     if ($opts{"clean"} == -99) {
 2127       # we need to check the tlpdb
 2128       my $tlpdb_option = $localtlpdb->option("autobackup");
 2129       if (!defined($tlpdb_option)) {
 2130         tlwarn ("$prg: --clean given without an argument, but no default clean\n");
 2131         tlwarn ("$prg: mode specified in the tlpdb.\n");
 2132         return ($F_ERROR);
 2133       }
 2134       $opts{"clean"} = $tlpdb_option;
 2135     }
 2136     # now $opts{"clean"} is something, but maybe not a number, check for
 2137     # validity
 2138     if ($opts{"clean"} =~ m/^(-1|[0-9]+)$/) {
 2139       # get rid of leading zeros etc etc
 2140       $opts{"clean"} = $opts{"clean"} + 0;
 2141     } else {
 2142       tlwarn ("$prg: clean mode as specified on the command line or as given by default\n");
 2143       tlwarn ("$prg: must be an integer larger or equal than -1, terminating.\n");
 2144       return($F_ERROR);
 2145     }
 2146   }
 2147   # check the backup dir argument
 2148   {
 2149     my ($a, $b) = check_backupdir_selection();
 2150     if ($a & $F_ERROR) {
 2151       # in all these cases we want to terminate in the non-gui mode
 2152       tlwarn($b);
 2153       return($F_ERROR);
 2154     }
 2155   }
 2156 
 2157   # if we do --clean --all we also want to remove packages that
 2158   # are not present anymore in the tlpdb, so use the readdir mode 
 2159   # to determine backups
 2160   if ($opts{"all"} && $clean_mode) {
 2161     # initialize the hash(packages) of hash(revisions)
 2162     # no need to stat the files
 2163     my %backups = get_available_backups($opts{"backupdir"}, 0);
 2164     init_local_db(1);
 2165     for my $p (sort keys %backups) {
 2166       clear_old_backups ($p, $opts{"backupdir"}, $opts{"clean"}, $opts{"dry-run"}, 1);
 2167     }
 2168     info("no action taken due to --dry-run\n") if $opts{"dry-run"};
 2169     return ($F_OK | $F_NOPOSTACTION);
 2170   }
 2171 
 2172   # in case we are not cleaning or cleaning only specific packages
 2173   # use the one-by-one mode
 2174   my @todo;
 2175   if ($opts{"all"}) {
 2176     @todo = $localtlpdb->list_packages;
 2177   } else {
 2178     @todo = @ARGV;
 2179     @todo = $localtlpdb->expand_dependencies("-only-arch", $localtlpdb, @todo);
 2180   }
 2181   if (!@todo) {
 2182     printf "tlmgr backup takes either a list of packages or --all\n";
 2183     return ($F_ERROR);
 2184   }
 2185   foreach my $pkg (@todo) {
 2186     if ($clean_mode) {
 2187       clear_old_backups ($pkg, $opts{"backupdir"}, $opts{"clean"}, $opts{"dry-run"}, 1);
 2188     } else {
 2189       # for now default to xz and allow overriding with env var
 2190       my $compressorextension = $Compressors{$::progs{'compressor'}}{'extension'};
 2191       my $tlp = $localtlpdb->get_package($pkg);
 2192       my $saving_verb = $opts{"dry-run"} ? "would save" : "saving";
 2193       info("$saving_verb current status of $pkg to $opts{'backupdir'}/${pkg}.r"
 2194            . $tlp->revision . ".tar.$compressorextension\n");
 2195       if (!$opts{"dry-run"}) {
 2196         $tlp->make_container($::progs{'compressor'}, $localtlpdb->root,
 2197                              destdir => $opts{"backupdir"},
 2198                              user => 1);
 2199       }
 2200     }
 2201   }
 2202   info("no action taken due to --dry-run\n") if $opts{"dry-run"};
 2203   # TODO_ERRORCHECKING needs checking of the above
 2204   return ($F_OK);
 2205 }
 2206 
 2207 # =====================================================================
 2208 #                  INFRASTRUCTURE UPDATE ON WINDOWS
 2209 # =====================================================================
 2210 #      Infrastructure files cannot be updated directly from the
 2211 # tlmgr.pl script due to file locking problem on Windows - files that
 2212 # are in use (either open or executing) cannot be removed or replaced.
 2213 # For that reason the update process is performed by a batch script
 2214 # outside of tlmgr.pl.
 2215 #      There are three pieces involved in the update: tlmgr.bat
 2216 # launcher, write_w32_updater subroutine below and a batch
 2217 # updater script. Their roles are as follows:
 2218 # * tlmgr.bat is a watchdog, it launches tlmgr.pl and watches for
 2219 #   the updater script that is to be executed. If the updater script
 2220 #   exists before tlmgr.pl is launched, it will be removed or
 2221 #   tlmgr.bat will abort if it fails to do so. This means that the
 2222 #   updater script has to be created by the current invocation of
 2223 #   tlmgr.pl. Furthermore, the updater script is renamed from
 2224 #   updater-w32 to updater-w32.bat just before it is run, and thus
 2225 #   it can be executed only once.
 2226 # * write_w32_updater subroutine in tlmgr.pl prepares the update
 2227 #   and writes the updater script. Packages in .xz archives are
 2228 #   downloaded/copied and uncompressed to .tar files. Also .tar
 2229 #   backups of the current packages are made. If everything is 
 2230 #   successful, the update script is created from the template. 
 2231 #   Otherwise the update is aborted.
 2232 # * updater-w32[.bat] batch script, triggers and executes the actual 
 2233 #   update. It first restarts itself in a separate instance of cmd.exe 
 2234 #   (and in a new console window in gui mode) and runs the update 
 2235 #   from there. The update is run with echo on and all output is 
 2236 #   logged to a file (or stderr in verbose mode). After successful 
 2237 #   infrastructure update, tlmgr is optionally restarted if update 
 2238 #   of other packages is asked for.
 2239 #      The infrastructure update itself proceeds as follows:
 2240 #   (1) untar all package archives
 2241 #   (2) include .tlpobj files into tlpdb
 2242 #   (3) print update info to console
 2243 #      Any error during (1) or (2) triggers the rollback sequence:
 2244 #   (1) print failed update info to console
 2245 #   (2) untar all package backups
 2246 #   (3) include .tlpobj files (from backup) into tlpdb
 2247 #   (4) print restore info to console
 2248 #      Any error during (2) or (3) and we go into panic state.  At this 
 2249 #   point there is no guarantee that the installation is still working. 
 2250 #   There is not much we can do but to print failed restore info and 
 2251 #   give instructions to download and run 'update-tlmgr-latest.exe'
 2252 #   to repair the installation.
 2253 # =====================================================================
 2254 #
 2255 sub write_w32_updater {
 2256   my ($restart_tlmgr, $ref_files_to_be_removed, @w32_updated) = @_;
 2257   my @infra_files_to_be_removed = @$ref_files_to_be_removed;
 2258   # TODO do something with these files TODO
 2259   my $media = $remotetlpdb->media;
 2260   # we have to download/copy also the src/doc files if necessary!
 2261   my $container_src_split = $remotetlpdb->config_src_container;
 2262   my $container_doc_split = $remotetlpdb->config_doc_container;
 2263   # get options about src/doc splitting from $totlpdb
 2264   # TT: should we use local options to decide about install of doc & src?
 2265   my $opt_src = $localtlpdb->option("install_srcfiles");
 2266   my $opt_doc = $localtlpdb->option("install_docfiles");
 2267   my $root = $localtlpdb->root;
 2268   my $temp = "$root/temp";
 2269   TeXLive::TLUtils::mkdirhier($temp);
 2270   tlwarn("$prg: Backup option not implemented for infrastructure update.\n") if ($opts{"backup"});
 2271   if ($media eq 'local_uncompressed') {
 2272     tlwarn("$prg: Creating updater from local_uncompressed currently not implemented!\n");
 2273     tlwarn("$prg: But it should not be necessary!\n");
 2274     return 1; # abort
 2275   }
 2276   my (@upd_tar, @upd_tlpobj, @upd_info, @rst_tar, @rst_tlpobj, @rst_info);
 2277   foreach my $pkg (@w32_updated) {
 2278     my $repo;
 2279     my $mediatlp;
 2280     # need to update the media type to the original, as it is
 2281     # reset below
 2282     $media = $remotetlpdb->media;
 2283     if ($media eq "virtual") {
 2284       my $maxtlpdb;
 2285       (undef, undef, $mediatlp, $maxtlpdb) = 
 2286         $remotetlpdb->virtual_candidate($pkg);
 2287       $repo = $maxtlpdb->root . "/$Archive";
 2288       # update the media type of the used tlpdb
 2289       # otherwise later on we stumble when preparing the updater
 2290       $media = $maxtlpdb->media;
 2291     } else {
 2292       $mediatlp = $remotetlpdb->get_package($pkg);
 2293       $repo = $remotetlpdb->root . "/$Archive";
 2294     }
 2295     my $localtlp = $localtlpdb->get_package($pkg);
 2296     my $oldrev = $localtlp->revision;
 2297     my $newrev = $mediatlp->revision;
 2298     # we do install documentation files for category Documentation even if
 2299     # option("install_docfiles") is false
 2300     my $opt_real_doc = ($mediatlp->category =~ m/documentation/i) ? 1 : $opt_doc;
 2301     my @pkg_parts = ($pkg);
 2302     push(@pkg_parts, "$pkg.source") if ($container_src_split && $opt_src && $mediatlp->srcfiles);
 2303     push(@pkg_parts, "$pkg.doc") if ($container_doc_split && $opt_real_doc && $mediatlp->docfiles);
 2304     foreach my $pkg_part (@pkg_parts) {
 2305       push (@upd_tar, "$pkg_part.tar");
 2306       push (@upd_tlpobj, "tlpkg\\tlpobj\\$pkg_part.tlpobj");
 2307     }
 2308     push (@upd_info, "$pkg ^($oldrev -^> $newrev^)");
 2309     push (@rst_tar, "__BACKUP_$pkg.r$oldrev.tar");
 2310     push (@rst_tlpobj, "tlpkg\\tlpobj\\$pkg.tlpobj");
 2311     push (@rst_info, "$pkg ^($oldrev^)");
 2312     next if ($opts{"dry-run"});
 2313     # create backup; make_container expects filename in format:
 2314     #   some-name.r[0-9]+
 2315     my ($size, undef, $fullname) = $localtlp->make_container("tar", $root,
 2316                                      destdir => $temp,
 2317                                      containername => "__BACKUP_$pkg",
 2318                                      user => 1);
 2319     if ($size <= 0) {
 2320       tlwarn("$prg: creation of backup container failed for: $pkg\n");
 2321       return 1; # backup failed? abort
 2322     }
 2323     my $decompressor = $::progs{$DefaultCompressorFormat};
 2324     my $compressorextension = $Compressors{$DefaultCompressorFormat}{'extension'};
 2325     my @decompressorArgs = @{$Compressors{$DefaultCompressorFormat}{'decompress_args'}};
 2326     foreach my $pkg_part (@pkg_parts) {
 2327       my $dlcontainer = "$temp/$pkg_part.tar.$compressorextension";
 2328       if ($media eq 'local_compressed') {
 2329         copy("$repo/$pkg_part.tar.$compressorextension", "$temp");
 2330       } else { # net
 2331         TeXLive::TLUtils::download_file("$repo/$pkg_part.tar.$compressorextension", $dlcontainer);
 2332       }
 2333       # now we should have the file present
 2334       if (!-r $dlcontainer) {
 2335         tlwarn("$prg: couldn't get $pkg_part.tar.$compressorextension, that is bad\n");
 2336         return 1; # abort
 2337       }
 2338       # unpack xz archive
 2339       my $sysret = system("$decompressor @decompressorArgs < \"$dlcontainer\" > \"$temp/$pkg_part.tar\"");
 2340       if ($sysret) {
 2341         tlwarn("$prg: couldn't unpack $pkg_part.tar.$compressorextension\n");
 2342         return 1; # unpack failed? abort
 2343       }
 2344       unlink($dlcontainer); # we don't need that archive anymore
 2345     }
 2346   }
 2347   
 2348   # prepare updater script
 2349   my $respawn_cmd = "cmd.exe /e:on/v:off/d/c";
 2350   $respawn_cmd = "start /wait $respawn_cmd" if ($::gui_mode);
 2351   my $gui_pause = ($::gui_mode ? "pause" : "rem");
 2352   my $upd_log = ($::opt_verbosity ? "STDERR" : '"%~dp0update-self.log"');
 2353   my $std_handles_redir = ($::opt_verbosity ? "1^>^&2" : "2^>$upd_log 1^>^&2");
 2354   my $pkg_log = ($packagelogfile ? "\"$packagelogfile\"" : "nul");
 2355   my $post_update_msg = "You may now close this window.";
 2356   my $rerun_tlmgr = "rem";
 2357   if ($restart_tlmgr) {
 2358     $post_update_msg = "About to restart tlmgr to complete update ...";
 2359     # quote all arguments for tlmgr restart in case of spaces
 2360     $rerun_tlmgr = join (" ", map ("\"$_\"", @::SAVEDARGV) );
 2361     $rerun_tlmgr = "if not errorlevel 1 tlmgr.bat $rerun_tlmgr";
 2362   }
 2363   my $batch_script = <<"EOF";
 2364 :: This file is part of an automated update process of
 2365 :: infrastructure files and should not be run standalone. 
 2366 :: For more details about the update process see comments 
 2367 :: in tlmgr.pl (subroutine write_w32_updater).
 2368 
 2369   if [%1]==[:doit] goto :doit
 2370   if not exist "%~dp0tar.exe" goto :notar
 2371   $respawn_cmd call "%~f0" :doit $std_handles_redir
 2372   $rerun_tlmgr
 2373   goto :eof
 2374 
 2375 :notar
 2376   echo %~nx0: cannot run without "%~dp0tar.exe"
 2377   findstr "^::" <"%~f0"
 2378   exit /b 1
 2379 
 2380 :doit
 2381   set prompt=TL\$G
 2382   title TeX Live Manager $TeXLive::TLConfig::ReleaseYear Update
 2383   set PERL5LIB=$root/tlpkg/tlperl/lib
 2384   >con echo DO NOT CLOSE THIS WINDOW!
 2385   >con echo TeX Live infrastructure update in progress ...
 2386   >con echo Detailed command logging to $upd_log
 2387   pushd "%~dp0.."
 2388   if not errorlevel 1 goto :update
 2389   >con echo Could not change working directory to "%~dp0.."
 2390   >con echo Aborting infrastructure update, no changes have been made.
 2391   >con $gui_pause 
 2392   popd
 2393   exit /b 1
 2394     
 2395 :update
 2396   for %%I in (@upd_tar) do (
 2397     temp\\tar.exe -xmf temp\\%%I
 2398     if errorlevel 1 goto :rollback
 2399   )
 2400   tlpkg\\tlperl\\bin\\perl.exe .\\texmf-dist\\scripts\\texlive\\tlmgr.pl _include_tlpobj @upd_tlpobj
 2401   if errorlevel 1 goto :rollback
 2402   >>$pkg_log echo [%date% %time%] self update: @upd_info
 2403   >con echo self update: @upd_info
 2404   del "%~dp0*.tar" "%~dp0tar.exe" 
 2405   >con echo Infrastructure update finished successfully.
 2406   >con echo $post_update_msg
 2407   >con $gui_pause 
 2408   popd
 2409   exit /b 0
 2410 
 2411 :rollback
 2412   >>$pkg_log echo [%date% %time%] failed self update: @upd_info
 2413   >con echo failed self update: @upd_info
 2414   >con echo Rolling back to previous version ...
 2415   for %%I in (@rst_tar) do (
 2416     temp\\tar.exe -xmf temp\\%%I
 2417     if errorlevel 1 goto :panic
 2418   )
 2419   tlpkg\\tlperl\\bin\\perl.exe .\\texmf-dist\\scripts\\texlive\\tlmgr.pl _include_tlpobj @rst_tlpobj
 2420   if errorlevel 1 goto :panic
 2421   >>$pkg_log echo [%date% %time%] self restore: @rst_info
 2422   >con echo self restore: @rst_info
 2423   >con echo Infrastructure update failed. Previous version has been restored.
 2424   >con $gui_pause 
 2425   popd
 2426   exit /b 1
 2427 
 2428 :panic
 2429   >>$pkg_log echo [%date% %time%] failed self restore: @rst_info
 2430   >con echo failed self restore: @rst_info
 2431   >con echo FATAL ERROR:
 2432   >con echo Infrastructure update failed and backup recovery failed too.
 2433   >con echo To repair your TeX Live installation download and run:
 2434   >con echo $TeXLive::TLConfig::TeXLiveURL/update-tlmgr-latest.exe
 2435   >con $gui_pause 
 2436   popd
 2437   exit /b 666
 2438 EOF
 2439 
 2440   ddebug("\n:: UPDATER BATCH SCRIPT ::\n$batch_script\n:: END OF FILE ::\n");
 2441   if ($opts{"dry-run"}) {
 2442     my $upd_info = "self update: @upd_info";
 2443     $upd_info =~ s/\^//g;
 2444     info($upd_info);
 2445   } else {
 2446     copy("$root/tlpkg/installer/tar.exe", "$temp");
 2447     # make sure copied tar is working
 2448     if (system("\"$temp/tar.exe\" --version >nul")) {
 2449       tlwarn("$prg: could not copy tar.exe, that is bad.\n");
 2450       return 1; # abort
 2451     }
 2452     open UPDATER, ">$temp/updater-w32" or die "Cannot create updater script: $!";
 2453     print UPDATER $batch_script;
 2454     close UPDATER;
 2455   }
 2456   return 0;
 2457 }
 2458 
 2459 
 2460 #  UPDATE
 2461 
 2462 # compute the list of auto-install, auto-remove, forcibly-removed 
 2463 # packages from the list of packages to be installed
 2464 # the list of packages passed in is already expanded
 2465 sub auto_remove_install_force_packages {
 2466   my @todo = @_;
 2467   my %removals_full;
 2468   my %forcermpkgs_full;
 2469   my %newpkgs_full;
 2470   my %new_pkgs_due_forcerm_coll;
 2471   # check for new/removed/forcibly removed packages.
 2472   # we start from the list of installed collections in the local tlpdb
 2473   # which are also present in the remote database
 2474   # and expand this list once with expand_dependencies in the local tlpdb
 2475   # and once in the tlmedia tlpdb. Then we compare the lists
 2476   # let A = set of local expansions
 2477   #     B = set of remote expansions
 2478   # then we should(?) have
 2479   #     B \ A  set of new packages
 2480   #     A \ B  set of packages removed on the server
 2481   #     A \cup B set of packages which should be checked for forcible removal
 2482   #
 2483   my @all_schmscolls = ();
 2484   for my $p ($localtlpdb->schemes) {
 2485     push (@all_schmscolls, $p) if defined($remotetlpdb->get_package($p));
 2486   }
 2487   for my $p ($localtlpdb->collections) {
 2488     push (@all_schmscolls, $p) if defined($remotetlpdb->get_package($p));
 2489   }
 2490   my @localexpansion_full =
 2491     $localtlpdb->expand_dependencies($localtlpdb, @all_schmscolls);
 2492   my @remoteexpansion_full =
 2493     $remotetlpdb->expand_dependencies($localtlpdb, @all_schmscolls);
 2494 
 2495   # compute new/remove/forcerm based on the full expansions
 2496   for my $p (@remoteexpansion_full) {
 2497     $newpkgs_full{$p} = 1;
 2498   }
 2499   for my $p (@localexpansion_full) {
 2500     delete($newpkgs_full{$p});
 2501     $removals_full{$p} = 1;
 2502   }
 2503   for my $p (@remoteexpansion_full) {
 2504     delete($removals_full{$p});
 2505   }
 2506   # in a first round we check only for forcibly removed collections
 2507   # this is necessary to NOT declare a package that is contained 
 2508   # in a forcibly removed collections as auto-install since it appears
 2509   # in the @remoteexpansion_full, but not in @localexpansion_full.
 2510   for my $p (@localexpansion_full) {
 2511     # intersection, don't check A\B and B\A
 2512     next if $newpkgs_full{$p};
 2513     next if $removals_full{$p};
 2514     my $remotetlp = $remotetlpdb->get_package($p);
 2515     if (!defined($remotetlp)) {
 2516       tlwarn("$prg: Strange, $p mentioned but not found anywhere!\n");
 2517       next;
 2518     }
 2519     next if ($remotetlp->category ne "Collection");
 2520     my $tlp = $localtlpdb->get_package($p);
 2521     if (!defined($tlp)) {
 2522       if ($opts{"reinstall-forcibly-removed"}) {
 2523         $newpkgs_full{$p} = 1;
 2524       } else {
 2525         $forcermpkgs_full{$p} = 1;
 2526       }
 2527     }
 2528   }
 2529   # now we have in %forcermpkgs_full only collections that have been
 2530   # forcibly removed. Again, expand those against the remote tlpdb
 2531   # and remove the expanded packages from the list of localexpansion.
 2532   my @pkgs_from_forcerm_colls = 
 2533     $remotetlpdb->expand_dependencies($localtlpdb, keys %forcermpkgs_full);
 2534   # 
 2535   # the package in @pkgs_from_forcerm_colls would be auto-installed, so
 2536   # check for that:
 2537   for my $p (keys %newpkgs_full) {
 2538     if (member($p, @pkgs_from_forcerm_colls)) {
 2539       delete $newpkgs_full{$p};
 2540       $new_pkgs_due_forcerm_coll{$p} = 1;
 2541     }
 2542   }
 2543   #
 2544   # now create the final list of forcerm packages by checking against
 2545   # all packages
 2546   for my $p (@localexpansion_full) {
 2547     # intersection, don't check A\B and B\A
 2548     next if $newpkgs_full{$p};
 2549     next if $removals_full{$p};
 2550     my $tlp = $localtlpdb->get_package($p);
 2551     if (!defined($tlp)) {
 2552       if ($opts{"reinstall-forcibly-removed"}) {
 2553         $newpkgs_full{$p} = 1;
 2554       } else {
 2555         $forcermpkgs_full{$p} = 1;
 2556       }
 2557     }
 2558   }
 2559   #
 2560   # for some packages (texworks, psview, ...) we only have w32 packages
 2561   # in the repository, but it is possible that alternative repositories
 2562   # ship binaries for some platforms (like texworks for GNU/Linux on tlcontrib)
 2563   # currently updating from tlnet will remove these alternative .ARCH
 2564   # packages because they are not listed anywhere locally, so they
 2565   # are considered as disappearing.
 2566   # We remove here packages PKG.ARCH if the main package PKG is found
 2567   # here and is *not* disappearing, from the removal hash
 2568   for my $p (keys %removals_full) {
 2569     if ($p =~ m/^([^.]*)\./) {
 2570       my $mpkg = $1;
 2571       if (!defined($removals_full{$mpkg})) {
 2572         delete($removals_full{$p});
 2573       }
 2574     }
 2575   }
 2576   #
 2577   # now take only the subset of packages that is in @todo
 2578   # note that @todo is already expanded in action_update according
 2579   # to the --no-depends and --no-depends-at-all options
 2580   #
 2581   my %removals;
 2582   my %forcermpkgs;
 2583   my %newpkgs;
 2584   for my $p (@todo) {
 2585     $removals{$p} = 1 if defined($removals_full{$p});
 2586     $forcermpkgs{$p} = 1 if defined($forcermpkgs_full{$p});
 2587     $newpkgs{$p} = 1 if defined($newpkgs_full{$p});
 2588   }
 2589   debug ("$prg: new pkgs: " . join("\n\t",keys %newpkgs) . "\n");
 2590   debug ("$prg: deleted : " . join("\n\t",keys %removals) . "\n");
 2591   debug ("$prg: forced  : " . join("\n\t",keys %forcermpkgs) . "\n");
 2592 
 2593   return (\%removals, \%newpkgs, \%forcermpkgs, \%new_pkgs_due_forcerm_coll);
 2594 }
 2595 
 2596 # tlmgr update foo
 2597 #   if foo is of type Package|Documentation it will update only foo
 2598 #     and the respective .ARCH dependencies
 2599 #   if foo is of type Collection|Scheme it will update itself AND
 2600 #     will check all depending packs of type NOT(Collection|Scheme)
 2601 #     for necessary updates
 2602 #
 2603 # tlmgr update --no-depends foo
 2604 #   as above, but will not check for depends of Collections/Schemes
 2605 #   but it will still update .ARCH deps
 2606 #
 2607 # tlmgr update --no-depends-at-all foo
 2608 #   will absolutely only update foo not even taking .ARCH into account
 2609 #
 2610 # TLPDB->install_package INSTALLS ONLY ONE PACKAGE, no deps whatsoever
 2611 # anymore. That has all to be done by hand.
 2612 #
 2613 sub machine_line {
 2614   my ($flag1) = @_;
 2615   my $ret = 0;
 2616   if ($flag1 eq "-ret") {
 2617     $ret = 1;
 2618     shift;
 2619   }
 2620   my ($pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv) = @_;
 2621   $lrev ||= "-";
 2622   $rrev ||= "-";
 2623   $flag ||= "?";
 2624   $size ||= "-";
 2625   $runtime ||= "-";
 2626   $esttot ||= "-";
 2627   $tag ||= "-";
 2628   $lcv ||= "-";
 2629   $rcv ||= "-";
 2630   my $str = join("\t", $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv);
 2631   $str .= "\n";
 2632   return($str) if $ret;
 2633   print $str;
 2634 }
 2635 
 2636 sub upd_info {
 2637   my ($pkg, $kb, $lrev, $mrev, $txt) = @_;
 2638   my $flen = 25;
 2639   my $kbstr = ($kb >= 0 ? " [${kb}k]" : "");
 2640   my $kbstrlen = length($kbstr);
 2641   my $pkglen = length($pkg);
 2642   my $is = sprintf("%-9s ", "$txt:");
 2643   if ($pkglen + $kbstrlen > $flen) {
 2644     $is .= "$pkg$kbstr: ";
 2645   } else {
 2646     $is .= sprintf ('%*2$s', $pkg, -($flen-$kbstrlen));
 2647     $is .= "$kbstr: ";
 2648   }
 2649   $is .= sprintf("local: %8s, source: %8s",
 2650                          $lrev,       $mrev);
 2651   info("$is\n");
 2652 }
 2653 
 2654 sub action_update {
 2655   init_local_db(1);
 2656   $opts{"no-depends"} = 1 if $opts{"no-depends-at-all"};
 2657 
 2658   # make a quick check on command line arguments to avoid loading
 2659   # the remote db uselessly. 
 2660   # we require:
 2661   # if no --list is given: either --self or --all or <pkgs> 
 2662   # if --list is given:    nothing
 2663   # other options just change the behavior
 2664   if (!($opts{"list"} || @ARGV || $opts{"all"} || $opts{"self"})) {
 2665     if ($opts{"dry-run"}) {
 2666       $opts{"list"} = 1; # update -n same as update -n --list
 2667     } else {
 2668       tlwarn("$prg update: specify --list, --all, --self, or a list of package names.\n");
 2669       return ($F_ERROR);
 2670     }
 2671   }
 2672 
 2673   init_tlmedia_or_die();
 2674   info("$prg update: dry run, no changes will be made\n") if $opts{"dry-run"};
 2675 
 2676   my @excluded_pkgs = ();
 2677   if ($opts{"exclude"}) {
 2678     @excluded_pkgs = @{$opts{"exclude"}};
 2679   } elsif ($config{'update-exclude'}) {
 2680     @excluded_pkgs = @{$config{'update-exclude'}};
 2681   }
 2682 
 2683   if (!$opts{"list"}) {
 2684     return ($F_ERROR) if !check_on_writable();
 2685   }
 2686 
 2687   # check for updates to tlmgr and die unless either --force or --list or --self
 2688   # is given
 2689   my @critical;
 2690   if (!$opts{"usermode"}) {
 2691     @critical = check_for_critical_updates($localtlpdb, $remotetlpdb);
 2692   }
 2693   my $dry_run_cont = $opts{"dry-run"} && ($opts{"dry-run"} < 0);
 2694   if ( !$dry_run_cont  && !$opts{"self"} && @critical) {
 2695     critical_updates_warning() if (!$::machinereadable);
 2696     if ($opts{"force"}) {
 2697       tlwarn("$prg: Continuing due to --force.\n");
 2698     } elsif ($opts{"list"}) {
 2699       # do not warn here
 2700     } else {
 2701       return($F_ERROR);
 2702     }
 2703   }
 2704 
 2705   my ($ret, $autobackup) = setup_backup_directory();
 2706   return ($ret) if ($ret != $F_OK);
 2707 
 2708   # these two variables are used throughout this function
 2709   my $root = $localtlpdb->root;
 2710   my $temp = TeXLive::TLUtils::tl_tmpdir();
 2711 
 2712   # remove old _BACKUP packages that have piled up in temp
 2713   # they can be recognized by their name starting with __BACKUP_
 2714   for my $f (<$temp/__BACKUP_*>) {
 2715     unlink($f) unless $opts{"dry-run"};
 2716   }
 2717 
 2718 
 2719   my @todo;
 2720   if ($opts{"list"}) {
 2721     if ($opts{"all"}) {
 2722       @todo = $localtlpdb->list_packages;
 2723     } elsif ($opts{"self"}) {
 2724       @todo = @critical;
 2725     } else {
 2726       if (@ARGV) {
 2727         @todo = @ARGV;
 2728       } else {
 2729         @todo = $localtlpdb->list_packages;
 2730       }
 2731     }
 2732   } elsif ($opts{"self"} && @critical) {
 2733     @todo = @critical;
 2734   } elsif ($opts{"all"}) {
 2735     @todo = $localtlpdb->list_packages;
 2736   } else {
 2737     @todo = @ARGV;
 2738   }
 2739   if ($opts{"self"} && !@critical) {
 2740     info("$prg: no self-updates for tlmgr available\n");
 2741   }
 2742   # don't do anything if we have been invoked in a strange way
 2743   if (!@todo && !$opts{"self"}) {
 2744     tlwarn("$prg update: please specify a list of packages, --all, or --self.\n");
 2745     return ($F_ERROR);
 2746   }
 2747 
 2748   if (!($opts{"self"} && @critical) || ($opts{"self"} && $opts{"list"})) {
 2749     # update all .ARCH dependencies, too, unless $opts{"no-depends-at-all"}:
 2750     @todo = $remotetlpdb->expand_dependencies("-only-arch", $localtlpdb, @todo)
 2751       unless $opts{"no-depends-at-all"};
 2752     #
 2753     # update general deps unless $opts{"no-depends"}:
 2754     @todo = $remotetlpdb->expand_dependencies("-no-collections",$localtlpdb,@todo)
 2755       unless $opts{"no-depends"};
 2756     #
 2757     # filter out critical packages
 2758     @todo = grep (!m/$CriticalPackagesRegexp/, @todo)
 2759       unless $opts{"list"};
 2760   }
 2761     
 2762   my ($remref, $newref, $forref, $new_due_to_forcerm_coll_ref) = 
 2763     auto_remove_install_force_packages(@todo);
 2764   my %removals = %$remref;
 2765   my %forcermpkgs = %$forref;
 2766   my %newpkgs = %$newref;
 2767   my %new_due_to_forcerm_coll = %$new_due_to_forcerm_coll_ref;
 2768 
 2769   # check that the --exclude options do not conflict with the
 2770   # options --no-auto-remove, --no-auto-install, --reinstall-forcibly-removed
 2771   my @option_conflict_lines = ();
 2772   my $in_conflict = 0;
 2773   if (!$opts{"no-auto-remove"} && $config{"auto-remove"}) {
 2774     for my $pkg (keys %removals) {
 2775       for my $ep (@excluded_pkgs) {
 2776         if ($pkg eq $ep || $pkg =~ m/^$ep\./) {
 2777           push @option_conflict_lines, "$pkg: excluded but scheduled for auto-removal\n";
 2778           $in_conflict = 1;
 2779           last; # of the --exclude for loop
 2780         }
 2781       }
 2782     }
 2783   }
 2784   if (!$opts{"no-auto-install"}) {
 2785     for my $pkg (keys %newpkgs) {
 2786       for my $ep (@excluded_pkgs) {
 2787         if ($pkg eq $ep || $pkg =~ m/^$ep\./) {
 2788           push @option_conflict_lines, "$pkg: excluded but scheduled for auto-install\n";
 2789           $in_conflict = 1;
 2790           last; # of the --exclude for loop
 2791         }
 2792       }
 2793     }
 2794   }
 2795   if ($opts{"reinstall-forcibly-removed"}) {
 2796     for my $pkg (keys %forcermpkgs) {
 2797       for my $ep (@excluded_pkgs) {
 2798         if ($pkg eq $ep || $pkg =~ m/^$ep\./) {
 2799           push @option_conflict_lines, "$pkg: excluded but scheduled for reinstall\n";
 2800           $in_conflict = 1;
 2801           last; # of the --exclude for loop
 2802         }
 2803       }
 2804     }
 2805   }
 2806   if ($in_conflict) {
 2807     tlwarn("$prg: Conflicts have been found:\n");
 2808     for (@option_conflict_lines) { tlwarn("  $_"); }
 2809     tlwarn("$prg: Please resolve these conflicts!\n");
 2810     return ($F_ERROR);
 2811   }
 2812       
 2813   #
 2814   # we first collect the list of packages to be actually updated or installed
 2815   my %updated;
 2816   my @new;
 2817   my @addlines;
 2818 
 2819   TODO: foreach my $pkg (sort @todo) {
 2820     next if ($pkg =~ m/^00texlive/);
 2821     for my $ep (@excluded_pkgs) {
 2822       if ($pkg eq $ep || $pkg =~ m/^$ep\./) {
 2823         info("$prg: skipping excluded package: $pkg\n");
 2824         next TODO;
 2825       }
 2826     }
 2827     my $tlp = $localtlpdb->get_package($pkg);
 2828     if (!defined($tlp)) {
 2829       # if the user has forcibly removed (say) bin-makeindex, then the
 2830       # loop above has no way to add bin-makeindex.ARCH into the
 2831       # %forcermpkgs hash, but the .ARCH will still be in the dependency
 2832       # expansion.  So try both with and without the .ARCH extension.
 2833       (my $pkg_noarch = $pkg) =~ s/\.[^.]*$//;
 2834       my $forcerm_coll = $forcermpkgs{$pkg} || $forcermpkgs{$pkg_noarch};
 2835 
 2836       # similarly for new packages.  If latexmk is new, latexmk.ARCH
 2837       # will be in the dependency expansion, and we want it.
 2838       my $newpkg_coll = $newpkgs{$pkg} || $newpkgs{$pkg_noarch};
 2839       if ($forcerm_coll) {
 2840         if ($::machinereadable) {
 2841           # TODO should we add a revision number
 2842           push @addlines,
 2843             # $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv
 2844             machine_line("-ret", $pkg, $FLAG_FORCIBLE_REMOVED);
 2845         } else {
 2846           info("$prg: skipping forcibly removed package: $pkg\n");
 2847         }
 2848         next;
 2849       } elsif ($newpkg_coll) {
 2850         # do nothing here, it will be reported below.
 2851       } elsif (defined($removals{$pkg})) {
 2852         # skipping this package, it has been removed due to server removal
 2853         # and has already been removed
 2854         next;
 2855       } elsif (defined($new_due_to_forcerm_coll{$pkg})) {
 2856         debug("$prg: $pkg seems to be contained in a forcibly removed" .
 2857           " collection, not auto-installing it!\n");
 2858         next;
 2859       } else {
 2860         tlwarn("\n$prg: $pkg mentioned, but neither new nor forcibly removed");
 2861         tlwarn("\n$prg: perhaps try tlmgr search or tlmgr info.\n");
 2862         next;
 2863       }
 2864       # install new packages
 2865       my $mediatlp = $remotetlpdb->get_package($pkg);
 2866       if (!defined($mediatlp)) {
 2867         tlwarn("\n$prg: Should not happen: $pkg not found in $location\n");
 2868         $ret |= $F_WARNING;
 2869         next;
 2870       }
 2871       my $mediarev = $mediatlp->revision;
 2872       push @new, $pkg;
 2873       next;
 2874     }
 2875     my $rev = $tlp->revision;
 2876     my $lctanvers = $tlp->cataloguedata->{'version'};
 2877     my $mediatlp;
 2878     my $maxtag;
 2879     if ($remotetlpdb->is_virtual) {
 2880       ($maxtag, undef, $mediatlp, undef) =
 2881         $remotetlpdb->virtual_candidate($pkg);
 2882     } else {
 2883       $mediatlp = $remotetlpdb->get_package($pkg);
 2884     }
 2885     if (!defined($mediatlp)) {
 2886       ddebug("$pkg cannot be found in $location\n");
 2887       next;
 2888     }
 2889     my $rctanvers = $mediatlp->cataloguedata->{'version'};
 2890     my $mediarev = $mediatlp->revision;
 2891     my $mediarevstr = $mediarev;
 2892     my @addargs = ();
 2893     if ($remotetlpdb->is_virtual) {
 2894       push @addargs, $maxtag;
 2895       $mediarevstr .= "\@$maxtag";
 2896     } else {
 2897       push @addargs, undef;
 2898     }
 2899     push @addargs, $lctanvers, $rctanvers;
 2900     if ($rev < $mediarev) {
 2901       $updated{$pkg} = 0; # will be changed to one on successful update
 2902     } elsif ($rev > $mediarev) {
 2903       if ($::machinereadable) {
 2904         # $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv
 2905         push @addlines,
 2906           machine_line("-ret", $pkg, $FLAG_REVERSED_UPDATE, $rev, $mediarev, "-", "-", "-", @addargs);
 2907       } else {
 2908         if ($opts{"list"}) {
 2909           # not issuing anything if we keep a package
 2910           upd_info($pkg, -1, $rev, $mediarevstr, "keep");
 2911         }
 2912       }
 2913     }
 2914   }
 2915   my @updated = sort keys %updated;
 2916   for my $i (sort @new) {
 2917     debug("$i new package\n");
 2918   }
 2919   for my $i (@updated) {
 2920     debug("$i upd package\n");
 2921   }
 2922 
 2923   # number calculation
 2924   # without w32 special packages, those are dealt with in the updater batch
 2925   # script
 2926   my $totalnr = $#updated + 1;
 2927   my @alltodo = @updated;
 2928   my $nrupdated = 0;
 2929   my $currnr = 1;
 2930 
 2931   # we have to remove all the stuff before we install other packages
 2932   # to support moving of files from one package to another.
 2933   # remove the packages that have disappeared:
 2934   # we add that only to the list of total packages do be worked on
 2935   # when --all is given, because we remove packages only on --all
 2936   if (!$opts{"no-auto-remove"} && $config{"auto-remove"}) {
 2937     my @foo = keys %removals;
 2938     $totalnr += $#foo + 1;
 2939   }
 2940   if (!$opts{"no-auto-install"}) {
 2941     $totalnr += $#new + 1;
 2942     push @alltodo, @new;
 2943   }
 2944 
 2945   # sizes_of_packages returns the sizes of *all* packages if nothing
 2946   # is passed over, so if @new and @updated both are empty we will
 2947   # get something wrong back, namely the total size of all packages
 2948   # the third argument is undef to compute *all* platforms
 2949   my %sizes;
 2950   if (@alltodo) {
 2951     %sizes = %{$remotetlpdb->sizes_of_packages(
 2952       $localtlpdb->option("install_srcfiles"),
 2953       $localtlpdb->option("install_docfiles"), undef, @alltodo)};
 2954   } else {
 2955     $sizes{'__TOTAL__'} = 0;
 2956   }
 2957 
 2958   print "total-bytes\t$sizes{'__TOTAL__'}\n" if $::machinereadable;
 2959   print "end-of-header\n" if $::machinereadable;
 2960 
 2961   # print deferred machine-readable lines after the header
 2962   for (@addlines) { print; }
 2963 
 2964   #
 2965   # compute the list of moved files from %removals, @new, @updated
 2966   #
 2967   my %do_warn_on_move;
 2968   {
 2969     # keep all these vars local to this block
 2970     my @removals = keys %removals;
 2971     my %old_files_to_pkgs;
 2972     my %new_files_to_pkgs;
 2973     # first save for each file in the currently installed packages
 2974     # to be updated the packages it is contained it (might be more!)
 2975     #
 2976     # TODO WHY WHY is there the next so that all the file move checks
 2977     # are actually disabled?!?!?!
 2978     for my $p (@updated, @removals) {
 2979       my $pkg = $localtlpdb->get_package($p);
 2980       tlwarn("$prg: Should not happen: $p not found in local tlpdb\n") if (!$pkg);
 2981       next;
 2982       for my $f ($pkg->all_files) {
 2983         push @{$old_files_to_pkgs{$f}}, $p;
 2984       }
 2985     }
 2986     for my $p (@updated, @new) {
 2987       my $pkg = $remotetlpdb->get_package($p);
 2988       tlwarn("$prg: Should not happen: $p not found in $location\n") if (!$pkg);
 2989       next;
 2990       for my $f ($pkg->all_files) {
 2991         if ($pkg->relocated) {
 2992           $f =~ s:^$RelocPrefix/:$RelocTree/:;
 2993         }
 2994         push @{$new_files_to_pkgs{$f}}, $p;
 2995       }
 2996     }
 2997     #
 2998     # the idea of suppressing warnings is simply that if a file is present
 2999     # in more than one package either in the beginning or after a full 
 3000     # update then this should give a warning. In all other cases
 3001     # the warning should be suppressed.
 3002     for my $f (keys %old_files_to_pkgs) {
 3003       my @a = @{$old_files_to_pkgs{$f}};
 3004       $do_warn_on_move{$f} = 1 if ($#a > 0)
 3005     }
 3006     for my $f (keys %new_files_to_pkgs) {
 3007       my @a = @{$new_files_to_pkgs{$f}};
 3008       $do_warn_on_move{$f} = 1 if ($#a > 0)
 3009     }
 3010   }
 3011 
 3012   # parameters for field width
 3013   my $totalnrdigits = length("$totalnr");
 3014 
 3015   #
 3016   # ORDER OF PACKAGE ACTIONS
 3017   # 1. removals
 3018   # 2. updates
 3019   # 3. auto-install
 3020   # that way if a file has been moved from one to another package it
 3021   # removing the old version after the new package has been installed 
 3022   # will not give a warning about files being included somewhere else
 3023   #
 3024 
 3025   #
 3026   # REMOVALS
 3027   #
 3028   for my $p (keys %removals) {
 3029     if ($opts{"no-auto-remove"} || !$config{"auto-remove"}) {
 3030       info("not removing $p due to -no-auto-remove or config file option (removed on server)\n");
 3031     } else {
 3032       &ddebug("removing package $p\n");
 3033       my $pkg = $localtlpdb->get_package($p);
 3034       if (! $pkg) {
 3035         # This happened when a collection was removed by the user,
 3036         # and then renamed on the server, e.g., collection-langarab ->
 3037         # collection-langarabic; Luecking report 20 July 2009.
 3038         &ddebug(" get_package($p) failed, ignoring");
 3039         next;
 3040       }
 3041       my $rev = $pkg->revision;
 3042       my $lctanvers = $pkg->cataloguedata->{'version'};
 3043       if ($opts{"list"}) {
 3044         if ($::machinereadable) {
 3045           # $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv
 3046           machine_line($p, $FLAG_REMOVE, $rev, "-", "-", "-", "-", "-", $lctanvers);
 3047         } else {
 3048           upd_info($p, -1, $rev, "<absent>", "autorm");
 3049         }
 3050         $currnr++;
 3051       } else {
 3052         # new we are sure that:
 3053         # - $opts{"no-auto-remove"} is *not* set
 3054         # - $opts{"list"} is *not* set
 3055         # we have to check in addition that
 3056         # - $opts{"dry-run"} is not set
 3057         if ($::machinereadable) {
 3058           # $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv
 3059           machine_line($p, $FLAG_REMOVE, $rev, "-", "-", "-", "-", "-", $lctanvers);
 3060         } else {
 3061           info("[" . sprintf ('%*2$s', $currnr, $totalnrdigits) .
 3062             "/$totalnr] auto-remove: $p ... ");
 3063         }
 3064         if (!$opts{"dry-run"}) {
 3065           # older tlmgr forgot to clear the relocated bit when saving a tlpobj
 3066           # into the local tlpdb, although the paths were rewritten.
 3067           # We have to clear this bit otherwise the make_container calls below
 3068           # for creating the backup will create some rubbish!
 3069           # Same as further down in the update part!
 3070           if ($pkg->relocated) {
 3071             debug("$prg: warn, relocated bit set for $p, but that is wrong!\n");
 3072             $pkg->relocated(0);
 3073           }
 3074           # TODO we do not check return value here!
 3075           backup_and_remove_package($p, $autobackup);
 3076           logpackage("remove: $p");
 3077         }
 3078         info("done\n") unless $::machinereadable;
 3079         $currnr++;
 3080       }
 3081     }
 3082   }
 3083 
 3084 
 3085   my $starttime = time();
 3086   my $donesize = 0;
 3087   my $totalsize = $sizes{'__TOTAL__'};
 3088 
 3089 
 3090   # 
 3091   # UPDATES AND NEW PACKAGES
 3092   #
 3093   # order:
 3094   # - update normal packages
 3095   # - install new normal packages
 3096   # - update collections
 3097   # - install new collections
 3098   # - update schemes
 3099   # - install new schemes (? will not happen?)
 3100   #
 3101   # this makes sure that only if all depending packages are installed
 3102   # the collection is updated, which in turn makes sure that 
 3103   # if the installation of a new package does break it will not be
 3104   # counted as forcibly removed later on.
 3105   # 
 3106   my @inst_packs;
 3107   my @inst_colls;
 3108   my @inst_schemes;
 3109   for my $pkg (@updated) {
 3110     # we do name checking here, not to load all tlpobj again and again
 3111     if ($pkg =~ m/^scheme-/) {
 3112       push @inst_schemes, $pkg;
 3113     } elsif ($pkg =~ m/^collection-/) {
 3114       push @inst_colls, $pkg;
 3115     } else {
 3116       push @inst_packs, $pkg;
 3117     }
 3118   }
 3119   @inst_packs = sort packagecmp @inst_packs;
 3120 
 3121   my @new_packs;
 3122   my @new_colls;
 3123   my @new_schemes;
 3124   for my $pkg (sort @new) {
 3125     # we do name checking here, not to load all tlpobj again and again
 3126     if ($pkg =~ m/^scheme-/) {
 3127       push @new_schemes, $pkg;
 3128     } elsif ($pkg =~ m/^collection-/) {
 3129       push @new_colls, $pkg;
 3130     } else {
 3131       push @new_packs, $pkg;
 3132     }
 3133   }
 3134   @new_packs = sort packagecmp @new_packs;
 3135   my %is_new;
 3136   for my $pkg (@new_packs, @new_colls, @new_schemes) {
 3137     $is_new{$pkg} = 1;
 3138   }
 3139   
 3140   #
 3141   # TODO idea
 3142   # currently this big loop contains a long if then for new packages
 3143   # and updated package. That *could* be merged into one so that
 3144   # some things like the logging has not been written two times.
 3145   # OTOH, the control flow in the "new package" part is much simpler
 3146   # and following it after the change would make it much harder
 3147   #
 3148   foreach my $pkg (@inst_packs, @new_packs, @inst_colls, @new_colls, @inst_schemes, @new_schemes) {
 3149     
 3150     if (!$is_new{$pkg}) {
 3151       # skip this loop if infra update on w32
 3152       next if ($pkg =~ m/^00texlive/);
 3153       my $tlp = $localtlpdb->get_package($pkg);
 3154       # we checked already that this package is present!
 3155       # but our checks seem to be wrong, no idea why
 3156       # ahhh, it seems that it can happen due to a stupid incident, a bug
 3157       # on the server:
 3158       # - remove a package from a collection
 3159       # - at the same time increase its version number
 3160       # then what happens is:
 3161       # - first the package is removed (auto-remove!)
 3162       # - then it is tried to be updated here, which is not working!
 3163       # report that and ask for report
 3164       if (!defined($tlp)) {
 3165         my %servers = repository_to_array($location);
 3166         my $servers = join("\n ", values(%servers));
 3167         tlwarn("$prg: inconsistency on (one of) the server(s): $servers\n");
 3168         tlwarn("$prg: tlp for package $pkg cannot be found, please report.\n");
 3169         $ret |= $F_WARNING;
 3170         next;
 3171       }
 3172       my $unwind_package;
 3173       my $remove_unwind_container = 0;
 3174       my $rev = $tlp->revision;
 3175       my $lctanvers = $tlp->cataloguedata->{'version'};
 3176       my $mediatlp;
 3177       my $maxtag;
 3178       if ($remotetlpdb->is_virtual) {
 3179         ($maxtag, undef, $mediatlp, undef) =
 3180           $remotetlpdb->virtual_candidate($pkg);
 3181       } else {
 3182         $mediatlp = $remotetlpdb->get_package($pkg);
 3183       }
 3184       if (!defined($mediatlp)) {
 3185         debug("$pkg cannot be found in $location\n");
 3186         next;
 3187       }
 3188       my $rctanvers = $mediatlp->cataloguedata->{'version'};
 3189       my $mediarev = $mediatlp->revision;
 3190       my $mediarevstr = $mediarev;
 3191       my @addargs = ();
 3192       if ($remotetlpdb->is_virtual) {
 3193         push @addargs, $maxtag;
 3194         $mediarevstr .= "\@$maxtag";
 3195       } else {
 3196         push @addargs, undef;
 3197       }
 3198       push @addargs, $lctanvers, $rctanvers;
 3199       $nrupdated++;
 3200       if ($opts{"list"}) {
 3201         if ($::machinereadable) {
 3202           # $pkg, $flag, $lrev, $rrev, $size, $runtime, $esttot, $tag, $lcv, $rcv
 3203           machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg}, "-", "-", @addargs);
 3204         } else {
 3205           my $kb = int($sizes{$pkg} / 1024) + 1;
 3206           upd_info($pkg, $kb, $rev, $mediarevstr, "update");
 3207           if ($remotetlpdb->is_virtual) {
 3208             my @cand = $remotetlpdb->candidates($pkg);
 3209             shift @cand;  # remove the top element
 3210             if (@cand) {
 3211               print "\tother candidates: ";
 3212               for my $a (@cand) {
 3213                 my ($t,$r) = split(/\//, $a, 2);
 3214                 print $r . '@' . $t . " ";
 3215               }
 3216               print "\n";
 3217             }
 3218           }
 3219         }
 3220         $updated{$pkg} = 1;
 3221         next;
 3222       } elsif (win32() && ($pkg =~ m/$CriticalPackagesRegexp/)) {
 3223         # we pretend that the update happened
 3224         # in order to calculate file changes properly
 3225         $updated{$pkg} = 1;
 3226         next;
 3227       }
 3228       
 3229       # older tlmgr forgot to clear the relocated bit when saving a tlpobj
 3230       # into the local tlpdb, although the paths were rewritten. 
 3231       # We have to clear this bit otherwise the make_container calls below
 3232       # for creating an unwind container will create some rubbish
 3233       # TODO for user mode we should NOT clear this bit!
 3234       if ($tlp->relocated) {
 3235         debug("$prg: warn, relocated bit set for $pkg, but that is wrong!\n");
 3236         $tlp->relocated(0);
 3237       }
 3238 
 3239       if ($opts{"backup"} && !$opts{"dry-run"}) {
 3240         my $compressorextension = $Compressors{$::progs{'compressor'}}{'extension'};
 3241         $tlp->make_container($::progs{'compressor'}, $root,
 3242                              destdir => $opts{"backupdir"},
 3243                              relative => $tlp->relocated,
 3244                              user => 1);
 3245         $unwind_package =
 3246             "$opts{'backupdir'}/${pkg}.r" . $tlp->revision . ".tar.$compressorextension";
 3247         
 3248         if ($autobackup) {
 3249           # in case we do auto backups we remove older backups
 3250           clear_old_backups($pkg, $opts{"backupdir"}, $autobackup);
 3251         }
 3252       }
 3253       
 3254       my ($estrem, $esttot);
 3255       if (!$opts{"list"}) {
 3256         ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize,
 3257                                                              $donesize, $starttime);
 3258       }
 3259       
 3260       if ($::machinereadable) {
 3261         machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg}, $estrem, $esttot, @addargs);
 3262       } else {
 3263         my $kb = int ($sizes{$pkg} / 1024) + 1;
 3264         info("[" . sprintf ('%*2$s', $currnr, $totalnrdigits) .
 3265           "/$totalnr, $estrem/$esttot] update: $pkg [${kb}k] ($rev -> $mediarevstr)");
 3266       }
 3267       $donesize += $sizes{$pkg};
 3268       $currnr++;
 3269       
 3270       if ($opts{"dry-run"}) {
 3271         info("\n") unless $::machinereadable;
 3272         $updated{$pkg} = 1;
 3273         next;
 3274       } else {
 3275         info(" ... ") unless $::machinereadable;  # more to come
 3276       }
 3277       
 3278       if (!$unwind_package) {
 3279         # no backup was made, so let us create a temporary .tar file
 3280         # of the package
 3281         my $tlp = $localtlpdb->get_package($pkg);
 3282         my ($s, undef, $fullname) = $tlp->make_container("tar", $root,
 3283                          destdir => $temp,
 3284                          containername => "__BACKUP_${pkg}",
 3285                          relative => $tlp->relocated,
 3286                          user => 1);
 3287         if ($s <= 0) {
 3288           tlwarn("\n$prg: creation of backup container failed for: $pkg\n");
 3289           tlwarn("$prg: continuing to update other packages, please retry...\n");
 3290           $ret |= $F_WARNING;
 3291           # we should try to update other packages at least
 3292           next;
 3293         }
 3294         $remove_unwind_container = 1;
 3295         $unwind_package = "$fullname";
 3296       }
 3297       # first remove the package, then reinstall it
 3298       # this way we get rid of useless files
 3299       # force the deinstallation since we will reinstall it
 3300       #
 3301       # the remove_package should also remove empty dirs in case
 3302       # a dir is changed into a file
 3303       if ($pkg =~ m/$CriticalPackagesRegexp/) {
 3304         debug("Not removing critical package $pkg\n");
 3305       } else {
 3306         $localtlpdb->remove_package($pkg, 
 3307           "remove-warn-files" => \%do_warn_on_move);
 3308       }
 3309       if ($remotetlpdb->install_package($pkg, $localtlpdb)) {
 3310         # installation succeeded because we got a reference
 3311         logpackage("update: $pkg ($rev -> $mediarevstr)");
 3312         unlink($unwind_package) if $remove_unwind_container;
 3313         # remember successful update
 3314         $updated{$pkg} = 1;
 3315         #
 3316         # if we updated a .ARCH package we have to announce the postactions
 3317         # of the parent package so that formats are rebuild
 3318         if ($pkg =~ m/^([^.]*)\./) {
 3319           my $parent = $1;
 3320           if (!TeXLive::TLUtils::member($parent, @inst_packs, @new_packs, @inst_colls, @new_colls, @inst_schemes, @new_schemes)) {
 3321             # ok, nothing happens with the parent package, so we have to
 3322             # find it and execute the postactions
 3323             my $parentobj = $localtlpdb->get_package($parent);
 3324             if (!defined($parentobj)) {
 3325               # well, in this case we might have hit a package that only
 3326               # has .ARCH package, like psv.win32, so do nothing
 3327               debug("$prg: .ARCH package without parent, not announcing postaction\n");
 3328             } else {
 3329               debug("$prg: announcing parent execute action for $pkg\n");
 3330               TeXLive::TLUtils::announce_execute_actions("enable", $parentobj);
 3331             }
 3332           }
 3333         }
 3334       } else {
 3335         # install_package returned a scalar, so error.
 3336         # now in fact we should do some cleanup, removing files and
 3337         # dirs from the new package before re-installing the old one.
 3338         # TODO
 3339         logpackage("failed update: $pkg ($rev -> $mediarevstr)");
 3340         tlwarn("$prg: Installation of new version of $pkg failed, trying to unwind.\n");
 3341         if (win32()) {
 3342           # w32 is notorious for not releasing a file immediately
 3343           # we experienced permission denied errors
 3344           my $newname = $unwind_package;
 3345           $newname =~ s/__BACKUP/___BACKUP/;
 3346           copy ("-f", $unwind_package, $newname);
 3347           # try to remove the file if has been created by us
 3348           unlink($unwind_package) if $remove_unwind_container;
 3349           # and make sure that the temporary file is removed in any case
 3350           $remove_unwind_container = 1;
 3351           $unwind_package = $newname;
 3352         }
 3353 
 3354         # the -1 force the TLUtils::unpack to NOT warn about missing checksum/sizes
 3355         my ($instret, $msg) = TeXLive::TLUtils::unpack("$unwind_package",
 3356           $localtlpdb->root, checksum => "-1", checksize => "-1");
 3357         if ($instret) {
 3358           # now we have to include the tlpobj
 3359           my $tlpobj = TeXLive::TLPOBJ->new;
 3360           $tlpobj->from_file($root . "/tlpkg/tlpobj/$pkg.tlpobj");
 3361           $localtlpdb->add_tlpobj($tlpobj);
 3362           $localtlpdb->save;
 3363           logpackage("restore: $pkg ($rev)");
 3364           $ret |= $F_WARNING;
 3365           tlwarn("$prg: Restoring old package state succeeded.\n");
 3366         } else {
 3367           logpackage("failed restore: $pkg ($rev)");
 3368           tlwarn("$prg: Restoring of old package did NOT succeed.\n");
 3369           tlwarn("$prg: Error message from unpack: $msg\n");
 3370           tlwarn("$prg: Most likely repair: run tlmgr install $pkg and hope.\n");
 3371           # TODO_ERRORCHECKING
 3372           # should we return F_ERROR here??? If we would do this, then
 3373           # no postactions at all would run? Maybe better only to give
 3374           # a warning
 3375           $ret |= $F_WARNING;
 3376         }
 3377         unlink($unwind_package) if $remove_unwind_container;
 3378       }
 3379       info("done\n") unless $::machinereadable;
 3380     } else { # $is_new{$pkg} is true!!!
 3381       # 
 3382       # NEW PACKAGES
 3383       #
 3384       if ($opts{"no-auto-install"}) {
 3385         info("not auto-installing $pkg due to -no-auto-install (new on server)\n")
 3386             unless $::machinereadable;
 3387       } else {
 3388         # install new packages
 3389         my $mediatlp;
 3390         my $maxtag;
 3391         if ($remotetlpdb->is_virtual) {
 3392           ($maxtag, undef, $mediatlp, undef) =
 3393             $remotetlpdb->virtual_candidate($pkg);
 3394         } else {
 3395           $mediatlp = $remotetlpdb->get_package($pkg);
 3396         }
 3397         if (!defined($mediatlp)) {
 3398           tlwarn("\n$prg: Should not happen: $pkg not found in $location\n");
 3399           $ret |= $F_WARNING;
 3400           next;
 3401         }
 3402         my $mediarev = $mediatlp->revision;
 3403         my $mediarevstr = $mediarev;
 3404         my @addargs;
 3405         if ($remotetlpdb->is_virtual) {
 3406           $mediarevstr .= "\@$maxtag";
 3407           push @addargs, $maxtag;
 3408         }
 3409         my ($estrem, $esttot);
 3410         if (!$opts{"list"}) {
 3411           ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize,
 3412                                           $donesize, $starttime);
 3413         }
 3414         if ($::machinereadable) {
 3415           my @maargs = ($pkg, $FLAG_AUTOINSTALL, "-", $mediatlp->revision, $sizes{$pkg});
 3416           if (!$opts{"list"}) {
 3417             push @maargs, $estrem, $esttot;
 3418           } else {
 3419             push @maargs, undef, undef;
 3420           }
 3421           machine_line(@maargs, @addargs);
 3422         } else {
 3423           my $kb = int($sizes{$pkg} / 1024) + 1;
 3424           if ($opts{"list"}) {
 3425             upd_info($pkg, $kb, "<absent>", $mediarevstr, "autoinst");
 3426           } else {
 3427             info("[" . sprintf ('%*2$s', $currnr, $totalnrdigits) .
 3428               "/$totalnr, $estrem/$esttot] auto-install: $pkg ($mediarevstr) [${kb}k] ... ");
 3429           }
 3430         }
 3431         $currnr++;
 3432         $donesize += $sizes{$pkg};
 3433         next if ($opts{"dry-run"} || $opts{"list"});
 3434         if ($remotetlpdb->install_package($pkg, $localtlpdb)) {
 3435           # installation succeeded because we got a reference
 3436           logpackage("auto-install new: $pkg ($mediarevstr)");
 3437           $nrupdated++;
 3438           info("done\n") unless $::machinereadable;
 3439         } else {
 3440           tlwarn("$prg: couldn't install new package $pkg\n");
 3441         }
 3442       }
 3443     }
 3444   }
 3445 
 3446   #
 3447   # special check for depending format updates:
 3448   # if one of latex or tex has been updated, we rebuild the formats
 3449   # defined in packages *depending* on these packages.
 3450   check_announce_format_triggers(@inst_packs, @new_packs)
 3451     if (!$opts{"list"});
 3452 
 3453   print "end-of-updates\n" if $::machinereadable;
 3454 
 3455   #
 3456   # check that if updates to the critical packages are present all of
 3457   # them have been successfully updated
 3458   my $infra_update_done = 1;
 3459   my @infra_files_to_be_removed;
 3460   if ($opts{"list"}) {
 3461     $infra_update_done = 0;
 3462   } else {
 3463     for my $pkg (@critical) {
 3464       next unless (defined($updated{$pkg}));
 3465       $infra_update_done &&= $updated{$pkg};
 3466       my $oldtlp;
 3467       my $newtlp;
 3468       if ($updated{$pkg}) {
 3469         $oldtlp = $localtlpdb->get_package($pkg);
 3470         $newtlp = $remotetlpdb->get_package($pkg);
 3471       } else {
 3472         # update failed but we could introduce new files, that
 3473         # should be removed now as a part of restoring backup
 3474         $oldtlp = $remotetlpdb->get_package($pkg);
 3475         $newtlp = $localtlpdb->get_package($pkg);
 3476       }
 3477       die ("That shouldn't happen: $pkg not found in tlpdb") if !defined($newtlp);
 3478       die ("That shouldn't happen: $pkg not found in tlpdb") if !defined($oldtlp);
 3479       my @old_infra_files = $oldtlp->all_files;
 3480       my @new_infra_files = $newtlp->all_files;
 3481       my %del_files;
 3482       @del_files{@old_infra_files} = ();
 3483       delete @del_files{@new_infra_files};
 3484       for my $k (keys %del_files) {
 3485         my @found_pkgs = $localtlpdb->find_file($k);
 3486         if ($#found_pkgs >= 0) {
 3487           my $bad_file = 1;
 3488           if (win32()) {
 3489             # on w32 the packages have not been removed already,
 3490             # so we check that the only package listed in @found_pkgs
 3491             # is the one we are working on ($pkg)
 3492             if ($#found_pkgs == 0 && $found_pkgs[0] =~ m/^$pkg:/) {
 3493               # only one package has been returned and it
 3494               # matches the current package followed by a colon
 3495               # remember the TLPDB->find_file returns 
 3496               #   $pkg:$file
 3497               # in this case we can ignore it
 3498               $bad_file = 0;
 3499             }
 3500           }
 3501           if ($bad_file) {
 3502             tlwarn("$prg: The file $k has disappeared from the critical" .
 3503                    " package $pkg but is still present in @found_pkgs\n");
 3504             $ret |= $F_WARNING;
 3505           } else {
 3506             push @infra_files_to_be_removed, $k;
 3507           }
 3508         } else {
 3509           push @infra_files_to_be_removed, $k;
 3510         }
 3511       }
 3512     }
 3513 
 3514     if (!win32()) {
 3515       for my $f (@infra_files_to_be_removed) {
 3516         # TODO actually unlink the stuff
 3517         #unlink("$Master/$f");
 3518         debug("removing disappearing file $f\n");
 3519       }
 3520     } 
 3521   } # end of if ($opts{"list"}) ... else part
 3522 
 3523   # check if any additional updates are asked for
 3524   my $other_updates_asked_for = 0;
 3525   if ($opts{"all"}) {
 3526     $other_updates_asked_for = 1;
 3527   } else {
 3528     foreach my $p (@ARGV) {
 3529       if ($p !~ m/$CriticalPackagesRegexp/) {
 3530         $other_updates_asked_for = 1;
 3531         last;
 3532       }
 3533     }
 3534   }
 3535 
 3536   my $restart_tlmgr = 0;
 3537   if ($opts{"self"} && @critical && !$opts{'no-restart'} &&
 3538       $infra_update_done && $other_updates_asked_for) {
 3539     # weed out the --self argument from the saved arguments
 3540     @::SAVEDARGV = grep (!m/^-?-self$/, @::SAVEDARGV);
 3541     $restart_tlmgr = 1;
 3542   }
 3543 
 3544   # infra update and tlmgr restart on w32 is done by the updater batch script
 3545   if (win32() && $opts{'self'} && !$opts{"list"} && @critical) {
 3546     info("$prg: Preparing TeX Live infrastructure update...\n");
 3547     for my $f (@infra_files_to_be_removed) {
 3548       debug("file scheduled for removal $f\n");
 3549     }
 3550     my $ret = write_w32_updater($restart_tlmgr, 
 3551                                 \@infra_files_to_be_removed, @critical);
 3552     if ($ret) {
 3553       tlwarn ("$prg: Aborting infrastructure update.\n");
 3554       $ret |= $F_ERROR;
 3555       $restart_tlmgr = 0 if ($opts{"dry-run"});
 3556     }
 3557   }
 3558 
 3559   # only when we are not dry-running we restart the program
 3560   if (!win32() && $restart_tlmgr && !$opts{"dry-run"} && !$opts{"list"}) {
 3561     info("$prg: Restarting to complete update ...\n");
 3562     debug("restarting tlmgr @::SAVEDARGV\n");
 3563     # cleanup temp files before re-exec-ing tlmgr
 3564     File::Temp::cleanup();
 3565     exec("tlmgr", @::SAVEDARGV);
 3566     # we need warn here, otherwise perl gives warnings!
 3567     warn("$prg: cannot restart tlmgr, please retry update\n");
 3568     return($F_ERROR);
 3569   }
 3570 
 3571   # for --dry-run we cannot restart tlmgr (no way to fake successful 
 3572   # infra update) instead we call action_update() again and signal this 
 3573   # by $opts{"dry-run"} = -1
 3574   if ($opts{"dry-run"} && !$opts{"list"} && $restart_tlmgr) {
 3575     $opts{"self"} = 0;
 3576     $opts{"dry-run"} = -1;
 3577     $localtlpdb = undef;
 3578     $remotetlpdb = undef;
 3579     info ("$prg --dry-run: would restart tlmgr to complete update ...\n");
 3580     $ret |= action_update();
 3581     return ($ret);
 3582   }
 3583   
 3584   # if a real update from default disk location didn't find anything,
 3585   # warn if nothing is updated.  Unless they said --self, in which case
 3586   # we've already reported it.
 3587   # But if --self --all was given, and *no* update available for
 3588   # critical packages, then we should report it, too!
 3589   if (!(@new || @updated) && ( !$opts{"self"} || @todo )) {
 3590     if (!$::machinereadable) {
 3591       info("$prg: no updates available\n");
 3592       if ($remotetlpdb->media ne "NET"
 3593           && $remotetlpdb->media ne "virtual"
 3594           && !$opts{"dry-run"}
 3595           && !$opts{"repository"}
 3596           && !$ENV{"TEXLIVE_INSTALL_ENV_NOCHECK"}
 3597         ) {
 3598         tlwarn(<<END_DISK_WARN);
 3599 $prg: Your installation is set up to look on the disk for updates.
 3600 To install from the Internet for this one time only, run:
 3601   tlmgr -repository $TeXLiveURL ACTION ARG...
 3602 where ACTION is install, update, etc.; see tlmgr -help if needed.
 3603 
 3604 To change the default for all future updates, run:
 3605   tlmgr option repository $TeXLiveURL
 3606 END_DISK_WARN
 3607       }
 3608     }
 3609   }
 3610   return ($ret);
 3611 }
 3612 
 3613 
 3614 sub check_announce_format_triggers {
 3615   # we treat new and updated packages the same as updated 
 3616   # when it comes to triggers
 3617   my %updpacks = map { $_ => 1 } @_;
 3618 
 3619   # search all format definitions in the tlpdb
 3620   FMTDEF: for my $fmtdef ($localtlpdb->format_definitions) {
 3621     # if by default they are activated, check the whether the
 3622     # trigger packages appear in the list of updated/new packages
 3623     if (($fmtdef->{'mode'} == 1) && $fmtdef->{'fmttriggers'}) {
 3624       for my $trigger (@{$fmtdef->{'fmttriggers'}}) {
 3625         if ($updpacks{$trigger}) {
 3626           TeXLive::TLUtils::announce_execute_actions("rebuild-format",
 3627             0, $fmtdef);
 3628           next FMTDEF;
 3629         }
 3630       }
 3631     }
 3632   }
 3633 }
 3634 
 3635 #  INSTALL
 3636 #
 3637 # tlmgr install foo bar baz
 3638 #   will create the closure under dependencies of {foo,bar,baz}, i.e. all
 3639 #   dependencies recursively down to the last package, and install all
 3640 #   the packages that are necessary
 3641 #
 3642 # tlmgr install --no-depends foo bar baz
 3643 #   will *only* install these three packages (if they are not already installed
 3644 #   but it will STILL INSTALL foo.ARCH if they are necessary.
 3645 #
 3646 # tlmgr install --no-depends-at-all foo bar baz
 3647 #   will absolutely only install these three packages, and will not even
 3648 #   take .ARCH deps into account
 3649 #
 3650 # tlmgr install --reinstall ...
 3651 #   behaves exactly like without --reinstall BUT the following two
 3652 #   differences:
 3653 #   . dependencies are not expanded from collection to collection, so
 3654 #     if you reinstall a collection then all its dependencies of type
 3655 #     Package will be reinstalled, too, but not the dependencies on
 3656 #     other collection, because that would force the full reinstallation
 3657 #     of the whole installation
 3658 #   . it does not care for whether a package seems to be installed or
 3659 #     not (that is the --reinstall)
 3660 #
 3661 # TLPDB->install_package does ONLY INSTALL ONE PACKAGE, no deps whatsoever
 3662 # anymore!  That has all to be done by the caller.
 3663 #
 3664 sub action_install {
 3665   init_local_db(1);
 3666   my $ret = $F_OK;
 3667   return ($F_ERROR) if !check_on_writable();
 3668 
 3669   # installation from a .tar.xz
 3670   if ($opts{"file"}) {
 3671     if ($localtlpdb->install_package_files(@ARGV)) {
 3672       return ($ret);
 3673     } else {
 3674       return ($F_ERROR);
 3675     }
 3676   }
 3677 
 3678   # if we are still here, we are installing from some repository
 3679   # initialize the TLPDB from $location
 3680   $opts{"no-depends"} = 1 if $opts{"no-depends-at-all"};
 3681   init_tlmedia_or_die();
 3682 
 3683   # check for updates to tlmgr itself, and die unless --force is given
 3684   if (!$opts{"usermode"}) {
 3685     if (check_for_critical_updates( $localtlpdb, $remotetlpdb)) {
 3686       critical_updates_warning() if (!$::machinereadable);
 3687       if ($opts{"force"}) {
 3688         tlwarn("$prg: Continuing due to --force\n");
 3689       } else {
 3690         if ($::gui_mode) {
 3691           # return here and don't do any updates
 3692           return ($F_ERROR);
 3693         } else {
 3694           die "$prg: Terminating; please see warning above!\n";
 3695         }
 3696       }
 3697     }
 3698   }
 3699 
 3700   $opts{"no-depends"} = 1 if $opts{"no-depends-at-all"};
 3701   info("$prg install: dry run, no changes will be made\n") if $opts{"dry-run"};
 3702 
 3703   my @packs = @ARGV;
 3704   # first expand the .ARCH dependencies unless $opts{"no-depends-at-all"}
 3705   @packs = $remotetlpdb->expand_dependencies("-only-arch", $localtlpdb, @ARGV)
 3706     unless $opts{"no-depends-at-all"};
 3707   #
 3708   # if no-depends, we're done; else get rest of deps.
 3709   unless ($opts{"no-depends"}) {
 3710     if ($opts{"reinstall"} || $opts{"usermode"}) {
 3711       # if reinstall or usermode, omit collection->collection deps
 3712       @packs = $remotetlpdb->expand_dependencies("-no-collections",
 3713                                                  $localtlpdb, @packs);
 3714     } else {
 3715       @packs = $remotetlpdb->expand_dependencies($localtlpdb, @packs);
 3716     }
 3717   }
 3718   #
 3719   # expand dependencies returns a list pkg@tag in case of a virtual
 3720   # remote db.
 3721   my %packs;
 3722   for my $p (@packs) {
 3723     my ($pp, $aa) = split('@', $p);
 3724     $packs{$pp} = (defined($aa) ? $aa : 0);
 3725   }
 3726   #
 3727   # installation order of packages:
 3728   # first all normal packages, then collections, then schemes
 3729   # isn't already installed, but the collection already updated, it will
 3730   # be reported as forcibly removed.
 3731   my @inst_packs;
 3732   my @inst_colls;
 3733   my @inst_schemes;
 3734   for my $pkg (sort keys %packs) {
 3735     # we do name checking here, not to load all tlpobj again and again
 3736     if ($pkg =~ m/^scheme-/) {
 3737       push @inst_schemes, $pkg;
 3738     } elsif ($pkg =~ m/^collection-/) {
 3739       push @inst_colls, $pkg;
 3740     } else {
 3741       push @inst_packs, $pkg;
 3742     }
 3743   }
 3744   @inst_packs = sort packagecmp @inst_packs;
 3745 
 3746   my $starttime = time();
 3747   # count packages
 3748   my $totalnr = 0;
 3749   my %revs;
 3750   my @todo;
 3751   for my $pkg (@inst_packs, @inst_colls, @inst_schemes) {
 3752     my $pkgrev = 0;
 3753     # if the package name is asked from a specific repository, use
 3754     # that one, otherwise leave the  decision to $remotetlpdb by not
 3755     # giving a final argument
 3756     my $mediatlp = $remotetlpdb->get_package($pkg,
 3757       ($packs{$pkg} ? $packs{$pkg} : undef));
 3758     if (!defined($mediatlp)) {
 3759       tlwarn("$prg install: package $pkg not present in repository.\n");
 3760       $ret |= $F_WARNING;
 3761       next;
 3762     }
 3763     if (defined($localtlpdb->get_package($pkg))) {
 3764       if ($opts{"reinstall"}) {
 3765         $totalnr++;
 3766         $revs{$pkg} = $mediatlp->revision;
 3767         push @todo, $pkg;
 3768       } else {
 3769         # debug msg that we have this one.
 3770         debug("already installed: $pkg\n");
 3771         # if explicitly requested by user (not a dep), tell them.
 3772         info("$prg install: package already present: $pkg\n")
 3773           if grep { $_ eq $pkg } @ARGV;
 3774       }
 3775     } else {
 3776       $totalnr++;
 3777       $revs{$pkg} = $mediatlp->revision;
 3778       push (@todo, $pkg);
 3779     }
 3780   }
 3781   # return if there is nothing to install!
 3782   return ($ret) if (!@todo);
 3783 
 3784   my $orig_do_src = $localtlpdb->option("install_srcfiles");
 3785   my $orig_do_doc = $localtlpdb->option("install_docfiles");
 3786   if (!$opts{"dry-run"}) {
 3787     $localtlpdb->option("install_srcfiles", 1) if $opts{'with-src'};
 3788     $localtlpdb->option("install_docfiles", 1) if $opts{'with-doc'};
 3789   }
 3790 
 3791   my $currnr = 1;
 3792   # undef here is a ref to array of platforms, if undef all are used
 3793   my %sizes = %{$remotetlpdb->sizes_of_packages(
 3794     $localtlpdb->option("install_srcfiles"),
 3795     $localtlpdb->option("install_docfiles"), undef, @todo)};
 3796   defined($sizes{'__TOTAL__'}) || ($sizes{'__TOTAL__'} = 0);
 3797   my $totalsize = $sizes{'__TOTAL__'};
 3798   my $donesize = 0;
 3799   
 3800   print "total-bytes\t$sizes{'__TOTAL__'}\n" if $::machinereadable;
 3801   print "end-of-header\n" if $::machinereadable;
 3802 
 3803   foreach my $pkg (@todo) {
 3804     my $flag = $FLAG_INSTALL;
 3805     my $re = "";
 3806     my $tlp = $remotetlpdb->get_package($pkg);
 3807     my $rctanvers = $tlp->cataloguedata->{'version'};
 3808     if (!defined($tlp)) {
 3809       info("$prg: unknown package: $pkg\n");
 3810       next;
 3811     }
 3812     if (!$tlp->relocated && $opts{"usermode"}) {
 3813       info("$prg: package $pkg is not relocatable, cannot install it in user mode!\n");
 3814       next;
 3815     }
 3816     my $lctanvers;
 3817     if (defined($localtlpdb->get_package($pkg))) {
 3818       my $lctanvers = $localtlpdb->get_package($pkg)->cataloguedata->{'version'};
 3819       if ($opts{"reinstall"}) {
 3820         $re = "re";
 3821         $flag = $FLAG_REINSTALL;
 3822       } else {
 3823         debug("already installed (but didn't we say that already?): $pkg\n");
 3824         next;
 3825       }
 3826     }
 3827     my ($estrem, $esttot) = TeXLive::TLUtils::time_estimate($totalsize,
 3828                               $donesize, $starttime);
 3829     my $kb = int($sizes{$pkg} / 1024) + 1;
 3830     my @addargs = ();
 3831     my $tagstr = "";
 3832     if ($remotetlpdb->is_virtual) {
 3833       if ($packs{$pkg} ne "0") {
 3834         push @addargs, $packs{$pkg};
 3835         $tagstr = " \@" . $packs{$pkg};
 3836       } else {
 3837         my ($maxtag,undef,undef,undef) = $remotetlpdb->virtual_candidate($pkg);
 3838         push @addargs, $maxtag;
 3839         $tagstr = " \@" . $maxtag;
 3840       }
 3841     }
 3842     push @addargs, $lctanvers, $rctanvers;
 3843     if ($::machinereadable) {
 3844       machine_line($pkg, $flag, "-", $revs{$pkg}, $sizes{$pkg}, $estrem, $esttot, @addargs);
 3845     } else {
 3846       info("[$currnr/$totalnr, $estrem/$esttot] ${re}install: $pkg$tagstr [${kb}k]\n");
 3847     }
 3848     if (!$opts{"dry-run"}) {
 3849       if ($remotetlpdb->install_package($pkg, $localtlpdb,
 3850             ($packs{$pkg} ? $packs{$pkg} : undef) )) {
 3851         logpackage("${re}install: $pkg$tagstr");
 3852       } else {
 3853         logpackage("failed ${re}install: $pkg$tagstr");
 3854       }
 3855     }
 3856     $donesize += $sizes{$pkg};
 3857     $currnr++;
 3858   }
 3859   print "end-of-updates\n" if $::machinereadable;
 3860 
 3861 
 3862   if ($opts{"dry-run"}) {
 3863     # stop here, don't do any postinstall actions
 3864     return($ret | $F_NOPOSTACTION);
 3865   } else {
 3866     # reset option if --with-src argument was given
 3867     $localtlpdb->option("install_srcfiles", $orig_do_src) if $opts{'with-src'};
 3868     $localtlpdb->option("install_docfiles", $orig_do_doc) if $opts{'with-doc'};
 3869     $localtlpdb->save if ($opts{'with-src'} || $opts{'with-doc'});
 3870   }
 3871   return ($ret);
 3872 }
 3873 
 3874 sub show_one_package {
 3875   my ($pkg, $fmt, @rest) = @_;
 3876   my $ret;
 3877   if ($fmt eq "list") {
 3878     $ret = show_one_package_list($pkg, @rest);
 3879   } elsif ($fmt eq "detail") {
 3880     $ret = show_one_package_detail($pkg, @rest);
 3881   } elsif ($fmt eq "csv") {
 3882     $ret = show_one_package_csv($pkg, @rest);
 3883   } elsif ($fmt eq "json") {
 3884     $ret = show_one_package_json($pkg);
 3885   } else {
 3886     tlwarn("$prg: show_one_package: unknown format: $fmt\n");
 3887     return($F_ERROR);
 3888   }
 3889   return($ret);
 3890 }
 3891 
 3892 sub show_one_package_json {
 3893   my ($p) = @_;
 3894   my @out;
 3895   my $loctlp = $localtlpdb->get_package($p);
 3896   my $remtlp = $remotetlpdb->get_package($p);
 3897   my $is_installed = (defined($loctlp) ? 1 : 0);
 3898   my $is_available = (defined($remtlp) ? 1 : 0);
 3899   if (!($is_installed || $is_available)) {
 3900     # output proper JSON for unavailable packages
 3901     print "{ \"name\":\"$p\", \"available\":false }";
 3902     #tlwarn("$prg: package $p not found neither locally nor remote!\n");
 3903     #return($F_WARNING);
 3904     return($F_OK);
 3905   }
 3906   # prefer local TLPs as they have RELOC replaced by proper paths
 3907   my $tlp = ($is_installed ? $loctlp : $remtlp);
 3908   #my $tlp = ($is_available ? $remtlp : $loctlp);
 3909   # add available, installed, lrev, rrev fields and remove revision field
 3910   my $str = $tlp->as_json(available => ($is_available ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()), 
 3911                           installed => ($is_installed ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()),
 3912                           lrev      => ($is_installed ? $loctlp->revision : 0),
 3913                           rrev      => ($is_available ? $remtlp->revision : 0),
 3914                           revision  => undef);
 3915   print $str;
 3916   return($F_OK);
 3917 }
 3918 
 3919 
 3920 sub show_one_package_csv {
 3921   my ($p, @datafields) = @_;
 3922   my @out;
 3923   my $loctlp = $localtlpdb->get_package($p);
 3924   my $remtlp = $remotetlpdb->get_package($p) unless ($opts{'only-installed'});
 3925   my $is_installed = (defined($loctlp) ? 1 : 0);
 3926   my $is_available = (defined($remtlp) ? 1 : 0);
 3927   if (!($is_installed || $is_available)) {
 3928     if ($opts{'only-installed'}) {
 3929       tlwarn("$prg: package $p not locally!\n");
 3930     } else {
 3931       tlwarn("$prg: package $p not found neither locally nor remote!\n");
 3932     }
 3933     return($F_WARNING);
 3934   }
 3935   my $tlp = ($is_installed ? $loctlp : $remtlp);
 3936   for my $d (@datafields) {
 3937     if ($d eq "name") {
 3938       push @out, $p;
 3939     } elsif ($d eq "category") {
 3940       push @out, $tlp->category || "";
 3941     } elsif ($d eq "shortdesc") {
 3942       my $str = $tlp->shortdesc;
 3943        if (defined $tlp->shortdesc) {
 3944         $str =~ s/"/\\"/g;
 3945         push @out, "\"$str\"";
 3946       } else {
 3947         push @out, "";
 3948       }
 3949     } elsif ($d eq "longdesc") {
 3950       my $str = $tlp->longdesc;
 3951       if (defined $tlp->shortdesc) {
 3952         $str =~ s/"/\\"/g;
 3953         $str =~ s/\n/\\n/g;
 3954         push @out, "\"$str\"";
 3955       } else {
 3956         push @out, "";
 3957       }
 3958     } elsif ($d eq "installed") {
 3959       push @out, $is_installed;
 3960     } elsif ($d eq "relocatable") {
 3961       push @out, ($tlp->relocatable ? 1 : 0);
 3962     } elsif ($d eq "cat-version") {
 3963       push @out, ($tlp->cataloguedata->{'version'} || "");
 3964     } elsif ($d eq "cat-date") {
 3965       push @out, ($tlp->cataloguedata->{'date'} || "");
 3966     } elsif ($d eq "cat-license") {
 3967       push @out, ($tlp->cataloguedata->{'license'} || "");
 3968     } elsif ($d =~ m/^cat-(contact-.*)$/) {
 3969       push @out, ($tlp->cataloguedata->{$1} || "");
 3970     } elsif ($d eq "localrev") {
 3971       push @out, ($is_installed ? $loctlp->revision : 0);
 3972     } elsif ($d eq "remoterev") {
 3973       push @out, ($is_available ? $remtlp->revision : 0);
 3974     } elsif ($d eq "depends") {
 3975       push @out, (join(":", $tlp->depends));
 3976     } elsif ($d eq "size") {
 3977       # tlp->*size is in 4k blocks!
 3978       my $srcsize = $tlp->srcsize * $TeXLive::TLConfig::BlockSize;
 3979       my $docsize = $tlp->docsize * $TeXLive::TLConfig::BlockSize;
 3980       my $runsize = $tlp->runsize * $TeXLive::TLConfig::BlockSize;
 3981       my $binsize = 0;
 3982       my $binsizes = $tlp->binsize;
 3983       for my $a (keys %$binsizes) { $binsize += $binsizes->{$a} ; }
 3984       $binsize *= $TeXLive::TLConfig::BlockSize;
 3985       my $totalsize = $srcsize + $docsize + $runsize + $binsize;
 3986       push @out, $totalsize;
 3987     } else {
 3988       tlwarn("$prg: unknown data field $d\n");
 3989       return($F_WARNING);
 3990     }
 3991   }
 3992   print join(",", @out), "\n";
 3993   return($F_OK);
 3994 }
 3995 
 3996 sub show_one_package_list {
 3997   my ($p, @rest) = @_;
 3998   my @out;
 3999   my $loctlp = $localtlpdb->get_package($p);
 4000   my $remtlp = $remotetlpdb->get_package($p) unless ($opts{'only-installed'});
 4001   my $is_installed = (defined($loctlp) ? 1 : 0);
 4002   my $is_available = (defined($remtlp) ? 1 : 0);
 4003   if (!($is_installed || $is_available)) {
 4004     if ($opts{'only-installed'}) {
 4005       tlwarn("$prg: package $p not locally!\n");
 4006     } else {
 4007       tlwarn("$prg: package $p not found neither locally nor remote!\n");
 4008     }
 4009     return($F_WARNING);
 4010   }
 4011   my $tlp = ($is_installed ? $loctlp : $remtlp);
 4012   my $tlm;
 4013   if ($opts{"only-installed"}) {
 4014     $tlm = $localtlpdb;
 4015   } else {
 4016     $tlm = $remotetlpdb;
 4017   }
 4018   if ($is_installed) {
 4019     print "i ";
 4020   } else {
 4021     print "  ";
 4022   }
 4023   if (!$tlp) {
 4024     if ($remotetlpdb->is_virtual) {
 4025       # we might have the case that a package is present in a
 4026       # subsidiary repository, but not pinned, so it will
 4027       # not be found by ->get_package
 4028       # In this case we list all repositories shipping it,
 4029       # but warn that it is not pinned and thus not reachable.
 4030       my @cand = $remotetlpdb->candidates($p);
 4031       if (@cand) {
 4032         my $first = shift @cand;
 4033         if (defined($first)) {
 4034           tlwarn("$prg: strange, we have a first candidate but no tlp: $p\n");
 4035           return($F_WARNING);
 4036         }
 4037         # already shifted away the first element
 4038         if ($#cand >= 0) {
 4039           print "$p: --- no installable candidate found, \n";
 4040           print "    but present in subsidiary repositories without a pin.\n";
 4041           print "    This package is not reachable without pinning.\n";
 4042           print "    Repositories containing this package:\n";
 4043           for my $a (@cand) {
 4044             my ($t,$r) = split(/\//, $a, 2);
 4045             my $tlp = $remotetlpdb->get_package($p, $t);
 4046             my $foo = $tlp->shortdesc;
 4047             print "      $t: ", defined($foo) ? $foo : "(shortdesc missing)" , "\n";
 4048           }
 4049           return($F_WARNING);
 4050         } else {
 4051           tlwarn("$prg: strange, package listed but no residual candidates: $p\n");
 4052           return($F_WARNING);
 4053         }
 4054       } else {
 4055         tlwarn("$prg: strange, package listed but no candidates: $p\n");
 4056         return($F_WARNING);
 4057       }
 4058     } else {
 4059       tlwarn("$prg: strange, package cannot be found in remote tlpdb: $p\n");
 4060       return($F_WARNING);
 4061     }
 4062   }
 4063   my $foo = $tlp->shortdesc;
 4064   print "$p: ", defined($foo) ? $foo : "(shortdesc missing)" , "\n";
 4065   return($F_OK);
 4066 }
 4067 
 4068 sub show_one_package_detail {
 4069   my ($ppp, @rest) = @_;
 4070   my $ret = $F_OK;
 4071   my ($pkg, $tag) = split ('@', $ppp, 2);
 4072   my $tlpdb = $localtlpdb;
 4073   my $source_found;
 4074   my $tlp = $localtlpdb->get_package($pkg);
 4075   my $installed = 0;
 4076   if (!$tlp) {
 4077     if ($opts{"only-installed"}) {
 4078       print "package:     $pkg\n";
 4079       print "installed:   No\n";
 4080       return($F_OK);
 4081     }
 4082     if (!$remotetlpdb) {
 4083       init_tlmedia_or_die(1);
 4084     }
 4085     if (defined($tag)) {
 4086       if (!$remotetlpdb->is_virtual) {
 4087         tlwarn("$prg: specifying implicit tags not allowed for non-virtual databases!\n");
 4088         return($F_WARNING);
 4089       } else {
 4090         if (!$remotetlpdb->is_repository($tag)) {
 4091           tlwarn("$prg: no such repository tag defined: $tag\n");
 4092           return($F_WARNING);
 4093         }
 4094       }
 4095     }
 4096     $tlp = $remotetlpdb->get_package($pkg, $tag);
 4097     if (!$tlp) {
 4098       if (defined($tag)) {
 4099         # we already searched for the package in a specific tag, don't retry
 4100         # all candidates!
 4101         tlwarn("$prg: cannot find package $pkg in repository $tag\n");
 4102         return($F_WARNING);
 4103       }
 4104       my @cand = $remotetlpdb->candidates($pkg);
 4105       if (@cand) {
 4106         # if @cand is not empty, then we have a virtual database
 4107         # we might have a package that is available in a
 4108         # subsidiary repository, but not installable
 4109         # because it is not pinned
 4110         # we will list it but warn about this fact
 4111         # useless test, @cand will always be defined because $remotetlpdb is virtual
 4112         my $first = shift @cand;
 4113         if (defined($first)) {
 4114           tlwarn("$prg: strange, we have a first candidate but no tlp: $pkg\n");
 4115           return($F_WARNING);
 4116         }
 4117         # already shifted away the first element
 4118         if ($#cand >= 0) {
 4119           # recursively showing all tags, but warn
 4120           print "package:     ", $pkg, "\n";
 4121           print "WARNING:     This package is not pinned but present in subsidiary repositories\n";
 4122           print "WARNING:     As long as it is not pinned it is not installable.\n";
 4123           print "WARNING:     Listing all available copies of the package.\n";
 4124           my @aaa;
 4125           for my $a (@cand) {
 4126             my ($t,$r) = split(/\//, $a, 2);
 4127             push @aaa, "$pkg" . '@' . $t;
 4128           }
 4129           $ret |= action_info(@aaa);
 4130           return($ret);
 4131         }
 4132       }
 4133       # we didn't find a package like this, so use search
 4134       info("$prg: cannot find package $pkg, searching for other matches:\n");
 4135       my ($foundfile, $founddesc) = search_tlpdb($remotetlpdb,$pkg,1,1,0);
 4136       print "\nPackages containing \`$pkg\' in their title/description:\n";
 4137       print $founddesc;
 4138       print "\nPackages containing files matching \`$pkg\':\n";
 4139       print $foundfile;
 4140       return($ret);
 4141     }
 4142     # we want to also show the source if it is known
 4143     if (defined($tag)) {
 4144       $source_found = $tag;
 4145     } else {
 4146       if ($remotetlpdb->is_virtual) {
 4147         my ($firsttag, @cand) = $remotetlpdb->candidates($pkg);
 4148         $source_found = $firsttag;
 4149       } else {
 4150         # might be single user repository, don't mention anything
 4151       }
 4152     }
 4153     $tlpdb = $remotetlpdb;
 4154   } else {
 4155     $installed = 1;
 4156   }
 4157   my @colls;
 4158   if ($tlp->category ne "Collection" && $tlp->category ne "Scheme") {
 4159     @colls = $localtlpdb->needed_by($pkg);
 4160     if (!@colls) {
 4161       if (!$opts{"only-installed"}) {
 4162         # not referenced in the local tlpdb, so try the remote here, too
 4163         init_tlmedia_or_die() if (!$remotetlpdb);
 4164         @colls = $remotetlpdb->needed_by($pkg);
 4165       }
 4166     }
 4167   }
 4168   # {
 4169   #   require Data::Dumper;
 4170   #   print Data::Dumper->Dump([\$tlp], [qw(tlp)]);
 4171   # }
 4172   # some packages might depend on other packages, so do not
 4173   # include arbitrary packages in the list of collections, but
 4174   # only collections:
 4175   @colls = grep {m;^collection-;} @colls;
 4176   print "package:     ", $tlp->name, "\n";
 4177   print "repository:  ", $source_found, "\n" if (defined($source_found));
 4178   print "category:    ", $tlp->category, "\n";
 4179   print "shortdesc:   ", $tlp->shortdesc, "\n" if ($tlp->shortdesc);
 4180   print "longdesc:    ", $tlp->longdesc, "\n" if ($tlp->longdesc);
 4181   print "installed:   ", ($installed ? "Yes" : "No"), "\n";
 4182   print "revision:    ", $tlp->revision, "\n" if ($installed);
 4183   #
 4184   # size computation: for normal packages give src/run/doc/bin sizes
 4185   # for scheme/collection accumulated (including deps) sizes
 4186   my $sizestr = "";
 4187   if ($tlp->category ne "Collection" && $tlp->category ne "Scheme") {
 4188     my $srcsize = $tlp->srcsize * $TeXLive::TLConfig::BlockSize;
 4189     $sizestr = sprintf("%ssrc: %dk", $sizestr, int($srcsize / 1024) + 1) 
 4190       if ($srcsize > 0);
 4191     my $docsize = $tlp->docsize * $TeXLive::TLConfig::BlockSize;
 4192     $sizestr .= sprintf("%sdoc: %dk", 
 4193       ($sizestr ? ", " : ""), int($docsize / 1024) + 1)
 4194         if ($docsize > 0);
 4195     my $runsize = $tlp->runsize * $TeXLive::TLConfig::BlockSize;
 4196     $sizestr .= sprintf("%srun: %dk", 
 4197       ($sizestr ? ", " : ""), int($runsize / 1024) + 1)
 4198         if ($runsize > 0);
 4199     # check for .ARCH expansions
 4200     my $do_archs = 0;
 4201     for my $d ($tlp->depends) {
 4202       if ($d =~ m/^(.*)\.ARCH$/) {
 4203         $do_archs = 1;
 4204         last;
 4205       }
 4206     }
 4207     if ($do_archs) {
 4208       my @a = $localtlpdb->available_architectures;
 4209       my %binsz = %{$tlp->binsize};
 4210       my $binsize = 0;
 4211       for my $a (@a) {
 4212         $binsize += $binsz{$a} if defined($binsz{$a});
 4213         my $atlp = $tlpdb->get_package($tlp->name . ".$a");
 4214         if (!$atlp) {
 4215           tlwarn("$prg: cannot find depending package" . $tlp->name . ".$a\n");
 4216           return($F_WARNING);
 4217         }
 4218         my %abinsz = %{$atlp->binsize};
 4219         $binsize += $abinsz{$a} if defined($abinsz{$a});
 4220       }
 4221       $binsize *= $TeXLive::TLConfig::BlockSize;
 4222       $sizestr .= sprintf("%sbin: %dk",
 4223         ($sizestr ? ", " : ""), int($binsize / 1024) + 1)
 4224           if ($binsize > 0);
 4225     }
 4226   } else {
 4227     # case of collection or scheme
 4228     my $foo = $tlpdb->sizes_of_packages_with_deps ( 1, 1, undef, $pkg);
 4229     if (defined($foo->{$pkg})) {
 4230       $sizestr = sprintf("%dk", int($foo->{$pkg} / 1024) + 1);
 4231     }
 4232   }
 4233   print "sizes:       ", $sizestr, "\n";
 4234   print "relocatable: ", ($tlp->relocated ? "Yes" : "No"), "\n";
 4235   print "cat-version: ", $tlp->cataloguedata->{'version'}, "\n"
 4236     if $tlp->cataloguedata->{'version'};
 4237   print "cat-date:    ", $tlp->cataloguedata->{'date'}, "\n"
 4238     if $tlp->cataloguedata->{'date'};
 4239   print "cat-license: ", $tlp->cataloguedata->{'license'}, "\n"
 4240     if $tlp->cataloguedata->{'license'};
 4241   print "cat-topics:  ", $tlp->cataloguedata->{'topics'}, "\n"
 4242     if $tlp->cataloguedata->{'topics'};
 4243   print "cat-related: ", $tlp->cataloguedata->{'also'}, "\n"
 4244     if $tlp->cataloguedata->{'also'};
 4245   # print all the contact-* keys
 4246   for my $k (keys %{$tlp->cataloguedata}) {
 4247     if ($k =~ m/^contact-/) {
 4248       print "cat-$k: ", $tlp->cataloguedata->{$k}, "\n";
 4249     }
 4250   }
 4251   print "collection:  ", @colls, "\n" if (@colls);
 4252   if ($opts{"list"}) {
 4253     if ($tlp->category eq "Collection" || $tlp->category eq "Scheme") {
 4254       # in the case of collections of schemes we list the deps
 4255       my @deps = $tlp->depends;
 4256       if (@deps) {
 4257         print "depends:\n";
 4258         for my $d (@deps) {
 4259           print "\t$d\n";
 4260         }
 4261       }
 4262     }
 4263     print "Included files, by type:\n";
 4264     # if the package has a .ARCH dependency we also list the files for
 4265     # those packages
 4266     my @todo = $tlpdb->expand_dependencies("-only-arch", $tlpdb, ($pkg));
 4267     for my $d (sort @todo) {
 4268       my $foo = $tlpdb->get_package($d);
 4269       if (!$foo) {
 4270         tlwarn ("$prg: Should not happen, no dependent package $d\n");
 4271         return($F_WARNING);
 4272       }
 4273       if ($d ne $pkg) {
 4274         print "depending package $d:\n";
 4275       }
 4276       if ($foo->runfiles) {
 4277         print "run files:\n";
 4278         for my $f (sort $foo->runfiles) { print "  $f\n"; }
 4279       }
 4280       if ($foo->srcfiles) {
 4281         print "source files:\n";
 4282         for my $f (sort $foo->srcfiles) { print "  $f\n"; }
 4283       }
 4284       if ($foo->docfiles) {
 4285         print "doc files:\n";
 4286         for my $f (sort $foo->docfiles) {
 4287           print "  $f";
 4288           my $dfd = $foo->docfiledata;
 4289           if (defined($dfd->{$f})) {
 4290             for my $k (keys %{$dfd->{$f}}) {
 4291               print " $k=\"", $dfd->{$f}->{$k}, '"';
 4292             }
 4293           }
 4294           print "\n";
 4295         }
 4296       }
 4297       # in case we have them
 4298       if ($foo->allbinfiles) {
 4299         print "bin files (all platforms):\n";
 4300       for my $f (sort $foo->allbinfiles) { print " $f\n"; }
 4301       }
 4302     }
 4303   }
 4304   print "\n";
 4305   return($ret);
 4306 }
 4307 
 4308 #  PINNING
 4309 #
 4310 # this action manages the pinning file
 4311 # of course it can be edited by hand, but we want to make this
 4312 # easier for people to use
 4313 # tlmgr pinning show
 4314 # tlmgr pinning check
 4315 # tlmgr pinning add <repo> <pkgglob> [<pkgglob> ...]
 4316 # tlmgr pinning remove <repo> <pkgglob> [<pkgglob> ...]
 4317 # tlmgr pinning remove <repo> --all
 4318 sub action_pinning {
 4319   my $what = shift @ARGV;
 4320   $what || ($what = 'show');
 4321   init_local_db();
 4322   init_tlmedia_or_die();
 4323   if (!$remotetlpdb->is_virtual) {
 4324     tlwarn("$prg: only one repository configured, "
 4325            . "pinning actions not supported.\n");
 4326     return $F_WARNING;
 4327   }
 4328   my $pinref = $remotetlpdb->virtual_pindata();
 4329   my $pf = $remotetlpdb->virtual_pinning();
 4330 
 4331   if ($what =~ m/^show$/i) {
 4332     my @pins = @$pinref;
 4333     if (!@pins) {
 4334       tlwarn("$prg: no pinning data present.\n");
 4335       return $F_OK;
 4336     }
 4337     info("$prg: this pinning data is defined:\n");
 4338     for my $p (@pins) {
 4339       info("  ", $p->{'repo'}, ":", $p->{'glob'}, "\n");
 4340     }
 4341     return $F_OK;
 4342 
 4343   } elsif ($what =~ m/^check$/i) {
 4344     tlwarn("$prg: not implemented yet, sorry!\n");
 4345     return $F_WARNING;
 4346 
 4347   } elsif ($what =~ m/^add$/i) {
 4348     # we need at least two more arguments
 4349     if (@ARGV < 2) {
 4350       tlwarn("$prg: need at least two arguments to pinning add\n");
 4351       return $F_ERROR;
 4352     }
 4353     my $repo = shift @ARGV;
 4354     my @new = ();
 4355     my @ov = $pf->value($repo);
 4356     for my $n (@ARGV) {
 4357       if (member($n, @ov)) {
 4358         info("$prg: already pinned to $repo: $n\n");
 4359       } else {
 4360         push (@ov, $n);
 4361         push (@new, $n);
 4362       }
 4363     }
 4364     $pf->value($repo, @ov);
 4365     $remotetlpdb->virtual_update_pins();
 4366     $pf->save;
 4367     info("$prg: new pinning data for $repo: @new\n") if @new;
 4368     return $F_OK;
 4369 
 4370   } elsif ($what =~ m/^remove$/i) {
 4371     my $repo = shift @ARGV;
 4372     if (!defined($repo)) {
 4373       tlwarn("$prg: missing repository argument to pinning remove\n");
 4374       return $F_ERROR;
 4375     }
 4376     if ($opts{'all'}) {
 4377       if (@ARGV) {
 4378         tlwarn("$prg: additional argument(s) not allowed with --all: @ARGV\n");
 4379         return $F_ERROR;
 4380       }
 4381       $pf->delete_key($repo);
 4382       $remotetlpdb->virtual_update_pins();
 4383       $pf->save;
 4384       info("$prg: all pinning data removed for repository $repo\n");
 4385       return $F_OK;
 4386     }
 4387     # complicated case, we want to remove only one setting
 4388     my @ov = $pf->value($repo);
 4389     my @nv;
 4390     for my $pf (@ov) {
 4391       push (@nv, $pf) if (!member($pf, @ARGV));
 4392     }
 4393     if ($#ov == $#nv) {
 4394       info("$prg: no changes in pinning data for $repo\n");
 4395       return $F_OK;
 4396     }
 4397     if (@nv) {
 4398       $pf->value($repo, @nv);
 4399     } else {
 4400       $pf->delete_key($repo);
 4401     }
 4402     $remotetlpdb->virtual_update_pins();
 4403     $pf->save;
 4404     info("$prg: removed pinning data for repository $repo: @ARGV\n");
 4405     return $F_OK;
 4406 
 4407   } else {
 4408     tlwarn("$prg: unknown argument for pinning action: $what\n");
 4409     return $F_ERROR;
 4410   }
 4411   # $pin{'repo'} = $repo;
 4412   # $pin{'glob'} = $glob;
 4413   # $pin{'re'} = $re;
 4414   # $pin{'line'} = $line; # for debug/warning purpose
 4415   return $F_ERROR;
 4416 }
 4417 
 4418 #  REPOSITORY
 4419 #
 4420 # this action manages the list of repositories
 4421 # tlmgr repository list               -> lists repositories
 4422 # tlmgr repository list path|tag      -> lists content of repo path|tag
 4423 # tlmgr repository add path [tag]     -> add repository with optional tag
 4424 # tlmgr repository remove [path|tag]  -> removes repository or tag
 4425 # tlmgr repository set path[#tag] [path[#tag] ...] -> sets the list
 4426 #
 4427 
 4428 sub array_to_repository {
 4429   my %r = @_;
 4430   my @ret;
 4431   my @k = keys %r;
 4432   if ($#k == 0) {
 4433     # only one repo, don't write any tag
 4434     return $r{$k[0]};
 4435   }
 4436   for my $k (keys %r) {
 4437     my $v = $r{$k};
 4438     if ($k ne $v) {
 4439       $v = "$v#$k";
 4440     }
 4441     # encode spaces and % in the path and tags
 4442     $v =~ s/%/%25/g;
 4443     $v =~ s/ /%20/g;
 4444     push @ret, $v;
 4445   }
 4446   return "@ret";
 4447 }
 4448 sub merge_sub_packages {
 4449   my %pkgs;
 4450   for my $p (@_) {
 4451     if ($p =~ m/^(.*)\.([^.]*)$/) {
 4452       my $n = $1;
 4453       my $a = $2;
 4454       if ($p eq "texlive.infra") {
 4455         push @{$pkgs{$p}}, "all";
 4456       } else {
 4457         push @{$pkgs{$n}}, $a;
 4458       }
 4459     } else {
 4460       push @{$pkgs{$p}}, "all";
 4461     }
 4462   }
 4463   return %pkgs;
 4464 }
 4465 sub action_repository {
 4466   init_local_db();
 4467   my $what = shift @ARGV;
 4468   $what = "list" if !defined($what);
 4469   my %repos = repository_to_array($localtlpdb->option("location"));
 4470   if ($what =~ m/^list$/i) {
 4471     if (@ARGV) {
 4472       # list what is in a repository
 4473       for my $repo (@ARGV) {
 4474         my $loc = $repo;
 4475         if (defined($repos{$repo})) {
 4476           $loc = $repos{$repo};
 4477         }
 4478         my ($tlpdb, $errormsg) = setup_one_remotetlpdb($loc);
 4479         if (!defined($tlpdb)) {
 4480           tlwarn("$prg: cannot get TLPDB from location $loc\n\n");
 4481         } else {
 4482           print "Packages at $loc:\n";
 4483           my %pkgs = merge_sub_packages($tlpdb->list_packages);
 4484           for my $p (sort keys %pkgs) {
 4485             next if ($p =~ m/00texlive/);
 4486             print "  $p";
 4487             if (!$opts{'with-platforms'}) {
 4488               print "\n";
 4489             } else {
 4490               my @a = @{$pkgs{$p}};
 4491               if ($#a == 0) {
 4492                 if ($a[0] eq "all") {
 4493                   # no further information necessary
 4494                   print "\n";
 4495                 } else {
 4496                   print ".$a[0]\n";
 4497                 }
 4498               } else {
 4499                 print " (@{$pkgs{$p}})\n";
 4500               }
 4501             }
 4502           }
 4503         }
 4504       }
 4505     } else {
 4506       print "List of repositories (with tags if set):\n";
 4507       for my $k (keys %repos) {
 4508         my $v = $repos{$k};
 4509         print "\t$v";
 4510         if ($k ne $v) {
 4511           print " ($k)";
 4512         }
 4513         print "\n";
 4514       }
 4515     }
 4516     return ($F_OK);
 4517   }
 4518   if ($what eq "add") {
 4519     my $p