summaryrefslogtreecommitdiff
path: root/Master/tlpkg/libexec/place
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2009-01-23 18:51:52 +0000
committerKarl Berry <karl@freefriends.org>2009-01-23 18:51:52 +0000
commit2290654a562daebf8ff3cecfd279e2d513218eb6 (patch)
tree71b2c13ffe2e1e4e52093ded668ff50b92693bde /Master/tlpkg/libexec/place
parenta728d3a907d5c8b0decba70740ffa1d387d0c1ce (diff)
(compare_disk_vs_tlpobj): new fn to report on any
stray files that are in the package but did not get matched by the tlpsrc patterns. git-svn-id: svn://tug.org/texlive/trunk@11953 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/libexec/place')
-rwxr-xr-xMaster/tlpkg/libexec/place52
1 files changed, 40 insertions, 12 deletions
diff --git a/Master/tlpkg/libexec/place b/Master/tlpkg/libexec/place
index 509aa36b852..cc754a93c46 100755
--- a/Master/tlpkg/libexec/place
+++ b/Master/tlpkg/libexec/place
@@ -63,13 +63,14 @@ if ($Root eq 'texmf-doc') {
die "top-level README in $Root, that can't be right" if -e "$Root/README";
-# initialize TLPDB
-my $tlpdb = new TeXLive::TLPDB ('root' => $M);
+# initialize TLPDB.
+my $tlpdb = new TeXLive::TLPDB ("root" => $M);
# create TLTREE from stuff in cooked/$pkg
-my $tltree = TeXLive::TLTREE->new ('svnroot' => "$cooked/$package");
+my $tltree = TeXLive::TLTREE->new ("svnroot" => "$cooked/$package");
$tltree->init_from_files;
-# get package from TLPDB;
+# get package from TLPDB.
+my %Old;
my $tlpold = $tlpdb->get_package ($package);
if (defined($tlpold)) {
foreach ($tlpold->all_files) {
@@ -79,7 +80,7 @@ if (defined($tlpold)) {
$newpackage = 1;
}
-# create new tlpsrc and tlpobj
+# create new tlpsrc.
my $tlpsrc = TeXLive::TLPSRC;
my $tlpsrcfile = "$M/tlpkg/tlpsrc/$package.tlpsrc";
if (! -r $tlpsrcfile) {
@@ -99,14 +100,17 @@ if (! -r $tlpsrcfile) {
# make the new tlpobj.
my $tlpnew = $tlpsrc->make_tlpobj($tltree, $M);
-# we took over the comparison of files from the ctan2tl script since
-# we are here in perl world, which makes it easier ...
+
+# show comparison of old and new.
print "\n\f ";
+
+&compare_disk_vs_tlpobj ("$cooked/$package", $tlpnew);
+
if (!defined($tlpold)) {
print "place: $package not present in $M/$InfraLocation/$DatabaseName\n\n";
} else {
print "new vs. present $package (present is indented)\n";
- my @oldfiles = $tlpold->all_files;
+ my @oldfiles = keys %Old;
`rm -f $tmpfile.old`;
foreach (sort @oldfiles) {
`echo $_ >>$tmpfile.old`;
@@ -176,7 +180,7 @@ my $job = "tar cf - . | (cd $M && tar xf - )";
&xsystem ($job);
# sort so dirs will be added before subdirs.
-foreach $file (sort keys %New) {
+for my $file (sort keys %New) {
if (! $Old{$file}) {
&add_file ("$M/$file");
}
@@ -185,7 +189,6 @@ foreach $file (sort keys %New) {
&xchdir ($cooked);
&xsystem ("mv $package $package.done");
-
if ($newpackage) {
&add_file ("$M/tlpkg/tlpsrc/$package.tlpsrc");
}
@@ -212,7 +215,7 @@ for my $dir (sort keys %dirs) {
#
close (DIRLIST) || warn "close($DIRLIST) failed: $!";
-# Always run svn update, even without --place. This will let a user
+# 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.
print ("\nsvn update of those directories:\n");
@@ -222,7 +225,6 @@ exit (0);
-#--------------------------------------
sub dirs
{
local @filenames;
@@ -285,7 +287,33 @@ sub add_file
$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: ",
+ join ("\n ", keys %files_on_disk),
+ "\n"
+ if keys %files_on_disk;
+}
+
+
+
sub xchdir
{
my ($dir) = @_;