#!/usr/bin/env perl # Copyright 2012-2020 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. # Run from tl-update-images. my $vc_id; my $mydir; 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|n" => \$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`); # necessary for TLUtils->platform $::installerdir = $Master; 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 $type) { 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)) { die "platform $a not installed, cannot prune, goodbye"; } } 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 removed but # is still in the list above, so ignore it. 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 print "removing $pkg.$a from tlpdb ... "; $tlpdb->remove_tlpobj("$pkg.$a") unless $opt_dry; print "done\n"; # remove the container my @arch_files = glob ("$containerdir/$pkg.$a.*tar.xz"); if (@arch_files) { print "removing @arch_files ... "; `rm @arch_files` unless $opt_dry; print "done\n"; } else { print "no arch files for $pkg.$a?\n"; } } } } } } my @newarchs; for my $a (@all_archs) { push @newarchs, $a if !TeXLive::TLUtils::member($a, @ARGV); } $tlpdb->setting("available_architectures", @newarchs); if (! $opt_dry) { TeXLive::TLUtils::copy ("-f", $tlpdb->location, $tlpdb->location . ".preprune"); $tlpdb->save; } return 0; } __END__ =head1 NAME tl-prune-platforms - remove platforms from a tlnet hierarchy =head1 SYNOPSIS tl-prune-platforms [I