fix tl-update-tlpdb to deal with all kind of regressions

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

2 files changed, 214 insertions, 39 deletions

diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index 757a3fb44fd..ba48ed0586e 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -90,6 +90,9 @@ C<TeXLive::TLUtils> -- utilities used in the TeX Live infrastructure
   TeXLive::TLUtils::give_ctan_mirror();
   TeXLive::TLUtils::give_ctan_mirror_base();
   TeXLive::TLUtils::tlmd5($path);
+  TeXLive::TLUtils::compare_tlpobjs($tlpA, $tlpB);
+  TeXLive::TLUtils::compare_tlpdbs($tlpdbA, $tlpdbB);
+  TeXLive::TLUtils::report_tlpdb_differences(\%ret);
 
 =head1 DESCRIPTION
 
@@ -148,6 +151,9 @@ BEGIN {
     &w32_remove_from_path
     &tlcmp
     &time_estimate
+    &compare_tlpobjs
+    &compare_tlpdbs
+    &report_tlpdb_differences
   );
   @EXPORT = qw(setup_programs download_file process_logging_options
                tldie tlwarn info log debug ddebug dddebug debug_hash
@@ -3012,6 +3018,133 @@ sub tlmd5 {
   }
 }
 
+#
+# compare_tlpobjs 
+# returns a hash
+#   $ret{'revision'} = "leftRev:rightRev"     if revision differ
+#   $ret{'removed'} = \[ list of files removed from A to B ]
+#   $ret{'added'} = \[ list of files added from A to B ]
+#
+sub compare_tlpobjs {
+  my ($tlpA, $tlpB) = @_;
+  my %ret;
+  my @rem;
+  my @add;
+
+  my $rA = $tlpA->revision;
+  my $rB = $tlpB->revision;
+  if ($rA != $rB) {
+    $ret{'revision'} = "$rA:$rB";
+  }
+  if ($tlpA->relocated) {
+    $tlpA->cancel_reloc_prefix;
+  }
+  if ($tlpB->relocated) {
+    $tlpB->cancel_reloc_prefix;
+  }
+  my @fA = $tlpA->all_files;
+  my @fB = $tlpB->all_files;
+  my %removed;
+  my %added;
+  for my $f (@fA) { $removed{$f} = 1; }
+  for my $f (@fB) { delete($removed{$f}); $added{$f} = 1; }
+  for my $f (@fA) { delete($added{$f}); }
+  @rem = sort keys %removed;
+  @add = sort keys %added;
+  $ret{'removed'} = \@rem if @rem;
+  $ret{'added'} = \@add if @add;
+  return %ret;
+}
+
+#
+# compare_tlpdbs
+# return several hashes
+# @{$ret{'removed_packages'}} = list of removed packages from A to B
+# @{$ret{'added_packages'}} = list of added packages from A to B
+# $ret{'different_packages'}->{$package} = output of compare_tlpobjs
+#
+sub compare_tlpdbs {
+  my ($tlpdbA, $tlpdbB) = @_;
+  my @ignored_packs = qw/00texlive.installer 00texlive.image/;
+
+  my @inAnotinB;
+  my @inBnotinA;
+  my %diffpacks;
+  my %do_compare;
+  my %ret;
+
+  for my $p ($tlpdbA->list_packages()) {
+    next if TeXLive::TLUtils::member($p, @ignored_packs);
+    my $tlpB = $tlpdbB->get_package($p);
+    if (!defined($tlpB)) {
+      push @inAnotinB, $p;
+    } else {
+      $do_compare{$p} = 1;
+    }
+  }
+  $ret{'removed_packages'} = \@inAnotinB if @inAnotinB;
+  
+  for my $p ($tlpdbB->list_packages()) {
+    next if TeXLive::TLUtils::member($p, @ignored_packs);
+    my $tlpA = $tlpdbA->get_package($p);
+    if (!defined($tlpA)) {
+      push @inBnotinA, $p;
+    } else {
+      $do_compare{$p} = 1;
+    }
+  }
+  $ret{'added_packages'} = \@inBnotinA if @inBnotinA;
+
+  for my $p (sort keys %do_compare) {
+    my $tlpA = $tlpdbA->get_package($p);
+    my $tlpB = $tlpdbB->get_package($p);
+    my %foo = compare_tlpobjs($tlpA, $tlpB);
+    if (keys %foo) {
+      # some diffs were found
+      $diffpacks{$p} = \%foo;
+    }
+  }
+  $ret{'different_packages'} = \%diffpacks if (keys %diffpacks);
+
+  return %ret;
+}
+
+sub report_tlpdb_differences {
+  my $rret = shift;
+  my %ret = %$rret;
+
+  if (defined($ret{'removed_packages'})) {
+    info ("removed packages from A to B:\n");
+    for my $f (@{$ret{'removed_packages'}}) {
+      info ("  $f\n");
+    }
+  }
+  if (defined($ret{'added_packages'})) {
+    info ("added packages from A to B:\n");
+    for my $f (@{$ret{'added_packages'}}) {
+      info ("  $f\n");
+    }
+  }
+  if (defined($ret{'different_packages'})) {
+    info ("different packages from A to B:\n");
+    for my $p (keys %{$ret{'different_packages'}}) {
+      info ("  $p\n");
+      for my $k (keys %{$ret{'different_packages'}->{$p}}) {
+        if ($k eq "revision") {
+          info("    revision differ: $ret{'different_packages'}->{$p}->{$k}\n");
+        } elsif ($k eq "removed" || $k eq "added") {
+          info("    $k files:\n");
+          for my $f (@{$ret{'different_packages'}->{$p}->{$k}}) {
+            info("      $f\n");
+          }
+        } else {
+          info("  unknown differ $k\n");
+        }
+      }
+    }
+  }
+}
+
 #############################################
 #
 # Taken from Text::ParseWords
