New file, contents mostly from `help.el'.

lisp/help-mode.el

+;;; help-mode.el --- `help-mode' used by *Help* buffers
+
+;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001
+;;   Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: help, internal
+
+;; 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 2, 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; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Defines `help-mode', which is the mode used by *Help* buffers, and
+;; associated support machinery, such as adding hyperlinks, etc.,
+
+;;; Code:
+
+(require 'button)
+(eval-when-compile (require 'view))
+
+(defvar help-mode-map (make-sparse-keymap)
+  "Keymap for help mode.")
+
+(set-keymap-parent help-mode-map button-buffer-map)
+
+(define-key help-mode-map "\C-c\C-b" 'help-go-back)
+(define-key help-mode-map "\C-c\C-c" 'help-follow)
+;; Documentation only, since we use minor-mode-overriding-map-alist.
+(define-key help-mode-map "\r" 'help-follow)
+
+(defvar help-xref-stack nil
+  "A stack of ways by which to return to help buffers after following xrefs.
+Used by `help-follow' and `help-xref-go-back'.
+An element looks like (POSITION FUNCTION ARGS...), where POSITION is
+`(POINT . BUFFER-NAME)'.
+To use the element, do (apply FUNCTION ARGS) then goto the point in
+the named buffer.")
+(put 'help-xref-stack 'permanent-local t)
+
+(defvar help-xref-stack-item nil
+  "An item for `help-follow' in this buffer to push onto `help-xref-stack'.
+The format is (FUNCTION ARGS...).")
+(put 'help-xref-stack-item 'permanent-local t)
+
+(setq-default help-xref-stack nil help-xref-stack-item nil)
+
+
+
+;; Button types used by help
+
+;; Make some button types that all use the same naming conventions
+(dolist (help-type '("function" "variable" "face"
+		     "coding-system" "input-method" "character-set"))
+  (define-button-type (intern (purecopy (concat "help-" help-type)))
+    'help-function (intern (concat "describe-" help-type))
+    'help-echo (purecopy (concat "mouse-2, RET: describe this " help-type))
+    'action #'help-button-action))
+
+;; make some more ideosyncratic button types
+
+(define-button-type 'help-symbol
+  'help-function #'help-xref-interned
+  'help-echo (purecopy "mouse-2, RET: describe this symbol")
+  'action #'help-button-action)
+
+(define-button-type 'help-back
+  'help-function #'help-xref-go-back
+  'help-echo (purecopy "mouse-2, RET: go back to previous help buffer")
+  'action #'help-button-action)
+
+(define-button-type 'help-info
+  'help-function #'info
+  'help-echo (purecopy"mouse-2, RET: read this Info node")
+  'action #'help-button-action)
+
+(define-button-type 'help-customize-variable
+  'help-function (lambda (v)
+		   (if help-xref-stack
+		       (pop help-xref-stack))
+		   (customize-variable v))
+  'help-echo (purecopy "mouse-2, RET: customize variable")
+  'action #'help-button-action)
+
+(define-button-type 'help-function-def
+  'help-function (lambda (fun file)
+		   (require 'find-func)
+		  ;; Don't use find-function-noselect because it follows
+		   ;; aliases (which fails for built-in functions).
+		   (let* ((location (find-function-search-for-symbol
+				     fun nil file)))
+		     (pop-to-buffer (car location))
+		     (goto-char (cdr location))))
+  'help-echo (purecopy "mouse-2, RET: find function's definition")
+  'action #'help-button-action)
+
+(define-button-type 'help-variable-def
+  'help-function (lambda (var &optional file)
+		   (let ((location
+			  (find-variable-noselect var file)))
+		     (pop-to-buffer (car location))
+		     (goto-char (cdr location))))
+  'help-echo (purecopy"mouse-2, RET: find variable's definition")
+  'action #'help-button-action)
+
+(defun help-button-action (button)
+  "Call BUTTON's help function."
+  (help-do-xref (button-start button)
+		(button-get button 'help-function)
+		(button-get button 'help-args)))
+
+
+;;;###autoload
+(define-derived-mode help-mode nil "Help"
+  "Major mode for viewing help text and navigating references in it.
+Entry to this mode runs the normal hook `help-mode-hook'.
+Commands:
+\\{help-mode-map}"
+  (setq font-lock-defaults nil)         ; font-lock would defeat xref
+  (view-mode)
+  (make-local-variable 'view-no-disable-on-exit)
+  (setq view-no-disable-on-exit t))
+
+;;;###autoload
+(defun help-mode-setup ()
+  (help-mode)
+  (setq buffer-read-only nil))
+
+;;;###autoload
+(defun help-mode-finish ()
+  (when (eq major-mode 'help-mode)
+    ;; View mode's read-only status of existing *Help* buffer is lost
+    ;; by with-output-to-temp-buffer.
+    (toggle-read-only 1)
+    (help-make-xrefs (current-buffer)))
+  (setq view-return-to-alist
+	(list (cons (selected-window) help-return-method))))
+
+
+;;; Grokking cross-reference information in doc strings and
+;;; hyperlinking it.
+
+;; This may have some scope for extension and the same or something
+;; similar should be done for widget doc strings, which currently use
+;; another mechanism.
+
+(defcustom help-highlight-p t
+  "*If non-nil, `help-make-xrefs' highlight cross-references.
+Under a window system it highlights them with face defined by
+`help-highlight-face'."
+ :group 'help
+ :version "20.3"
+ :type 'boolean)
+
+(defcustom help-highlight-face 'underline
+  "Face used by `help-make-xrefs' to highlight cross-references.
+Must be previously-defined."
+  :group 'help
+  :version "20.3"
+  :type 'face)
+
+(defvar help-back-label (purecopy "[back]")
+  "Label to use by `help-make-xrefs' for the go-back reference.")
+
+(defconst help-xref-symbol-regexp
+  (purecopy (concat "\\(\\<\\(\\(variable\\|option\\)\\|"
+		    "\\(function\\|command\\)\\|"
+		    "\\(face\\)\\|"
+		    "\\(symbol\\)\\|"
+		    "\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)\\s-+\\)?"
+		    ;; Note starting with word-syntax character:
+		    "`\\(\\sw\\(\\sw\\|\\s_\\)+\\)'"))
+  "Regexp matching doc string references to symbols.
+
+The words preceding the quoted symbol can be used in doc strings to
+distinguish references to variables, functions and symbols.")
+
+(defconst help-xref-mule-regexp nil
+  "Regexp matching doc string references to MULE-related keywords.
+
+It is usually nil, and is temporarily bound to an appropriate regexp
+when help commands related to multilingual environment (e.g.,
+`describe-coding-system') are invoked.")
+
+
+(defconst help-xref-info-regexp
+  (purecopy "\\<[Ii]nfo[ \t\n]+node[ \t\n]+`\\([^']+\\)'")
+  "Regexp matching doc string references to an Info node.")
+
+;;;###autoload
+(defun help-setup-xref (item interactive-p)
+  "Invoked from commands using the \"*Help*\" buffer to install some xref info.
+
+ITEM is a (FUNCTION . ARGS) pair appropriate for recreating the help
+buffer after following a reference.  INTERACTIVE-P is non-nil if the
+calling command was invoked interactively.  In this case the stack of
+items for help buffer \"back\" buttons is cleared."
+  (if interactive-p
+      (setq help-xref-stack nil))
+  (setq help-xref-stack-item item))
+
+(defvar help-xref-following nil
+  "Non-nil when following a help cross-reference.")
+
+;;;###autoload
+(defun help-make-xrefs (&optional buffer)
+  "Parse and hyperlink documentation cross-references in the given BUFFER.
+
+Find cross-reference information in a buffer and, if
+`help-highlight-p' is non-nil, highlight it with face defined by
+`help-highlight-face'; activate such cross references for selection
+with `help-follow'.  Cross-references have the canonical form `...'
+and the type of reference may be disambiguated by the preceding
+word(s) used in `help-xref-symbol-regexp'.
+
+If the variable `help-xref-mule-regexp' is non-nil, find also
+cross-reference information related to multilingual environment
+\(e.g., coding-systems).  This variable is also used to disambiguate
+the type of reference as the same way as `help-xref-symbol-regexp'.
+
+A special reference `back' is made to return back through a stack of
+help buffers.  Variable `help-back-label' specifies the text for
+that."
+  (interactive "b")
+  (save-excursion
+    (set-buffer (or buffer (current-buffer)))
+    (goto-char (point-min))
+    ;; Skip the header-type info, though it might be useful to parse
+    ;; it at some stage (e.g. "function in `library'").
+    (forward-paragraph)
+    (let ((old-modified (buffer-modified-p)))
+      (let ((stab (syntax-table))
+            (case-fold-search t)
+            (inhibit-read-only t))
+        (set-syntax-table emacs-lisp-mode-syntax-table)
+        ;; The following should probably be abstracted out.
+        (unwind-protect
+            (progn
+              ;; Info references
+              (save-excursion
+                (while (re-search-forward help-xref-info-regexp nil t)
+                  (let ((data (match-string 1)))
+		    (save-match-data
+		      (unless (string-match "^([^)]+)" data)
+			(setq data (concat "(emacs)" data))))
+		    (help-xref-button 1 'help-info data))))
+	      ;; Mule related keywords.  Do this before trying
+	      ;; `help-xref-symbol-regexp' because some of Mule
+	      ;; keywords have variable or function definitions.
+	      (if help-xref-mule-regexp
+		  (save-excursion
+		    (while (re-search-forward help-xref-mule-regexp nil t)
+		      (let* ((data (match-string 7))
+			     (sym (intern-soft data)))
+			(cond
+			 ((match-string 3) ; coding system
+			  (and sym (coding-system-p sym)
+			       (help-xref-button 6 'help-coding-system sym)))
+			 ((match-string 4) ; input method
+			  (and (assoc data input-method-alist)
+			       (help-xref-button 7 'help-input-method data)))
+			 ((or (match-string 5) (match-string 6)) ; charset
+			  (and sym (charsetp sym)
+			       (help-xref-button 7 'help-character-set sym)))
+			 ((assoc data input-method-alist)
+			  (help-xref-button 7 'help-character-set data))
+			 ((and sym (coding-system-p sym))
+			  (help-xref-button 7 'help-coding-system sym))
+			 ((and sym (charsetp sym))
+			  (help-xref-button 7 'help-character-set sym)))))))
+              ;; Quoted symbols
+              (save-excursion
+                (while (re-search-forward help-xref-symbol-regexp nil t)
+                  (let* ((data (match-string 8))
+                         (sym (intern-soft data)))
+                    (if sym
+                        (cond
+                         ((match-string 3) ; `variable' &c
+                          (and (boundp sym) ; `variable' doesn't ensure
+                                        ; it's actually bound
+                               (help-xref-button 8 'help-variable sym)))
+                         ((match-string 4) ; `function' &c
+                          (and (fboundp sym) ; similarly
+                               (help-xref-button 8 'help-function sym)))
+			 ((match-string 5) ; `face'
+			  (and (facep sym)
+			       (help-xref-button 8 'help-face sym)))
+                         ((match-string 6)) ; nothing for `symbol'
+			 ((match-string 7)
+;; this used:
+;; 			   #'(lambda (arg)
+;; 			       (let ((location
+;; 				      (find-function-noselect arg)))
+;; 				 (pop-to-buffer (car location))
+;; 				 (goto-char (cdr location))))
+			  (help-xref-button 8 'help-function-def sym))
+                         ((and (boundp sym) (fboundp sym))
+                          ;; We can't intuit whether to use the
+                          ;; variable or function doc -- supply both.
+                          (help-xref-button 8 'help-symbol sym))
+                         ((boundp sym)
+			  (help-xref-button 8 'help-variable sym))
+			 ((fboundp sym)
+			  (help-xref-button 8 'help-function sym))
+			 ((facep sym)
+			  (help-xref-button 8 'help-face sym)))))))
+              ;; An obvious case of a key substitution:
+              (save-excursion
+                (while (re-search-forward
+			;; Assume command name is only word characters
+			;; and dashes to get things like `use M-x foo.'.
+                        "\\<M-x\\s-+\\(\\sw\\(\\sw\\|-\\)+\\)" nil t)
+                  (let ((sym (intern-soft (match-string 1))))
+                    (if (fboundp sym)
+                        (help-xref-button 1 'help-function sym)))))
+              ;; Look for commands in whole keymap substitutions:
+              (save-excursion
+		;; Make sure to find the first keymap.
+		(goto-char (point-min))
+                ;; Find a header and the column at which the command
+                ;; name will be found.
+                (while (re-search-forward "^key +binding\n\\(-+ +\\)-+\n\n"
+                                          nil t)
+                  (let ((col (- (match-end 1) (match-beginning 1))))
+                    (while
+                        ;; Ignore single blank lines in table, but not
+                        ;; double ones, which should terminate it.
+                        (and (not (looking-at "\n\\s-*\n"))
+                             (progn
+			       (and (eolp) (forward-line))
+			       (end-of-line)
+			       (skip-chars-backward "^\t\n")
+                               (if (and (>= (current-column) col)
+					(looking-at "\\(\\sw\\|-\\)+$"))
+                                   (let ((sym (intern-soft (match-string 0))))
+                                     (if (fboundp sym)
+                                         (help-xref-button 0 'help-function sym))))
+			       (zerop (forward-line)))))))))
+          (set-syntax-table stab))
+	;; Delete extraneous newlines at the end of the docstring
+	(goto-char (point-max))
+	(while (and (not (bobp)) (bolp))
+	  (delete-char -1))
+        ;; Make a back-reference in this buffer if appropriate.
+        (when (and help-xref-following help-xref-stack)
+	  (insert "\n\n")
+	  (help-insert-xref-button help-back-label 'help-back
+				   (current-buffer))))
+      ;; View mode steals RET from us.
+      (set (make-local-variable 'minor-mode-overriding-map-alist)
+           (list (cons 'view-mode
+                       (let ((map (make-sparse-keymap)))
+                         (set-keymap-parent map view-mode-map)
+                         (define-key map "\r" 'help-follow)
+                         map))))
+      (set-buffer-modified-p old-modified))))
+
+;;;###autoload
+(defun help-xref-button (match-number type &rest args)
+  "Make a hyperlink for cross-reference text previously matched.
+MATCH-NUMBER is the subexpression of interest in the last matched
+regexp.  TYPE is the type of button to use.  Any remaining arguments are
+passed to the button's help-function when it is invoked.
+See `help-make-xrefs'."
+  ;; Don't mung properties we've added specially in some instances.
+  (unless (button-at (match-beginning match-number))
+    (make-text-button (match-beginning match-number)
+		      (match-end match-number)
+		      'type type 'help-args args)))
+
+;;;###autoload
+(defun help-insert-xref-button (string type &rest args)
+  "Insert STRING and make a hyperlink from cross-reference text on it.
+TYPE is the type of button to use.  Any remaining arguments are passed
+to the button's help-function when it is invoked.
+See `help-make-xrefs'."
+  (unless (button-at (point))
+    (insert-text-button string 'type type 'help-args args)))
+
+;;;###autoload
+(defun help-xref-on-pp (from to)
+  "Add xrefs for symbols in `pp's output between FROM and TO."
+  (let ((ost (syntax-table)))
+    (unwind-protect
+	(save-excursion
+	  (save-restriction
+	    (set-syntax-table emacs-lisp-mode-syntax-table)
+	    (narrow-to-region from to)
+	    (goto-char (point-min))
+	    (while (not (eobp))
+	      (cond
+	       ((looking-at "\"") (forward-sexp 1))
+	       ((looking-at "#<") (search-forward ">" nil 'move))
+	       ((looking-at "\\(\\(\\sw\\|\\s_\\)+\\)")
+		(let* ((sym (intern-soft (match-string 1)))
+		       (type (cond ((fboundp sym) 'help-function)
+				 ((or (memq sym '(t nil))
+				      (keywordp sym))
+				  nil)
+				 ((and sym (boundp sym))
+				  'help-variable))))
+		  (when type (help-xref-button 1 type sym)))
+		(goto-char (match-end 1)))
+	       (t (forward-char 1))))))
+      (set-syntax-table ost))))
+
+
+;; Additional functions for (re-)creating types of help buffers.
+(defun help-xref-interned (symbol)
+  "Follow a hyperlink which appeared to be an arbitrary interned SYMBOL.
+
+Both variable and function documentation are extracted into a single
+help buffer."
+  (let ((fdoc (when (fboundp symbol) (describe-function symbol)))
+	(facedoc (when (facep symbol) (describe-face symbol))))
+    (when (or (boundp symbol) (not fdoc))
+      (describe-variable symbol)
+      ;; We now have a help buffer on the variable.  Insert the function
+      ;; text before it.
+      (when (or fdoc facedoc)
+	(with-current-buffer "*Help*"
+	  (goto-char (point-min))
+	  (let ((inhibit-read-only t))
+	    (when fdoc
+	      (insert fdoc "\n\n"))
+	    (when facedoc
+	      (insert (make-string 30 ?-) "\n\n" (symbol-name symbol)
+		      " is also a " "face." "\n\n" facedoc "\n\n"))
+	    (insert (make-string 30 ?-) "\n\n" (symbol-name symbol)
+		    " is also a " "variable." "\n\n"))
+	  (help-setup-xref (list #'help-xref-interned symbol) nil))))))
+
+
+;;; Navigation/hyperlinking with xrefs
+
+(defun help-xref-go-back (buffer)
+  "From BUFFER, go back to previous help buffer text using `help-xref-stack'."
+  (let (item position method args)
+    (with-current-buffer buffer
+      (when help-xref-stack
+	(setq help-xref-stack (cdr help-xref-stack)) ; due to help-follow
+	(setq item (pop help-xref-stack)
+	      position (car item)
+	      method (cadr item)
+	      args (cddr item))))
+    (apply method args)
+    ;; We assume that the buffer we just recreated has the saved name,
+    ;; which might not always be true.
+    (when (get-buffer (cdr position))
+      (with-current-buffer (cdr position)
+	(goto-char (car position))))))
+
+(defun help-go-back ()
+  "Invoke the [back] button (if any) in the Help mode buffer."
+  (interactive)
+  (let ((back-button (button-at (1- (point-max)))))
+    (if back-button
+	(button-activate back-button)
+      (error "No [back] button"))))
+
+(defun help-do-xref (pos function args)
+  "Call the help cross-reference function FUNCTION with args ARGS.
+Things are set up properly so that the resulting help-buffer has
+a proper [back] button."
+  (setq help-xref-stack (cons (cons (cons pos (buffer-name))
+				    help-xref-stack-item)
+			      help-xref-stack))
+  (setq help-xref-stack-item nil)
+  ;; There is a reference at point.  Follow it.
+  (let ((help-xref-following t))
+    (apply function args)))
+
+(defun help-follow (&optional pos)
+  "Follow cross-reference at POS, defaulting to point.
+
+For the cross-reference format, see `help-make-xrefs'."
+  (interactive "d")
+  (unless pos
+    (setq pos (point)))
+  (unless (push-button pos)
+    ;; check if the symbol under point is a function or variable
+    (let ((sym
+	   (intern
+	    (save-excursion
+	      (goto-char pos) (skip-syntax-backward "w_")
+	      (buffer-substring (point)
+				(progn (skip-syntax-forward "w_")
+				       (point)))))))
+      (when (or (boundp sym) (fboundp sym))
+	(help-do-xref pos #'help-xref-interned (list sym))))))
+
+
+(provide 'help-mode)
+
+;;; help-mode.el ends here
+
+