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,29 +95,43 @@ 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.") "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 ;;;###autoload
(defun apropos-command (regexp &optional do-all) (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."
(interactive (list (read-string (concat "Apropos command " (interactive (list (read-string (concat "Apropos command "
(if (or current-prefix-arg (if (or current-prefix-arg
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))))
(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 (if (apropos-print
regexp
(apropos-internal regexp
(if do-all
(lambda (x) (or (commandp x)
(user-variable-p x)))
'commandp))
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) ;;;###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)) (setq pl (symbol-plist pl))
(let (p p-out) (let (p p-out)
(while pl (while pl
(setq p (format "%s %S" (car pl) (nth 1 pl))) (setq p (format "%s %S" (car pl) (nth 1 pl)))
(if (string-match (or regexp "") p) (if (or (not compare) (string-match apropos-regexp p))
(if apropos-use-faces (if apropos-property-face
(put-text-property 0 (length (symbol-name (car pl))) (put-text-property 0 (length (symbol-name (car pl)))
'face 'bold-italic p)) 'face apropos-property-face p))
(setq p nil)) (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))) (setq pl (nthcdr 2 pl)))
p-out)) p-out))
;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
;;;###autoload (defun apropos-documentation-check-doc-file ()
(defun apropos-documentation (regexp &optional do-all) (let (type symbol beg end)
"Show symbols whose names or documentation contain matches for REGEXP. (insert-file-contents (concat doc-directory internal-doc-file-name))
With optional prefix ARG or if `apropos-do-all' is non-nil, also use (while (re-search-forward apropos-regexp nil t)
documentation that is not stored in the documentation file and show key (setq beg (match-beginning 0)
bindings. end (point))
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)
(search-backward "\C-_") (search-backward "\C-_")
(or (setq type (if (eq ?F (char-after (1+ (point)))) (if (> (point) beg)
1 ;function documentation ()
2) ;variable documentation (or (setq type (if (eq ?F (char-after (1+ (point))))
symbol (progn 1 ;function documentation
(forward-char 2) 2) ;variable documentation
(read doc-buffer)) symbol (prog2
doc (buffer-substring (forward-char 2)
(1+ (point)) (read))
(if (search-forward "\C-_" nil 'move) beg (- beg (point) 1)
(1- (point)) end (- end (point) 1)
(point))) doc (buffer-substring
item (assq symbol sym-list)) (1+ (point))
(setq item (list symbol nil nil) (if (search-forward "\C-_" nil 'move)
sym-list (cons item sym-list))) (1- (point))
(setcar (nthcdr type item) doc)) (point)))
sym-list)) apropos-item (assq symbol apropos-accumulator))
(setq apropos-item (list symbol nil nil)
apropos-accumulator (cons apropos-item apropos-accumulator)))
(and apropos-match-face
;; This function is misnamed, it is simply a variety of the original (>= beg 0)
;; that might be handled easier and more efficiently by that with a flag. (put-text-property beg end 'face apropos-match-face doc))
;; Otherwise it might be inlined above. (setcar (nthcdr type apropos-item) doc)))))
(defun safe-documentation (function) (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'. "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))
function)) (nth 2 function)
(if (stringp (nth 3 function))
(nth 3 function)))))))
(if (integerp function)
(defun apropos-print (regexp apropos-result do-keys doc-fn spacing) nil
"Output result of various appropos commands with REGEXP. function))
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
(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 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
(set-buffer old-buffer) (if (setq item (save-excursion
(where-is-internal symbol))) (set-buffer old-buffer)
(mapconcat 'key-description tem ", ") (where-is-internal symbol)))
"(not bound to any keys)"))) (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) (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)
do-keys) "Macro"
(apropos-print-documentation 'describe-variable (nth 2 item) "Function"))
"Variable: " do-keys) do-keys)
(apropos-print-documentation 'apropos-describe-plist (nth 3 item) (apropos-print-doc 'describe-variable 2
"Plist: " nil)) "Variable" do-keys)
(apropos-print-doc 'apropos-describe-plist 3
"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))))))