X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/5725bd2cc0e691dadc31bd958f210b1bbcf17c49..daddb3fd8355bce563d1b70eb372d978db912704:/lisp/man.el diff --git a/lisp/man.el b/lisp/man.el index 6b1b9dc042..a03fda5e6b 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1,7 +1,7 @@ -;;; man.el --- browse UNIX manual pages -*- coding: iso-8859-1 -*- +;;; man.el --- browse UNIX manual pages -*- coding: utf-8 -*- -;; Copyright (C) 1993-1994, 1996-1997, 2001-2012 -;; Free Software Foundation, Inc. +;; Copyright (C) 1993-1994, 1996-1997, 2001-2013 Free Software +;; Foundation, Inc. ;; Author: Barry A. Warsaw ;; Maintainer: FSF @@ -55,7 +55,7 @@ ;; point and some other names have been changed to make it a drop-in ;; replacement for the old man.el package. -;; Francesco Potorti` cleaned it up thoroughly, +;; Francesco Potortì cleaned it up thoroughly, ;; making it faster, more robust and more tolerant of different ;; systems' man idiosyncrasies. @@ -88,6 +88,8 @@ ;;; Code: +(require 'ansi-color) +(require 'cl-lib) (require 'button) (defgroup man nil @@ -124,20 +126,29 @@ the manpage buffer." :type 'boolean :group 'man) -(defcustom Man-overstrike-face 'bold +(defface Man-overstrike + '((t (:inherit bold))) "Face to use when fontifying overstrike." - :type 'face - :group 'man) + :group 'man + :version "24.3") -(defcustom Man-underline-face 'underline +(defface Man-underline + '((t (:inherit underline))) "Face to use when fontifying underlining." - :type 'face - :group 'man) + :group 'man + :version "24.3") -(defcustom Man-reverse-face 'highlight +(defface Man-reverse + '((t (:inherit highlight))) "Face to use when fontifying reverse video." - :type 'face - :group 'man) + :group 'man + :version "24.3") + +(defvar Man-ansi-color-map (let ((ansi-color-faces-vector + [ default Man-overstrike default Man-underline + Man-underline default default Man-reverse ])) + (ansi-color-make-color-map)) + "The value used here for `ansi-color-map'.") ;; Use the value of the obsolete user option Man-notify, if set. (defcustom Man-notify-method (if (boundp 'Man-notify) Man-notify 'friendly) @@ -266,7 +277,7 @@ Used in `bookmark-set' to get the default bookmark name." :type 'hook :group 'man) -(defvar Man-name-regexp "[-a-zA-Z0-9_­+][-a-zA-Z0-9_.:­+]*" +(defvar Man-name-regexp "[-a-zA-Z0-9_­+][-a-zA-Z0-9_.:­+]*" "Regular expression describing the name of a manpage (without section).") (defvar Man-section-regexp "[0-9][a-zA-Z0-9+]*\\|[LNln]" @@ -358,6 +369,12 @@ specified subject, if your `man' program supports it." Otherwise, the value is whatever the function `Man-support-local-filenames' should return.") +(defcustom man-imenu-title "Contents" + "The title to use if man adds a Contents menu to the menubar." + :version "24.4" + :type 'string + :group 'man) + ;; other variables and keymap initializations (defvar Man-original-frame) @@ -403,7 +420,7 @@ Otherwise, the value is whatever the function (defvar Man-topic-history nil "Topic read history.") -(defvar man-mode-syntax-table +(defvar Man-mode-syntax-table (let ((table (copy-syntax-table (standard-syntax-table)))) (modify-syntax-entry ?. "w" table) (modify-syntax-entry ?_ "w" table) @@ -416,6 +433,7 @@ Otherwise, the value is whatever the function (suppress-keymap map) (set-keymap-parent map button-buffer-map) + (define-key map [?\S-\ ] 'scroll-down-command) (define-key map " " 'scroll-up-command) (define-key map "\177" 'scroll-down-command) (define-key map "n" 'Man-next-section) @@ -430,11 +448,34 @@ Otherwise, the value is whatever the function (define-key map "s" 'Man-goto-see-also-section) (define-key map "k" 'Man-kill) (define-key map "q" 'Man-quit) + (define-key map "u" 'Man-update-manpage) (define-key map "m" 'man) ;; Not all the man references get buttons currently. The text in the ;; manual page can contain references to other man pages (define-key map "\r" 'man-follow) (define-key map "?" 'describe-mode) + + (easy-menu-define nil map + "`Man-mode' menu." + '("Man" + ["Next Section" Man-next-section t] + ["Previous Section" Man-previous-section t] + ["Go To Section..." Man-goto-section t] + ["Go To \"SEE ALSO\" Section" Man-goto-see-also-section + :active (cl-member Man-see-also-regexp Man--sections + :test #'string-match-p)] + ["Follow Reference..." Man-follow-manual-reference + :active Man--refpages + :help "Go to a manpage referred to in the \"SEE ALSO\" section"] + "--" + ["Next Manpage" Man-next-manpage + :active (> (length Man-page-list) 1)] + ["Previous Manpage" Man-previous-manpage + :active (> (length Man-page-list) 1)] + "--" + ["Man..." man t] + ["Kill Buffer" Man-kill t] + ["Quit" Man-quit t])) map) "Keymap for Man mode.") @@ -741,7 +782,7 @@ POS defaults to `point'." (setq word (concat word (match-string-no-properties 1))) ;; Make sure the section number gets included by the code below. (goto-char (match-end 1))) - (when (string-match "[._]+$" word) + (when (string-match "[-._]+$" word) (setq word (substring word 0 (match-beginning 0)))) ;; The following was commented out since the preceding code ;; should not produce a leading "*" in the first place. @@ -770,6 +811,59 @@ 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)) + ;; See man-tests for data about which systems use which format (hopefully we + ;; will be able to simplify the code if/when some of those formats aren't + ;; used any more). + (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))) + (goto-char (match-end 1)) + (while + (progn + ;; 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) + (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 @@ -801,16 +895,15 @@ 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)) - (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))) + ;; 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 @@ -881,6 +974,7 @@ names or descriptions. The pattern argument is usually an ;; ("man -k" is case-insensitive similarly, so the ;; table has everything available to complete) (completion-ignore-case t) + Man-completion-cache ;Don't cache across calls. (input (completing-read (format "Manual entry%s" (if (string= default-entry "") @@ -907,6 +1001,52 @@ names or descriptions. The pattern argument is usually an (error "No item under point") (man man-args))) +(defmacro Man-start-calling (&rest body) + "Start the man command in `body' after setting up the environment" + `(let ((process-environment (copy-sequence process-environment)) + ;; The following is so Awk script gets \n intact + ;; But don't prevent decoding of the outside. + (coding-system-for-write 'raw-text-unix) + ;; We must decode the output by a coding system that the + ;; system's locale suggests in multibyte mode. + (coding-system-for-read locale-coding-system) + ;; Avoid possible error by using a directory that always exists. + (default-directory + (if (and (file-directory-p default-directory) + (not (find-file-name-handler default-directory + 'file-directory-p))) + default-directory + "/"))) + ;; Prevent any attempt to use display terminal fanciness. + (setenv "TERM" "dumb") + ;; In Debian Woody, at least, we get overlong lines under X + ;; unless COLUMNS or MANWIDTH is set. This isn't a problem on + ;; a tty. man(1) says: + ;; MANWIDTH + ;; If $MANWIDTH is set, its value is used as the line + ;; length for which manual pages should be formatted. + ;; If it is not set, manual pages will be formatted + ;; with a line length appropriate to the current ter- + ;; minal (using an ioctl(2) if available, the value of + ;; $COLUMNS, or falling back to 80 characters if nei- + ;; ther is available). + (when (or window-system + (not (or (getenv "MANWIDTH") (getenv "COLUMNS")))) + ;; This isn't strictly correct, since we don't know how + ;; the page will actually be displayed, but it seems + ;; reasonable. + (setenv "COLUMNS" (number-to-string + (cond + ((and (integerp Man-width) (> Man-width 0)) + Man-width) + (Man-width (frame-width)) + ((window-width)))))) + ;; Since man-db 2.4.3-1, man writes plain text with no escape + ;; sequences when stdout is not a tty. In 2.5.0, the following + ;; env-var was added to allow control of this (see Debian Bug#340673). + (setenv "MAN_KEEP_FORMATTING" "1") + ,@body)) + (defun Man-getpage-in-background (topic) "Use TOPIC to build and fire off the manpage and cleaning command. Return the buffer in which the manpage will appear." @@ -922,52 +1062,8 @@ Return the buffer in which the manpage will appear." (setq buffer-undo-list t) (setq Man-original-frame (selected-frame)) (setq Man-arguments man-args)) - (let ((process-environment (copy-sequence process-environment)) - ;; The following is so Awk script gets \n intact - ;; But don't prevent decoding of the outside. - (coding-system-for-write 'raw-text-unix) - ;; We must decode the output by a coding system that the - ;; system's locale suggests in multibyte mode. - (coding-system-for-read - (if (default-value 'enable-multibyte-characters) - locale-coding-system 'raw-text-unix)) - ;; Avoid possible error by using a directory that always exists. - (default-directory - (if (and (file-directory-p default-directory) - (not (find-file-name-handler default-directory - 'file-directory-p))) - default-directory - "/"))) - ;; Prevent any attempt to use display terminal fanciness. - (setenv "TERM" "dumb") - ;; In Debian Woody, at least, we get overlong lines under X - ;; unless COLUMNS or MANWIDTH is set. This isn't a problem on - ;; a tty. man(1) says: - ;; MANWIDTH - ;; If $MANWIDTH is set, its value is used as the line - ;; length for which manual pages should be formatted. - ;; If it is not set, manual pages will be formatted - ;; with a line length appropriate to the current ter- - ;; minal (using an ioctl(2) if available, the value of - ;; $COLUMNS, or falling back to 80 characters if nei- - ;; ther is available). - (when (or window-system - (not (or (getenv "MANWIDTH") (getenv "COLUMNS")))) - ;; This isn't strictly correct, since we don't know how - ;; the page will actually be displayed, but it seems - ;; reasonable. - (setenv "COLUMNS" (number-to-string - (cond - ((and (integerp Man-width) (> Man-width 0)) - Man-width) - (Man-width (frame-width)) - ((window-width)))))) - (setenv "GROFF_NO_SGR" "1") - ;; Since man-db 2.4.3-1, man writes plain text with no escape - ;; sequences when stdout is not a tty. In 2.5.0, the following - ;; env-var was added to allow control of this (see Debian Bug#340673). - (setenv "MAN_KEEP_FORMATTING" "1") - (if (fboundp 'start-process) + (Man-start-calling + (if (fboundp 'start-process) (set-process-sentinel (start-process manual-program buffer (if (memq system-type '(cygwin windows-nt)) @@ -989,7 +1085,34 @@ Return the buffer in which the manpage will appear." exit-status))) (setq msg exit-status)) (Man-bgproc-sentinel bufname msg))))) - buffer)) + buffer)) + +(defun Man-update-manpage () + "Reformat current manpage by calling the man command again synchronously." + (interactive) + (when (eq Man-arguments nil) + ;;this shouldn't happen unless it is not in a Man buffer." + (error "Man-arguments not initialized")) + (let ((old-pos (point)) + (text (current-word)) + (old-size (buffer-size)) + (inhibit-read-only t) + (buffer-read-only nil)) + (erase-buffer) + (Man-start-calling + (call-process shell-file-name nil (list (current-buffer) nil) nil + shell-command-switch + (format (Man-build-man-command) Man-arguments))) + (if Man-fontify-manpage-flag + (Man-fontify-manpage) + (Man-cleanup-manpage)) + (goto-char old-pos) + ;;restore the point, not strictly right. + (unless (or (eq text nil) (= old-size (buffer-size))) + (let ((case-fold-search nil)) + (if (> old-size (buffer-size)) + (search-backward text nil t)) + (search-forward text nil t))))) (defun Man-notify-when-ready (man-buffer) "Notify the user when MAN-BUFFER is ready. @@ -1050,38 +1173,12 @@ Same for the ANSI bold and normal escape sequences." (message "Please wait: formatting the %s man page..." Man-arguments) (goto-char (point-min)) ;; Fontify ANSI escapes. - (let ((faces nil) - (buffer-undo-list t) - (start (point))) - ;; http://www.isthe.com/chongo/tech/comp/ansi_escapes.html - ;; suggests many codes, but we only handle: - ;; ESC [ 00 m reset to normal display - ;; ESC [ 01 m bold - ;; ESC [ 04 m underline - ;; ESC [ 07 m reverse-video - ;; ESC [ 22 m no-bold - ;; ESC [ 24 m no-underline - ;; ESC [ 27 m no-reverse-video - (while (re-search-forward "\e\\[0?\\([1470]\\|2\\([247]\\)\\)m" nil t) - (if faces (put-text-property start (match-beginning 0) 'face - (if (cdr faces) faces (car faces)))) - (setq faces - (cond - ((match-beginning 2) - (delq (pcase (char-after (match-beginning 2)) - (?2 Man-overstrike-face) - (?4 Man-underline-face) - (?7 Man-reverse-face)) - faces)) - ((eq (char-after (match-beginning 1)) ?0) nil) - (t - (cons (pcase (char-after (match-beginning 1)) - (?1 Man-overstrike-face) - (?4 Man-underline-face) - (?7 Man-reverse-face)) - faces)))) - (delete-region (match-beginning 0) (match-end 0)) - (setq start (point)))) + (let ((ansi-color-apply-face-function + (lambda (beg end face) + (when face + (put-text-property beg end 'face face)))) + (ansi-color-map Man-ansi-color-map)) + (ansi-color-apply-on-region (point-min) (point-max))) ;; Other highlighting. (let ((buffer-undo-list t)) (if (< (buffer-size) (position-bytes (point-max))) @@ -1090,23 +1187,23 @@ Same for the ANSI bold and normal escape sequences." (goto-char (point-min)) (while (search-forward "__\b\b" nil t) (backward-delete-char 4) - (put-text-property (point) (1+ (point)) 'face Man-underline-face)) + (put-text-property (point) (1+ (point)) 'face 'Man-underline)) (goto-char (point-min)) (while (search-forward "\b\b__" nil t) (backward-delete-char 4) - (put-text-property (1- (point)) (point) 'face Man-underline-face)))) + (put-text-property (1- (point)) (point) 'face 'Man-underline)))) (goto-char (point-min)) (while (search-forward "_\b" nil t) (backward-delete-char 2) - (put-text-property (point) (1+ (point)) 'face Man-underline-face)) + (put-text-property (point) (1+ (point)) 'face 'Man-underline)) (goto-char (point-min)) (while (search-forward "\b_" nil t) (backward-delete-char 2) - (put-text-property (1- (point)) (point) 'face Man-underline-face)) + (put-text-property (1- (point)) (point) 'face 'Man-underline)) (goto-char (point-min)) (while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t) (replace-match "\\1") - (put-text-property (1- (point)) (point) 'face Man-overstrike-face)) + (put-text-property (1- (point)) (point) 'face 'Man-overstrike)) (goto-char (point-min)) (while (re-search-forward "o\b\\+\\|\\+\bo" nil t) (replace-match "o") @@ -1117,7 +1214,7 @@ Same for the ANSI bold and normal escape sequences." (put-text-property (1- (point)) (point) 'face 'bold)) ;; When the header is longer than the manpage name, groff tries to ;; condense it to a shorter line interspersed with ^H. Remove ^H with - ;; their preceding chars (but don't put Man-overstrike-face). (Bug#5566) + ;; their preceding chars (but don't put Man-overstrike). (Bug#5566) (goto-char (point-min)) (while (re-search-forward ".\b" nil t) (backward-delete-char 2)) (goto-char (point-min)) @@ -1128,7 +1225,7 @@ Same for the ANSI bold and normal escape sequences." (while (re-search-forward Man-heading-regexp nil t) (put-text-property (match-beginning 0) (match-end 0) - 'face Man-overstrike-face))) + 'face 'Man-overstrike))) (message "%s man page formatted" (Man-page-from-arguments Man-arguments))) (defun Man-highlight-references (&optional xref-man-type) @@ -1211,7 +1308,7 @@ script would have done them." (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) (replace-match "+")) ;; When the header is longer than the manpage name, groff tries to ;; condense it to a shorter line interspersed with ^H. Remove ^H with - ;; their preceding chars (but don't put Man-overstrike-face). (Bug#5566) + ;; their preceding chars (but don't put Man-overstrike). (Bug#5566) (goto-char (point-min)) (while (re-search-forward ".\b" nil t) (backward-delete-char 2)) (Man-softhyphen-to-minus) @@ -1313,7 +1410,7 @@ manpage command." (put 'Man-mode 'mode-class 'special) -(defun Man-mode () +(define-derived-mode Man-mode fundamental-mode "Man" "A mode for browsing Un*x manual pages. The following man commands are available in the buffer. Try @@ -1350,11 +1447,7 @@ The following variables may be of some use. Try The following key bindings are currently in effect in the buffer: \\{Man-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'Man-mode - mode-name "Man" - buffer-auto-save-file-name nil + (setq buffer-auto-save-file-name nil mode-line-buffer-identification (list (default-value 'mode-line-buffer-identification) " {" 'Man-page-mode-string "}") @@ -1362,9 +1455,8 @@ The following key bindings are currently in effect in the buffer: buffer-read-only t) (buffer-disable-undo) (auto-fill-mode -1) - (use-local-map Man-mode-map) - (set-syntax-table man-mode-syntax-table) (setq imenu-generic-expression (list (list nil Man-heading-regexp 0))) + (imenu-add-to-menubar man-imenu-title) (set (make-local-variable 'outline-regexp) Man-heading-regexp) (set (make-local-variable 'outline-level) (lambda () 1)) (set (make-local-variable 'bookmark-make-record-function) @@ -1372,8 +1464,7 @@ The following key bindings are currently in effect in the buffer: (Man-build-page-list) (Man-strip-page-headers) (Man-unindent) - (Man-goto-page 1 t) - (run-mode-hooks 'Man-mode-hook)) + (Man-goto-page 1 t)) (defsubst Man-build-section-alist () "Build the list of manpage sections." @@ -1412,7 +1503,7 @@ The following key bindings are currently in effect in the buffer: ;; Update len, in case a reference spans ;; more than two lines (paranoia). len (1- (length word)))) - (if (memq (aref word len) '(?- ?­)) + (if (memq (aref word len) '(?- ?­)) (setq hyphenated (substring word 0 len))) (and (string-match Man-reference-regexp word) (not (member word Man--refpages))