safer update for tlmgr (make tar before removing)

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

3 files changed, 120 insertions, 53 deletions

diff --git a/Master/tlpkg/TeXLive/TLMedia.pm b/Master/tlpkg/TeXLive/TLMedia.pm
index 704051502db..49b21011a0a 100644
--- a/Master/tlpkg/TeXLive/TLMedia.pm
+++ b/Master/tlpkg/TeXLive/TLMedia.pm
@@ -86,6 +86,8 @@ sub new
 }
 
 #
+# returns a scalar (0) on error
+# returns a reference to a hash with actions on success
 sub install_package {
   my ($self, $pkg, $totlpdb, $nodepends, $nopostinstall, $fallbackmedia) = @_;
   my $fromtlpdb = $self->tlpdb;
@@ -117,7 +119,6 @@ sub install_package {
       # even if opt_doc is false
       $real_opt_doc = 1;
     }
-    info("install: $pkg\n");
     foreach my $h (@::install_packages_hook) {
       &$h("install: $package");
     }
@@ -160,7 +161,7 @@ sub install_package {
     } elsif (&media eq 'NET') {
       $container = "$location/$Archive/$pkg.$DefaultContainerExtension";
     }
-    $self->_install_package($container,\@installfiles,$totlpdb);
+    $self->_install_package($container,\@installfiles,$totlpdb) || return(0);
     # if we are installing from CD or NET we have to fetch the respective
     # source and doc packages $pkg.source and $pkg.doc and install them, too
     if (($media eq 'NET') || ($media eq 'CD')) {
@@ -173,13 +174,13 @@ sub install_package {
           ($pkg !~ m/\./) && $tlpobj->srcfiles) {
         my $srccontainer = $container;
         $srccontainer =~ s/(\.tar\.lzma|\.zip)$/.source$1/;
-        $self->_install_package($srccontainer,\@installfiles,$totlpdb);
+        $self->_install_package($srccontainer,\@installfiles,$totlpdb) || return(0);
       }
       if ($container_doc_split && $real_opt_doc &&
           ($pkg !~ m/\./) && $tlpobj->docfiles) {
         my $doccontainer = $container;
         $doccontainer =~ s/(\.tar\.lzma|\.zip)$/.doc$1/;
-        $self->_install_package($doccontainer,\@installfiles,$totlpdb);
+        $self->_install_package($doccontainer,\@installfiles,$totlpdb) || return(0);
       }
     }
     # we don't want to have wrong information in the tlpdb, so remove the
@@ -245,6 +246,11 @@ sub install_package {
   }
 }
 
+#
+# _install_package
+# actually does the installation work
+# returns 1 on success and 0 on error
+#
 sub _install_package {
   my ($self, $what, $filelistref, $totlpdb) = @_;
 
@@ -258,7 +264,8 @@ sub _install_package {
   my $lzmadec = $::progs{'lzmadec'};
   my $tar = $::progs{'tar'};
   if (!defined($wget) || !defined($lzmadec) || !defined($tar)) {
-    die "Programs have not been set up properly, strange!";
+    tlwarn("Programs have not been set up properly, strange!\n");
+    return(0);
   }
 
   if (ref $what) {
@@ -271,48 +278,82 @@ sub _install_package {
       mkdirhier("$target/$dn");
       copy "$location/$file", "$target/$dn";
     }
-  } elsif ($what =~ m,\.tar.lzma$,) {
-    # this is the case when we install from CD or the NET
+  } elsif ($what =~ m,\.tar(\.lzma)?$,) {
+    my $type = defined($1) ? "lzma" : "tar";
+      
+    # this is the case when we install from CD or the NET, or a backup
     #
     # in all other cases we create temp files .tar.lzma (or use the present
     # one), lzmadec them, and then call tar
 
     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 $tarfile_quote = $tarfile;
-    my $target_quote = $target;
-    if (win32()) {
-      $lzmafile =~ s!/!\\!g;
-      $lzmafile_quote = "\"$lzmafile\"";
-      $tarfile =~ s!/!\\!g;
-      $tarfile_quote = "\"$tarfile\"";
-      $target =~ s!/!\\!g;
-      $target_quote = "\"$target\"";
-    }
-    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)) {
-        die "Downloading $what did not succeed, please retry!";
+    my $tarfile;
+    my $remove_tarfile = 1;
+    if ($type eq "lzma") {
+      my $lzmafile = "$target/temp/$fn";
+      $tarfile  = "$target/temp/$fn"; $tarfile =~ s/\.lzma$//;
+      my $lzmafile_quote = $lzmafile;
+      my $tarfile_quote = $tarfile;
+      my $target_quote = $target;
+      if (win32()) {
+        $lzmafile =~ s!/!\\!g;
+        $lzmafile_quote = "\"$lzmafile\"";
+        $tarfile =~ s!/!\\!g;
+        $tarfile_quote = "\"$tarfile\"";
+        $target =~ s!/!\\!g;
+        $target_quote = "\"$target\"";
+      }
+      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)) {
+          tlwarn("Downloading \n");
+          tlwarn("   $what\n");
+          tlwarn("did not succeed, please retry!\n");
+          unlink($tarfile, $lzmafile);
+          return(0);
+        }
+      } else {
+        # we are installing from CD
+        # copy it to temp
+        copy($what, "$target/temp");
       }
