Commit | Line | Data |
---|---|---|
b8396f96 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix man-db) | |
20 | #:use-module (guix zlib) | |
21 | #:use-module ((guix build utils) #:select (find-files)) | |
22 | #:use-module (srfi srfi-9) | |
23 | #:use-module (srfi srfi-26) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (ice-9 rdelim) | |
26 | #:use-module (ice-9 regex) | |
27 | #:export (mandb-entry? | |
28 | mandb-entry-file-name | |
29 | mandb-entry-name | |
30 | mandb-entry-section | |
31 | mandb-entry-synopsis | |
32 | mandb-entry-kind | |
33 | ||
34 | mandb-entries | |
35 | write-mandb-database)) | |
36 | ||
37 | ;;; Comment: | |
38 | ;;; | |
39 | ;;; Scan gzipped man pages and create a man-db database. The database is | |
40 | ;;; meant to be used by 'man -k KEYWORD'. | |
41 | ;;; | |
42 | ;;; The implementation here aims to be simpler than that of 'man-db', and to | |
43 | ;;; produce deterministic output. See <https://bugs.gnu.org/29654>. | |
44 | ;;; | |
45 | ;;; Code: | |
46 | ||
47 | ;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co. | |
16613d23 | 48 | (module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT)) |
b8396f96 LC |
49 | |
50 | (define-record-type <mandb-entry> | |
51 | (mandb-entry file-name name section synopsis kind) | |
52 | mandb-entry? | |
53 | (file-name mandb-entry-file-name) ;e.g., "../abiword.1.gz" | |
54 | (name mandb-entry-name) ;e.g., "ABIWORD" | |
55 | (section mandb-entry-section) ;number | |
56 | (synopsis mandb-entry-synopsis) ;string | |
57 | (kind mandb-entry-kind)) ;'ultimate | 'link | |
58 | ||
59 | (define (mandb-entry<? entry1 entry2) | |
60 | (match entry1 | |
61 | (($ <mandb-entry> file1 name1 section1) | |
62 | (match entry2 | |
63 | (($ <mandb-entry> file2 name2 section2) | |
64 | (or (< section1 section2) | |
65 | (string<? (basename file1) (basename file2)))))))) | |
66 | ||
67 | (define abbreviate-file-name | |
68 | (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.gz)?$"))) | |
69 | (lambda (file) | |
70 | (match (regexp-exec man-file-rx (basename file)) | |
71 | (#f | |
72 | (basename file)) | |
73 | (matches | |
74 | (match:substring matches 1)))))) | |
75 | ||
76 | (define (entry->string entry) | |
77 | "Return the wire format for ENTRY as a string." | |
78 | (match entry | |
79 | (($ <mandb-entry> file name section synopsis kind) | |
80 | ;; See db_store.c:make_content in man-db for the format. | |
81 | (string-append (abbreviate-file-name file) "\t" | |
82 | (number->string section) "\t" | |
83 | (number->string section) | |
84 | ||
85 | ;; Timestamp that we always set to the epoch. | |
86 | "\t0\t0" | |
87 | ||
88 | ;; See "db_storage.h" in man-db for the different kinds. | |
89 | "\t" | |
90 | (case kind | |
91 | ((ultimate) "A") ;ultimate man page | |
92 | ((link) "B") ;".so" link to other man page | |
93 | (else "A")) ;something that doesn't matter much | |
94 | ||
95 | "\t-\t-\t" | |
96 | ||
97 | (if (string-suffix? ".gz" file) "gz" "") | |
98 | "\t" | |
99 | ||
100 | synopsis "\x00")))) | |
101 | ||
102 | ;; The man-db schema version we're compatible with. | |
103 | (define %version-key "$version$\x00") | |
104 | (define %version-value "2.5.0\x00") | |
105 | ||
106 | (define (write-mandb-database file entries) | |
107 | "Write ENTRIES to FILE as a man-db database. FILE is usually | |
108 | \".../index.db\", and is a GDBM database." | |
109 | (let ((db (gdbm-open file GDBM_WRCREAT))) | |
110 | (gdbm-set! db %version-key %version-value) | |
111 | ||
112 | ;; Write ENTRIES in sorted order so we get deterministic output. | |
113 | (for-each (lambda (entry) | |
114 | (gdbm-set! db | |
115 | (string-append (mandb-entry-file-name entry) | |
116 | "\x00") | |
117 | (entry->string entry))) | |
118 | (sort entries mandb-entry<?)) | |
119 | (gdbm-close db))) | |
120 | ||
121 | (define (read-synopsis port) | |
122 | "Read from PORT a man page synopsis." | |
123 | (define (section? line) | |
124 | ;; True if LINE starts with ".SH", ".PP", or so. | |
125 | (string-prefix? "." (string-trim line))) | |
126 | ||
127 | (define (extract-synopsis str) | |
128 | (match (string-contains str "\\-") | |
129 | (#f "") | |
130 | (index | |
131 | (string-map (match-lambda | |
132 | (#\newline #\space) | |
133 | (chr chr)) | |
134 | (string-trim-both (string-drop str (+ 2 index))))))) | |
135 | ||
136 | ;; Synopses look like "Command \- Do something.", possibly spanning several | |
137 | ;; lines. | |
138 | (let loop ((lines '())) | |
139 | (match (read-line port 'concat) | |
140 | ((? eof-object?) | |
141 | (extract-synopsis (string-concatenate-reverse lines))) | |
142 | ((? section?) | |
143 | (extract-synopsis (string-concatenate-reverse lines))) | |
144 | (line | |
145 | (loop (cons line lines)))))) | |
146 | ||
147 | (define* (man-page->entry file #:optional (resolve identity)) | |
148 | "Parse FILE, a gzipped man page, and return a <mandb-entry> for it." | |
149 | (define (string->number* str) | |
150 | (if (and (string-prefix? "\"" str) | |
151 | (> (string-length str) 1) | |
152 | (string-suffix? "\"" str)) | |
153 | (string->number (string-drop (string-drop-right str 1) 1)) | |
154 | (string->number str))) | |
155 | ||
156 | ;; Note: This works for both gzipped and uncompressed files. | |
157 | (call-with-gzip-input-port (open-file file "r0") | |
158 | (lambda (port) | |
159 | (let loop ((name #f) | |
160 | (section #f) | |
161 | (synopsis #f) | |
162 | (kind 'ultimate)) | |
163 | (if (and name section synopsis) | |
164 | (mandb-entry file name section synopsis kind) | |
165 | (let ((line (read-line port))) | |
166 | (if (eof-object? line) | |
167 | (mandb-entry file name (or section 0) (or synopsis "") | |
168 | kind) | |
169 | (match (string-tokenize line) | |
170 | ((".TH" name (= string->number* section) _ ...) | |
171 | (loop name section synopsis kind)) | |
172 | ((".SH" (or "NAME" "\"NAME\"")) | |
173 | (loop name section (read-synopsis port) kind)) | |
174 | ((".so" link) | |
175 | (match (and=> (resolve link) | |
176 | (cut man-page->entry <> resolve)) | |
177 | (#f | |
178 | (loop name section synopsis 'link)) | |
179 | (alias | |
180 | (mandb-entry file | |
181 | (mandb-entry-name alias) | |
182 | (mandb-entry-section alias) | |
183 | (mandb-entry-synopsis alias) | |
184 | 'link)))) | |
185 | (_ | |
186 | (loop name section synopsis kind)))))))))) | |
187 | ||
188 | (define (man-files directory) | |
189 | "Return the list of man pages found under DIRECTORY, recursively." | |
47ebb1a8 RW |
190 | ;; Filter the list to ensure that broken symlinks are excluded. |
191 | (filter file-exists? (find-files directory "\\.[0-9][a-z]?(\\.gz)?$"))) | |
b8396f96 LC |
192 | |
193 | (define (mandb-entries directory) | |
194 | "Return mandb entries for the man pages found under DIRECTORY, recursively." | |
195 | (map (lambda (file) | |
196 | (man-page->entry file | |
197 | (lambda (link) | |
198 | (let ((file (string-append directory "/" link | |
199 | ".gz"))) | |
200 | (and (file-exists? file) file))))) | |
201 | (man-files directory))) |