"Fossies" - the Fresh Open Source Software Archive 
Member "install-tl-20231204/tlpkg/TeXLive/TLUtils.pm" (15 Sep 2023, 158075 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 # $Id: TLUtils.pm 68283 2023-09-15 13:11:11Z preining $
2 # TeXLive::TLUtils.pm - the inevitable utilities for TeX Live.
3 # Copyright 2007-2023 Norbert Preining, Reinhard Kotucha
4 # This file is licensed under the GNU General Public License version 2
5 # or any later version.
6
7 use strict; use warnings;
8
9 package TeXLive::TLUtils;
10
11 my $svnrev = '$Revision: 68283 $';
12 my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
13 sub module_revision { return $_modulerevision; }
14
15 =pod
16
17 =head1 NAME
18
19 C<TeXLive::TLUtils> - TeX Live infrastructure miscellany
20
21 =head1 SYNOPSIS
22
23 use TeXLive::TLUtils;
24
25 =head2 Platform detection
26
27 TeXLive::TLUtils::platform();
28 TeXLive::TLUtils::platform_name($canonical_host);
29 TeXLive::TLUtils::platform_desc($platform);
30 TeXLive::TLUtils::wndws();
31 TeXLive::TLUtils::unix();
32
33 =head2 System tools
34
35 TeXLive::TLUtils::getenv($string);
36 TeXLive::TLUtils::which($string);
37 TeXLive::TLUtils::initialize_global_tmpdir();
38 TeXLive::TLUtils::tl_tmpdir();
39 TeXLive::TLUtils::tl_tmpfile();
40 TeXLive::TLUtils::xchdir($dir);
41 TeXLive::TLUtils::wsystem($msg,@args);
42 TeXLive::TLUtils::xsystem(@args);
43 TeXLive::TLUtils::run_cmd($cmd [, @envvars ]);
44 TeXLive::TLUtils::system_pipe($prog, $infile, $outfile, $removeIn, @args);
45 TeXLive::TLUtils::diskfree($path);
46 TeXLive::TLUtils::get_user_home();
47 TeXLive::TLUtils::expand_tilde($str);
48
49 =head2 File utilities
50
51 TeXLive::TLUtils::dirname($path);
52 TeXLive::TLUtils::basename($path);
53 TeXLive::TLUtils::dirname_and_basename($path);
54 TeXLive::TLUtils::tl_abs_path($path);
55 TeXLive::TLUtils::dir_writable($path);
56 TeXLive::TLUtils::dir_creatable($path);
57 TeXLive::TLUtils::mkdirhier($path);
58 TeXLive::TLUtils::rmtree($root, $verbose, $safe);
59 TeXLive::TLUtils::copy($file, $target_dir);
60 TeXLive::TLUtils::touch(@files);
61 TeXLive::TLUtils::collapse_dirs(@files);
62 TeXLive::TLUtils::all_dirs_and_removed_dirs(@files);
63 TeXLive::TLUtils::dirs_of_files(@files);
64 TeXLive::TLUtils::removed_dirs(@files);
65 TeXLive::TLUtils::download_file($path, $destination);
66 TeXLive::TLUtils::setup_programs($bindir, $platform);
67 TeXLive::TLUtils::tlcmp($file, $file);
68 TeXLive::TLUtils::nulldev();
69 TeXLive::TLUtils::get_full_line($fh);
70
71 =head2 Installer functions
72
73 TeXLive::TLUtils::make_var_skeleton($path);
74 TeXLive::TLUtils::make_local_skeleton($path);
75 TeXLive::TLUtils::create_fmtutil($tlpdb,$dest);
76 TeXLive::TLUtils::create_updmap($tlpdb,$dest);
77 TeXLive::TLUtils::create_language_dat($tlpdb,$dest,$localconf);
78 TeXLive::TLUtils::create_language_def($tlpdb,$dest,$localconf);
79 TeXLive::TLUtils::create_language_lua($tlpdb,$dest,$localconf);
80 TeXLive::TLUtils::time_estimate($totalsize, $donesize, $starttime)
81 TeXLive::TLUtils::install_packages($from_tlpdb,$media,$to_tlpdb,$what,$opt_src, $opt_doc, $retry, $continue);
82 TeXLive::TLUtils::do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script);
83 TeXLive::TLUtils::announce_execute_actions($how, @executes, $what);
84 TeXLive::TLUtils::add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info);
85 TeXLive::TLUtils::remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info);
86 TeXLive::TLUtils::w32_add_to_path($bindir, $multiuser);
87 TeXLive::TLUtils::w32_remove_from_path($bindir, $multiuser);
88 TeXLive::TLUtils::setup_persistent_downloads();
89
90 =head2 Logging and debugging
91
92 TeXLive::TLUtils::info($str1, ...); # output unless -q
93 TeXLive::TLUtils::debug($str1, ...); # output if -v
94 TeXLive::TLUtils::ddebug($str1, ...); # output if -vv
95 TeXLive::TLUtils::dddebug($str1, ...); # output if -vvv
96 TeXLive::TLUtils::log($str1, ...); # only to log file
97 TeXLive::TLUtils::tlwarn($str1, ...); # warn on stderr and log
98 TeXLive::TLUtils::tldie($str1, ...); # tlwarn and die
99 TeXLive::TLUtils::debug_hash_str($label, HASH); # stringified HASH
100 TeXLive::TLUtils::debug_hash($label, HASH); # warn stringified HASH
101 TeXLive::TLUtils::backtrace(); # return call stack as string
102 TeXLive::TLUtils::process_logging_options($texdir); # handle -q -v* -logfile
103
104 =head2 Miscellaneous
105
106 TeXLive::TLUtils::sort_uniq(@list);
107 TeXLive::TLUtils::push_uniq(\@list, @items);
108 TeXLive::TLUtils::member($item, @list);
109 TeXLive::TLUtils::merge_into(\%to, \%from);
110 TeXLive::TLUtils::texdir_check($texdir);
111 TeXLive::TLUtils::compare_tlpobjs($tlpA, $tlpB);
112 TeXLive::TLUtils::compare_tlpdbs($tlpdbA, $tlpdbB);
113 TeXLive::TLUtils::report_tlpdb_differences(\%ret);
114 TeXLive::TLUtils::tlnet_disabled_packages($root);
115 TeXLive::TLUtils::mktexupd();
116 TeXLive::TLUtils::setup_sys_user_mode($prg,$optsref,$tmfc,$tmfsc,$tmfv,$tmfsv);
117 TeXLive::TLUtils::prepend_own_path();
118 TeXLive::TLUtils::repository_to_array($str);
119
120 =head2 Windows and paths
121
122 TeXLive::TLUtils::quotify_path_with_spaces($path);
123 TeXLive::TLUtils::conv_to_w32_path($path);
124 TeXLive::TLUtils::native_slashify($internal_path);
125 TeXLive::TLUtils::forward_slashify($path_from_user);
126
127 =head2 CTAN
128
129 TeXLive::TLUtils::give_ctan_mirror();
130 TeXLive::TLUtils::give_ctan_mirror_base();
131
132 =head2 JSON
133
134 TeXLive::TLUtils::encode_json($ref);
135 TeXLive::TLUtils::True();
136 TeXLive::TLUtils::False();
137
138 =head1 DESCRIPTION
139
140 =cut
141
142 # avoid -warnings.
143 our $PERL_SINGLE_QUOTE; # we steal code from Text::ParseWords
144
145 # We use myriad global and package-global variables, unfortunately.
146 # To avoid "used only once" warnings, we must use the variable names again.
147 #
148 # This ugly repetition in the BEGIN block works with all Perl versions.
149 BEGIN {
150 $::LOGFILE = $::LOGFILE;
151 $::LOGFILENAME = $::LOGFILENAME;
152 @::LOGLINES = @::LOGLINES;
153 @::debug_hook = @::debug_hook;
154 @::ddebug_hook = @::ddebug_hook;
155 @::dddebug_hook = @::dddebug_hook;
156 @::info_hook = @::info_hook;
157 @::install_packages_hook = @::install_packages_hook;
158 @::installation_failed_packages = @::installation_failed_packages;
159 @::warn_hook = @::warn_hook;
160 $::checksum_method = $::checksum_method;
161 $::gui_mode = $::gui_mode;
162 $::machinereadable = $::machinereadable;
163 $::no_execute_actions = $::no_execute_actions;
164 $::regenerate_all_formats = $::regenerate_all_formats;
165 #
166 $JSON::false = $JSON::false;
167 $JSON::true = $JSON::true;
168 #
169 $TeXLive::TLDownload::net_lib_avail = $TeXLive::TLDownload::net_lib_avail;
170 }
171
172 ## A cleaner way is to use the "package PKGNAME BLOCK" syntax:
173 ## when providing a block to the package command, the scope is
174 ## limited to that block, so the current real package ends up unaffected.
175 ## Example in first reply to: https://perlmonks.org/?node_id=11139324
176 ## (Other solutions are also given there, but they don't work well in
177 ## our context here, although we use them elsewhere.)
178 ##
179 ## Unfortunately the package BLOCK syntax was invented for perl 5.14.0,
180 ## ca.2011, and OpenCSW on Solaris 10 only provides an older Perl. If we
181 ## ever drop Solaris 10 support, we can replace the above with this.
182 ##
183 #package main {
184 # our ($LOGFILE, $LOGFILENAME, @LOGLINES,
185 # @debug_hook, @ddebug_hook, @dddebug_hook, @info_hook,
186 # @install_packages_hook, @warn_hook,
187 # $checksum_method, $gui_mode, $machinereadable,
188 # $no_execute_actions, $regenerate_all_formats); }
189 #package JSON { our ($false, $true); }
190 #package TeXLive::TLDownload { our $net_lib_avail; }
191
192 BEGIN {
193 use Exporter ();
194 use vars qw(@ISA @EXPORT_OK @EXPORT);
195 @ISA = qw(Exporter);
196 @EXPORT_OK = qw(
197 &platform
198 &platform_name
199 &platform_desc
200 &unix
201 &getenv
202 &which
203 &initialize_global_tmpdir
204 &dirname
205 &basename
206 &dirname_and_basename
207 &tl_abs_path
208 &dir_writable
209 &dir_creatable
210 &mkdirhier
211 &rmtree
212 ©
213 &touch
214 &collapse_dirs
215 &all_dirs_and_removed_dirs
216 &dirs_of_files
217 &removed_dirs
218 &install_package
219 &install_packages
220 &make_var_skeleton
221 &make_local_skeleton
222 &create_fmtutil
223 &create_updmap
224 &create_language_dat
225 &create_language_def
226 &create_language_lua
227 &parse_AddFormat_line
228 &parse_AddHyphen_line
229 &sort_uniq
230 &push_uniq
231 &texdir_check
232 &member
233 "ewords
234 "ify_path_with_spaces
235 &conv_to_w32_path
236 &native_slashify
237 &forward_slashify
238 &untar
239 &unpack
240 &merge_into
241 &give_ctan_mirror
242 &give_ctan_mirror_base
243 &create_mirror_list
244 &extract_mirror_entry
245 &system_ok
246 &wsystem
247 &xsystem
248 &run_cmd
249 &system_pipe
250 &diskfree
251 &get_user_home
252 &expand_tilde
253 &announce_execute_actions
254 &add_symlinks
255 &remove_symlinks
256 &w32_add_to_path
257 &w32_remove_from_path
258 &tlcmp
259 &time_estimate
260 &compare_tlpobjs
261 &compare_tlpdbs
262 &report_tlpdb_differences
263 &setup_persistent_downloads
264 &mktexupd
265 &setup_sys_user_mode
266 &prepend_own_path
267 &nulldev
268 &get_full_line
269 &sort_archs
270 &repository_to_array
271 &encode_json
272 &True
273 &False
274 &SshURIRegex
275 );
276 @EXPORT = qw(setup_programs download_file process_logging_options
277 tldie tlwarn info log debug ddebug dddebug debug
278 debug_hash_str debug_hash
279 wndws xchdir xsystem run_cmd system_pipe sort_archs);
280 }
281
282 use Cwd;
283 use Getopt::Long;
284 use File::Temp;
285
286 use TeXLive::TLConfig;
287
288 $::opt_verbosity = 0; # see process_logging_options
289
290 our $SshURIRegex = '^((ssh|scp)://([^@]*)@([^/]*)/|([^@]*)@([^:]*):).*$';
291
292 =head2 Platform detection
293
294 =over 4
295
296 =item C<platform>
297
298 If C<$^O =~ /MSWin/i> is true we know that we're on
299 Windows and we set the global variable C<$::_platform_> to C<windows>.
300 Otherwise we call C<platform_name> with the output of C<config.guess>
301 as argument.
302
303 The result is stored in a global variable C<$::_platform_>, and
304 subsequent calls just return that value.
305
306 As of 2021, C<config.guess> unfortunately requires a shell that
307 understands the C<$(...)> construct. This means that on old-enough
308 systems, such as Solaris, we have to look for a shell. We use the value
309 of the C<CONFIG_SHELL> environment variable if it is set, else
310 C</bin/ksh> if it exists, else C</bin/bash> if it exists, else give up.
311 Happily, C<config.guess> later reverted this change, but we keep our
312 shell-finding code anyway to defend against future mistakes of the same ilk.
313
314 =cut
315
316 sub platform {
317 if (! defined $::_platform_) {
318 if ($^O =~ /^MSWin/i) {
319 # print STDERR "\$^O is $^O\n";
320 $::_platform_ = "windows";
321 } else {
322 my $config_guess = "$::installerdir/tlpkg/installer/config.guess";
323
324 # For example, if the disc or reader has hardware problems.
325 die "$0: config.guess script does not exist, goodbye: $config_guess"
326 if ! -r $config_guess;
327
328 # We cannot rely on #! in config.guess but have to call /bin/sh
329 # explicitly because sometimes the 'noexec' flag is set in
330 # /etc/fstab for ISO9660 file systems.
331 #
332 # In addition, config.guess was (unnecessarily) changed in 2020 by
333 # to use $(...) instead of `...`, although $(...) is not supported
334 # by Solaris /bin/sh (and others). The maintainers have declined
335 # to revert the change, so now every caller of config.guess must
336 # laboriously find a usable shell. Sigh.
337 #
338 my $config_shell = $ENV{"CONFIG_SHELL"} || "/bin/sh";
339 #
340 # check if $(...) is supported:
341 my $paren_cmdout = `'$config_shell' -c 'echo \$(echo foo)' 2>/dev/null`;
342 #warn "paren test out: `$paren_cmdout'.\n";
343 #
344 # The echo command might output a newline (maybe CRLF?) even if
345 # the $(...) fails, so don't just check for non-empty output.
346 # Maybe checking exit status would be better, but maybe not.
347 #
348 if (length ($paren_cmdout) <= 2) {
349 # if CONFIG_SHELL is set to something bad, give up.
350 if ($ENV{"CONFIG_SHELL"}) {
351 die <<END_BAD_CONFIG_SHELL;
352 $0: the CONFIG_SHELL environment variable is set to $ENV{CONFIG_SHELL}
353 but this cannot execute \$(...) shell constructs,
354 which is required. Set CONFIG_SHELL to something that works.
355 END_BAD_CONFIG_SHELL
356
357 } elsif (-x "/bin/ksh") {
358 $config_shell = "/bin/ksh";
359
360 } elsif (-x "/bin/bash") {
361 $config_shell = "/bin/bash";
362
363 } else {
364 die <<END_NO_PAREN_CMDS_SHELL
365 $0: can't find shell to execute $config_guess
366 (which gratuitously requires support for \$(...) command substitution).
367 Tried $config_shell, /bin/ksh, bin/bash.
368 Set the environment variable CONFIG_SHELL to specify explicitly.
369 END_NO_PAREN_CMDS_SHELL
370 }
371 }
372 #warn "executing config.guess with $config_shell\n";
373 chomp (my $guessed_platform = `'$config_shell' '$config_guess'`);
374
375 # If we didn't get anything usable, give up.
376 die "$0: could not run $config_guess, cannot proceed, sorry"
377 if ! $guessed_platform;
378
379 $::_platform_ = platform_name($guessed_platform);
380 }
381 }
382 return $::_platform_;
383 }
384
385
386 =item C<platform_name($canonical_host)>
387
388 Convert the C<$canonical_host> argument, a system description as
389 returned by C<config.guess>, into a TeX Live platform name, that is, a
390 name used as a subdirectory of our C<bin/> dir. Our names have the
391 form CPU-OS, for example, C<x86_64-linux>.
392
393 We need this because what's returned from C<config.,guess> does not
394 match our historical names, e.g., C<config.guess> returns C<linux-gnu>
395 but we need C<linux>.
396
397 The C<CPU> part of our name is always taken from the argument, with
398 various transformation.
399
400 For the C<OS> part, if the environment variable C<TEXLIVE_OS_NAME> is
401 set, it is used as-is. Otherwise we do our best to figure it out.
402
403 This function still handles old systems which are no longer supported,
404 just in case.
405
406 =cut
407
408 sub platform_name {
409 my ($orig_platform) = @_;
410 my $guessed_platform = $orig_platform;
411
412 # try to parse out some bsd variants that use amd64.
413 # We throw away everything after the "bsd" to elide version numbers,
414 # as in amd64-unknown-midnightbsd1.2.
415 $guessed_platform =~ s/^x86_64-(.*-k?)(free|net)bsd/amd64-$1$2bsd/;
416 my $CPU; # CPU type as reported by config.guess.
417 my $OS; # O/S type as reported by config.guess.
418 ($CPU = $guessed_platform) =~ s/(.*?)-.*/$1/;
419
420 $CPU =~ s/^alpha(.*)/alpha/; # alphaev whatever
421 $CPU =~ s/mips64el/mipsel/; # don't distinguish mips64 and 32 el
422 $CPU =~ s/powerpc64/powerpc/; # don't distinguish ppc64
423 $CPU =~ s/sparc64/sparc/; # don't distinguish sparc64
424
425 # armv6l-unknown-linux-gnueabihf -> armhf-linux (RPi)
426 # armv7l-unknown-linux-gnueabi -> armel-linux (Android)
427 if ($CPU =~ /^arm/) {
428 $CPU = $guessed_platform =~ /hf$/ ? "armhf" : "armel";
429 }
430
431 if ($ENV{"TEXLIVE_OS_NAME"}) {
432 $OS = $ENV{"TEXLIVE_OS_NAME"};
433 } else {
434 my @OSs = qw(aix cygwin darwin dragonfly freebsd hpux irix
435 kfreebsd linux midnightbsd netbsd openbsd solaris);
436 for my $os (@OSs) {
437 # Match word boundary at the beginning of the os name so that
438 # freebsd and kfreebsd are distinguished.
439 # Do not match word boundary at the end of the os so that
440 # solaris2 is matched.
441 $OS = $os if $guessed_platform =~ /\b$os/;
442 }
443 }
444
445 if (! $OS) {
446 warn "$0: could not guess OS from config.guess string: $orig_platform";
447 $OS = "unknownOS";
448 }
449
450 if ($OS eq "linux") {
451 # deal with the special case of musl based distributions
452 # config.guess returns
453 # x86_64-pc-linux-musl
454 # i386-pc-linux-musl
455 $OS = "linuxmusl" if $guessed_platform =~ /\blinux-musl/;
456 }
457
458 if ($OS eq "darwin") {
459 # We have two versions of Mac binary sets.
460 # 10.x and newer -> universal-darwin [MacTeX]
461 # 10.6/Snow Leopard through 10.x -> x86_64-darwinlegacy, if 64-bit.
462 # x changes every year. As of TL 2021 (Big Sur) Apple started with 11.x.
463 #
464 # (BTW, uname -r numbers are larger by 4 than the Mac minor version.
465 # We don't use uname numbers here.)
466 #
467 # this changes each year, per above:
468 my $mactex_darwin = 14; # lowest minor rev supported by universal-darwin.
469 #
470 # Most robust approach is apparently to check sw_vers (os version,
471 # returns "10.x" values), and sysctl (processor hardware).
472 chomp (my $sw_vers = `sw_vers -productVersion`);
473 my ($os_major,$os_minor) = split (/\./, $sw_vers);
474 if ($os_major < 10) {
475 warn "$0: only MacOSX is supported, not $OS $os_major.$os_minor "
476 . " (from sw_vers -productVersion: $sw_vers)\n";
477 return "unknownmac-unknownmac";
478 }
479 # have to refine after all 10.x become "legacy".
480 if ($os_major >= 11 || $os_minor >= $mactex_darwin) {
481 $CPU = "universal";
482 $OS = "darwin";
483 } elsif ($os_major == 10 && 6 <= $os_minor && $os_minor < $mactex_darwin){
484 # in between, x86 hardware only. On 10.6 only, must check if 64-bit,
485 # since if later than that, always 64-bit.
486 my $is64 = $os_minor == 6
487 ? `/usr/sbin/sysctl -n hw.cpu64bit_capable` >= 1
488 : 1;
489 if ($is64) {
490 $CPU = "x86_64";
491 $OS = "darwinlegacy";
492 } # if not 64-bit, default is ok (i386-darwin).
493 } else {
494 ; # older version, default is ok (i386-darwin, powerpc-darwin).
495 }
496
497 } elsif ($CPU =~ /^i.86$/) {
498 $CPU = "i386"; # 586, 686, whatever
499 }
500
501 if (! defined $OS) {
502 ($OS = $guessed_platform) =~ s/.*-(.*)/$1/;
503 }
504
505 return "$CPU-$OS";
506 }
507
508 =item C<platform_desc($platform)>
509
510 Return a string which describes a particular platform identifier, e.g.,
511 given C<i386-linux> we return C<Intel x86 with GNU/Linux>.
512
513 =cut
514
515 sub platform_desc {
516 my ($platform) = @_;
517
518 my %platform_name = (
519 'aarch64-linux' => 'GNU/Linux on ARM64',
520 'alpha-linux' => 'GNU/Linux on DEC Alpha',
521 'amd64-freebsd' => 'FreeBSD on x86_64',
522 'amd64-kfreebsd' => 'GNU/kFreeBSD on x86_64',
523 'amd64-midnightbsd'=> 'MidnightBSD on x86_64',
524 'amd64-netbsd' => 'NetBSD on x86_64',
525 'armel-linux' => 'GNU/Linux on ARM',
526 'armhf-linux' => 'GNU/Linux on RPi(32-bit) and ARMv7',
527 'hppa-hpux' => 'HP-UX',
528 'i386-cygwin' => 'Cygwin on Intel x86',
529 'i386-darwin' => 'MacOSX legacy (10.5-10.6) on Intel x86',
530 'i386-freebsd' => 'FreeBSD on Intel x86',
531 'i386-kfreebsd' => 'GNU/kFreeBSD on Intel x86',
532 'i386-linux' => 'GNU/Linux on Intel x86',
533 'i386-linuxmusl' => 'GNU/Linux on Intel x86 with musl',
534 'i386-netbsd' => 'NetBSD on Intel x86',
535 'i386-openbsd' => 'OpenBSD on Intel x86',
536 'i386-solaris' => 'Solaris on Intel x86',
537 'mips-irix' => 'SGI IRIX',
538 'mipsel-linux' => 'GNU/Linux on MIPSel',
539 'powerpc-aix' => 'AIX on PowerPC',
540 'powerpc-darwin' => 'MacOSX legacy (10.5) on PowerPC',
541 'powerpc-linux' => 'GNU/Linux on PowerPC',
542 'sparc-linux' => 'GNU/Linux on Sparc',
543 'sparc-solaris' => 'Solaris on Sparc',
544 'universal-darwin' => 'MacOSX current (10.14-) on ARM/x86_64',
545 'win32' => 'Windows (32-bit)',
546 'windows' => 'Windows (64-bit)',
547 'x86_64-cygwin' => 'Cygwin on x86_64',
548 'x86_64-darwinlegacy' => 'MacOSX legacy (10.6-) on x86_64',
549 'x86_64-dragonfly' => 'DragonFlyBSD on x86_64',
550 'x86_64-linux' => 'GNU/Linux on x86_64',
551 'x86_64-linuxmusl' => 'GNU/Linux on x86_64 with musl',
552 'x86_64-solaris' => 'Solaris on x86_64',
553 );
554
555 # the inconsistency between amd64-freebsd and x86_64-linux is
556 # unfortunate (it's the same hardware), but the os people say those
557 # are the conventional names on the respective os's, so we follow suit.
558
559 if (exists $platform_name{$platform}) {
560 return "$platform_name{$platform}";
561 } else {
562 my ($CPU,$OS) = split ('-', $platform);
563 $OS = "" if ! defined $OS; # e.g., -force-platform foo
564 return "$CPU with " . ucfirst "$OS";
565 }
566 }
567
568
569 =item C<wndws>
570
571 Return C<1> if platform is Windows and C<0> otherwise. The test is
572 currently based on the value of Perl's C<$^O> variable.
573
574 =cut
575
576 sub wndws {
577 if ($^O =~ /^MSWin/i) {
578 return 1;
579 } else {
580 return 0;
581 }
582 # the following needs config.guess, which is quite bad ...
583 # return (&platform eq "windows")? 1:0;
584 }
585
586
587 =item C<unix>
588
589 Return C<1> if platform is UNIX and C<0> otherwise.
590
591 =cut
592
593 sub unix {
594 return (&platform eq "windows")? 0:1;
595 }
596
597
598 =back
599
600 =head2 System Tools
601
602 =over 4
603
604 =item C<getenv($string)>
605
606 Get an environment variable. It is assumed that the environment
607 variable contains a path. On Windows all backslashes are replaced by
608 forward slashes as required by Perl. If this behavior is not desired,
609 use C<$ENV{"$variable"}> instead. C<0> is returned if the
610 environment variable is not set.
611
612 =cut
613
614 sub getenv {
615 my $envvar=shift;
616 my $var=$ENV{"$envvar"};
617 return 0 unless (defined $var);
618 if (&wndws) {
619 $var=~s!\\!/!g; # change \ -> / (required by Perl)
620 }
621 return "$var";
622 }
623
624
625 =item C<which($string)>
626
627 C<which> does the same as the UNIX command C<which(1)>, but it is
628 supposed to work on Windows too. On Windows we have to try all the
629 extensions given in the C<PATHEXT> environment variable. We also try
630 without appending an extension because if C<$string> comes from an
631 environment variable, an extension might already be present.
632
633 =cut
634
635 sub which {
636 my ($prog) = @_;
637 my @PATH;
638 my $PATH = getenv('PATH');
639
640 if (&wndws) {
641 my @PATHEXT = split (';', getenv('PATHEXT'));
642 push (@PATHEXT, ''); # in case argument contains an extension
643 @PATH = split (';', $PATH);
644 for my $dir (@PATH) {
645 for my $ext (@PATHEXT) {
646 if (-f "$dir/$prog$ext") {
647 return "$dir/$prog$ext";
648 }
649 }
650 }
651
652 } else { # not windows
653 @PATH = split (':', $PATH);
654 for my $dir (@PATH) {
655 if (-x "$dir/$prog") {
656 return "$dir/$prog";
657 }
658 }
659 }
660 return 0;
661 }
662
663 =item C<initialize_global_tmpdir();>
664
665 Initializes a directory for all temporary files. This uses C<File::Temp>
666 and thus honors various env variables like C<TMPDIR>, C<TMP>, and C<TEMP>.
667
668 =cut
669
670 sub initialize_global_tmpdir {
671 $::tl_tmpdir = File::Temp::tempdir(CLEANUP => 1);
672 ddebug("TLUtils::initialize_global_tmpdir: creating global tempdir $::tl_tmpdir\n");
673 return ($::tl_tmpdir);
674 }
675
676 =item C<tl_tmpdir>
677
678 Create a temporary directory which is removed when the program
679 is terminated.
680
681 =cut
682
683 sub tl_tmpdir {
684 initialize_global_tmpdir() if (!defined($::tl_tmpdir));
685 my $tmp = File::Temp::tempdir(DIR => $::tl_tmpdir, CLEANUP => 1);
686 ddebug("TLUtils::tl_tmpdir: creating tempdir $tmp\n");
687 return ($tmp);
688 }
689
690 =item C<tl_tmpfile>
691
692 Create a temporary file which is removed when the program
693 is terminated. Returns file handle and file name.
694 Arguments are passed on to C<File::Temp::tempfile>.
695
696 =cut
697
698 sub tl_tmpfile {
699 initialize_global_tmpdir() if (!defined($::tl_tmpdir));
700 my ($fh, $fn) = File::Temp::tempfile(@_, DIR => $::tl_tmpdir, UNLINK => 1);
701 ddebug("TLUtils::tl_tempfile: creating tempfile $fn\n");
702 return ($fh, $fn);
703 }
704
705
706 =item C<xchdir($dir)>
707
708 C<chdir($dir)> or die.
709
710 =cut
711
712 sub xchdir {
713 my ($dir) = @_;
714 chdir($dir) || die "$0: chdir($dir) failed: $!";
715 ddebug("xchdir($dir) ok\n");
716 }
717
718 =item C<system_ok($cmdline)>
719
720 Run C<system($cmdline)> and return true if return status was zero, false
721 if status was nonzero. Throw away stdout and stderr.
722
723 =cut
724
725 sub system_ok {
726 my $nulldev = nulldev();
727 my ($cmdline) = @_;
728 `$cmdline >$nulldev 2>&1`;
729 return $? == 0;
730 }
731
732 =item C<wsystem($msg, @args)>
733
734 Call C<info> about what is being done starting with C<$msg>, then run
735 C<system(@args)>; C<tlwarn> if unsuccessful and return the exit status.
736
737 =cut
738
739 sub wsystem {
740 my ($msg,@args) = @_;
741 info("$msg @args ...\n");
742 my $retval = system(@args);
743 if ($retval != 0) {
744 $retval /= 256 if $retval > 0;
745 tlwarn("$0: command failed (status $retval): @args: $!\n");
746 }
747 return $retval;
748 }
749
750
751 =item C<xsystem(@args)>
752
753 Call C<ddebug> about what is being done, then run C<system(@args)>, and
754 die if unsuccessful.
755
756 =cut
757
758 sub xsystem {
759 my (@args) = @_;
760 ddebug("running system(@args)\n");
761 my $retval = system(@args);
762 if ($retval != 0) {
763 $retval /= 256 if $retval > 0;
764 my $pwd = cwd ();
765 die "$0: system(@args) failed in $pwd, status $retval";
766 }
767 return $retval;
768 }
769
770 =item C<run_cmd($cmd, @envvars)>
771
772 Run shell command C<$cmd> and captures its output. Returns a list with CMD's
773 output as the first element and the return value (exit code) as second.
774
775 If given, C<@envvars> is a list of environment variable name / value
776 pairs set in C<%ENV> for the call and reset to their original value (or
777 unset if not defined initially).
778
779 =cut
780
781 sub run_cmd {
782 my $cmd = shift;
783 my %envvars = @_;
784 my %envvarsSetState;
785 my %envvarsValue;
786 for my $k (keys %envvars) {
787 $envvarsSetState{$k} = exists $ENV{$k};
788 $envvarsValue{$k} = $ENV{$k};
789 $ENV{$k} = $envvars{$k};
790 }
791 my $output = `$cmd`;
792 for my $k (keys %envvars) {
793 if ($envvarsSetState{$k}) {
794 $ENV{$k} = $envvarsValue{$k};
795 } else {
796 delete $ENV{$k};
797 }
798 }
799
800 $output = "" if ! defined ($output); # don't return undef
801
802 my $retval = $?;
803 if ($retval != 0) {
804 $retval /= 256 if $retval > 0;
805 }
806 return ($output,$retval);
807 }
808
809 =item C<system_pipe($prog, $infile, $outfile, $removeIn, @extraargs)>
810
811 Runs C<$prog> with C<@extraargs> redirecting stdin from C<$infile>,
812 stdout to C<$outfile>. Removes C<$infile> if C<$removeIn> is true.
813
814 =cut
815
816 sub system_pipe {
817 my ($prog, $infile, $outfile, $removeIn, @extraargs) = @_;
818
819 my $progQuote = quotify_path_with_spaces($prog);
820 if (wndws()) {
821 $infile =~ s!/!\\!g;
822 $outfile =~ s!/!\\!g;
823 }
824 my $infileQuote = "\"$infile\"";
825 my $outfileQuote = "\"$outfile\"";
826 debug("TLUtils::system_pipe: calling $progQuote @extraargs < $infileQuote > $outfileQuote\n");
827 my $retval = system("$progQuote @extraargs < $infileQuote > $outfileQuote");
828 if ($retval != 0) {
829 $retval /= 256 if $retval > 0;
830 debug("TLUtils::system_pipe: system exit code = $retval\n");
831 return 0;
832 } else {
833 if ($removeIn) {
834 debug("TLUtils::system_pipe: removing $infile\n");
835 unlink($infile);
836 }
837 return 1;
838 }
839 }
840
841 =item C<diskfree($path)>
842
843 If a POSIX compliant C<df> program is found, returns the number of Mb
844 free at C<$path>, otherwise C<-1>. If C<$path> does not exist, check
845 upwards for two levels for an existing parent, and if found, use it for
846 computing the disk space.
847
848 =cut
849
850 sub diskfree {
851 my $td = shift;
852 my ($output, $retval);
853 if (wndws()) {
854 # the powershell one-liner only works from win8 on.
855 my @winver = Win32::GetOSVersion();
856 if ($winver[1]<=6 && $winver[2]<=1) {
857 return -1;
858 }
859 my $avl;
860 if ($td =~ /^[a-zA-Z]:/) {
861 my $drv = substr($td,0,1);
862 # ea ignore: error action ignore: no output at all
863 my $cmd = "powershell -nologo -noninteractive -noprofile -command " .
864 "\"get-psdrive -name $drv -ea ignore |select-object free |format-wide\"";
865 ($output, $retval) = run_cmd($cmd);
866 # ignore exit code, just parse the output, which should
867 # consist of empty lines and a number surrounded by spaces
868 my @lines = split(/\r*\n/, $output);
869 foreach (@lines) {
870 chomp $_;
871 if ($_ !~ /^\s*$/) {
872 $_ =~ s/^\s*//;
873 $_ =~ s/\s*$//;
874 $avl = $_;
875 last;
876 }
877 }
878 if ($avl !~ /^[0-9]+$/) {
879 return (-1);
880 } else {
881 return (int($avl/(1024*1024)));
882 }
883 } else {
884 # maybe UNC drive; do not try to handle this
885 return -1;
886 }
887 }
888 # now windows case has been taken care of
889 return (-1) if (! $::progs{"df"});
890 # drop final /
891 $td =~ s!/$!!;
892 if (! -e $td) {
893 my $ptd = dirname($td);
894 if (-e $ptd) {
895 $td = $ptd;
896 } else {
897 my $pptd = dirname($ptd);
898 if (-e $pptd) {
899 $td = $pptd;
900 }
901 }
902 }
903 $td .= "/" if ($td !~ m!/$!);
904 return (-1) if (! -e $td);
905 debug("checking diskfree() in $td\n");
906 ($output, $retval) = run_cmd("df -Pk \"$td\"");
907 # With -k (mandated by POSIX), we should always get 1024-blocks.
908 # Otherwise, the POSIXLY_CORRECT envvar for GNU df would need to
909 # be set, to force 512-blocks; and the BLOCKSIZE envvar would need
910 # to be unset to avoid overriding.
911 if ($retval == 0) {
912 # Output format should be this:
913 # Filesystem 1024-blocks Used Available Capacity Mounted on
914 # /dev/sdb3 209611780 67718736 141893044 33% /
915 my ($h,$l) = split(/\n/, $output);
916 my ($fs, $nrb, $used, $avail, @rest) = split(' ', $l);
917 debug("diskfree: df -Pk output: $output");
918 debug("diskfree: used=$used (1024-block), avail=$avail (1024-block)\n");
919 # $avail is in 1024-byte blocks, so we divide by 1024 to obtain Mb.
920 return (int($avail / 1024));
921 } else {
922 # error in running df -P for whatever reason, just skip the check.
923 return (-1);
924 }
925 }
926
927 =item C<get_user_home()>
928
929 Returns the current user's home directory (C<$HOME> on Unix,
930 C<$USERPROFILE> on Windows, and C<~> if none of the two are
931 set. Save in package variable C<$user_home_dir> after computing.
932
933 =cut
934
935 # only search for home directory once, and save expansion here
936 my $user_home_dir;
937
938 sub get_user_home {
939 return $user_home_dir if ($user_home_dir);
940 $user_home_dir = getenv (wndws() ? 'USERPROFILE' : 'HOME') || '~';
941 return $user_home_dir;
942 }
943
944 =item C<expand_tilde($str)>
945
946 Expands initial C<~> with the user's home directory in C<$str> if
947 available, else leave C<~> in place.
948
949 =cut
950
951 sub expand_tilde {
952 my $str = shift;
953 my $h = get_user_home();
954 $str =~ s/^~/$h/;
955 return $str;
956 }
957
958 =back
959
960 =head2 File utilities
961
962 =over 4
963
964 =item C<dirname_and_basename($path)>
965
966 Return both C<dirname> and C<basename>. Example:
967
968 ($dirpart,$filepart) = dirname_and_basename ($path);
969
970 =cut
971
972 sub dirname_and_basename {
973 my $path=shift;
974 my ($share, $base) = ("", "");
975 if (wndws()) {
976 $path=~s!\\!/!g;
977 }
978 # do not try to make sense of paths ending with /..
979 return (undef, undef) if $path =~ m!/\.\.$!;
980 if ($path=~m!/!) { # dirname("foo/bar/baz") -> "foo/bar"
981 # eliminate `/.' path components
982 while ($path =~ s!/\./!/!) {};
983 # UNC path? => first split in $share = //xxx/yy and $path = /zzzz
984 if (wndws() and $path =~ m!^(//[^/]+/[^/]+)(.*)$!) {
985 ($share, $path) = ($1, $2);
986 if ($path =~ m!^/?$!) {
987 $path = $share;
988 $base = "";
989 } elsif ($path =~ m!(/.*)/(.*)!) {
990 $path = $share.$1;
991 $base = $2;
992 } else {
993 $base = $path;
994 $path = $share;
995 }
996 return ($path, $base);
997 }
998 # not a UNC path
999 $path=~m!(.*)/(.*)!; # works because of greedy matching
1000 return ((($1 eq '') ? '/' : $1), $2);
1001 } else { # dirname("ignore") -> "."
1002 return (".", $path);
1003 }
1004 }
1005
1006
1007 =item C<dirname($path)>
1008
1009 Return C<$path> with its trailing C</component> removed.
1010
1011 =cut
1012
1013 sub dirname {
1014 my $path = shift;
1015 my ($dirname, $basename) = dirname_and_basename($path);
1016 return $dirname;
1017 }
1018
1019
1020 =item C<basename($path)>
1021
1022 Return C<$path> with any leading directory components removed.
1023
1024 =cut
1025
1026 sub basename {
1027 my $path = shift;
1028 my ($dirname, $basename) = dirname_and_basename($path);
1029 return $basename;
1030 }
1031
1032
1033 =item C<tl_abs_path($path)>
1034
1035 # Other than Cwd::abs_path, tl_abs_path also works if the argument does not
1036 # yet exist as long as the path does not contain '..' components.
1037
1038 =cut
1039
1040 sub tl_abs_path {
1041 my $path = shift;
1042 if (wndws()) {
1043 $path=~s!\\!/!g;
1044 }
1045 if (-e $path) {
1046 $path = Cwd::abs_path($path);
1047 } elsif ($path eq '.') {
1048 $path = Cwd::getcwd();
1049 } else{
1050 # collapse /./ components
1051 $path =~ s!/\./!/!g;
1052 # no support for .. path components or for windows long-path syntax
1053 # (//?/ path prefix)
1054 die "Unsupported path syntax" if $path =~ m!/\.\./! || $path =~ m!/\.\.$!
1055 || $path =~ m!^\.\.!;
1056 die "Unsupported path syntax" if wndws() && $path =~ m!^//\?/!;
1057 if ($path !~ m!^(.:)?/!) { # relative path
1058 if (wndws() && $path =~ /^.:/) { # drive letter
1059 my $dcwd;
1060 # starts with drive letter: current dir on drive
1061 $dcwd = Cwd::getdcwd ($1);
1062 $dcwd .= '/' unless $dcwd =~ m!/$!;
1063 return $dcwd.$path;
1064 } else { # relative path without drive letter
1065 my $cwd = Cwd::getcwd();
1066 $cwd .= '/' unless $cwd =~ m!/$!;
1067 return $cwd . $path;
1068 }
1069 } # else absolute path
1070 }
1071 $path =~ s!/$!! unless $path =~ m!^(.:)?/$!;
1072 return $path;
1073 }
1074
1075
1076 =item C<dir_creatable($path)>
1077
1078 Tests whether its argument is a directory where we can create a directory.
1079
1080 =cut
1081
1082 sub dir_slash {
1083 my $d = shift;
1084 $d = "$d/" unless $d =~ m!/!;
1085 return $d;
1086 }
1087
1088 # test whether subdirectories can be created in the argument
1089 sub dir_creatable {
1090 my $path=shift;
1091 #print STDERR "testing $path\n";
1092 $path =~ s!\\!/!g if wndws;
1093 return 0 unless -d $path;
1094 $path .= '/' unless $path =~ m!/$!;
1095 #print STDERR "testing $path\n";
1096 my $d;
1097 for my $i (1..100) {
1098 $d = "";
1099 # find a non-existent dirname
1100 $d = $path . int(rand(1000000));
1101 last unless -e $d;
1102 }
1103 if (!$d) {
1104 tlwarn("Cannot find available testdir name\n");
1105 return 0;
1106 }
1107 #print STDERR "creating $d\n";
1108 return 0 unless mkdir $d;
1109 return 0 unless -d $d;
1110 rmdir $d;
1111 return 1;
1112 }
1113
1114
1115 =item C<dir_writable($path)>
1116
1117 Tests whether its argument is writable by trying to write to
1118 it. This function is necessary because the built-in C<-w> test just
1119 looks at mode and uid/gid, which on Windows always returns true and
1120 even on Unix is not always good enough for directories mounted from
1121 a fileserver.
1122
1123 =cut
1124
1125 # The Unix test gives the wrong answer when used under Windows Vista
1126 # with one of the `virtualized' directories such as Program Files:
1127 # lacking administrative permissions, it would write successfully to
1128 # the virtualized Program Files rather than fail to write to the
1129 # real Program Files. Ugh.
1130
1131 sub dir_writable {
1132 my ($path) = @_;
1133 return 0 unless -d $path;
1134 $path =~ s!\\!/!g if wndws;
1135 $path .= '/' unless $path =~ m!/$!;
1136 my $i = 0;
1137 my $f;
1138 for my $i (1..100) {
1139 $f = "";
1140 # find a non-existent filename
1141 $f = $path . int(rand(1000000));
1142 last unless -e $f;
1143 }
1144 if (!$f) {
1145 tlwarn("Cannot find available testfile name\n");
1146 return 0;
1147 }
1148 return 0 if ! open (TEST, ">$f");
1149 my $written = 0;
1150 $written = (print TEST "\n");
1151 close (TEST);
1152 unlink ($f);
1153 return $written;
1154 }
1155
1156
1157 =item C<mkdirhier($path, [$mode])>
1158
1159 The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>.
1160 It behaves differently depending on the context in which it is called:
1161 If called in void context it will die on failure. If called in
1162 scalar context, it will return 1/0 on sucess/failure. If called in
1163 list context, it returns 1/0 as first element and an error message
1164 as second, if an error occurred (and no second element in case of
1165 success). The optional parameter sets the permission bits.
1166
1167 =cut
1168
1169 sub mkdirhier {
1170 my ($tree,$mode) = @_;
1171 my $ret = 1;
1172 my $reterror;
1173
1174 if (-d "$tree") {
1175 $ret = 1;
1176 } else {
1177 my $subdir = "";
1178 # windows is special as usual: we need to separate //servername/ part
1179 # from the UNC path, since (! -d //servername/) tests true
1180 $subdir = $& if ( wndws() && ($tree =~ s!^//[^/]+/!!) );
1181
1182 my @dirs = split (/[\/\\]/, $tree);
1183 for my $dir (@dirs) {
1184 $subdir .= "$dir/";
1185 if (! -d $subdir) {
1186 if (defined $mode) {
1187 if (! mkdir ($subdir, $mode)) {
1188 $ret = 0;
1189 $reterror = "mkdir($subdir,$mode) failed: $!";
1190 last;
1191 }
1192 } else {
1193 if (! mkdir ($subdir)) {
1194 $ret = 0;
1195 $reterror = "mkdir($subdir) failed for tree $tree: $!";
1196 last;
1197 }
1198 }
1199 }
1200 }
1201 }
1202 if ($ret) {
1203 return(1); # nothing bad here returning 1 in any case, will
1204 # be ignored in void context, and give 1 in list context
1205 } else {
1206 if (wantarray) {
1207 return(0, $reterror);
1208 } elsif (defined wantarray) {
1209 return(0);
1210 } else {
1211 die "$0: $reterror";
1212 }
1213 }
1214 }
1215
1216
1217 =item C<rmtree($root, $verbose, $safe)>
1218
1219 The C<rmtree> function provides a convenient way to delete a
1220 subtree from the directory structure, much like the Unix command C<rm -r>.
1221 C<rmtree> takes three arguments:
1222
1223 =over 4
1224
1225 =item *
1226
1227 the root of the subtree to delete, or a reference to
1228 a list of roots. All of the files and directories
1229 below each root, as well as the roots themselves,
1230 will be deleted.
1231
1232 =item *
1233
1234 a boolean value, which if TRUE will cause C<rmtree> to
1235 print a message each time it examines a file, giving the
1236 name of the file, and indicating whether it's using C<rmdir>
1237 or C<unlink> to remove it, or that it's skipping it.
1238 (defaults to FALSE)
1239
1240 =item *
1241
1242 a boolean value, which if TRUE will cause C<rmtree> to
1243 skip any files to which you do not have delete access
1244 (if running under VMS) or write access (if running
1245 under another OS). This will change in the future when
1246 a criterion for 'delete permission' under OSs other
1247 than VMS is settled. (defaults to FALSE)
1248
1249 =back
1250
1251 It returns the number of files successfully deleted. Symlinks are
1252 simply deleted and not followed.
1253
1254 B<NOTE:> There are race conditions internal to the implementation of
1255 C<rmtree> making it unsafe to use on directory trees which may be
1256 altered or moved while C<rmtree> is running, and in particular on any
1257 directory trees with any path components or subdirectories potentially
1258 writable by untrusted users.
1259
1260 Additionally, if the third parameter is not TRUE and C<rmtree> is
1261 interrupted, it may leave files and directories with permissions altered
1262 to allow deletion (and older versions of this module would even set
1263 files and directories to world-read/writable!)
1264
1265 Note also that the occurrence of errors in C<rmtree> can be determined I<only>
1266 by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
1267 from the return value.
1268
1269 =cut
1270
1271 #taken from File/Path.pm
1272 #
1273 my $Is_VMS = $^O eq 'VMS';
1274 my $Is_MacOS = $^O eq 'MacOS';
1275
1276 # These OSes complain if you want to remove a file that you have no
1277 # write permission to:
1278 my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
1279 $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
1280
1281 sub rmtree {
1282 my($roots, $verbose, $safe) = @_;
1283 my(@files);
1284 my($count) = 0;
1285 $verbose ||= 0;
1286 $safe ||= 0;
1287
1288 if ( defined($roots) && length($roots) ) {
1289 $roots = [$roots] unless ref $roots;
1290 } else {
1291 warn "No root path(s) specified";
1292 return 0;
1293 }
1294
1295 my($root);
1296 foreach $root (@{$roots}) {
1297 if ($Is_MacOS) {
1298 $root = ":$root" if $root !~ /:/;
1299 $root =~ s#([^:])\z#$1:#;
1300 } else {
1301 $root =~ s#/\z##;
1302 }
1303 (undef, undef, my $rp) = lstat $root or next;
1304 $rp &= 07777; # don't forget setuid, setgid, sticky bits
1305 if ( -d _ ) {
1306 # notabene: 0700 is for making readable in the first place,
1307 # it's also intended to change it to writable in case we have
1308 # to recurse in which case we are better than rm -rf for
1309 # subtrees with strange permissions
1310 chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
1311 or warn "Can't make directory $root read+writeable: $!"
1312 unless $safe;
1313
1314 if (opendir my $d, $root) {
1315 no strict 'refs';
1316 if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
1317 # Blindly untaint dir names
1318 @files = map { /^(.*)$/s ; $1 } readdir $d;
1319 } else {
1320 @files = readdir $d;
1321 }
1322 closedir $d;
1323 } else {
1324 warn "Can't read $root: $!";
1325 @files = ();
1326 }
1327 # Deleting large numbers of files from VMS Files-11 filesystems
1328 # is faster if done in reverse ASCIIbetical order
1329 @files = reverse @files if $Is_VMS;
1330 ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
1331 if ($Is_MacOS) {
1332 @files = map("$root$_", @files);
1333 } else {
1334 @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
1335 }
1336 $count += rmtree(\@files,$verbose,$safe);
1337 if ($safe &&
1338 ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
1339 print "skipped $root\n" if $verbose;
1340 next;
1341 }
1342 chmod $rp | 0700, $root
1343 or warn "Can't make directory $root writeable: $!"
1344 if $force_writeable;
1345 print "rmdir $root\n" if $verbose;
1346 if (rmdir $root) {
1347 ++$count;
1348 } else {
1349 warn "Can't remove directory $root: $!";
1350 chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
1351 or warn("and can't restore permissions to "
1352 . sprintf("0%o",$rp) . "\n");
1353 }
1354 } else {
1355 if ($safe &&
1356 ($Is_VMS ? !&VMS::Filespec::candelete($root)
1357 : !(-l $root || -w $root)))
1358 {
1359 print "skipped $root\n" if $verbose;
1360 next;
1361 }
1362 chmod $rp | 0600, $root
1363 or warn "Can't make file $root writeable: $!"
1364 if $force_writeable;
1365 print "unlink $root\n" if $verbose;
1366 # delete all versions under VMS
1367 for (;;) {
1368 unless (unlink $root) {
1369 warn "Can't unlink file $root: $!";
1370 if ($force_writeable) {
1371 chmod $rp, $root
1372 or warn("and can't restore permissions to "
1373 . sprintf("0%o",$rp) . "\n");
1374 }
1375 last;
1376 }
1377 ++$count;
1378 last unless $Is_VMS && lstat $root;
1379 }
1380 }
1381 }
1382 $count;
1383 }
1384
1385
1386 =item C<copy($file, $target_dir)>
1387
1388 =item C<copy("-f", $file, $destfile)>
1389
1390 =item C<copy("-L", $file, $destfile)>
1391
1392 Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile>
1393 if the first argument is C<"-f">. No external programs are involved.
1394 Since we need C<sysopen()>, the Perl module C<Fcntl.pm> is required. The
1395 time stamps are preserved and symlinks are created on Unix systems. On
1396 Windows, C<(-l $file)> will never return 'C<true>' and so symlinks will
1397 be (uselessly) copied as regular files.
1398
1399 If the first argument is C<"-L"> and C<$file> is a symlink, the link is
1400 dereferenced before the copying is done. (If both C<"-f"> and C<"-L">
1401 are desired, they must be given in that order, although the codebase
1402 currently has no need to do this.)
1403
1404 C<copy> invokes C<mkdirhier> if target directories do not exist. Files
1405 start with mode C<0777> if they are executable and C<0666> otherwise,
1406 with the set bits in I<umask> cleared in each case.
1407
1408 C<$file> can begin with a C<file:/> prefix.
1409
1410 If C<$file> is not readable, we return without copying anything. (This
1411 can happen when the database and files are not in perfect sync.) On the
1412 other file, if the destination is not writable, or the writing fails,
1413 that is a fatal error.
1414
1415 =cut
1416
1417 sub copy {
1418 #too verbose ddebug("TLUtils::copy(", join (",", @_), "\n");
1419 my $infile = shift;
1420 my $filemode = 0;
1421 my $dereference = 0;
1422 if ($infile eq "-f") { # second argument is a file
1423 $filemode = 1;
1424 $infile = shift;
1425 }
1426 if ($infile eq "-L") {
1427 $dereference = 1;
1428 $infile = shift;
1429 }
1430 my $destdir=shift;
1431
1432 # while we're trying to figure out the versioned containers.
1433 #debug("copy($infile, $destdir, filemode=$filemode)\n");
1434 #debug("copy: backtrace:\n", backtrace(), "copy: end backtrace\n");
1435
1436 my $outfile;
1437 my @stat;
1438 my $mode;
1439 my $buffer;
1440 my $offset;
1441 my $filename;
1442 my $dirmode = 0755;
1443 my $blocksize = $TeXLive::TLConfig::BlockSize;
1444
1445 $infile =~ s!^file://*!/!i; # remove file:/ url prefix
1446 $filename = basename "$infile";
1447 if ($filemode) {
1448 # given a destination file
1449 $outfile = $destdir;
1450 $destdir = dirname($outfile);
1451 } else {
1452 $outfile = "$destdir/$filename";
1453 }
1454
1455 if (! -d $destdir) {
1456 my ($ret,$err) = mkdirhier ($destdir);
1457 die "mkdirhier($destdir) failed: $err\n" if ! $ret;
1458 }
1459
1460 # if we should dereference, change $infile to refer to the link target.
1461 if (-l $infile && $dereference) {
1462 my $linktarget = readlink($infile);
1463 # The symlink target should always be relative, and we need to
1464 # prepend the directory containing the link in that case.
1465 # (Although it should never happen, if the symlink target happens
1466 # to already be absolute, do not prepend.)
1467 if ($linktarget !~ m,^/,) {
1468 $infile = Cwd::abs_path(dirname($infile)) . "/$linktarget";
1469 }
1470 ddebug("TLUtils::copy: dereferencing symlink $infile -> $linktarget");
1471 }
1472
1473 if (-l $infile) {
1474 my $linktarget = readlink($infile);
1475 my $dest = "$destdir/$filename";
1476 ddebug("TLUtils::copy: doing symlink($linktarget,$dest)"
1477 . " [from readlink($infile)]\n");
1478 symlink($linktarget, $dest) || die "symlink($linktarget,$dest) failed: $!";
1479 } else {
1480 if (! open (IN, $infile)) {
1481 warn "open($infile) failed, not copying: $!";
1482 return;
1483 }
1484 binmode IN;
1485
1486 $mode = (-x $infile) ? oct("0777") : oct("0666");
1487 $mode &= ~umask;
1488
1489 open (OUT, ">$outfile") || die "open(>$outfile) failed: $!";
1490 binmode OUT;
1491
1492 chmod ($mode, $outfile) || warn "chmod($mode,$outfile) failed: $!";
1493
1494 while (my $read = sysread (IN, $buffer, $blocksize)) {
1495 die "read($infile) failed: $!" unless defined $read;
1496 $offset = 0;
1497 while ($read) {
1498 my $written = syswrite (OUT, $buffer, $read, $offset);
1499 die "write($outfile) failed: $!" unless defined $written;
1500 $read -= $written;
1501 $offset += $written;
1502 }
1503 }
1504 close (OUT) || warn "close($outfile) failed: $!";
1505 close (IN) || warn "close($infile) failed: $!";;
1506 @stat = lstat ($infile);
1507 die "lstat($infile) failed: $!" if ! @stat;
1508 utime ($stat[8], $stat[9], $outfile);
1509 }
1510 }
1511
1512
1513 =item C<touch(@files)>
1514
1515 Update modification and access time of C<@files>. Non-existent files
1516 are created.
1517
1518 =cut
1519
1520 sub touch {
1521 my @files=@_;
1522
1523 foreach my $file (@_) {
1524 if (-e $file) {
1525 utime time, time, $file;
1526 } else {
1527 if (open( TMP, ">$file")) {
1528 close(TMP);
1529 } else {
1530 warn "Can't create file $file: $!\n";
1531 }
1532 }
1533 }
1534 }
1535
1536
1537 =item C<collapse_dirs(@files)>
1538
1539 Return a (more or less) minimal list of directories and files, given an
1540 original list of files C<@files>. That is, if every file within a given
1541 directory is included in C<@files>, replace all of those files with the
1542 absolute directory name in the return list. Any files which have
1543 sibling files not included are retained and made absolute.
1544
1545 We try to walk up the tree so that the highest-level directory
1546 containing only directories or files that are in C<@files> is returned.
1547 (This logic may not be perfect, though.)
1548
1549 This is not just a string function; we check for other directory entries
1550 existing on disk within the directories of C<@files>. Therefore, if the
1551 entries are relative pathnames, the current directory must be set by the
1552 caller so that file tests work.
1553
1554 As mentioned above, the returned list is absolute paths to directories
1555 and files.
1556
1557 For example, suppose the input list is
1558
1559 dir1/subdir1/file1
1560 dir1/subdir2/file2
1561 dir1/file3
1562
1563 If there are no other entries under C<dir1/>, the result will be
1564 C</absolute/path/to/dir1>.
1565
1566 =cut
1567
1568 sub collapse_dirs {
1569 my (@files) = @_;
1570 my @ret = ();
1571 my %by_dir;
1572
1573 # construct hash of all directories mentioned, values are lists of the
1574 # files in that directory.
1575 for my $f (@files) {
1576 my $abs_f = Cwd::abs_path ($f);
1577 die ("oops, no abs_path($f) from " . `pwd`) unless $abs_f;
1578 (my $d = $abs_f) =~ s,/[^/]*$,,;
1579 my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : ();
1580 push (@a, $abs_f);
1581 $by_dir{$d} = \@a;
1582 }
1583
1584 # for each of our directories, see if we are given everything in
1585 # the directory. if so, return the directory; else return the
1586 # individual files.
1587 for my $d (sort keys %by_dir) {
1588 opendir (DIR, $d) || die "opendir($d) failed: $!";
1589 my @dirents = readdir (DIR);
1590 closedir (DIR) || warn "closedir($d) failed: $!";
1591
1592 # initialize test hash with all the files we saw in this dir.
1593 # (These idioms are due to "Finding Elements in One Array and Not
1594 # Another" in the Perl Cookbook.)
1595 my %seen;
1596 my @rmfiles = @{$by_dir{$d}};
1597 @seen{@rmfiles} = ();
1598
1599 # see if everything is the same.
1600 my $ok_to_collapse = 1;
1601 for my $dirent (@dirents) {
1602 next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn
1603
1604 my $item = "$d/$dirent"; # prepend directory for comparison
1605 if (! exists $seen{$item}) {
1606 ddebug(" no collapse of $d because of: $dirent\n");
1607 $ok_to_collapse = 0;
1608 last; # no need to keep looking after the first.
1609 }
1610 }
1611
1612 push (@ret, $ok_to_collapse ? $d : @{$by_dir{$d}});
1613 }
1614
1615 if (@ret != @files) {
1616 @ret = &collapse_dirs (@ret);
1617 }
1618 return @ret;
1619 }
1620
1621 =item C<dirs_of_files(@files)>
1622
1623 Returns all the directories in which at least one of the given
1624 files reside.
1625 =cut
1626
1627 sub dirs_of_files {
1628 my (@files) = @_;
1629 my %by_dir;
1630
1631 # construct hash of all directories mentioned, values are lists of the
1632 # files/dirs in that directory.
1633 for my $f (@files) {
1634 # what should we do with not existing entries????
1635 next if (! -r "$f");
1636 my $abs_f = Cwd::abs_path ($f);
1637 # the following is necessary because on windows,
1638 # abs_path("tl-portable")
1639 # returns
1640 # c:\tl test\...
1641 # and not forward slashes, while, if there is already a forward /
1642 # in the path, also the rest is done with forward slashes.
1643 $abs_f =~ s!\\!/!g if wndws();
1644 if (!$abs_f) {
1645 warn ("oops, no abs_path($f) from " . `pwd`);
1646 next;
1647 }
1648 (my $d = $abs_f) =~ s,/[^/]*$,,;
1649 my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : ();
1650 push (@a, $abs_f);
1651 $by_dir{$d} = \@a;
1652 }
1653
1654 return %by_dir;
1655 }
1656
1657 =item C<all_dirs_and_removed_dirs(@files)>
1658
1659 Returns all the directories for files and those from which all
1660 content will be removed.
1661
1662 =cut
1663
1664 sub all_dirs_and_removed_dirs {
1665 my (@files) = @_;
1666 my %removed_dirs;
1667 my %by_dir = dirs_of_files(@files);
1668
1669 # for each of our directories, see if we are removing everything in
1670 # the directory. if so, return the directory; else return the
1671 # individual files.
1672 for my $d (reverse sort keys %by_dir) {
1673 opendir (DIR, $d) || die "opendir($d) failed: $!";
1674 my @dirents = readdir (DIR);
1675 closedir (DIR) || warn "closedir($d) failed: $!";
1676
1677 # initialize test hash with all the files we saw in this dir.
1678 # (These idioms are due to "Finding Elements in One Array and Not
1679 # Another" in the Perl Cookbook.)
1680 my %seen;
1681 my @rmfiles = @{$by_dir{$d}};
1682 @seen{@rmfiles} = ();
1683
1684 # see if everything is the same.
1685 my $cleandir = 1;
1686 for my $dirent (@dirents) {
1687 next if $dirent =~ /^\.(\.|svn)?$/; # ignore . .. .svn
1688 my $item = "$d/$dirent"; # prepend directory for comparison
1689 if (
1690 ((-d $item) && (defined($removed_dirs{$item})))
1691 ||
1692 (exists $seen{$item})
1693 ) {
1694 # do nothing
1695 } else {
1696 $cleandir = 0;
1697 last;
1698 }
1699 }
1700 if ($cleandir) {
1701 $removed_dirs{$d} = 1;
1702 }
1703 }
1704 return (%by_dir, %removed_dirs);
1705 }
1706
1707 =item C<removed_dirs(@files)>
1708
1709 Returns all the directories from which all content will be removed.
1710
1711 Here is the idea:
1712
1713 =over 4
1714
1715 =item create a hashes by_dir listing all files that should be removed
1716 by directory, i.e., key = dir, value is list of files
1717
1718 =item for each of the dirs (keys of by_dir and ordered deepest first)
1719 check that all actually contained files are removed
1720 and all the contained dirs are in the removal list. If this is the
1721 case put that directory into the removal list
1722
1723 =item return this removal list
1724
1725 =back
1726 =cut
1727
1728 sub removed_dirs {
1729 my (@files) = @_;
1730 my (%by_dir, %removed_dirs) = all_dirs_and_removed_dirs(@files);
1731 return keys %removed_dirs;
1732 }
1733
1734
1735 =item C<time_estimate($totalsize, $donesize, $starttime)>
1736
1737 Returns the current running time and the estimated total time
1738 based on the total size, the already done size, and the start time.
1739
1740 =cut
1741
1742 sub time_estimate {
1743 my ($totalsize, $donesize, $starttime) = @_;
1744 if ($donesize <= 0) {
1745 return ("??:??", "??:??");
1746 }
1747 my $curtime = time();
1748 my $passedtime = $curtime - $starttime;
1749 my $esttotalsecs = int ( ( $passedtime * $totalsize ) / $donesize );
1750 #
1751 # we change the display to show that passed time instead of the
1752 # estimated remaining time. We keep the old code and naming and
1753 # only initialize the $remsecs to the $passedtime instead.
1754 # my $remsecs = $esttotalsecs - $passedtime;
1755 my $remsecs = $passedtime;
1756 my $min = int($remsecs/60);
1757 my $hour;
1758 if ($min >= 60) {
1759 $hour = int($min/60);
1760 $min %= 60;
1761 }
1762 my $sec = $remsecs % 60;
1763 my $remtime = sprintf("%02d:%02d", $min, $sec);
1764 if ($hour) {
1765 $remtime = sprintf("%02d:$remtime", $hour);
1766 }
1767 my $tmin = int($esttotalsecs/60);
1768 my $thour;
1769 if ($tmin >= 60) {
1770 $thour = int($tmin/60);
1771 $tmin %= 60;
1772 }
1773 my $tsec = $esttotalsecs % 60;
1774 my $tottime = sprintf("%02d:%02d", $tmin, $tsec);
1775 if ($thour) {
1776 $tottime = sprintf("%02d:$tottime", $thour);
1777 }
1778 return($remtime, $tottime);
1779 }
1780
1781
1782 =item C<install_packages($from_tlpdb, $media, $to_tlpdb, $what, $opt_src, $opt_doc, $retry, $continue)>
1783
1784 Installs the list of packages found in C<@$what> (a ref to a list) into
1785 the TLPDB given by C<$to_tlpdb>. Information on files are taken from
1786 the TLPDB C<$from_tlpdb>.
1787
1788 C<$opt_src> and C<$opt_doc> specify whether srcfiles and docfiles should
1789 be installed (currently implemented only for installation from
1790 uncompressed media).
1791
1792 If C<$retry> is trueish, retry failed packages a second time.
1793
1794 If C<$continue> is trueish, installation failure of non-critical packages
1795 will be ignored (success is returned).
1796
1797 Returns 1 on success and 0 on error.
1798
1799 =cut
1800
1801 sub install_packages {
1802 my ($fromtlpdb,$media,$totlpdb,$what,
1803 $opt_src,$opt_doc,$opt_retry,$opt_continue) = @_;
1804 my $container_src_split = $fromtlpdb->config_src_container;
1805 my $container_doc_split = $fromtlpdb->config_doc_container;
1806 my $root = $fromtlpdb->root;
1807 my @packs = @$what;
1808 my $totalnr = $#packs + 1;
1809 my $td = length("$totalnr");
1810 my $n = 0;
1811 my %tlpobjs;
1812 my $totalsize = 0;
1813 my $donesize = 0;
1814 my %tlpsizes;
1815 debug("TLUtils::install_packages: fromtlpdb.root=$root, media=$media,"
1816 . " totlpdb.root=" . $totlpdb->root
1817 . " what=$what ($totalnr), opt_src=$opt_src, opt_doc=$opt_doc\n");
1818
1819 foreach my $p (@packs) {
1820 $tlpobjs{$p} = $fromtlpdb->get_package($p);
1821 if (!defined($tlpobjs{$p})) {
1822 die "STRANGE: $p not to be found in ", $fromtlpdb->root;
1823 }
1824 if ($media ne 'local_uncompressed') {
1825 # we use the container size as the measuring unit since probably
1826 # downloading will be the limiting factor
1827 $tlpsizes{$p} = $tlpobjs{$p}->containersize;
1828 $tlpsizes{$p} += $tlpobjs{$p}->srccontainersize if $opt_src;
1829 $tlpsizes{$p} += $tlpobjs{$p}->doccontainersize if $opt_doc;
1830 } else {
1831 # we have to add the respective sizes, that is checking for
1832 # installation of src and doc file
1833 $tlpsizes{$p} = $tlpobjs{$p}->runsize;
1834 $tlpsizes{$p} += $tlpobjs{$p}->srcsize if $opt_src;
1835 $tlpsizes{$p} += $tlpobjs{$p}->docsize if $opt_doc;
1836 my %foo = %{$tlpobjs{$p}->binsize};
1837 for my $k (keys %foo) { $tlpsizes{$p} += $foo{$k}; }
1838 # all the packages sizes are in blocks, so transfer that to bytes
1839 $tlpsizes{$p} *= $TeXLive::TLConfig::BlockSize;
1840 }
1841 $totalsize += $tlpsizes{$p};
1842 }
1843 my $starttime = time();
1844 my @packs_again; # packages that we failed to download and should retry later
1845 foreach my $package (@packs) {
1846 my $tlpobj = $tlpobjs{$package};
1847 my $reloc = $tlpobj->relocated;
1848 $n++;
1849 my ($estrem, $esttot) = time_estimate($totalsize, $donesize, $starttime);
1850 my $infostr = sprintf("Installing [%0${td}d/$totalnr, "
1851 . "time/total: $estrem/$esttot]: $package [%dk]",
1852 $n, int($tlpsizes{$package}/1024) + 1);
1853 info("$infostr\n");
1854 foreach my $h (@::install_packages_hook) {
1855 &$h($n,$totalnr);
1856 }
1857 # push $package to @packs_again if download failed
1858 # (and not installing from disk).
1859 if (!$fromtlpdb->install_package($package, $totlpdb)) {
1860 tlwarn("TLUtils::install_packages: Failed to install $package\n");
1861 if ($opt_retry) {
1862 tlwarn(" $package will be retried later.\n");
1863 push @packs_again, $package;
1864 } else {
1865 # return false as soon as one package failed, since we won't
1866 # be trying again.
1867 return 0;
1868 }
1869 } else {
1870 $donesize += $tlpsizes{$package};
1871 }
1872 }
1873 # try to download packages in @packs_again again
1874 foreach my $package (@packs_again) {
1875 my $infostr = sprintf("Retrying to install: $package [%dk]",
1876 int($tlpsizes{$package}/1024) + 1);
1877 info("$infostr\n");
1878 # return false if download failed again
1879 if (!$fromtlpdb->install_package($package, $totlpdb)) {
1880 if ($opt_continue) {
1881 push @::installation_failed_packages, $package;
1882 tlwarn("Failed to install $package, but continuing anyway!\n");
1883 } else {
1884 return 0;
1885 }
1886 }
1887 $donesize += $tlpsizes{$package};
1888 }
1889 my $totaltime = time() - $starttime;
1890 my $tothour = int ($totaltime/3600);
1891 my $totmin = (int ($totaltime/60)) % 60;
1892 my $totsec = $totaltime % 60;
1893 my $hrstr = ($tothour > 0 ? "$tothour:" : "");
1894 info(sprintf("Time used for installing the packages: $hrstr%02d:%02d\n",
1895 $totmin, $totsec));
1896 $totlpdb->save;
1897 return 1;
1898 }
1899
1900 =item C<do_postaction($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script)>
1901
1902 Evaluates the C<postaction> fields in the C<$tlpobj>. The first parameter
1903 can be either C<install> or C<remove>. The second gives the TLPOBJ whos
1904 postactions should be evaluated, and the last four arguments specify
1905 what type of postactions should (or shouldn't) be evaluated.
1906
1907 Returns 1 on success, and 0 on failure.
1908
1909 =cut
1910
1911 sub do_postaction {
1912 my ($how, $tlpobj, $do_fileassocs, $do_menu, $do_desktop, $do_script) = @_;
1913 my $ret = 1;
1914 if (!defined($tlpobj)) {
1915 tlwarn("do_postaction: didn't get a tlpobj\n");
1916 return 0;
1917 }
1918 debug("running postaction=$how for " . $tlpobj->name . "\n")
1919 if $tlpobj->postactions;
1920 for my $pa ($tlpobj->postactions) {
1921 if ($pa =~ m/^\s*shortcut\s+(.*)\s*$/) {
1922 $ret &&= _do_postaction_shortcut($how, $tlpobj, $do_menu, $do_desktop, $1);
1923 } elsif ($pa =~ m/\s*filetype\s+(.*)\s*$/) {
1924 next unless $do_fileassocs;
1925 $ret &&= _do_postaction_filetype($how, $tlpobj, $1);
1926 } elsif ($pa =~ m/\s*fileassoc\s+(.*)\s*$/) {
1927 $ret &&= _do_postaction_fileassoc($how, $do_fileassocs, $tlpobj, $1);
1928 next;
1929 } elsif ($pa =~ m/\s*progid\s+(.*)\s*$/) {
1930 next unless $do_fileassocs;
1931 $ret &&= _do_postaction_progid($how, $tlpobj, $1);
1932 } elsif ($pa =~ m/\s*script\s+(.*)\s*$/) {
1933 next unless $do_script;
1934 $ret &&= _do_postaction_script($how, $tlpobj, $1);
1935 } else {
1936 tlwarn("do_postaction: don't know how to do $pa\n");
1937 $ret = 0;
1938 }
1939 }
1940 # nothing to do
1941 return $ret;
1942 }
1943
1944 sub _do_postaction_fileassoc {
1945 my ($how, $mode, $tlpobj, $pa) = @_;
1946 return 1 unless wndws();
1947 my ($errors, %keyval) =
1948 parse_into_keywords($pa, qw/extension filetype/);
1949
1950 if ($errors) {
1951 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n");
1952 return 0;
1953 }
1954
1955 # name can be an arbitrary string
1956 if (!defined($keyval{'extension'})) {
1957 tlwarn("extension of fileassoc postaction not given\n");
1958 return 0;
1959 }
1960 my $extension = $keyval{'extension'};
1961
1962 # cmd can be an arbitrary string
1963 if (!defined($keyval{'filetype'})) {
1964 tlwarn("filetype of fileassoc postaction not given\n");
1965 return 0;
1966 }
1967 my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear;
1968
1969 &log("postaction $how fileassoc for " . $tlpobj->name .
1970 ": $extension, $filetype\n");
1971 if ($how eq "install") {
1972 TeXLive::TLWinGoo::register_extension($mode, $extension, $filetype);
1973 } elsif ($how eq "remove") {
1974 TeXLive::TLWinGoo::unregister_extension($mode, $extension, $filetype);
1975 } else {
1976 tlwarn("Unknown mode $how\n");
1977 return 0;
1978 }
1979 return 1;
1980 }
1981
1982 sub _do_postaction_filetype {
1983 my ($how, $tlpobj, $pa) = @_;
1984 return 1 unless wndws();
1985 my ($errors, %keyval) =
1986 parse_into_keywords($pa, qw/name cmd/);
1987
1988 if ($errors) {
1989 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n");
1990 return 0;
1991 }
1992
1993 # name can be an arbitrary string
1994 if (!defined($keyval{'name'})) {
1995 tlwarn("name of filetype postaction not given\n");
1996 return 0;
1997 }
1998 my $name = $keyval{'name'}.'.'.$ReleaseYear;
1999
2000 # cmd can be an arbitrary string
2001 if (!defined($keyval{'cmd'})) {
2002 tlwarn("cmd of filetype postaction not given\n");
2003 return 0;
2004 }
2005 my $cmd = $keyval{'cmd'};
2006
2007 my $texdir = `kpsewhich -var-value=TEXMFROOT`;
2008 chomp($texdir);
2009 my $texdir_bsl = conv_to_w32_path($texdir);
2010 $cmd =~ s!^("?)TEXDIR/!$1$texdir/!g;
2011
2012 &log("postaction $how filetype for " . $tlpobj->name .
2013 ": $name, $cmd\n");
2014 if ($how eq "install") {
2015 TeXLive::TLWinGoo::register_file_type($name, $cmd);
2016 } elsif ($how eq "remove") {
2017 TeXLive::TLWinGoo::unregister_file_type($name);
2018 } else {
2019 tlwarn("Unknown mode $how\n");
2020 return 0;
2021 }
2022 return 1;
2023 }
2024
2025 # alternate filetype (= progid) for an extension;
2026 # associated program shows up in `open with' menu
2027 sub _do_postaction_progid {
2028 my ($how, $tlpobj, $pa) = @_;
2029 return 1 unless wndws();
2030 my ($errors, %keyval) =
2031 parse_into_keywords($pa, qw/extension filetype/);
2032
2033 if ($errors) {
2034 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n");
2035 return 0;
2036 }
2037
2038 if (!defined($keyval{'extension'})) {
2039 tlwarn("extension of progid postaction not given\n");
2040 return 0;
2041 }
2042 my $extension = $keyval{'extension'};
2043
2044 if (!defined($keyval{'filetype'})) {
2045 tlwarn("filetype of progid postaction not given\n");
2046 return 0;
2047 }
2048 my $filetype = $keyval{'filetype'}.'.'.$ReleaseYear;
2049
2050 &log("postaction $how progid for " . $tlpobj->name .
2051 ": $extension, $filetype\n");
2052 if ($how eq "install") {
2053 TeXLive::TLWinGoo::add_to_progids($extension, $filetype);
2054 } elsif ($how eq "remove") {
2055 TeXLive::TLWinGoo::remove_from_progids($extension, $filetype);
2056 } else {
2057 tlwarn("Unknown mode $how\n");
2058 return 0;
2059 }
2060 return 1;
2061 }
2062
2063 sub _do_postaction_script {
2064 my ($how, $tlpobj, $pa) = @_;
2065 my ($errors, %keyval) =
2066 parse_into_keywords($pa, qw/file filew32/);
2067
2068 if ($errors) {
2069 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n");
2070 return 0;
2071 }
2072
2073 # file can be an arbitrary string
2074 if (!defined($keyval{'file'})) {
2075 tlwarn("filename of script not given\n");
2076 return 0;
2077 }
2078 my $file = $keyval{'file'};
2079 if (wndws() && defined($keyval{'filew32'})) {
2080 $file = $keyval{'filew32'};
2081 }
2082 my $texdir = `kpsewhich -var-value=TEXMFROOT`;
2083 chomp($texdir);
2084 my @syscmd;
2085 if ($file =~ m/\.pl$/i) {
2086 # we got a perl script, call it via perl
2087 push @syscmd, "perl", "$texdir/$file";
2088 } elsif ($file =~ m/\.texlua$/i) {
2089 # we got a texlua script, call it via texlua
2090 push @syscmd, "texlua", "$texdir/$file";
2091 } else {
2092 # we got anything else, call it directly and hope it is excutable
2093 push @syscmd, "$texdir/$file";
2094 }
2095 &log("postaction $how script for " . $tlpobj->name . ": @syscmd\n");
2096 push @syscmd, $how, $texdir;
2097 my $ret = system (@syscmd);
2098 if ($ret != 0) {
2099 $ret /= 256 if $ret > 0;
2100 my $pwd = cwd ();
2101 warn "$0: calling post action script $file did not succeed in $pwd, status $ret";
2102 return 0;
2103 }
2104 return 1;
2105 }
2106
2107 sub _do_postaction_shortcut {
2108 my ($how, $tlpobj, $do_menu, $do_desktop, $pa) = @_;
2109 return 1 unless wndws();
2110 my ($errors, %keyval) =
2111 parse_into_keywords($pa, qw/type name icon cmd args hide/);
2112
2113 if ($errors) {
2114 tlwarn("parsing the postaction line >>$pa<< did not succeed!\n");
2115 return 0;
2116 }
2117
2118 # type can be either menu or desktop
2119 if (!defined($keyval{'type'})) {
2120 tlwarn("type of shortcut postaction not given\n");
2121 return 0;
2122 }
2123 my $type = $keyval{'type'};
2124 if (($type ne "menu") && ($type ne "desktop")) {
2125 tlwarn("type of shortcut postaction $type is unknown (menu, desktop)\n");
2126 return 0;
2127 }
2128
2129 if (($type eq "menu") && !$do_menu) {
2130 return 1;
2131 }
2132 if (($type eq "desktop") && !$do_desktop) {
2133 return 1;
2134 }
2135
2136 # name can be an arbitrary string
2137 if (!defined($keyval{'name'})) {
2138 tlwarn("name of shortcut postaction not given\n");
2139 return 0;
2140 }
2141 my $name = $keyval{'name'};
2142
2143 # icon, cmd, args is optional
2144 my $icon = (defined($keyval{'icon'}) ? $keyval{'icon'} : '');
2145 my $cmd = (defined($keyval{'cmd'}) ? $keyval{'cmd'} : '');
2146 my $args = (defined($keyval{'args'}) ? $keyval{'args'} : '');
2147
2148 # hide can be only 0 or 1, and defaults to 1
2149 my $hide = (defined($keyval{'hide'}) ? $keyval{'hide'} : 1);
2150 if (($hide ne "0") && ($hide ne "1")) {
2151 tlwarn("hide of shortcut postaction $hide is unknown (0, 1)\n");
2152 return 0;
2153 }
2154
2155 &log("postaction $how shortcut for " . $tlpobj->name . "\n");
2156 if ($how eq "install") {
2157 my $texdir = `kpsewhich -var-value=TEXMFROOT`;
2158 chomp($texdir);
2159 my $texdir_bsl = conv_to_w32_path($texdir);
2160 $icon =~ s!^TEXDIR/!$texdir/!;
2161 $cmd =~ s!^TEXDIR/!$texdir/!;
2162 # $cmd can be an URL, in which case we do NOT want to convert it to
2163 # w32 paths!
2164 if ($cmd !~ m!^\s*(https?://|ftp://)!) {
2165 if (!(-e $cmd) or !(-r $cmd)) {
2166 tlwarn("Target of shortcut action does not exist: $cmd\n")
2167 if $cmd =~ /\.(exe|bat|cmd)$/i;
2168 # if not an executable, just omit shortcut silently: no error
2169 return 1;
2170 }
2171 $cmd = conv_to_w32_path($cmd);
2172 }
2173 if ($type eq "menu" ) {
2174 TeXLive::TLWinGoo::add_menu_shortcut(
2175 $TeXLive::TLConfig::WindowsMainMenuName,
2176 $name, $icon, $cmd, $args, $hide);
2177 } elsif ($type eq "desktop") {
2178 TeXLive::TLWinGoo::add_desktop_shortcut(
2179 $name, $icon, $cmd, $args, $hide);
2180 } else {
2181 tlwarn("Unknown type of shortcut: $type\n");
2182 return 0;
2183 }
2184 } elsif ($how eq "remove") {
2185 if ($type eq "menu") {
2186 TeXLive::TLWinGoo::remove_menu_shortcut(
2187 $TeXLive::TLConfig::WindowsMainMenuName, $name);
2188 } elsif ($type eq "desktop") {
2189 TeXLive::TLWinGoo::remove_desktop_shortcut($name);
2190 } else {
2191 tlwarn("Unknown type of shortcut: $type\n");
2192 return 0;
2193 }
2194 } else {
2195 tlwarn("Unknown mode $how\n");
2196 return 0;
2197 }
2198 return 1;
2199 }
2200
2201 sub parse_into_keywords {
2202 my ($str, @keys) = @_;
2203 my @words = quotewords('\s+', 0, $str);
2204 my %ret;
2205 my $error = 0;
2206 while (@words) {
2207 $_ = shift @words;
2208 if (/^([^=]+)=(.*)$/) {
2209 $ret{$1} = $2;
2210 } else {
2211 tlwarn("parser found a invalid word in parsing keys: $_\n");
2212 $error++;
2213 $ret{$_} = "";
2214 }
2215 }
2216 for my $k (keys %ret) {
2217 if (!member($k, @keys)) {
2218 $error++;
2219 tlwarn("parser found invalid keyword: $k\n");
2220 }
2221 }
2222 return($error, %ret);
2223 }
2224
2225 =item C<announce_execute_actions($how, $tlpobj, $what)>
2226
2227 Announces that the actions given in C<$tlpobj> should be executed
2228 after all packages have been unpacked. C<$what> provides
2229 additional information.
2230
2231 =cut
2232
2233 sub announce_execute_actions {
2234 my ($type, $tlp, $what) = @_;
2235 # do simply return immediately if execute actions are suppressed
2236 return if $::no_execute_actions;
2237
2238 if (defined($type) && ($type eq "regenerate-formats")) {
2239 $::regenerate_all_formats = 1;
2240 return;
2241 }
2242 if (defined($type) && ($type eq "files-changed")) {
2243 $::files_changed = 1;
2244 return;
2245 }
2246 if (defined($type) && ($type eq "rebuild-format")) {
2247 # rebuild-format must feed in a hashref of a parse_AddFormat_line data
2248 # the $tlp argument is not used
2249 $::execute_actions{'enable'}{'formats'}{$what->{'name'}} = $what;
2250 return;
2251 }
2252 if (!defined($type) || (($type ne "enable") && ($type ne "disable"))) {
2253 die "announce_execute_actions: enable or disable, not type $type";
2254 }
2255 my (@maps, @formats, @dats);
2256 if ($tlp->runfiles || $tlp->srcfiles || $tlp->docfiles) {
2257 $::files_changed = 1;
2258 }
2259 $what = "map format hyphen" if (!defined($what));
2260 foreach my $e ($tlp->executes) {
2261 if ($e =~ m/^add((Mixed|Kanji)?Map)\s+([^\s]+)\s*$/) {
2262 # save the refs as we have another =~ grep in the following lines
2263 my $a = $1;
2264 my $b = $3;
2265 $::execute_actions{$type}{'maps'}{$b} = $a if ($what =~ m/map/);
2266 } elsif ($e =~ m/^AddFormat\s+(.*)\s*$/) {
2267 my %r = TeXLive::TLUtils::parse_AddFormat_line("$1");
2268 if (defined($r{"error"})) {
2269 tlwarn ("$r{'error'} in parsing $e for return hash\n");
2270 } else {
2271 $::execute_actions{$type}{'formats'}{$r{'name'}} = \%r
2272 if ($what =~ m/format/);
2273 }
2274 } elsif ($e =~ m/^AddHyphen\s+(.*)\s*$/) {
2275 my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1");
2276 if (defined($r{"error"})) {
2277 tlwarn ("$r{'error'} in parsing $e for return hash\n");
2278 } else {
2279 $::execute_actions{$type}{'hyphens'}{$r{'name'}} = \%r
2280 if ($what =~ m/hyphen/);
2281 }
2282 } else {
2283 tlwarn("Unknown execute $e in ", $tlp->name, "\n");
2284 }
2285 }
2286 }
2287
2288
2289 =pod
2290
2291 =item C<add_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)>
2292
2293 =item C<remove_symlinks($root, $arch, $sys_bin, $sys_man, $sys_info)>
2294
2295 These two functions try to create/remove symlinks for binaries, man pages,
2296 and info files as specified by the options $sys_bin, $sys_man, $sys_info.
2297
2298 The functions return 1 on success and 0 on error.
2299 On Windows it returns undefined.
2300
2301 =cut
2302
2303 sub add_link_dir_dir {
2304 my ($from,$to) = @_;
2305 my ($ret, $err) = mkdirhier ($to);
2306 if (!$ret) {
2307 tlwarn("$err\n");
2308 return 0;
2309 }
2310 if (-w $to) {
2311 debug ("TLUtils::add_link_dir_dir: linking from $from to $to\n");
2312 chomp (my @files = `ls "$from"`);
2313 my $ret = 1;
2314 for my $f (@files) {
2315 # don't make a system-dir link to our special "man" link.
2316 if ($f eq "man") {
2317 debug ("not linking `man' into $to.\n");
2318 next;
2319 }
2320 #
2321 # attempt to remove an existing symlink, but nothing else.
2322 unlink ("$to/$f") if -l "$to/$f";
2323 #
2324 # if the destination still exists, skip it.
2325 if (-e "$to/$f") {
2326 tlwarn ("add_link_dir_dir: $to/$f exists; not making symlink.\n");
2327 next;
2328 }
2329 #
2330 # try to make the link.
2331 if (symlink ("$from/$f", "$to/$f") == 0) {
2332 tlwarn ("add_link_dir_dir: symlink of $f from $from to $to failed: $!\n");
2333 $ret = 0;
2334 }
2335 }
2336 return $ret;
2337 } else {
2338 tlwarn ("add_link_dir_dir: destination $to not writable, "
2339 . "no links from $from.\n");
2340 return 0;
2341 }
2342 }
2343
2344 sub remove_link_dir_dir {
2345 my ($from, $to) = @_;
2346 if ((-d "$to") && (-w "$to")) {
2347 debug("TLUtils::remove_link_dir_dir: removing links from $from to $to\n");
2348 chomp (my @files = `ls "$from"`);
2349 my $ret = 1;
2350 foreach my $f (@files) {
2351 next if (! -r "$to/$f");
2352 if ($f eq "man") {
2353 debug("TLUtils::remove_link_dir_dir: not considering man in $to, it should not be from us!\n");
2354 next;
2355 }
2356 if ((-l "$to/$f") &&
2357 (readlink("$to/$f") =~ m;^$from/;)) {
2358 $ret = 0 unless unlink("$to/$f");
2359 } else {
2360 $ret = 0;
2361 tlwarn ("TLUtils::remove_link_dir_dir: not removing $to/$f, not a link or wrong destination!\n");
2362 }
2363 }
2364 # try to remove the destination directory, it might be empty and
2365 # we might have write permissions, ignore errors
2366 # `rmdir "$to" 2>/dev/null`;
2367 return $ret;
2368 } else {
2369 tlwarn ("TLUtils::remove_link_dir_dir: destination $to not writable, no removal of links done!\n");
2370 return 0;
2371 }
2372 }
2373
2374 sub add_remove_symlinks {
2375 my ($mode, $Master, $arch, $sys_bin, $sys_man, $sys_info) = @_;
2376 my $errors = 0;
2377 my $plat_bindir = "$Master/bin/$arch";
2378
2379 # nothing to do with symlinks on Windows, of course.
2380 return if wndws();
2381
2382 my $info_dir = "$Master/texmf-dist/doc/info";
2383 if ($mode eq "add") {
2384 $errors++ unless add_link_dir_dir($plat_bindir, $sys_bin); # bin
2385 if (-d $info_dir) {
2386 $errors++ unless add_link_dir_dir($info_dir, $sys_info);
2387 }
2388 } elsif ($mode eq "remove") {
2389 $errors++ unless remove_link_dir_dir($plat_bindir, $sys_bin); # bin
2390 if (-d $info_dir) {
2391 $errors++ unless remove_link_dir_dir($info_dir, $sys_info);
2392 }
2393 } else {
2394 die ("should not happen, unknown mode $mode in add_remove_symlinks!");
2395 }
2396
2397 # man
2398 my $top_man_dir = "$Master/texmf-dist/doc/man";
2399 debug("TLUtils::add_remove_symlinks: $mode symlinks for man pages to $sys_man from $top_man_dir\n");
2400 if (! -d $top_man_dir) {
2401 ; # better to be silent?
2402 #info("skipping add of man symlinks, no source directory $top_man_dir\n");
2403 } else {
2404 my $man_doable = 1;
2405 if ($mode eq "add") {
2406 my ($ret, $err) = mkdirhier $sys_man;
2407 if (!$ret) {
2408 $man_doable = 0;
2409 tlwarn("$err\n");
2410 $errors++;
2411 }
2412 }
2413 if ($man_doable) {
2414 if (-w $sys_man) {
2415 my $foo = `(cd "$top_man_dir" && echo *)`;
2416 my @mans = split (' ', $foo);
2417 chomp (@mans);
2418 foreach my $m (@mans) {
2419 my $mandir = "$top_man_dir/$m";
2420 next unless -d $mandir;
2421 if ($mode eq "add") {
2422 $errors++ unless add_link_dir_dir($mandir, "$sys_man/$m");
2423 } else {
2424 $errors++ unless remove_link_dir_dir($mandir, "$sys_man/$m");
2425 }
2426 }
2427 #`rmdir "$sys_man" 2>/dev/null` if ($mode eq "remove");
2428 } else {
2429 tlwarn("TLUtils::add_remove_symlinks: man symlink destination ($sys_man) not writable, "
2430 . "cannot $mode symlinks.\n");
2431 $errors++;
2432 }
2433 }
2434 }
2435
2436 # we collected errors in $errors, so return the negation of it
2437 if ($errors) {
2438 info("TLUtils::add_remove_symlinks: $mode of symlinks had $errors error(s), see messages above.\n");
2439 return $F_ERROR;
2440 } else {
2441 return $F_OK;
2442 }
2443 }
2444
2445 sub add_symlinks { return (add_remove_symlinks("add", @_)); }
2446 sub remove_symlinks { return (add_remove_symlinks("remove", @_)); }
2447
2448 =pod
2449
2450 =item C<w32_add_to_path($bindir, $multiuser)>
2451 =item C<w32_remove_from_path($bindir, $multiuser)>
2452
2453 These two functions try to add/remove the binary directory $bindir
2454 on Windows to the registry PATH variable.
2455
2456 If running as admin user and $multiuser is set, the system path will
2457 be adjusted, otherwise the user path.
2458
2459 After calling these functions TeXLive::TLWinGoo::broadcast_env() should
2460 be called to make the changes immediately visible.
2461
2462 =cut
2463
2464 sub w32_add_to_path {
2465 my ($bindir, $multiuser) = @_;
2466 return if (!wndws());
2467
2468 my $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'};
2469 $path =~ s/[\s\x00]+$//;
2470 &log("Old system path: $path\n");
2471 $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'};
2472 if ($path) {
2473 $path =~ s/[\s\x00]+$//;
2474 &log("Old user path: $path\n");
2475 } else {
2476 &log("Old user path: none\n");
2477 }
2478 my $mode = 'user';
2479 if (TeXLive::TLWinGoo::admin() && $multiuser) {
2480 $mode = 'system';
2481 }
2482 debug("TLUtils:w32_add_to_path: calling adjust_reg_path_for_texlive add $bindir $mode\n");
2483 TeXLive::TLWinGoo::adjust_reg_path_for_texlive('add', $bindir, $mode);
2484 $path = TeXLive::TLWinGoo::get_system_env() -> {'/Path'};
2485 $path =~ s/[\s\x00]+$//;
2486 &log("New system path: $path\n");
2487 $path = TeXLive::TLWinGoo::get_user_env() -> {'/Path'};
2488 if ($path) {
2489 $path =~ s/[\s\x00]+$//;
2490 &log("New user path: $path\n");
2491 } else {
2492 &log("New user path: none\n");
2493 }
2494 }
2495
2496 sub w32_remove_from_path {
2497 my ($bindir, $multiuser) = @_;
2498 my $mode = 'user';
2499 if (TeXLive::TLWinGoo::admin() && $multiuser) {
2500 $mode = 'system';
2501 }
2502 debug("w32_remove_from_path: trying to remove $bindir in $mode\n");
2503 TeXLive::TLWinGoo::adjust_reg_path_for_texlive('remove', $bindir, $mode);
2504 }
2505
2506 =pod
2507
2508 =item C<check_file_and_remove($what, $checksum, $checksize>
2509
2510 Remove the file C<$what> if either the given C<$checksum> or
2511 C<$checksize> for C<$what> does not agree with our recomputation using
2512 C<TLCrypto::tlchecksum> and C<stat>, respectively. If a check argument
2513 is not given, that check is not performed. If the checksums agree, the
2514 size is not checked. The return status is random.
2515
2516 This unusual behavior (removing the given file) is because this is used
2517 for newly-downloaded files; see the calls in the C<unpack> routine
2518 (which is the only caller).
2519
2520 =cut
2521
2522 sub check_file_and_remove {
2523 my ($xzfile, $checksum, $checksize) = @_;
2524 my $fn_name = (caller(0))[3];
2525 debug("$fn_name $xzfile, $checksum, $checksize\n");
2526
2527 if (!$checksum && !$checksize) {
2528 tlwarn("$fn_name: neither checksum nor checksize " .
2529 "available for $xzfile, cannot check integrity");
2530 return;
2531 }
2532
2533 # The idea is that if one of the tests fail, we want to save a copy of
2534 # the input file for debugging. But we can't just omit removing the
2535 # file, since the caller depends on the removal. So we copy it to a
2536 # new temporary directory, which we want to persist, so can't use tl_tmpdir.
2537 my $check_file_tmpdir = undef;
2538
2539 # only run checksum tests if we can actually compute the checksum
2540 if ($checksum && ($checksum ne "-1") && $::checksum_method) {
2541 my $tlchecksum = TeXLive::TLCrypto::tlchecksum($xzfile);
2542 if ($tlchecksum ne $checksum) {
2543 tlwarn("$fn_name: checksums differ for $xzfile:\n");
2544 tlwarn("$fn_name: tlchecksum=$tlchecksum, arg=$checksum\n");
2545 tlwarn("$fn_name: backtrace:\n" . backtrace());
2546 # on Windows passing a pattern creates the tmpdir in PWD
2547 # which means that it will be tried to be created on the DVD
2548 # $check_file_tmpdir = File::Temp::tempdir("tlcheckfileXXXXXXXX");
2549 $check_file_tmpdir = File::Temp::tempdir();
2550 tlwarn("$fn_name: removing $xzfile, "
2551 . "but saving copy in $check_file_tmpdir\n");
2552 copy($xzfile, $check_file_tmpdir);
2553 unlink($xzfile);
2554 return;
2555 } else {
2556 debug("$fn_name: checksums for $xzfile agree\n");
2557 # if we have checked the checksum, we don't need to check the size, too
2558 return;
2559 }
2560 }
2561 if ($checksize && ($checksize ne "-1")) {
2562 my $filesize = (stat $xzfile)[7];
2563 if ($filesize != $checksize) {
2564 tlwarn("$fn_name: removing $xzfile, sizes differ:\n");
2565 tlwarn("$fn_name: tlfilesize=$filesize, arg=$checksize\n");
2566 if (!defined($check_file_tmpdir)) {
2567 # the tmpdir should always be undefined, since we shouldn't get
2568 # here if the checksums failed, but test anyway.
2569 $check_file_tmpdir = File::Temp::tempdir("tlcheckfileXXXXXXXX");
2570 tlwarn("$fn_name: saving copy in $check_file_tmpdir\n");
2571 copy($xzfile, $check_file_tmpdir);
2572 }
2573 unlink($xzfile);
2574 return;
2575 }
2576 }
2577 # We cannot remove the file here, otherwise restoring of backups
2578 # or unwind packages might die.
2579 }
2580
2581 =pod
2582
2583 =item C<unpack($what, $targetdir, @opts>
2584
2585 If necessary, downloads C$what>, and then unpacks it into C<$targetdir>.
2586 C<@opts> is assigned to a hash and can contain the following
2587 keys: C<tmpdir> (use this directory for downloaded files),
2588 C<checksum> (check downloaded file against this checksum),
2589 C<size> (check downloaded file against this size),
2590 C<remove> (remove temporary files after operation).
2591
2592 Returns a pair of values: in case of error return 0 and an additional
2593 explanation, in case of success return 1 and the name of the package.
2594
2595 If C<checksum> or C<size> is C<-1>, no warnings about missing checksum/size
2596 is printed. This is used during restore and unwinding of failed updates.
2597
2598 =cut
2599
2600 sub unpack {
2601 my ($what, $target, %opts) = @_;
2602 # remove by default
2603 my $remove = (defined($opts{'remove'}) ? $opts{'remove'} : 1);
2604 my $tempdir = (defined($opts{'tmpdir'}) ? $opts{'tmpdir'} : tl_tmpdir());
2605 my $checksum = (defined($opts{'checksum'}) ? $opts{'checksum'} : 0);
2606 my $size = (defined($opts{'size'}) ? $opts{'size'} : 0);
2607
2608 if (!defined($what)) {
2609 return (0, "nothing to unpack");
2610 }
2611
2612 my $decompressorType;
2613 my $compressorextension;
2614 if ($what =~ m/\.tar\.$CompressorExtRegexp$/) {
2615 $compressorextension = $1;
2616 $decompressorType = $1 eq "gz" ? "gzip" : $1;
2617 }
2618 if (!$decompressorType) {
2619 return(0, "don't know how to unpack");
2620 }
2621 # make sure that the found uncompressor type is also available
2622 if (!member($decompressorType, @{$::progs{'working_compressors'}})) {
2623 return(0, "unsupported container format $decompressorType");
2624 }
2625
2626 # only check the necessary compressor program
2627 my $decompressor = $::progs{$decompressorType};
2628 my @decompressorArgs = @{$Compressors{$decompressorType}{'decompress_args'}};
2629
2630 my $fn = basename($what);
2631 my $pkg = $fn;
2632 $pkg =~ s/\.tar\.$compressorextension$//;
2633 my $remove_containerfile = $remove;
2634 my $containerfile = "$tempdir/$fn";
2635 my $tarfile = "$tempdir/$fn";
2636 $tarfile =~ s/\.$compressorextension$//;
2637 if ($what =~ m,^(https?|ftp)://, || $what =~ m!$SshURIRegex!) {
2638 # we are installing from the NET
2639 # check for the presence of $what in $tempdir
2640 if (-r $containerfile) {
2641 check_file_and_remove($containerfile, $checksum, $size);
2642 }
2643 # if the file is now not present, we can use it
2644 if (! -r $containerfile) {
2645 # try download the file and put it into temp
2646 if (!download_file($what, $containerfile)) {
2647 return(0, "downloading did not succeed (download_file failed)");
2648 }
2649 # remove false downloads
2650 check_file_and_remove($containerfile, $checksum, $size);
2651 if ( ! -r $containerfile ) {
2652 return(0, "downloading did not succeed (check_file_and_remove failed)");
2653 }
2654 }
2655 } else {
2656 # we are installing from local compressed files
2657 # copy it to temp with dereferencing of link target
2658 TeXLive::TLUtils::copy("-L", $what, $tempdir);
2659
2660 check_file_and_remove($containerfile, $checksum, $size);
2661 if (! -r $containerfile) {
2662 return (0, "consistency checks failed");
2663 }
2664 # we can remove it afterwards
2665 $remove_containerfile = 1;
2666 }
2667 if (!system_pipe($decompressor, $containerfile, $tarfile,
2668 $remove_containerfile, @decompressorArgs)
2669 ||
2670 ! -f $tarfile) {
2671 unlink($tarfile, $containerfile);
2672 return(0, "Decompressing $containerfile failed");
2673 }
2674 if (untar($tarfile, $target, 1)) {
2675 return (1, "$pkg");
2676 } else {
2677 return (0, "untar failed");
2678 }
2679 }
2680
2681 =pod
2682
2683 =item C<untar($tarfile, $targetdir, $remove_tarfile)>
2684
2685 Unpacks C<$tarfile> in C<$targetdir> (changing directories to
2686 C<$targetdir> and then back to the original directory). If
2687 C<$remove_tarfile> is true, unlink C<$tarfile> after unpacking.
2688
2689 Assumes the global C<$::progs{"tar"}> has been set up.
2690
2691 =cut
2692
2693 # return 1 if success, 0 if failure.
2694 sub untar {
2695 my ($tarfile, $targetdir, $remove_tarfile) = @_;
2696 my $ret;
2697
2698 my $tar = $::progs{'tar'}; # assume it's been set up
2699
2700 # don't use the -C option to tar since Solaris tar et al. don't support it.
2701 # don't use system("cd ... && $tar ...") since that opens us up to
2702 # quoting issues.
2703 # so fall back on chdir in Perl.
2704 #
2705 debug("TLUtils::untar: unpacking $tarfile in $targetdir\n");
2706 my $cwd = cwd();
2707 chdir($targetdir) || die "chdir($targetdir) failed: $!";
2708
2709 # on w32 don't extract file modified time, because AV soft can open
2710 # files in the mean time causing time stamp modification to fail
2711 my $taropt = wndws() ? "xmf" : "xf";
2712 if (system($tar, $taropt, $tarfile) != 0) {
2713 tlwarn("TLUtils::untar: $tar $taropt $tarfile failed (in $targetdir)\n");
2714 $ret = 0;
2715 } else {
2716 $ret = 1;
2717 }
2718 unlink($tarfile) if $remove_tarfile;
2719
2720 chdir($cwd) || die "chdir($cwd) failed: $!";
2721 return $ret;
2722 }
2723
2724
2725 =item C<tlcmp($file, $file)>
2726
2727 Compare two files considering CR, LF, and CRLF as equivalent.
2728 Returns 1 if different, 0 if the same.
2729
2730 =cut
2731
2732 sub tlcmp {
2733 my ($filea, $fileb) = @_;
2734 if (!defined($fileb)) {
2735 die <<END_USAGE;
2736 tlcmp needs two arguments FILE1 FILE2.
2737 Compare as text files, ignoring line endings.
2738 Exit status is zero if the same, 1 if different, something else if trouble.
2739 END_USAGE
2740 }
2741 my $file1 = &read_file_ignore_cr ($filea);
2742 my $file2 = &read_file_ignore_cr ($fileb);
2743
2744 return $file1 eq $file2 ? 0 : 1;
2745 }
2746
2747
2748 =item C<read_file_ignore_cr($file)>
2749
2750 Return contents of FILE as a string, converting all of CR, LF, and
2751 CRLF to just LF.
2752
2753 =cut
2754
2755 sub read_file_ignore_cr {
2756 my ($fname) = @_;
2757 my $ret = "";
2758
2759 local *FILE;
2760 open (FILE, $fname) || die "open($fname) failed: $!";
2761 while (<FILE>) {
2762 s/\r\n?/\n/g;
2763 #warn "line is |$_|";
2764 $ret .= $_;
2765 }
2766 close (FILE) || warn "close($fname) failed: $!";
2767
2768 return $ret;
2769 }
2770
2771
2772 =item C<setup_programs($bindir, $platform, $tlfirst)>
2773
2774 Populate the global C<$::progs> hash containing the paths to the
2775 programs C<lz4>, C<tar>, C<wget>, C<xz>. The C<$bindir> argument specifies
2776 the path to the location of the C<xz> binaries, the C<$platform>
2777 gives the TeX Live platform name, used as the extension on our
2778 executables. If a program is not present in the TeX Live tree, we also
2779 check along PATH (without the platform extension.)
2780
2781 If the C<$tlfirst> argument or the C<TEXLIVE_PREFER_OWN> envvar is set,
2782 prefer TL versions; else prefer system versions (except for Windows
2783 C<tar.exe>, where we always use ours).
2784
2785 Check many different downloads and compressors to determine what is
2786 working.
2787
2788 Return 0 if failure, nonzero if success.
2789
2790 =cut
2791
2792 sub setup_programs {
2793 my ($bindir, $platform, $tlfirst) = @_;
2794 my $ok = 1;
2795
2796 # tlfirst is (currently) not passed in by either the installer or
2797 # tlmgr, so it will be always false.
2798 # If it is not defined, we check for the env variable
2799 # TEXLIVE_PREFER_OWN
2800 #
2801 if (!defined($tlfirst)) {
2802 if ($ENV{'TEXLIVE_PREFER_OWN'}) {
2803 debug("setup_programs: TEXLIVE_PREFER_OWN is set!\n");
2804 $tlfirst = 1;
2805 }
2806 }
2807
2808 debug("setup_programs: preferring " . ($tlfirst ? "TL" : "system") . " versions\n");
2809
2810 my $isWin = ($^O =~ /^MSWin/i);
2811
2812 if ($isWin) {
2813 # we need to make sure that we use our own tar, since
2814 # Windows system tar is stupid bsdtar ...
2815 setup_one("w32", 'tar', "$bindir/tar.exe", "--version", 1);
2816 $platform = "exe";
2817 } else {
2818 # tar needs to be provided by the system, we not even check!
2819 $::progs{'tar'} = "tar";
2820
2821 setup_one("unix", "df", undef, "-P .", 0);
2822
2823 if (!defined($platform) || ($platform eq "")) {
2824 # we assume that we run from uncompressed media, so we can call
2825 # platform() and thus also the config.guess script but we have to
2826 # setup $::installerdir because the platform script relies on it
2827 $::installerdir = "$bindir/../..";
2828 $platform = platform();
2829 }
2830 }
2831
2832 # setup of the fallback downloaders
2833 my @working_downloaders;
2834 for my $dltype (@AcceptedFallbackDownloaders) {
2835 my $defprog = $FallbackDownloaderProgram{$dltype};
2836 # do not warn on errors
2837 push @working_downloaders, $dltype if
2838 setup_one(($isWin ? "w32" : "unix"), $defprog,
2839 "$bindir/$dltype/$defprog.$platform", "--version", $tlfirst);
2840 }
2841 # check for curl special stuff on MacOS
2842 if (member("curl", @working_downloaders) && platform() =~ m/darwin/) {
2843 # copied from platform_name
2844 chomp (my $sw_vers = `sw_vers -productVersion`);
2845 my ($os_major,$os_minor) = split (/\./, $sw_vers);
2846 if ($os_major == 10 && ($os_minor == 13 || $os_minor == 14)) {
2847 my @curlargs = @{$TeXLive::TLConfig::FallbackDownloaderArgs{'curl'}};
2848 # can't push new arg at end of list because builtin list ends with
2849 # -o to set the output file.
2850 unshift (@curlargs, '--cacert', "$::installerdir/tlpkg/installer/curl/curl-ca-bundle.crt");
2851 $TeXLive::TLConfig::FallbackDownloaderArgs{'curl'} = \@curlargs;
2852 debug("TLUtils::setup_programs: curl on old darwin, final curl args: @{$TeXLive::TLConfig::FallbackDownloaderArgs{'curl'}}\n");
2853 }
2854 }
2855 # check for wget/ssl support
2856 if (member("wget", @working_downloaders)) {
2857 debug("TLUtils::setup_programs: checking for ssl enabled wget\n");
2858 my @lines = `$::progs{'wget'} --version 2>&1`;
2859 if (grep(/\+ssl/, @lines)) {
2860 $::progs{'options'}{'wget-ssl'} = 1;
2861 my @wgetargs = @{$TeXLive::TLConfig::FallbackDownloaderArgs{'wget'}};
2862 # can't push new arg at end of list because builtin list ends with
2863 # -O to set the output file.
2864 unshift (@wgetargs, '--no-check-certificate');
2865 $TeXLive::TLConfig::FallbackDownloaderArgs{'wget'} = \@wgetargs;
2866 debug("TLUtils::setup_programs: wget has ssl, final wget args: @{$TeXLive::TLConfig::FallbackDownloaderArgs{'wget'}}\n");
2867 } else {
2868 debug("TLUtils::setup_programs: wget without ssl support found\n");
2869 $::progs{'options'}{'wget-ssl'} = 0;
2870 }
2871 }
2872 $::progs{'working_downloaders'} = [ @working_downloaders ];
2873 my @working_compressors;
2874 for my $defprog (sort
2875 { $Compressors{$a}{'priority'} <=> $Compressors{$b}{'priority'} }
2876 keys %Compressors) {
2877 # do not warn on errors
2878 if (setup_one(($isWin ? "w32" : "unix"), $defprog,
2879 "$bindir/$defprog/$defprog.$platform", "--version",
2880 $tlfirst)) {
2881 push @working_compressors, $defprog;
2882 # also set up $::{'compressor'} if not already done
2883 # this selects the first one, but we might reset this depending on
2884 # TEXLIVE_COMPRESSOR setting, see below
2885 defined($::progs{'compressor'}) || ($::progs{'compressor'} = $defprog);
2886 }
2887 }
2888 $::progs{'working_compressors'} = [ @working_compressors ];
2889
2890 # check whether selected downloader/compressor is working
2891 # for downloader we allow 'lwp' as setting, too
2892 if ($ENV{'TEXLIVE_DOWNLOADER'}
2893 && $ENV{'TEXLIVE_DOWNLOADER'} ne 'lwp'
2894 && !TeXLive::TLUtils::member($ENV{'TEXLIVE_DOWNLOADER'},
2895 @{$::progs{'working_downloaders'}})) {
2896 tlwarn(<<END_DOWNLOADER_BAD);
2897 Selected download program TEXLIVE_DOWNLOADER=$ENV{'TEXLIVE_DOWNLOADER'}
2898 is not working!
2899 Please choose a different downloader or don't set TEXLIVE_DOWNLOADER.
2900 Detected working downloaders: @{$::progs{'working_downloaders'}}.
2901 END_DOWNLOADER_BAD
2902 $ok = 0;
2903 }
2904 if ($ENV{'TEXLIVE_COMPRESSOR'}
2905 && !TeXLive::TLUtils::member($ENV{'TEXLIVE_COMPRESSOR'},
2906 @{$::progs{'working_compressors'}})) {
2907 tlwarn(<<END_COMPRESSOR_BAD);
2908 Selected compression program TEXLIVE_COMPRESSOR=$ENV{'TEXLIVE_COMPRESSOR'}
2909 is not working!
2910 Please choose a different compressor or don't set TEXLIVE_COMPRESSOR.
2911 Detected working compressors: @{$::progs{'working_compressors'}}.
2912 END_COMPRESSOR_BAD
2913 $ok = 0;
2914 }
2915 # setup default compressor $::progs{'compressor'} which is used in
2916 # tlmgr in the calls to make_container. By default we have already
2917 # chosen the first that is actually working from our list of
2918 # @AcceptableCompressors, but let the user override this.
2919 if ($ENV{'TEXLIVE_COMPRESSOR'}) {
2920 $::progs{'compressor'} = $ENV{'TEXLIVE_COMPRESSOR'};
2921 }
2922
2923 if ($::opt_verbosity >= 2) {
2924 require Data::Dumper;
2925 # avoid spurious "used only once" warnings due to require
2926 # (warnings restored at end of scope). https://perlmonks.org/?node_id=3333
2927 no warnings 'once';
2928 local $Data::Dumper::Sortkeys = 1; # stable output
2929 local $Data::Dumper::Purity = 1; # reconstruct recursive structures
2930 print STDERR "DD:dumping ";
2931 print STDERR Data::Dumper->Dump([\%::progs], [qw(::progs)]);
2932 }
2933 return $ok;
2934 }
2935
2936 sub setup_one {
2937 my ($what, $p, $def, $arg, $tlfirst) = @_;
2938 my $setupfunc = ($what eq "unix") ? \&setup_unix_tl_one : \&setup_windows_tl_one ;
2939 if ($tlfirst) {
2940 if (&$setupfunc($p, $def, $arg)) {
2941 return(1);
2942 } else {
2943 return(setup_system_one($p, $arg));
2944 }
2945 } else {
2946 if (setup_system_one($p, $arg)) {
2947 return(1);
2948 } else {
2949 return(&$setupfunc($p, $def, $arg));
2950 }
2951 }
2952 }
2953
2954 sub setup_system_one {
2955 my ($p, $arg) = @_;
2956 my $nulldev = nulldev();
2957 ddebug("trying to set up system $p, arg $arg\n");
2958 my $ret = system("$p $arg >$nulldev 2>&1");
2959 if ($ret == 0) {
2960 debug("program $p found in path\n");
2961 $::progs{$p} = $p;
2962 return(1);
2963 } else {
2964 debug("program $p not usable from path\n");
2965 return(0);
2966 }
2967 }
2968
2969 sub setup_windows_tl_one {
2970 my ($p, $def, $arg) = @_;
2971 debug("(w32) trying to set up $p, default $def, arg $arg\n");
2972
2973 if (-r $def) {
2974 my $prog = conv_to_w32_path($def);
2975 my $ret = system("$prog $arg >nul 2>&1"); # on windows
2976 if ($ret == 0) {
2977 debug("Using shipped $def for $p (tested).\n");
2978 $::progs{$p} = $prog;
2979 return(1);
2980 } else {
2981 tlwarn("Setting up $p with $def as $prog didn't work\n");
2982 system("$prog $arg");
2983 return(0);
2984 }
2985 } else {
2986 debug("Default program $def not readable?\n");
2987 return(0);
2988 }
2989 }
2990
2991
2992 # setup one prog on unix using the following logic:
2993 # - if the shipped one is -x and can be executed, use it
2994 # - if the shipped one is -x but cannot be executed, copy it. set -x
2995 # . if the copy is -x and executable, use it
2996 # - if the shipped one is not -x, copy it, set -x
2997 # . if the copy is -x and executable, use it
2998 sub setup_unix_tl_one {
2999 my ($p, $def, $arg) = @_;
3000 if (!$def) {
3001 debug("(unix) no default program for $p, no setup done\n");
3002 return(1);
3003 }
3004 our $tmp;
3005 debug("(unix) trying to set up $p, default $def, arg $arg\n");
3006 if (-r $def) {
3007 if (-x $def) {
3008 ddebug(" Default $def has executable permissions\n");
3009 # we have to check for actual "executability" since a "noexec"
3010 # mount option may interfere, which is not taken into account by -x.
3011 my $ret = system("'$def' $arg >/dev/null 2>&1" ); # we are on Unix
3012 if ($ret == 0) {
3013 $::progs{$p} = $def;
3014 debug(" Using shipped $def for $p (tested).\n");
3015 return(1);
3016 } else {
3017 ddebug(" Shipped $def has -x but cannot be executed, "
3018 . "trying tmp copy.\n");
3019 }
3020 }
3021 # we are still here
3022 # out of some reasons we couldn't execute the shipped program
3023 # try to copy it to a temp directory and make it executable
3024 #
3025 # create tmp dir only when necessary
3026 $tmp = TeXLive::TLUtils::tl_tmpdir() unless defined($tmp);
3027 # probably we are running from uncompressed media and want to copy it to
3028 # some temporary location
3029 copy($def, $tmp);
3030 my $bn = basename($def);
3031 my $tmpprog = "$tmp/$bn";
3032 chmod(0755,$tmpprog);
3033 # we do not check the return value of chmod, but check whether
3034 # the -x bit is now set, the only thing that counts
3035 if (! -x $tmpprog) {
3036 # hmm, something is going really bad, not even the copy is
3037 # executable. Fall back to normal path element
3038 ddebug(" Copied $p $tmpprog does not have -x bit, strange!\n");
3039 return(0);
3040 } else {
3041 # check again for executability
3042 my $ret = system("$tmpprog $arg > /dev/null 2>&1");
3043 if ($ret == 0) {
3044 # ok, the copy works
3045 debug(" Using copied $tmpprog for $p (tested).\n");
3046 $::progs{$p} = $tmpprog;
3047 return(1);
3048 } else {
3049 # even the copied prog is not executable, strange
3050 ddebug(" Copied $p $tmpprog has x bit but not executable?!\n");
3051 return(0);
3052 }
3053 }
3054 } else {
3055 # default program is not readable
3056 return(0);
3057 }
3058 }
3059
3060
3061 =item C<download_file( $relpath, $destination )>
3062
3063 Try to download the file given in C<$relpath> from C<$TeXLiveURL>
3064 into C<$destination>, which can be either
3065 a filename of simply C<|>. In the latter case a file handle is returned.
3066
3067 Downloading first checks for the environment variable C<TEXLIVE_DOWNLOADER>,
3068 which takes various built-in values. If not set, the next check is for
3069 C<TL_DOWNLOAD_PROGRAM> and C<TL_DOWNLOAD_ARGS>. The former overrides the
3070 above specification devolving to C<wget>, and the latter overrides the
3071 default wget arguments.
3072
3073 C<TL_DOWNLOAD_ARGS> must be defined so that the file the output goes to
3074 is the first argument after the C<TL_DOWNLOAD_ARGS>. Thus, for wget it
3075 would end in C<-O>. Use with care.
3076
3077 =cut
3078
3079 sub download_file {
3080 my ($relpath, $dest) = @_;
3081 # create output dir if necessary
3082 my $par;
3083 if ($dest ne "|") {
3084 $par = dirname($dest);
3085 mkdirhier ($par) unless -d "$par";
3086 }
3087 my $url;
3088 if ($relpath =~ m;^file://*(.*)$;) {
3089 my $filetoopen = "/$1";
3090 # $dest is a file name, we have to get the respective dirname
3091 if ($dest eq "|") {
3092 open(RETFH, "<$filetoopen") or
3093 die("Cannot open $filetoopen for reading");
3094 # opening to a pipe always succeeds, so we return immediately
3095 return \*RETFH;
3096 } else {
3097 if (-r $filetoopen) {
3098 copy ("-f", "-L", $filetoopen, $dest);
3099 return 1;
3100 }
3101 return 0;
3102 }
3103 }
3104
3105 if ($relpath =~ m!$SshURIRegex!) {
3106 my $downdest;
3107 if ($dest eq "|") {
3108 my ($fh, $fn) = TeXLive::TLUtils::tl_tmpfile();
3109 $downdest = $fn;
3110 } else {
3111 $downdest = $dest;
3112 }
3113 # massage ssh:// into the scp-acceptable scp://
3114 $relpath =~ s!^ssh://!scp://!;
3115 my $retval = system("scp", "-q", $relpath, $downdest);
3116 if ($retval != 0) {
3117 $retval /= 256 if $retval > 0;
3118 my $pwd = cwd ();
3119 tlwarn("$0: system(scp -q $relpath $downdest) failed in $pwd, status $retval");
3120 return 0;
3121 }
3122 if ($dest eq "|") {
3123 open(RETFH, "<$downdest") or
3124 die("Cannot open $downdest for reading");
3125 # opening to a pipe always succeeds, so we return immediately
3126 return \*RETFH;
3127 } else {
3128 return 1;
3129 }
3130 }
3131
3132 if ($relpath =~ /^(https?|ftp):\/\//) {
3133 $url = $relpath;
3134 } else {
3135 $url = "$TeXLiveURL/$relpath";
3136 }
3137
3138 my @downloader_trials;
3139 if ($ENV{'TEXLIVE_DOWNLOADER'}) {
3140 push @downloader_trials, $ENV{'TEXLIVE_DOWNLOADER'};
3141 } elsif ($ENV{"TL_DOWNLOAD_PROGRAM"}) {
3142 push @downloader_trials, 'custom';
3143 } else {
3144 @downloader_trials = qw/lwp curl wget/;
3145 }
3146
3147 my $success = 0;
3148 for my $downtype (@downloader_trials) {
3149 if ($downtype eq 'lwp') {
3150 if (_download_file_lwp($url, $dest)) {
3151 $success = $downtype;
3152 last;
3153 }
3154 }
3155 if ($downtype eq "custom" || TeXLive::TLUtils::member($downtype, @{$::progs{'working_downloaders'}})) {
3156 if (_download_file_program($url, $dest, $downtype)) {
3157 $success = $downtype;
3158 last;
3159 }
3160 }
3161 }
3162 if ($success) {
3163 debug("TLUtils::download_file: downloading using $success succeeded\n");
3164 return(1);
3165 } else {
3166 debug("TLUtils::download_file: tried to download using @downloader_trials, none succeeded\n");
3167 return(0);
3168 }
3169 }
3170
3171
3172 sub _download_file_lwp {
3173 my ($url, $dest) = @_;
3174 if (!defined($::tldownload_server)) {
3175 ddebug("::tldownload_server not defined\n");
3176 return(0);
3177 }
3178 if (!$::tldownload_server->enabled) {
3179 # try to reinitialize a disabled connection
3180 # disabling happens after 6 failed download trials
3181 # we just re-initialize the connection
3182 if (!setup_persistent_downloads()) {
3183 # setup failed, give up
3184 debug("reinitialization of LWP download failed\n");
3185 return(0);
3186 }
3187 # we don't need to check for ->enabled, because
3188 # setup_persistent_downloads calls TLDownload->new()
3189 # which, if it succeeds, automatically set enabled to 1
3190 }
3191 # we are still here, so try to download
3192 debug("persistent connection set up, trying to get $url (for $dest)\n");
3193 my $ret = $::tldownload_server->get_file($url, $dest);
3194 if ($ret) {
3195 ddebug("downloading file via persistent connection succeeded\n");
3196 return $ret;
3197 } else {
3198 debug("TLUtils::download_file: persistent connection ok,"
3199 . " but download failed: $url\n");
3200 debug("TLUtils::download_file: retrying with other downloaders.\n");
3201 }
3202 # if we are still here, download with LWP didn't succeed.
3203 return(0);
3204 }
3205
3206
3207 sub _download_file_program {
3208 my ($url, $dest, $type) = @_;
3209 if (wndws()) {
3210 $dest =~ s!/!\\!g;
3211 }
3212
3213 debug("TLUtils::_download_file_program: $type $url $dest\n");
3214 my $downloader;
3215 my $downloaderargs;
3216 my @downloaderargs;
3217 if ($type eq 'custom') {
3218 $downloader = $ENV{"TL_DOWNLOAD_PROGRAM"};
3219 if ($ENV{"TL_DOWNLOAD_ARGS"}) {
3220 $downloaderargs = $ENV{"TL_DOWNLOAD_ARGS"};
3221 @downloaderargs = split(' ', $downloaderargs);
3222 }
3223 } else {
3224 $downloader = $::progs{$FallbackDownloaderProgram{$type}};
3225 @downloaderargs = @{$FallbackDownloaderArgs{$type}};
3226 $downloaderargs = join(' ',@downloaderargs);
3227 }
3228
3229 debug("downloading $url using $downloader $downloaderargs\n");
3230 my $ret;
3231 if ($dest eq "|") {
3232 open(RETFH, "$downloader $downloaderargs - $url|")
3233 || die "open($url) via $downloader $downloaderargs failed: $!";
3234 # opening to a pipe always succeeds, so we return immediately
3235 return \*RETFH;
3236 } else {
3237 $ret = system ($downloader, @downloaderargs, $dest, $url);
3238 # we have to reverse the meaning of ret because system has 0=success.
3239 $ret = ($ret ? 0 : 1);
3240 }
3241 # return false/undef in case the download did not succeed.
3242 return ($ret) unless $ret;
3243 debug("download of $url succeeded\n");
3244 if ($dest eq "|") {
3245 return \*RETFH;
3246 } else {
3247 return 1;
3248 }
3249 }
3250
3251 =item C<nulldev ()>
3252
3253 Return C</dev/null> on Unix and C<nul> on Windows.
3254
3255 =cut
3256
3257 sub nulldev {
3258 return (&wndws()) ? 'nul' : '/dev/null';
3259 }
3260
3261 =item C<get_full_line ($fh)>
3262
3263 returns the next line from the file handle $fh, taking
3264 continuation lines into account (last character of a line is \, and
3265 no quoting is parsed).
3266
3267 =cut
3268
3269 # open my $f, '<', $file_name or die;
3270 # while (my $l = get_full_line($f)) { ... }
3271 # close $f or die;
3272 sub get_full_line {
3273 my ($fh) = @_;
3274 my $line = <$fh>;
3275 return undef unless defined $line;
3276 return $line unless $line =~ s/\\\r?\n$//;
3277 my $cont = get_full_line($fh);
3278 if (!defined($cont)) {
3279 tlwarn('Continuation disallowed at end of file');
3280 $cont = "";
3281 }
3282 $cont =~ s/^\s*//;
3283 return $line . $cont;
3284 }
3285
3286
3287 =back
3288
3289 =head2 Installer Functions
3290
3291 =over 4
3292
3293 =item C<make_var_skeleton($prefix)>
3294
3295 Generate a skeleton of empty directories in the C<TEXMFSYSVAR> tree.
3296
3297 =cut
3298
3299 sub make_var_skeleton {
3300 my ($prefix) = @_;
3301
3302 mkdirhier "$prefix/tex/generic/config";
3303 mkdirhier "$prefix/fonts/map/dvipdfmx/updmap";
3304 mkdirhier "$prefix/fonts/map/dvips/updmap";
3305 mkdirhier "$prefix/fonts/map/pdftex/updmap";
3306 mkdirhier "$prefix/fonts/pk";
3307 mkdirhier "$prefix/fonts/tfm";
3308 mkdirhier "$prefix/web2c";
3309 mkdirhier "$prefix/xdvi";
3310 mkdirhier "$prefix/tex/context/config";
3311 }
3312
3313
3314 =item C<make_local_skeleton($prefix)>
3315
3316 Generate a skeleton of empty directories in the C<TEXMFLOCAL> tree,
3317 unless C<TEXMFLOCAL> already exists.
3318
3319 =cut
3320
3321 sub make_local_skeleton {
3322 my ($prefix) = @_;
3323
3324 return if (-d $prefix);
3325
3326 mkdirhier "$prefix/bibtex/bib/local";
3327 mkdirhier "$prefix/bibtex/bst/local";
3328 mkdirhier "$prefix/doc/local";
3329 mkdirhier "$prefix/dvips/local";
3330 mkdirhier "$prefix/fonts/source/local";
3331 mkdirhier "$prefix/fonts/tfm/local";
3332 mkdirhier "$prefix/fonts/type1/local";
3333 mkdirhier "$prefix/fonts/vf/local";
3334 mkdirhier "$prefix/metapost/local";
3335 mkdirhier "$prefix/tex/latex/local";
3336 mkdirhier "$prefix/tex/plain/local";
3337 mkdirhier "$prefix/tlpkg";
3338 mkdirhier "$prefix/web2c";
3339 }
3340
3341
3342 =item C<create_fmtutil($tlpdb, $dest)>
3343
3344 =item C<create_updmap($tlpdb, $dest)>
3345
3346 =item C<create_language_dat($tlpdb, $dest, $localconf)>
3347
3348 =item C<create_language_def($tlpdb, $dest, $localconf)>
3349
3350 =item C<create_language_lua($tlpdb, $dest, $localconf)>
3351
3352 These five functions create C<fmtutil.cnf>, C<updmap.cfg>, C<language.dat>,
3353 C<language.def>, and C<language.dat.lua> respectively, in C<$dest> (which by
3354 default is below C<$TEXMFSYSVAR>). These functions merge the information
3355 present in the TLPDB C<$tlpdb> (formats, maps, hyphenations) with local
3356 configuration additions: C<$localconf>.
3357
3358 Currently the merging is done by omitting disabled entries specified
3359 in the local file, and then appending the content of the local
3360 configuration files at the end of the file. We should also check for
3361 duplicates, maybe even error checking.
3362
3363 =cut
3364
3365 #
3366 # get_disabled_local_configs
3367 # returns the list of disabled formats/hyphenpatterns/maps
3368 # disabling is done by putting
3369 # #!NAME
3370 # or
3371 # %!NAME
3372 # into the respective foo-local.cnf/cfg file
3373 #
3374 sub get_disabled_local_configs {
3375 my $localconf = shift;
3376 my $cc = shift;
3377 my @disabled = ();
3378 if ($localconf && -r $localconf) {
3379 open (FOO, "<$localconf")
3380 || die "strange, -r ok but open($localconf) failed: $!";
3381 my @tmp = <FOO>;
3382 close(FOO) || warn("close($localconf) failed: $!");
3383 @disabled = map { if (m/^$cc!(\S+)\s*$/) { $1 } else { } } @tmp;
3384 }
3385 return @disabled;
3386 }
3387
3388 sub create_fmtutil {
3389 my ($tlpdb,$dest) = @_;
3390 my @lines = $tlpdb->fmtutil_cnf_lines();
3391 _create_config_files($tlpdb, "texmf-dist/web2c/fmtutil-hdr.cnf", $dest,
3392 undef, 0, '#', \@lines);
3393 }
3394
3395 sub create_updmap {
3396 my ($tlpdb,$dest) = @_;
3397 check_for_old_updmap_cfg();
3398 my @tlpdblines = $tlpdb->updmap_cfg_lines();
3399 _create_config_files($tlpdb, "texmf-dist/web2c/updmap-hdr.cfg", $dest,
3400 undef, 0, '#', \@tlpdblines);
3401 }
3402
3403 sub check_for_old_updmap_cfg {
3404 chomp( my $tmfsysconf = `kpsewhich -var-value=TEXMFSYSCONFIG` ) ;
3405 my $oldupd = "$tmfsysconf/web2c/updmap.cfg";
3406 return unless -r $oldupd; # if no such file, good.
3407
3408 open (OLDUPD, "<$oldupd") || die "open($oldupd) failed: $!";
3409 my $firstline = <OLDUPD>;
3410 close(OLDUPD);
3411 # cygwin returns undef when reading from an empty file, we have
3412 # to make sure that this is anyway initialized
3413 $firstline = "" if (!defined($firstline));
3414 chomp ($firstline);
3415 #
3416 if ($firstline =~ m/^# Generated by (install-tl|.*\/tlmgr) on/) {
3417 # assume it was our doing, rename it.
3418 my $nn = "$oldupd.DISABLED";
3419 if (-r $nn) {
3420 my $fh;
3421 ($fh, $nn) = tl_tmpfile(
3422 "updmap.cfg.DISABLED.XXXXXX", DIR => "$tmfsysconf/web2c");
3423 }
3424 print "Renaming old config file from
3425 $oldupd
3426 to
3427 $nn
3428 ";
3429 if (rename($oldupd, $nn)) {
3430 if (system("mktexlsr", $tmfsysconf) != 0) {
3431 die "mktexlsr $tmfsysconf failed after updmap.cfg rename, fix fix: $!";
3432 }
3433 print "No further action should be necessary.\n";
3434 } else {
3435 print STDERR "
3436 Renaming of
3437 $oldupd
3438 did not succeed. This config file should not be used anymore,
3439 so please do what's necessary to eliminate it.
3440 See the documentation for updmap.
3441 ";
3442 }
3443
3444 } else { # first line did not match
3445 # that is NOT a good idea, because updmap creates updmap.cfg in
3446 # TEXMFSYSCONFIG when called with --enable Map etc, so we should
3447 # NOT warn here
3448 # print STDERR "Apparently
3449 # $oldupd
3450 # was created by hand. This config file should not be used anymore,
3451 # so please do what's necessary to eliminate it.
3452 # See the documentation for updmap.
3453 # ";
3454 }
3455 }
3456
3457 sub check_updmap_config_value {
3458 my ($k, $v, $f) = @_;
3459 return 0 if !defined($k);
3460 return 0 if !defined($v);
3461 if (member( $k, qw/dvipsPreferOutline dvipsDownloadBase35
3462 pdftexDownloadBase14 dvipdfmDownloadBase14/)) {
3463 if ($v eq "true" || $v eq "false") {
3464 return 1;
3465 } else {
3466 tlwarn("Unknown setting for $k in $f: $v\n");
3467 return 0;
3468 }
3469 } elsif ($k eq "LW35") {
3470 if (member($v, qw/URW URWkb ADOBE ADOBEkb/)) {
3471 return 1;
3472 } else {
3473 tlwarn("Unknown setting for LW35 in $f: $v\n");
3474 return 0;
3475 }
3476 } elsif ($k eq "kanjiEmbed") {
3477 # any string is fine
3478 return 1;
3479 } else {
3480 return 0;
3481 }
3482 }
3483
3484 sub create_language_dat {
3485 my ($tlpdb,$dest,$localconf) = @_;
3486 # no checking for disabled stuff for language.dat and .def
3487 my @lines = $tlpdb->language_dat_lines(
3488 get_disabled_local_configs($localconf, '%'));
3489 _create_config_files($tlpdb, "texmf-dist/tex/generic/config/language.us",
3490 $dest, $localconf, 0, '%', \@lines);
3491 }
3492
3493 sub create_language_def {
3494 my ($tlpdb,$dest,$localconf) = @_;
3495 # no checking for disabled stuff for language.dat and .def
3496 my @lines = $tlpdb->language_def_lines(
3497 get_disabled_local_configs($localconf, '%'));
3498 my @postlines;
3499 push @postlines, "%%% No changes may be made beyond this point.\n";
3500 push @postlines, "\n";
3501 push @postlines, "\\uselanguage {USenglish} %%% This MUST be the last line of the file.\n";
3502 _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.def",
3503 $dest, $localconf, 1, '%', \@lines, @postlines);
3504 }
3505
3506 sub create_language_lua {
3507 my ($tlpdb,$dest,$localconf) = @_;
3508 # no checking for disabled stuff for language.dat and .lua
3509 my @lines = $tlpdb->language_lua_lines(
3510 get_disabled_local_configs($localconf, '--'));
3511 my @postlines = ("}\n");
3512 _create_config_files ($tlpdb,"texmf-dist/tex/generic/config/language.us.lua",
3513 $dest, $localconf, 0, '--', \@lines, @postlines);
3514 }
3515
3516 sub _create_config_files {
3517 my ($tlpdb, $headfile, $dest,$localconf, $keepfirstline, $cc,
3518 $tlpdblinesref, @postlines) = @_;
3519 my $root = $tlpdb->root;
3520 my @lines = ();
3521 my $usermode = $tlpdb->setting( "usertree" );
3522 if (-r "$root/$headfile") {
3523 open (INFILE, "<$root/$headfile")
3524 || die "open($root/$headfile) failed, but -r ok: $!";
3525 @lines = <INFILE>;
3526 close (INFILE);
3527 } elsif (!$usermode) {
3528 # we might be in user mode and then do *not* want the generation
3529 # of the configuration file to just bail out.
3530 tldie ("TLUtils::_create_config_files: giving up, unreadable: "
3531 . "$root/$headfile\n")
3532 }
3533 push @lines, @$tlpdblinesref;
3534 if (defined($localconf) && -r $localconf) {
3535 #
3536 # this should be done more intelligently, but for now only add those
3537 # lines without any duplication check ...
3538 open (FOO, "<$localconf")
3539 || die "strange, -r ok but cannot open $localconf: $!";
3540 my @tmp = <FOO>;
3541 close (FOO);
3542 push @lines, @tmp;
3543 }
3544 if (@postlines) {
3545 push @lines, @postlines;
3546 }
3547 if ($usermode && -e $dest) {
3548 tlwarn("Updating $dest, backup copy in $dest.backup\n");
3549 copy("-f", $dest, "$dest.backup");
3550 }
3551 open(OUTFILE,">$dest")
3552 or die("Cannot open $dest for writing: $!");
3553
3554 if (!$keepfirstline) {
3555 print OUTFILE $cc;
3556 printf OUTFILE " Generated by %s on %s\n", "$0", scalar localtime;
3557 }
3558 print OUTFILE @lines;
3559 close(OUTFILE) || warn "close(>$dest) failed: $!";
3560 }
3561
3562 sub parse_AddHyphen_line {
3563 my $line = shift;
3564 my %ret;
3565 # default values
3566 my $default_lefthyphenmin = 2;
3567 my $default_righthyphenmin = 3;
3568 $ret{"lefthyphenmin"} = $default_lefthyphenmin;
3569 $ret{"righthyphenmin"} = $default_righthyphenmin;
3570 $ret{"synonyms"} = [];
3571 for my $p (quotewords('\s+', 0, "$line")) {
3572 my ($a, $b) = split /=/, $p;
3573 if ($a eq "name") {
3574 if (!$b) {
3575 $ret{"error"} = "AddHyphen line needs name=something";
3576 return %ret;
3577 }
3578 $ret{"name"} = $b;
3579 next;
3580 }
3581 if ($a eq "lefthyphenmin") {
3582 $ret{"lefthyphenmin"} = ( $b ? $b : $default_lefthyphenmin );
3583 next;
3584 }
3585 if ($a eq "righthyphenmin") {
3586 $ret{"righthyphenmin"} = ( $b ? $b : $default_righthyphenmin );
3587 next;
3588 }
3589 if ($a eq "file") {
3590 if (!$b) {
3591 $ret{"error"} = "AddHyphen line needs file=something";
3592 return %ret;
3593 }
3594 $ret{"file"} = $b;
3595 next;
3596 }
3597 if ($a eq "file_patterns") {
3598 $ret{"file_patterns"} = $b;
3599 next;
3600 }
3601 if ($a eq "file_exceptions") {
3602 $ret{"file_exceptions"} = $b;
3603 next;
3604 }
3605 if ($a eq "luaspecial") {
3606 $ret{"luaspecial"} = $b;
3607 next;
3608 }
3609 if ($a eq "databases") {
3610 @{$ret{"databases"}} = split /,/, $b;
3611 next;
3612 }
3613 if ($a eq "synonyms") {
3614 @{$ret{"synonyms"}} = split /,/, $b;
3615 next;
3616 }
3617 if ($a eq "comment") {
3618 $ret{"comment"} = $b;
3619 next;
3620 }
3621 # should not be reached at all
3622 $ret{"error"} = "Unknown language directive $a";
3623 return %ret;
3624 }
3625 # this default value couldn't be set earlier
3626 if (not defined($ret{"databases"})) {
3627 if (defined $ret{"file_patterns"} or defined $ret{"file_exceptions"}
3628 or defined $ret{"luaspecial"}) {
3629 @{$ret{"databases"}} = qw(dat def lua);
3630 } else {
3631 @{$ret{"databases"}} = qw(dat def);
3632 }
3633 }
3634 return %ret;
3635 }
3636
3637 #
3638 # return hash of items on AddFormat line LINE (which must not have the
3639 # leading "execute AddFormat"). If parse fails, hash will contain a key
3640 # "error" with a message.
3641 #
3642 sub parse_AddFormat_line {
3643 my $line = shift;
3644 my %ret;
3645 $ret{"options"} = "";
3646 $ret{"patterns"} = "-";
3647 $ret{"mode"} = 1;
3648 for my $p (quotewords('\s+', 0, "$line")) {
3649 my ($a, $b);
3650 if ($p =~ m/^(name|engine|mode|patterns|options|fmttriggers)=(.*)$/) {
3651 $a = $1;
3652 $b = $2;
3653 } else {
3654 $ret{"error"} = "Unknown format directive $p";
3655 return %ret;
3656 }
3657 if ($a eq "name") {
3658 if (!$b) {
3659 $ret{"error"} = "AddFormat line needs name=something";
3660 return %ret;
3661 }
3662 $ret{"name"} = $b;
3663 next;
3664 }
3665 if ($a eq "engine") {
3666 if (!$b) {
3667 $ret{"error"} = "AddFormat line needs engine=something";
3668 return %ret;
3669 }
3670 $ret{"engine"} = $b;
3671 next;
3672 }
3673 if ($a eq "patterns") {
3674 $ret{"patterns"} = ( $b ? $b : "-" );
3675 next;
3676 }
3677 if ($a eq "mode") {
3678 $ret{"mode"} = ( $b eq "disabled" ? 0 : 1 );
3679 next;
3680 }
3681 if ($a eq "options") {
3682 $ret{"options"} = ( $b ? $b : "" );
3683 next;
3684 }
3685 if ($a eq "fmttriggers") {
3686 my @tl = split(',',$b);
3687 $ret{"fmttriggers"} = \@tl ;
3688 next;
3689 }
3690 # should not be reached at all
3691 $ret{"error"} = "Unknown format directive $p";
3692 return %ret;
3693 }
3694 return %ret;
3695 }
3696
3697 =back
3698
3699 =head2 Logging
3700
3701 Logging and debugging messages.
3702
3703 =over 4
3704
3705 =item C<logit($out,$level,@rest)>
3706
3707 Internal routine to write message to both C<$out> (references to
3708 filehandle) and C<$::LOGFILE>, at level C<$level>, of concatenated items
3709 in C<@rest>. If the log file is not initialized yet, the message is
3710 saved to be logged later (unless the log file never comes into existence).
3711
3712 =cut
3713
3714 sub logit {
3715 my ($out, $level, @rest) = @_;
3716 _logit($out, $level, @rest) unless $::opt_quiet;
3717 _logit('file', $level, @rest);
3718 }
3719
3720 sub _logit {
3721 my ($out, $level, @rest) = @_;
3722 if ($::opt_verbosity >= $level) {
3723 # if $out is a ref/glob to STDOUT or STDERR, print it there
3724 if (ref($out) eq "GLOB") {
3725 print $out @rest;
3726 } else {
3727 # we should log it into the logfile, but that might be not initialized
3728 # so either print it to the filehandle $::LOGFILE, or push it onto
3729 # the to be printed log lines @::LOGLINES
3730 if (defined($::LOGFILE)) {
3731 print $::LOGFILE @rest;
3732 } else {
3733 push (@::LOGLINES, join ("", @rest));
3734 }
3735 }
3736 }
3737 }
3738
3739 =item C<info ($str1, $str2, ...)>
3740
3741 Write a normal informational message, the concatenation of the argument
3742 strings. The message will be written unless C<-q> was specified. If
3743 the global C<$::machinereadable> is set (the C<--machine-readable>
3744 option to C<tlmgr>), then output is written to stderr, else to stdout.
3745 If the log file (see L<process_logging_options>) is defined, it also
3746 writes there.
3747
3748 It is best to use this sparingly, mainly to give feedback during lengthy
3749 operations and for final results.
3750
3751 =cut
3752
3753 sub info {
3754 my $str = join("", @_);
3755 my $fh = ($::machinereadable ? \*STDERR : \*STDOUT);
3756 logit($fh, 0, $str);
3757 for my $i (@::info_hook) {
3758 &{$i}($str);
3759 }
3760 }
3761
3762 =item C<debug ($str1, $str2, ...)>
3763
3764 Write a debugging message, the concatenation of the argument strings.
3765 The message will be omitted unless C<-v> was specified. If the log
3766 file (see L<process_logging_options>) is defined, it also writes there.
3767
3768 This first level debugging message reports on the overall flow of
3769 work, but does not include repeated messages about processing of each
3770 package.
3771
3772 =cut
3773
3774 sub debug {
3775 return if ($::opt_verbosity < 1);
3776 my $str = "D:" . join("", @_);
3777 logit(\*STDERR, 1, $str);
3778 for my $i (@::debug_hook) {
3779 &{$i}($str);
3780 }
3781 }
3782
3783 =item C<ddebug ($str1, $str2, ...)>
3784
3785 Write a deep debugging message, the concatenation of the argument
3786 strings. The message will be omitted unless C<-v -v> (or higher) was
3787 specified. If the log file (see L<process_logging_options>) is defined,
3788 it also writes there.
3789
3790 This second level debugging message reports messages about processing
3791 each package, in addition to the first level.
3792
3793 =cut
3794
3795 sub ddebug {
3796 return if ($::opt_verbosity < 2);
3797 my $str = "DD:" . join("", @_);
3798 logit(\*STDERR, 2, $str);
3799 for my $i (@::ddebug_hook) {
3800 &{$i}($str);
3801 }
3802 }
3803
3804 =item C<dddebug ($str1, $str2, ...)>
3805
3806 Write the deepest debugging message, the concatenation of the argument
3807 strings. The message will be omitted unless C<-v -v -v> was specified.
3808 If the log file (see L<process_logging_options>) is defined, it also
3809 writes there.
3810
3811 In addition to the first and second levels, this third level debugging
3812 message reports messages about processing each line of any tlpdb files
3813 read, and messages about files tested or matched against tlpsrc
3814 patterns. This output is extremely voluminous, so unless you're
3815 debugging those parts of the code, it just gets in the way.
3816
3817 =cut
3818
3819 sub dddebug {
3820 return if ($::opt_verbosity < 3);
3821 my $str = "DDD:" . join("", @_);
3822 logit(\*STDERR, 3, $str);
3823 for my $i (@::dddebug_hook) {
3824 &{$i}($str);
3825 }
3826 }
3827
3828 =item C<log ($str1, $str2, ...)>
3829
3830 Write a message to the log file (and nowhere else), the concatenation of
3831 the argument strings. The log file may not ever be defined (e.g., the
3832 C<-logfile> option isn't given), in which case the message will never be
3833 written anywhere.
3834
3835 =cut
3836
3837 sub log {
3838 my $savequiet = $::opt_quiet;
3839 $::opt_quiet = 0;
3840 _logit('file', -100, @_);
3841 $::opt_quiet = $savequiet;
3842 }
3843
3844 =item C<tlwarn ($str1, $str2, ...)>
3845
3846 Write a warning message, the concatenation of the argument strings.
3847 This always and unconditionally writes the message to standard error; if
3848 the log file (see L<process_logging_options>) is defined, it also writes
3849 there.
3850
3851 =cut
3852
3853 sub tlwarn {
3854 my $savequiet = $::opt_quiet;
3855 my $str = join("", @_);
3856 $::opt_quiet = 0;
3857 logit (\*STDERR, -100, $str);
3858 $::opt_quiet = $savequiet;
3859 for my $i (@::warn_hook) {
3860 &{$i}($str);
3861 }
3862 }
3863
3864 =item C<tldie ($str1, $str2, ...)>
3865
3866 Uses C<tlwarn> to issue a warning for @_ preceded by a newline, then
3867 exits with exit code 1.
3868
3869 =cut
3870
3871 sub tldie {
3872 tlwarn("\n", @_);
3873 if ($::gui_mode) {
3874 Tk::exit(1);
3875 } else {
3876 exit(1);
3877 }
3878 }
3879
3880 =item C<debug_hash_str($label, HASH)>
3881
3882 Return LABEL followed by HASH elements, followed by a newline, as a
3883 single string. If HASH is a reference, it is followed (but no recursive
3884 derefencing).
3885
3886 =item C<debug_hash($label, HASH)>
3887
3888 Write the result of C<debug_hash_str> to stderr.
3889
3890 =cut
3891
3892 sub debug_hash_str {
3893 my ($label) = shift;
3894 my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_;
3895
3896 my $str = "$label: {";
3897 my @items = ();
3898 for my $key (sort keys %hash) {
3899 my $val = $hash{$key};
3900 $val = ".undef" if ! defined $val;
3901 $key =~ s/\n/\\n/g;
3902 $val =~ s/\n/\\n/g;
3903 push (@items, "$key:$val");
3904 }
3905 $str .= join (",", @items);
3906 $str .= "}";
3907
3908 return "$str\n";
3909 }
3910
3911 sub debug_hash {
3912 warn &debug_hash_str(@_);
3913 }
3914
3915 =item C<backtrace()>
3916
3917 Return call(er) stack, as a string.
3918
3919 =cut
3920
3921 sub backtrace {
3922 my $ret = "";
3923
3924 my ($filename, $line, $subr);
3925 my $stackframe = 1; # skip ourselves
3926 while ((undef,$filename,$line,$subr) = caller ($stackframe)) {
3927 # the undef is for the package, which is already included in $subr.
3928 $ret .= " -> ${filename}:${line}: ${subr}\n";
3929 $stackframe++;
3930 }
3931
3932 return $ret;
3933 }
3934
3935 =item C<process_logging_options ($texdir)>
3936
3937 This function handles the common logging options for TeX Live scripts.
3938 It should be called before C<GetOptions> for any program-specific option
3939 handling. For our conventional calling sequence, see (for example) the
3940 L<tlpfiles> script.
3941
3942 These are the options handled here:
3943
3944 =over 4
3945
3946 =item B<-q>
3947
3948 Omit normal informational messages.
3949
3950 =item B<-v>
3951
3952 Include debugging messages. With one C<-v>, reports overall flow; with
3953 C<-v -v> (or C<-vv>), also reports per-package processing; with C<-v -v
3954 -v> (or C<-vvv>), also reports each line read from any tlpdb files.
3955 Further repeats of C<-v>, as in C<-v -v -v -v>, are accepted but
3956 ignored. C<-vvvv> is an error.
3957
3958 The idea behind these levels is to be able to specify C<-v> to get an
3959 overall idea of what is going on, but avoid terribly voluminous output
3960 when processing many packages, as we often are. When debugging a
3961 specific problem with a specific package, C<-vv> can help. When
3962 debugging problems with parsing tlpdb files, C<-vvv> gives that too.
3963
3964 =item B<-logfile> I<file>
3965
3966 Write all messages (informational, debugging, warnings) to I<file>, in
3967 addition to standard output or standard error. In TeX Live, only the
3968 installer sets a log file by default; none of the other standard TeX
3969 Live scripts use this feature, but you can specify it explicitly.
3970
3971 =back
3972
3973 See also the L<info>, L<debug>, L<ddebug>, and L<tlwarn> functions,
3974 which actually write the messages.
3975
3976 =cut
3977
3978 sub process_logging_options {
3979 $::opt_verbosity = 0;
3980 $::opt_quiet = 0;
3981 my $opt_logfile;
3982 my $opt_Verbosity = 0;
3983 my $opt_VERBOSITY = 0;
3984 # check all the command line options for occurrences of -q and -v;
3985 # do not report errors.
3986 my $oldconfig = Getopt::Long::Configure(qw(pass_through permute));
3987 GetOptions("logfile=s" => \$opt_logfile,
3988 "v+" => \$::opt_verbosity,
3989 "vv" => \$opt_Verbosity,
3990 "vvv" => \$opt_VERBOSITY,
3991 "q" => \$::opt_quiet);
3992 Getopt::Long::Configure($oldconfig);
3993
3994 # verbosity level, forcing -v -v instead of -vv is too annoying.
3995 $::opt_verbosity = 2 if $opt_Verbosity;
3996 $::opt_verbosity = 3 if $opt_VERBOSITY;
3997
3998 # open log file if one was requested.
3999 if ($opt_logfile) {
4000 open(TLUTILS_LOGFILE, ">$opt_logfile")
4001 || die "open(>$opt_logfile) failed: $!\n";
4002 $::LOGFILE = \*TLUTILS_LOGFILE;
4003 $::LOGFILENAME = $opt_logfile;
4004 }
4005 }
4006
4007 =back
4008
4009 =head2 Miscellaneous
4010
4011 A few ideas from Fabrice Popineau's C<FileUtils.pm>.
4012
4013 =over 4
4014
4015 =item C<sort_uniq(@list)>
4016
4017 The C<sort_uniq> function sorts the given array and throws away multiple
4018 occurrences of elements. It returns a sorted and unified array.
4019
4020 =cut
4021
4022 sub sort_uniq {
4023 my (@l) = @_;
4024 my ($e, $f, @r);
4025 $f = "";
4026 @l = sort(@l);
4027 foreach $e (@l) {
4028 if ($e ne $f) {
4029 $f = $e;
4030 push @r, $e;
4031 }
4032 }
4033 return @r;
4034 }
4035
4036
4037 =item C<push_uniq(\@list, @new_items)>
4038
4039 The C<push_uniq> function pushes each element in the last argument
4040 @ITEMS to the $LIST referenced by the first argument, if it is not
4041 already in the list.
4042
4043 =cut
4044
4045 sub push_uniq {
4046 my ($l, @new_items) = @_;
4047 for my $e (@new_items) {
4048 # turns out this is one of the most-used functions when updating the
4049 # tlpdb, with hundreds of thousands of calls. So let's write it out
4050 # to eliminate the sub overhead.
4051 #if (! &member($e, @$l)) {
4052 if (! scalar grep($_ eq $e, @$l)) {
4053 push (@$l, $e);
4054 }
4055 }
4056 }
4057
4058 =item C<member($item, @list)>
4059
4060 The C<member> function returns true if the first argument
4061 is also inclued in the list of the remaining arguments.
4062
4063 =cut
4064
4065 sub member {
4066 my $what = shift;
4067 return scalar grep($_ eq $what, @_);
4068 }
4069
4070 =item C<merge_into(\%to, \%from)>
4071
4072 Merges the keys of %from into %to.
4073
4074 =cut
4075
4076 sub merge_into {
4077 my ($to, $from) = @_;
4078 foreach my $k (keys %$from) {
4079 if (defined($to->{$k})) {
4080 push @{$to->{$k}}, @{$from->{$k}};
4081 } else {
4082 $to->{$k} = [ @{$from->{$k}} ];
4083 }
4084 }
4085 }
4086
4087 =item C<texdir_check($texdir)>
4088
4089 Test whether installation with TEXDIR set to $texdir should be ok, e.g.,
4090 would be a creatable directory. Return 1 if ok, 0 if not.
4091
4092 Writable or not, we will not allow installation to the root
4093 directory (Unix) or the root of a drive (Windows).
4094
4095 We also do not allow paths containing various special characters, and
4096 print a message about this if second argument WARN is true. (We only
4097 want to do this for the regular text installer, since spewing output in
4098 a GUI program wouldn't be good; the generic message will have to do for
4099 them.)
4100
4101 =cut
4102
4103 sub texdir_check {
4104 my ($orig_texdir,$warn) = @_;
4105 return 0 unless defined $orig_texdir;
4106
4107 # convert to absolute, for safer parsing.
4108 # also replaces backslashes with slashes on w32.
4109 # The return value may still contain symlinks,
4110 # but no unnecessary terminating '/'.
4111 my $texdir = tl_abs_path($orig_texdir);
4112 return 0 unless defined $texdir;
4113
4114 # reject the root of a drive,
4115 # assuming that only the canonical form of the root ends with /
4116 return 0 if $texdir =~ m!/$!;
4117
4118 # Unfortunately we have lots of special characters.
4119 # On Windows, backslashes are normal but will already have been changed
4120 # to slashes by tl_abs_path. And we should only check for : on Unix.
4121 my $colon = wndws() ? "" : ":";
4122 if ($texdir =~ /[,$colon;\\{}\$]/) {
4123 if ($warn) {
4124 print " !! TEXDIR value has problematic characters: $orig_texdir\n";
4125 print " !! (such as comma, colon, semicolon, backslash, braces\n";
4126 print " !! and dollar sign; sorry)\n";
4127 }
4128 # although we could check each character individually and give a
4129 # specific error, it seems plausibly useful to report all the chars
4130 # that cause problems, regardless of which was there. Simpler too.
4131 return 0;
4132 }
4133 # w32: for now, reject the root of a samba share
4134 return 0 if wndws() && $texdir =~ m!^//[^/]+/[^/]+$!;
4135
4136 # if texdir already exists, make sure we can write into it.
4137 return dir_writable($texdir) if (-d $texdir);
4138
4139 # if texdir doesn't exist, make sure we can write the parent.
4140 (my $texdirparent = $texdir) =~ s!/[^/]*$!!;
4141 #print STDERR "Checking $texdirparent".'[/]'."\n";
4142 return dir_creatable($texdirparent) if -d dir_slash($texdirparent);
4143
4144 # ditto for the next level up the tree
4145 (my $texdirpparent = $texdirparent) =~ s!/[^/]*$!!;
4146 #print STDERR "Checking $texdirpparent".'[/]'."\n";
4147 return dir_creatable($texdirpparent) if -d dir_slash($texdirpparent);
4148
4149 # doesn't look plausible.
4150 return 0;
4151 }
4152
4153 =pod
4154
4155 This function takes a single argument I<path> and returns it with
4156 C<"> chars surrounding it on Unix. On Windows, the C<"> chars are only
4157 added if I<path> contains special characters, since unconditional quoting
4158 leads to errors there. In all cases, any C<"> chars in I<path> itself
4159 are (erroneously) eradicated.
4160
4161 =cut
4162
4163 sub quotify_path_with_spaces {
4164 my $p = shift;
4165 my $m = wndws() ? '[+=^&();,!%\s]' : '.';
4166 if ( $p =~ m/$m/ ) {
4167 $p =~ s/"//g; # remove any existing double quotes
4168 $p = "\"$p\"";
4169 }
4170 return($p);
4171 }
4172
4173 =pod
4174
4175 This function returns a "Windows-ized" version of its single argument
4176 I<path>, i.e., replaces all forward slashes with backslashes, and adds
4177 an additional C<"> at the beginning and end if I<path> contains any
4178 spaces. It also makes the path absolute. So if $path does not start
4179 with one (arbitrary) characer followed by C<:>, we add the output of
4180 C<`cd`>.
4181
4182 The result is suitable for running in shell commands, but not file tests
4183 or other manipulations, since in such internal Perl contexts, the quotes
4184 would be considered part of the filename.
4185
4186 =cut
4187
4188 sub conv_to_w32_path {
4189 my $p = shift;
4190 # we need absolute paths, too
4191 my $pabs = tl_abs_path($p);
4192 if (not $pabs) {
4193 $pabs = $p;
4194 tlwarn ("sorry, could not determine absolute path of $p!\n".
4195 "using original path instead");
4196 }
4197 $pabs =~ s!/!\\!g;
4198 $pabs = quotify_path_with_spaces($pabs);
4199 return($pabs);
4200 }
4201
4202 =pod
4203
4204 The next two functions are meant for user input/output in installer menus.
4205 They help making the windows user happy by turning slashes into backslashes
4206 before displaying a path, and our code happy by turning backslashes into forwars
4207 slashes after reading a path. They both are no-ops on Unix.
4208
4209 =cut
4210
4211 sub native_slashify {
4212 my ($r) = @_;
4213 $r =~ s!/!\\!g if wndws();
4214 return $r;
4215 }
4216
4217 sub forward_slashify {
4218 my ($r) = @_;
4219 $r =~ s!\\!/!g if wndws();
4220 return $r;
4221 }
4222
4223 =item C<setup_persistent_downloads()>
4224
4225 Set up to use persistent connections using LWP/TLDownload, that is look
4226 for a download server. Return the TLDownload object if successful, else
4227 false.
4228
4229 =cut
4230
4231 sub setup_persistent_downloads {
4232 if ($TeXLive::TLDownload::net_lib_avail) {
4233 ddebug("setup_persistent_downloads has net_lib_avail set\n");
4234 if ($::tldownload_server) {
4235 if ($::tldownload_server->initcount() > $TeXLive::TLConfig::MaxLWPReinitCount) {
4236 debug("stop retrying to initialize LWP after 10 failures\n");
4237 return 0;
4238 } else {
4239 $::tldownload_server->reinit();
4240 }
4241 } else {
4242 $::tldownload_server = TeXLive::TLDownload->new;
4243 }
4244 if (!defined($::tldownload_server)) {
4245 ddebug("TLUtils:setup_persistent_downloads: failed to get ::tldownload_server\n");
4246 } else {
4247 ddebug("TLUtils:setup_persistent_downloads: got ::tldownload_server\n");
4248 }
4249 return $::tldownload_server;
4250 }
4251 return 0;
4252 }
4253
4254
4255 =item C<query_ctan_mirror()>
4256
4257 Return a particular mirror given by the generic CTAN auto-redirecting
4258 default (specified in L<$TLConfig::TexLiveServerURL>) if we get a
4259 response, else the empty string.
4260
4261 Use C<curl> if it is listed as a C<working_downloader>, else C<wget>,
4262 else give up. We can't support arbitrary downloaders here, as we do for
4263 regular package downloads, since certain options have to be set and the
4264 output has to be parsed.
4265
4266 We try invoking the program three times (hardwired).
4267
4268 =cut
4269
4270 sub query_ctan_mirror {
4271 my @working_downloaders = @{$::progs{'working_downloaders'}};
4272 ddebug("query_ctan_mirror: working_downloaders: @working_downloaders\n");
4273 if (TeXLive::TLUtils::member("curl", @working_downloaders)) {
4274 return query_ctan_mirror_curl();
4275 } elsif (TeXLive::TLUtils::member("wget", @working_downloaders)) {
4276 if ($::progs{'options'}{'wget-ssl'}) {
4277 # we need ssl enabled wget to query ctan
4278 return query_ctan_mirror_wget();
4279 } else {
4280 tlwarn(<<END_NO_SSL);
4281 TLUtils::query_ctan_mirror: neither curl nor an ssl-enabled wget is
4282 available, so no CTAN mirror can be resolved via https://mirror.ctan.org.
4283
4284 Please install curl or ssl-enabled wget; otherwise, please pick an
4285 http (not https) mirror from the list at https://ctan.org/mirrors/mirmon.
4286
4287 To report a bug about this, please rerun your command with -vv and
4288 include the resulting output with the report.
4289 END_NO_SSL
4290 return;
4291 }
4292 } else {
4293 return;
4294 }
4295 }
4296
4297 # curl will follow the redirect chain for us.
4298 #
4299 sub query_ctan_mirror_curl {
4300 my $max_trial = 3;
4301 my $warg = (wndws() ? '-w "%{url_effective}" ' : "-w '%{url_effective}' ");
4302 for (my $i = 1; $i <= $max_trial; $i++) {
4303 # -L -> follow redirects
4304 # -s -> silent
4305 # -w -> what to output after completion
4306 my $cmd = "$::progs{'curl'} -Ls "
4307 . "-o " . nulldev() . " "
4308 . $warg
4309 . "--connect-timeout $NetworkTimeout "
4310 . "--max-time $NetworkTimeout "
4311 . $TeXLiveServerURL;
4312 ddebug("query_ctan_mirror_curl: cmd: $cmd\n");
4313 my $url = `$cmd`;
4314 if (length $url) {
4315 # remove trailing slashes
4316 $url =~ s,/*$,,;
4317 ddebug("query_ctan_mirror_curl: returning url: $url\n");
4318 return $url;
4319 }
4320 sleep(1);
4321 }
4322 return;
4323 }
4324
4325 sub query_ctan_mirror_wget {
4326 my $wget = $::progs{'wget'};
4327 if (!defined ($wget)) {
4328 tlwarn("query_ctan_mirror_wget: Programs not set up, trying wget\n");
4329 $wget = "wget";
4330 }
4331
4332 # we need the verbose output, so no -q.
4333 # do not reduce retries here, but timeout still seems desirable.
4334 my $mirror = $TeXLiveServerURL;
4335 my $cmd = "$wget $mirror --timeout=$NetworkTimeout "
4336 . "-O " . nulldev() . " 2>&1";
4337 ddebug("query_ctan_mirror_wget: cmd is $cmd\n");
4338
4339 # since we are reading the output of wget to find a mirror
4340 # we have to make sure that the locale is unset
4341 my $saved_lcall;
4342 if (defined($ENV{'LC_ALL'})) {
4343 $saved_lcall = $ENV{'LC_ALL'};
4344 }
4345 $ENV{'LC_ALL'} = "C";
4346 # we try 3 times to get a mirror from mirror.ctan.org in case we have
4347 # bad luck with what gets returned.
4348 my $max_trial = 3;
4349 my $mhost;
4350 for (my $i = 1; $i <= $max_trial; $i++) {
4351 my @out = `$cmd`;
4352 # analyze the output for the mirror actually selected.
4353 foreach (@out) {
4354 if (m/^Location: (\S*)\s*.*$/) {
4355 (my $mhost = $1) =~ s,/*$,,; # remove trailing slashes since we add it
4356 ddebug("query_ctan_mirror_wget: returning url: $mhost\n");
4357 return $mhost;
4358 }
4359 }
4360 sleep(1);
4361 }
4362
4363 # reset LC_ALL to undefined or the previous value
4364 if (defined($saved_lcall)) {
4365 $ENV{'LC_ALL'} = $saved_lcall;
4366 } else {
4367 delete($ENV{'LC_ALL'});
4368 }
4369
4370 # we are still here, so three times we didn't get a mirror, give up
4371 # and return undefined
4372 return;
4373 }
4374
4375 =item C<check_on_working_mirror($mirror)>
4376
4377 Check if MIRROR is functional.
4378
4379 =cut
4380
4381 sub check_on_working_mirror {
4382 my $mirror = shift;
4383
4384 my $wget = $::progs{'wget'};
4385 if (!defined ($wget)) {
4386 tlwarn ("check_on_working_mirror: Programs not set up, trying wget\n");
4387 $wget = "wget";
4388 }
4389 $wget = quotify_path_with_spaces($wget);
4390 #
4391 # the test is currently not completely correct, because we do not
4392 # use the LWP if it is set up for it, but I am currently too lazy
4393 # to program it,
4394 # so try wget and only check for the return value
4395 # please KEEP the / after $mirror, some ftp mirrors do give back
4396 # an error if the / is missing after ../CTAN/
4397 my $cmd = "$wget $mirror/ --timeout=$NetworkTimeout -O -"
4398 . " >" . (TeXLive::TLUtils::nulldev())
4399 . " 2>" . (TeXLive::TLUtils::nulldev());
4400 my $ret = system($cmd);
4401 # if return value is not zero it is a failure, so switch the meanings
4402 return ($ret ? 0 : 1);
4403 }
4404
4405 =item C<give_ctan_mirror_base()>
4406
4407 1. get a mirror (retries 3 times to contact mirror.ctan.org)
4408 - if no mirror found, use one of the backbone servers
4409 - if it is an http server return it (no test is done)
4410 - if it is a ftp server, continue
4411 2. if the ftp mirror is good, return it
4412 3. if the ftp mirror is bad, search for http mirror (5 times)
4413 4. if http mirror is found, return it (again, no test,)
4414 5. if no http mirror is found, return one of the backbone servers
4415
4416 =cut
4417
4418 sub give_ctan_mirror_base {
4419 # only one backbone has existed for a while (2018).
4420 my @backbone = qw!https://www.ctan.org/tex-archive!;
4421
4422 # start by selecting a mirror and test its operationality
4423 ddebug("give_ctan_mirror_base: calling query_ctan_mirror\n");
4424 my $mirror = query_ctan_mirror();
4425 if (!defined($mirror)) {
4426 # three times calling mirror.ctan.org did not give anything useful,
4427 # return one of the backbone servers
4428 tlwarn("cannot contact mirror.ctan.org, returning a backbone server!\n");
4429 return $backbone[int(rand($#backbone + 1))];
4430 }
4431
4432 if ($mirror =~ m!^https?://!) { # if http mirror, assume good and return.
4433 return $mirror;
4434 }
4435
4436 # we are still here, so we got a ftp mirror from mirror.ctan.org
4437 if (check_on_working_mirror($mirror)) {
4438 return $mirror; # ftp mirror is working, return.
4439 }
4440
4441 # we are still here, so the ftp mirror failed, retry and hope for http.
4442 # theory is that if one ftp fails, probably all ftp is broken.
4443 my $max_mirror_trial = 5;
4444 for (my $try = 1; $try <= $max_mirror_trial; $try++) {
4445 my $m = query_ctan_mirror();
4446 debug("querying mirror, got " . (defined($m) ? $m : "(nothing)") . "\n");
4447 if (defined($m) && $m =~ m!^https?://!) {
4448 return $m; # got http this time, assume ok.
4449 }
4450 # sleep to make mirror happy, but only if we are not ready to return
4451 sleep(1) if $try < $max_mirror_trial;
4452 }
4453
4454 # 5 times contacting the mirror service did not return a http server,
4455 # use one of the backbone servers.
4456 debug("no mirror found ... randomly selecting backbone\n");
4457 return $backbone[int(rand($#backbone + 1))];
4458 }
4459
4460
4461 sub give_ctan_mirror {
4462 return (give_ctan_mirror_base(@_) . "/$TeXLiveServerPath");
4463 }
4464
4465 =item C<create_mirror_list()>
4466
4467 =item C<extract_mirror_entry($listentry)>
4468
4469 C<create_mirror_list> returns the lists of viable mirrors according to
4470 ctan-mirrors.pl, in a list which also contains continents, and country headers.
4471
4472 C<extract_mirror_entry> extracts the actual repository data from one
4473 of these entries.
4474
4475 # KEEP THESE TWO FUNCTIONS IN SYNC!!!
4476
4477 =cut
4478
4479 sub create_mirror_list {
4480 our $mirrors;
4481 my @ret = ();
4482 require("installer/ctan-mirrors.pl");
4483 my @continents = sort keys %$mirrors;
4484 for my $continent (@continents) {
4485 # first push the name of the continent
4486 push @ret, uc($continent);
4487 my @countries = sort keys %{$mirrors->{$continent}};
4488 for my $country (@countries) {
4489 my @mirrors = sort keys %{$mirrors->{$continent}{$country}};
4490 my $first = 1;
4491 for my $mirror (@mirrors) {
4492 my $mfull = $mirror;
4493 $mfull =~ s!/$!!;
4494 # do not append the server path part here, but add
4495 # it down there in the extract mirror entry
4496 #$mfull .= "/" . $TeXLive::TLConfig::TeXLiveServerPath;
4497 #if ($first) {
4498 my $country_str = sprintf "%-12s", $country;
4499 push @ret, " $country_str $mfull";
4500 # $first = 0;
4501 #} else {
4502 # push @ret, " $mfull";
4503 #}
4504 }
4505 }
4506 }
4507 return @ret;
4508 }
4509
4510 # extract_mirror_entry is not very intelligent, it assumes that
4511 # the last "word" is the URL
4512 sub extract_mirror_entry {
4513 my $ent = shift;
4514 my @foo = split ' ', $ent;
4515 return $foo[$#foo] . "/" . $TeXLive::TLConfig::TeXLiveServerPath;
4516 }
4517
4518 =pod
4519
4520 =item C<< slurp_file($file) >>
4521
4522 Reads the whole file and returns the content in a scalar.
4523
4524 =cut
4525
4526 sub slurp_file {
4527 my $file = shift;
4528 my $file_data = do {
4529 local $/ = undef;
4530 open my $fh, "<", $file || die "open($file) failed: $!";
4531 <$fh>;
4532 };
4533 return($file_data);
4534 }
4535
4536 =pod
4537
4538 =item C<< download_to_temp_or_file($url) >>
4539
4540 If C<$url> is a url, tries to download the file into a temporary file.
4541 Otherwise assume that C<$url> is a local file.
4542 In both cases returns the local file.
4543
4544 Returns the local file name if succeeded, otherwise undef.
4545
4546 =cut
4547
4548 sub download_to_temp_or_file {
4549 my $url = shift;
4550 my $ret;
4551 my ($url_fh, $url_file);
4552 if ($url =~ m,^(https?|ftp|file)://, || $url =~ m!$SshURIRegex!) {
4553 ($url_fh, $url_file) = tl_tmpfile();
4554 # now $url_fh filehandle is open, the file created
4555 # TLUtils::download_file will just overwrite what is there
4556 # on windows that doesn't work, so we close the fh immediately
4557 # this creates a short loophole, but much better than before anyway
4558 close($url_fh);
4559 $ret = download_file($url, $url_file);
4560 } else {
4561 $url_file = $url;
4562 $ret = 1;
4563 }
4564 if ($ret && (-r "$url_file")) {
4565 return $url_file;
4566 }
4567 return;
4568 }
4569
4570
4571 =item C<< compare_tlpobjs($tlpA, $tlpB) >>
4572
4573 Compare the two passed L<TLPOBJ> objects. Returns a hash:
4574
4575 $ret{'revision'} = "revA:revB" # if revisions differ
4576 $ret{'removed'} = \[ list of files removed from A to B ]
4577 $ret{'added'} = \[ list of files added from A to B ]
4578 $ret{'fmttriggers'} = 1 if the fmttriggers have changed
4579
4580 =cut
4581
4582 sub compare_tlpobjs {
4583 my ($tlpA, $tlpB) = @_;
4584 my %ret;
4585
4586 my $rA = $tlpA->revision;
4587 my $rB = $tlpB->revision;
4588 if ($rA != $rB) {
4589 $ret{'revision'} = "$rA:$rB";
4590 }
4591 if ($tlpA->relocated) {
4592 $tlpA->replace_reloc_prefix;
4593 }
4594 if ($tlpB->relocated) {
4595 $tlpB->replace_reloc_prefix;
4596 }
4597 my @fA = $tlpA->all_files;
4598 my @fB = $tlpB->all_files;
4599 my %removed;
4600 my %added;
4601 for my $f (@fA) { $removed{$f} = 1; }
4602 for my $f (@fB) { delete($removed{$f}); $added{$f} = 1; }
4603 for my $f (@fA) { delete($added{$f}); }
4604 my @rem = sort keys %removed;
4605 my @add = sort keys %added;
4606 $ret{'removed'} = \@rem if @rem;
4607 $ret{'added'} = \@add if @add;
4608
4609 # changed dependencies should not trigger a change without a
4610 # change in revision, so for now (until we find a reason why
4611 # we need to) we don't check.
4612 # OTOH, execute statements like
4613 # execute AddFormat name=aleph engine=aleph options=*aleph.ini fmttriggers=cm,hyphen-base,knuth-lib,plain
4614 # might change due to changes in the fmttriggers variables.
4615 # Again, name/engine/options are only defined in the package's
4616 # tlpsrc file, so changes here will trigger revision changes,
4617 # but fmttriggers are defined outside the tlpsrc and thus do
4618 # not trigger an automatic revision change. Check for that!
4619 # No need to record actual changes, just record that it has changed.
4620 my %triggersA;
4621 my %triggersB;
4622 # we sort executes after format/engine like fmtutil does, since this
4623 # should be unique
4624 for my $e ($tlpA->executes) {
4625 if ($e =~ m/AddFormat\s+(.*)\s*/) {
4626 my %r = parse_AddFormat_line("$1");
4627 if (defined($r{"error"})) {
4628 die "$r{'error'} when comparing packages $tlpA->name execute $e";
4629 }
4630 for my $t (@{$r{'fmttriggers'}}) {
4631 $triggersA{"$r{'name'}:$r{'engine'}:$t"} = 1;
4632 }
4633 }
4634 }
4635 for my $e ($tlpB->executes) {
4636 if ($e =~ m/AddFormat\s+(.*)\s*/) {
4637 my %r = parse_AddFormat_line("$1");
4638 if (defined($r{"error"})) {
4639 die "$r{'error'} when comparing packages $tlpB->name execute $e";
4640 }
4641 for my $t (@{$r{'fmttriggers'}}) {
4642 $triggersB{"$r{'name'}:$r{'engine'}:$t"} = 1;
4643 }
4644 }
4645 }
4646 for my $t (keys %triggersA) {
4647 delete($triggersA{$t});
4648 delete($triggersB{$t});
4649 }
4650 if (keys(%triggersA) || keys(%triggersB)) {
4651 $ret{'fmttrigger'} = 1;
4652 }
4653
4654 return %ret;
4655 }
4656
4657
4658 =item C<< compare_tlpdbs($tlpdbA, $tlpdbB, @more_ignored_pkgs) >>
4659
4660 Compare the two passed L<TLPDB> objects, ignoring the packages
4661 C<00texlive.installer>, C<00texlive.image>, and any passed
4662 C<@more_ignore_pkgs>. Returns a hash:
4663
4664 $ret{'removed_packages'} = \[ list of removed packages from A to B ]
4665 $ret{'added_packages'} = \[ list of added packages from A to B ]
4666 $ret{'different_packages'}->{$package} = output of compare_tlpobjs
4667
4668 =cut
4669
4670 sub compare_tlpdbs {
4671 my ($tlpdbA, $tlpdbB, @add_ignored_packs) = @_;
4672 my @ignored_packs = qw/00texlive.installer 00texlive.image/;
4673 push @ignored_packs, @add_ignored_packs;
4674
4675 my @inAnotinB;
4676 my @inBnotinA;
4677 my %diffpacks;
4678 my %do_compare;
4679 my %ret;
4680
4681 for my $p ($tlpdbA->list_packages()) {
4682 my $is_ignored = 0;
4683 for my $ign (@ignored_packs) {
4684 if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) {
4685 $is_ignored = 1;
4686 last;
4687 }
4688 }
4689 next if $is_ignored;
4690 my $tlpB = $tlpdbB->get_package($p);
4691 if (!defined($tlpB)) {
4692 push @inAnotinB, $p;
4693 } else {
4694 $do_compare{$p} = 1;
4695 }
4696 }
4697 $ret{'removed_packages'} = \@inAnotinB if @inAnotinB;
4698
4699 for my $p ($tlpdbB->list_packages()) {
4700 my $is_ignored = 0;
4701 for my $ign (@ignored_packs) {
4702 if (($p =~ m/^$ign$/) || ($p =~ m/^$ign\./)) {
4703 $is_ignored = 1;
4704 last;
4705 }
4706 }
4707 next if $is_ignored;
4708 my $tlpA = $tlpdbA->get_package($p);
4709 if (!defined($tlpA)) {
4710 push @inBnotinA, $p;
4711 } else {
4712 $do_compare{$p} = 1;
4713 }
4714 }
4715 $ret{'added_packages'} = \@inBnotinA if @inBnotinA;
4716
4717 for my $p (sort keys %do_compare) {
4718 my $tlpA = $tlpdbA->get_package($p);
4719 my $tlpB = $tlpdbB->get_package($p);
4720 my %foo = compare_tlpobjs($tlpA, $tlpB);
4721 if (keys %foo) {
4722 # some diffs were found
4723 $diffpacks{$p} = \%foo;
4724 }
4725 }
4726 $ret{'different_packages'} = \%diffpacks if (keys %diffpacks);
4727
4728 return %ret;
4729 }
4730
4731 sub tlnet_disabled_packages {
4732 my ($root) = @_;
4733 my $disabled_pkgs = "$root/tlpkg/dev/tlnet-disabled-packages.txt";
4734 my @ret;
4735 if (-r $disabled_pkgs) {
4736 open (DISABLED, "<$disabled_pkgs") || die "Huu, -r but cannot open: $?";
4737 while (<DISABLED>) {
4738 chomp;
4739 next if /^\s*#/;
4740 next if /^\s*$/;
4741 $_ =~ s/^\s*//;
4742 $_ =~ s/\s*$//;
4743 push @ret, $_;
4744 }
4745 close(DISABLED) || warn ("Cannot close tlnet-disabled-packages.txt: $?");
4746 }
4747 return @ret;
4748 }
4749
4750 sub report_tlpdb_differences {
4751 my $rret = shift;
4752 my %ret = %$rret;
4753
4754 if (defined($ret{'removed_packages'})) {
4755 info ("removed packages from A to B:\n");
4756 for my $f (@{$ret{'removed_packages'}}) {
4757 info (" $f\n");
4758 }
4759 }
4760 if (defined($ret{'added_packages'})) {
4761 info ("added packages from A to B:\n");
4762 for my $f (@{$ret{'added_packages'}}) {
4763 info (" $f\n");
4764 }
4765 }
4766 if (defined($ret{'different_packages'})) {
4767 info ("different packages from A to B:\n");
4768 for my $p (keys %{$ret{'different_packages'}}) {
4769 info (" $p\n");
4770 for my $k (keys %{$ret{'different_packages'}->{$p}}) {
4771 if ($k eq "revision") {
4772 info(" revision differ: $ret{'different_packages'}->{$p}->{$k}\n");
4773 } elsif ($k eq "removed" || $k eq "added") {
4774 info(" $k files:\n");
4775 for my $f (@{$ret{'different_packages'}->{$p}->{$k}}) {
4776 info(" $f\n");
4777 }
4778 } else {
4779 info(" unknown differ $k\n");
4780 }
4781 }
4782 }
4783 }
4784 }
4785
4786 sub sort_archs ($$) {
4787 my $aa = $_[0];
4788 my $bb = $_[1];
4789 $aa =~ s/^(.*)-(.*)$/$2-$1/;
4790 $bb =~ s/^(.*)-(.*)$/$2-$1/;
4791 $aa cmp $bb ;
4792 }
4793
4794 # Taken from Text::ParseWords
4795 #
4796 sub quotewords {
4797 my($delim, $keep, @lines) = @_;
4798 my($line, @words, @allwords);
4799
4800 foreach $line (@lines) {
4801 @words = parse_line($delim, $keep, $line);
4802 return() unless (@words || !length($line));
4803 push(@allwords, @words);
4804 }
4805 return(@allwords);
4806 }
4807
4808 sub parse_line {
4809 my($delimiter, $keep, $line) = @_;
4810 my($word, @pieces);
4811
4812 no warnings 'uninitialized'; # we will be testing undef strings
4813
4814 $line =~ s/\s+$//; # kill trailing whitespace
4815 while (length($line)) {
4816 $line =~ s/^(["']) # a $quote
4817 ((?:\\.|(?!\1)[^\\])*) # and $quoted text
4818 \1 # followed by the same quote
4819 | # --OR--
4820 ^((?:\\.|[^\\"'])*?) # an $unquoted text
4821 (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["']))
4822 # plus EOL, delimiter, or quote
4823 //xs or return; # extended layout
4824 my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4);
4825 return() unless( defined($quote) || length($unquoted) || length($delim));
4826
4827 if ($keep) {
4828 $quoted = "$quote$quoted$quote";
4829 } else {
4830 $unquoted =~ s/\\(.)/$1/sg;
4831 if (defined $quote) {
4832 $quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
4833 $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
4834 }
4835 }
4836 $word .= substr($line, 0, 0); # leave results tainted
4837 $word .= defined $quote ? $quoted : $unquoted;
4838
4839 if (length($delim)) {
4840 push(@pieces, $word);
4841 push(@pieces, $delim) if ($keep eq 'delimiters');
4842 undef $word;
4843 }
4844 if (!length($line)) {
4845 push(@pieces, $word);
4846 }
4847 }
4848 return(@pieces);
4849 }
4850
4851
4852 =item C<mktexupd ()>
4853
4854 Append entries to C<ls-R> files. Usage example:
4855
4856 my $updLSR=&mktexupd();
4857 $updLSR->{mustexist}(1);
4858 $updLSR->{add}(file1);
4859 $updLSR->{add}(file2);
4860 $updLSR->{add}(file3);
4861 $updLSR->{exec}();
4862
4863 The first line creates a new object. Only one such object should be
4864 created in a program in order to avoid duplicate entries in C<ls-R> files.
4865
4866 C<add> pushes a filename or a list of filenames to a hash encapsulated
4867 in a closure. Filenames must be specified with the full (absolute) path.
4868 Duplicate entries are ignored.
4869
4870 C<exec> checks for each component of C<$TEXMFDBS> whether there are files
4871 in the hash which have to be appended to the corresponding C<ls-R> files
4872 and eventually updates the corresponding C<ls-R> files. Files which are
4873 in directories not stated in C<$TEXMFDBS> are silently ignored.
4874
4875 If the flag C<mustexist> is set, C<exec> aborts with an error message
4876 if a file supposed to be appended to an C<ls-R> file doesn't exist physically
4877 on the file system. This option was added for compatibility with the
4878 C<mktexupd> shell script. This option shouldn't be enabled in scripts,
4879 except for testing, because it degrades performance on non-cached file
4880 systems.
4881
4882 =cut
4883
4884 sub mktexupd {
4885 my %files;
4886 my $mustexist=0;
4887
4888 my $hash={
4889 "add" => sub {
4890 foreach my $file (@_) {
4891 $file =~ s|\\|/|g;
4892 $files{$file}=1;
4893 }
4894 },
4895 "reset" => sub {
4896 %files=();
4897 },
4898 "mustexist" => sub {
4899 $mustexist=shift;
4900 },
4901 "exec" => sub {
4902 # check whether files exist
4903 if ($mustexist) {
4904 foreach my $file (keys %files) {
4905 die "mktexupd: exec file does not exist: $file" if (! -f $file);
4906 }
4907 }
4908 my $delim= (&wndws)? ';' : ':';
4909 my $TEXMFDBS;
4910 chomp($TEXMFDBS=`kpsewhich --show-path="ls-R"`);
4911
4912 my @texmfdbs=split ($delim, "$TEXMFDBS");
4913 my %dbs;
4914
4915 foreach my $path (keys %files) {
4916 foreach my $db (@texmfdbs) {
4917 $db=substr($db, -1) if ($db=~m|/$|); # strip leading /
4918 $db = lc($db) if wndws();
4919 my $up = (wndws() ? lc($path) : $path);
4920 if (substr($up, 0, length("$db/")) eq "$db/") {
4921 # we appended a / because otherwise "texmf" is recognized as a
4922 # substring of "texmf-dist".
4923 my $np = './' . substr($up, length("$db/"));
4924 my ($dir, $file);
4925 $_=$np;
4926 ($dir, $file) = m|(.*)/(.*)|;
4927 $dbs{$db}{$dir}{$file}=1;
4928 }
4929 }
4930 }
4931 foreach my $db (keys %dbs) {
4932 if (! -f "$db" || ! -w "$db/ls-R") {
4933 &mkdirhier ($db);
4934 }
4935 open LSR, ">>$db/ls-R";
4936 foreach my $dir (keys %{$dbs{$db}}) {
4937 print LSR "\n$dir:\n";
4938 foreach my $file (keys %{$dbs{$db}{$dir}}) {
4939 print LSR "$file\n";
4940 }
4941 }
4942 close LSR;
4943 }
4944 }
4945 };
4946 return $hash;
4947 }
4948
4949
4950 =item C<setup_sys_user_mode($prg, $optsref, $tmfc, $tmfsc, $tmfv, $tmfsv)>
4951
4952 Return two-element list C<($texmfconfig,$texmfvar)> specifying which
4953 directories to use, either user or sys. If C<$optsref->{'sys'}> is
4954 true, we are in sys mode; else if C<$optsref->{'user'}> is set, we are
4955 in user mode; else a fatal error.
4956
4957 If C<$prg> eq C<"mktexfmt">, and C<$TEXMFSYSVAR/web2c> is writable, use
4958 it instead of C<$TEXMFVAR>, even if we are in user mode. C<$TEXMFCONFIG>
4959 is not switched, however.
4960
4961 =cut
4962
4963 sub setup_sys_user_mode {
4964 my ($prg, $optsref, $TEXMFCONFIG, $TEXMFSYSCONFIG,
4965 $TEXMFVAR, $TEXMFSYSVAR) = @_;
4966
4967 if ($optsref->{'user'} && $optsref->{'sys'}) {
4968 print STDERR "$prg [ERROR]: only one of -sys or -user can be used.\n";
4969 exit(1);
4970 }
4971
4972 # check if we are in *hidden* sys mode, in which case we switch
4973 # to sys mode
4974 # Nowdays we use -sys switch instead of simply overriding TEXMFVAR
4975 # and TEXMFCONFIG
4976 # This is used to warn users when they run updmap in usermode the first time.
4977 # But it might happen that this script is called via another wrapper that
4978 # sets TEXMFCONFIG and TEXMFVAR, and does not pass on the -sys option.
4979 # for this case we check whether the SYS and non-SYS variants agree,
4980 # and if, then switch to sys mode (with a warning)
4981 if (($TEXMFSYSCONFIG eq $TEXMFCONFIG) && ($TEXMFSYSVAR eq $TEXMFVAR)) {
4982 if ($optsref->{'user'}) {
4983 print STDERR "$prg [ERROR]: -user mode but path setup is -sys type, bailing out.\n";
4984 exit(1);
4985 }
4986 if (!$optsref->{'sys'}) {
4987 print STDERR "$prg [WARNING]: hidden sys mode found, switching to sys mode.\n"
4988 if (!$optsref->{'quiet'});
4989 $optsref->{'sys'} = 1;
4990 }
4991 }
4992
4993 my ($texmfconfig, $texmfvar);
4994 if ($optsref->{'sys'}) {
4995 # we are running as updmap-sys, make sure that the right tree is used
4996 $texmfconfig = $TEXMFSYSCONFIG;
4997 $texmfvar = $TEXMFSYSVAR;
<