#!/usr/bin/env perl # $Id$ # 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 ($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); } my @l = ("texmf/tpm/scheme-full.tpm", "texmf/tpm/collection-wintools.tpm", ); while ($#l >= 0) { my $p = pop @l; &remove_list(\@tpm_files, "^" . $p . "\$"); push @l, @{$req{$p}}; } print "***********************************\n"; print "Wrong requirements: \n"; map { print "$_ ("; map { print "$_ "; } @{$wrong{$_}}; print ")\n"; } &FileUtils::sort_uniq(keys %wrong); print "\n"; print "***********************************\n"; print "Packages not required by anything: \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; unless ($path =~ m/^${Tpm::IgnoredFiles}$/) { push @texmf_files, $path; #warn "accepted $path\n"; } else { ; #warn "ignored $path\n"; } } } } 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/perltl", \&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) } }