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

#!/usr/bin/env perl
# 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 (except some critical
# packages) if none specified.

BEGIN {
  $vc_id = '$Id$';
  $^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;

# packages matching these re's will not be updated without --all.
my @critical_pkg_list = qw/texlive\.infra texlive-en/;

our ($mydir, $vc_id);
my $opt_all = 0;
my $opt_location = ".";
my $opt_nosetup = 0;
my $opt_recreate = 0;
my $opt_relative = 0;
my $opt_version = 0;
my $opt_help = 0;
my $opt_dry = 0;

TeXLive::TLUtils::process_logging_options();
GetOptions(
  "all|a"       => \$opt_all,
  "dry-run"	=> \$opt_dry,
  "location=s"  => \$opt_location, 
  "no-setup"    => \$opt_nosetup,
  "recreate"    => \$opt_recreate,
  "version"	=> \$opt_version,
  "help|?"      => \$opt_help) or pod2usage(1);

pod2usage("-exitstatus" => 0, "-verbose" => 2) if $opt_help;
if ($opt_version) { print "$vc_id\n"; exit 0; } 

exit (&main());


sub main
{
  # get our db, same hierarchy from which we are being run.
  chomp(my $Master = `cd $mydir/../.. && pwd`);
  my $tlpdb = TeXLive::TLPDB->new("root" => $Master);
  die "cannot find tlpdb in $Master" unless defined($tlpdb);
  my @packs = $tlpdb->expand_dependencies("-only-arch", $tlpdb,
                                        @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");

  if (! $opt_recreate) {
    if (! -r "$opt_location/tlpkg/texlive.tlpdb") {
      tlwarn ("$0: Cannot load tlpdb from $opt_location, continuing in recreate mode.\n");
      $opt_recreate = 1;
    }
  }

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

  if ($opt_recreate) {
    # remake everything.
    if (@ARGV) {
      @todopacks = @packs;
      $nettlpdb = TeXLive::TLPDB->new;
      die "Cannot create new tlpdb" unless defined($nettlpdb);
      # we have to copy 00texlive.config to the new tlpdb otherwise
      # the configuration gets lost ...
      my $tlpconfig = $tlpdb->get_package("00texlive.config");
      $nettlpdb->add_tlpobj($tlpconfig);
    } else {
      @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("$0: $pkg is new\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 ("failed to get package $pkg, that should not happen!");
      }

      if ($oldrev == $newrev) {
        debug("$pkg up to date\n");
        # check for the existence of all containers, might got missing
        if (($tlp->runfiles && ! -r "$opt_containerdir/$pkg.tar.$type") ||
            ($srcsplit && $tlp->srcfiles && ! -r "$opt_containerdir/$pkg.source.tar.$type") ||
            ($docsplit && $tlp->docfiles && ! -r "$opt_containerdir/$pkg.doc.tar.$type")) {
          info("$0: container(s) for $pkg have disappeared, recreating them.\n");
          push @todopacks, $pkg;
          $count{"updated"}++;
        } else {
          $count{"unchanged"}++;
        }
      } elsif ($oldrev < $newrev) {
        push @todopacks, $pkg;
        $count{"updated"}++ if $oldrev;
      } else {
        # This can happen when packages get renamed or files get
        # shuffled from one package to another.
        warn "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 ...
  if ($opt_nosetup) {
    # do a minimal setup
    $::progs{'lzma'} = "lzma";
    $::progs{'tar'} = "tar";
  } else {
    # do a full setup
    my $ret = &TeXLive::TLUtils::setup_programs("$Master/tlpkg/installer");
    if ($ret == -1) {
      tlwarn("no binary of lzmadec for $::_platform_ detected, aborting.\n");
      exit 1;
    }
    if (!$ret) {
      tlwarn("binaries could not be set up, aborting.\n");
      exit 1;
    }
  }

  # get list of packages.
  PACKS: for my $pkg (sort @todopacks) {
    next if $pkg =~ /^00texlive\.(config|installer)$/;
    foreach my $manualpkgre (@critical_pkg_list) {
      # we match the initial string of the package name, so that all the
      # .arch packages are skipped, too
      if ($pkg =~ m/^$manualpkgre/) {
        if ($opt_all || $opt_recreate) {
          tlwarn ("$0: updating critical $pkg due to -all\n");
          last; # of the manualpkgre checks

        } else {
          tlwarn ("$0: skipping critical $pkg\n");
          # we assume that the packages in @critical_pkg_list always
          # exist, so if they are there then the number of updated packages
          # should be reduced.
          $count{'updated'}--;
          
          # the following line skips all other regexp checks on critical
          # packages and skips everything below this (the part which
          # actually builds the containers) and continues with the next
          # package (the PACKS: label above).
          next PACKS;
        }
      }
    }
    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) {
      if (!$opt_dry) {
        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);
          }
        } else {
          # no src files in the package, so remove old .source containers
          push @removepacks, "$pkg.source";
        }
      }
    } else {
      # remove the .source container
      push @removepacks, "$pkg.source";
    }
    if ($docsplit) {
      if (!$opt_dry) {
        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);
          }
        } else {
          # no doc files in the package, so remove old .doc containers
          push @removepacks, "$pkg.doc";
        }
      }
    } else {
      # remove the .doc containers
      push @removepacks, "$pkg.doc";
    }
    if (!$opt_dry) {
      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) unless $opt_dry;
  }

  # next we remove those containers which have been gone!
  REMOVEPACK: for my $op (@removepacks) {
    foreach my $manualpkgre (@critical_pkg_list) {
      # we match the initial string of the package name, so that all the
      # .arch packages are skipped, too
      if ($op =~ m/^$manualpkgre/) {
        if ($opt_all || $opt_recreate) {
          tlwarn ("$0: removing critical $op due to -all\n");
          last; # of the manualpkgre checks

        } else {
          tlwarn ("$0: skipping removal of critical $op\n");
          # the following line skips all other regexp checks on critical
          # packages and skips everything below this (the part which
          # actually builds the containers) and continues with the next
          # package (the PACKS: label above).
          next REMOVEPACK;
        }
      }
    }
    info("$0: $op has disappeared, removing its containers\n");
    `rm $opt_containerdir/$op.*` unless $opt_dry;
    $nettlpdb->remove_package($op) unless $opt_dry;
    $count{"removed"}++;
  }

  if ($opt_recreate) {
    info("$0: all packages recreated.\n");
  } else {
    if (@todopacks) {
      # 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";
    }
  }

  
  return(0) if $opt_dry;

  # 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 ($nettlpdb->list_packages) {
    next if $p =~ /00texlive/;
    if (! -r "$opt_containerdir/$p.tar.lzma") {
      tlwarn ("container for $p is missing, strange!\n");
    }
  }
}


__END__

=head1 NAME

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

=head1 SYNOPSIS

tl-update-containers [I<option>]...

=head1 OPTIONS

=over 4

=item B<-location> I</container/dir>

The location to find the previously generated containers;
default is C<./archive>.  

=item B<-recreate>

Does a full rebuild of all packages.

=item B<-all|-a>

Include packages deemed critical in the update, currently
C<texlive.infra> and C<texlive-en>.  (L<tlmgr> itself needs testing
before updating.)

=item B<-no-setup>

Does not try to setup the various programs, but uses I<lzma> and I<tar>
from path.

=item B<-help>

Print this documentation and exit.

=back

The standard options B<-q>, B<-v>, and B<-logfile>=I<file> are also
accepted; see the C<process_logging_options> function in
L<TeXLive::TLUtils> for details.

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


=head1 DESCRIPTION

This program compares C<texlive.tlpdb> (found relative to this script)
with the specified I<containerdir>.  If a tlpdb package is newer (i.e.,
a higher revision number), the container(s) for the package are updated.
When the package exists in tlpdb only, it is created in I<containerdir>.
When the package exists in I<containerdir> only, it is removed from there.

This is called from the L<tl-update-tlnet> script, which is run nightly.

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