path: root/Master/tlpkg/libexec/place

#!/usr/bin/env perl
# $Id$
# Public domain.  Originally written by Sebastian Rahtz.
# 
# Process a "cooked" tree directory (probably created by ctan2tds in
# Build/tmp.cooked), and integrate into the main texmf trees.
# 
# Basic usage: place PKG
# to process ./PKG.  Best invoked from ctan2tl, not directly.

BEGIN {
  chomp ($mydir = `dirname $0`);  # we are in Master/tlpkg/bin
  unshift (@INC, "$mydir/..");
}

use File::Basename;
use File::Find;
use Cwd;
use TeXLive::TLConfig qw/$InfraLocation $DatabaseName/;
use TeXLive::TLPSRC;
use TeXLive::TLPOBJ;
use TeXLive::TLPDB;
use TeXLive::TLTREE;
use Getopt::Long;

my $chicken = 0;
my $opt_contrib;
my $opt_mode = "svn";
exit 2 unless Getopt::Long::GetOptions (
  "n" => \$chicken,
  "contrib=s" => \$opt_contrib,
  "mode=s"    => \$opt_mode,
);

print "place: chicken mode = $chicken\n";

die "usage: $0 PKGNAME\n" unless @ARGV == 1;
$package = $ARGV[0];
# $::opt_verbosity = 3;  # debug tlpdb reading

# Negative patterns are used to avoid conflicts when the name of a given
# package happens to match the name of a subdirectory in another package.
# For example, cell.tlpsrc contains:
#   docpattern +!d texmf-dist/doc/latex/cals/test/cell
# to avoid including that test/cell subdirectory in the cals package
# when building tlpdb.  Ordinarily, if the pattern being excluded
# doesn't match anything, there is a warning (e.g., cals might get rid
# of that subdir someday, and then we'd want to delete the pattern from cell.)
# 
# But when we update cell from CTAN, of course cals is not present,
# therefore the negative pattern has nothing to match, therefore warning
# about it is noise, therefore omit the warning.
$::tlpsrc_pattern_no_warn_negative = 1;

%dirs = ();  # dirs we make changes in
$TMP = $ENV{"TMPDIR"} || "/tmp";
$tmpfile = "$TMP/$>.tlplace"; # use effective uid in temp file names

$cooked_top = getcwd ();  # ctan2tl invokes us in the top-level cooked dir

&xchdir ("$mydir/../..");
my $M = $DEST = getcwd ();  # svn Master, ordinarily where we write

$M = $DEST = $opt_contrib if (defined($opt_contrib));

#
&xchdir ("..");

# top-level.  For historical reasons, is usually just relative to
# Master, e.g., has texmf-dist.  But when a package has to write to both
# Master and Build (e.g., biber), it will have Master and Build subdirs.
my $TOP = getcwd ();

&xchdir ("$cooked_top/$package");
my $cooked_pkg = getcwd ();

print "place: checking for case-insensitive clashes\n"; # Windows/Mac checkouts
my @caseclash = `find . -print | sort | uniq -i -d`;
die "place: case clashes: @caseclash\n" if @caseclash;

print "place: checking for trailing dot clashes\n";
# this typically happens with a README generated from a dtx, thus
# named "README.", and the package author also includes a
# manually-renamed README in the package.  This causes a clash with
# Windows checkouts.  So remove the README. if it's the same, else give up.
# (= have to do something in ctan2tds to fix it.)
#
my @trailingdots = `find . -type f -name \*. -print | sort`;
for my $dot (@trailingdots) {
  chomp ($dot);
  (my $nodot = $dot) =~ s/\.$//;
  print "place:   checking $dot vs. $nodot\n";
  next if ! -e $nodot;  # just foo., no foo -- unlikely, but ok
  if (system ("cmp -s $dot $nodot") == 0) {
    print "place:   same, removing dot: $dot\n";
    unlink ($dot) || die "unlink($dot) failed: $!";
  } else {
    die "place: clash between $dot and $nodot; fix in ctan2ds\n";
  }
}
# we do those checks (and possible removals) before making the new TL
# package, so the "README."  file doesn't get into the data structures.


if (-d "Master") {  # maybe have both Build and Master
  &xchdir ("Master");
  $DEST = $TOP;
}
my $cooked_master = getcwd ();

if (-d "texmf-dist") {
  $Type = "Package";
} else {
  die "$cooked_master: no top level texmf-dist";
}

die "top-level README under $TOP, that can't be right" if <*/README>;

# get all files in the existing package, if there is one.
# In the unusual case when we have both Master and Build, we'll assume
# we also want all the platform-specific files under bin/; else not.
our %Old = &find_old_files ($package, $DEST eq $TOP ? "with-arch" : "");

