X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/95b6d681b1121e1be8955aa3f79dd39098edf4cf..62a81506f802e4824b718cc30321ee3a0057cdf7:/lisp/emacs-lisp/eieio-opt.el diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index ca3850562c..64b240b9d5 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -1,10 +1,9 @@ ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar) -;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008, -;; 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1998-2003, 2005, 2008-2012 +;; Free Software Foundation, Inc. ;; Author: Eric M. Ludlam -;; Version: 0.2 ;; Keywords: OO, lisp ;; Package: eieio @@ -30,8 +29,12 @@ ;; (require 'eieio) +(require 'button) +(require 'help-mode) +(require 'find-func) ;;; Code: +;;;###autoload (defun eieio-browse (&optional root-class) "Create an object browser window to show all objects. If optional ROOT-CLASS, then start with that, otherwise start with @@ -71,8 +74,9 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION -(defalias 'describe-class 'eieio-describe-class) +;;;###autoload(defalias 'describe-class 'eieio-describe-class) +;;;###autoload (defun eieio-describe-class (class &optional headerfcn) "Describe a CLASS defined by a string or symbol. If CLASS is actually an object, then also display current values of that object. @@ -83,13 +87,18 @@ Optional HEADERFCN should be called to insert a few bits of info first." (called-interactively-p 'interactive)) (when headerfcn (funcall headerfcn)) - - (if (class-option class :abstract) - (princ "Abstract ")) - (princ "Class ") (prin1 class) + (princ " is a") + (if (class-option class :abstract) + (princ "n abstract")) + (princ " class") + ;; Print file location + (when (get class 'class-location) + (princ " in `") + (princ (file-name-nondirectory (get class 'class-location))) + (princ "'")) (terpri) - ;; Inheritence tree information + ;; Inheritance tree information (let ((pl (class-parents class))) (when pl (princ " Inherits from ") @@ -238,6 +247,7 @@ Outputs to the standard output." prot (cdr prot) i (1+ i))))) +;;;###autoload (defun eieio-describe-constructor (fcn) "Describe the constructor function FCN. Uses `eieio-describe-class' to describe the class being constructed." @@ -248,8 +258,13 @@ Uses `eieio-describe-class' to describe the class being constructed." (eieio-describe-class fcn (lambda () ;; Describe the constructor part. - (princ "Object Constructor Function: ") (prin1 fcn) + (princ " is an object constructor function") + ;; Print file location + (when (get fcn 'class-location) + (princ " in `") + (princ (file-name-nondirectory (get fcn 'class-location))) + (princ "'")) (terpri) (princ "Creates an object of class ") (prin1 fcn) @@ -259,6 +274,16 @@ Uses `eieio-describe-class' to describe the class being constructed." )) ) +(defun eieio-build-class-list (class) + "Return a list of all classes that inherit from CLASS." + (if (class-p class) + (apply #'append + (mapcar + (lambda (c) + (append (list c) (eieio-build-class-list c))) + (class-children-fast class))) + (list class))) + (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. Optional argument CLASS is the class to start with. @@ -267,8 +292,9 @@ are not abstract, otherwise allow all classes. Optional argument BUILDLIST is more list to attach and is used internally." (let* ((cc (or class eieio-default-superclass)) (sublst (aref (class-v cc) class-children))) - (if (or (not instantiable-only) (not (class-abstract-p cc))) - (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))) + (unless (assoc (symbol-name cc) buildlist) + (when (or (not instantiable-only) (not (class-abstract-p cc))) + (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) (while sublst (setq buildlist (eieio-build-class-alist (car sublst) instantiable-only buildlist)) @@ -301,9 +327,10 @@ are not abstract." ;;; METHOD COMPLETION / DOC (defalias 'describe-method 'eieio-describe-generic) -(defalias 'describe-generic 'eieio-describe-generic) +;;;###autoload(defalias 'describe-generic 'eieio-describe-generic) (defalias 'eieio-describe-method 'eieio-describe-generic) +;;;###autoload (defun eieio-describe-generic (generic) "Describe the generic function GENERIC. Also extracts information about all methods specific to this generic." @@ -338,10 +365,10 @@ Also extracts information about all methods specific to this generic." (princ "Implementations:") (terpri) (terpri) - (let ((i 3) + (let ((i 4) (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) ;; Loop over fanciful generics - (while (< i 6) + (while (< i 7) (let ((gm (aref (get generic 'eieio-method-tree) i))) (when gm (princ "Generic ") @@ -353,8 +380,9 @@ Also extracts information about all methods specific to this generic." (setq i (1+ i))) (setq i 0) ;; Loop over defined class-specific methods - (while (< i 3) - (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))) + (while (< i 4) + (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))) + location) (while gm (princ "`") (prin1 (car (car gm))) @@ -371,6 +399,13 @@ Also extracts information about all methods specific to this generic." ;; 3 because of cdr (princ (or (documentation (cdr (car gm))) "Undocumented")) + ;; Print file location if available + (when (and (setq location (get generic 'method-locations)) + (setq location (assoc (caar gm) location))) + (setq location (cadr location)) + (princ "\n\nDefined in `") + (princ (file-name-nondirectory location)) + (princ "'\n")) (setq gm (cdr gm)) (terpri) (terpri))) @@ -550,6 +585,65 @@ Optional argument HISTORYVAR is the variable to use as history." ;;; HELP AUGMENTATION ;; +(define-button-type 'eieio-method-def + :supertype 'help-xref + 'help-function (lambda (class method file) + (eieio-help-find-method-definition class method file)) + 'help-echo (purecopy "mouse-2, RET: find method's definition")) + +(define-button-type 'eieio-class-def + :supertype 'help-xref + 'help-function (lambda (class file) + (eieio-help-find-class-definition class file)) + 'help-echo (purecopy "mouse-2, RET: find class definition")) + +(defun eieio-help-find-method-definition (class method file) + (let ((filename (find-library-name file)) + location buf) + (when (null filename) + (error "Cannot find library %s" file)) + (setq buf (find-file-noselect filename)) + (with-current-buffer buf + (goto-char (point-min)) + (when + (re-search-forward + ;; Regexp for searching methods. + (concat "(defmethod[ \t\r\n]+" method + "\\([ \t\r\n]+:[a-zA-Z]+\\)?" + "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+" + class + "\\s-*)") + nil t) + (setq location (match-beginning 0)))) + (if (null location) + (message "Unable to find location in file") + (pop-to-buffer buf) + (goto-char location) + (recenter) + (beginning-of-line)))) + +(defun eieio-help-find-class-definition (class file) + (let ((filename (find-library-name file)) + location buf) + (when (null filename) + (error "Cannot find library %s" file)) + (setq buf (find-file-noselect filename)) + (with-current-buffer buf + (goto-char (point-min)) + (when + (re-search-forward + ;; Regexp for searching a class. + (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+") + nil t) + (setq location (match-beginning 0)))) + (if (null location) + (message "Unable to find location in file") + (pop-to-buffer buf) + (goto-char location) + (recenter) + (beginning-of-line)))) + + (defun eieio-help-mode-augmentation-maybee (&rest unused) "For buffers thrown into help mode, augment for EIEIO. Arguments UNUSED are not used." @@ -592,6 +686,26 @@ Arguments UNUSED are not used." (goto-char (point-min)) (while (re-search-forward "^\\(Private \\)?Slot:" nil t) (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (goto-char (point-min)) + (cond + ((looking-at "\\(.+\\) is a generic function") + (let ((mname (match-string 1)) + cname) + (while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t) + (setq cname (match-string-no-properties 1)) + (help-xref-button 2 'eieio-method-def cname + mname + (cadr (assoc (intern cname) + (get (intern mname) + 'method-locations))))))) + ((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'") + (let ((cname (match-string-no-properties 1))) + (help-xref-button 2 'eieio-class-def cname + (get (intern cname) 'class-location)))) + ((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'") + (let ((cname (match-string-no-properties 1))) + (help-xref-button 3 'eieio-class-def cname + (get (intern cname) 'class-location))))) )))) ;;; SPEEDBAR SUPPORT @@ -693,5 +807,4 @@ INDENT is the current indentation level." (provide 'eieio-opt) -;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6 ;;; eieio-opt.el ends here