Subject: [PATCH core-updates v2 5/5] man-db: Add support for zstd compressed man pages.

From: Maxim Cournoyer <[email-masked]>
Date: Fri, 5 Jan 2024 14:52:54 -0500

* guix/man-db.scm (<mandb-entry>): Adjust comment.
(abbreviate-file-name): Adjust regexp.
(gz-compressed?, zstd-compressed?): New predicates.
(entry->string): Use them.
(man-page->entry): Adjust doc.  Use input port reader appropriate to the
compression type, if any.
(man-files): Adjust regexp.
(mandb-entries): Adjust link resolving predicate.
* guix/profiles.scm (manual-database): Add guile-zlib extension.

Change-Id: I6336e46e2d324c520a7d15d6cafd12bbf43c5b09
---

(no changes since v1)

 guix/man-db.scm   | 45 +++++++++++++++++++++++++++++++++++----------
 guix/profiles.scm |  8 ++++++--
 2 files changed, 41 insertions(+), 12 deletions(-)

diff --git a/guix/man-db.scm b/guix/man-db.scm
index 7d9707a592..12887ce400 100644
--- a/guix/man-db.scm
+++ b/guix/man-db.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2022, 2024 Maxim Cournoyer <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,6 +19,7 @@
 
 (define-module (guix man-db)
   #:use-module (zlib)
+  #:use-module (zstd)
   #:use-module ((guix build utils) #:select (find-files))
   #:use-module (gdbm)                             ;gdbm-ffi
   #:use-module (srfi srfi-9)
@@ -48,7 +50,7 @@ (define-module (guix man-db)
 (define-record-type <mandb-entry>
   (mandb-entry file-name name section synopsis kind)
   mandb-entry?
-  (file-name mandb-entry-file-name)               ;e.g., "../abiword.1.gz"
+  (file-name mandb-entry-file-name)               ;e.g., "../abiword.1.zst"
   (name      mandb-entry-name)                    ;e.g., "ABIWORD"
   (section   mandb-entry-section)                 ;number
   (synopsis  mandb-entry-synopsis)                ;string
@@ -63,7 +65,7 @@ (define (mandb-entry<? entry1 entry2)
             (string<? (basename file1) (basename file2))))))))
 
 (define abbreviate-file-name
-  (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.gz)?$")))
+  (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.(gz|zst))?$")))
     (lambda (file)
       (match (regexp-exec man-file-rx (basename file))
         (#f
@@ -71,6 +73,14 @@ (define abbreviate-file-name
         (matches
          (match:substring matches 1))))))
 
+(define (gzip-compressed? file-name)
+  "True if FILE-NAME is suffixed with the '.gz' file extension."
+  (string-suffix? ".gz" file-name))
+
+(define (zstd-compressed? file-name)
+  "True if FILE-NAME is suffixed with the '.zst' file extension."
+  (string-suffix? ".zst" file-name))
+
 (define (entry->string entry)
   "Return the wire format for ENTRY as a string."
   (match entry
@@ -92,7 +102,11 @@ (define (entry->string entry)
 
                     "\t-\t-\t"
 
-                    (if (string-suffix? ".gz" file) "gz" "")
+                    (cond
+                     ((gzip-compressed? file) "gz")
+                     ((zstd-compressed? file) "zst")
+                     (else ""))
+
                     "\t"
 
                     synopsis "\x00"))))
@@ -148,7 +162,8 @@ (define (read-synopsis port)
        (loop (cons line lines))))))
 
 (define* (man-page->entry file #:optional (resolve identity))
-  "Parse FILE, a gzipped man page, and return a <mandb-entry> for it."
+  "Parse FILE, a gzip or zstd compressed man page, and return a <mandb-entry>
+for it."
   (define (string->number* str)
     (if (and (string-prefix? "\"" str)
              (> (string-length str) 1)
@@ -156,8 +171,13 @@ (define* (man-page->entry file #:optional (resolve identity))
         (string->number (string-drop (string-drop-right str 1) 1))
         (string->number str)))
 
-  ;; Note: This works for both gzipped and uncompressed files.
-  (call-with-gzip-input-port (open-file file "r0")
+  (define call-with-input-port*
+    (cond
+     ((gzip-compressed? file) call-with-gzip-input-port)
+     ((zstd-compressed? file) call-with-zstd-input-port)
+     (else call-with-port)))
+
+  (call-with-input-port* (open-file file "r0")
     (lambda (port)
       (let loop ((name     #f)
                  (section  #f)
@@ -191,14 +211,19 @@ (define* (man-page->entry file #:optional (resolve identity))
 (define (man-files directory)
   "Return the list of man pages found under DIRECTORY, recursively."
   ;; Filter the list to ensure that broken symlinks are excluded.
-  (filter file-exists? (find-files directory "\\.[0-9][a-z]?(\\.gz)?$")))
+  (filter file-exists?
+          (find-files directory "\\.[0-9][a-z]?(\\.(gz|zst))?$")))
 
 (define (mandb-entries directory)
   "Return mandb entries for the man pages found under DIRECTORY, recursively."
   (map (lambda (file)
          (man-page->entry file
                           (lambda (link)
-                            (let ((file (string-append directory "/" link
-                                                       ".gz")))
-                              (and (file-exists? file) file)))))
+                            (let ((file-gz (string-append directory "/" link
+                                                          ".gz"))
+                                  (file-zst (string-append directory "/" link
+                                                           ".zst")))
+                              (and (or (file-exists? file-gz)
+                                       (file-exists? file-zst) file)
+                                   file)))))
        (man-files directory)))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index da7790d819..7fa5dab62a 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -7,7 +7,7 @@
 ;;; Copyright © 2016, 2017, 2018, 2019, 2021, 2022 Ricardo Wurmus <[email-masked]>
 ;;; Copyright © 2016 Chris Marusich <[email-masked]>
 ;;; Copyright © 2017 Huang Ying <[email-masked]>
-;;; Copyright © 2017, 2021 Maxim Cournoyer <[email-masked]>
+;;; Copyright © 2017, 2021, 2024 Maxim Cournoyer <[email-masked]>
 ;;; Copyright © 2019 Kyle Meyer <[email-masked]>
 ;;; Copyright © 2019 Mathieu Othacehe <[email-masked]>
 ;;; Copyright © 2020 Danny Milosavljevic <[email-masked]>
@@ -1701,6 +1701,9 @@ (define* (manual-database manifest #:optional system)
   (define guile-zlib
     (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
 
+  (define guile-zstd
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-zstd))
+
   (define modules
     (delete '(guix config)
             (source-module-closure `((guix build utils)
@@ -1709,7 +1712,8 @@ (define* (manual-database manifest #:optional system)
   (define build
     (with-imported-modules modules
       (with-extensions (list gdbm-ffi           ;for (guix man-db)
-                             guile-zlib)
+                             guile-zlib
+                             guile-zstd)
         #~(begin
             (use-modules (guix man-db)
                          (guix build utils)
-- 
2.41.0