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