diff options
author | Norbert Preining <preining@logic.at> | 2008-03-29 14:28:19 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2008-03-29 14:28:19 +0000 |
commit | d4eedbeb6301b3ed03a6b6f703020f7dc5dcdc63 (patch) | |
tree | 2e75e7be0a5c8389343b511710f59c3e87dd65d9 /Master/tlpkg/TeXLive/TLMedia.pm | |
parent | 90c3bb4dc0c455df131af548a15d4cf875a86708 (diff) |
too many changes, see email, basically tl.-package-manager work
git-svn-id: svn://tug.org/texlive/trunk@7221 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/TeXLive/TLMedia.pm')
-rw-r--r-- | Master/tlpkg/TeXLive/TLMedia.pm | 420 |
1 files changed, 420 insertions, 0 deletions
diff --git a/Master/tlpkg/TeXLive/TLMedia.pm b/Master/tlpkg/TeXLive/TLMedia.pm new file mode 100644 index 00000000000..8d38ff3c184 --- /dev/null +++ b/Master/tlpkg/TeXLive/TLMedia.pm @@ -0,0 +1,420 @@ +# $Id: TLMedia.pm 6947 2008-03-13 00:40:12Z karl $ +# TeXLive::TLMedia.pm - module for accessing TeX Live Media +# Copyright 2008 Norbert Preining +# +# This file is licensed under the GNU General Public License version 2 +# or any later version. +# + +package TeXLive::TLMedia; + +use TeXLive::TLConfig; +use TeXLive::TLUtils qw(tllog copy win32 dirname mkdirhier conv_to_win_path basename); +use TeXLive::TLPDB; +use Cwd qw/abs_path/; + +sub shortnew +{ + my ($class, $location) = @_; + my $media; + # of no argument is given we assume NET and default URL + $location = "$TeXLiveURL" unless (defined($location)); + # do media autodetection + if ($location =~ m,http://|ftp://,) { + $media = 'NET'; + } else { + if (-d "$location/texmf/web2c") { + $media = 'DVD'; + } elsif (-d "$location/$DiskArchive") { + $media = 'CD'; + } else { + die ("Cannot find the correct media for $location, please specify!"); + } + } + my $database; + if ($media eq 'NET') { + $database = "$location/$NetArchive/texlive.pkgver"; + open(WGET, "wget -q --output-document=- $database|") or + tllog($::LOG_NORMAL, "Cannot get texlive.pkgver the net!\n"); + } elsif ($media eq 'CD') { + $database = "$location/$DiskArchive/texlive.pkgver"; + open(WGET, "<$database") or + tllog($::LOG_NORMAL, "Cannot get texlive.pkgver from CD!\n"); + } else { + $database = "$location/$InfraLocation/texlive.pkgver"; + open(WGET, "<$database") or + tllog($::LOG_NORMAL, "Cannot get texlive.pkgver from DVD!\n"); + } + my %revs; + my @platforms; + while (<WGET>) { + chop; + my $line=$_; + my ($pkg, $rev) = split " ", $line; + $revs{$pkg} = $rev; + if ($rev == -1) { + push @platforms, $pkg; + } + } + $self->{'media'} = $media; + $self->{'location'} = $location; + %{ $self->{'pkgrevs'} } = %revs; + @{ $self->{'systems'} } = @platforms; + bless $self, $class; + return $self; +} + +sub new +{ + my ($class, $location) = @_; + my $media; + # of no argument is given we assume NET and default URL + $location = "$TeXLiveURL" unless (defined($location)); + # do media autodetection + if ($location =~ m,http://|ftp://,) { + $media = 'NET'; + } else { + if (-d "$location/texmf/web2c") { + $media = 'DVD'; + } elsif (-d "$location/$DiskArchive") { + $media = 'CD'; + } else { + die ("Cannot find the correct media for $location, please specify!"); + } + } + tllog($::LOG_DEBUG, "Loading $location/$InfraLocation/$DatabaseName ...\n"); + my $tlpdb = TeXLive::TLPDB->new(root => "$location"); + 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 0 for error +# otherwise a bitmap which specifies what commands have to be run +# always: 0x0001 mktexlsr +# addMap: 0x0010 updmap-sys +# BuildFormat: 0x0100 fmtutil-sys --missing +# BuildLanguageDat: 0x1000 fmtutil-sys --by-hyphen language.dat +# +sub install_package { + my ($self, $pkg, $totlpdb, $nodepends, $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)) { + tllog($::LOG_DEBUG, "installed $pkg from fallback"); + return $ret; + } else { + tllog($::LOG_NORMAL, "couldn't find $pkg"); + return 0; + } + } else { + tllog($::LOG_NORMAL, "couldn't find $pkg"); + 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_srcfiles; + my $opt_doc = $totlpdb->option_docfiles; + tllog($::LOG_NORMAL, "Installing: $pkg\n"); + foreach my $h (@::install_packages_hook) { + &$h("Installing: $package"); + } + my $container; + my @installfiles; + my $location = $self->location; + 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 ($opt_doc) { + foreach ($tlpobj->docfiles) { + s!^!$location/!; + push @installfiles, $_; + } + } + my $media = $self->media; + if ($media eq 'DVD') { + $container = \@installfiles; + } elsif ($media eq 'CD') { + if (-r "$location/$DiskArchive/$pkg.zip") { + $container = "$location/$DiskArchive/$pkg.zip"; + } elsif (-r "$location/$DiskArchive/$pkg.tar.lzma") { + $container = "$location/$DiskArchive/$pkg.tar.lzma"; + } else { + # for now only warn and return, should (?) be die!? + warn "Cannot find a package $pkg (.zip or .lzma) in $location/$DiskArchive\n"; + next; + } + } elsif (&media eq 'NET') { + $container = "$location/$NetArchive/$pkg.$DefaultContainerExtension"; + } + $self->_install_package($container,\@installfiles,$totlpdb); + # 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')) { + # 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) + # - there are actually src/doc files present + if ($container_src_split && $opt_src && + ($pkg !~ m/\./) && $tlpobj->srcfiles) { + my $srccontainer = $container; + $srccontainer =~ s/(.tar.lzma|.zip)/.source$1/; + $self->_install_package($srccontainer,\@installfiles,$totlpdb); + } + if ($container_doc_split && $opt_doc && + ($pkg !~ m/\./) && $tlpobj->docfiles) { + my $doccontainer = $container; + $doccontainer =~ s/(.tar.lzma|.zip)/.doc$1/; + $self->_install_package($doccontainer,\@installfiles,$totlpdb); + } + } + # 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 (!$opt_doc) { + $tlpobj->clear_docfiles; + } + $totlpdb->add_tlpobj($tlpobj); + $totlpdb->save; + # compute the return value + $ret |= 0x0001; # mktexlsr + foreach my $e ($tlpobj->executes) { + if ($e =~ m/^add/) { + $ret |= 0x0010; + } elsif ($e =~ m/^BuildFormat/) { + $ret |= 0x0100; + } elsif ($e =~ m/^BuildLanguageDat/) { + $ret |= 0x1000; + } else { + warn("Unknown execute $e in $pkg"); + } + } + # now install all the depends if they are not already present + if (!$nodepends) { + foreach my $d ($tlpobj->depends) { + if ($d =~ m/^(.*)\.ARCH$/) { + my $foo = $1; + foreach my $a ($totlpdb->available_architectures) { + if (!defined($totlpdb->get_package("$foo.$a"))) { + $ret |= $self->install_package("$foo.$a", $totlpdb, $nodepends, $fallbackmedia); + } + } + } elsif ($d =~ m/^(.*).win32$/) { + # install only of win32 is under the available archs + if (TeXLive::TLUtils::member("win32",$totlpdb->available_architectures)) { + $ret |= $self->install_package($d, $totlpdb, $nodepends, $fallbackmedia); + } + } else { + if (!defined($totlpdb->get_package($d))) { + # we have to install it! + $ret |= $self->install_package($d, $totlpdb, $nodepends, $fallbackmedia); + } + } + } + } + return $ret; + } +} + +sub _install_package { + sub mysystem { + my $cmd = shift; + # print "DEBUG: $cmd\n"; + system("$cmd"); + } + my ($self, $what, $filelistref, $totlpdb) = @_; + my $buffer; + my $offset; + my $blocksize=2048; + my $media = $self->media; + my $target = $totlpdb->root; + + $blocksize=4096 if ($media eq 'NET'); + + my @filelist = @$filelistref; + + my $bindir = "$target/tlpkg/installer"; + my $platform = $totlpdb->option_platform; + # unix defaults + my $wget = "wget"; + my $lzmadec = "$bindir/lzmadec.$platform"; + my $tar = "tar"; + if (win32()) { + $wget = conv_to_win_path("$bindir/wget.exe"); + #$tar = conv_to_win_path("$bindir/bsdtar.exe"); + # try Akira's tar.exe + $tar = conv_to_win_path("$bindir/tar.exe"); + $lzmadec = conv_to_win_path("$lzmadec"); + $target =~ s!/!\\!g; + } + if (ref $what) { + # we are getting a ref to a list of files, so install from DVD + foreach my $file (@$what) { + # @what is taken, not @filelist! + # is this still needed? + my $dn=dirname($file); + mkdirhier("$target/$dn"); + copy "$file", "$target/$dn"; + } + } elsif ($what =~ m,http://|ftp://,) { + # we are installing from the NET + # currently the list of file @filelist is NOT EVALUATED!!! + if (win32()) { + # we need temporary files here + # tmpdir is $target/temp + my $fn = basename($what); + my $tarfile = $fn; + $tarfile =~ s/\.lzma$//; + mkdirhier("$target/temp"); + tllog($::LOG_DEBUG, "Downloading $what to $target\\temp\\$fn\n"); + tllog($::LOG_DEBUG, `$wget --tries=2 --timeout=60 -q -O \"$target\\temp\\$fn\" \"$what\" 2>\&1`); + tllog($::LOG_DEBUG, "Un-lzmaing $target\\temp\\$fn to $target\\temp\\$tarfile\n"); + #tllog($::LOG_DEBUG, `type \"$target\\temp\\$fn\" | $lzmadec > \"$target\\temp\\$tarfile\" 2>&1`); + tllog($::LOG_DEBUG, `$lzmadec < \"$target\\temp\\$fn\" > \"$target\\temp\\$tarfile\" 2>&1`); + tllog($::LOG_DEBUG, "Unpacking temp\\$tarfile\n"); + tllog($::LOG_DEBUG, `pushd \"$target\" & $tar -xf \"temp\\$tarfile\" 2>&1`); + unlink("$target/temp/$tarfile", "$target/temp/$fn"); + } else { + tllog($::LOG_DEBUG, "downloading/unlzma-ing/unpacking $what\n"); + tllog($::LOG_NORMAL, `$wget --tries=2 --timeout=60 -q -O- \"$what\"|\"$lzmadec\"|$tar -xf - -C \"$target\"`); + } + } elsif ($what =~ m,\.tar.lzma$,) { + if (win32()) { + my $fn = basename($what); + my $tarfile = $fn; + $tarfile =~ s/\.lzma$//; + mkdirhier("$target/temp"); + tllog($::LOG_DEBUG, "Un-lzmaing $what to $target\\temp\\$tarfile\n"); + tllog($::LOG_DEBUG, `$lzmadec < \"$what\" > \"$target\\temp\\$tarfile\" 2>&1`); + tllog($::LOG_DEBUG, "Unpacking temp\\$tarfile\n"); + tllog($::LOG_DEBUG, `pushd \"$target\" & $tar -xf \"temp\\$tarfile\" 2>&1`); + unlink("$target/temp/$tarfile"); + } else { + tllog($::LOG_DEBUG, "downloading/unlzma-ing/unpacking $what\n"); + tllog($::LOG_DEBUG, `cat \"$what\"|\"$lzmadec\"|$tar -xf - -C \"$target\" 2>&1`); + } + } else { + die "Don't know how to install $what!\n"; + } +} + + + +# 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'} }; } + +1; + + +__END__ + + +=head1 NAME + +C<TeXLive::TLMedia> -- TeX Live Media module + +=head1 SYNOPSIS + + use TeXLive::TLMedia; + + my $tlnet = TeXLive::TLMedia->new('NET'); + my $tlneo = TeXLive::TLMedia->new('NET','http://www.ctan.org/mirror/tl/'); + my $tlcd = TeXLive::TLMedia->new('CD','/mnt/tl-cd/'); + my $tldvd = TeXLive::TLMedia->new('DVD','/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 + +=back + +=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: # |