minor-modes nil)
(setq minor-modes (cdr minor-modes)))))
result))
+
+\f
+(defun substitute-command-keys (string)
+ "Substitute key descriptions for command names in STRING.
+Each substring of the form \\\\=[COMMAND] is replaced by either a
+keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND
+is not on any keys.
+
+Each substring of the form \\\\={MAPVAR} is replaced by a summary of
+the value of MAPVAR as a keymap. This summary is similar to the one
+produced by ‘describe-bindings’. The summary ends in two newlines
+(used by the helper function ‘help-make-xrefs’ to find the end of the
+summary).
+
+Each substring of the form \\\\=<MAPVAR> specifies the use of MAPVAR
+as the keymap for future \\\\=[COMMAND] substrings.
+
+Each grave accent \\=` is replaced by left quote, and each apostrophe \\='
+is replaced by right quote. Left and right quote characters are
+specified by ‘text-quoting-style’.
+
+\\\\== quotes the following character and is discarded; thus, \\\\==\\\\== puts \\\\==
+into the output, \\\\==\\[ puts \\[ into the output, and \\\\==\\=` puts \\=` into the
+output.
+
+Return the original STRING if no substitutions are made.
+Otherwise, return a new string (without any text properties)."
+ (when (not (null string))
+ ;; KEYMAP is either nil (which means search all the active
+ ;; keymaps) or a specified local map (which means search just that
+ ;; and the global map). If non-nil, it might come from
+ ;; overriding-local-map, or from a \\<mapname> construct in STRING
+ ;; itself.
+ (let ((keymap overriding-local-map)
+ (inhibit-modification-hooks t)
+ (orig-buf (current-buffer)))
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (let ((orig-point (point))
+ end-point active-maps
+ close generate-summary)
+ (cond
+ ;; 1. Handle all sequences starting with "\"
+ ((= (following-char) ?\\)
+ (ignore-errors
+ (forward-char 1))
+ (cond
+ ;; 1A. Ignore \= at end of string.
+ ((and (= (+ (point) 1) (point-max))
+ (= (following-char) ?=))
+ (forward-char 1))
+ ;; 1B. \= quotes the next character; thus, to put in \[
+ ;; without its special meaning, use \=\[.
+ ((= (following-char) ?=)
+ (goto-char orig-point)
+ (delete-char 2)
+ (ignore-errors
+ (forward-char 1)))
+ ;; 1C. \[foo] is replaced with the keybinding.
+ ((and (= (following-char) ?\[)
+ (save-excursion
+ (prog1 (search-forward "]" nil t)
+ (setq end-point (- (point) 2)))))
+ (goto-char orig-point)
+ (delete-char 2)
+ (let* ((fun (intern (buffer-substring (point) (1- end-point))))
+ (key (with-current-buffer orig-buf
+ (where-is-internal fun keymap t))))
+ ;; If this a command remap, we need to follow it.
+ (when (and (vectorp key)
+ (> (length key) 1)
+ (eq (aref key 0) 'remap)
+ (symbolp (aref key 1)))
+ (setq fun (aref key 1))
+ (setq key (with-current-buffer orig-buf
+ (where-is-internal fun keymap t))))
+ (if (not key)
+ ;; Function is not on any key.
+ (progn (insert "M-x ")
+ (goto-char (+ end-point 3))
+ (delete-char 1))
+ ;; Function is on a key.
+ (delete-char (- end-point (point)))
+ (insert (key-description key)))))
+ ;; 1D. \{foo} is replaced with a summary of the keymap
+ ;; (symbol-value foo).
+ ;; \<foo> just sets the keymap used for \[cmd].
+ ((and (or (and (= (following-char) ?{)
+ (setq close "}")
+ (setq generate-summary t))
+ (and (= (following-char) ?<)
+ (setq close ">")))
+ (or (save-excursion
+ (prog1 (search-forward close nil t)
+ (setq end-point (- (point) 2))))))
+ (goto-char orig-point)
+ (delete-char 2)
+ (let* ((name (intern (buffer-substring (point) (1- end-point))))
+ this-keymap)
+ (delete-char (- end-point (point)))
+ ;; Get the value of the keymap in TEM, or nil if
+ ;; undefined. Do this in the user's current buffer
+ ;; in case it is a local variable.
+ (with-current-buffer orig-buf
+ ;; This is for computing the SHADOWS arg for
+ ;; describe-map-tree.
+ (setq active-maps (current-active-maps))
+ (when (boundp name)
+ (setq this-keymap (and (keymapp (symbol-value name))
+ (symbol-value name)))))
+ (cond
+ ((null this-keymap)
+ (insert "\nUses keymap "
+ (substitute-command-keys "`")
+ (symbol-name name)
+ (substitute-command-keys "'")
+ ", which is not currently defined.\n")
+ (unless generate-summary
+ (setq keymap nil)))
+ ((not generate-summary)
+ (setq keymap this-keymap))
+ (t
+ ;; Get the list of active keymaps that precede this one.
+ ;; If this one's not active, get nil.
+ (let ((earlier-maps (cdr (memq this-keymap (reverse active-maps)))))
+ (describe-map-tree this-keymap t (nreverse earlier-maps)
+ nil nil t nil nil))))))))
+ ;; 2. Handle quotes.
+ ((and (eq (get-quoting-style) 'curve)
+ (or (and (= (following-char) ?\`)
+ (prog1 t (insert "‘")))
+ (and (= (following-char) ?')
+ (prog1 t (insert "’")))))
+ (delete-char 1))
+ ((and (eq (get-quoting-style) 'straight)
+ (= (following-char) ?\`))
+ (insert "'")
+ (delete-char 1))
+ ;; 3. Nothing to do -- next character.
+ (t (forward-char 1)))))
+ (buffer-string)))))
+
\f
(declare-function x-display-pixel-height "xfns.c" (&optional terminal))
(declare-function x-display-pixel-width "xfns.c" (&optional terminal))
}
if (NILP (raw))
- doc = Fsubstitute_command_keys (doc);
+ doc = call1 (Qsubstitute_command_keys, doc);
return doc;
}
tem = Feval (tem, Qnil);
if (NILP (raw) && STRINGP (tem))
- tem = Fsubstitute_command_keys (tem);
+ tem = call1 (Qsubstitute_command_keys, tem);
return tem;
}
\f
return CURVE_QUOTING_STYLE;
}
-DEFUN ("substitute-command-keys", Fsubstitute_command_keys,
- Ssubstitute_command_keys, 1, 1, 0,
+/* This is just a Lisp wrapper for text_quoting_style above. */
+DEFUN ("get-quoting-style", Fget_quoting_style,
+ Sget_quoting_style, 0, 0, 0,
+ doc: /* Return the current effective text quoting style.
+See variable `text-quoting-style'. */)
+ (void)
+{
+ switch (text_quoting_style ())
+ {
+ case STRAIGHT_QUOTING_STYLE:
+ return Qstraight;
+ case CURVE_QUOTING_STYLE:
+ return Qcurve;
+ case GRAVE_QUOTING_STYLE:
+ default:
+ return Qgrave;
+ }
+}
+
+DEFUN ("substitute-command-keys-old", Fsubstitute_command_keys_old,
+ Ssubstitute_command_keys_old, 1, 1, 0,
doc: /* Substitute key descriptions for command names in STRING.
Each substring of the form \\=\\[COMMAND] is replaced by either a
keystroke sequence that invokes COMMAND, or "M-x COMMAND" if COMMAND
{
name = Fsymbol_name (name);
AUTO_STRING (msg_prefix, "\nUses keymap `");
- insert1 (Fsubstitute_command_keys (msg_prefix));
+ insert1 (Fsubstitute_command_keys_old (msg_prefix));
insert_from_string (name, 0, 0,
SCHARS (name),
SBYTES (name), 1);
AUTO_STRING (msg_suffix, "', which is not currently defined.\n");
- insert1 (Fsubstitute_command_keys (msg_suffix));
+ insert1 (Fsubstitute_command_keys_old (msg_suffix));
if (!generate_summary)
keymap = Qnil;
}
void
syms_of_doc (void)
{
+ DEFSYM (Qsubstitute_command_keys, "substitute-command-keys");
DEFSYM (Qfunction_documentation, "function-documentation");
DEFSYM (Qgrave, "grave");
DEFSYM (Qstraight, "straight");
+ DEFSYM (Qcurve, "curve");
DEFVAR_LISP ("internal-doc-file-name", Vdoc_file_name,
doc: /* Name of file containing documentation strings of built-in symbols. */);
defsubr (&Sdocumentation);
defsubr (&Sdocumentation_property);
defsubr (&Ssnarf_documentation);
- defsubr (&Ssubstitute_command_keys);
+ defsubr (&Sget_quoting_style);
+ defsubr (&Ssubstitute_command_keys_old);
}
help)))
return help;
- return Fsubstitute_command_keys (help);
+ return call1 (Qsubstitute_command_keys, help);
}
/* Display the help-echo property of the character after the mouse pointer.
/* The previous code preferred :key-sequence to :keys, so we
preserve this behavior. */
if (STRINGP (keyeq) && !CONSP (keyhint))
- keyeq = concat2 (space_space, Fsubstitute_command_keys (keyeq));
+ keyeq = concat2 (space_space, call1 (Qsubstitute_command_keys, keyeq));
else
{
Lisp_Object prefix = keyeq;
Any inserted text ends in two newlines (used by `help-make-xrefs'). */
+DEFUN ("describe-map-tree", Fdescribe_map_tree, Sdescribe_map_tree, 1, 8, 0,
+ doc: /* This is just temporary. */)
+ (Lisp_Object startmap, Lisp_Object partial, Lisp_Object shadow,
+ Lisp_Object prefix, Lisp_Object title, Lisp_Object nomenu,
+ Lisp_Object transl, Lisp_Object always_title)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+ char *title_string;
+
+ if ( !NILP (title) )
+ {
+ CHECK_STRING (title);
+ title_string = SSDATA(title);
+ }
+ else
+ {
+ title_string = NULL;
+ }
+
+ bool b_partial = NILP (partial) ? false : true;
+ bool b_nomenu = NILP (nomenu) ? false : true;
+ bool b_transl = NILP (transl) ? false : true;
+ bool b_always_title = NILP (always_title) ? false : true;
+
+ /* specbind (Qstandard_output, Fcurrent_buffer ()); */
+ describe_map_tree (startmap, b_partial, shadow, prefix, title_string,
+ b_nomenu, b_transl, b_always_title, true);
+
+ return unbind_to (count, Qnil);
+}
+
void
describe_map_tree (Lisp_Object startmap, bool partial, Lisp_Object shadow,
Lisp_Object prefix, const char *title, bool nomenu,
defsubr (&Scurrent_active_maps);
defsubr (&Saccessible_keymaps);
defsubr (&Skey_description);
+ defsubr (&Sdescribe_map_tree);
defsubr (&Sdescribe_vector);
defsubr (&Ssingle_key_description);
defsubr (&Stext_char_description);
else
{
Lisp_Object error_conditions = Fget (errname, Qerror_conditions);
- errmsg = Fsubstitute_command_keys (Fget (errname, Qerror_message));
+ errmsg = call1 (Qsubstitute_command_keys, Fget (errname, Qerror_message));
file_error = Fmemq (Qfile_error, error_conditions);
}
{
AUTO_STRING (prefixdoc,
",\n\t is a prefix character for `backward-prefix-chars'");
- insert1 (Fsubstitute_command_keys (prefixdoc));
+ insert1 (call1 (Qsubstitute_command_keys, prefixdoc));
}
return syntax;
;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
;; Author: Juanma Barranquero <lekktu@gmail.com>
+;; Eli Zaretskii <eliz@gnu.org>
+;; Stefan Kangas <stefankangas@gmail.com>
;; Keywords: help, internal
;; This file is part of GNU Emacs.
;;; Code:
(require 'ert)
+(eval-when-compile (require 'cl-lib))
(ert-deftest help-split-fundoc-SECTION ()
"Test new optional arg SECTION."
(should (equal (help-split-fundoc nil t 'usage) nil))
(should (equal (help-split-fundoc nil t 'doc) nil))))
+\f
+;;; substitute-command-keys
+
+(defmacro with-substitute-command-keys-test (&rest body)
+ `(cl-flet* ((should-be-same-as-c-version
+ ;; TODO: Remove this when old C function is removed.
+ (lambda (orig)
+ (should (equal-including-properties
+ (substitute-command-keys orig)
+ (substitute-command-keys-old orig)))))
+ (test
+ (lambda (orig result)
+ (should (equal-including-properties
+ (substitute-command-keys orig)
+ result))
+ (should-be-same-as-c-version orig)))
+ (test-re
+ (lambda (orig regexp)
+ (should (string-match (concat "^" regexp "$")
+ (substitute-command-keys orig)))
+ (should-be-same-as-c-version orig))))
+ ,@body))
+
+(ert-deftest help-tests-substitute-command-keys/no-change ()
+ (with-substitute-command-keys-test
+ (test "foo" "foo")
+ (test "\\invalid-escape" "\\invalid-escape")))
+
+(ert-deftest help-tests-substitute-command-keys/commands ()
+ (with-substitute-command-keys-test
+ (test "foo \\[goto-char]" "foo M-g c")
+ (test "\\[next-line]" "C-n")
+ (test "\\[next-line]\n\\[next-line]" "C-n\nC-n")
+ (test "\\[next-line]\\[previous-line]" "C-nC-p")
+ (test "\\[next-line]\\=\\[previous-line]" "C-n\\[previous-line]")
+ ;; Allow any style of quotes, since the terminal might not support
+ ;; UTF-8. Same thing is done below.
+ (test-re "\\[next-line]`foo'" "C-n[`'‘]foo['’]")
+ (test "\\[emacs-version]" "M-x emacs-version")
+ (test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n")
+ (test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]")))
+
+(ert-deftest help-tests-substitute-command-keys/keymaps ()
+ (with-substitute-command-keys-test
+ (test "\\{minibuffer-local-must-match-map}"
+ "\
+key binding
+--- -------
+
+C-g abort-recursive-edit
+TAB minibuffer-complete
+C-j minibuffer-complete-and-exit
+RET minibuffer-complete-and-exit
+ESC Prefix Command
+SPC minibuffer-complete-word
+? minibuffer-completion-help
+<C-tab> file-cache-minibuffer-complete
+<XF86Back> previous-history-element
+<XF86Forward> next-history-element
+<down> next-line-or-history-element
+<next> next-history-element
+<prior> switch-to-completions
+<up> previous-line-or-history-element
+
+M-v switch-to-completions
+
+M-< minibuffer-beginning-of-buffer
+M-n next-history-element
+M-p previous-history-element
+M-r previous-matching-history-element
+M-s next-matching-history-element
+
+")))
+
+(ert-deftest help-tests-substitute-command-keys/keymap-change ()
+ (with-substitute-command-keys-test
+ (test "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-g")
+ (test "\\<emacs-lisp-mode-map>\\[eval-defun]" "C-M-x")))
+
+(ert-deftest help-tests-substitute-command-keys/undefined-map ()
+ (with-substitute-command-keys-test
+ (test-re "\\{foobar-map}"
+ "\nUses keymap [`'‘]foobar-map['’], which is not currently defined.\n")))
+
+(ert-deftest help-tests-substitute-command-keys/quotes ()
+ (with-substitute-command-keys-test
+ (let ((text-quoting-style 'curve))
+ (test "quotes ‘like this’" "quotes ‘like this’")
+ (test "`x'" "‘x’")
+ (test "`" "‘")
+ (test "'" "’")
+ (test "\\`" "\\‘"))
+ (let ((text-quoting-style 'straight))
+ (test "quotes `like this'" "quotes 'like this'")
+ (test "`x'" "'x'")
+ (test "`" "'")
+ (test "'" "'")
+ (test "\\`" "\\'"))
+ (let ((text-quoting-style 'grave))
+ (test "quotes `like this'" "quotes `like this'")
+ (test "`x'" "`x'")
+ (test "`" "`")
+ (test "'" "'")
+ (test "\\`" "\\`"))))
+
+(ert-deftest help-tests-substitute-command-keys/literals ()
+ (with-substitute-command-keys-test
+ (test "foo \\=\\[goto-char]" "foo \\[goto-char]")
+ (test "foo \\=\\=" "foo \\=")
+ (test "\\=\\=" "\\=")
+ (test "\\=\\[" "\\[")
+ (let ((text-quoting-style 'curve))
+ (test "\\=`x\\='" "`x'"))
+ (let ((text-quoting-style 'straight))
+ (test "\\=`x\\='" "`x'"))
+ (let ((text-quoting-style 'grave))
+ (test "\\=`x\\='" "`x'"))))
+
+(ert-deftest help-tests-substitute-command-keys/no-change ()
+ (with-substitute-command-keys-test
+ (test "\\[foobar" "\\[foobar")
+ (test "\\=" "\\=")))
+
+(ert-deftest help-tests-substitute-command-keys/multibyte ()
+ ;; Cannot use string= here, as that compares unibyte and multibyte
+ ;; strings not equal.
+ (should (compare-strings
+ (substitute-command-keys "\200 \\[goto-char]") nil nil
+ "\200 M-g c" nil nil)))
+
+(ert-deftest help-tests-substitute-command-keys/apropos ()
+ (save-window-excursion
+ (apropos "foo")
+ (switch-to-buffer "*Apropos*")
+ (goto-char (point-min))
+ (should (looking-at "Type RET on"))))
+
+(defvar help-tests-major-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "x" 'foo-original)
+ map))
+
+(define-derived-mode help-tests-major-mode nil
+ "Major mode for testing shadowing.")
+
+(defvar help-tests-minor-mode-map
+ (let ((map (make-keymap)))
+ (define-key map "x" 'foo-shadow)
+ map))
+
+(define-minor-mode help-tests-minor-mode
+ "Minor mode for testing shadowing.")
+
+(ert-deftest help-tests-substitute-command-keys/shadow ()
+ (with-substitute-command-keys-test
+ (with-temp-buffer
+ (help-tests-major-mode)
+ (test "\\{help-tests-major-mode-map}"
+ "\
+key binding
+--- -------
+
+x foo-original
+
+")
+ (help-tests-minor-mode)
+ (test "\\{help-tests-major-mode-map}"
+ "\
+key binding
+--- -------
+
+x foo-original
+ (this binding is currently shadowed)
+
+"))))
+
+(ert-deftest help-tests-substitute-command-keys/command-remap ()
+ (with-substitute-command-keys-test
+ (let ((help-tests-major-mode-map (make-keymap))) ; Protect from changes.
+ (with-temp-buffer
+ (help-tests-major-mode)
+ (define-key help-tests-major-mode-map [remap foo] 'bar)
+ (test "\\{help-tests-major-mode-map}"
+ "\
+key binding
+--- -------
+
+<remap> Prefix Command
+
+<remap> <foo> bar
+
+")))))
+
+;; TODO: This is a temporary test that should be removed together with
+;; substitute-command-keys-old.
+(ert-deftest help-tests-substitute-command-keys/compare ()
+ (with-substitute-command-keys-test
+ (with-temp-buffer
+ (Info-mode)
+ (outline-minor-mode)
+ (test-re "\\{Info-mode-map}" ".*")))
+ (with-substitute-command-keys-test
+ (with-temp-buffer
+ (c-mode)
+ (outline-minor-mode)
+ (test-re "\\{c-mode-map}" ".*"))))
+
(provide 'help-tests)
;;; help-tests.el ends here
+++ /dev/null
-;;; doc-tests.el --- Tests for doc.c -*- lexical-binding: t -*-
-
-;; Copyright (C) 2016-2020 Free Software Foundation, Inc.
-
-;; Author: Eli Zaretskii <eliz@gnu.org>
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Code:
-
-(require 'ert)
-
-(ert-deftest doc-test-substitute-command-keys ()
- ;; Bindings.
- (should (string= (substitute-command-keys "foo \\[goto-char]") "foo M-g c"))
- ;; Cannot use string= here, as that compares unibyte and multibyte
- ;; strings not equal.
- (should (compare-strings
- (substitute-command-keys "\200 \\[goto-char]") nil nil
- "\200 M-g c" nil nil))
- ;; Literals.
- (should (string= (substitute-command-keys "foo \\=\\[goto-char]")
- "foo \\[goto-char]"))
- (should (string= (substitute-command-keys "foo \\=\\=")
- "foo \\="))
- ;; Keymaps.
- ;; I don't see that this is testing anything useful.
- ;; AFAICS all it does it fail whenever someone modifies the
- ;; minibuffer map.
-;;; (should (string= (substitute-command-keys
-;;; "\\{minibuffer-local-must-match-map}")
-;;; "\
-;;; key binding
-;;; --- -------
-;;;
-;;; C-g abort-recursive-edit
-;;; TAB minibuffer-complete
-;;; C-j minibuffer-complete-and-exit
-;;; RET minibuffer-complete-and-exit
-;;; ESC Prefix Command
-;;; SPC minibuffer-complete-word
-;;; ? minibuffer-completion-help
-;;; <C-tab> file-cache-minibuffer-complete
-;;; <XF86Back> previous-history-element
-;;; <XF86Forward> next-history-element
-;;; <down> next-line-or-history-element
-;;; <next> next-history-element
-;;; <prior> switch-to-completions
-;;; <up> previous-line-or-history-element
-;;;
-;;; M-v switch-to-completions
-;;;
-;;; M-< minibuffer-beginning-of-buffer
-;;; M-n next-history-element
-;;; M-p previous-history-element
-;;; M-r previous-matching-history-element
-;;; M-s next-matching-history-element
-;;;
-;;; "))
- (should (string=
- (substitute-command-keys
- "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]")
- "C-g"))
- ;; Allow any style of quotes, since the terminal might not support
- ;; UTF-8.
- (should (string-match
- "\nUses keymap [`‘']foobar-map['’], which is not currently defined.\n"
- (substitute-command-keys "\\{foobar-map}")))
- ;; Quotes.
- (should (let ((text-quoting-style 'grave))
- (string= (substitute-command-keys "quotes `like this'")
- "quotes `like this'")))
- (should (let ((text-quoting-style 'grave))
- (string= (substitute-command-keys "quotes ‘like this’")
- "quotes ‘like this’")))
- (should (let ((text-quoting-style 'straight))
- (string= (substitute-command-keys "quotes `like this'")
- "quotes 'like this'")))
- ;; Bugs.
- (should (string= (substitute-command-keys "\\[foobar") "\\[foobar"))
- (should (string= (substitute-command-keys "\\=") "\\="))
- )
-
-(provide 'doc-tests)
-;;; doc-tests.el ends here
projects / emacs.git / commitdiff