sync

git-svn-id: svn://tug.org/texlive/trunk@45540 c570f23f-e606-0410-a88d-b1316a301751

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