2116 |
(let (enabled-advices) |
(let (enabled-advices) |
2117 |
(ad-dolist (advice (ad-get-advice-info-field function class)) |
(ad-dolist (advice (ad-get-advice-info-field function class)) |
2118 |
(if (ad-advice-enabled advice) |
(if (ad-advice-enabled advice) |
2119 |
(setq enabled-advices (cons advice enabled-advices)))) |
(push advice enabled-advices))) |
2120 |
(reverse enabled-advices))) |
(reverse enabled-advices))) |
2121 |
|
|
2122 |
|
|
2475 |
with-output-to-temp-buffer))) |
with-output-to-temp-buffer))) |
2476 |
;; track-mouse could be void in some configurations. |
;; track-mouse could be void in some configurations. |
2477 |
(if (fboundp 'track-mouse) |
(if (fboundp 'track-mouse) |
2478 |
(setq tem (cons 'track-mouse tem))) |
(push 'track-mouse tem)) |
2479 |
(mapcar 'symbol-function tem))) |
(mapcar 'symbol-function tem))) |
2480 |
|
|
2481 |
(defmacro ad-special-form-p (definition) |
(defmacro ad-special-form-p (definition) |
2545 |
;; otherwise get it from its printed representation: |
;; otherwise get it from its printed representation: |
2546 |
(setq name (format "%s" definition)) |
(setq name (format "%s" definition)) |
2547 |
(string-match "^#<subr \\([^>]+\\)>$" name) |
(string-match "^#<subr \\([^>]+\\)>$" name) |
2548 |
(ad-subr-arglist |
(ad-subr-arglist (intern (match-string 1 name))))))) |
|
(intern (substring name (match-beginning 1) (match-end 1)))))))) |
|
2549 |
|
|
2550 |
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish |
;; Store subr-args as `((arg1 arg2 ...))' so I can distinguish |
2551 |
;; a defined empty arglist `(nil)' from an undefined arglist: |
;; a defined empty arglist `(nil)' from an undefined arglist: |
2582 |
(ad-define-subr-args |
(ad-define-subr-args |
2583 |
subr-name |
subr-name |
2584 |
(cdr (car (read-from-string |
(cdr (car (read-from-string |
2585 |
(downcase |
(downcase (match-string 1 doc)))))) |
|
(substring doc |
|
|
(match-beginning 1) |
|
|
(match-end 1))))))) |
|
|
(ad-get-subr-args subr-name)) |
|
|
;; this is the old format used before Emacs 19.24: |
|
|
((string-match |
|
|
"[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" doc) |
|
|
(ad-define-subr-args |
|
|
subr-name |
|
|
(car (read-from-string |
|
|
doc (match-beginning 1) (match-end 1)))) |
|
2586 |
(ad-get-subr-args subr-name)) |
(ad-get-subr-args subr-name)) |
2587 |
|
;; This is actually an error. |
2588 |
(t '(&rest ad-subr-args))))))) |
(t '(&rest ad-subr-args))))))) |
2589 |
|
|
2590 |
(defun ad-docstring (definition) |
(defun ad-docstring (definition) |
2988 |
(capitalize (symbol-name class)) |
(capitalize (symbol-name class)) |
2989 |
(ad-advice-name advice))))))) |
(ad-advice-name advice))))))) |
2990 |
|
|
2991 |
|
(require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage. |
2992 |
|
|
2993 |
(defun ad-make-advised-docstring (function &optional style) |
(defun ad-make-advised-docstring (function &optional style) |
2994 |
;;"Constructs a documentation string for the advised FUNCTION. |
"Construct a documentation string for the advised FUNCTION. |
2995 |
;;It concatenates the original documentation with the documentation |
It concatenates the original documentation with the documentation |
2996 |
;;strings of the individual pieces of advice which will be formatted |
strings of the individual pieces of advice which will be formatted |
2997 |
;;according to STYLE. STYLE can be `plain' or `freeze', everything else |
according to STYLE. STYLE can be `plain' or `freeze', everything else |
2998 |
;;will be interpreted as `default'. The order of the advice documentation |
will be interpreted as `default'. The order of the advice documentation |
2999 |
;;strings corresponds to before/around/after and the individual ordering |
strings corresponds to before/around/after and the individual ordering |
3000 |
;;in any of these classes." |
in any of these classes." |
3001 |
(let* ((origdef (ad-real-orig-definition function)) |
(let* ((origdef (ad-real-orig-definition function)) |
3002 |
(origtype (symbol-name (ad-definition-type origdef))) |
(origtype (symbol-name (ad-definition-type origdef))) |
3003 |
(origdoc |
(origdoc |
3004 |
;; Retrieve raw doc, key substitution will be taken care of later: |
;; Retrieve raw doc, key substitution will be taken care of later: |
3005 |
(ad-real-documentation origdef t)) |
(ad-real-documentation origdef t)) |
3006 |
paragraphs advice-docstring) |
(usage (help-split-fundoc origdoc function)) |
3007 |
|
paragraphs advice-docstring ad-usage) |
3008 |
|
(if usage (setq origdoc (cdr usage) usage (car usage))) |
3009 |
(if origdoc (setq paragraphs (list origdoc))) |
(if origdoc (setq paragraphs (list origdoc))) |
3010 |
(if (not (eq style 'plain)) |
(unless (eq style 'plain) |
3011 |
(setq paragraphs (cons (concat "This " origtype " is advised.") |
(push (concat "This " origtype " is advised.") paragraphs)) |
|
paragraphs))) |
|
3012 |
(ad-dolist (class ad-advice-classes) |
(ad-dolist (class ad-advice-classes) |
3013 |
(ad-dolist (advice (ad-get-enabled-advices function class)) |
(ad-dolist (advice (ad-get-enabled-advices function class)) |
3014 |
(setq advice-docstring |
(setq advice-docstring |
3015 |
(ad-make-single-advice-docstring advice class style)) |
(ad-make-single-advice-docstring advice class style)) |
3016 |
(if advice-docstring |
(if advice-docstring |
3017 |
(setq paragraphs (cons advice-docstring paragraphs))))) |
(push advice-docstring paragraphs)))) |
3018 |
(if paragraphs |
(setq origdoc (if paragraphs |
3019 |
;; separate paragraphs with blank lines: |
;; separate paragraphs with blank lines: |
3020 |
(mapconcat 'identity (nreverse paragraphs) "\n\n")))) |
(mapconcat 'identity (nreverse paragraphs) "\n\n"))) |
3021 |
|
(help-add-fundoc-usage origdoc usage))) |
3022 |
|
|
3023 |
(defun ad-make-plain-docstring (function) |
(defun ad-make-plain-docstring (function) |
3024 |
(ad-make-advised-docstring function 'plain)) |
(ad-make-advised-docstring function 'plain)) |