summaryrefslogtreecommitdiff
path: root/Build
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2017-10-14 21:12:48 +0000
committerKarl Berry <karl@freefriends.org>2017-10-14 21:12:48 +0000
commit3bba2637d36fab5639bb4544f8c018e777ab15fd (patch)
tree07a2b956df9845c0bba964e619158a42c8d8c9c4 /Build
parent5b212b8ee20d87ed0e687d3faa23f0f26d71d2c3 (diff)
sync
git-svn-id: svn://tug.org/texlive/trunk@45540 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build')
-rw-r--r--Build/source/texk/tests/TeXLive/TLUtils.pm119
-rwxr-xr-xBuild/source/texk/texlive/linked_scripts/texlive/tlmgr.pl127
2 files changed, 178 insertions, 68 deletions
diff --git a/Build/source/texk/tests/TeXLive/TLUtils.pm b/Build/source/texk/tests/TeXLive/TLUtils.pm
index 61102113735..5b603cf52f1 100644
--- a/Build/source/texk/tests/TeXLive/TLUtils.pm
+++ b/Build/source/texk/tests/TeXLive/TLUtils.pm
@@ -5,7 +5,7 @@
package TeXLive::TLUtils;
-my $svnrev = '$Revision: 44243 $';
+my $svnrev = '$Revision: 44872 $';
my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
sub module_revision { return $_modulerevision; }
@@ -802,32 +802,61 @@ sub dir_writable {
=item C<mkdirhier($path, [$mode])>
-The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>,
-and dies on failure. The optional parameter sets the permission bits.
+The function C<mkdirhier> does the same as the UNIX command C<mkdir -p>.
+It behaves differently depending on the context in which it is called:
+If called in void context it will die on failure. If called in
+scalar context, it will return 1/0 on sucess/failure. If called in
+list context, it returns 1/0 as first element and an error message
+as second, if an error occurred (and no second element in case of
+success). The optional parameter sets the permission bits.
=cut
sub mkdirhier {
my ($tree,$mode) = @_;
+ my $ret = 1;
+ my $reterror;
- return if (-d "$tree");
- my $subdir = "";
- # win32 is special as usual: we need to separate //servername/ part
- # from the UNC path, since (! -d //servername/) tests true
- $subdir = $& if ( win32() && ($tree =~ s!^//[^/]+/!!) );
-
- @dirs = split (/\//, $tree);
- for my $dir (@dirs) {
- $subdir .= "$dir/";
- if (! -d $subdir) {
- if (defined $mode) {
- mkdir ($subdir, $mode)
- || die "$0: mkdir($subdir,$mode) failed, goodbye: $!\n";
- } else {
- mkdir ($subdir) || die "$0: mkdir($subdir) failed, goodbye: $!\n";
+ if (-d "$tree") {
+ $ret = 1;
+ } else {
+ my $subdir = "";
+ # win32 is special as usual: we need to separate //servername/ part
+ # from the UNC path, since (! -d //servername/) tests true
+ $subdir = $& if ( win32() && ($tree =~ s!^//[^/]+/!!) );
+
+ @dirs = split (/\//, $tree);
+ for my $dir (@dirs) {
+ $subdir .= "$dir/";
+ if (! -d $subdir) {
+ if (defined $mode) {
+ if (! mkdir ($subdir, $mode)) {
+ $ret = 0;
+ $reterror = "mkdir($subdir,$mode) failed: $!";
+ last;
+ }
+ } else {
+ if (! mkdir ($subdir)) {
+ $ret = 0;
+ $reterror = "mkdir($subdir) failed: $!";
+ last;
+ }
+ }
}
}
}
+ if ($ret) {
+ return(1); # nothing bad here returning 1 in any case, will
+ # be ignored in void context, and give 1 in list context
+ } else {
+ if (wantarray) {
+ return(0, $reterror);
+ } elsif (defined wantarray) {
+ return(0);
+ } else {
+ die "$0: $reterror\n";
+ }
+ }
}
@@ -1809,7 +1838,11 @@ On Windows it returns undefined.
sub add_link_dir_dir {
my ($from,$to) = @_;
- mkdirhier ($to);
+ my ($ret, $err) = mkdirhier ($to);
+ if (!$ret) {
+ tlwarn("$err\n");
+ return 0;
+ }
if (-w $to) {
debug ("linking files from $from to $to\n");
chomp (@files = `ls "$from"`);
@@ -1864,7 +1897,7 @@ sub remove_link_dir_dir {
tlwarn ("not removing $to/$f, not a link or wrong destination!\n");
}
}
- # trry to remove the destination directory, it might be empty and
+ # try to remove the destination directory, it might be empty and
# we might have write permissions, ignore errors
# `rmdir "$to" 2>/dev/null`;
return $ret;
@@ -1896,7 +1929,7 @@ sub add_remove_symlinks {
} else {
die ("should not happen, unknown mode $mode in add_remove_symlinks!");
}
-
+
# man
my $top_man_dir = "$Master/texmf-dist/doc/man";
debug("$mode symlinks for man pages to $sys_man from $top_man_dir\n");
@@ -1904,25 +1937,35 @@ sub add_remove_symlinks {
; # better to be silent?
#info("skipping add of man symlinks, no source directory $top_man_dir\n");
} else {
- mkdirhier $sys_man if ($mode eq "add");
- if (-w $sys_man) {
- my $foo = `(cd "$top_man_dir" && echo *)`;
- my @mans = split (' ', $foo);
- chomp (@mans);
- foreach my $m (@mans) {
- my $mandir = "$top_man_dir/$m";
- next unless -d $mandir;
- if ($mode eq "add") {
- $errors++ unless add_link_dir_dir($mandir, "$sys_man/$m");
- } else {
- $errors++ unless remove_link_dir_dir($mandir, "$sys_man/$m");
+ my $man_doable = 1;
+ if ($mode eq "add") {
+ my ($ret, $err) = mkdirhier $sys_man;
+ if (!$ret) {
+ $man_doable = 0;
+ tlwarn("$err\n");
+ $errors++;
+ }
+ }
+ if ($man_doable) {
+ if (-w $sys_man) {
+ my $foo = `(cd "$top_man_dir" && echo *)`;
+ my @mans = split (' ', $foo);
+ chomp (@mans);
+ foreach my $m (@mans) {
+ my $mandir = "$top_man_dir/$m";
+ next unless -d $mandir;
+ if ($mode eq "add") {
+ $errors++ unless add_link_dir_dir($mandir, "$sys_man/$m");
+ } else {
+ $errors++ unless remove_link_dir_dir($mandir, "$sys_man/$m");
+ }
}
+ #`rmdir "$sys_man" 2>/dev/null` if ($mode eq "remove");
+ } else {
+ tlwarn("man symlink destination ($sys_man) not writable, "
+ . "cannot $mode symlinks.\n");
+ $errors++;
}
- #`rmdir "$sys_man" 2>/dev/null` if ($mode eq "remove");
- } else {
- tlwarn("man symlink destination ($sys_man) not writable,"
- . "cannot $mode symlinks.\n");
- $errors++;
}
}
diff --git a/Build/source/texk/texlive/linked_scripts/texlive/tlmgr.pl b/Build/source/texk/texlive/linked_scripts/texlive/tlmgr.pl
index d086264bcb1..ae25ab9f70b 100755
--- a/Build/source/texk/texlive/linked_scripts/texlive/tlmgr.pl
+++ b/Build/source/texk/texlive/linked_scripts/texlive/tlmgr.pl
@@ -1,13 +1,13 @@
#!/usr/bin/env perl
-# $Id: tlmgr.pl 45499 2017-10-08 14:26:19Z preining $
+# $Id: tlmgr.pl 45532 2017-10-13 06:50:59Z preining $
#
# Copyright 2008-2017 Norbert Preining
# This file is licensed under the GNU General Public License version 2
# or any later version.
#
-my $svnrev = '$Revision: 45499 $';
-my $datrev = '$Date: 2017-10-08 16:26:19 +0200 (Sun, 08 Oct 2017) $';
+my $svnrev = '$Revision: 45532 $';
+my $datrev = '$Date: 2017-10-13 08:50:59 +0200 (Fri, 13 Oct 2017) $';
my $tlmgrrevision;
my $prg;
if ($svnrev =~ m/: ([0-9]+) /) {
@@ -169,7 +169,7 @@ my %action_specification = (
"function" => \&action_conf
},
"dump-tlpdb" => {
- "options" => { "local" => 1, remote => 1 },
+ "options" => { local => 1, remote => 1, json => 1 },
"run-post" => 0,
"function" => \&action_dumptlpdb
},
@@ -210,6 +210,7 @@ my %action_specification = (
"info" => {
"options" => {
"data" => "=s",
+ "all" => 1,
"list" => 1,
"only-installed" => 1,
},
@@ -334,6 +335,7 @@ my %action_specification = (
"no-auto-remove" => 1,
"no-depends" => 1,
"no-depends-at-all" => 1,
+ "no-restart" => 1,
"reinstall-forcibly-removed" => 1,
"self" => 1,
},
@@ -1376,14 +1378,22 @@ sub action_dumptlpdb {
$::machinereadable = 1;
if ($opts{"local"} && !$opts{"remote"}) {
- # for consistency we write out the location of the installation,
- # too, in the same format as when dumping the remote tlpdb
- print "location-url\t", $localtlpdb->root, "\n";
- $localtlpdb->writeout;
+ if ($opts{"json"}) {
+ print $localtlpdb->as_json;
+ } else {
+ # for consistency we write out the location of the installation,
+ # too, in the same format as when dumping the remote tlpdb
+ print "location-url\t", $localtlpdb->root, "\n";
+ $localtlpdb->writeout;
+ }
} elsif ($opts{"remote"} && !$opts{"local"}) {
- init_tlmedia_or_die();
- $remotetlpdb->writeout;
+ init_tlmedia_or_die(1);
+ if ($opts{"json"}) {
+ print $remotetlpdb->as_json;
+ } else {
+ $remotetlpdb->writeout;
+ }
} else {
tlwarn("$prg dump-tlpdb: need exactly one of --local and --remote.\n");
@@ -1402,13 +1412,34 @@ sub action_info {
my $ret = $F_OK | $F_NOPOSTACTION;
my @datafields;
my $fmt = "list";
- if ($opts{'data'}) {
+ if ($opts{'data'} eq "json") {
+ eval { require JSON; };
+ if ($@) {
+ # that didn't work out, give some usefull error message and stop
+ if ($^O =~ /^MSWin/i) {
+ # that should not happen, we are shipping Tk!!
+ require Win32;
+ my $msg = "Cannot load JSON:PP, that should not happen as we ship it!\n(Error message: $@)\n";
+ Win32::MsgBox($msg, 1|Win32::MB_ICONSTOP(), "Warning");
+ } else {
+ printf STDERR "
+$prg: Cannot load JSON.
+This module is shipped with core Perl unless you have a very old Perl,
+in which case you cannot use the json option.
+Goodbye.
+";
+ }
+ }
+ $fmt = 'json';
+ # the 1 is the silent mode!
+ init_tlmedia_or_die(1);
+ } elsif ($opts{'data'}) {
# output format is changed to csv with " as quotes
# we need to determine the fields
@datafields = split(',', $opts{'data'});
# check for correctness of data fields
for my $d (@datafields) {
- if ($d !~ m/name|category|localrev|remoterev|shortdesc|longdesc|size|installed|relocatable|cat-version|cat-date|cat-license/) {
+ if ($d !~ m/name|category|localrev|remoterev|shortdesc|longdesc|size|installed|relocatable|depends|cat-version|cat-date|cat-license/) {
tlwarn("unknown data field: $d\n");
return($F_ERROR);
}
@@ -1430,14 +1461,21 @@ sub action_info {
}
# we are still here, so $what is defined and neither collection nor scheme,
# so assume the arguments are package names
- $fmt = ($opts{'data'} ? "csv" : "detail");
+ if ($opts{'data'} ne "json") {
+ $fmt = ($opts{'data'} ? "csv" : "detail");
+ }
my @adds;
if ($opts{'data'}) {
@adds = @datafields;
}
+ print "[\n" if ($fmt eq "json");
+ my $first = 1;
foreach my $ppp ($what, @todo) {
+ print "," if ($fmt eq "json" && !$first);
+ $first = 0;
$ret |= show_one_package($ppp, $fmt, @adds);
}
+ print "]\n" if ($fmt eq "json");
return ($ret);
}
@@ -2379,7 +2417,7 @@ sub action_update {
}
my $dry_run_cont = $opts{"dry-run"} && ($opts{"dry-run"} < 0);
if ( !$dry_run_cont && !$opts{"self"} && @critical) {
- critical_updates_warning();
+ critical_updates_warning() if (!$::machinereadable);
if ($opts{"force"}) {
tlwarn("$prg: Continuing due to --force.\n");
} elsif ($opts{"list"}) {
@@ -3216,7 +3254,7 @@ sub action_update {
}
my $restart_tlmgr = 0;
- if ($opts{"self"} && @critical &&
+ if ($opts{"self"} && @critical && !$opts{'no-restart'} &&
$infra_update_done && $other_updates_asked_for) {
# weed out the --self argument from the saved arguments
@::SAVEDARGV = grep (!m/^-?-self$/, @::SAVEDARGV);
@@ -3265,14 +3303,15 @@ sub action_update {
# warn if nothing is updated. Unless they said --self, in which case
# we've already reported it.
if (!(@new || @updated) && ! $opts{"self"}) {
- info("$prg: no updates available\n") if (!$::machinereadable);
- if ($remotetlpdb->media ne "NET"
- && $remotetlpdb->media ne "virtual"
- && !$opts{"dry-run"}
- && !$opts{"repository"}
- && !$ENV{"TEXLIVE_INSTALL_ENV_NOCHECK"}
- ) {
- tlwarn(<<END_DISK_WARN);
+ if (!$::machinereadable) {
+ info("$prg: no updates available\n");
+ if ($remotetlpdb->media ne "NET"
+ && $remotetlpdb->media ne "virtual"
+ && !$opts{"dry-run"}
+ && !$opts{"repository"}
+ && !$ENV{"TEXLIVE_INSTALL_ENV_NOCHECK"}
+ ) {
+ tlwarn(<<END_DISK_WARN);
$prg: Your installation is set up to look on the disk for updates.
To install from the Internet for this one time only, run:
tlmgr -repository $TeXLiveURL ACTION ARG...
@@ -3281,6 +3320,7 @@ where ACTION is install, update, etc.; see tlmgr -help if needed.
To change the default for all future updates, run:
tlmgr option repository $TeXLiveURL
END_DISK_WARN
+ }
}
}
return ($ret);
@@ -3359,7 +3399,7 @@ sub action_install {
# check for updates to tlmgr itself, and die unless --force is given
if (!$opts{"usermode"}) {
if (check_for_critical_updates( $localtlpdb, $remotetlpdb)) {
- critical_updates_warning();
+ critical_updates_warning() if (!$::machinereadable);
if ($opts{"force"}) {
tlwarn("$prg: Continuing due to --force\n");
} else {
@@ -3556,6 +3596,8 @@ sub show_one_package {
$ret = show_one_package_detail($pkg, @rest);
} elsif ($fmt eq "csv") {
$ret = show_one_package_csv($pkg, @rest);
+ } elsif ($fmt eq "json") {
+ $ret = show_one_package_json($pkg);
} else {
tlwarn("$prg: show_one_package: unknown format: $fmt\n");
return($F_ERROR);
@@ -3563,6 +3605,24 @@ sub show_one_package {
return($ret);
}
+sub show_one_package_json {
+ my ($p) = @_;
+ my @out;
+ my $loctlp = $localtlpdb->get_package($p);
+ my $remtlp = $remotetlpdb->get_package($p);
+ my $is_installed = (defined($loctlp) ? 1 : 0);
+ my $is_available = (defined($remtlp) ? 1 : 0);
+ if (!($is_installed || $is_available)) {
+ tlwarn("$prg: package $p not found neither locally nor remote!\n");
+ return($F_WARNING);
+ }
+ my $tlp = ($is_installed ? $loctlp : $remtlp);
+ my $str = $tlp->as_json();
+ print $str, "\n";
+ return($F_OK);
+}
+
+
sub show_one_package_csv {
my ($p, @datafields) = @_;
my @out;
@@ -3611,6 +3671,8 @@ sub show_one_package_csv {
push @out, ($is_installed ? $loctlp->revision : 0);
} elsif ($d eq "remoterev") {
push @out, ($is_available ? $remtlp->revision : 0);
+ } elsif ($d eq "depends") {
+ push @out, (join(":", $tlp->depends));
} elsif ($d eq "size") {
# tlp->*size is in 4k blocks!
my $srcsize = $tlp->srcsize * $TeXLive::TLConfig::BlockSize;
@@ -6217,7 +6279,7 @@ sub action_shell {
print "OK\n";
}
# make sure that we restart after having called update --self!
- if (($cmd eq 'update') && $opts{'self'}) {
+ if (($cmd eq 'update') && $opts{'self'} && !$opts{'no-restart'}) {
print "tlmgr has been updated, restarting!\n";
exec("tlmgr", @::SAVEDARGV);
}
@@ -7621,10 +7683,15 @@ locally installed packages, collections, or schemes are listed.
If the option C<--data> is given, its argument must be a comma separated
list of field names from: C<name>, C<category>, C<localrev>, C<remoterev>,
-C<shortdesc>, C<longdesc>, C<installed>, C<size>, C<relocatable>, C<cat-version>,
-C<cat-date>, or C<cat-licence>. In this case the requested packages'
-information is listed in CSV format one package per line, and the
-column information is given by the C<itemN>.
+C<shortdesc>, C<longdesc>, C<installed>, C<size>, C<relocatable>, C<depends>,
+C<cat-version>, C<cat-date>, or C<cat-licence>. In this case the requested
+packages' information is listed in CSV format one package per line, and the
+column information is given by the C<itemN>. The C<depends> column contains
+the name of all dependencies separated by C<:>.
+
+In case the only value passed to C<--data> is C<json>, the output is a
+JSON encoded array where each array element is the JSON representation of
+the internal object.
=back
@@ -9097,7 +9164,7 @@ This script and its documentation were written for the TeX Live
distribution (L<http://tug.org/texlive>) and both are licensed under the
GNU General Public License Version 2 or later.
-$Id: tlmgr.pl 45499 2017-10-08 14:26:19Z preining $
+$Id: tlmgr.pl 45532 2017-10-13 06:50:59Z preining $
=cut
# to remake HTML version: pod2html --cachedir=/tmp tlmgr.pl >/tmp/tlmgr.html