TeXLive/TLPSRC.pm (autopatterns): new global.

(find_default_patterns): new fn for getting default patterns.
(make_tlpobj): call it; third arg now dir in which to find autopatterns.
TeXLive/TLUtils.pm (debug_hash): new fn.
bin/tlpsrc2tlpdb: move new defalt pattern logic to TLPSRC.pm, change call.
bin/place: change call.


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

4 files changed, 104 insertions, 70 deletions

diff --git a/Master/tlpkg/TeXLive/TLPSRC.pm b/Master/tlpkg/TeXLive/TLPSRC.pm
index 0a0eb0faeb4..e21d938b6c9 100644
--- a/Master/tlpkg/TeXLive/TLPSRC.pm
+++ b/Master/tlpkg/TeXLive/TLPSRC.pm
@@ -14,6 +14,7 @@ use TeXLive::TLPOBJ;
 use TeXLive::TLTREE;
 
 my $_tmp;
+my %autopatterns;  # computed once internally
 
 sub new
 {
@@ -201,11 +202,10 @@ sub writeout
 #
 sub make_tlpobj
 {
-  my ($self,$tltree,$defaultpatterns) = @_;
-  my %patterns;
-  if (defined($defaultpatterns)) {
-    %patterns = %{$defaultpatterns};
-  }
+  my ($self,$tltree,$autopattern_root) = @_;
+  my %allpatterns = &find_default_patterns($autopattern_root);
+  my $category_patterns = $allpatterns{$self->category};
+
   my $tlp = TeXLive::TLPOBJ->new;
   $tlp->name($self->name);
   $tlp->category($self->category);
@@ -220,7 +220,7 @@ sub make_tlpobj
   my @allpospats;
   my @allnegpats;
   my $pkgname = $self->name;
-  #
+
   # src/run/doc patterns
   #
   # WARNING WARNING WARNING
@@ -243,8 +243,10 @@ sub make_tlpobj
         $usedefault = 0;
       }
     }
