path: root/Master/tlpkg/bin/check-fmttriggers

#!/usr/bin/env perl
# $Id$
# 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 ($vc_id, $Master);

BEGIN {
  $vc_id = '$Id$';
  $^W = 1;
  (my $mydir = $0) =~ s,/[^/]*$,,;
  my $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;
my $opt_version = 0;

TeXLive::TLUtils::process_logging_options ();
GetOptions (
  "fmtdir"     => \$opt_fmtdir,
  "rerecord!"  => \$opt_rerecord,
  "version"    => \$opt_version,
  "help|?"     => \$help) || pod2usage(1);

pod2usage ("-exitstatus" => 0, "-verbose" => 2) if $help;
if ($opt_version) { print "$vc_id\n"; exit 0; } 

$::installerdir = $Master;  # TLUtils.pm should be smarter
$ENV{'PATH'} = "$Master/bin/" . TeXLive::TLUtils::platform() . ":$ENV{PATH}";

exit (&main());


sub main {
  # no interference from TEXMFHOME, please.
  $ENV{'TEXMFHOME'} = "/nonesuch";

  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 B<--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 B<--no-rerecord>

Do not rebuild all formats to remake the recorder files; the default
(C<--rerecord>) is to do so.

=item B<--help>

Display this documentation and exit.

=item B<--version>

Display version information 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