diff --git a/Master/tlpkg/bin/tl-update-tlpdb b/Master/tlpkg/bin/tl-update-tlpdb
index 7498c6afc76..4984088cede 100755
--- a/Master/tlpkg/bin/tl-update-tlpdb
+++ b/Master/tlpkg/bin/tl-update-tlpdb
@@ -51,6 +51,8 @@ GetOptions(
     "help|?" => \$help) or pod2usage(1);
 pod2usage(-exitstatus => 0, -verbose => 2) if $help;
 
+my $progname = TeXLive::TLUtils::basename($0);
+
 exit (&main ());
 
 
@@ -64,14 +66,14 @@ sub finish
   if ($opt_output) {
     if (open(OUT, ">$opt_output")) {
       $tlpdb->writeout(\*OUT);
-      info ("$0: wrote $pkgcount packages to $opt_output.\n");
+      info ("$progname: wrote $pkgcount packages to $opt_output.\n");
     } else {
       warn ("Cannot open $opt_output for writing");
       exit 1;
     }
   } else {
     $tlpdb->save;
-    info ("$0: wrote $pkgcount packages to ". $tlpdb->root . ".\n");
+    info ("$progname: wrote $pkgcount packages to ". $tlpdb->root . ".\n");
   }
   exit(0);
 }
