texlive[69954] Master/texmf-dist/scripts/texlive/tlmgr.pl: Initial

[commits+preining at tug.org]

Revision: 69954
          https://tug.org/svn/texlive?view=revision&revision=69954
Author:   preining
Date:     2024-02-18 13:33:15 +0100 (Sun, 18 Feb 2024)
Log Message:
-----------
Initial work towards tlmgr bug

Modified Paths:
--------------
    trunk/Master/texmf-dist/scripts/texlive/tlmgr.pl

Modified: trunk/Master/texmf-dist/scripts/texlive/tlmgr.pl
===================================================================
--- trunk/Master/texmf-dist/scripts/texlive/tlmgr.pl	2024-02-18 06:55:16 UTC (rev 69953)
+++ trunk/Master/texmf-dist/scripts/texlive/tlmgr.pl	2024-02-18 12:33:15 UTC (rev 69954)
@@ -147,6 +147,9 @@
     "run-post" => 1,
     "function" => \&action_backup
   },
+  "bug" => {
+    "function" => \&action_bug
+  },
   "candidates" => {
     "run-post" => 0,
     "function" => \&action_candidates
@@ -1851,10 +1854,9 @@
   return ($F_OK | $F_NOPOSTACTION);
 }
 
-sub search_tlpdb {
+sub _search_tlpdb {
   my ($tlpdb, $what, $dofile, $dodesc, $inword) = @_;
-  my $retfile = '';
-  my $retdesc = '';
+  my %pkgs;
   foreach my $pkg ($tlpdb->list_packages) {
     my $tlp = $tlpdb->get_package($pkg);
     
@@ -1862,9 +1864,8 @@
     if ($dofile) {
       my @ret = search_pkg_files($tlp, $what);
       if (@ret) {
-        $retfile .= "$pkg:\n";
         foreach (@ret) {
-          $retfile .= "\t$_\n";
+          $pkgs{$pkg}{'files'}{$_} = 1;
         }
       }
     }
@@ -1872,28 +1873,43 @@
     # no options or --all -> search package names/descriptions
     if ($dodesc) {
       next if ($pkg =~ m/\./);
-      my $matched = search_pkg_desc($tlp, $what, $inword);
-      $retdesc .= "$matched\n" if ($matched);
+      my $t = "$pkg\n";
+      $t = $t . $tlp->shortdesc . "\n" if (defined($tlp->shortdesc));
+      $t = $t . $tlp->longdesc . "\n" if (defined($tlp->longdesc));
+      $t = $t . $tlp->cataloguedata->{'topics'} . "\n" if (defined($tlp->cataloguedata->{'topics'}));
+      my $pat = $what;
+      $pat = '\W' . $what . '\W' if ($inword);
+      my $matched = "";
+      if ($t =~ m/$pat/i) {
+        my $shortdesc = $tlp->shortdesc || "";
+        $pkgs{$pkg}{'desc'} = $shortdesc;
+      }
     }
   }
-  return($retfile, $retdesc);
+  return \%pkgs;
 }
 
-sub search_pkg_desc {
-  my ($tlp, $what, $inword) = @_;
-  my $pkg = $tlp->name;
-  my $t = "$pkg\n";
-  $t = $t . $tlp->shortdesc . "\n" if (defined($tlp->shortdesc));
-  $t = $t . $tlp->longdesc . "\n" if (defined($tlp->longdesc));
-  $t = $t . $tlp->cataloguedata->{'topics'} . "\n" if (defined($tlp->cataloguedata->{'topics'}));
-  my $pat = $what;
-  $pat = '\W' . $what . '\W' if ($inword);
-  my $matched = "";
-  if ($t =~ m/$pat/i) {
-    my $shortdesc = $tlp->shortdesc || "";
-    $matched .= "$pkg - $shortdesc";
+
+sub search_tlpdb {
+  my ($tlpdb, $what, $dofile, $dodesc, $inword) = @_;
+  my $fndptr = _search_tlpdb($tlpdb, $what, $dofile, $dodesc, $inword);
+  # first report on $pkg - $shortdesc found
+  my $retfile = '';
+  my $retdesc = '';
+  for my $pkg (sort keys %$fndptr) {
+    if ($fndptr->{$pkg}{'desc'}) {
+      $retdesc .= "$pkg - " . $fndptr->{$pkg}{'desc'} . "\n";
+    }
   }
-  return $matched;
+  for my $pkg (sort keys %$fndptr) {
+    if ($fndptr->{$pkg}{'files'}) {
+      $retfile .= "$pkg:\n";
+      for my $f (keys %{$fndptr->{$pkg}{'files'}}) {
+        $retfile .= "\t$f\n";
+      }
+    }
+  }
+  return($retfile, $retdesc);
 }
 
 sub search_pkg_files {
@@ -6930,6 +6946,75 @@
 }
 
 
+# 
 BUG
+# interactive bug support
+# 
+sub action_bug {
+  sub prompt_it {
+    my ($q, $required, $default) = @_;
+    print "$q ";
+    my $ans = <STDIN>;
+    if (!defined($ans)) {
+      if ($required) {
+        return $F_ERROR, "";
+      } else {
+        return $F_OK, $default;
+      }
+    }
+    chomp($ans);
+    return $F_OK, $ans;
+  }
+  init_local_db();
+  my ($ok, $ans);
+  ($ok, $ans) = prompt_it("Which package or file do you want to report a bug against:", 1);
+  if ($ok == $F_ERROR) {
+    print "Bailing out!\n";
+    return $F_ERROR;
+  }
+  # first search for packages that match $ans, and if not search for files
+  my $tlp = $localtlpdb->get_package($ans);
+  if ($tlp) {
+    return issue_bug_info_for_package($tlp);
+  }
+  # we are still here, so search for a file that matches
+  my $fndptr = _search_tlpdb($localtlpdb, $ans,
+    1, # search files,
+    0, # don't search descriptions
+    1  # don't search within words
+  );
+  my @found_pkgs = sort keys %$fndptr;
+  my $pkg;
+  if ($#found_pkgs > 0) {
+    print "Multiple matching packages found for term $ans:\n";
+    for my $i (0..$#found_pkgs) {
+      print $i, " $found_pkgs[$i]\n";
+    }
+    print "Select a package: ";
+    my $pkgidx = <STDIN>;
+    if (!defined($pkgidx) or int($pkgidx) < 0 or int($pkgidx) > $#found_pkgs) {
+      print "Bailing out!\n";
+      return $F_ERROR;
+    }
+    chomp($pkgidx);
+    $pkg = $found_pkgs[int($pkgidx)];
+  } elsif ($#found_pkgs == 0) {
+    $pkg = $found_pkgs[0];
+  } else {
+    print "Nothing found, bailing out\n";
+    return $F_OK;
+  }
+  $tlp = $localtlpdb->get_package($pkg);
+  return issue_bug_info_for_package($tlp);
+}
+
+sub issue_bug_info_for_package {
+  my $tlp = shift;
+  print $tlp->name, " ", $tlp->revision, "\n";
+  print "TODO\n";
+  return $F_OK;
+}
+
+
 

 # Subroutines galore.
 #
@@ -8278,6 +8363,11 @@
 
 =back
 
+=head2 bug
+
+Interactively guides through finding information where to report
+bugs.
+
 =head2 candidates I<pkg>
 
 Shows the available candidate repositories for package I<pkg>.