From f9396602378a18a853ddd295375c279674592679 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Tue, 24 Jul 2012 23:46:01 +0000 Subject: add a script to prune platforms from a tlnet hieararchy, will be used in DVD production git-svn-id: svn://tug.org/texlive/trunk@27142 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/bin/tl-prune-platforms | 154 ++++++++++++++++++++++++++++++++++++ 1 file changed, 154 insertions(+) create mode 100755 Master/tlpkg/bin/tl-prune-platforms (limited to 'Master') diff --git a/Master/tlpkg/bin/tl-prune-platforms b/Master/tlpkg/bin/tl-prune-platforms new file mode 100755 index 00000000000..43435d9bbd9 --- /dev/null +++ b/Master/tlpkg/bin/tl-prune-platforms @@ -0,0 +1,154 @@ +#!/usr/bin/env perl +# Copyright 2012 Norbert Preining +# This file is licensed under the GNU General Public License version 2 +# or any later version. +# +# Prune (remove) platforms from a tlnet distribution tree + +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; + +my $opt_version = 0; +my $opt_help = 0; +my $opt_dry = 0; + +TeXLive::TLUtils::process_logging_options(); +GetOptions( + "dry-run" => \$opt_dry, + "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 +{ + # prune db in the 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 $format = $tlpdb->config_container_format; + my $type = "xz"; + if ($format ne "xz") { + tlwarn("$0: unknown container format $format in 00texlive.config; ", + "ignoring and continuing with $type"); + } + + # check that all archs given on the command line are actual archs, + # otherwise bail out for security + my @all_archs = $tlpdb->available_architectures; + for my $a (@ARGV) { + if (!TeXLive::TLUtils::member($a, @all_archs)) { + print "Platform $a not installed, cannot prune, exiting\n"; + exit 1; + } + } + + my $containerdir = "$Master/$TeXLive::TLConfig::Archive"; + + # loop over packages and remove their binary component + for my $pkg ($tlpdb->list_packages) { + # by definition, any 00texlive... package does not need containers. + next if $pkg =~ /00texlive/; + + my $tlp = $tlpdb->get_package($pkg); + if (!$tlp) { + # that is a package foobar.$a that has already been remove but + # is still in the list above, so ignore that + next; + } + foreach my $dep ($tlp->depends) { + if ($dep =~ m/^(.*)\.ARCH$/) { + foreach my $a (@ARGV) { + if ($tlpdb->get_package("$pkg.$a")) { + # remove entry in the tlpdb + $tlpdb->remove_package("$pkg.$a"); + # remove the container + if (-r "$containerdir/$pkg.$a.tar.xz") { + `rm $containerdir/$pkg.$a.tar.xz`; + } + } + } + } + } + } + + my @newarchs; + for my $a (@all_archs) { + push @newarchs, $a if !member($a, @ARGV); + } + + $tlpdb->setting("available_architectures",@newarchs); + $tlpdb->save; + + return 0; +} + +__END__ + +=head1 NAME + +tl-prune-platforms - remove platforms from a tlnet hierarchy + +=head1 SYNOPSIS + +tl-prune-platforms [I