# $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 () { 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; } # we have to write out the tlpobj file since it is contained in the # archives (.tar.lzma) 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 $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 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"; } } 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 -- 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, L, L, L, L. =head1 AUTHORS AND COPYRIGHT This script and its documentation were written for the TeX Live distribution (L) 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: #