new patch from Tomek for tmgr/w32_updater

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

1 files changed, 133 insertions, 118 deletions

diff --git a/Master/texmf/scripts/texlive/tlmgr.pl b/Master/texmf/scripts/texlive/tlmgr.pl
index 2643505f519..c60cf2199fe 100755
--- a/Master/texmf/scripts/texlive/tlmgr.pl
+++ b/Master/texmf/scripts/texlive/tlmgr.pl
@@ -1124,28 +1124,31 @@ sub action_backup {
 
 #
 sub write_w32_updater {
-  my ($opt_dry, @w32_updates) = @_;
+  my @w32_updated = @_;
   my $media = $tlmediasrc->media;
   my $mediatlpdb = $tlmediasrc->tlpdb;
   # we have to download/copy also the src/doc files if necessary!
   my $container_src_split = $mediatlpdb->config_src_container;
   my $container_doc_split = $mediatlpdb->config_doc_container;
   # get options about src/doc splitting from $totlpdb
-  # TT: should we local options to decide about install of doc & src?
+  # TT: should we use local options to decide about install of doc & src?
   my $opt_src = $localtlpdb->option_install_srcfiles;
   my $opt_doc = $localtlpdb->option_install_docfiles;
   my $root = $localtlpdb->root;
   my $temp = "$root/temp";
   my $repo = $mediatlpdb->root . "/$Archive";
   TeXLive::TLUtils::mkdirhier($temp);
+  tlwarn("Backup option not implemented for infrastructure update.\n") if ($opts{"backup"});
   if ($media eq 'DVD') {
-    tlwarn ("Creating updater from DVD currently not implemented!\n");
-    tlwarn ("But it should not be necessary!\n");
+    tlwarn("Creating updater from DVD currently not implemented!\n");
+    tlwarn("But it should not be necessary!\n");
     return 1; # abort
   }
   my ($mediatlp, $localtlp, $opt_real_doc, $sysret, $size, $md5, $fullname,
       $oldrev, $newrev, $pkg_part, @pkg_parts, @updater_args);
-  foreach my $pkg (@w32_updates) {
+  my $totalnr = $#w32_updated + 1;
+  my $currnr = 0;
+  foreach my $pkg (@w32_updated) {
     $mediatlp = $mediatlpdb->get_package($pkg);
     $localtlp = $localtlpdb->get_package($pkg);
     $oldrev = $localtlp->revision;
@@ -1155,10 +1158,17 @@ sub write_w32_updater {
     @pkg_parts = ($pkg);
     push(@pkg_parts, "$pkg.source") if ($container_src_split && $opt_src && $mediatlp->srcfiles);
     push(@pkg_parts, "$pkg.doc") if ($container_doc_split && $opt_real_doc && $mediatlp->docfiles);
-    if ($opt_dry) {
-      info("update: $pkg ($oldrev -> $newrev)\n");
+    $currnr++;
+    if ($opts{"dry-run"}) {
+      info("[$currnr/$totalnr] update: $pkg ($oldrev -> $newrev)\n");
       next;
     }
+    # create backup; make_container expects file name in a format: some-name.r[0-9]+
+    ($size, $md5, $fullname) = $localtlp->make_container("tar", $root, $temp, "__BACKUP_$pkg.r$oldrev");
+    if ($size <= 0) {
+      tlwarn("Creation of backup container of $pkg failed.\n");
+      return 1; # backup failed? abort
+    }
     foreach $pkg_part (@pkg_parts) {
       if ($media eq 'CD') {
         copy("$repo/$pkg_part.tar.lzma", "$temp");
@@ -1167,26 +1177,27 @@ sub write_w32_updater {
       }
       # now we should have the file present
       if (!-r "$temp/$pkg_part.tar.lzma") {
-        tlwarn ("Couldn't get $pkg_part.tar.lzma, that is bad\n");
+        tlwarn("Couldn't get $pkg_part.tar.lzma, that is bad\n");
         return 1; # abort
       } 
       # unpack lzma archive
-      $sysret = system("$root/tlpkg/installer/lzma/lzmadec.win32.exe  < \"$temp/$pkg_part.tar.lzma\" > \"$temp/$pkg_part.tar\"");
-      return 1 if $sysret; # unpack failed? abort
+      $sysret = system("$::progs{'lzmadec'} < \"$temp/$pkg_part.tar.lzma\" > \"$temp/$pkg_part.tar\"");
+      if ($sysret) {
+        tlwarn("Couldn't unpack $pkg_part.tar.lzma\n");
+        return 1; # unpack failed? abort
+      }
       unlink("$temp/$pkg_part.tar.lzma"); # we don't need that archive anymore
       push @updater_args, $pkg_part, $oldrev, $newrev;
     }
-    # create backup
-    ($size, $md5, $fullname) = $localtlp->make_container("tar", $root, $temp, "__BACKUP_$pkg.r$oldrev");
-    if ($size <= 0) {
-      tlwarn("Creation of backup container of $pkg failed.\n");
-      return 1; # backup failed? abort
-    }
   }
-  return 0 if ($opt_dry); # nothing else to do
+  return 0 if ($opts{"dry-run"}); # nothing else to do
   # write the updater script file
   open UPDATER, ">$root/tlpkg/installer/updater" or die "Cannot create updater: $!";
-  print UPDATER 'call %~dp0w32_updater ' . join(' ',@updater_args);
+  print UPDATER '@echo off
+setlocal enableextensions
+(set errorlevel=)
+call "%~dp0w32_updater" ' . join(' ',@updater_args) . '
+start /b cmd /c del "%~f0" & exit /b %errorlevel%';
   close UPDATER;
   return 0;
 }
@@ -1422,6 +1433,7 @@ sub action_update {
   #
   # we first collect the list of packages to be actually updated or installed
   my @updated;
+  my @w32_updated; # win32 special packages that need the updater batch script
   my @new;
   my @addlines;
 
@@ -1476,7 +1488,12 @@ sub action_update {
     }
     my $mediarev = $mediatlp->revision;
     if ($rev < $mediarev) {
-      push @updated, $pkg;
+      if (win32() && !$opts{"list"} && ($pkg =~ m/$WinSpecialUpdatePackagesRegexp/)) {
+        # w32 specials are treated as other packages for --list
+        push @w32_updated, $pkg;
+      } else {
+        push @updated, $pkg;
+      }
     } elsif ($rev > $mediarev) {
       if ($::machinereadable) {
         push @addlines,
@@ -1495,18 +1512,20 @@ sub action_update {
   }
 
   # number calculation
-  my $totalnr = $#new + $#updated + 2;
+  # without w32 special packages, those are dealt with in the updater batch script
+  my $totalnr = $#new + $#updated + 2; 
   my $nrupdated = 0;
   my $currnr = 1;
   # sizes_of_packages returns the sizes of *all* packages if nothing
   # is passed over, so if @new and @updated both are empty we will 
   # get something wrong back, namely the total size of all packages
   my %sizes;
-  if ($totalnr > 0) {
+  #  for size calculation we also want w32 special packages
+  if (@new || @updated || @w32_updated) {
     %sizes = %{$mediatlpdb->sizes_of_packages( 
       $localtlpdb->option_install_srcfiles,
       $localtlpdb->option_install_docfiles,
-      @new, @updated )};
+      @new, @updated, @w32_updated)};
   } else {
     $sizes{'__TOTAL__'} = 0;
   }
@@ -1567,7 +1586,6 @@ sub action_update {
   }
 
   #
-  my @w32_updates if win32();
   foreach my $pkg (sort @updated) {
     next if ($pkg =~ m/^00texlive/);
     my $tlp = $localtlpdb->get_package($pkg);
@@ -1588,110 +1606,107 @@ sub action_update {
       } else {
         info("$pkg: local: $rev, source: $mediarev\n");
       }
-    } else {
-      if ($opts{"backup"} && !$opts{"dry-run"}) {
-        $tlp->make_container("lzma", $root, 
-                             $opts{"backupdir"}, "${pkg}.r" . $tlp->revision);
-        $unwind_package = 
-          "$opts{'backupdir'}/${pkg}.r" . $tlp->revision . ".tar.lzma";
+      next;
+    }
+    
+    if ($opts{"backup"} && !$opts{"dry-run"}) {
+      $tlp->make_container("lzma", $root, 
+                           $opts{"backupdir"}, "${pkg}.r" . $tlp->revision);
+      $unwind_package = 
+        "$opts{'backupdir'}/${pkg}.r" . $tlp->revision . ".tar.lzma";
 
-        if ($autobackup) {
-          # in case we do auto backups we remove older backups
-          clear_old_backups($pkg, $opts{"backupdir"}, $autobackup);
-        }
+      if ($autobackup) {
+        # in case we do auto backups we remove older backups
+        clear_old_backups($pkg, $opts{"backupdir"}, $autobackup);
       }
+    }
 
-      if (win32() && ($pkg =~ m/$WinSpecialUpdatePackagesRegexp/)) {
-        # collect all infrastructure packages for later processing
-        push @w32_updates, $pkg;
-      } else {
-        if ($::machinereadable) {
-          machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg});
-        } else {
-          info("[$currnr/$totalnr] update: $pkg ($rev -> $mediarev)");
-        }
-        $currnr++;
-        if ($opts{"dry-run"}) {
-          info("\n") unless $::machinereadable;
-          next;
-        } else {
-          info(" ... ") unless $::machinereadable;  # more to come
-        }
+    if ($::machinereadable) {
+      machine_line($pkg, $FLAG_UPDATE, $rev, $mediarev, $sizes{$pkg});
+    } else {
+      info("[$currnr/$totalnr] update: $pkg ($rev -> $mediarev)");
+    }
+    $currnr++;
+    if ($opts{"dry-run"}) {
+      info("\n") unless $::machinereadable;
+      next;
+    } else {
+      info(" ... ") unless $::machinereadable;  # more to come
+    }
 
-        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("\n$0: Creation of backup container of $pkg failed.\n");
-            tlwarn("Continuing to update other packages, please retry...\n");
-            # we should try to update other packages at least
-            next;
-          }
-          $remove_unwind_container = 1;
-          $unwind_package = "$fullname";
-        }
-        # first remove the package, then reinstall it
-        # this way we get rid of useless files
-        # force the deinstallation since we will reinstall it
-        #
-        # the remove_package should also remove empty dirs in case
-        # a dir is changed into a file
-        merge_into(\%ret, &remove_package($pkg, $localtlpdb));
-        my $foo = $tlmediasrc->install_package($pkg, $localtlpdb);
-        if (ref $foo) {
-          # installation succeeded because we got a reference
-          merge_into (\%ret, $foo);
-          logpackage("update: $pkg ($rev -> $mediarev)");
-          unlink($unwind_package) if $remove_unwind_container;
-        } else {
-          # install_package returned a scalar, 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
-          logpackage("failed update: $pkg ($rev -> $mediarev)");
-          tlwarn("\n\nInstallation of new version of $pkg did fail, trying to unwind.\n");
-          if (win32()) {
-            # w32 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;
-            logpackage("restore: $pkg ($rev)");
-            tlwarn("Restoring old package state succeeded.\n");
-          } else {
-            logpackage("restore failed: $pkg ($rev)");
-            tlwarn("Restoring of old package did NOT succeed.\n");
-            tlwarn("Most likely repair: run tlmgr install $pkg and hope.\n");
-          }
-          unlink($unwind_package) if $remove_unwind_container;
-        }
-        info("done\n") unless $::machinereadable;
+    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("\n$0: Creation of backup container of $pkg failed.\n");
+        tlwarn("Continuing to update other packages, please retry...\n");
+        # we should try to update other packages at least
+        next;
       }
+      $remove_unwind_container = 1;
+      $unwind_package = "$fullname";
     }
+    # first remove the package, then reinstall it
+    # this way we get rid of useless files
+    # force the deinstallation since we will reinstall it
+    #
+    # the remove_package should also remove empty dirs in case
+    # a dir is changed into a file
+    merge_into(\%ret, &remove_package($pkg, $localtlpdb));
+    my $foo = $tlmediasrc->install_package($pkg, $localtlpdb);
+    if (ref $foo) {
+      # installation succeeded because we got a reference
+      merge_into (\%ret, $foo);
+      logpackage("update: $pkg ($rev -> $mediarev)");
+      unlink($unwind_package) if $remove_unwind_container;
+    } else {
+      # install_package returned a scalar, 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
+      logpackage("failed update: $pkg ($rev -> $mediarev)");
+      tlwarn("\n\nInstallation of new version of $pkg did fail, trying to unwind.\n");
+      if (win32()) {
+        # w32 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;
+        logpackage("restore: $pkg ($rev)");
+        tlwarn("Restoring old package state succeeded.\n");
+      } else {
+        logpackage("failed restore: $pkg ($rev)");
+        tlwarn("Restoring of old package did NOT succeed.\n");
+        tlwarn("Most likely repair: run tlmgr install $pkg and hope.\n");
+      }
+      unlink($unwind_package) if $remove_unwind_container;
+    }
+    info("done\n") unless $::machinereadable;
   }
-
-  # that already checks whether we actually have to do something
-  if (win32()) {
-    my $ret = write_w32_updater($opts{"dry-run"} || $opts{"list"}, @w32_updates);
+  
+  if (win32() && !$opts{"list"} && @w32_updated) {
+    info("Preparing TeX Live infrastructure update...\n");
+    my $ret = write_w32_updater(@w32_updated);
     tlwarn ("Aborting infrastructure update.\n") if ($ret);
   }
+  
   if (($nrupdated == 0) && ($tlmediasrc->media ne "NET") && $opts{"all"}) {
     # for all but net updates we warn if nothing is updated
     tlwarn("\nNothing to update.\n");