04/06: squash! '--glob'

[guix-commits]

civodul pushed a commit to branch wip-guix-index
in repository guix.

commit a2d1f8e1e902adb624bb2f6d07265ef82609e71d
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jun 7 23:20:12 2023 +0200

    squash! '--glob'
---
 doc/guix.texi           | 16 ++++++++++++++++
 guix/scripts/locate.scm | 43 +++++++++++++++++++++++++++----------------
 tests/guix-locate.sh    |  3 +++
 3 files changed, 46 insertions(+), 16 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 0719892d9a..833b1fd9b4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4448,6 +4448,16 @@ icu4c@@71.1          
/gnu/store/@dots{}/include/unicode/unistr.h
 libunistring@@1.0    /gnu/store/@dots{}/include/unistr.h
 @end example
 
+You may also specify @dfn{glob patterns} with wildcards.  For example,
+here is how you would search for packages providing @file{.service}
+files:
+
+@example
+$ guix locate -g '*.service'
+man-db@@2.11.1        @dots{}/lib/systemd/system/man-db.service
+wpa-supplicant@@2.10  @dots{}/system-services/fi.w1.wpa_supplicant1.service
+@end example
+
 The @command{guix locate} command relies on a database that maps file
 names to package names.  By default, it automatically creates that
 database if it does not exist yet by traversing packages available
@@ -4473,6 +4483,12 @@ guix locate [@var{options}@dots{}] @var{file}@dots{}
 The available options are as follows:
 
 @table @code
+@item --glob
+@item -g
+Interpret @var{file}@dots{} as @dfn{glob patterns}---patterns that may
+include wildcards, such as @samp{*.scm} to denote all files ending in
+@samp{.scm}.
+
 @item --update
 @itemx -u
 Update the file database.
diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
index 259fc39797..f5de02cf2c 100644
--- a/guix/scripts/locate.scm
+++ b/guix/scripts/locate.scm
@@ -25,7 +25,8 @@
                           show-bug-report-information
                           with-error-handling
                           string->number*
-                          display-hint))
+                          display-hint
+                          leave-on-EPIPE))
   #:use-module (guix diagnostics)
   #:use-module (guix scripts)
   #:use-module (sqlite3)
@@ -433,16 +434,22 @@ for each package to insert."
   (output  package-match-output)
   (file    package-match-file))
 
-(define (matching-packages db file)
-  "Return unique <package-match> corresponding to packages containing FILE."
+(define* (matching-packages db file #:key glob?)
+  "Return a list of <package-match> records, one for each package containing
+FILE.  When GLOB? is true, interpret FILE as a glob pattern."
+  (define match-stmt
+    (if glob?
+        "f.basename GLOB :file"
+        "f.basename = :file"))
+
   (define lookup-stmt
-    (sqlite-prepare db "\
+    (sqlite-prepare db (string-append "\
 SELECT p.name, p.version, p.output, d.name, f.name
 FROM Packages p
 INNER JOIN Files f, Directories d
-ON f.basename = :file
+ON " match-stmt "
   AND d.id = f.directory
-  AND p.id = d.package;"))
+  AND p.id = d.package;")))
 
   (define prefix
     (match (sqlite-fold (lambda (value _) value)
@@ -460,11 +467,6 @@ ON f.basename = :file
                           lst))))
                '() lookup-stmt))
 
-(define (matching-packages-with-db db-file file)
-  "Compute list of packages referencing FILE using the database at DB-FILE."
-  (call-with-database db-file
-    (lambda (db) (matching-packages db file))))
-
 (define (print-matching-results matches)
   "Print the MATCHES matching results."
   (for-each (lambda (result)
@@ -488,6 +490,8 @@ ON f.basename = :file
 (define (show-help)
   (display (G_ "Usage: guix locate [OPTIONS...] FILE...
 Locate FILE and return the list of packages that contain it.\n"))
+  (display (G_ "
+  -g, --glob          interpret FILE as a glob pattern"))
   (display (G_ "
   -u, --update        force a database update"))
   (display (G_ "
@@ -512,7 +516,9 @@ Locate FILE and return the list of packages that contain 
it.\n"))
    (option '(#\V "version") #f #f
            (lambda (opt name arg result)
              (show-version-and-exit "guix locate")))
-   ;; index data out of the method (store or package)
+   (option '(#\g "glob") #f #f
+           (lambda (opt name arg result)
+             (alist-cons 'glob? #t result)))
    (option '("database") #f #t
            (lambda (opt name arg result)
              (alist-cons 'database (const arg)
@@ -571,6 +577,7 @@ Locate FILE and return the list of packages that contain 
it.\n"))
                                                        result))))
            (clear?   (assoc-ref opts 'clear?))
            (update?  (assoc-ref opts 'update?))
+           (glob?    (assoc-ref opts 'glob?))
            (database ((assoc-ref opts 'database) update?))
            (method   (assoc-ref opts 'method))
            (files    (reverse (filter-map (match-lambda
@@ -604,9 +611,12 @@ Locate FILE and return the list of packages that contain 
it.\n"))
           (info (G_ "indexing files from ~a...~%") (%store-prefix))
           (populate-database database clear?)))
 
-      (match (append-map (lambda (file)
-                           (matching-packages-with-db database file))
-                         files)
+      (match (call-with-database database
+               (lambda (db)
+                 (append-map (lambda (file)
+                               (matching-packages db file
+                                                  #:glob? glob?))
+                             files)))
         (()
          (if (null? files)
              (unless update?
@@ -616,4 +626,5 @@ Locate FILE and return the list of packages that contain 
it.\n"))
                         (length files))
                     files database)))
         (matches
-         (print-matching-results matches))))))
+         (leave-on-EPIPE
+          (print-matching-results matches)))))))
diff --git a/tests/guix-locate.sh b/tests/guix-locate.sh
index 596d20eb43..d303fcc543 100755
--- a/tests/guix-locate.sh
+++ b/tests/guix-locate.sh
@@ -57,6 +57,9 @@ $cmd_manifests --update
 $cmd_manifests guile | grep "$(guix build guile-bootstrap)/bin/guile"
 $cmd_manifests boot-9.scm | grep ^guile-bootstrap
 
+# Using a glob pattern.
+$cmd_manifests -g '*.scm' | grep "^guile-bootstrap.*boot-9"
+
 if $RUN_EXPENSIVE_TESTS
 then
     $cmd_store