02/02: import/texlive: Add helper to check installed files.

[guix-commits]

rekado pushed a commit to branch master
in repository guix.

commit 5ecb4acdcb95478c6efe63bf9caa4db6bda82aba
Author: Ricardo Wurmus <rekado@elephly.net>
AuthorDate: Thu Jan 20 22:55:55 2022 +0100

    import/texlive: Add helper to check installed files.
    
    * guix/import/texlive.scm (files-differ?): New procedure.
---
 guix/import/texlive.scm | 42 +++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 41 insertions(+), 1 deletion(-)

diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index 77b3c6380c..c741555928 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -18,6 +18,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix import texlive)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
@@ -38,7 +39,8 @@
   #:use-module (guix upstream)
   #:use-module (guix packages)
   #:use-module (guix build-system texlive)
-  #:export (texlive->guix-package
+  #:export (files-differ?
+            texlive->guix-package
             texlive-recursive-import))
 
 ;;; Commentary:
@@ -196,6 +198,44 @@
                          (loop all (record key value current field-type) 
key))))
                      (loop all current #false))))))))))))
 
+(define* (files-differ? directory package-name
+                        #:key
+                        (package-database tlpdb)
+                        (type #false)
+                        (direction 'missing))
+  "Return a list of files in DIRECTORY that differ from the expected installed
+files for PACKAGE-NAME according to the PACKAGE-DATABASE.  By default all
+files considered, but this can be restricted by setting TYPE to 'runfiles,
+'docfiles, or 'srcfiles.  The names of files that are missing from DIRECTORY
+are returned; by setting DIRECTION to anything other than 'missing, the names
+of those files are returned that are unexpectedly installed."
+  (define (strip-directory-prefix file-name)
+    (string-drop file-name (1+ (string-length directory))))
+  (let* ((data (or (assoc-ref (package-database) package-name)
+                   (error (format #false
+                                  "~a is not a valid package name in the TeX 
Live package database."
+                                  package-name))))
+         (files (if type
+                    (or (assoc-ref data type) (list))
+                    (append (or (assoc-ref data 'runfiles) (list))
+                            (or (assoc-ref data 'docfiles) (list))
+                            (or (assoc-ref data 'srcfiles) (list)))))
+         (existing (file-system-fold
+                    (const #true)                             ;enter?
+                    (lambda (path stat result) (cons path result)) ;leaf
+                    (lambda (path stat result) result)             ;down
+                    (lambda (path stat result) result)             ;up
+                    (lambda (path stat result) result)             ;skip
+                    (lambda (path stat errno result) result)       ;error
+                    (list)
+                    directory)))
+    (if (eq? direction 'missing)
+        (lset-difference string=?
+                         files (map strip-directory-prefix existing))
+        ;; List files that are installed but should not be.
+        (lset-difference string=?
+                         (map strip-directory-prefix existing) files))))
+
 (define (files->directories files)
   (define name->parts (cut string-split <> #\/))
   (map (cut string-join <> "/" 'suffix)