trunk

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

1 files changed, 640 insertions, 0 deletions

diff --git a/Master/Tools/tpm-factory.pl b/Master/Tools/tpm-factory.pl
new file mode 100755
index 00000000000..a1995b0c4de
--- /dev/null
+++ b/Master/Tools/tpm-factory.pl
@@ -0,0 +1,640 @@
+#!/usr/bin/perl
+# $Id: //depot/Master/Tools/tpm-factory.pl#46 $  $Date: 2005/10/05 $  $Author: staw $
+# Public domain.
+# 
+# TPM Build tool for TeXLive
+# Author: F. Popineau
+#
+# This file aims at automating tpm files maintenance
+# It's kind of a swiss-army knife so you can use it in several ways:
+#
+# Clean up a tpm file:
+# perl tpm-factory.pl --clean --name=Package/a0poster --patterns=auto
+# Clean up all Package (texmf-dist) tpm files
+# perl tpm-factory.pl --clean --type=Package --patterns=auto
+# perl tpm-factory.pl --clean --type=TLCore --patterns=from
+# The 'patterns' options tells to generate the files lists either
+# automatically (auto), from the patterns (from)
+# or to build patterns lists from files lists (to).
+# You can restrict the range of architectures with the --arch option.
+# By default --arch=all, but you can say --arch=win32,i386-linux too.
+#
+# Build a new tpm file from scratch:
+# perl tpm-factory.pl --new --name=Package/foo
+# This will build a new foo package, then you want to clean it up.
+#
+# Checking coverage:
+# perl tpm-factory.pl --check=cov --arch=all --type=Package
+# will check coverage inside the texmf-dist tree.
+#
+# Checking dependencies:
+# perl tpm-factory.pl --check=dep --arch=all --type=Package
+# will check dependencies inside the texmf-dist tree.
+#
+# Checking duplicates:
+# perl tpm-factory.pl --check=dup --arch=all --type=Package
+# will check duplicate file names inside the texmf-dist tree.
+#
+#
+
+BEGIN {   # get our other local perl modules.
+  ($mydir = $0) =~ s,/[^/]*$,,;
+  unshift (@INC, $mydir);
+  
+  $mydir = "c:/source/TeXLive/Master/Tools";  # fabrice
+  unshift (@INC, $mydir) if -d $mydir;
+}
+
+require "newgetopt.pl";
+use File::Basename;
+use Cwd;
+
+use FileUtils qw(canon_dir cleandir make_link newpath member
+		 normalize substitute_var_val dirname diff_list remove_list
+		 rec_rmdir sync_dir walk_dir start_redirection stop_redirection);
+use Tpm;
+
+File::Basename::fileparse_set_fstype('unix');
+
+use Strict;
+
+my $FtpDir = "c:/Inetpub/ftp/fptex";
+my $fpTeXVersion = "0.7";
+
+local $opt_check = 0;
+local $opt_ftp_dir = "${FtpDir}/${fpTeXVersion}";
+local $opt_arch;
+local $opt_log = 0;
+local $opt_verbose = 0;
+local $opt_tpm2zip = 0;
+local $opt_fixreq = 0;
+$opt_debug = 0;  # global so Tpm.pm can access it.
+$opt_warnings = 0;
+
+# print "XML::Parser::VERSION = $XML::Parser::VERSION, XML::DOM::VERSION = $XML::DOM::VERSION\n";
+&main;
+
+1;
+
+sub help {
+    print <<END_HELP;
+Usage: $ARGV[0] [OPTION]...
+ 
+Handle TPM (TeX package metadata) operations.
+
+Main operation (these targets are exclusive!):
+   --tpm2zip                 build zip files out of a set of tpm files;
+   --check=<(dep|cov)>       check dependencies or coverage for the tpm files.
+   --tpm_index               rebuild the tpm.zip index file.
+   --new                     create a new tpm file from scratch
+   --clean                   clean up the tpm file
+   --remove [--dry]          remove the tpm file and all files it may reference
+                             [testing only]
+   --patterns=(from|to|auto) fix one or more tpm files
+                             by automatically creating files lists,
+                             by expanding patterns to files lists,
+                             or regenerating patterns from files lists.
+
+Directories:
+   --master_dir=<path>       root directory of the TeX distribution
+                             [$opt_master_dir].
+   --dest_dir=<path>         destination directory for the zip files
+                             [$opt_ftp_dir].
+   --ftp_dir=<path>          directory for ftp results
+                             [$opt_ftp_dir].
+       
+Packages:
+   --name=<pattern>          process only the files matching the pattern;
+   --all                     process all package files;
+   --standalone              process only standalone package files;
+   --arch=<(all|name)>       process some or all architectures.
+ 
+Support commands:
+   --log=<file name>         log activity to file
+   --debug                   turn on debug trace
+   --verbose                 some more messages
+   --warnings                report empty fields Author, Version, ...
+   --help                    displays this help text and exits
+END_HELP
+}
+
+sub build_zip {
+  local ($tree,$tpmname) = @_;
+  print "building zip of $tree/tpm/$tpmname\n" if ($opt_verbose);
+  $tree =~ s@^$opt_master_dir/@@;
+  my $tpm = Tpm->new("$tree/tpm/$tpmname");
+
+  if ($opt_tpm2zip eq 'full') {
+    $tpm->Tpm2Zip($opt_ftp_dir, 'full', $opt_standalone);
+  }
+  else {
+    $tpm->Tpm2Zip($opt_ftp_dir, $opt_standalone);
+  }
+}
+
+sub read_dependencies {
+  local ($tree, $tpmname) = @_;
+  $tree =~ s@^$opt_master_dir/@@;
+  my $tpm = Tpm->new("$tree/tpm/$tpmname");
+  my %requires = $tpm->getHash("Requires");
+  my @reqlist = ();
+  foreach my $k (keys %requires) {
+    foreach my $e (@{$requires{$k}}) {
+      my $f = ${Tpm::TexmfTreeOfType}{$k} . "/tpm/$e.tpm";
+      if (-f "$opt_master_dir/$f") {
+	push @reqlist, $f ;
+      }
+      else {
+	push @{$wrong{"$tree/tpm/$tpmname"}}, "$f";
+      }
+    }
+  }
+  @{$req{"$tree/tpm/$tpmname"}} = @reqlist;
+#  print "$tree$tpmname requires @reqlist\n";
+}
+
+sub collect_tpmfiles {
+  local ($tree, $tpmname) = @_;
+  $tree =~ s@^$opt_master_dir/@@;
+  if ("texmf/tpm/$tpmname" !~ m@^${Tpm::IgnoredFiles}$@) {
+    push @tpm_files, "$tree/tpm/$tpmname";
+  }
+}
+
+sub do_tree {
+  local ($tree, $fn) = @_;
+  print " Directory $tree\n" if ($opt_verbose);
+  while (<$tree/tpm/*.tpm>) {
+    my $tpmname = $_;
+    next if ($tpmname =~ m/~$/); # for emacs backups!
+#    next if ($tree =~ /texmf$/ && $tpmname =~ m/xemtex/);
+#    next if ($tpmname =~ m/-static/ && ! $opt_standalone);
+    $tpmname =~ s@^${tree}/tpm/@@;
+    print "Doing $tree/tpm/$tpmname\n" if ($opt_verbose);
+    &{$fn}($tree, $tpmname);
+  }
+}
+
+#
+# Check that every tpm package is required by another one at least
+#
+sub check_dependencies {
+  local (%req, @tpm_files, %wrong);
+  local ($s, $k, @l);
+
+  foreach my $tree (@{Tpm::TexmfTrees}) {
+    if (! -d "$opt_master_dir/$tree/tpm") {
+      printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+      next;
+    }
+    $tree = "$opt_master_dir/$tree";
+    &do_tree($tree, \&read_dependencies);
+    &do_tree($tree, \&collect_tpmfiles);
+  }
+  # FIXME!!!
+  if (-f "$opt_master_dir/texmf/tpm/scheme-full.tpm") {
+    @l = ("texmf/tpm/scheme-full.tpm");
+  }
+  elsif (-f "$opt_master_dir/texmf/tpm/scheme-xemtex.tpm") {
+    @l = ("texmf/tpm/scheme-xemtex.tpm");
+  }
+  else {
+    die "No entry point, quitting...\n";
+  }
+  while ($#l >= 0) {
+    my $p = pop @l;
+#     if (! -f "$opt_master_dir/$p") {
+#       push @wrong, $p;
+#     }
+#     else {
+      &remove_list(\@tpm_files, "^" . $p . "\$");
+      push @l, @{$req{$p}};
+#          print "p = $p, l = @l\n";
+#     }
+  }
+  print "***********************************\n";
+  print "Wrong requirements:                \n";
+  print "***********************************\n";
+  map { print "$_ (";
+	map { print "$_ "; } @{$wrong{$_}};
+	print ")\n"; } &FileUtils::sort_uniq(keys %wrong);
+  print "\n";
+  print "***********************************\n";
+  print "Packages not required by anything: \n";
+  print "***********************************\n";
+  map { print "$_\n"; } @tpm_files;
+  print "\n";
+  print "***********************************\n";
+}
+
+sub collect_files {
+  local ($d, @lf) = @_;
+  my ($f);
+  foreach $f (@lf) {
+    my $path = "$d/$f";
+    if (-f "$path") {
+      $path =~ s@^${opt_master_dir}/@@;
+      $path =~ s@\\@/@g;
+      if ($path !~ m@^${Tpm::IgnoredFiles}$@
+#	 && $path !~ m@^bin/win32-static/@
+	 ) { push @texmf_files, $path; }
+    }
+  }
+}
+
+sub collect_coverage {
+  local ($tree, $tpmname) = @_;
+  if ("texmf/tpm/$tpmname" !~ m@^${Tpm::IgnoredFiles}$@) {
+    my $tpm = Tpm->new("$tree/tpm/$tpmname");
+    my @l = $tpm->getAllFileList();
+    print "Pushing $#l files from $tree/tpm/$tpmname\n" if $opt_debug;
+    push @tpm_files, @l;
+  }
+}
+
+sub find_multiple {
+  local (*files) = @_;
+  my (@l) = sort(@files);
+  my(@res, $e1, $e2);
+  @files = ( );
+  $e1 = pop(@l);
+  while ($e1) {
+    push @files, $e1;
+    while (($e2 = pop(@l)) eq $e1) {
+      push @res, $e2;
+    }
+    $e1 = $e2;
+  }
+  return @res;
+}
+
+#
+# Check that all files in tpm files exist
+# and that all files in the texmf tree
+# are requested by one tpm file.
+#
+sub check_coverage {
+  local (@texmf_files, @tpm_files);
+  my($s, @tree_list);
+
+  if ($opt_type eq 'TLCore' || $opt_type eq 'all') {
+    &walk_dir("$opt_master_dir/texmf", \&collect_files);
+    &walk_dir("$opt_master_dir/bin", \&collect_files);
+    &walk_dir("$opt_master_dir/xemtex", \&collect_files);
+    &walk_dir("$opt_master_dir/source", \&collect_files);
+    push @tree_list, "texmf";
+  }
+  if ($opt_type eq 'Package' || $opt_type eq 'all') {
+    &walk_dir("$opt_master_dir/texmf-dist", \&collect_files);
+    push @tree_list, "texmf-dist";
+  }
+  if ($opt_type eq 'Documentation' || $opt_type eq 'all') {
+    &walk_dir("$opt_master_dir/texmf-doc", \&collect_files);
+    push @tree_list, "texmf-doc";
+  }
+
+  foreach my $tree (@tree_list) {
+    if (! -d "$opt_master_dir/$tree/tpm") {
+      printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+      next;
+    }
+    $tree = "$opt_master_dir/$tree";
+    &do_tree($tree, \&collect_coverage);
+  }
+
+  print "Found $#tpm_files files in tpm files.\n";
+  local (@doublons) = find_multiple(\@tpm_files);
+  print "*****************************************\n";
+  print "Files found multiple times in tpm files :\n";
+  map { print "$_\n"; } @doublons;
+  print "*****************************************\n";
+  local (@l1, @l2);
+  &diff_list(\@texmf_files, \@tpm_files, \@l1, \@l2);
+  print "*****************************************\n";
+  print "Files in texmf tree not in tpm files :\n";
+  map { print "$_\n"; } @l1;
+  print "*****************************************\n";
+  print "Files in tpm files not in texmf tree :\n";
+  print "*****************************************\n";
+  map { print "$_\n"; } @l2;
+  print "*****************************************\n";
+  print "With Regexp:\n";
+  print "*****************************************\n";
+
+  @l1 = &FileUtils::regexpify(1, $Tpm::MasterDir, @l1);
+  @l2 = &FileUtils::regexpify(1, $Tpm::MasterDir, @l2);
+  print "*****************************************\n";
+  print "Files in texmf tree not in tpm files :\n";
+  map { print "$_\n"; } (sort @l1);
+  print "*****************************************\n";
+  print "Files in tpm files not in texmf tree :\n";
+  print "*****************************************\n";
+  map { print "$_\n"; } (sort @l2);
+  print "*****************************************\n";
+
+}
+
+sub compare_extensions {
+    my ($ext1, $ext2);
+#    print "a = $a, b = $b\n";
+    $ext1 = $2 if ($a =~ m/^(.*)\.([^\.]*)$/);
+    $ext2 = $2 if ($b =~ m/^(.*)\.([^\.]*)$/);
+#    print "ext1 = $ext1, ext2 = $ext2 " . ($ext1 cmp $ext2) . "\n";
+    if ($ext1 && $ext2) {
+      return ($ext1 cmp $ext2);
+    }
+    elsif ($ext1) {
+      return -1;
+    }
+    elsif ($ext2) {
+      return 1;
+    }
+    else {
+      return $a cmp $b;
+    }
+}
+
+sub check_duplicates {
+  local (@texmf_files);
+  my %doublons;
+
+  if ($opt_type eq 'TLCore' || $opt_type eq 'all') {
+    &walk_dir("$opt_master_dir/texmf", \&collect_files);
+  }
+  if ($opt_type eq 'Package' || $opt_type eq 'all') {
+    &walk_dir("$opt_master_dir/texmf-dist", \&collect_files);
+  }
+  if ($opt_type eq 'Documentation' || $opt_type eq 'all') {
+    &walk_dir("$opt_master_dir/texmf-doc", \&collect_files);
+  }
+  map {
+    push @{$doublons{&FileUtils::basename($_)}}, $_;
+  } @texmf_files;
+  for my $k (keys %doublons) {
+    if ($#{$doublons{$k}} < 1) {
+      delete $doublons{$k};
+    }
+  }
+  for my $k (sort compare_extensions (keys %doublons)) {
+    print "$k:\n";
+    map { 
+      my $date, $size;
+      my @t = stat("$opt_master_dir/" . $_);
+      $size = $t[7]; $date = &Tpm::printdate($t[9]);
+      print "\t$date\t$size\t$_\n"; } @{$doublons{$k}};
+  }  
+}
+
+sub clean_tpm {
+  my @texmf_trees = () ;
+  if ($opt_type eq 'all') {
+    @texmf_trees = @{Tpm::TexmfTrees};
+  }
+  else {
+    @texmf_trees = ( ${Tpm::TexmfTreeOfType}{$opt_type} );
+  }
+  map { print "tree = $_\n"; } @texmf_trees;
+  foreach my $tree (@texmf_trees) {
+    if (! -d "$opt_master_dir/$tree/tpm") {
+      printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+      next;
+    }
+    $tree = "$opt_master_dir/$tree";
+    &do_tree($tree, \&process_clean);
+  }
+}
+
+sub process_clean {
+  my ($tree, $tpmname) = @_;
+  $tpmname .= ".tpm" if ($tpmname !~ m/\.tpm$/);
+  my $tpm = Tpm->new("$tree/tpm/$tpmname");
+  $tpm->Clean($opt_patterns, $opt_fixreq);
+}
+
+sub process_remove {
+  my ($tree, $tpmname) = @_;
+  $tpmname .= ".tpm" if ($tpmname !~ m/\.tpm$/);
+  my $tpm = Tpm->new("$tree/tpm/$tpmname");
+  $tpm->Remove($opt_patterns, $opt_dry);
+}
+
+sub main {
+  # don't delay messages.
+  $| = 1;
+  select ((select (STDERR), $| = 1)[0]);
+
+  unless (&NGetOpt ("tpm2zip:s",
+		    "clean",
+		    "patterns=s",
+#		    "edit=s",
+		    "tpm_dir=s", 
+		    "ftp_dir=s", 
+		    "master_dir=s",
+		    "dest_dir=s",
+		    "name=s", 
+                    "arch=s",
+		    "check=s", 
+                    "tpm_index",
+		    "type=s",
+		    "fixreq",
+		    "new",
+		    "remove",
+		    "dry",
+                    "standalone", "log=s",
+		    "verbose", 
+                    "debug", "help"))
+    {
+	print STDERR "Try `$0 --help'.\n";
+	exit 1;
+    }
+
+  if ($opt_help) {
+    &help;
+    exit 0;
+  }
+
+  if (($opt_name && $opt_type)
+     || ($opt_type && $opt_standalone)
+     || ($opt_type && $opt_standalone)) {
+    print STDERR "$0: `--type', `standalone' and `--name' are mutually exclusive.\n";
+    exit 1;
+  }
+
+  $opt_verbose = 1 if $opt_debug;
+  
+  $opt_arch = "all" if (! $opt_arch);
+  if ($opt_arch =~ m/,/) {
+    my @l = split ",", $opt_arch;
+    map { 
+      if (!&member($_, @Tpm::ArchList)) {
+	print STDERR "$0: $_ is not a valid architecture, aborting.\n";
+	exit 1;
+      }
+    } @l;
+    @Tpm::ArchList = @l;
+    $opt_arch = 'all';
+  }
+
+  if ($opt_arch 
+      && !(($opt_arch eq "all")
+	   || &member($opt_arch, @Tpm::ArchList))) {
+    print STDERR "$0: $opt_arch is neither `all' nor a valid architecture, aborting.\n";
+    exit 1;
+  }
+
+  $Tpm::CurrentArch = $opt_arch;
+
+#  if ($opt_standalone && ($opt_ftp_dir =~ m@/$fpTeXVersion$@)) {
+#    $opt_ftp_dir =~ s@/$fpTeXVersion$@/standalone@;
+#  }
+  
+  if ($opt_master_dir) {
+    die "$0: !!!Error: Master dir $opt_master_dir is not a directory!\n" if (! -d $opt_master_dir);
+    ${Tpm::MasterDir} = $opt_master_dir;
+  }
+  else {
+    $opt_master_dir = ${Tpm::MasterDir};
+  }
+  
+  if ($opt_ftp_dir) {
+    die "$0: !!!Error: FTP dir $opt_ftp_dir is not a directory!\n" if (! -d $opt_ftp_dir);
+  }
+  
+  if ($opt_log) {
+    #    $logfile = "$topdir\\win32\\$opt_log";
+    if (! $opt_log =~ /\.log$/) {
+      $opt_log .= ".log";
+    }
+    # start redirection if asked
+    &start_redirection($opt_log);
+  }
+
+  if ($opt_tpm2zip eq '' || $opt_tpm2zip eq 'full') {
+
+    if ($opt_type) {
+      my @texmf_trees = () ;
+      if ($opt_type eq 'all') {
+	@texmf_trees = @{Tpm::TexmfTrees};
+      }
+      else {
+	@texmf_trees = ( ${Tpm::TexmfTreeOfType}{$opt_type} );
+      }
+      foreach my $tree (@texmf_trees) {
+	if (! -d "$opt_master_dir/$tree/tpm") {
+	  printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+	  next;
+	} 
+	$tree = "$opt_master_dir/$tree";
+	&do_tree($tree, \&build_zip);
+      }
+      # Copy TeXSetup in due place
+      my $src = "$opt_master_dir/bin/win32/TeXSetup.exe";
+      my $dst = "$opt_ftp_dir/TeXSetup.exe";
+      if (&FileUtils::newer($src, $dst) > 0) {
+	&FileUtils::copy($src, $dst);
+      }
+
+      #
+      # Rebuild tpm.zip file
+      #
+      unlink("${opt_ftp_dir}/tpm.zip");
+      $cwd = &getcwd();
+      chdir($opt_master_dir);
+      open ZIP, "| zip -9\@or ${opt_ftp_dir}/tpm.zip  > nul";
+      foreach my $e (@{Tpm::TexmfTrees}) {
+	while (<$e/tpm/*.tpm>) {
+	  print ZIP "$_\n" if (/\.tpm$/io);
+	  print  "$_\n" if (/\.tpm$/io and $opt_verbose);
+	}
+      }
+      close ZIP;
+      chdir($cwd);
+      print "File `${opt_ftp_dir}/tpm.zip' rebuilt.\n";
+    }
+    elsif ($opt_standalone) {
+      print "Doing standalone ...\n";
+      foreach $tpmname (@{Tpm::StandAlonePackages}) {
+	$tpmname =~ m@^(.*)/(.*)$@;
+        &build_zip(${Tpm::TexmfTreeOfType}{$1}, $2);
+      }
+    }
+    elsif ($opt_name) {
+      my ($tpmname, $tree);
+      $opt_name =~ m@^([^/]*)/([^/]*)$@x;
+      $tpmname = $2; $tree = ${Tpm::TexmfTreeOfType}{$1};
+      $tpmname .= ".tpm" if ($tpmname !~ m/\.tpm$/);
+      print "Doing $opt_master_dir/$tree/tpm/$tpmname\n";
+      if (! -f "$opt_master_dir/$tree/tpm/$tpmname") {
+	printf STDERR "$0: $opt_name non existent tpm file, aborting!\n";
+	exit 1;
+      }
+      &build_zip($tree, $tpmname);
+    }
+  }
+  elsif ($opt_tpm_index) {
+    #
+    # Rebuild tpm.zip file
+    #
+    unlink("${opt_ftp_dir}/tpm.zip");
+    $cwd = &getcwd();
+    chdir($opt_master_dir);
+    open ZIP, "| zip -9\@or ${opt_ftp_dir}/tpm.zip  > nul";
+    foreach my $e (@{Tpm::TexmfTrees}) {
+      while (<$e/tpm/*.tpm>) {
+	print ZIP "$_\n" if (/\.tpm$/io);
+	print  "$_\n" if (/\.tpm$/io and $opt_verbose);
+      }
+    }
+    close ZIP;
+    chdir($cwd);
+    print "File `${opt_ftp_dir}/tpm.zip' rebuilt.\n";
+  }
+  elsif ($opt_clean) {
+    if ($opt_name) {
+      $opt_name =~ m@^(.*)[/\\]([^/]*)$@x;
+      my $tree = ${Tpm::TexmfTreeOfType}{$1};
+      &process_clean($tree, $2);
+    }
+    elsif ($opt_type) {
+      &clean_tpm;
+    }
+  }
+  
+  # Check coverage for packages: do the tpm files cover
+  # the list of files in the texmf tree?
+  elsif ($opt_check && $opt_check =~ m/^cov/) {
+    print "Checking coverage:\n";
+    $opt_arch = "all";
+    &check_coverage;
+  }
+  # Check dependencies: are all the tpm packages required
+  # by some other package?
+  elsif ($opt_check && $opt_check =~ m/^dep/) {
+    print "Checking dependencies:\n";
+    &check_dependencies;
+  }
+  elsif ($opt_check && $opt_check =~ m/^dup/) {
+    print "Checking duplicates:\n";
+    &check_duplicates;
+  }
+  elsif ($opt_new) {
+    if ($opt_name) {
+      my $tpm = Tpm->fresh($opt_name);
+      $tpm->Clean($opt_patterns, $opt_fixreq);
+    }
+  }
+  elsif ($opt_remove) {
+    if ($opt_name) {
+      $opt_name =~ m@^(.*)[/\\]([^/]*)$@x;
+      my $tree = ${Tpm::TexmfTreeOfType}{$1};
+      my $name = $2;
+      &process_remove($tree, $name);
+    } else {
+      warn "$0: need --name=Type/pkgname with --remove.\n";
+    }
+  }
+
+  if ($opt_log) {
+    &stop_redirection($opt_log)
+  }
+}