summaryrefslogtreecommitdiff
path: root/Master
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2008-09-25 06:43:52 +0000
committerNorbert Preining <preining@logic.at>2008-09-25 06:43:52 +0000
commit4f03af4024357554412cfc7925e668e8365fd5df (patch)
treeb2c65aafede28f7b3c153d3720fea41c0ed2fd62 /Master
parent60a7a267a7b1e9179bb3866e4b8e65791ab5b25f (diff)
safer update for tlmgr (make tar before removing)
git-svn-id: svn://tug.org/texlive/trunk@10720 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master')
-rwxr-xr-xMaster/texmf/scripts/texlive/tlmgr.pl96
-rw-r--r--Master/tlpkg/TeXLive/TLMedia.pm113
-rw-r--r--Master/tlpkg/TeXLive/TLPOBJ.pm39
-rw-r--r--Master/tlpkg/TeXLive/TLUtils.pm21
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";