@@ -79,14 +81,14 @@ sub finish
 sub main
 {
   if (! -d $opt_master) {
-    die "$0: Master $opt_master not a directory, goodbye.\n";
+    die "$progname: Master $opt_master not a directory, goodbye.\n";
   }
   my $tlc = undef;
   if (! -d $opt_catalogue) {
-    info ("$0: -c /Cat/a/logue not given, continuing without it.\n");
+    info ("$progname: -c /Cat/a/logue not given, continuing without it.\n");
   } else {
     require TeXLive::TeXCatalogue;  # not at compile time, for now anyway.
-    info ("$0: reading TeX Catalogue $opt_catalogue ...\n");
+    info ("$progname: reading TeX Catalogue $opt_catalogue ...\n");
     $tlc = TeXLive::TeXCatalogue->new ("location" => $opt_catalogue);
   }
 
@@ -106,7 +108,7 @@ sub main
   # compare_tlpdbs returns true if some reversed revisions have been found.
   # If in addition the option --fix-reverse-revisions is given it tries
   # to fix that, by committing changes.
-  if (compare_tlpdbs($oldtlpdb, $newtlpdb)) {
+  if (compare_and_fix_tlpdbs($oldtlpdb, $newtlpdb)) {
     # there have been reversed revision that have already been warned about
     # and that have been (hopefully) fixed by compared_tlpdbs if
     # --fix-reverse-revisions has been given
@@ -116,8 +118,12 @@ sub main
     # the tlpdb
     if (!$opt_fromfiles && $opt_fix_reverse_revisions) {
       ($newtlpdb, $pkgcount) = create_tlpdb($tlc);
-      if (compare_tlpdbs($oldtlpdb, $newtlpdb)) {
-        tldie("$0: That should not happen, after one iteration of compare_tlpdbs\nthe newly created tlpdb is still going backwards in time.\nPlease check output above!\n");
+      #
+      # now recheck, but do NOT try to check in changes again by unsetting
+      # $opt_fix_reverse_revisions
+      $opt_fix_reverse_revisions = 0;
+      if (compare_and_fix_tlpdbs($oldtlpdb, $newtlpdb)) {
+        tldie("$progname: That should not happen, after one iteration of compare_tlpdbs\nthe newly created tlpdb is still going backwards in time.\nPlease check output above!\n");
       }
     }
   }
@@ -125,44 +131,80 @@ sub main
   finish ($newtlpdb, $pkgcount);
 }
 
-sub compare_tlpdbs {
+sub compare_and_fix_tlpdbs {
   my ($oldtlpdb, $newtlpdb) = @_;
-  #
-  # check that revisions are actually going forward
-  my $recheck = 0;
-  my $commitit = 0;
-  for my $p ($newtlpdb->list_packages) {
-    my $newrev = $newtlpdb->get_package($p)->revision;
-    my $oldtlp = $oldtlpdb->get_package($p);
-    if (defined($oldtlp)) {
-      my $oldrev = $oldtlp->revision;
-      if ($oldrev > $newrev) {
-        # that is the bad case
-        $recheck = 1;
-        # here we should do a change to
-        #   $opt_master/tlpkg/tlpsrc/$p.tlpsrc
-        # and commit it!
-        tlwarn("$0: revision going backwards in $p.\n");
-        if ($opt_fix_reverse_revisions) {
-          tlwarn("$0: trying to fix it, running:\n");
-          my $time = time();
-          my $cmd = "svn propset texlive:force_incr_after_delete $time $opt_master/tlpkg/tlpsrc/$p.tlpsrc";
-          $commitit = 1;
-          tlwarn("  $cmd\n");
-          TeXLive::TLUtils::xsystem($cmd);
+
+  my %ret = TeXLive::TLUtils::compare_tlpdbs($oldtlpdb, $newtlpdb);
+
+  # we only care for differences in packages. If a packages has been
+  # removed or added that is fine for here as this will be dealt with
+  # in tl-update-containers
+
+  # within the list of packages that differ the problematic ones are
+  # where there are either files added or removed, but the revision
+  # did not increase
+
+  my %packages_that_need_fixup;
+
+  if (defined($ret{'different_packages'})) {
+    for my $p (keys %{$ret{'different_packages'}}) {
+      if (defined($ret{'different_packages'}->{$p}->{'added'}) ||
+          defined($ret{'different_packages'}->{$p}->{'removed'})) {
+        if (!defined($ret{'different_packages'}->{$p}->{'revision'})) {
+          # no revision change reported, but files have been added
+          # or removed, try fixing it
+          $packages_that_need_fixup{$p} = 1;
+        } else {
+          # revision change has been reported, if the revision is increasing
+          # that is fine, otherwise try fixing it
+          my ($rA, $rB) = split (':', 
+                            $ret{'different_packages'}->{$p}->{'revision'});
+          if ($rA >= $rB) {
+            $packages_that_need_fixup{$p} = 1;
+          }
+        }
+      } else {
+        # there have been no changed filelists, but we still check that
+        # revision is not going backward out of some strange other reason
+        if (defined($ret{'different_packages'}->{$p}->{'revision'})) {
+          # revision change has been reported, if the revision is increasing
+          # that is fine, otherwise try fixing it
+          my ($rA, $rB) = split (':', 
+                            $ret{'different_packages'}->{$p}->{'revision'});
+          if ($rA > $rB) {
+            tlwarn("$progname: big warning for $p: file lists didn't change but "
+                   . "revision is going backward! Very strange!\n");
+            $packages_that_need_fixup{$p} = 1;
+          }
         }
       }
     }
   }
+   
+  my $commitit = 0;
+
+  for my $p (keys %packages_that_need_fixup) {
+    tlwarn("$progname: package $p has different files but same/decreasing revision number\n");
+    if ($opt_fix_reverse_revisions) {
+      tlwarn("$progname: trying to fix it by running:\n");
+      my $time = time();
+      my $cmd = "svn propset texlive:force_incr_after_delete $time $opt_master/tlpkg/tlpsrc/$p.tlpsrc";
+      $commitit = 1;
+      tlwarn("  $cmd\n");
+      TeXLive::TLUtils::xsystem($cmd);
+    }
+  }
   if ($commitit) {
-    tlwarn("$0: committing changes to tlpsrc files:\n");
+    tlwarn("$progname: committing changes to tlpsrc files:\n");
     TeXLive::TLUtils::xsystem("svn commit "
-      . "-m'($0) force increased revision after removal of files' "
+      . "-m'($progname) force increased revision after removal of files' "
       . "$opt_master/tlpkg/tlpsrc/");
-    # we do not check the outcome, we expect to see a positive result 
-    # after rebuilding the tlpdb
   }
-  return $recheck;
+  if (keys %packages_that_need_fixup) {
+    return 1;
+  } else {
+    return 0;
+  }
 }
 
   
@@ -183,7 +225,7 @@ sub create_tlpdb
     @ARGV = glob ("*.tlpsrc");
   }
   
-  info ("$0: reading Master $opt_master ...\n");
+  info ("$progname: reading Master $opt_master ...\n");
   my $tltree = TeXLive::TLTREE->new ("svnroot" => $opt_master);
   if ($opt_fromfiles) {
     $tltree->init_from_files;
@@ -191,7 +233,7 @@ sub create_tlpdb
     $tltree->init_from_svn;
   }
 
-  info ("$0: updating from tlpsrc ...\n");
+  info ("$progname: updating from tlpsrc ...\n");
   my $tldb = TeXLive::TLPDB->new;
   my $src_count = 0;
   foreach my $f (@ARGV) {