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 @@
;;; 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,10 +95,23 @@ 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'.")
;;;###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
(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.
With optional prefix ARG or if `apropos-do-all' is non-nil, also show
variables."
......@@ -88,17 +120,18 @@ variables."
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))))
(if (apropos-print
regexp
(apropos-internal regexp
(or do-all (setq do-all apropos-do-all))
(setq apropos-accumulator
(apropos-internal apropos-regexp
(if do-all
(lambda (x) (or (commandp x)
(user-variable-p x)))
'commandp))
(lambda (symbol) (or (commandp symbol)
(user-variable-p symbol)))
'commandp)))
(if (apropos-print
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))
(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))
(setq apropos-accumulator (cons (list symbol f v p)
apropos-accumulator))))))
(apropos-print nil nil t))
;;;###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.
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))
(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 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)))
(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 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)))
(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 (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.
;; 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)
;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name.
(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-_")
(if (> (point) beg)
()
(or (setq type (if (eq ?F (char-after (1+ (point))))
1 ;function documentation
2) ;variable documentation
symbol (progn
symbol (prog2
(forward-char 2)
(read doc-buffer))
(read))
beg (- beg (point) 1)
end (- end (point) 1)
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))
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)))))
;; 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'.
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)
(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 (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
(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-local-map>\\[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
(insert
(if (setq item (save-excursion
(set-buffer old-buffer)
(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)")))
(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 (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: "
"Function: ")
"Command"
(if (apropos-macrop symbol)
"Macro"
"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))
(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 ")")))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment