From 645c4f6a8f8582b0a84dcc42d3b064e856d5a88c Mon Sep 17 00:00:00 2001 From: Karl Heuer Date: Sat, 22 Jul 1995 15:17:54 +0000 Subject: [PATCH] Add latest changes of old library and some more. (apropos): Only show unbound symbols when do-all (apropos-documentation-check-elc-file): new copied function. (apropos-command): also use `apropos-do-all' when called as function. (apropos-print-doc): renamed from `apropos-print-documentation', i is numeric index, replaces parameter tem. (apropos-macrop): new function. (apropos-print): use it to differentiate macros. (apropos-symbol-face, apropos-keybinding-face, apropos-label-face) (apropos-property-face, apropos-match-face): new variables replace and extend the effect of `apropos-use-faces'. (apropos-safe-documentation): renames `safe-documentation', also returns a cons. (apropos-regexp, apropos-files-scanned, apropos-accumulator) (apropos-item): new variables to prevent compiler warnings. (apropos-value-internal, apropos-documentation-internal): new fns. --- lisp/apropos.el | 489 ++++++++++++++++++++++++++++++------------------ 1 file changed, 311 insertions(+), 178 deletions(-) diff --git a/lisp/apropos.el b/lisp/apropos.el index 009f0157068..4a5e16391a8 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -44,8 +44,8 @@ ;;; Made doc file buffer read-only, buried it. ;; Only call substitute-command-keys if do-all set. -;; Optionally use faces to make the output more legible. -;; Differentiate between command and function. +;; Optionally use configurable faces to make the output more legible. +;; Differentiate between command, function and macro. ;; Apropos-command (ex command-apropos) does cmd and optionally user var. ;; Apropos shows all 3 aspects of symbols (fn, var and plist) ;; Apropos-documentation (ex super-apropos) now finds all it should. @@ -62,8 +62,27 @@ Slows them down more or less. Set this non-nil if you have a fast machine.") -(defvar apropos-use-faces window-system - "*Whether the apropos commands display output using bold and italic. +(defvar apropos-symbol-face (if window-system 'bold) + "*Face for symbol name in apropos output or `nil'. +This looks good, but slows down the commands several times.") + +(defvar apropos-keybinding-face (if window-system 'underline) + "*Face for keybinding display in apropos output or `nil'. +This looks good, but slows down the commands several times.") + +(defvar apropos-label-face (if window-system 'italic) + "*Face for label (Command, Variable ...) in apropos output or `nil'. +If this is `nil' no mouse highlighting occurs. +This looks good, but slows down the commands several times. +When this is a face name, as it is initially, it gets transformed to a +text-property list for efficiency.") + +(defvar apropos-property-face (if window-system 'bold-italic) + "*Face for property name in apropos output or `nil'. +This looks good, but slows down the commands several times.") + +(defvar apropos-match-face (if window-system 'highlight) + "*Face for matching part in apropos-documentation/value output or `nil'. This looks good, but slows down the commands several times.") @@ -76,29 +95,43 @@ This looks good, but slows down the commands several times.") "Local map active when displaying apropos output.") +(defvar apropos-regexp nil + "Regexp used in current apropos run.") + +(defvar apropos-files-scanned () + "List of elc files already scanned in current run of `apropos-documentaion'.") + +(defvar apropos-accumulator () + "Alist of symbols already found in current apropos run.") -;;;###autoload (fset 'command-apropos 'apropos-command) +(defvar apropos-item () + "Current item in or for apropos-accumulator.") + +;; For auld lang syne: +;;;###autoload +(fset 'command-apropos 'apropos-command) ;;;###autoload -(defun apropos-command (regexp &optional do-all) +(defun apropos-command (apropos-regexp &optional do-all) "Shows commands (interactively callable functions) that match REGEXP. With optional prefix ARG or if `apropos-do-all' is non-nil, also show variables." (interactive (list (read-string (concat "Apropos command " (if (or current-prefix-arg - apropos-do-all) + apropos-do-all) "or variable ") "(regexp): ")) - (or current-prefix-arg apropos-do-all))) + current-prefix-arg)) (let ((message (let ((standard-output (get-buffer-create "*Help*"))) (print-help-return-message 'identity)))) + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator + (apropos-internal apropos-regexp + (if do-all + (lambda (symbol) (or (commandp symbol) + (user-variable-p symbol))) + 'commandp))) (if (apropos-print - regexp - (apropos-internal regexp - (if do-all - (lambda (x) (or (commandp x) - (user-variable-p x))) - 'commandp)) t (lambda (p) (let (doc symbol) @@ -120,17 +153,23 @@ variables." (and message (message message))))) - ;;;###autoload -(defun apropos (regexp &optional do-all) - "Show all symbols whose names match REGEXP. -With optional prefix ARG or if `apropos-do-all' is non-nil, also show key -bindings, which is a little more time-consuming. +(defun apropos (apropos-regexp &optional do-all) + "Show all bound symbols whose names match REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound +symbols and key bindings, which is a little more time-consuming. Returns list of symbols and documentation found." (interactive "sApropos symbol (regexp): \nP") + (setq apropos-accumulator + (apropos-internal apropos-regexp + (and (not do-all) + (not apropos-do-all) + (lambda (symbol) + (or (fboundp symbol) + (boundp symbol) + (symbol-plist symbol)))))) (apropos-print - regexp (apropos-internal regexp) - (or apropos-do-all do-all) + (or do-all apropos-do-all) (lambda (p) (let (symbol doc) (while p @@ -154,131 +193,194 @@ Returns list of symbols and documentation found." nil)) - ;;;###autoload -(defun apropos-value (regexp &optional do-all) +(defun apropos-value (apropos-regexp &optional do-all) "Show all symbols whose value's printed image matches REGEXP. With optional prefix ARG or if `apropos-do-all' is non-nil, also looks at the function and at the names and values of properties. -Returns list of symbols and documentation found." +Returns list of symbols and values found." (interactive "sApropos value (regexp): \nP") - (setq do-all (or apropos-do-all do-all)) - (apropos-print - regexp - (let (accumulator f v p) + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator ()) + (let (f v p) (mapatoms (lambda (symbol) (setq f nil v nil p nil) - (or (memq symbol '(regexp do-all accumulator symbol v pl p)) - (if (boundp symbol) - (setq v (prin1-to-string (symbol-value symbol)) - v (if (string-match regexp v) v)))) + (or (memq symbol '(apropos-regexp do-all apropos-accumulator + symbol f v p)) + (setq v (apropos-value-internal 'boundp symbol 'symbol-value))) (if do-all - (progn - (if (fboundp symbol) - (setq f (prin1-to-string (symbol-function symbol)) - f (if (string-match regexp f) f))) - (setq p (apropos-format-plist symbol "\n " regexp)))) - ;; (if p-out (insert p-out)) + (setq f (apropos-value-internal 'fboundp symbol 'symbol-function) + p (apropos-format-plist symbol "\n " t))) (if (or f v p) - (setq accumulator (cons (list symbol f v p) accumulator))))) - accumulator) - nil nil t)) + (setq apropos-accumulator (cons (list symbol f v p) + apropos-accumulator)))))) + (apropos-print nil nil t)) -(defun apropos-format-plist (pl sep &optional regexp) +;;;###autoload +(defun apropos-documentation (apropos-regexp &optional do-all) + "Show symbols whose names or documentation contain matches for REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also use +documentation that is not stored in the documentation file and show key +bindings. +Returns list of symbols and documentation found." + (interactive "sApropos documentation (regexp): \nP") + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator () apropos-files-scanned ()) + (let ((standard-input (get-buffer-create " apropos-temp")) + f v) + (unwind-protect + (save-excursion + (set-buffer standard-input) + (apropos-documentation-check-doc-file) + (if do-all + (mapatoms + (lambda (symbol) + (setq f (apropos-safe-documentation symbol) + v (get symbol 'variable-documentation) + v (if (integerp v) nil v)) + (or (string-match apropos-regexp (symbol-name symbol)) + (setq f (apropos-documentation-internal f) + v (apropos-documentation-internal v))) + (if (or f v) + (if (setq apropos-item + (cdr (assq symbol apropos-accumulator))) + (progn + (if f + (setcar apropos-item f)) + (if v + (setcar (cdr apropos-item) v))) + (setq apropos-accumulator + (cons (list symbol f v) + apropos-accumulator))))))) + (apropos-print do-all nil t)) + (kill-buffer standard-input)))) + + +(defun apropos-value-internal (predicate symbol function) + (if (funcall predicate symbol) + (progn + (setq symbol (prin1-to-string (funcall function symbol))) + (if (string-match apropos-regexp symbol) + (progn + (if apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + symbol)) + symbol))))) + +(defun apropos-documentation-internal (doc) + (if (consp doc) + (apropos-documentation-check-elc-file (car doc)) + (and doc + (string-match apropos-regexp doc) + (progn + (if apropos-match-face + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face + (setq doc (copy-sequence doc)))) + doc)))) + +(defun apropos-format-plist (pl sep &optional compare) (setq pl (symbol-plist pl)) (let (p p-out) (while pl (setq p (format "%s %S" (car pl) (nth 1 pl))) - (if (string-match (or regexp "") p) - (if apropos-use-faces + (if (or (not compare) (string-match apropos-regexp p)) + (if apropos-property-face (put-text-property 0 (length (symbol-name (car pl))) - 'face 'bold-italic p)) + 'face apropos-property-face p)) (setq p nil)) - (if p (setq p-out (concat p-out (if p-out sep) p))) + (if p + (progn + (and compare apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + p)) + (setq p-out (concat p-out (if p-out sep) p)))) (setq pl (nthcdr 2 pl))) p-out)) +;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name. -;;;###autoload -(defun apropos-documentation (regexp &optional do-all) - "Show symbols whose names or documentation contain matches for REGEXP. -With optional prefix ARG or if `apropos-do-all' is non-nil, also use -documentation that is not stored in the documentation file and show key -bindings. -Returns list of symbols and documentation found." - (interactive "sApropos documentation (regexp): \nP") - (setq do-all (or apropos-do-all do-all)) - (let (accumulator fn-doc var-doc item) - (setq accumulator (apropos-documentation-check-doc-file regexp)) - (if do-all - (mapatoms - (lambda (symbol) - (setq fn-doc (safe-documentation symbol) - var-doc (get symbol 'variable-documentation)) - (if (numberp var-doc) - (setq var-doc nil)) - (if (string-match regexp (symbol-name symbol)) - () - (if fn-doc - (or (string-match regexp fn-doc) - (setq fn-doc nil))) - (if var-doc - (or (string-match regexp var-doc) - (setq var-doc nil)))) - (if (or fn-doc var-doc) - (if (setq item (cdr (assq symbol accumulator))) - (progn - (if fn-doc - (setcar item fn-doc)) - (if var-doc - (setcar (cdr item) var-doc))) - (setq accumulator - (cons (list symbol fn-doc var-doc) - accumulator))))))) - (apropos-print regexp accumulator do-all nil t))) - - - -;; Finds all documentation related to REGEXP in internal-doc-file-name. -;; Returns an alist of form ((symbol fn-doc var-doc) ...). - -(defun apropos-documentation-check-doc-file (regexp) - (let ((doc-buffer (get-buffer-create " *apropos-doc*")) - ;; item is already let - type symbol sym-list) - (set-buffer doc-buffer) - (goto-char (point-min)) - (if (eobp) - (insert-file-contents (concat doc-directory internal-doc-file-name))) - (while (re-search-forward regexp nil t) +(defun apropos-documentation-check-doc-file () + (let (type symbol beg end) + (insert-file-contents (concat doc-directory internal-doc-file-name)) + (while (re-search-forward apropos-regexp nil t) + (setq beg (match-beginning 0) + end (point)) (search-backward "\C-_") - (or (setq type (if (eq ?F (char-after (1+ (point)))) - 1 ;function documentation - 2) ;variable documentation - symbol (progn - (forward-char 2) - (read doc-buffer)) - doc (buffer-substring - (1+ (point)) - (if (search-forward "\C-_" nil 'move) - (1- (point)) - (point))) - item (assq symbol sym-list)) - (setq item (list symbol nil nil) - sym-list (cons item sym-list))) - (setcar (nthcdr type item) doc)) - sym-list)) - - - -;; This function is misnamed, it is simply a variety of the original -;; that might be handled easier and more efficiently by that with a flag. -;; Otherwise it might be inlined above. - -(defun safe-documentation (function) + (if (> (point) beg) + () + (or (setq type (if (eq ?F (char-after (1+ (point)))) + 1 ;function documentation + 2) ;variable documentation + symbol (prog2 + (forward-char 2) + (read)) + beg (- beg (point) 1) + end (- end (point) 1) + doc (buffer-substring + (1+ (point)) + (if (search-forward "\C-_" nil 'move) + (1- (point)) + (point))) + apropos-item (assq symbol apropos-accumulator)) + (setq apropos-item (list symbol nil nil) + apropos-accumulator (cons apropos-item apropos-accumulator))) + (and apropos-match-face + (>= beg 0) + (put-text-property beg end 'face apropos-match-face doc)) + (setcar (nthcdr type apropos-item) doc))))) + +(defun apropos-documentation-check-elc-file (file) + (if (member file apropos-files-scanned) + nil + (let (symbol doc beg end end1 this-is-a-variable) + (setq apropos-files-scanned (cons file apropos-files-scanned)) + (erase-buffer) + (insert-file-contents file) + (while (search-forward "\n#@" nil t) + ;; Read the comment length, and advance over it. + (setq end (read) + beg (point) + end (+ (point) end 1)) + (if (re-search-forward apropos-regexp end t) + (progn + (goto-char end) + (setq doc (buffer-substring (1+ beg) (- end 2)) + end1 (- (match-end 0) beg 1) + beg (- (match-beginning 0) beg 1) + this-is-a-variable (looking-at "(defvar\\|(defconst") + symbol (progn + (skip-chars-forward "(a-z") + (forward-char 1) + (read)) + symbol (if (consp symbol) + (nth 1 symbol) + symbol)) + (if (if this-is-a-variable + (get symbol 'variable-documentation) + (and (fboundp symbol) (apropos-safe-documentation symbol))) + (progn + (or (setq apropos-item (assq symbol apropos-accumulator)) + (setq apropos-item (list symbol nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (if apropos-match-face + (put-text-property beg end1 'face apropos-match-face + doc)) + (setcar (nthcdr (if this-is-a-variable 2 1) + apropos-item) + doc))))) + (goto-char end))))) + + + +(defun apropos-safe-documentation (function) "Like documentation, except it avoids calling `get_doc_string'. Will return nil instead." (while (and function (symbolp function)) @@ -287,33 +389,42 @@ Will return nil instead." (if (eq (car-safe function) 'macro) (setq function (cdr function))) (setq function (if (byte-code-function-p function) - (condition-case nil - (aref function 4) - (error)) - (if (memq (car-safe function) '(lambda autoload)) - (nth 2 function)))) - (if (stringp function) - function)) - - - -(defun apropos-print (regexp apropos-result do-keys doc-fn spacing) - "Output result of various appropos commands with REGEXP. -APROPOS-RESULT is a list. Optional DOC-FN is called for each element -of apropos-result and may modify it resulting in (symbol fn-doc + (if (> (length function) 4) + (aref function 4)) + (if (eq (car-safe function) 'autoload) + (nth 2 function) + (if (eq (car-safe function) 'lambda) + (if (stringp (nth 2 function)) + (nth 2 function) + (if (stringp (nth 3 function)) + (nth 3 function))))))) + (if (integerp function) + nil + function)) + + + +(defun apropos-print (do-keys doc-fn spacing) + "Output result of various apropos commands with `apropos-regexp'. +APROPOS-ACCUMULATOR is a list. Optional DOC-FN is called for each element +of apropos-accumulator and may modify it resulting in (symbol fn-doc var-doc [plist-doc]). Returns sorted list of symbols and documentation found." - (if (null apropos-result) - (message "No apropos matches for `%s'" regexp) + (if (null apropos-accumulator) + (message "No apropos matches for `%s'" apropos-regexp) (if doc-fn - (funcall doc-fn apropos-result)) - (setq apropos-result - (sort apropos-result (lambda (a b) + (funcall doc-fn apropos-accumulator)) + (setq apropos-accumulator + (sort apropos-accumulator (lambda (a b) (string-lessp (car a) (car b))))) + (and apropos-label-face + (symbolp apropos-label-face) + (setq apropos-label-face `(face ,apropos-label-face + mouse-face highlight))) (with-output-to-temp-buffer "*Help*" - (let ((p apropos-result) + (let ((p apropos-accumulator) (old-buffer (current-buffer)) - symbol item tem point1 point2) + symbol item point1 point2) (save-excursion (set-buffer standard-output) (if window-system @@ -323,8 +434,8 @@ found." "In this buffer, type \\\\[apropos-follow] to get full documentation.\n\n")) (while (consp p) (or (not spacing) (bobp) (terpri)) - (setq item (car p) - symbol (car item) + (setq apropos-item (car p) + symbol (car apropos-item) p (cdr p) point1 (point)) (princ symbol) ;print symbol name @@ -333,47 +444,69 @@ found." (and do-keys (commandp symbol) (indent-to 30 1) - (princ (if (setq tem (save-excursion - (set-buffer old-buffer) - (where-is-internal symbol))) - (mapconcat 'key-description tem ", ") - "(not bound to any keys)"))) + (insert + (if (setq item (save-excursion + (set-buffer old-buffer) + (where-is-internal symbol))) + (mapconcat + (if apropos-keybinding-face + (lambda (key) + (setq key (key-description key)) + (put-text-property 0 (length key) + 'face apropos-keybinding-face + key) + key) + 'key-description) + item ", ") + "(not bound to any keys)"))) (terpri) ;; only now so we don't propagate text attributes all over (put-text-property point1 (1+ point1) 'item - (if (or (nth 1 item) (nth 2 item) (nth 3 item)) - (car item) - item)) - (if apropos-use-faces - (put-text-property point1 point2 'face 'bold)) - (apropos-print-documentation 'describe-function (nth 1 item) - (if (commandp symbol) - "Command: " - "Function: ") - do-keys) - (apropos-print-documentation 'describe-variable (nth 2 item) - "Variable: " do-keys) - (apropos-print-documentation 'apropos-describe-plist (nth 3 item) - "Plist: " nil)) + (if (eval `(or ,@(cdr apropos-item))) + (car apropos-item) + apropos-item)) + (if apropos-symbol-face + (put-text-property point1 point2 'face apropos-symbol-face)) + (apropos-print-doc 'describe-function 1 + (if (commandp symbol) + "Command" + (if (apropos-macrop symbol) + "Macro" + "Function")) + do-keys) + (apropos-print-doc 'describe-variable 2 + "Variable" do-keys) + (apropos-print-doc 'apropos-describe-plist 3 + "Plist" nil)) (put-text-property 1 (point) 'local-map apropos-local-map))))) - apropos-result) + (prog1 apropos-accumulator + (setq apropos-accumulator ()))) ; permit gc + +(defun apropos-macrop (symbol) + "T if SYMBOL is a Lisp macro." + (and (fboundp symbol) + (consp (setq symbol + (symbol-function symbol))) + (or (eq (car symbol) 'macro) + (if (eq (car symbol) 'autoload) + (memq (nth 4 symbol) + '(macro t)))))) -(defun apropos-print-documentation (action tem str do-keys) - (if tem + +(defun apropos-print-doc (action i str do-keys) + (if (stringp (setq i (nth i apropos-item))) (progn (insert " ") (put-text-property (- (point) 2) (1- (point)) 'action action) - (princ str) - (if apropos-use-faces - (add-text-properties (- (point) (length str)) + (insert str ": ") + (if apropos-label-face + (add-text-properties (- (point) (length str) 2) (1- (point)) - '(face italic - mouse-face highlight))) - (insert (if do-keys (substitute-command-keys tem) tem)))) - (or (bolp) (terpri))) - + apropos-label-face)) + (insert (if do-keys (substitute-command-keys i) i)) + (or (bolp) (terpri))))) (defun apropos-mouse-follow (event) @@ -383,7 +516,7 @@ found." (current-buffer)))) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) - ;; somehow when clicking with the point in another window, doesn't undo + ;; somehow when clicking with the point in another window, undoes badly (undo-boundary) (apropos-follow other))) @@ -427,8 +560,8 @@ found." (princ "Symbol ") (prin1 symbol) (princ "'s plist is\n (") - (if apropos-use-faces - (put-text-property 8 (- (point) 14) 'face 'bold)) + (if apropos-symbol-face + (put-text-property 8 (- (point) 14) 'face apropos-symbol-face)) (insert (apropos-format-plist symbol "\n ")) (princ ")"))) -- 2.39.2