safer update for tlmgr (make tar before removing)

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

4 files changed, 205 insertions, 64 deletions

diff --git a/Master/texmf/scripts/texlive/tlmgr.pl b/Master/texmf/scripts/texlive/tlmgr.pl
index d042b118b9d..def2880ed85 100755
--- a/Master/texmf/scripts/texlive/tlmgr.pl
+++ b/Master/texmf/scripts/texlive/tlmgr.pl
@@ -259,21 +259,20 @@ sub remove_package {
   my $tlp = $localtlpdb->get_package($pkg);
   my %ret;
   if (!defined($tlp)) {
-    print "Package $pkg not present, cannot remove it!\n";
+    tlwarn ("Package $pkg not present, cannot remove it!\n");
   } else {
     if (!$force) {
       # do some checking
       my @needed = $localtlpdb->needed_by($pkg);
       if (@needed) {
-        print "$pkg: not removed, referenced in @needed\n";
+        tlwarn  ("$pkg: not removed, referenced in @needed\n");
         return;
       }
     }
     if ($pkg =~ m/^texlive\.infra/) {
-      log("Not removing $pkg, it is essential!\n");
+      log ("Not removing $pkg, it is essential!\n");
       return;
     }
-    print "remove: $pkg\n";
     # we have to chdir to $localtlpdb->root
     my $Master = $localtlpdb->root;
     chdir ($Master) || die "chdir($Master) failed: $!";
@@ -302,6 +301,7 @@ sub remove_package {
       if ($d eq "$pkg.ARCH") {
         foreach my $a ($localtlpdb->available_architectures) {
           if (defined($localtlpdb->get_package("$pkg.$a"))) {
+            debug ("remove $pkg.$a\n");
             merge_into(\%ret,
                        &remove_package("$pkg.$a", $localtlpdb, $force));
           }
@@ -372,6 +372,7 @@ sub action_remove {
           # the rest will not be run in dry_run mode
           $foo{'mktexlsr'} = 1;
         } else {
+          info ("remove $pkg\n");
           merge_into(\%foo, &remove_package($pkg, $localtlpdb, $opt_force));
         }
         if (keys %foo) {
@@ -387,6 +388,7 @@ sub action_remove {
                   if ($opt_dry) {
                     print "remove: $d\n";
                   } else {
+                    info ("remove $d\n");
                     merge_into(\%ret, &remove_package($d, $localtlpdb, $opt_force));
                   }
                   $already_removed{$d} = 1;
@@ -410,6 +412,7 @@ sub action_remove {
         print "remove: $pkg\n";
       } else {
         my %foo;
+        info ("remove $pkg\n");
         merge_into(\%foo, &remove_package($pkg, $localtlpdb, $opt_force));
         if (keys %foo) {
           # removal was successful
@@ -637,6 +640,15 @@ sub action_update {
   my %ret;
   init_tlmedia();
   my $mediatlpdb = $tlmediasrc->tlpdb;
+  # these two variables are used throughout this function
+  my $root = $localtlpdb->root;
+  my $temp = "$root/temp";
+  #
+  # remove old _BACKUP packages that have piled up in temp
+  # they can be recognized by their name starting with __BACKUP_
+  for my $f (<$temp/__BACKUP_*>) {
+    unlink($f) unless $opt_dry;
+  }
   my @todo;
   if ($opt_all || $opt_list) {
     @todo = $localtlpdb->list_packages;
@@ -677,6 +689,8 @@ sub action_update {
       printf STDERR "$0: $pkg not installed locally\n";
       next;
     }
+    my $unwind_package;
+    my $remove_unwind_container = 0;
     my $rev = $tlp->revision;
     my $mediatlp = $mediatlpdb->get_package($pkg);
     if (!defined($mediatlp)) {
@@ -700,13 +714,14 @@ sub action_update {
             printf STDERR "backupdir argument must be an existing directory!\n";
           } else {
             my $tlp = $localtlpdb->get_package($pkg);
-            $tlp->make_container("lzma", $localtlpdb->root, 
+            $tlp->make_container("lzma", $root, 
                                  $opt_backupdir, "${pkg}.r" . $tlp->revision);
+            $unwind_package = "$opt_backupdir/${pkg}.r" . $tlp->revision . ".tar.lzma";
           }
         }
         if (win32() && ($pkg =~ m/$WinSpecialUpdatePackagesRegexp/)) {
           if (!$updater_started) {
-            open UPDATER, ">" . $localtlpdb->root . "/tlpkg/installer/updater.bat"
+            open UPDATER, ">" . $root . "/tlpkg/installer/updater.bat"
               or die "Cannot create updater.bat: $!";
             print UPDATER <<'EOF';
 rem update program, can savely removed after it has been done
@@ -730,8 +745,6 @@ EOF
           # so we have to create a update program
           my $media = $tlmediasrc->media;
           my $remoteroot = $mediatlpdb->root;
-          my $root = $localtlpdb->root;
-          my $temp = "$root/temp";
           TeXLive::TLUtils::mkdirhier($temp);
           if ($media eq 'DVD') {
             tlwarn ("Creating updater from DVD currently not implemented!\n");
@@ -757,10 +770,63 @@ EOF
             }
           }
         } else {
-          print "update: $pkg (first remove old, then install new)\n";
+          info("update: $pkg ... ");
+          if (!$unwind_package) {
+            # no backup was made, so let us create a temporary .tar file
+            # of the package
+            my $tlp = $localtlpdb->get_package($pkg);
+            my ($s, $m, $fullname) = $tlp->make_container("tar", $root, $temp, 
+                                          "__BACKUP_${pkg}.r" . $tlp->revision);
+            if ($s <= 0) {
+              tlwarn("\nCreation of backup container of $pkg didn't succeed\n");
+              tlwarn("I will not continue, either retry or call update --force\n");
+              tlwarn("Exiting!\n");
+              exit(1);
+            }
+            $remove_unwind_container = 1;
+            $unwind_package = "$fullname";
+          }
+          # the remove_package should also remove empty dirs in case
+          # a dir is changed into a file
           merge_into(\%ret, &remove_package($pkg, $localtlpdb, 1));
-          merge_into(\%ret, $tlmediasrc->install_package($pkg, $localtlpdb, $opt_nodepends, 0));
-          print "update: $pkg done\n";
+          my $foo = $tlmediasrc->install_package($pkg, $localtlpdb, $opt_nodepends, 0);
+          if (ref $foo) {
+            # installation succeeded because we got a reference
+            merge_into (\%ret, $foo);
+            unlink($unwind_package) if $remove_unwind_container;
+          } else {
+            # install_package returned a scalare, so error!
+            # now in fact we should do some cleanup, removing files and
+            # dirs from the new package before re-installing the old one!!!
+            # TODO
+            tlwarn("\n\nInstallation of new version of $pkg did fail, trying to unwind!\n");
+            if (win32()) {
+              # win32 is notorious for not releasing a file immediately
+              # we experienced permission denied errors 
+              my $newname = $unwind_package;
+              $newname =~ s/__BACKUP/___BACKUP/;
+              copy ("-f", $unwind_package, $newname);
+              # try to remove the file if has been created by us
+              unlink($unwind_package) if $remove_unwind_container;
+              # and make sure that the temporary file is removed in any case
+              $remove_unwind_container = 1;
+              $unwind_package = $newname;
+            }
+            my $instret = TeXLive::TLMedia->_install_package("$unwind_package" , [] ,$localtlpdb);
+            if ($instret) {
+              # now we have to include the tlpobj
+              my $tlpobj = TeXLive::TLPOBJ->new;
+              $tlpobj->from_file($root . "/tlpkg/tlpobj/$pkg.tlpobj");
+              $localtlpdb->add_tlpobj($tlpobj);
+              $localtlpdb->save;
+              tlwarn("Restoring old package state succeeded.\n");
+            } else {
+              tlwarn("Restoring of old package did NOT succeed!\n");
+              tlwarn("Best is to call tlmgr install $pkg and hope to get it right!\n");
+            }
+            unlink($unwind_package) if $remove_unwind_container;
+          }
+          info("done\n");
         }
       }
     } elsif ($rev > $mediarev) {
@@ -813,6 +879,7 @@ sub action_install {
       print "install: $pkg\n";
     } else {
       # install the packages and run postinstall actions (that is the 0)
+      info("install: $pkg\n");
       merge_into(\%ret, $tlmediasrc->install_package($pkg, $localtlpdb, $opt_nodepends, 0));
     }
   }
@@ -976,6 +1043,7 @@ sub action_arch {
             if ($opt_dry) {
               print "Installing $pkg.$a\n";
             } else {
+              info("install: $pkg.$a\n");
               merge_into(\%ret, $tlmediasrc->install_package("$pkg.$a", $localtlpdb, 0, 0));
             }
           }
@@ -984,8 +1052,11 @@ sub action_arch {
     }
     if (TeXLive::TLUtils::member('win32', @todoarchs)) {
       # install the necessary win32 stuff
+      info("install: bin-tlperl.win32\n");
       merge_into (\%ret, $tlmediasrc->install_package("bin-tlperl.win32", $localtlpdb, 1, 0));
+      info("install: bin-tlgs.win32\n");
       merge_into (\%ret, $tlmediasrc->install_package("bin-tlgs.win32", $localtlpdb, 1, 0));
+      info("install: bin-tlpsv.win32\n");
       merge_into (\%ret, $tlmediasrc->install_package("bin-tlpsv.win32", $localtlpdb, 1, 0));
     }
     # update the option_archs list of installed archs
@@ -1072,6 +1143,9 @@ sub init_local_db {
   if (!defined($location)) {
     die("No installation source found, nor in the texlive.tlpdb nor on the cmd line.\nPlease specify one!");
   }
+  if ($location =~ m/^ctan$/i) {
+    $location = "$TeXLive::TLConfig::TeXLiveURL";
+  }
   if ($location !~ m!^(http|ftp)://!i) {
     # seems to be a local path, try to normalize it
     my $testloc = abs_path($location);
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";