+      debug("Un-lzmaing $lzmafile to $tarfile\n");
+      system("$lzmadec < $lzmafile_quote > $tarfile_quote");
+      if (! -f $tarfile) {
+        tlwarn("Unpacking $lzmafile did not succeed, please retry!\n");
+        unlink($tarfile, $lzmafile);
+        return(0);
+      }
+      unlink($lzmafile);
     } else {
-      # we are installing from CD
-      # copy it to temp
-      copy($what, "$target/temp");
-    }
-    debug("Un-lzmaing $lzmafile to $tarfile\n");
-    system("$lzmadec < $lzmafile_quote > $tarfile_quote");
-    if (! -f $tarfile) {
-      die "Unpacking $lzmafile did not succeed, please retry!";
+      $tarfile = "$target/temp/$fn";
+      if ($what =~ m,http://|ftp://,) {
+        if (!download_file($what, $tarfile) || (! -r $tarfile)) {
+          tlwarn("Downloading \n");
+          tlwarn("   $what\n");
+          tlwarn("did not succeed, please retry!\n");
+          unlink($tarfile);
+          return(0);
+        }
+      } else {
+        $tarfile = $what;
+        $remove_tarfile = 0;
+      }
     }
     debug("Unpacking $tarfile\n");
-    system($tar,"-x","-C",$target,"-f",$tarfile);
-    unlink($tarfile, $lzmafile);
+    if (system($tar,"-x","-C",$target,"-f",$tarfile) != 0) {
+      tlwarn("Untarring $tarfile did not succeed, please retry!\n");
+      unlink($tarfile) if $remove_tarfile;
+      return(0);
+    }
+    # we are still here, so success!
+    unlink($tarfile) if $remove_tarfile;
+    return(1);
   } else {
-    die "Don't know how to install $what!\n";
+    tlwarn("Don't know how to install $what!\n");
+    return(0);
   }
 }
 
