/[emacs]/emacs/lisp/emacs-lisp/advice.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/advice.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.33 by rms, Sun Jul 7 09:37:09 2002 UTC revision 1.34 by monnier, Sun May 4 00:32:46 2003 UTC
# Line 2116  Redefining advices affect the constructi Line 2116  Redefining advices affect the constructi
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    
# Line 2475  will clear the cache." Line 2475  will clear the cache."
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)
# Line 2545  supplied to make subr arglist lookup mor Line 2545  supplied to make subr arglist lookup mor
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:
# Line 2583  that property, or otherwise use `(&rest Line 2582  that property, or otherwise use `(&rest
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)
# Line 2999  Example: `(ad-map-arglists '(a &rest arg Line 2988  Example: `(ad-map-arglists '(a &rest arg
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))

Legend:
Removed from v.1.33  
changed lines
  Added in v.1.34

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26