# create new tlpsrc.
my $tlpsrc = TeXLive::TLPSRC;
my $tlpsrcfile = "$M/tlpkg/tlpsrc/$package.tlpsrc";
if (! -r $tlpsrcfile) {
  $tlpsrc->name($package);
  $tlpsrc->category($Type);
  if (! $chicken) {
    local *TLPSRC;
    $TLPSRC = ">$tlpsrcfile";
    open (TLPSRC) || die "open($TLPSRC) failed: $!";
    # not needed, we only set name and category which are taken
    # be default from the file name, so do not create useless entries
    # but only empty files
    # $tlpsrc->writeout (\*TLPSRC);
    close TLPSRC;
  }
} else {
  $tlpsrc->from_file($tlpsrcfile);
}

# make the new tlpobj.
# create TLTREE from stuff in cooked.
my $tltree = TeXLive::TLTREE->new ("svnroot" => $cooked_master);
$tltree->init_from_files;
my $tlpnew = $tlpsrc->make_tlpobj($tltree, $M);



# show comparison of old and new.
print "\n\f ";

&compare_disk_vs_tlpobj ($cooked_master, $tlpnew);
&show_tlp_diffs ($tlpnew, %Old);

# xx need svn cp, too?
my ($new_build_files,$existing_build_files) = &build_files ($cooked_pkg,$DEST);
my @new_build_files = @$new_build_files;

# Figure out removals relative to old package.
my %dirs_with_removals;
&xchdir ($cooked_master);
find (\&files, ".");  # sets %New to all new files under Master
foreach $file (sort keys %Old) {
  my $status = $New{$file} ? "retained" : "removed";
  print "* $file\t[$status]\n";

  # if the old file does not exist, don't try to remove it -- we
  # probably did so by hand and didn't bother to update.
  next unless -e "$M/$file";

  # remove no longer existing files.
  if (! $New{$file}) {
    if ($opt_mode eq "svn") {
      &xsystem ("svn remove \"$M/$file\"");
    } else {
      # we cannot use the full path since git does not allow this
      &xsystem ("cd \"$M\" && git rm \"$file\"");
    }
    (my $old_dir = "$M/$file") =~ s,/[^/]*$,,;
    $dirs_with_removals{$old_dir}++;
  }

  my $dname = dirname ("$M/$file");
  $dirs{$dname}++;
}



# Copy in new files.
&xchdir ($cooked_pkg);
&xsystem ("tar cf - . | (cd $DEST && tar xf - )");

# Processed everything out of the tmp cooked dir now, mv it aside.
&xchdir ($cooked_top);
&xsystem ("mv $package $package.done");

# sort so dirs will be added before subdirs.
for my $build_file (sort @new_build_files) {  # usually none
  &add_file ($build_file);
}
#
for my $file (sort keys %New) {
  &add_file ("$M/$file") if ! $Old{$file};
}

if (keys %Old == 0) {  # new package
  &add_file ("$M/tlpkg/tlpsrc/$package.tlpsrc");
}

# this file will often change, so be sure and include it.
$dirs{"$M/tlpkg/tlpsrc/$package.tlpsrc"}++;

# Now that all the files have been added, look for newly-empty
# directories in the previous package incarnation.  We can only do this
# when not chicken, since otherwise the old files will still exist and
# the directories will not be empty.
if (! $chicken) {
  for my $empty_dir (&empty_dirs (keys %dirs_with_removals)) {
    # every once in a while a directory consists only of newly-empty
    # dirs. This will catch some of those; not worth trying to do full
    # recursive search to get everything, cron.tl will report on leftovers.
    chomp (my $empty_dir_parent = `cd $empty_dir/.. && pwd`);
    my ($parent_if_empty) = &empty_dirs ($empty_dir_parent);
    my $cmd = $opt_mode eq "svn" ? "svn remove" : "rmdir";
    &xsystem ("cd $M && $cmd $empty_dir $parent_if_empty # emptydir");
    #
    # already in %dirs, so don't need to add.
  }
}


# include any directories with existing files in Build.
for my $bf (@$existing_build_files) {
  (my $dir = $bf) =~ s,/[^/]*$,,;
  $dirs{$dir}++;
}

# if we have a directory Build/.../linked_scripts/foo, 
# include the linked_scripts directory, since the Makefile.am and .in
# should have been changed (by hand) if the script was new.
for my $dir (keys %dirs) {
  next unless $dir =~ m,Build/.*/linked_scripts,;
  $dir =~ s,/linked_scripts/.*$,/linked_scripts,;
  $dirs{$dir}++;
}

