Commit 645c4f6a authored by Karl Heuer's avatar Karl Heuer
Browse files

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.
parent 821d417e
...@@ -44,8 +44,8 @@ ...@@ -44,8 +44,8 @@
;;; Made doc file buffer read-only, buried it. ;;; Made doc file buffer read-only, buried it.
;; Only call substitute-command-keys if do-all set. ;; Only call substitute-command-keys if do-all set.
;; Optionally use faces to make the output more legible. ;; Optionally use configurable faces to make the output more legible.
;; Differentiate between command and function. ;; Differentiate between command, function and macro.
;; Apropos-command (ex command-apropos) does cmd and optionally user var. ;; Apropos-command (ex command-apropos) does cmd and optionally user var.
;; Apropos shows all 3 aspects of symbols (fn, var and plist) ;; Apropos shows all 3 aspects of symbols (fn, var and plist)
;; Apropos-documentation (ex super-apropos) now finds all it should. ;; Apropos-documentation (ex super-apropos) now finds all it should.
...@@ -62,8 +62,27 @@ ...@@ -62,8 +62,27 @@
Slows them down more or less. Set this non-nil if you have a fast machine.") Slows them down more or less. Set this non-nil if you have a fast machine.")
(defvar apropos-use-faces window-system (defvar apropos-symbol-face (if window-system 'bold)
"*Whether the apropos commands display output using bold and italic. "*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.") This looks good, but slows down the commands several times.")
...@@ -76,10 +95,23 @@ This looks good, but slows down the commands several times.") ...@@ -76,10 +95,23 @@ This looks good, but slows down the commands several times.")
"Local map active when displaying apropos output.") "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'.")
;;;###autoload (fset 'command-apropos 'apropos-command) (defvar apropos-accumulator ()
"Alist of symbols already found in current apropos run.")
(defvar apropos-item ()
"Current item in or for apropos-accumulator.")
;; For auld lang syne:
;;;###autoload ;;;###autoload
(defun apropos-command (regexp &optional do-all) (fset 'command-apropos 'apropos-command)
;;;###autoload
(defun apropos-command (apropos-regexp &optional do-all)
"Shows commands (interactively callable functions) that match REGEXP. "Shows commands (interactively callable functions) that match REGEXP.
With optional prefix ARG or if `apropos-do-all' is non-nil, also show With optional prefix ARG or if `apropos-do-all' is non-nil, also show
variables." variables."
...@@ -88,17 +120,18 @@ variables." ...@@ -88,17 +120,18 @@ variables."
apropos-do-all) apropos-do-all)
"or variable ") "or variable ")
"(regexp): ")) "(regexp): "))
(or current-prefix-arg apropos-do-all))) current-prefix-arg))
(let ((message (let ((message
(let ((standard-output (get-buffer-create "*Help*"))) (let ((standard-output (get-buffer-create "*Help*")))
(print-help-return-message 'identity)))) (print-help-return-message 'identity))))
(if (apropos-print (or do-all (setq do-all apropos-do-all))
regexp (setq apropos-accumulator
(apropos-internal regexp (apropos-internal apropos-regexp
(if do-all (if do-all
(lambda (x) (or (commandp x) (lambda (symbol) (or (commandp symbol)
(user-variable-p x))) (user-variable-p symbol)))
'commandp)) 'commandp)))
(if (apropos-print
t t
(lambda (p) (lambda (p)
(let (doc symbol) (let (doc symbol)
...@@ -120,17 +153,23 @@ variables." ...@@ -120,17 +153,23 @@ variables."
(and message (message message))))) (and message (message message)))))
;;;###autoload ;;;###autoload
(defun apropos (regexp &optional do-all) (defun apropos (apropos-regexp &optional do-all)
"Show all symbols whose names match REGEXP. "Show all bound symbols whose names match REGEXP.
With optional prefix ARG or if `apropos-do-all' is non-nil, also show key With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound
bindings, which is a little more time-consuming. symbols and key bindings, which is a little more time-consuming.
Returns list of symbols and documentation found." Returns list of symbols and documentation found."
(interactive "sApropos symbol (regexp): \nP") (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 (apropos-print
regexp (apropos-internal regexp) (or do-all apropos-do-all)
(or apropos-do-all do-all)
(lambda (p) (lambda (p)
(let (symbol doc) (let (symbol doc)
(while p (while p
...@@ -154,131 +193,194 @@ Returns list of symbols and documentation found." ...@@ -154,131 +193,194 @@ Returns list of symbols and documentation found."
nil)) nil))
;;;###autoload ;;;###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. "Show all symbols whose value's printed image matches REGEXP.
With optional prefix ARG or if `apropos-do-all' is non-nil, also looks 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. 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") (interactive "sApropos value (regexp): \nP")
(setq do-all (or apropos-do-all do-all)) (or do-all (setq do-all apropos-do-all))
(apropos-print (setq apropos-accumulator ())
regexp (let (f v p)
(let (accumulator f v p)
(mapatoms (mapatoms
(lambda (symbol) (lambda (symbol)
(setq f nil v nil p nil) (setq f nil v nil p nil)
(or (memq symbol '(regexp do-all accumulator symbol v pl p)) (or (memq symbol '(apropos-regexp do-all apropos-accumulator
(if (boundp symbol) symbol f v p))
(setq v (prin1-to-string (symbol-value symbol)) (setq v (apropos-value-internal 'boundp symbol 'symbol-value)))
v (if (string-match regexp v) v))))
(if do-all (if do-all
(progn (setq f (apropos-value-internal 'fboundp symbol 'symbol-function)
(if (fboundp symbol) p (apropos-format-plist symbol "\n " t)))
(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))
(if (or f v p) (if (or f v p)
(setq accumulator (cons (list symbol f v p) accumulator))))) (setq apropos-accumulator (cons (list symbol f v p)
accumulator) apropos-accumulator))))))
nil nil t)) (apropos-print nil nil t))
(defun apropos-format-plist (pl sep &optional regexp)
(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
(put-text-property 0 (length (symbol-name (car pl)))
'face 'bold-italic p))
(setq p nil))
(if p (setq p-out (concat p-out (if p-out sep) p)))
(setq pl (nthcdr 2 pl)))
p-out))
;;;###autoload ;;;###autoload
(defun apropos-documentation (regexp &optional do-all) (defun apropos-documentation (apropos-regexp &optional do-all)
"Show symbols whose names or documentation contain matches for REGEXP. "Show symbols whose names or documentation contain matches for REGEXP.
With optional prefix ARG or if `apropos-do-all' is non-nil, also use 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 documentation that is not stored in the documentation file and show key
bindings. bindings.
Returns list of symbols and documentation found." Returns list of symbols and documentation found."
(interactive "sApropos documentation (regexp): \nP") (interactive "sApropos documentation (regexp): \nP")
(setq do-all (or apropos-do-all do-all)) (or do-all (setq do-all apropos-do-all))
(let (accumulator fn-doc var-doc item) (setq apropos-accumulator () apropos-files-scanned ())
(setq accumulator (apropos-documentation-check-doc-file regexp)) (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 (if do-all
(mapatoms (mapatoms
(lambda (symbol) (lambda (symbol)
(setq fn-doc (safe-documentation symbol) (setq f (apropos-safe-documentation symbol)
var-doc (get symbol 'variable-documentation)) v (get symbol 'variable-documentation)
(if (numberp var-doc) v (if (integerp v) nil v))
(setq var-doc nil)) (or (string-match apropos-regexp (symbol-name symbol))
(if (string-match regexp (symbol-name symbol)) (setq f (apropos-documentation-internal f)
() v (apropos-documentation-internal v)))
(if fn-doc (if (or f v)
(or (string-match regexp fn-doc) (if (setq apropos-item
(setq fn-doc nil))) (cdr (assq symbol apropos-accumulator)))
(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 (progn
(if fn-doc (if f
(setcar item fn-doc)) (setcar apropos-item f))
(if var-doc (if v
(setcar (cdr item) var-doc))) (setcar (cdr apropos-item) v)))
(setq accumulator (setq apropos-accumulator
(cons (list symbol fn-doc var-doc) (cons (list symbol f v)
accumulator))))))) apropos-accumulator)))))))
(apropos-print regexp accumulator do-all nil t))) (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 (or (not compare) (string-match apropos-regexp p))
(if apropos-property-face
(put-text-property 0 (length (symbol-name (car pl)))
'face apropos-property-face p))
(setq p nil))
(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 REGEXP in internal-doc-file-name. ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
;; Returns an alist of form ((symbol fn-doc var-doc) ...).
(defun apropos-documentation-check-doc-file ()
(defun apropos-documentation-check-doc-file (regexp) (let (type symbol beg end)
(let ((doc-buffer (get-buffer-create " *apropos-doc*")) (insert-file-contents (concat doc-directory internal-doc-file-name))
;; item is already let (while (re-search-forward apropos-regexp nil t)
type symbol sym-list) (setq beg (match-beginning 0)
(set-buffer doc-buffer) end (point))
(goto-char (point-min))
(if (eobp)
(insert-file-contents (concat doc-directory internal-doc-file-name)))
(while (re-search-forward regexp nil t)
(search-backward "\C-_") (search-backward "\C-_")
(if (> (point) beg)
()
(or (setq type (if (eq ?F (char-after (1+ (point)))) (or (setq type (if (eq ?F (char-after (1+ (point))))
1 ;function documentation 1 ;function documentation
2) ;variable documentation 2) ;variable documentation
symbol (progn symbol (prog2
(forward-char 2) (forward-char 2)
(read doc-buffer)) (read))
beg (- beg (point) 1)
end (- end (point) 1)
doc (buffer-substring doc (buffer-substring
(1+ (point)) (1+ (point))
(if (search-forward "\C-_" nil 'move) (if (search-forward "\C-_" nil 'move)
(1- (point)) (1- (point))
(point))) (point)))
item (assq symbol sym-list)) apropos-item (assq symbol apropos-accumulator))
(setq item (list symbol nil nil) (setq apropos-item (list symbol nil nil)
sym-list (cons item sym-list))) apropos-accumulator (cons apropos-item apropos-accumulator)))
(setcar (nthcdr type item) doc)) (and apropos-match-face
sym-list)) (>= 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)))))
;; 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) (defun apropos-safe-documentation (function)
"Like documentation, except it avoids calling `get_doc_string'. "Like documentation, except it avoids calling `get_doc_string'.
Will return nil instead." Will return nil instead."
(while (and function (symbolp function)) (while (and function (symbolp function))
...@@ -287,33 +389,42 @@ Will return nil instead." ...@@ -287,33 +389,42 @@ Will return nil instead."
(if (eq (car-safe function) 'macro) (if (eq (car-safe function) 'macro)
(setq function (cdr function))) (setq function (cdr function)))
(setq function (if (byte-code-function-p function) (setq function (if (byte-code-function-p function)
(condition-case nil (if (> (length function) 4)
(aref function 4) (aref function 4))
(error)) (if (eq (car-safe function) 'autoload)
(if (memq (car-safe function) '(lambda autoload)) (nth 2 function)
(nth 2 function)))) (if (eq (car-safe function) 'lambda)
(if (stringp function) (if (stringp (nth 2 function))
(nth 2 function)
(if (stringp (nth 3 function))
(nth 3 function)))))))
(if (integerp function)
nil
function)) function))
(defun apropos-print (regexp apropos-result do-keys doc-fn spacing) (defun apropos-print (do-keys doc-fn spacing)
"Output result of various appropos commands with REGEXP. "Output result of various apropos commands with `apropos-regexp'.
APROPOS-RESULT is a list. Optional DOC-FN is called for each element APROPOS-ACCUMULATOR is a list. Optional DOC-FN is called for each element
of apropos-result and may modify it resulting in (symbol fn-doc of apropos-accumulator and may modify it resulting in (symbol fn-doc
var-doc [plist-doc]). Returns sorted list of symbols and documentation var-doc [plist-doc]). Returns sorted list of symbols and documentation
found." found."
(if (null apropos-result) (if (null apropos-accumulator)
(message "No apropos matches for `%s'" regexp) (message "No apropos matches for `%s'" apropos-regexp)
(if doc-fn (if doc-fn
(funcall doc-fn apropos-result)) (funcall doc-fn apropos-accumulator))
(setq apropos-result (setq apropos-accumulator
(sort apropos-result (lambda (a b) (sort apropos-accumulator (lambda (a b)
(string-lessp (car a) (car 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*" (with-output-to-temp-buffer "*Help*"
(let ((p apropos-result) (let ((p apropos-accumulator)
(old-buffer (current-buffer)) (old-buffer (current-buffer))
symbol item tem point1 point2) symbol item point1 point2)
(save-excursion (save-excursion
(set-buffer standard-output) (set-buffer standard-output)
(if window-system (if window-system
...@@ -323,8 +434,8 @@ found." ...@@ -323,8 +434,8 @@ found."
"In this buffer, type \\<apropos-local-map>\\[apropos-follow] to get full documentation.\n\n")) "In this buffer, type \\<apropos-local-map>\\[apropos-follow] to get full documentation.\n\n"))
(while (consp p) (while (consp p)
(or (not spacing) (bobp) (terpri)) (or (not spacing) (bobp) (terpri))
(setq item (car p) (setq apropos-item (car p)
symbol (car item) symbol (car apropos-item)
p (cdr p) p (cdr p)
point1 (point)) point1 (point))
(princ symbol) ;print symbol name (princ symbol) ;print symbol name
...@@ -333,47 +444,69 @@ found." ...@@ -333,47 +444,69 @@ found."
(and do-keys (and do-keys
(commandp symbol) (commandp symbol)
(indent-to 30 1) (indent-to 30 1)
(princ (if (setq tem (save-excursion (insert
(if (setq item (save-excursion
(set-buffer old-buffer) (set-buffer old-buffer)
(where-is-internal symbol))) (where-is-internal symbol)))
(mapconcat 'key-description tem ", ") (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)"))) "(not bound to any keys)")))
(terpri) (terpri)
;; only now so we don't propagate text attributes all over ;; only now so we don't propagate text attributes all over
(put-text-property point1 (1+ point1) 'item (put-text-property point1 (1+ point1) 'item
(if (or (nth 1 item) (nth 2 item) (nth 3 item)) (if (eval `(or ,@(cdr apropos-item)))
(car item) (car apropos-item)
item)) apropos-item))
(if apropos-use-faces (if apropos-symbol-face
(put-text-property point1 point2 'face 'bold)) (put-text-property point1 point2 'face apropos-symbol-face))
(apropos-print-documentation 'describe-function (nth 1 item) (apropos-print-doc 'describe-function 1
(if (commandp symbol) (if (commandp symbol)
"Command: " "Command"
"Function: ") (if (apropos-macrop symbol)
"Macro"
"Function"))
do-keys) do-keys)
(apropos-print-documentation 'describe-variable (nth 2 item) (apropos-print-doc 'describe-variable 2
"Variable: " do-keys) "Variable" do-keys)
(apropos-print-documentation 'apropos-describe-plist (nth 3 item) (apropos-print-doc 'apropos-describe-plist 3
"Plist: " nil)) "Plist" nil))
(put-text-property 1 (point) 'local-map apropos-local-map))))) (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