From e6faeef3e4205722d36bbbb86b3b3390ab6527be Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Wed, 28 Dec 2005 00:04:28 +0000 Subject: trunk git-svn-id: svn://tug.org/texlive/trunk@5 c570f23f-e606-0410-a88d-b1316a301751 --- Master/Tools/tpm-factory.pl | 640 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 640 insertions(+) create mode 100755 Master/Tools/tpm-factory.pl (limited to 'Master/Tools/tpm-factory.pl') 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 < 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= root directory of the TeX distribution + [$opt_master_dir]. + --dest_dir= destination directory for the zip files + [$opt_ftp_dir]. + --ftp_dir= directory for ftp results + [$opt_ftp_dir]. + +Packages: + --name= 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= 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) + } +} -- cgit v1.2.3