summaryrefslogtreecommitdiff
path: root/Master/tlpkg/TeXLive/TLMedia.pm
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2008-03-29 14:28:19 +0000
committerNorbert Preining <preining@logic.at>2008-03-29 14:28:19 +0000
commitd4eedbeb6301b3ed03a6b6f703020f7dc5dcdc63 (patch)
tree2e75e7be0a5c8389343b511710f59c3e87dd65d9 /Master/tlpkg/TeXLive/TLMedia.pm
parent90c3bb4dc0c455df131af548a15d4cf875a86708 (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.pm420
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: #