diff --git a/Master/tlpkg/TeXLive/TLPOBJ.pm b/Master/tlpkg/TeXLive/TLPOBJ.pm
index 44c0b1b197b..57403d7ebc0 100644
--- a/Master/tlpkg/TeXLive/TLPOBJ.pm
+++ b/Master/tlpkg/TeXLive/TLPOBJ.pm
@@ -512,8 +512,8 @@ sub writeout_simple {
 
 sub make_container {
   my ($self,$type,$instroot,$destdir,$containername,$relative) = @_;
-  if ($type ne "lzma") {
-    die("TLPOBJ currently supports only lzma containers");
+  if (($type ne "lzma") && ($type ne "tar")) {
+    die("TLPOBJ currently supports only plain or lzma containers");
   }
   if (!defined($containername)) {
     $containername = $self->name;
@@ -572,18 +572,25 @@ sub make_container {
   close(TMP);
   push @files, "$tlpobjdir/$self->{'name'}.tlpobj";
   $tarname = "$containername.tar";
-  $containername = "$tarname.lzma";
+  if ($type eq "tar") {
+    $containername = $tarname;
+  } else {
+    $containername = "$tarname.lzma";
+  }
 
   # start the whole fun
   my $tar = $::progs{'tar'};
-  my $lzma = $::progs{'lzma'};
+  my $lzma;
   if (!defined($tar)) {
     tlwarn("Programs have not been set up, trying with \"tar\"!\n");
     $tar = "tar";
   }
-  if (!defined($lzma)) {
-    tlwarn("Programs have not been set up, trying with \"lzma\"!\n");
-    $lzma = "lzma";
+  if ($type eq "lzma") {
+    my $lzma = $::progs{'lzma'};
+    if (!defined($lzma)) {
+      tlwarn("Programs have not been set up, trying with \"lzma\"!\n");
+      $lzma = "lzma";
+    }
   }
   my @cmdline = ($tar, "--owner", "0", "--group", "0", "-c", "-f", "$destdir/$tarname", "--files-from=-");
   unlink("$destdir/$containername");
@@ -603,20 +610,23 @@ sub make_container {
     }
   } @files;
   close ZIP;
-  if (-r "$destdir/$tarname") {
-    system($lzma, "--force", "-z", "$destdir/$tarname");
-  } else {
-    tlwarn("Couldn't find $destdir/$tarname\n");
+  if ($type eq "lzma") {
+    if (-r "$destdir/$tarname") {
+      system($lzma, "--force", "-z", "$destdir/$tarname");
+    } else {
+      tlwarn("Couldn't find $destdir/$tarname\n");
+      return(0,0,"");
+    }
   }
   # compute the size
-  my $size = (stat "$destdir/$tarname.lzma") [7];
-  my $m = TeXLive::TLUtils::tlmd5("$destdir/$tarname.lzma");
+  my $size = (stat "$destdir/$containername") [7];
+  my $m = TeXLive::TLUtils::tlmd5("$destdir/$containername");
   # cleaning up
   unlink("$tlpobjdir/$self->{'name'}.tlpobj");
   rmdir("$tlpobjdir") if $removetlpobjdir;
   chdir($cwd);
   ddebug("Done $containername\n");
-  return($size,$m);
+  return($size,$m,"$destdir/$containername");
 }
 
 
@@ -1288,6 +1298,7 @@ is placed into the root of the installation.
 This is used to distribute packages which can be installed in any arbitrary
 texmf tree (of other distributions, too).
 
+Return values are the size, the md5sum, and the full name of the container.
 
 =item C<recompute_sizes($tltree)>
 
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index c96fad10358..a35fd51fbbc 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -683,8 +683,10 @@ sub rmtree {
 =pod
 
 =item C<copy($file, $target_dir)>
+=item C<copy("-f", $file, $destfile)>
 
-Copy file C<$file> to directory C<$target_dir>.  No external programs
+Copy file C<$file> to directory C<$target_dir>, or to the C<$destfile> in
+the second case.  No external programs
 are involved.  Since we need C<sysopen()>, the Perl module C<Fcntl.pm>
 is required.  The time stamps are preserved and symlinks are created
 on UNIX systems.  On Windows, C<(-l $file)> will certainly never
@@ -700,6 +702,12 @@ Note that C<copy> will work with file:/ prefixes, too.
 
 sub copy {
   my $infile=shift;
+  my $filemode = 0;
+  if ($infile eq "-f") {
+    # second argument is a file!!!
+    $filemode = 1;
+    $infile = shift;
+  }
   my $destdir=shift;
   my $outfile;
   my @stat;
@@ -710,11 +718,18 @@ sub copy {
   my $dirmode=0755;
   my $blocksize=2048;
 
-  mkdirhier ("$destdir") unless -d "$destdir";
 
   $infile =~ s!^file://*!/!i;
   $filename=basename "$infile";
-  $outfile="$destdir/$filename";
+  if ($filemode) {
+    # we actually got a destination file
+    $outfile = $destdir;
+    $destdir = dirname($outfile);
+  } else {
+    $outfile="$destdir/$filename";
+  }
+
+  mkdirhier ("$destdir") unless -d "$destdir";
 
   if (-l "$infile") {
     symlink readlink "$infile", "$destdir/$filename";