path: root/Master/Tools/tpm-factory.pl

#!/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)
  }
}