new script to set up package removals

git-svn-id: svn://tug.org/texlive/trunk@4596 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 228 insertions, 0 deletions

diff --git a/Master/tlpkg/bin/tlprm b/Master/tlpkg/bin/tlprm
new file mode 100755
index 00000000000..57153c254f3
--- /dev/null
+++ b/Master/tlpkg/bin/tlprm
@@ -0,0 +1,228 @@
+#!/usr/bin/env perl
+# $Id$
+# Copyright 2007 Karl Berry.
+# This file is licensed under the GNU General Public License version 2
+# or any later version.
+# 
+# Remove a package from the TeX Live source repository. 
+# We use this when a package becomes obsolete, gets merged, or whatever.
+# It doesn't currently handle package removals from an installation.
+
+our $mydir;
+
+BEGIN {
+  $^W = 1;
+  ($mydir = $0) =~ s,/[^/]*$,,;
+  unshift (@INC, "$mydir/..");
+}
+
+use strict;
+
+use TeXLive::TLPDB;
+use TeXLive::TLPSRC;
+use Pod::Usage;
+use Getopt::Long;
+use Cwd 'abs_path';
+
+our $opt_debug = 0;
+my $opt_svn = 1;
+my $man = 0;
+my $help = 0;
+
+GetOptions("svn!",
+           "debug!", "help|?" => \$help, "man" => \$man) or pod2usage(2);
+
+pod2usage(1) if $help;
+pod2usage(-exitstatus => 0, -verbose => 2) if $man;
+
+exit (&main ());
+
+
+sub main
+{
+  my $failure_count = 0;
+
+  # xx should default in TLPDB.
+  chomp (my $Master = `cd $mydir/../.. && pwd`);
+  my $tlpdb = TeXLive::TLPDB->new (location => "$Master/texlive.tlpdb");
+
+  foreach my $f (@ARGV) {
+    my $obj = $tlpdb->get_package ($f);
+    if (! $obj) {
+      warn "$0: no TeX Live package named $f (in $Master/texlive.tlpdb).\n";
+      $failure_count++;
+      next;
+    }
+
+    my @files = $obj->all_files;
+    if ($opt_svn) {
+      my $tlpsrc = new TeXLive::TLPSRC;
+      $tlpsrc->from_file ($f);
+      push (@files, $tlpsrc->_srcfile); # also want to remove the tlpsrc file.
+
+      # The paths in tlpdb are relative to Master, so we chdir there so
+      # that Cwd::abs_path can work.
+      chdir ($Master) || die "chdir($Master) failed: $!";
+
+      # Commonly, we want to remove entire directories, not just all the
+      # files in the directory.
+      my @removals = &collapse_dirs (@files);
+      my $removals = join ("", map { "$_\n" } @removals);
+      
+      my $TMPDIR = $ENV{"TMPDIR"} || "/tmp";
+      my $rm_file = "$TMPDIR/tlprm.rm";
+      unlink ($rm_file);
+      `printf "$removals" >$rm_file`;
+      
+      my @lines = `grep -l 'depend.*/$f\$' $Master/tlpkg/tlpsrc/collection-*`;
+      my $commit_file = "$TMPDIR/tlprm.commit";
+      unlink ($commit_file);
+      `printf "$removals" >$commit_file`;
+      `printf "@lines" >>$commit_file`;
+      
+      print "first edit collections:\n", @lines;
+      print "then svn remove `cat $rm_file`\n";
+      print "then svn commit -m'rm $f' `cat $commit_file`\n";
+      
+      if (1) {  # maybe only if debugging?
+        print "\nremovals ($rm_file):\n";
+        print `cat $rm_file`;
+        print "\ncommits ($commit_file):\n";
+        print `cat $commit_file`;
+        print "\nlist of files being removed:\n";
+        print "$_\n" foreach @files;
+      }
+
+    } else {
+      die "sorry, can only do svn removals now.";
+      # maybe later it will make sense to extend this for removals
+      # from an installation.
+    }
+  }
+
+  # Instead of rewriting the database here, I think we're better off
+  # just doing it nightly or whatever.  For --svn purposes anyway.
+
+  return $failure_count;
+}
+
+
+# Return FILES, filtered with containing directories.  That is, look at
+# the containing directories of each FILE.  If every file within a given
+# dir is included in FILES, replace those files with the directory name
+# in the return list.  Any files with sibling files not included are
+# retained.
+# 
+# We do not try to check anything recursively.  It doesn't buy us
+# anything, since what we will eventually be doing is running svn
+# commands to remove these dirs/files, and it's harmless to list subdirs.
+# 
+sub collapse_dirs
+{
+  my (@files) = @_;
+  my @ret = ();
+  my %by_dir;
+  
+  # construct hash of all directories mentioned, values are lists of the
+  # files in that directory.
+  for my $f (@files) {
+    my $abs_f = abs_path ($f);
+    die ("oops, no abs_path($f) from " . `pwd`) unless $abs_f;
+    (my $d = $abs_f) =~ s,/[^/]*$,,;
+    my @a = exists $by_dir{$d} ? @{$by_dir{$d}} : ();
+    push (@a, $abs_f);
+    $by_dir{$d} = \@a;
+  }
+  
+  # for each of our directories, see if we are removing everything in
+  # the directory.  if so, return the directory; else return the
+  # individual files.
+  for my $d (sort keys %by_dir) {
+    opendir (DIR, $d) || die "opendir($d) failed: $!";
+    my @dirents = readdir (DIR);
+    closedir (DIR) || warn "closedir($d) failed: $!";
+    
+    # initialize test hash with all the files we saw in this dir.
+    # (These idioms are due to "Finding Elements in One Array and Not
+    # Another" in the Perl Cookbook.)
+    my %seen;
+    my @rmfiles = @{$by_dir{$d}};
+    @seen{@rmfiles} = ();
+
+    # see if everything is the same.
+    my @dironly = ();
+    for my $dirent (@dirents) {
+      next if $dirent =~ /^\.(\.|svn)?$/;  # ignore . .. .svn
+
+      my $item = "$d/$dirent";  # prepend directory for comparison
+      if (! exists $seen{$item}) {
+        push (@dironly, $item);
+        last;  # no need to keep looking after the first.
+      }
+    }
+    
+    push (@ret, @dironly ? @{$by_dir{$d}} : $d);
+  }
+  
+  return @ret;
+}
+
+__END__
+
+=head1 NAME
+
+tlprm - remove a TeX Live package
+
+=head1 SYNOPSIS
+
+tlprm [OPTION]... [TLPKG]...
+
+Set up to remove the specified TeX Live packages from the source repository.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-svn>
+Print the Subversion commands that will do the actual removal.  This is
+the default mode of operation.
+
+=item B<-help>
+Print brief help message and exit.
+
+=item B<-man>
+Print formatted manual page and exit.
+
+=item B<-debug>
+Give debug messages from the TeX Live modules.
+
+=back
+
+=head1 DESCRIPTION
+
+By default (or with the C<--svn> option), B<tlprm> merely prints
+commands to remove TeX Live packages from the source repository, e.g.,
+when a package becomes obsolete or merged.  It does not actually run any
+commands, remove anything, or change the TeX Live package database or
+anything else.
+
+No dependency or other checking is done.  It also does not remove the
+given package from any collection(s) where it is present.
+
+Perhaps someday this will be extended to remove a package from an actual
+installation.
+
+=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: #