-    if ($usedefault && defined($patterns{$pattype})) {
-      for my $p (@{$patterns{$pattype}}) {
+
+    if ($usedefault && defined($category_patterns)) {
+      my $type_patterns = $category_patterns->{$pattype};
+      for my $p (@{$type_patterns}) {
         # replace the string %NAME% with the actual package name
         # we have to make a copy of $p otherwise we change it in the
         # hash once and for all
@@ -261,6 +263,7 @@ sub make_tlpobj
     # at this point we do NOT do the actual pattern matching for 
     # bin patterns, since we have some specialities to do
     last if ($pattype eq "bin");
+    
     # for all other patterns we create the list and add the files
     foreach my $p (@allpospats) {
       ddebug("pos pattern $p\n");
@@ -384,6 +387,68 @@ sub _do_normal_pattern {
 }
 
 
+# get the default patterns for all categories from an external file,
+# return hash with keys being the categories (Package, Documentation)
+# and values being refs to another hash.  The subhash's keys are the
+# file types (run bin doc ...) with values being refs to an array of
+# patterns for that type.
+# 
+sub find_default_patterns
+{
+  my ($tlroot) = @_;
+  # %autopatterns is global.
+  return %autopatterns if keys %autopatterns;  # only compute once
+  
+  my $apfile = "$tlroot/tlpkg/tlpsrc/00texlive.autopatterns.tlpsrc";
+  die "No autopatterns file found: $apfile" if ! -r $apfile;
+
+  my $tlsrc = new TeXLive::TLPSRC;
+  $tlsrc->from_file ($apfile);
+  if ($tlsrc->binpatterns) {
+    for my $p ($tlsrc->binpatterns) {
+      my ($cat, @rest) = split ' ', $p;
+      push @{$autopatterns{$cat}{"bin"}}, join(' ', @rest);
+    }
+  }
+  if ($tlsrc->srcpatterns) {
+    for my $p ($tlsrc->srcpatterns) {
+      my ($cat, @rest) = split ' ', $p;
+      push @{$autopatterns{$cat}{"src"}}, join(' ', @rest);
+    }
+  }
+  if ($tlsrc->docpatterns) {
+    for my $p ($tlsrc->docpatterns) {
+      my ($cat, @rest) = split ' ', $p;
+      push @{$autopatterns{$cat}{"doc"}}, join(' ', @rest);
+    }
+  }
+  if ($tlsrc->runpatterns) {
+    for my $p ($tlsrc->runpatterns) {
+      my ($cat, @rest) = split ' ', $p;
+      push @{$autopatterns{$cat}{"run"}}, join(' ', @rest);
+    }
+  }
+
+  for my $cat (keys %autopatterns) {
+    debug ("Category $cat\n");
+    for my $d (@{$autopatterns{$cat}{"bin"}}) {
+      debug ("Found auto bin pattern $d\n");
+    }
+    for my $d (@{$autopatterns{$cat}{"src"}}) {
+      debug ("Found auto src pattern $d\n");
+    }
+    for my $d (@{$autopatterns{$cat}{"doc"}}) {
+      debug ("Found auto doc pattern $d\n");
+    }
+    for my $d (@{$autopatterns{$cat}{"run"}}) {
+      debug ("Found auto run pattern $d\n");
+    }
+  }
+  
+  return %autopatterns;
+}
+
+
 # member access functions
 #
 sub _srcfile {
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index c557afd9d16..594f2cb20f9 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -1522,6 +1522,34 @@ sub tlwarn {
   $::opt_quiet = $savequiet;
 }
 
+
+=pod
+=item C<debug_hash ($label, hash))>
+
+Write LABEL followed by HASH elements, all on one line, to stderr.
+If HASH is a reference, it is followed.
+=cut
+
+sub debug_hash
+{
+  my ($label) = shift;
+  my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_;
+
+  my $str = "$label: {";
+  my @items = ();
+  for my $key (sort keys %hash) {
+    my $val = $hash{$key};
+    $key =~ s/\n/\\n/g;
+    $val =~ s/\n/\\n/g;
+    push (@items, "$key:$val");
+  }
+  $str .= join (",", @items);
+  $str .= "}";
+
+  warn "$str\n";
+}
+
+
 =pod
 
 =item C<process_logging_options ($texdir)>
diff --git a/Master/tlpkg/bin/place b/Master/tlpkg/bin/place
index 19646cb6d79..de23064f46c 100755
--- a/Master/tlpkg/bin/place
+++ b/Master/tlpkg/bin/place
@@ -95,7 +95,8 @@ if (! -r $tlpsrcfile) {
   $tlpsrc->from_file($tlpsrcfile);
 }
 
-my $tlpnew = $tlpsrc->make_tlpobj($tltree);
+# 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 ...
diff --git a/Master/tlpkg/bin/tlpsrc2tlpdb b/Master/tlpkg/bin/tlpsrc2tlpdb
index dcc857cad14..c70a7bd97e3 100755
--- a/Master/tlpkg/bin/tlpsrc2tlpdb
+++ b/Master/tlpkg/bin/tlpsrc2tlpdb
@@ -67,62 +67,6 @@ sub main
 
   my $tlpsrc_dir = "$opt_master/tlpkg/tlpsrc";
 
-  # get the default patterns
-  my %autopatterns;
-  if (! $opt_noautopatterns) {
-    my $apfile = "$tlpsrc_dir/00texlive.autopatterns.tlpsrc";
-    if (! -r $apfile) {
-      if (! $opt_noautopatterns) {
-        tlwarn ("No autopatterns tlpsrc 00texlive.autopatterns.tlpsrc found.\n");
-        tlwarn ("Stopping here. If you want to continue either add the above file\n");
-        tlwarn ("or call tlpsrc with --no-autopatterns.\n");
-        exit 1;
-      }
-    }
-    my $tlsrc = new TeXLive::TLPSRC;
-    $tlsrc->from_file ( $apfile );
-    if ($tlsrc->binpatterns) {
-      for my $p ($tlsrc->binpatterns) {
-        my ($cat, @rest) = split ' ', $p;
-        push @{$autopatterns{$cat}{"bin"}}, join(' ', @rest);
-      }
-    }
-    if ($tlsrc->srcpatterns) {
-      for my $p ($tlsrc->srcpatterns) {
-        my ($cat, @rest) = split ' ', $p;
-        push @{$autopatterns{$cat}{"src"}}, join(' ', @rest);
-      }
-    }
-    if ($tlsrc->docpatterns) {
-      for my $p ($tlsrc->docpatterns) {
-        my ($cat, @rest) = split ' ', $p;
-        push @{$autopatterns{$cat}{"doc"}}, join(' ', @rest);
-      }
-    }
-    if ($tlsrc->runpatterns) {
-      for my $p ($tlsrc->runpatterns) {
-        my ($cat, @rest) = split ' ', $p;
-        push @{$autopatterns{$cat}{"run"}}, join(' ', @rest);
-      }
-    }
-
-    for my $cat (keys %autopatterns) {
-      debug ("Category $cat\n");
-      for my $d (@{$autopatterns{$cat}{"bin"}}) {
-        debug ("Found auto bin pattern $d\n");
-      }
-      for my $d (@{$autopatterns{$cat}{"src"}}) {
-        debug ("Found auto src pattern $d\n");
-      }
-      for my $d (@{$autopatterns{$cat}{"doc"}}) {
-        debug ("Found auto doc pattern $d\n");
-      }
-      for my $d (@{$autopatterns{$cat}{"run"}}) {
-        debug ("Found auto run pattern $d\n");
-      }
-    }
-  } # end of if (! $opt_noautopatterns)
-
   # if we're regenerating the whole thing, get all our tlpsrc files.
   if ($opt_all) {
     chdir ($tlpsrc_dir) || die "chdir($tlpsrc_dir) failed: $!";
@@ -146,11 +90,7 @@ sub main
 
     my $tlsrc = new TeXLive::TLPSRC;
     $tlsrc->from_file ($f);
-    my $patternref;
-    if (defined($autopatterns{$tlsrc->category})) {
-      $patternref = $autopatterns{$tlsrc->category};
-    }
-    my $tlp = $tlsrc->make_tlpobj ($tltree, $autopatterns{$tlsrc->category});
+    my $tlp = $tlsrc->make_tlpobj ($tltree, $opt_master);
 
     (my $base_f = $f) =~ s/\.tlpsrc$//;
     warn "$f: package name " . $tlp->name . " does not match filename\n"