rollback implementation, needs testings and polishing. worked on linux

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

3 files changed, 124 insertions, 163 deletions

diff --git a/Master/texmf/scripts/texlive/tlmgr.pl b/Master/texmf/scripts/texlive/tlmgr.pl
index 81e70769f07..7ff7ce90d98 100755
--- a/Master/texmf/scripts/texlive/tlmgr.pl
+++ b/Master/texmf/scripts/texlive/tlmgr.pl
@@ -475,19 +475,13 @@ sub action_update {
         # this way we get rid of useless files
         # force the deinstallation since we will reinstall it
         if ($opt_rollback) {
-          printf STDERR "rollback not implemented by now!!!\n";
-          if (0) {
           if (! -d $opt_rollback) {
             printf STDERR "rollback argument must be an existing directory!\n";
           } else {
-            # TODO TODO TODO
-            # we need to change TLPOBJ so that it uses the same style
-            # as TLMedia with $::progs etc etc etc !!!!!!!!!!!!!!!!!
             my $tlp = $localtlpdb->get_package($pkg);
             $tlp->make_container("lzma", $localtlpdb->root, 
-                               $opt_rollback, "${pkg}_" . $tlp->revision);
-            }
-          } # if 0, must be removed later
+                                 $opt_rollback, "${pkg}_rev" . $tlp->revision);
+          }
         }
         merge_into(\%ret, &remove_package($pkg, $localtlpdb, 1));
         merge_into(\%ret, $tlmediasrc->install_package($pkg, $localtlpdb, $opt_nodepends, 1));
diff --git a/Master/tlpkg/TeXLive/TLPOBJ.pm b/Master/tlpkg/TeXLive/TLPOBJ.pm
index 09fad0aafd5..5866dca2e51 100644
--- a/Master/tlpkg/TeXLive/TLPOBJ.pm
+++ b/Master/tlpkg/TeXLive/TLPOBJ.pm
@@ -375,160 +375,118 @@ sub writeout_simple {
   }
 }
 