# print dirs with changed files, and write the dir list to a file, for
# passing to svn commit.  if other files have been modified in those
# same dirs, though, this won't detect it.  It would be better to list
# exactly the *files* which should be committed.
# 
my $dirlist_file = "$tmpfile.dirs";
$DIRLIST = ">$dirlist_file";
open (DIRLIST) || die "open($DIRLIST) failed: $!";
#
print "place: directories are:\n";
for my $dir (sort keys %dirs) {
  print "$dir\n";
  print DIRLIST "$dir\n";
}
#
close (DIRLIST) || warn "close($DIRLIST) failed: $!";

# Always run svn update, even without --place.  This will let a worker
# detect that a particular package update has already been done by
# someone else.
if ($opt_mode eq "svn") {
  print ("\nsvn update of those directories:\n");
  system ("svn update `cat $dirlist_file`");
}
# do nothing in git mode

exit (0);



# return hash whose keys are all the files in PACKAGE from the main
# tlpdb.  If second arg is "with-arch", include platform-specific
# files.  If PACKAGE is not defined, return undef or the empty list.
# 
sub find_old_files {
  my ($package,$control) = @_;
  my %ret;

  # initialize TLPDB.
  my $tlpdb = new TeXLive::TLPDB ("root" => $M);

  my $tlpold = $tlpdb->get_package ($package);
  if (defined($tlpold)) {
    my @oldpkgs;
    if ($control eq "with-arch") {
      # also retrieve the platform-specific files, which are dependencies.
      @oldpkgs = $tlpdb->expand_dependencies ("-only-arch", $tlpdb,($package));
    } else {
      @oldpkgs = ($package);
    }
    for my $oldpkgname (@oldpkgs) {
      my $oldp = $tlpdb->get_package ($oldpkgname);
      for my $f ($oldp->all_files) {
        $ret{$f} = 1;
      }
    }
  }

  return %ret;
}



# add a file to the repository.  for svn, we also have to add the
# containing dir, and the parent of that dir, if they are new.
# 
sub add_file {
  my ($newfile) = @_;
#warn "adding file $newfile";

  # when it's needed, (grand*)parents must come first, else have svn
  # "not working copy" error.
  my $newdir = $dir = dirname ($newfile);

  if ($opt_mode eq "git") {
    &xsystem ("cd $M && git add $newfile");
    $dirs{$newdir}++;
    return;
  }

  my $needed_dirs = "";
  #until (-d "$dir/.svn") {
  until (&is_svn_dir($dir)) {
    $needed_dirs = "$dir $needed_dirs";  # parents first
    $dirs{$dir}++;
    $dir = dirname ($dir);
    die "no .svn dir found above $newdir? (in `pwd`)" if $dir eq ".";
  }
  &xsystem ("svn add -N $needed_dirs") if $needed_dirs;

  # sometimes the add fails due to svn guessing wrongly about a file
  # being binary vs. text, or mixed eol conventions.  Attempt to repair
  # -- just with pdf for now.  This is not tested and needs work.
  # 
  if (!defined (eval qq(xsystem("svn add '$newfile'")))
      && $newfile =~ /\.pdf\$/) {
    &xsystem ("svn proplist --verbose $newfile");
    &xsystem ("svn propset svn:mime-type application/pdf $newfile");
  }

  # remember that we changed this directory.
  $dirs{$newdir}++;
}



# compare against independent list of files in the new hierarchy, in
# case some of them did not get matched by the patterns.
#
sub compare_disk_vs_tlpobj {
  my ($diskdir,$tlp) = @_;
  chomp (my @files_on_disk = `cd $diskdir && find \! -type d`);
  s,^\./,, foreach @files_on_disk;      # remove leading ./
  @files_on_disk{@files_on_disk} = ();  # make list into hash
  
  for my $tlpfile ($tlp->all_files) {
    if (exists $files_on_disk{$tlpfile}) {
      delete $files_on_disk{$tlpfile};
    } else {
      print "$tlpfile in tlp but not on disk?!\n";
    }
  }
  
  print "\n*** not matched in new tlp:\n",
        map ("  $_\n", sort keys %files_on_disk)
    if keys %files_on_disk;
}



