path: root/Master/tlpkg/bin/tl-update-containers

#!/usr/bin/env perl
# $Id: tl-update-containers 5188 2007-10-14 20:32:44Z karl $
# Copyright 2008 Norbert Preining
# This file is licensed under the GNU General Public License version 2
# or any later version.
# 
# Generate archive file(s) for the packages specified on the cmdline
# (doesn't really work, not documented), or all if none specified.

BEGIN {
  $^W = 1;
  ($mydir = $0) =~ s,/[^/]*$,,;
  unshift (@INC, "$mydir/..");
}

use strict;

use TeXLive::TLConfig;
use TeXLive::TLPOBJ;
use TeXLive::TLPDB;
use TeXLive::TLUtils;
use Getopt::Long;
use Pod::Usage;
use File::Path;

our $mydir;
my $opt_location = ".";
my $opt_relative = 0;
my $opt_recreate = 0;
my $help = 0;

TeXLive::TLUtils::process_logging_options();
GetOptions(
  "location=s"     => \$opt_location, 
  "recreate"       => \$opt_recreate,
  "help|?"         => \$help) or pod2usage(1);

pod2usage(-exitstatus => 0, -verbose => 2) if $help;

exit (&main ());

sub main
{
  # get the db.
  chomp(my $Master = `cd $mydir/../.. && pwd`);  # xx TLPDB should default
  my $tlpdb = TeXLive::TLPDB->new("root" => $Master);
  die "cannot find tlpdb in $Master" unless defined($tlpdb);
  my @packs = @ARGV ? @ARGV : $tlpdb->list_packages;

  # get configuration of package splitting
  my $srcsplit = $tlpdb->config_src_container;
  my $docsplit = $tlpdb->config_doc_container;
  my $format = $tlpdb->config_container_format;
  my $type = "lzma";
  if (($format eq "lzma") || ($format eq "zip")) {
    $type = $format;
  } else {
    warn "$0: unknown container format specified in 00texlive.config: $format"
         . "; ignoring and continuing with $type";
  }

  debug("format=$type srcsplit=$srcsplit docsplit=$docsplit\n");

  my @todopacks = ();
  my @removepacks = ();
  my $opt_containerdir = "$opt_location/$TeXLive::TLConfig::Archive";
  my %count;
  my $nettlpdb;

  if ($opt_recreate) {
    # remake everything.
    @todopacks = $tlpdb->list_packages();
    $nettlpdb = $tlpdb->copy;
    $nettlpdb->root($opt_location);

  } else {
    $nettlpdb = TeXLive::TLPDB->new(root => $opt_location);
    if (!defined($nettlpdb)) {
      die "Cannot init tlpdb from $opt_location ...";
    }
    my %archiverevs;
    foreach my $pkg ($nettlpdb->list_packages()) {
      $archiverevs{$pkg} = $nettlpdb->get_package($pkg)->revision();
      if (!defined($tlpdb->get_package($pkg))) {
        # $pkg has disappeared, removing it
        push @removepacks, $pkg;
      }
    }

    # collect packages to be updated.
    $count{"new"} = $count{"removed"} = $count{"updated"} = $count{"unchanged"}
                  = 0;
 
    for my $pkg (@packs) {
      # by definition, any 00texlive... package does not need containers.
      next if $pkg =~ /00texlive.*\./;
      my $oldrev = 0;
      if (-r "$opt_containerdir/$pkg.tar.$type"
          && defined($archiverevs{$pkg})) {
        $oldrev = $archiverevs{$pkg};
      } else {
        info("$pkg is new, found no containers\n");
        $count{"new"}++;
      }

      my $tlp = $tlpdb->get_package($pkg);
      my $newrev = 0;
      if (defined($tlp)) {
        $newrev = $tlp->revision;
      } else {
        # that cannot happen!!! we are looping over the packages of
        # $tlpdb so the above ->get_package will succeed (or something
        # stranged happened!
        die ("Huu, that should not happen ...");
      }

      if ($oldrev == $newrev) {
        debug("$pkg up to date\n");
        $count{"unchanged"}++;
      } elsif ($oldrev < $newrev) {
        push @todopacks, $pkg;
        $count{"updated"}++ if $oldrev;
      } else {
        warn "This shouldn't happen!  The revision of $pkg in texlive.tlpdb"
            . "($newrev) is OLDER than the one in"
            . "$opt_location/tlpkg/texlive.tlpdb ($oldrev)";
        push @todopacks, $pkg;
      }
    }
  }

  # set up the programs ...
  &TeXLive::TLUtils::setup_programs("$Master/tlpkg/installer");

  # get list of packages.
  for my $pkg (sort @todopacks) {
    next if ($pkg eq "00texlive.config");
    next if ($pkg eq "00texlive.installer");
    my $obj = $tlpdb->get_package ($pkg);
    die "$0: no TL package named $pkg in $Master" if ! $obj;
    debug("updating $pkg containers ...\n");
    # we have to make a copy otherwise the src/doc files in the original
    # tlpobj are removed, and thus also in the tlpdb to be saved!!!
    my $objcopy = $obj->copy;
    if ($srcsplit) {
      my $objsrc = $obj->srcfiles_package;
      $objcopy->clear_srcfiles;
      if ($objsrc) {
        my ($s,$m) = $objsrc->make_container($type, $Master, $opt_containerdir,
                                            "$pkg.source", $opt_relative);
        if ($s > 0) {
          # something was created 
          # important, we have to add it to the original $obj
          $obj->srccontainersize($s);
        }
        if ($m ne "") {
          $obj->srccontainermd5($m);
        }
      }
    }
    if ($docsplit) {
      my $objdoc = $obj->docfiles_package;
      $objcopy->clear_docfiles;
      if ($objdoc) {
        my ($s,$m) = $objdoc->make_container($type, $Master, $opt_containerdir,
                                             "$pkg.doc", $opt_relative);
        if ($s > 0) {
          # something was created
          $obj->doccontainersize($s);
        }
        if ($m ne "") {
          $obj->doccontainermd5($m);
        }
      }
    }
    my ($s,$m) = $objcopy->make_container($type, $Master, $opt_containerdir,
                                          $pkg, $opt_relative);
    if ($s > 0) {
      $obj->containersize($s);
    }
    if ($m ne "") {
      $obj->containermd5($m);
    }
    # add the updated (or new) TLPOBJ to NET TLPDB
    # that way the other container sizes are not destroyed
    $nettlpdb->add_tlpobj($obj);
  }

  # next we remove those containers which have been gone!
  foreach my $op (@removepacks) {
    info("$op has disappeared, removing its containers\n");
    `rm $opt_containerdir/$op.*`;
    $nettlpdb->remove_package($op);
    $count{"removed"}++;
  }

  if (@todopacks && ! $opt_recreate) {
    # we updated something
    print "$0: $count{new} new, $count{removed} removed, "
          . "$count{updated} updated, $count{unchanged} unchanged.\n";
  } else {
    print "$0: nothing to be done.\n";
  }

  # STRANGE: It seems that calling -recreate did not save the
  # docfiles into the texlive.tlpdb, no idea why. So update should now
  # do that.
  $nettlpdb->save;
  system("lzma --force -k -z $opt_location/tlpkg/texlive.tlpdb");
  
  # do a last check that all the containers are actually present
  foreach my $p ($tlpdb->list_packages) {
    next if $p =~ /00texlive.*\./;
    if (! -r "$opt_containerdir/$p.tar.lzma") {
      info ("container for $p is missing, strange!\n");
    }
  }
}


__END__

=head1 NAME

tl-update-containers - create, update, or remove TL containers

=head1 SYNOPSIS

tl-update-containers [OPTION]...

=head1 OPTIONS

=over 8

=item B<-location> I</container/dir>
The location to find the previously generated containers;
default is C<./archive>.  

=back

The standard options C<-help> and C<-debug> are also accepted.
See the tlpfiles documentation for details.

The format of the containers and the splitting off of source and
documentation files are controlled by the TLPDB options in the
pseudo-package C<00texlive.config>. See the documentation for TLPDB.


=head1 DESCRIPTION

The B<tl-update-containers> program compares the revision of each
package found in C<containerdir> with the revision of the same package
in C<texlive.tlpdb>, found relative to this script. Where the latter is
newer (i.e., a higher number), the container(s) for the package are
updated.  Where the container(s) do not exist, they are created.  When
the package no longer exists in tlpdb, the container(s) are removed.


=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: #