-###################################################
-## OLD IMPLEMENTATION WITHOUT binfiles packaging split
-## where we generate the $name.$arch packages automatically
-##
-## sub make_container {
-##   my ($self,$type,$instroot,$destdir,$containername,$relative) = @_;
-##   if (not(defined($containername))) {
-##     $containername = $self->name;
-##   }
-##   if (not(defined($destdir))) {
-##     $destdir = TeXLive::TLPOBJ->containerdir;
-##   }
-##   die("Undefined instroot argument!") if (not(defined($instroot)));
-##   # first build the arch independent part
-##   $self->_make_container($type,$instroot,$destdir,$containername,$relative,"all");
-##   # now the $pkg.$arch.zip
-##   if ($self->is_arch_dependent) {
-##     foreach my $t (keys %{$self->{'binfiles'}}) {
-##       &TeXLive::TLUtils::debug("arch=$t");
-##       $self->_make_container($type,$instroot,$destdir,"$containername.$t",$relative,$t);
-##     }
-##   }
-## }
-## 
-## sub _make_container {
-##   my ($self,$type,$instroot,$destdir,$containername,$relative,$arch) = @_;
-##   my @files = ();
-##   my $compresscmd;
-##   my $tlpobjdir = "$InfraLocation/tlpobj";
-##   if ($arch ne "all") {
-##     push @files, @{$self->{'binfiles'}{$arch}};
-##   } else {
-##     push @files, $self->runfiles;
-##     push @files, $self->docfiles;
-##     push @files, $self->srcfiles;
-##   }
-##   # note that the Tpm.pm module had something like
-##   #   if ($zipname =~ /\/binary/ && $^O !~ /MSWin32/) {
-##   #     $zipcmd = "| zip -9\@ory "
-##   #   } else {
-##   #     $zipcmd = "| zip -9\@or "
-##   #   }
-##   if ($^O =~ /MSWin32/) {
-##     $nul = "nul";
-##   } else {
-##     $nul = "/dev/null";
-##   }
-##   @files = TeXLive::TLUtils::sort_uniq(@files);
-##   if (!@files) {
-##     &TeXLive::TLUtils::debug("Not creating empty container file for $containername");
-##     return;
-##   }
-##   # we do relative packages ONLY if the files do NOT span multiple
-##   # texmf trees. check this here
-##   my $tltree;
-##   if ($relative) {
-##     foreach (@files) {
-##       my $tmp;
-##       ($tmp) = split m@/@;
-##       if (defined($tltree) && ($tltree ne $tmp)) {
-##         die "Not generating relative package for multiple tree spanning packages!\n";
-##       } else {
-##         $tltree = $tmp;
-##       }
-##     }
-##     my @nf;
-##     map { s@^$tltree/@@ ; push @nf, $_; } @files;
-##     @files = @nf;
-##   }
-##   my $cwd = &getcwd;
-##   if ("$destdir" !~ m@^/@) {
-##     # we have an relative containerdir, so we have to make it absolute
-##     $destdir = "$cwd/$destdir";
-##   }
-##   &mkpath("$destdir") if (! -d "$destdir");
-##   chdir($instroot);
-##   # in the relative case we have to chdir to the respective tltree
-##   # and put the tlpobj into the root!
-##   if ($relative) { 
-##     chdir("./$tltree");
-##     $tlpobjdir = ".";
-##   }
-##   if ($arch eq "all") {
-##     # we add the .tlpobj into the .tlpobj directory
-##     my $removetlpobjdir = 0;
-##     if (! -d "$tlpobjdir") {
-##       &mkpath("$tlpobjdir");
-##       $removetlpobjdir = 1;
-##     }
-##     open(TMP,">$tlpobjdir/$self->{'name'}.tlpobj") or die "Cannot create $tlpobjdir/$self->{'name'}.tlpobj";
-##     $self->writeout(\*TMP);
-##     close(TMP);
-##     push @files, "$tlpobjdir/$self->{'name'}.tlpobj";
-##   }
-##   if ($type eq "zip") {
-##     $containername .= ".zip";
-##       if ($^O =~ /MSWin32/) {
-##       $compresscmd = "| zip -9\@or $destdir/$containername > $nul"
-##     } else {
-##       $compresscmd = "| zip -9\@ory $destdir/$containername > $nul"
-##     }
-##   } elsif ($type eq "lzma") {
-##     $containername .= ".tar.lzma";
-##     $compresscmd = "| tar --create --files-from=-  | lzma -c > $destdir/$containername ";
-##   } else {
-##     die("Container method $type unknown!\n");
-##   }
-##   unlink("$destdir/$containername");
-##   print "$compresscmd\n" if ($::opt_debug);
-##   open ZIP, $compresscmd ;
-##   map {
-##     if (! -f $_) {
-##       print STDERR "!!!Error: non-existent $_\n";
-##     } else {
-##       print ZIP "$_\n";
-##     }
-##   } @files;
-##   close ZIP;
-##   if ($arch eq "all") {
-##     # cleaning up
-##     unlink("$tlpobjdir/$self->{'name'}.tlpobj");
-##     rmdir("$tlpobjdir") if $removetlpobjdir;
-##   }
-##   chdir($cwd);
-##   print "Done $containername\n" if ($::opt_debug);
-## }
-#######################################################
+### 
+### OLD VERSION WITH zip SUPPORT AND WITHOUT USING $::progs
+### sub make_container {
+###   my ($self,$type,$instroot,$destdir,$containername,$relative) = @_;
+###   my @files = ();
+###   my $compresscmd;
+###   my $tlpobjdir = "$InfraLocation/tlpobj";
+###   my %binf = %{$self->{'binfiles'}};
+###   foreach (keys %binf) {
+###     push @files, @{$binf{$_}};
+###   }
+###   push @files, $self->runfiles;
+###   push @files, $self->docfiles;
+###   push @files, $self->srcfiles;
+###   if ($^O =~ /MSWin32/) {
+###     $nul = "nul";
+###   } else {
+###     $nul = "/dev/null";
+###   }
+###   @files = TeXLive::TLUtils::sort_uniq(@files);
+###   # we do relative packages ONLY if the files do NOT span multiple
+###   # texmf trees. check this here
+###   my $tltree;
+###   if ($relative) {
+###     foreach (@files) {
+###       my $tmp;
+###       ($tmp) = split m@/@;
+###       if (defined($tltree) && ($tltree ne $tmp)) {
+###         die "Not generating relative package for multiple tree spanning packages!\n";
+###       } else {
+###         $tltree = $tmp;
+###       }
+###     }
+###     my @nf;
+###     map { s@^$tltree/@@ ; push @nf, $_; } @files;
+###     @files = @nf;
+###   }
+###   # load Cwd only if necessary ...
+###   require Cwd;
+###   my $cwd = &Cwd::getcwd;
+###   if ("$destdir" !~ m@^/@) {
+###     # we have an relative containerdir, so we have to make it absolute
+###     $destdir = "$cwd/$destdir";
+###   }
+###   &TeXLive::TLUtils::mkdirhier("$destdir");
+###   chdir($instroot);
+###   # in the relative case we have to chdir to the respective tltree
+###   # and put the tlpobj into the root!
+###   if ($relative) { 
+###     chdir("./$tltree");
+###     $tlpobjdir = ".";
+###   }
+###   # we add the .tlpobj into the .tlpobj directory
+###   my $removetlpobjdir = 0;
+###   if (! -d "$tlpobjdir") {
+###     &TeXLive::TLUtils::mkdirhier("$tlpobjdir");
+###     $removetlpobjdir = 1;
+###   }
+###   open(TMP,">$tlpobjdir/$self->{'name'}.tlpobj") or die "Cannot create $tlpobjdir/$self->{'name'}.tlpobj";
+###   $self->writeout(\*TMP);
+###   close(TMP);
+###   push @files, "$tlpobjdir/$self->{'name'}.tlpobj";
+###   if ($type eq "zip") {
+###     $containername .= ".zip";
+###       if ($^O =~ /MSWin32/) {
+###       $compresscmd = "| zip -9\@or $destdir/$containername > $nul"
+###     } else {
+###       $compresscmd = "| zip -9\@ory $destdir/$containername > $nul"
+###     }
+###   } elsif ($type eq "lzma") {
+###     $containername .= ".tar.lzma";
+###     $compresscmd = "| tar --create --files-from=-  | lzma -c > $destdir/$containername ";
+###   } else {
+###     die("Container method $type unknown!\n");
+###   }
+###   unlink("$destdir/$containername");
+###   tllog($::LOG_DDDEBUG, "$compresscmd\n");
+###   open ZIP, $compresscmd or die "Cannot open container program $compresscmd: $!\n";
+###   map {
+###     if (! -f $_) {
+###       print STDERR "!!!Error: non-existent $_\n";
+###     } else {
+###       print ZIP "$_\n";
+###     }
+###   } @files;
+###   close ZIP;
+###   # cleaning up
+###   unlink("$tlpobjdir/$self->{'name'}.tlpobj");
+###   rmdir("$tlpobjdir") if $removetlpobjdir;
+###   chdir($cwd);
+###   tllog($::LOG_DDDEBUG, "Done $containername\n");
+### }
+### 
 
 sub make_container {
   my ($self,$type,$instroot,$destdir,$containername,$relative) = @_;
+  if ($type ne "lzma") {
+    die("TLPOBJ currently supports only lzma containers");
+  }
+  if (!defined($containername)) {
+    $containername = $self->name;
+  }
   my @files = ();
   my $compresscmd;
   my $tlpobjdir = "$InfraLocation/tlpobj";
   my %binf = %{$self->{'binfiles'}};
-  if (!defined($containername)) {
-    $containername = $self->name;
-  }
   foreach (keys %binf) {
     push @files, @{$binf{$_}};
   }
   push @files, $self->runfiles;
   push @files, $self->docfiles;
   push @files, $self->srcfiles;
-  # note that the Tpm.pm module had something like
-  #   if ($zipname =~ /\/binary/ && $^O !~ /MSWin32/) {
-  #     $zipcmd = "| zip -9\@ory "
-  #   } else {
-  #     $zipcmd = "| zip -9\@or "
-  #   }
-  if ($^O =~ /MSWin32/) {
-    $nul = "nul";
-  } else {
-    $nul = "/dev/null";
-  }
   @files = TeXLive::TLUtils::sort_uniq(@files);
   # we do relative packages ONLY if the files do NOT span multiple
   # texmf trees. check this here
@@ -572,22 +530,24 @@ sub make_container {
   $self->writeout(\*TMP);
   close(TMP);
   push @files, "$tlpobjdir/$self->{'name'}.tlpobj";
-  if ($type eq "zip") {
-    $containername .= ".zip";
-      if ($^O =~ /MSWin32/) {
-      $compresscmd = "| zip -9\@or $destdir/$containername > $nul"
-    } else {
-      $compresscmd = "| zip -9\@ory $destdir/$containername > $nul"
-    }
-  } elsif ($type eq "lzma") {
-    $containername .= ".tar.lzma";
-    $compresscmd = "| tar --create --files-from=-  | lzma -c > $destdir/$containername ";
-  } else {
-    die("Container method $type unknown!\n");
+  $tarname = "$containername.tar";
+  $containername = "$tarname.lzma";
+
+  # start the whole fun
+  my $tar = $::progs{'tar'};
+  my $lzma = $::progs{'lzma'};
+  if (!defined($tar)) {
+    tllog($::LOG_NORMAL, "Programs have not been set up, trying with \"tar\"!\n");
+    $tar = "tar";
   }
+  if (!defined($lzma)) {
+    tllog($::LOG_NORMAL, "Programs have not been set up, trying with \"lzma\"!\n");
+    $lzma = "lzma";
+  }
+  my @cmdline = ($tar, "-c", "-f", "$destdir/$tarname", "--files-from=-");
   unlink("$destdir/$containername");
-  tllog($::LOG_DDDEBUG, "$compresscmd\n");
-  open ZIP, $compresscmd or die "Cannot open container program $compresscmd: $!\n";
+  unlink("$destdir/$tarname");
+  open ZIP, "|-", @cmdline or die "Cannot open container program @cmdline: $!";
   map {
     if (! -f $_) {
       print STDERR "!!!Error: non-existent $_\n";
@@ -596,6 +556,11 @@ sub make_container {
     }
   } @files;
   close ZIP;
+  if (-r "$destdir/$tarname") {
+    system($lzma, "--force", "-z", "$destdir/$tarname");
+  } else {
+    warn("Couldn't find $destdir/$tarname");
+  }
   # cleaning up
   unlink("$tlpobjdir/$self->{'name'}.tlpobj");
   rmdir("$tlpobjdir") if $removetlpobjdir;
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index 0e4ff4713a0..9bf03ad6b8e 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -707,11 +707,13 @@ sub setup_programs {
     $platform = platform();
   }
   $::progs{'lzmadec'} = "$bindir/lzmadec.$platform";
+  $::progs{'lzma'} = "$bindir/lzma.$platform";
   $::progs{'tar'} = "tar";
   if (win32()) {
     $::progs{'wget'}    = conv_to_win_path("$bindir/wget.exe");
     $::progs{'tar'}     = conv_to_win_path("$bindir/tar.exe");
     $::progs{'lzmadec'} = conv_to_win_path($::progs{'lzmadec'});
+    $::progs{'lzma'}    = conv_to_win_path($::progs{'lzma'});
   }
 }