diff options
Diffstat (limited to 'Master/tlpkg/TeXLive/TLMedia.pm')
-rw-r--r-- | Master/tlpkg/TeXLive/TLMedia.pm | 615 |
1 files changed, 0 insertions, 615 deletions
diff --git a/Master/tlpkg/TeXLive/TLMedia.pm b/Master/tlpkg/TeXLive/TLMedia.pm deleted file mode 100644 index 2c3be124b4b..00000000000 --- a/Master/tlpkg/TeXLive/TLMedia.pm +++ /dev/null @@ -1,615 +0,0 @@ -# $Id$ -# TeXLive::TLMedia.pm - module for accessing TeX Live Media -# Copyright 2008, 2009, 2010 Norbert Preining -# This file is licensed under the GNU General Public License version 2 -# or any later version. - -package TeXLive::TLMedia; - -my $svnrev = '$Revision$'; -my $_modulerevision; -if ($svnrev =~ m/: ([0-9]+) /) { - $_modulerevision = $1; -} else { - $_modulerevision = "unknown"; -} -sub module_revision { - return $_modulerevision; -} - - -use TeXLive::TLConfig; -use TeXLive::TLUtils qw(copy win32 dirname mkdirhier basename download_file - merge_into debug ddebug info tlwarn log); -use TeXLive::TLPDB; -use TeXLive::TLWinGoo; - -sub new -{ - my ($class, @args) = @_; - # 0 elements -> -1 - # 1 arg -> 0 - # even args -> uneven - my $location; - my %params; - my $self = { }; - my $tlpdbfile; - if ($#args % 2) { - # even number of arguments, the first must be the location - %params = @args; - $location = $params{'-location'}; - $tlpdbfile = $params{'-tlpdbfile'}; - } else { - # odd number of arguments - $location = shift @args; - } - my $media; - # of no argument is given we assume NET and default URL - if (!defined($location)) { - return; - } - # no default by itself ... - # $location = "$TeXLiveURL" unless (defined($location)); - # do media autodetection - if ($location =~ m,http://|ftp://,) { - $media = 'NET'; - } else { - if ($location =~ m,file://*(.*)$,) { - $location = "/$1"; - } - if (-d "$location/texmf/web2c") { - $media = 'local_uncompressed'; - } elsif (-d "$location/$Archive") { - $media = 'local_compressed'; - } else { - # we cannot find the right type, return undefined, that should - # make people notice - return; - } - } - my $tlpdb; - if (defined($tlpdbfile)) { - # we got the tlpdb file for a specific location - debug("Loading TLPDB from $tlpdbfile for $location ...\n"); - $tlpdb = TeXLive::TLPDB->new; - if ($tlpdb->from_file($tlpdbfile)) { - # found a positive number of packages - $tlpdb->root($location); - } else { - # couldn't read from tlpdb - return(undef); - } - } else { - debug("Loading $location/$InfraLocation/$DatabaseName ...\n"); - $tlpdb = TeXLive::TLPDB->new(root => $location); - return(undef) unless defined($tlpdb); - } - my (@all_c, @std_c, @lang_c, @lang_doc_c); - my (@schemes); - my %revs; - foreach my $pkg ($tlpdb->list_packages) { - my $tlpobj = $tlpdb->{'tlps'}{$pkg}; - $revs{$tlpobj->name} = $tlpobj->revision; - if ($tlpobj->category eq "Collection") { - push @all_c, $pkg; - if ($pkg =~ /collection-lang/) { - push @lang_c, $pkg; - } elsif ($pkg =~ /documentation/) { - if ($pkg =~ /documentation-base/) { - push @std_c, $pkg; - } else { - push @lang_doc_c, $pkg; - } - } else { - push @std_c, $pkg; - } - } elsif ($tlpobj->category eq "Scheme") { - push @schemes, $pkg; - } - } - my (@systems); - @systems = $tlpdb->available_architectures; - $self->{'media'} = $media; - $self->{'location'} = $location; - $self->{'tlpdb'} = $tlpdb; - $self->{'release'} = $tlpdb->config_release; - @{ $self->{'all_collections'} } = @all_c; - @{ $self->{'std_collections'} } = @std_c; - @{ $self->{'lang_collections'} } = @lang_c; - @{ $self->{'lang_doc_collections'} } = @lang_doc_c; - @{ $self->{'schemes'} } = @schemes; - @{ $self->{'systems'} } = @systems; - %{ $self->{'pkgrevs'} } = %revs; - bless $self, $class; - return $self; -} - -# returns a scalar (0) on error -# returns a reference to a hash with actions on success -sub install_package { - my ($self, $pkg, $totlpdb, $nopostinstall, $fallbackmedia) = @_; - my $fromtlpdb = $self->tlpdb; - my $ret; - die("TLMedia not initialized, cannot find tlpdb!") unless (defined($fromtlpdb)); - my $tlpobj = $fromtlpdb->get_package($pkg); - if (!defined($tlpobj)) { - if (defined($fallbackmedia)) { - if ($ret = $fallbackmedia->install_package($pkg,$totlpdb, $nopostinstall)) { - debug("installed $pkg from fallback\n"); - return $ret; - } else { - tlwarn("$0: Cannot find package $pkg (in fallback, either)\n"); - return 0; - } - } else { - tlwarn("$0: Cannot find package $pkg\n"); - return 0; - } - } else { - my $container_src_split = $fromtlpdb->config_src_container; - my $container_doc_split = $fromtlpdb->config_doc_container; - # get options about src/doc splitting from $totlpdb - my $opt_src = $totlpdb->option("install_srcfiles"); - my $opt_doc = $totlpdb->option("install_docfiles"); - my $real_opt_doc = $opt_doc; - my $reloc = 1 if $tlpobj->relocated; - my $container; - my @installfiles; - my $location = $self->location; - # make sure that there is no terminal / in $location, otherwise we - # will get double // somewhere - $location =~ s!/$!!; - foreach ($tlpobj->runfiles) { - # s!^!$location/!; - push @installfiles, $_; - } - foreach ($tlpobj->allbinfiles) { - # s!^!$location/!; - push @installfiles, $_; - } - if ($opt_src) { - foreach ($tlpobj->srcfiles) { - # s!^!$location/!; - push @installfiles, $_; - } - } - if ($real_opt_doc) { - foreach ($tlpobj->docfiles) { - # s!^!$location/!; - push @installfiles, $_; - } - } - my $media = $self->media; - if ($media eq 'local_uncompressed') { - $container = \@installfiles; - } elsif ($media eq 'local_compressed') { - if (-r "$location/$Archive/$pkg.zip") { - $container = "$location/$Archive/$pkg.zip"; - } elsif (-r "$location/$Archive/$pkg.tar.xz") { - $container = "$location/$Archive/$pkg.tar.xz"; - } else { - tlwarn("Cannot find a package $pkg (.zip or .xz) in $location/$Archive\n"); - next; - } - } elsif (&media eq 'NET') { - $container = "$location/$Archive/$pkg.$DefaultContainerExtension"; - } - $self->_install_package ($container, $reloc, \@installfiles, $totlpdb) - || return(0); - # if we are installing from local_compressed 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 'local_compressed')) { - # we install split containers under the following conditions: - # - the container were split generated - # - src/doc files should be installed - # (- the package is not already a split one (like .i386-linux)) - # the above test has been removed because it would mean that - # texlive.infra.doc.tar.xz - # will never be installed, and we do already check that there - # are at all src/doc files, which in split packages of the form - # foo.ARCH are not present. And if they are present, than that is fine, - # too (bin-foobar.win32.doc.tar.xz) - # - there are actually src/doc files present - if ($container_src_split && $opt_src && $tlpobj->srcfiles) { - my $srccontainer = $container; - $srccontainer =~ s/(\.tar\.xz|\.zip)$/.source$1/; - $self->_install_package ($srccontainer, $reloc, \@installfiles, $totlpdb) - || return(0); - } - if ($container_doc_split && $real_opt_doc && $tlpobj->docfiles) { - my $doccontainer = $container; - $doccontainer =~ s/(\.tar\.xz|\.zip)$/.doc$1/; - $self->_install_package ($doccontainer, $reloc, \@installfiles, $totlpdb) - || return(0); - } - # - # if we installed from NET/local_compressed and we got a relocatable container - # make sure that the stray texmf-dist/tlpkg directory is removed - # in USER MODE that should NOT be done because we keep the information - # there, but for now do it unconditionally - if ($tlpobj->relocated) { - my $reloctree = $totlpdb->root . "/" . $TeXLive::TLConfig::RelocTree; - my $tlpkgdir = $reloctree . "/" . $TeXLive::TLConfig::InfraLocation; - my $tlpod = $tlpkgdir . "/tlpobj"; - TeXLive::TLUtils::rmtree($tlpod) if (-d $tlpod); - # we try to remove the tlpkg directory, that will succeed only - # if it is empty. So in normal installations it won't be, but - # if we are installing a relocated package it is texmf-dist/tlpkg - # which will be (hopefully) empty - rmdir($tlpkgdir) if (-d "$tlpkgdir"); - } - } - # we don't want to have wrong information in the tlpdb, so remove the - # src/doc files if they are not installed ... - if (!$opt_src) { - $tlpobj->clear_srcfiles; - } - if (!$real_opt_doc) { - $tlpobj->clear_docfiles; - } - # if a package is relocatable we have to cancel the reloc prefix - # and unset the relocated setting - # before we save it to the local tlpdb - if ($tlpobj->relocated) { - $tlpobj->cancel_reloc_prefix; - $tlpobj->relocated(0); - } - # we have to write out the tlpobj file since it is contained in the - # archives (.tar.xz) but at DVD install time we don't have them - my $tlpod = $totlpdb->root . "/tlpkg/tlpobj"; - mkdirhier( $tlpod ); - open(TMP,">$tlpod/".$tlpobj->name.".tlpobj") or - die("Cannot open tlpobj file for ".$tlpobj->name); - $tlpobj->writeout(\*TMP); - close(TMP); - $totlpdb->add_tlpobj($tlpobj); - $totlpdb->save; - # compute the return value - TeXLive::TLUtils::announce_execute_actions("enable", $tlpobj); - if (!$nopostinstall) { - # do the postinstallation actions - # - # Run the post installation code in the postaction tlpsrc entries - # in case we are on w32 and the admin did install for himself only - # we switch off admin mode - if (win32() && admin() && !$totlpdb->option("w32_multi_user")) { - non_admin(); - } - # for now desktop_integration maps to both installation - # of desktop shortcuts and menu items, but we can split them later - &TeXLive::TLUtils::do_postaction("install", $tlpobj, - $totlpdb->option("file_assocs"), - $totlpdb->option("desktop_integration"), - $totlpdb->option("desktop_integration"), - $totlpdb->option("post_code")); - } - } - return 1; -} - -# -# _install_package -# actually does the installation work -# returns 1 on success and 0 on error -# -sub _install_package { - my ($self, $what, $reloc, $filelistref, $totlpdb) = @_; - - my $media = $self->media; - my $target = $totlpdb->root; - my $tempdir = "$target/temp"; - - my @filelist = @$filelistref; - - # we assume that $::progs has been set up! - my $wget = $::progs{'wget'}; - my $xzdec = $::progs{'xzdec'}; - if (!defined($wget) || !defined($xzdec)) { - tlwarn("_install_package: programs not set up properly, strange.\n"); - return(0); - } - - if (ref $what) { - # we are getting a ref to a list of files, so install from DVD - my $location = $self->location; - foreach my $file (@$what) { - # @what is taken, not @filelist! - # is this still needed? - my $dn=dirname($file); - mkdirhier("$target/$dn"); - copy "$location/$file", "$target/$dn"; - } - # we always assume that copy will work - return(1); - } elsif ($what =~ m,\.tar(\.xz)?$,) { - my $type = defined($1) ? "xz" : "tar"; - - $target .= "/$TeXLive::TLConfig::RelocTree" if $reloc; - - # this is the case when we install from local_compressed or the NET, or a backup - # - # in all other cases we create temp files .tar.xz (or use the present - # one), xzdec them, and then call tar - - my $fn = basename($what); - my $pkg = $fn; - $pkg =~ s/\.tar(\.xz)?$//; - mkdirhier("$tempdir"); - my $tarfile; - my $remove_tarfile = 1; - if ($type eq "xz") { - my $xzfile = "$tempdir/$fn"; - $tarfile = "$tempdir/$fn"; $tarfile =~ s/\.xz$//; - my $xzfile_quote = $xzfile; - my $tarfile_quote = $tarfile; - my $target_quote = $target; - if (win32()) { - $xzfile =~ s!/!\\!g; - $xzfile_quote = "\"$xzfile\""; - $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, $xzfile) || (! -r $xzfile)) { - tlwarn("Downloading \n"); - tlwarn(" $what\n"); - tlwarn("did not succeed, please retry.\n"); - unlink($tarfile, $xzfile); - return(0); - } - } else { - # we are installing from local compressed files - # copy it to temp - copy($what, $tempdir); - } - debug("un-xzing $xzfile to $tarfile\n"); - system("$xzdec < $xzfile_quote > $tarfile_quote"); - if (! -f $tarfile) { - tlwarn("_install_package: Unpacking $xzfile failed, please retry.\n"); - unlink($tarfile, $xzfile); - return(0); - } - unlink($xzfile); - } else { - $tarfile = "$tempdir/$fn"; - if ($what =~ m,http://|ftp://,) { - if (!download_file($what, $tarfile) || (! -r $tarfile)) { - tlwarn("Downloading \n"); - tlwarn(" $what\n"); - tlwarn("failed, please retry.\n"); - unlink($tarfile); - return(0); - } - } else { - $tarfile = $what; - $remove_tarfile = 0; - } - } - my $ret = TeXLive::TLUtils::untar($tarfile, $target, $remove_tarfile); - # remove the $pkg.tlpobj, we recreate it anyway again - unlink ("$target/tlpkg/tlpobj/$pkg.tlpobj") - if (-r "$target/tlpkg/tlpobj/$pkg.tlpobj"); - return $ret; - } else { - tlwarn("_install_package: Don't know how to install $what\n"); - return(0); - } -} - -# -# remove_package removes a single package with all files (including the -# # tlpobj files) and the entry from the tlpdb. -sub remove_package { - my ($self, $pkg, %opts) = @_; - my $localtlpdb = $self->tlpdb; - my $tlp = $localtlpdb->get_package($pkg); - if (!defined($tlp)) { - tlwarn ("$pkg: package not present, cannot remove\n"); - } else { - my $currentarch = $self->platform(); - if ($pkg eq "texlive.infra" || $pkg eq "texlive.infra.$currentarch") { - log ("Not removing $pkg, it is essential!\n"); - return 0; - } - # we have to chdir to $localtlpdb->root - my $Master = $localtlpdb->root; - chdir ($Master) || die "chdir($Master) failed: $!"; - my @files = $tlp->all_files; - # also remove the .tlpobj file - push @files, "tlpkg/tlpobj/$pkg.tlpobj"; - # and the ones from src/doc splitting - if (-r "tlpkg/tlpobj/$pkg.source.tlpobj") { - push @files, "tlpkg/tlpobj/$pkg.source.tlpobj"; - } - if (-r "tlpkg/tlpobj/$pkg.doc.tlpobj") { - push @files, "tlpkg/tlpobj/$pkg.doc.tlpobj"; - } - # - # some packages might be relocated, thus having the RELOC prefix - # in user mode we just remove the prefix, in normal mode we - # replace it with texmf-dist - # since we don't have user mode - if ($tlp->relocated) { - for (@files) { - s:^$RelocPrefix/:$RelocTree/:; - } - } - # - # we want to check that a file is only listed in one package, so - # in case that a file to be removed is listed in another package - # we will warn and *not* remove it - my %allfiles; - for my $p ($localtlpdb->list_packages) { - next if ($p eq $pkg); # we have to skip the to be removed package - for my $f ($localtlpdb->get_package($p)->all_files) { - $allfiles{$f} = $p; - } - } - my @goodfiles = (); - my @badfiles = (); - my @debugfiles = (); - for my $f (@files) { - # in usermode we have to add texmf-dist again for comparison - if (defined($allfiles{$f})) { - # this file should be removed but is mentioned somewhere, too - # take into account if we got a warn list - if (defined($opts{'remove-warn-files'})) { - my %a = %{$opts{'remove-warn-files'}}; - if (defined($a{$f})) { - push @badfiles, $f; - } else { - # NO NOTHING HERE!!! - # DON'T PUSH IT ON @goodfiles, it will be removed, which we do - # NOT want. We only want to supress the warning! - push @debugfiles, $f; - } - } else { - push @badfiles, $f; - } - } else { - push @goodfiles, $f; - } - } - if ($#debugfiles >= 0) { - debug("The following files will not be removed due to the removal of $pkg.\n"); - debug("But we do not warn on it because they are moved to other packages.\n"); - for my $f (@debugfiles) { - debug(" $f - $allfiles{$f}\n"); - } - } - if ($#badfiles >= 0) { - # warn the user - tlwarn("The following files should be removed due to the removal of $pkg,\n"); - tlwarn("but are part of another package, too.\n"); - for my $f (@badfiles) { - tlwarn(" $f - $allfiles{$f}\n"); - } - } - # - # Run only the postaction code thing now since afterwards the - # files will be gone ... - if (defined($opts{'nopostinstall'}) && $opts{'nopostinstall'}) { - &TeXLive::TLUtils::do_postaction("remove", $tlp, - 0, # option_file_assocs, - 0, # option_desktop_integration, menu part - 0, # option_desktop_integration, desktop part - $localtlpdb->option("post_code")); - } - # - my @removals = &TeXLive::TLUtils::removed_dirs (@goodfiles); - # now do the removal - for my $entry (@goodfiles) { - unlink $entry; - } - for my $d (@removals) { - rmdir $d; - } - $localtlpdb->remove_package($pkg); - TeXLive::TLUtils::announce_execute_actions("disable", $tlp); - # should we save at each removal??? - # advantage: the tlpdb actually reflects what is installed - # disadvantage: removing a collection calls the save routine several times - # still I consider it better that the tlpdb is in a consistent state - $localtlpdb->save; - # - # Run the post installation code in the postaction tlpsrc entries - # in case we are on w32 and the admin did install for himself only - # we switch off admin mode - if (win32() && admin() && !$localtlpdb->option("w32_multi_user")) { - non_admin(); - } - # - # Run the post installation code in the postaction tlpsrc entries - # the postaction code part cannot be evaluated now since the - # files are already removed. - # Again, desktop integration maps to desktop and menu links - if (!$nopostinstall) { - &TeXLive::TLUtils::do_postaction("remove", $tlp, - $localtlpdb->option("file_assocs"), - $localtlpdb->option("desktop_integration"), - $localtlpdb->option("desktop_integration"), - 0); - } - } - return 1; -} - - -# member access functions -# -sub media { my $self = shift ; return $self->{'media'}; } -sub location { my $self = shift ; return $self->{'location'}; } -sub tlpdb { my $self = shift ; return $self->{'tlpdb'}; } -sub release { my $self = shift ; return $self->{'release'}; } -sub all_collections { my $self = shift; return @{ $self->{'all_collections'} }; } -sub std_collections { my $self = shift; return @{ $self->{'std_collections'} }; } -sub lang_collections { my $self = shift; return @{ $self->{'lang_collections'} }; } -sub lang_doc_collections { my $self = shift; return @{ $self->{'lang_doc_collections'} }; } -sub schemes { my $self = shift; return @{ $self->{'schemes'} }; } -sub systems { my $self = shift; return @{ $self->{'systems'} }; } - -# deduce the platform of the referenced media as follows: -# - if the $tlpdb->setting("platform") is there it overrides the detected -# setting -# - if it is not there call TLUtils::platform() -sub platform { - # try to deduce the platform - my $self = shift; - my $tlpdb = $self->tlpdb; - if (defined($tlpdb)) { - my $ret = $tlpdb->setting("platform"); - return $ret if defined $ret; - } - # the platform setting wasn't found in the tlpdb, try TLUtils::platform - return TeXLive::TLUtils::platform(); -} - -1; -__END__ - - -=head1 NAME - -C<TeXLive::TLMedia> -- TeX Live Media module - -=head1 SYNOPSIS - - use TeXLive::TLMedia; - - my $tlneo = TeXLive::TLMedia->new('http://www.ctan.org/mirror/tl/'); - my $tlcd = TeXLive::TLMedia->new('/mnt/tl-cd/'); - my $tldvd = TeXLive::TLMedia->new('/mnt/tl-dvd/'); - -=head1 DESCRIPTION - -missing - -=head1 MEMBER ACCESS FUNCTIONS - -scalars: media, location, tlpdb, release -lists: all_collections, std_collections, lang_collections, lang_doc_collections, -schemes, systems - -=head1 SEE ALSO - -The modules L<TeXLive::TLConfig>, L<TeXLive::TLUtils>, L<TeXLive::TLPOBJ>, -L<TeXLive::TLPDB>, L<TeXLive::TLTREE>. - -=head1 AUTHORS AND COPYRIGHT - -This script and its documentation were written for the TeX Live -distribution (L<http://tug.org/texlive>) and both are licensed under the -GNU General Public License Version 2 or later. - -=cut - -### Local Variables: -### perl-indent-level: 2 -### tab-width: 2 -### indent-tabs-mode: nil -### End: -# vim:set tabstop=2 expandtab: # |