diff options
Diffstat (limited to 'Master/tlpkg/TeXLive/TLUtils.pm')
| -rw-r--r-- | Master/tlpkg/TeXLive/TLUtils.pm | 399 |
1 files changed, 347 insertions, 52 deletions
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm index 4b7dafbc3f3..cd5fc335235 100644 --- a/Master/tlpkg/TeXLive/TLUtils.pm +++ b/Master/tlpkg/TeXLive/TLUtils.pm @@ -32,6 +32,7 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure TeXLive::TLUtils::tl_tmpdir(); TeXLive::TLUtils::xchdir($dir); TeXLive::TLUtils::xsystem(@args); + TeXLive::TLUtils::run_cmd($cmd); =head2 File Utilities @@ -56,6 +57,7 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure TeXLive::TLUtils::create_language_def($tlpdb,$dest,$localconf); TeXLive::TLUtils::install_packages($from_tlpdb,$media,$to_tlpdb,$what,$opt_src, $opt_doc)>); TeXLive::TLUtils::install_package($what, $filelistref, $target, $platform); + TeXLive::TLUtils::do_postaction($how, $tlpobj); =head2 Miscellaneous @@ -113,10 +115,11 @@ BEGIN { &give_ctan_mirror &tlmd5 &xsystem + &run_cmd ); @EXPORT = qw(setup_programs download_file process_logging_options tlwarn info log debug ddebug dddebug debug_hash - win32 xchdir xsystem); + win32 xchdir xsystem run_cmd); } use Cwd; @@ -398,6 +401,25 @@ sub xsystem } } +=item C<run_cmd($cmd)> + +runs a command and captures its output. Then returns a list with the +output as first element and the return value (exit code) as second. + +=cut + +sub run_cmd { + my $cmd = shift; + my $output = `$cmd`; + $retval = $? + if ($retval != 0) { + $retval /= 256 if $retval > 0; + } + return ($output, $retval); +} + + + =back @@ -949,6 +971,7 @@ sub install_packages { my $starttime = time(); foreach my $package (@packs) { my $tlpobj = $tlpobjs{$package}; + my $reloc = $tlpobj->relocated; $n++; my $remtime = "??:??"; my $tottime = "??:??"; @@ -1006,16 +1029,16 @@ sub install_packages { } elsif ($media eq 'CD') { if (-r "$root/$Archive/$package.zip") { $container = "$root/$Archive/$package.zip"; - } elsif (-r "$root/$Archive/$package.tar.lzma") { - $container = "$root/$Archive/$package.tar.lzma"; + } elsif (-r "$root/$Archive/$package.tar.xz") { + $container = "$root/$Archive/$package.tar.xz"; } else { - tlwarn("No package $package (.zip or .lzma) in $root/$Archive\n"); + tlwarn("No package $package (.zip or .xz) in $root/$Archive\n"); next; } } elsif ($media eq 'NET') { $container = "$root/$Archive/$package.$DefaultContainerExtension"; } - if (!install_package($container, $tlpobj->containersize, + if (!install_package($container, $reloc, $tlpobj->containersize, $tlpobj->containermd5, \@installfiles, $totlpdb->root, $vars{'this_platform'})) { # we already warn in install_package that something bad happened, @@ -1036,8 +1059,8 @@ sub install_packages { # - there are actually src/doc files present if ($container_src_split && $opt_src && $tlpobj->srcfiles) { my $srccontainer = $container; - $srccontainer =~ s/(\.tar\.lzma|\.zip)$/.source$1/; - if (!install_package($srccontainer, $tlpobj->srccontainersize, + $srccontainer =~ s/(\.tar\.xz|\.zip)$/.source$1/; + if (!install_package($srccontainer, $reloc, $tlpobj->srccontainersize, $tlpobj->srccontainermd5, \@installfiles, $totlpdb->root, $vars{'this_platform'})) { return 0; @@ -1045,8 +1068,8 @@ sub install_packages { } if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) { my $doccontainer = $container; - $doccontainer =~ s/(\.tar\.lzma|\.zip)$/.doc$1/; - if (!install_package($doccontainer, + $doccontainer =~ s/(\.tar\.xz|\.zip)$/.doc$1/; + if (!install_package($doccontainer, $reloc, $tlpobj->doccontainersize, $tlpobj->doccontainermd5, \@installfiles, $totlpdb->root, $vars{'this_platform'})) { @@ -1064,7 +1087,7 @@ sub install_packages { } $totlpdb->add_tlpobj($tlpobj); # we have to write out the tlpobj file since it is contained in the - # archives (.tar.lzma) but at DVD install time we don't have them + # archives (.tar.xz) but at DVD install time we don't have them my $tlpod = $totlpdb->root . "/tlpkg/tlpobj"; mkdirhier( $tlpod ); open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") || @@ -1083,7 +1106,7 @@ sub install_packages { } -=item C<install_package($what, $size, $md5, $filelistref, $target, $platform)> +=item C<install_package($what, $reloc, $size, $md5, $filelistref, $target, $platform)> This function installs the files given in @$filelistref from C<$what> into C<$target>. @@ -1097,29 +1120,34 @@ the way. In this case the list C<@$filelistref> is not taken into account. If C<$what> starts with C<http://> or C<ftp://> then C<$what> is -downloaded from the net and piped through C<lzmadec> and C<tar>. +downloaded from the net and piped through C<xzdec> and C<tar>. -If $what ends with C<.tar.lzma> (but does not start with C<http://> or +If $what ends with C<.tar.xz> (but does not start with C<http://> or C<ftp://>, but possibly with C<file:/>) it is assumed to be a readable -file on the system and is likewise piped through C<lzmadec> and C<tar>. +file on the system and is likewise piped through C<xzdec> and C<tar>. In both of these cases currently the list C<$@filelistref> currently is not taken into account (should be fixed!). +if C<$reloc> is true the container (NET or CD mode) is packaged in a way +that the initial texmf-dist is missing. + Returns 1 on success and 0 on error. =cut sub install_package { - my ($what, $whatsize, $whatmd5, $filelistref, $target, $platform) = @_; + my ($what, $reloc, $whatsize, $whatmd5, $filelistref, $target, $platform) = @_; my @filelist = @$filelistref; + my $tempdir = "$target/temp"; + # we assume that $::progs has been set up! my $wget = $::progs{'wget'}; - my $lzmadec = $::progs{'lzmadec'}; - if (!defined($wget) || !defined($lzmadec)) { - tlwarn("install_package: wget/lzmadec programs not set up properly.\n"); + my $xzdec = $::progs{'xzdec'}; + if (!defined($wget) || !defined($xzdec)) { + tlwarn("install_package: wget/xzdec programs not set up properly.\n"); return 0; } if (ref $what) { @@ -1132,35 +1160,43 @@ sub install_package { mkdirhier("$target/$dn"); copy "$root/$file", "$target/$dn"; } - } elsif ($what =~ m,\.tar.lzma$,) { + } elsif ($what =~ m,\.tar.xz$,) { # this is the case when we install from CD or the NET # - # in all other cases we create temp files .tar.lzma (or use the present - # one), lzmadec them, and then call tar + # in all other cases we create temp files .tar.xz (or use the present + # one), xzdec them, and then call tar + + # if we are unpacking a relocated container we adjust the target + if ($reloc) { + $target .= "/$TeXLive::TLConfig::RelocTree" if $reloc; + mkdir($target) if (! -d $target); + } my $fn = basename($what); - mkdirhier("$target/temp"); - my $lzmafile = "$target/temp/$fn"; - my $tarfile = "$target/temp/$fn"; $tarfile =~ s/\.lzma$//; - my $lzmafile_quote = $lzmafile; + my $pkg = $fn; + $pkg =~ s/\.tar\.xz$//; + mkdirhier("$tempdir"); + my $xzfile = "$tempdir/$fn"; + my $tarfile = "$tempdir/$fn"; $tarfile =~ s/\.xz$//; + my $xzfile_quote = $xzfile; my $tarfile_quote = $tarfile; if (win32()) { - $lzmafile =~ s!/!\\!g; + $xzfile =~ s!/!\\!g; $tarfile =~ s!/!\\!g; $target =~ s!/!\\!g; } - $lzmafile_quote = "\"$lzmafile\""; + $xzfile_quote = "\"$xzfile\""; $tarfile_quote = "\"$tarfile\""; my $gotfiledone = 0; - if (-r $lzmafile) { + if (-r $xzfile) { # check that the downloaded file is not partial if ($whatsize >= 0) { # we have the size given, so check that first - my $size = (stat $lzmafile)[7]; + my $size = (stat $xzfile)[7]; if ($size == $whatsize) { # we want to check also the md5sum if we have it present if ($whatmd5) { - if (tlmd5($lzmafile) eq $whatmd5) { + if (tlmd5($xzfile) eq $whatmd5) { $gotfiledone = 1; } else { tlwarn("Downloaded $what, size equal, but md5sum differs;\n", @@ -1174,12 +1210,12 @@ sub install_package { } } else { tlwarn("Partial download of $what found, removing it.\n"); - unlink($tarfile, $lzmafile); + unlink($tarfile, $xzfile); } } else { # ok no size information, hopefully we have md5 sums if ($whatmd5) { - if (tlmd5($lzmafile) eq $whatmd5) { + if (tlmd5($xzfile) eq $whatmd5) { $gotfiledone = 1; } else { tlwarn("Downloaded file, but md5sum differs, removing it.\n"); @@ -1190,39 +1226,44 @@ sub install_package { $gotfiledone = 1; } } - debug("Reusing already downloaded container $lzmafile\n") + debug("Reusing already downloaded container $xzfile\n") if ($gotfiledone); } if (!$gotfiledone) { if ($what =~ m,http://|ftp://,) { # we are installing from the NET # download the file and put it into temp - if (!download_file($what, $lzmafile) || (! -r $lzmafile)) { + if (!download_file($what, $xzfile) || (! -r $xzfile)) { tlwarn("Downloading $what did not succeed.\n"); return 0; } } else { # we are installing from CD # copy it to temp - copy($what, "$target/temp"); + copy($what, $tempdir); } } - debug("un-lzmaing $lzmafile to $tarfile\n"); - system("$lzmadec < $lzmafile_quote > $tarfile_quote"); + debug("un-xzing $xzfile to $tarfile\n"); + system("$xzdec < $xzfile_quote > $tarfile_quote"); if (! -f $tarfile) { - tlwarn("Unpacking $lzmafile did not succeed.\n"); + tlwarn("Unpacking $xzfile did not succeed.\n"); return 0; } if (!TeXLive::TLUtils::untar($tarfile, $target, 1)) { tlwarn("Un-tarring $tarfile did not succeed.\n"); return 0; } + # we remove the created .tlpobj it is recreated anyway in + # install_packages above in the right place. This way we also + # get rid of the $pkg.source.tlpobj which are useless + unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj") + if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj"); if ($what =~ m,http://|ftp://,) { # we downloaded the original .tar.lzma from the net, so we keep it } else { - # we are downloading it from CD, so we can unlink it to save + # we are downloading it from CD, so we can unlink it to save # disk space - unlink($lzmafile); + unlink($xzfile); } } else { tlwarn("Sorry, no idea how to install $what\n"); @@ -1231,6 +1272,261 @@ sub install_package { return 1; } +=item C<do_postaction($how, $tlpobj, $do_fileassocs, $do_shortcuts, $do_script)> + +Evaluates the C<postaction> fields in the C<$tlpobj>. The first parameter +can be either C<install> or C<remove>. The second gives the TLPOBJ whos +postactions should be evaluated, and the last three arguments specify +what type of postactions should (or shouldn't) be evaluated. + +Returns 1 on success, and 0 on failure. + +=cut + +sub do_postaction { + my ($how, $tlpobj, $do_fileassocs, $do_shortcuts, $do_script) = @_; + my $ret = 1; + if (!defined($tlpobj)) { + tlwarn("do_postaction: didn't get a tlpobj\n"); + return 0; + } + debug("running postaction=$how for " . $tlpobj->name . "\n") + if $tlpobj->postactions; + for my $pa ($tlpobj->postactions) { + if ($pa =~ m/^\s*shortcut\s+(.*)\s*$/) { + next unless $do_shortcuts; + $ret &&= _do_postaction_shortcut($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*filetype\s+(.*)\s*$/) { + next unless $do_fileassocs; + $ret &&= _do_postaction_filetype($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*fileassoc\s+(.*)\s*$/) { + next unless $do_fileassocs; + $ret &&= _do_postaction_fileassoc($how, $tlpobj, $1); + } elsif ($pa =~ m/\s*script\s+(.*)\s*$/) { + next unless $do_script; + $ret &&= _do_postaction_script($how, $tlpobj, $1); + } else { + tlwarn("do_postaction: don't know how to do $pa\n"); + $ret = 0; + } + } + # nothing to do + return $ret; +} + +sub _do_postaction_fileassoc { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/extension filetype/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'extension'})) { + tlwarn("extension of fileassoc postaction not given\n"); + return 0; + } + my $extension = $keyval{'extension'}; + + # cmd can be an arbitrary string + if (!defined($keyval{'filetype'})) { + tlwarn("filetype of fileassoc postaction not given\n"); + return 0; + } + my $filetype = $keyval{'filetype'}; + + if ($how eq "install") { + TeXLive::TLWinGoo::register_extension($extension, $filetype); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::unregister_extension($extension); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} +sub _do_postaction_filetype { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/name cmd/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'name'})) { + tlwarn("name of filetype postaction not given\n"); + return 0; + } + my $name = $keyval{'name'}; + + # cmd can be an arbitrary string + if (!defined($keyval{'cmd'})) { + tlwarn("cmd of filetype postaction not given\n"); + return 0; + } + my $cmd = $keyval{'cmd'}; + + if ($how eq "install") { + TeXLive::TLWinGoo::register_file_type($name, $cmd); + } elsif ($how eq "remove") { + TeXLive::TLWinGoo::unregister_file_type($name); + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub _do_postaction_script { + my ($how, $tlpobj, $pa) = @_; + my ($errors, %keyval) = + parse_into_keywords($pa, qw/file filew32/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # file can be an arbitrary string + if (!defined($keyval{'file'})) { + tlwarn("filename of script not given\n"); + return 0; + } + my $file = $keyval{'file'}; + if (win32() && defined($keyval{'filew32'})) { + $file = $keyval{'filew32'}; + } + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my @syscmd; + if ($file =~ m/\.pl$/i) { + # we got a perl script, call it via perl + push @syscmd, "perl", "$texdir/$file"; + } elsif ($file =~ m/\.texlua$/i) { + # we got a texlua script, call it via texlua + push @syscmd, "texlua", "$texdir/$file"; + } else { + # we got anything else, call it directly and hope it is excutable + push @syscmd, "$texdir/$file"; + } + push @syscmd, $how, $texdir; + my $ret = system (@syscmd); + if ($ret != 0) { + $ret /= 256 if $ret > 0; + my $pwd = cwd (); + warn "$0: calling post action script $file did not succeed in $pwd, status $ret"; + return 0; + } + return 1; +} + +sub _do_postaction_shortcut { + my ($how, $tlpobj, $pa) = @_; + return 1 unless win32(); + my ($errors, %keyval) = + parse_into_keywords($pa, qw/type name icon cmd args hide/); + + if ($errors) { + tlwarn("parsing the postaction line >>$pa<< did not succeed!\n"); + return 0; + } + + # type can be either menu or desktop + if (!defined($keyval{'type'})) { + tlwarn("type of shortcut postaction not given\n"); + return 0; + } + my $type = $keyval{'type'}; + if (($type ne "menu") && ($type ne "desktop")) { + tlwarn("type of shortcut postaction $type is unknown (menu, desktop)\n"); + return 0; + } + + # name can be an arbitrary string + if (!defined($keyval{'name'})) { + tlwarn("name of shortcut postaction not given\n"); + return 0; + } + my $name = $keyval{'name'}; + + # icon, cmd, args is optional + my $icon = (defined($keyval{'icon'}) ? $keyval{'icon'} : ''); + my $cmd = (defined($keyval{'cmd'}) ? $keyval{'cmd'} : ''); + my $args = (defined($keyval{'args'}) ? $keyval{'args'} : ''); + + # hide can be only 0 or 1, and defaults to 0 + my $hide = (defined($keyval{'hide'}) ? $keyval{'hide'} : 0); + if (($hide ne "0") && ($hide ne "1")) { + tlwarn("hide of shortcut postaction $hide is unknown (0, 1)\n"); + return 0; + } + + if ($how eq "install") { + my $texdir = `kpsewhich -var-value=SELFAUTOPARENT`; + chomp($texdir); + my $texdir_bsl = conv_to_w32_path($texdir); + $icon =~ s!^TEXDIR/!$texdir/!; + $args =~ s!^TEXDIR/!$texdir/!; + $args = conv_to_w32_path($args); + if ($type eq "menu") { + TeXLive::TLWinGoo::add_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, + $name, $icon, $cmd, $args, $hide); + } elsif ($type eq "desktop") { + TeXLive::TLWinGoo::add_desktop_shortcut( + $name, $icon, $cmd, $args, $hide); + } else { + tlwarn("Unknown type of shortcut: $type\n"); + return 0; + } + } elsif ($how eq "remove") { + if ($type eq "menu") { + TeXLive::TLWinGoo::remove_menu_shortcut( + $TeXLive::TLConfig::WindowsMainMenuName, $name); + } elsif ($type eq "desktop") { + TeXLive::TLWinGoo::remove_desktop_shortcut($name); + } else { + tlwarn("Unknown type of shortcut: $type\n"); + return 0; + } + } else { + tlwarn("Unknown mode $how\n"); + return 0; + } + return 1; +} + +sub parse_into_keywords { + my ($str, @keys) = @_; + my @words = quotewords('\s+', 0, $str); + my %ret; + my $error = 0; + while (@words) { + $_ = shift @words; + if (/^([^=]+)=(.*)$/) { + $ret{$1} = $2; + } else { + tlwarn("parser found a invalid word in parsing keys: $_\n"); + $error++; + $ret{$_} = ""; + } + } + for my $k (keys %ret) { + if (!member($k, @keys)) { + $error++; + tlwarn("parser found invalid keyword: $k\n"); + } + } + return($error, %ret); +} =item C<untar($tarfile,$targetdir, $remove_tarfile)> @@ -1270,13 +1566,12 @@ sub untar { return $ret; } - =item C<setup_programs($bindir, $platform)> Populate the global C<$::progs> hash containing the paths to the -programs C<wget>, C<tar>, C<lzmadec>. The C<$bindir> argument specifies -the path to the location of the C<lzmadec> binaries, the C<$platform> +programs C<wget>, C<tar>, C<xzdec>. The C<$bindir> argument specifies +the path to the location of the C<xzdec> binaries, the C<$platform> gives the TeX Live platform name, used as the extension on our executables. If a program is not present in the TeX Live tree, we also check along PATH (without the platform extension.) @@ -1290,17 +1585,17 @@ sub setup_programs { my $ok = 1; $::progs{'wget'} = "wget"; - $::progs{'lzmadec'} = "lzmadec"; - $::progs{'lzma'} = "lzma"; + $::progs{'xzdec'} = "xzdec"; + $::progs{'xz'} = "xz"; $::progs{'tar'} = "tar"; if ($^O =~ /^MSWin(32|64)$/i) { $::progs{'wget'} = conv_to_w32_path("$bindir/wget/wget.exe"); $::progs{'tar'} = conv_to_w32_path("$bindir/tar.exe"); - $::progs{'lzmadec'} = conv_to_w32_path("$bindir/lzma/lzmadec.win32.exe"); - $::progs{'lzma'} = conv_to_w32_path("$bindir/lzma/lzma.exe"); - for my $prog ("lzmadec", "wget") { - my $opt = $prog eq "lzmadec" ? "--help" : "--version"; + $::progs{'xzdec'} = conv_to_w32_path("$bindir/xz/xzdec.exe"); + $::progs{'xz'} = conv_to_w32_path("$bindir/xz/xz.exe"); + for my $prog ("xzdec", "wget") { + my $opt = $prog eq "xzdec" ? "--help" : "--version"; my $ret = system("$::progs{$prog} $opt >nul 2>&1"); # on windows if ($ret != 0) { warn "TeXLive::TLUtils::setup_programs (w32) failed"; # no nl for perl @@ -1322,8 +1617,8 @@ sub setup_programs { } my $s = 0; $s += setup_unix_one('wget', "$bindir/wget/wget.$platform", "--version"); - $s += setup_unix_one('lzmadec',"$bindir/lzma/lzmadec.$platform","--help"); - $s += setup_unix_one('lzma', "$bindir/lzma/lzma.$platform", "notest"); + $s += setup_unix_one('xzdec',"$bindir/xz/xzdec.$platform","--help"); + $s += setup_unix_one('xz', "$bindir/xz/xz.$platform", "notest"); $ok = ($s == 3); # failure return unless all are present. } @@ -1600,7 +1895,7 @@ improved (checking for duplicates). sub create_fmtutil { my ($tlpdb,$dest,$localconf) = @_; my @lines = $tlpdb->fmtutil_cnf_lines; - _create_config_files($tlpdb, "texmf/fmtutil/fmtutil-hdr.cnf", $dest, + _create_config_files($tlpdb, "texmf/web2c/fmtutil-hdr.cnf", $dest, $localconf, 0, '#', \@lines); } |