bug#13160: 24.3.50; [PATCH] man page completion support beyond man-db

[Wolfgang Jenkner <wjenkner@inode.at>]

On Mon, Dec 24 2012, Stefan Monnier wrote:

> We could replace it with a boolean var like `Man--k-anchor-broken',
> since I think it's a bug for "man -k ^foo" to not match commands that
> start with a "foo" prefix.

With a different name:

-- >8 --
Subject: [PATCH] Support man page completion for more man programs. *
 lisp/man.el (Man-parse-man-k): New function. (Man-man-k-use-anchor): New
 variable. (Man-completion-table): Use them to replace man-db specific code
 for parsing `man -k' output.

* test/automated/man-tests.el: New file.
---
 lisp/man.el                 |  75 +++++++++++++++++++++++-----
 test/automated/man-tests.el | 118 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 182 insertions(+), 11 deletions(-)
 create mode 100644 test/automated/man-tests.el

diff --git a/lisp/man.el b/lisp/man.el
index 8210d63..ee3f507 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -780,6 +780,56 @@ POS defaults to `point'."
   ;; but apparently that's not the case in all cases, so let's add a cache.
   "Cache of completion table of the form (PREFIX . TABLE).")
 
+(defvar Man-man-k-use-anchor
+  ;; man-db or man-1.*
+  (memq system-type '(gnu gnu/linux gnu/kfreebsd))
+  "If non-nil prepend ^ to the prefix passed to \"man -k\" for completion.
+The value should be nil if \"man -k ^PREFIX\" may omit some man
+pages whose names start with PREFIX.
+
+Currently, the default value depends on `system-type' and is
+non-nil where the standard man programs are known to behave
+properly.  Setting the value to nil always gives correct results
+but computing the list of completions may take a bit longer.")
+
+(defun Man-parse-man-k ()
+  "Parse \"man -k\" output and return the list of page names.
+
+The current buffer should contain the output of a command of the
+form \"man -k keyword\", which is traditionally also available with
+apropos(1).
+
+While POSIX man(1p) is a bit vague about what to expect here,
+this function tries to parse some commonly used formats, which
+can be described in the following informal way, with square brackets
+indicating optional parts and whitespace being interpreted
+somewhat loosely.
+
+foo[, bar [, ...]] [other stuff] (sec) - description
+foo(sec)[, bar(sec) [, ...]] [other stuff] - description
+
+For more details and some regression tests, please see
+test/automated/man-tests.el in the emacs bzr repository."
+  (goto-char (point-min))
+  (let (table)
+    (while (search-forward-regexp "^\\([^ \t,\n]+\\)\\(.*?\\)\
+\\(?:[ \t]\\(([^ \t,\n]+?)\\)\\)?\\(?:[ \t]+- ?\\(.*\\)\\)?$" nil t)
+      (let ((section (match-string 3))
+	    (description (match-string 4))
+	    (bound (match-end 2))
+	    (continue (goto-char (match-end 1))))
+	(while continue
+	  ;; The first regexp grouping may already match the section
+	  ;; tacked on to the name, which is ok since for the formats we
+	  ;; claim to support the third (non-shy) grouping does not
+	  ;; match in this case, i.e., section is nil.
+	  (push (propertize (concat (match-string 1) section)
+			    'help-echo description)
+		table)
+	  (setq continue (search-forward-regexp "\\=, *\\([^ \t,]+\\)"
+						bound t)))))
+    (nreverse table)))
+
 (defun Man-completion-table (string pred action)
   (cond
    ;; This ends up returning t for pretty much any string, and hence leads to
@@ -811,17 +861,20 @@ POS defaults to `point'."
             ;; run differently in Man-getpage-in-background, an error
             ;; here may not necessarily mean that we'll also get an
             ;; error later.
-            (ignore-errors
-              (call-process manual-program nil '(t nil) nil
-                            "-k" (concat "^" prefix))))
-          (goto-char (point-min))
-          (setq table nil)
-          (while (re-search-forward "^\\([^ \t\n]+\\)\\(?: ?\\((.+?)\\)\\(?:[ \t]+- \\(.*\\)\\)?\\)?" nil t)
-            (push (propertize (concat (match-string 1) (match-string 2))
-                              'help-echo (match-string 3))
-                  table)))
-        ;; Cache the table for later reuse.
-        (setq Man-completion-cache (cons prefix table)))
+	    (ignore-errors
+	      (call-process manual-program nil '(t nil) nil
+			    "-k" (concat (when (or Man-man-k-use-anchor
+						   (string-equal prefix ""))
+					   "^")
+					 prefix))))
+	  (setq table (Man-parse-man-k)))
+	(unless Man-man-k-use-anchor
+	  ;; Weed out unwanted page names.
+	  (dolist (comp (prog1 table (setq table nil)))
+	    (if (string-prefix-p prefix comp)
+		(push comp table))))
+	;; Cache the table for later reuse.
+	(setq Man-completion-cache (cons prefix table)))
       ;; The table may contain false positives since the match is made
       ;; by "man -k" not just on the manpage's name.
       (if section
diff --git a/test/automated/man-tests.el b/test/automated/man-tests.el
new file mode 100644
index 0000000..8a2ec95
--- /dev/null
+++ b/test/automated/man-tests.el
@@ -0,0 +1,118 @@
+;;; man-tests.el --- Test suite for man.
+
+;; Copyright (C) 2013  Free Software Foundation, Inc.
+
+;; Author: Wolfgang Jenkner <wjenkner@inode.at>
+;; Keywords: help, internal, unix
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'man)
+
+(defconst man-tests-parse-man-k-tests
+  '(;; GNU/Linux: man-db-2.6.1
+    ("\
+sin (3)              - sine function
+sinf (3)             - sine function
+sinl (3)             - sine function"
+     . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function"))))
+    ;; GNU/Linux: man-1.6g
+    ("\
+sin                  (3)  - sine function
+sinf [sin]           (3)  - sine function
+sinl [sin]           (3)  - sine function"
+     . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function"))))
+    ;; FreeBSD 9
+    ("\
+sin(3), sinf(3), sinl(3) - sine functions"
+     . (#("sin(3)" 0 6 (help-echo "sine functions")) #("sinf(3)" 0 7 (help-echo "sine functions")) #("sinl(3)" 0 7 (help-echo "sine functions"))))
+    ;; SunOS, Solaris
+    ;; http://docs.oracle.com/cd/E19455-01/805-6331/usradm-7/index.html
+    ;; SunOS 4
+    ("\
+tset, reset (1)    - establish or restore terminal characteristics"
+     . (#("tset(1)" 0 7 (help-echo "establish or restore terminal characteristics")) #("reset(1)" 0 8 (help-echo "establish or restore terminal characteristics"))))
+    ;; SunOS 5.7, Solaris
+    ("\
+reset  tset (1b)   - establish or restore terminal characteristics
+tset   tset (1b)   - establish or restore terminal characteristics"
+     . (#("reset(1b)" 0 8 (help-echo "establish or restore terminal characteristics")) #("tset(1b)" 0 7 (help-echo "establish or restore terminal characteristics"))))
+    ;; Minix 3
+    ;; http://www.minix3.org/manpages/html5/whatis.html
+    ("\
+cawf, nroff (1) - C version of the nroff-like, Amazingly Workable (text) Formatter
+whatis (5) - database of online manual pages"
+     . (#("cawf(1)" 0 7 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("nroff(1)" 0 8 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("whatis(5)" 0 9 (help-echo "database of online manual pages"))))
+    ;; HP-UX
+    ;; http://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/man.1.html
+    ;; Assuming that the line break in the zgrep description was
+    ;; introduced by the man page formatting.
+    ("\
+grep, egrep, fgrep (1) - search a file for a pattern
+zgrep(1) - search possibly compressed files for a regular expression"
+     . (#("grep(1)" 0 7 (help-echo "search a file for a pattern")) #("egrep(1)" 0 8 (help-echo "search a file for a pattern")) #("fgrep(1)" 0 8 (help-echo "search a file for a pattern")) #("zgrep(1)" 0 8 (help-echo "search possibly compressed files for a regular expression"))))
+    ;; AIX
+    ;; http://pic.dhe.ibm.com/infocenter/aix/v7r1/topic/com.ibm.aix.cmds/doc/aixcmds6/whatis.htm
+    ("\
+ls(1)  -Displays the contents of a directory."
+    . (#("ls(1)" 0 5 (help-echo "Displays the contents of a directory."))))
+    ;; https://www.ibm.com/developerworks/mydeveloperworks/blogs/cgaix/entry/catman_0703_102_usr_lbin_mkwhatis_the_error_number_is_1?lang=en
+    ("\
+loopmount(1)    - Associate an image file to a loopback device."
+     . (#("loopmount(1)" 0 12 (help-echo "Associate an image file to a loopback device."))))
+    )
+  "List of tests for `Man-parse-man-k'.
+Each element is a cons cell whose car is a string containing
+man -k output.  That should result in the table which is stored
+in the cdr of the element.")
+
+(defun man-tests-name-equal-p (name description string)
+  (and (equal name string)
+       (not (next-single-property-change 0 'help-echo string))
+       (equal (get-text-property 0 'help-echo string) description)))
+
+(defun man-tests-parse-man-k-test-case (test)
+  (let ((temp-buffer (get-buffer-create " *test-man*"))
+	(man-k-output (car test)))
+    (unwind-protect
+	(save-window-excursion
+	  (with-current-buffer temp-buffer
+	    (erase-buffer)
+	    (insert man-k-output)
+	    (let ((result (Man-parse-man-k))
+		  (checklist (cdr test)))
+	      (while (and checklist result
+			  (man-tests-name-equal-p
+			   (car checklist)
+			   (get-text-property 0 'help-echo
+					      (car checklist))
+			   (pop result)))
+		(pop checklist))
+	      (and (null checklist) (null result)))))
+      (and (buffer-name temp-buffer)
+	   (kill-buffer temp-buffer)))))
+
+(ert-deftest man-tests ()
+  "Test man."
+  (dolist (test man-tests-parse-man-k-tests)
+    (should (man-tests-parse-man-k-test-case test))))
+
+(provide 'man-tests)
+
+;;; man-tests.el ends here
-- 
1.8.0.2