* bin/check-fmttriggers: new infrastructure script.

*.tlpsrc: add fmttriggers=, checked/created by check-fmttriggers.


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

1 files changed, 377 insertions, 0 deletions

diff --git a/Master/tlpkg/bin/check-fmttriggers b/Master/tlpkg/bin/check-fmttriggers
new file mode 100755
index 00000000000..6241b257468
--- /dev/null
+++ b/Master/tlpkg/bin/check-fmttriggers
@@ -0,0 +1,377 @@
+#!/usr/bin/env perl
+# $Id: check-files-by-format 36922 2015-04-18 22:40:06Z karl $
+# Originally written by Norbert Preining and Karl Berry, 2015.  Public domain.
+# 
+# Determine the files on which each format (fmt/base) depends
+#   (by running fmtutil -recorder),
+# then map those files to TL packages,
+# then check that exactly those packages are listed as triggers in the
+#   corresponding tlpsrc files.
+
+my ($tlroot, $Master);
+
+BEGIN {
+  $^W = 1;
+  ($mydir = $0) =~ s,/[^/]*$,,;
+  $tlroot = "$mydir/../..";
+  unshift (@INC, "$tlroot/tlpkg");
+  chomp ($Master = `cd $mydir/../.. && pwd`);
+}
+
+use File::Find;
+use Getopt::Long;
+use Pod::Usage;
+
+use TeXLive::TLConfig;
+use TeXLive::TLUtils qw(info debug ddebug debug_hash tlwarn tldie);
+
+my $prg = TeXLive::TLUtils::basename($0);
+
+my $opt_fmtdir = "/tmp/fmttriggers";
+my $opt_rerecord = 1;
+my $opt_help = 0;
+
+TeXLive::TLUtils::process_logging_options ();
+GetOptions ("fmtdir"     => \$opt_fmtdir,
+            "rerecord!"  => \$opt_rerecord,
+            "help|?"     => \$help) or pod2usage(1);
+pod2usage (-exitstatus => 0, -verbose => 2) if $help;
+
+exit (&main());
+
+
+sub main {
+  if ($opt_rerecord) {  # remake recorder files?
+    my $status = &run_fmtutil ($opt_fmtdir);
+    return $status if $status;
+  }
+  #system ("bytime $opt_fmtdir");
+  
+  # read recorder files.
+  my %files_per_format = &files_per_format ($opt_fmtdir);
+
+  # read tlpdb.
+  my $tlpdb_file = "$Master/tlpkg/texlive.tlpdb";
+  my ($tlpdb,$fmttriggers) = &tlpdb_by_file ($tlpdb_file);
+ 
+  # map files used in format building to packages.
+  my %pkgs_per_format = &pkgs_per_format ($tlpdb, %files_per_format);
+  
+  # check that those packages are exactly what's listed as needed.
+  return &compare_pkgs_and_triggers (\%pkgs_per_format, $fmttriggers);
+}
+
+
+# Run fmtutil --fmtdir=$OUTDIR --recorder ..., to recreate the recorder
+# files which are the basis for finding the dependencies.
+# 
+# OUTDIR is completely removed first (!!), on the theory that this job
+# should only be done in temporary directories.
+# 
+sub run_fmtutil {
+  my ($outdir) = @_;
+  
+  # yep, destroy output directory tree.
+  TeXLive::TLUtils::rmtree ($outdir);
+  mkdir ($outdir, 0775) || die "$prg: mkdir($outdir) failed: $!";
+  
+  # the output from fmtutil can be useful in debugging.
+  my $logfile = "$outdir/fmtutil.log";
+  my $which = "--all";
+  #$which = "--byengine=tex";
+  my $cmd = "fmtutil --sys --recorder --strict --fmtdir=$outdir $which "
+             . ">$logfile 2>&1";
+  &info ("Running $cmd\n");
+  my $retval = system ($cmd);
+  $retval >>= 8 if $retval > 0;
+  if ($retval) {
+    tlwarn ("fmtutil exit status = $retval; contents of $logfile =\n");
+    tlwarn (`cat $logfile`);
+    tldie ("fmtutil failed, goodbye.\n");
+  }
+  return $retval;
+}
+
+
+# Return a hash with each key being a string of the form ENGINE.FORMAT,
+# and the corresponding value a reference to the list of files used to
+# make that format with that engine.  This is based on reading the
+# recorder files (format.fls/.ofl) for the format in FMTDIR.
+# Uninteresting files are removed from the list, as is the Master
+# directory prefix.
+# 
+sub files_per_format {
+  my ($fmtdir) = @_;
+  my %ret;
+  
+  # gather all fls files.
+  my @fls = ();
+  my $recorder_files = sub {
+    # fun with perl: we use an anonymous sub because it's lexically scoped,
+    #   hence we can update a my variable inside.  Explanation at, e.g.,
+    #   http://stackoverflow.com/questions/8839005
+    # In this case, we could also pass a lambda sub to find, since
+    #   this sub is so simple, but for purposes of example, do it this way.
+    push (@fls, $File::Find::name)
+      if $File::Find::name =~ /\.(fls|ofl)$/
+  };
+  File::Find::find ($recorder_files, $fmtdir);
+  
+  # each fls file will become an entry in the return hash.
+  my $fls_count = @fls;
+  &info ("Reading $fls_count fls file(s): @fls\n");
+  for my $fls_name (@fls) {
+    open (my $fls, $fls_name) || die "open($fls_name) failed: $!";
+    my @files = ();
+    while (<$fls>) {
+      next unless s/^INPUT //;
+      next if m,/web2c/texmf\.cnf$,;       # read internally by kpathsea
+      next if m,/fontname/texfonts\.map$,; # likewise
+      next if m,/texsys\.aux$,;            # aux file created during run
+      chomp;
+      s,^${Master}/,,;			   # rm prefix
+      push (@files, $_);
+    }
+    close ($fls) || warn "close($fls_name) failed: $!";
+    
+    # The engine name is the directory above the format file,
+    # and the format name is the format file without extension.
+    my ($engine,$format) = ($fls_name =~ m!^.*/([^/]+)/([^/.]+)\.[^/]+$!);
+    #
+    # we'd have to have a similar special case for mpost if mem files
+    # were still used (see rebuild_one_format in fmtutil).
+    $engine = "mf-nowin" if $engine eq "metafont";
+    #
+    my $ef = "$engine.$format";
+
+    # Unfortunately, format filenames themselves are not unique, due to
+    # cont-en and pdfcsplain.  Shouldn't be any engine-format dups, though.
+    # 
+    tldie ("$prg: already saw format $ef\n (with files @{$ret{$ef}})\n"
+           . " files now = @files\n")
+      if exists $ret{$ef};
+    $ret{$ef} = \@files;
+  }
+
+  #&debug_hash ("files_per_format returning hash", %ret);
+  return %ret;
+}
+
+
+# Read TLPDB_FILE and return references to two hashes: one mapping
+# contained files to TL package names, and a second mapping
+# engine.format names to their specified fmttriggers.
+# 
+# Instead of using the general TeXLive::TLPDB functions, read the tlpdb
+# file ourselves.  We want to build the file->package mapping just once,
+# for all files, or things become noticeably slow.  (The tlpfiles script
+# does this too, but we repeat that code here because we want to find
+# the fmttriggers too.)
+#
+sub tlpdb_by_file {
+  my ($tlpdb_file) = @_;
+  my (%tlpfiles, %fmttriggers);
+  
+  open (my $tlpdb, $tlpdb_file) || die "open($tlpdb_file) failed: $!";
+  my $pkg;
+  while (<$tlpdb>) {
+    chomp;
+    if (/^name /) {  # notice package names
+      (undef,$pkg) = split (/ /);
+
+    } elsif (s/^execute +AddFormat +//) {  # notice AddFormat lines
+      my %af = TeXLive::TLUtils::parse_AddFormat_line ($_);
+      if (exists $af{"error"}) {
+        tldie ("$prg: parse_AddFormat_line failed: $af{error}\n"
+               . "line = $_\n");
+      }
+      if ($af{"fmttriggers"}) {
+        $fmttriggers{"$af{engine}.$af{name}"} = $af{"fmttriggers"};
+      } else {
+        tlwarn ("$prg: no fmttriggers: $_\n");
+      }
+
+    } elsif (s/^ //) { # notice file names
+      # we carefully designed the format so that the only lines with
+      # leading spaces are the files.
+      # The installer "package" isn't one, just ignore it.
+      next if $pkg eq "00texlive.installer";
+      my $f = $_;
+      tldie ("$prg: already saw file $f (package $tlpfiles{$f}), "
+             . "now in package $pkg\n")
+        if exists $tlpfiles{$f}; # should never happen
+      $tlpfiles{$f} = $pkg;
+    }
+  }
+  close ($tlpdb) || warn "close($tlpdb_file) failed: $!";
+  
+  &info ("TLPDB files: " . scalar (keys %tlpfiles)
+         . "  triggers: " . scalar (keys %fmttriggers) . "\n");
+  return (\%tlpfiles, \%fmttriggers);
+}
+  
+
+# Return a hash with each key being a format name and the corresponding
+# value a reference to the list of TL packages which contain the files
+# used to make that format, based on the incoming TLPDB and FILES_PER_FORMAT.
+# 
+sub pkgs_per_format {
+  my ($tlpdb,%files_per_format) = @_;
+  my %ret;  # format->pkgs mapping
+
+  # we don't include these as fmttriggers since when they meaningfully
+  # change, fmtutil should get called anyway due to language.* changing.
+  my @skip_pkgs = qw(dehyph-exptl hyph-utf8 hyphen-ancientgreek hyphen-german
+                     hyphen-greek ruhyphen ukrhyph);
+  # there's also the question of the binaries themselves.  we just
+  # ignore that, since it hasn't been a problem in practice: when the
+  # binaries change, everything tends to change anyway.
+
+  for my $format (sort keys %files_per_format) {
+    &debug ("finding packages for $format...\n");
+    my %pkgs_for_this_format;
+    my $files_ref = $files_per_format{$format};
+    for my $f (@$files_ref) {
+      if (exists $tlpdb->{$f}) {
+        my $pkg = $tlpdb->{$f};
+        next if grep ($_ eq $pkg, @skip_pkgs);
+        $pkgs_for_this_format{$pkg} = 1;
+      } else {
+        tlwarn ("$prg: tl package not found for file: $f\n");
+      }
+    }
+    # 
+    # looked up all files for this format; save our list of packages.
+    my @pkgs = sort keys %pkgs_for_this_format;
+    &debug ("  packages for $format: @pkgs\n");
+    if (@pkgs == 0) {
+      tlwarn ("$prg: no packages for format $format?  files = @$files_ref\n");
+    }
+    $ret{$format} = \@pkgs;
+  }
+
+  &info ("Formats found: " . scalar (keys %ret) . "\n");
+  #&debug_hash ("pkgs_per_format returning", %ret);
+  return %ret;
+}
+
+
+# Compare lists of required packages with lists of existing trigger
+# directives.  Return 0 if identical, 1 otherwise (and report
+# differences).
+# 
+sub compare_pkgs_and_triggers {
+  my ($pkgs_per_format,$fmttriggers) = @_;
+  my $bad_p = 0;
+  my $all_pkgs = 0;
+  
+  for my $ef (sort keys %$pkgs_per_format) {
+    my @recorded_pkgs = @{$pkgs_per_format->{$ef}};
+    $all_pkgs += @recorded_pkgs;
+
+    my %recorded_pkgs;
+    @recorded_pkgs{@recorded_pkgs} = ();  # hash slice for recorded files
+
+    if (defined $fmttriggers->{$ef}) {
+      my @tlpdb_pkgs = @{$fmttriggers->{$ef}};
+      my %tlpdb_pkgs;
+      @tlpdb_pkgs{@tlpdb_pkgs} = ();  # hash slice for the tlpdb side
+      
+      my @recorded_only = ();
+      for my $r (keys %recorded_pkgs) {
+        if (exists $tlpdb_pkgs{$r}) {
+          delete $tlpdb_pkgs{$r}; # ok, in both
+        } else {
+          push (@recorded_only, $r);
+        }
+      }
+      if (keys %tlpdb_pkgs) {
+        tlwarn ("$prg: $ef triggers only in tlpdb: "
+                . join (",", keys %tlpdb_pkgs) . "\n");
+        $bad_p = 1;
+      }
+      if (@recorded_only) {
+        tlwarn ("$prg: $ef triggers only in recorder: "
+                . join (",", @recorded_only) . "\n");
+        $bad_p = 1;
+      }
+      
+      delete $fmttriggers->{$ef};
+
+    } else {
+      # not in tlpdb at all; output needed fmttriggers directive.
+      tlwarn ("$prg: no fmttriggers in tlpdb: $ef\n"
+              . "  fmttriggers=" . join (",", @recorded_pkgs) . "\n");
+      $bad_p = 1;
+    }
+  }
+  
+  for my $ef (sort keys %$fmttriggers) {
+    my $trig = join (",", @{$fmttriggers->{$ef}});
+    tlwarn ("$prg: fmttriggers in tlpdb only, not recorder: "
+            . "$ef ($trig)\n");
+    $bad_p = 1;
+  }
+  
+  info ("Triggers checked: $all_pkgs (includes duplicates)\n");
+  return $bad_p;
+}
+
+__END__
+
+=head1 NAME
+
+check-fmt-triggers - check that all needed packages trigger format rebuilds
+
+=head1 SYNOPSIS
+
+check-fmt-trigger [I<option>]...
+
+=head1 OPTIONS
+
+=over 4
+
+=item C<--fmtdir> I<dir>
+
+Rebuild formats in I<dir>; default C</tmp/fmttriggers>.  This directory
+is completely removed before rebuilding, so do not use any system
+directory.
+
+=item C<--no-rerecord>
+
+Do not rebuild all formats to remake the recorder files; the default
+(C<--rerecord>) is to do so.
+
+=item C<--help>
+
+Print this documentation and exit.
+
+=back
+
+The standard options B<-q>, B<-v>, and B<-logfile>=I<file> are also
+accepted; see the C<process_logging_options> function in
+L<TeXLive::TLUtils> for details.
+
+=head1 DESCRIPTION
+
+This program removes the binary directories of the platforms given as
+arguments; that is, remove the binfiles entries in the tlpdb, and remove
+the containers.  (Any xz and wget binaries for the installer remain, though.)
+
+It is used during DVD production to exclude certain platforms, and is
+run from the L<tl-update-images> script.
+
+=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: sw=2 expandtab