path: root/Master/tlpkg/TeXLive/TLMedia.pm

# $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 download_file);
use TeXLive::TLPDB;
use Cwd qw/abs_path/;

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 {
  my ($self, $what, $filelistref, $totlpdb) = @_;

  my $media = $self->media;
  my $target = $totlpdb->root;

  my @filelist = @$filelistref;

  # we assume that $::progs has been set up!
  my $wget = $::progs{'wget'};
  my $lzmadec = $::progs{'lzmadec'};
  my $tar = $::progs{'tar'};
  if (!defined($wget) || !defined($lzmadec) || !defined($tar)) {
    die "Programs have not been set up properly, strange!";
  }

  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,\.tar.lzma$,) {
    # this is the case when we install from CD or the NET
    #
    # 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!";
      }
    } else {
      # we are installing from CD
      # copy it to temp
      copy($what, "$target/temp");
    }
    tllog($::LOG_DEBUG, "Un-lzmaing $lzmafile to $tarfile\n");
    system("$lzmadec < $lzmafile_quote > $tarfile_quote");
    if (! -f $tarfile) {
      die "Unpacking $lzmafile did not succeed, please retry!";
    }
    tllog($::LOG_DEBUG, "Unpacking $tarfile\n");
    system($tar,"-x","-C",$target,"-f",$tarfile);
    unlink($tarfile, $lzmafile);
  } 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: #