# write summary of changes to stdout and full diffs to a temp file so
# humans can inspect if desired.
# 
sub show_tlp_diffs {
  my ($tlpnew, %Old) = @_;
  if (keys %Old == 0) {
    print "place: $package not present in $M/$InfraLocation/$DatabaseName";
  } else {
    print "current vs. new $package (new is indented)\n";
    my @oldfiles = keys %Old;
    unlink ("$tmpfile.old");
    foreach (sort @oldfiles) {
      `echo "$_" >>$tmpfile.old`;
    }
    my @newfiles = $tlpnew->all_files;
    unlink ("$tmpfile.new");
    foreach (sort @newfiles) {
      `echo "$_" >>$tmpfile.new`;
    }
    print `comm -3 $tmpfile.old $tmpfile.new`;
    my @difffiles = `comm -12 $tmpfile.old $tmpfile.new`;
    chomp (@difffiles);
    my $sum = 0;
    my $identical = 0;
    #
    my $diff_file = "$tmpfile.diff";
    unlink ($diff_file);
    #
    # The --text is because we want to see the real changes, always.
    # The space-related options are because those changes aren't real.
    # (The diff is only run if the files are different according to our
    #  own test, so it's ok if the options eliminate all the diffs; it'll
    #  still get reported as needing an update.)
    # The -s reports identical files.
    # 
    my $diff_cmd ="diff --text --strip-trailing-cr --ignore-all-space -U 0 -s";
    #
    for my $f (@difffiles) {
      my $master_file = "$M/$f";
      my $cooked_file = "$cooked_master/$f";
      # diff has no options for handling Mac line endings, 
      # so use our own script for the initial comparison.
      if (system ("cmp-textfiles '$master_file' '$cooked_file'") == 0) {
        $identical++;
      } else {
        my $tee = "tee -a $diff_file";
        my @diff_out = `$diff_cmd $master_file $cooked_file | $tee`;
        $sum += $#diff_out - 2; # zero-based, so first line doesn't count.
                                # subtract another two lines for the heading
                                # and at least one hunk marker.
      }
    }
    my $nrcommfiles = @difffiles;
    #
    my $changed = $nrcommfiles - $identical;
    print "$nrcommfiles common files, $changed changed, ~$sum lines different"
          . " ($diff_file)";
  }
  print "\n\n\f\n";
}



# return list of new files under Build, if any.
# do nothing to try to remove files under Build, that doesn't make sense.
# 
sub build_files {
  my ($cooked_pkg, $svn_dest) = @_;
  my @new_ret = ();
  my @existing_ret = ();
 
  return unless -d "$cooked_pkg/Build";
  die "no Build subdir in $svn_dest?!" if ! -d "$svn_dest/Build";

  # get list of files in cooked Build dir.
  &xchdir ("$cooked_pkg");
  local %New;  # dynamically hide global %New.
  find (\&files, "Build");
  
  # compare against the svn Build dir; we only want the new files.
  for my $file (keys %New) {
    my $dest_file = "$svn_dest/$file";
    my $status = -e $dest_file ? "existing" : "new";
    print "* $file\t[$status]\n";
    if ($status eq "new") {
      push (@new_ret, $dest_file);
    } else {
      push (@existing_ret, $dest_file);
    }
  }
  
  return (\@new_ret, \@existing_ret);
}



# return list of empty (except for .svn) DIRS.
# 
sub empty_dirs {
  my (@dirs) = @_;
  my @ret = ();
  
  for my $d (@dirs) {
    if (opendir (DIR, $d)) {
      my @dirents = readdir (DIR);
      closedir (DIR) || warn "closedir($d) failed: $!";
      my @remainder = grep { $_ !~ /^\.(|\.|svn)$/ } @dirents;
      push (@ret, $d) if @remainder == 0;
    } else {
      if ($opt_mode eq "svn") {
        die "opendir($d) failed: $!";
      }
      # in git mode we don't die, git removes the empty dirs anyway
    }
  }
  return @ret;
}



# subroutine for &find, updating the global %New.
#
sub files {
  if (-f || -l) {  # consider files and symlinks
    my $This = $File::Find::name;
    $This =~ s,^\./,,;  # omit leading ./
    $New{$This} = 1;
  }
}



sub xchdir {
  my ($dir) = @_;
  chomp (my $pwd = `pwd`);
  chdir ($dir) || die "chdir($dir) failed: $!\n(cwd=$pwd)";
  print "place: chdir($dir)\n";
}


sub is_svn_dir {
  my ($dir) = @_;

  my $ret = system ("svn info $dir 2>/dev/null >/dev/null");
  $ret /= 256;
  return !$ret;
}

sub xsystem {
  my ($cmd) = @_;
  
  print "place: SYSTEM $cmd\n";

  unless ($chicken) {
    my $ret = system ($cmd);
    $ret /= 256;
    die "`$cmd' failed, status=$ret, goodbye\n" if $ret != 0;
  }
}