lisp/emacs-lisp/eieio-opt.el

   1 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
   2
   3 ;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008,
   4 ;;   2009  Free Software Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7 ;; Version: 0.2
   8 ;; Keywords: OO, lisp
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26 ;;
  27 ;;   This contains support functions to eieio.  These functions contain
  28 ;; some small class browser and class printing functions.
  29 ;;
  30
  31 (require 'eieio)
  32
  33 ;;; Code:
  34 (defun eieio-browse (&optional root-class)
  35   "Create an object browser window to show all objects.
  36 If optional ROOT-CLASS, then start with that, otherwise start with
  37 variable `eieio-default-superclass'."
  38   (interactive (if current-prefix-arg
  39                    (list (read (completing-read "Class: "
  40                                                 (eieio-build-class-alist)
  41                                                 nil t)))
  42                  nil))
  43   (if (not root-class) (setq root-class 'eieio-default-superclass))
  44   (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class)))
  45   (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
  46   (save-excursion
  47     (set-buffer (get-buffer "*EIEIO OBJECT BROWSE*"))
  48     (erase-buffer)
  49     (goto-char 0)
  50     (eieio-browse-tree root-class "" "")
  51     ))
  52
  53 (defun eieio-browse-tree (this-root prefix ch-prefix)
  54   "Recursively, draws the children of the given class on the screen.
  55 Argument THIS-ROOT is the local root of the tree.
  56 Argument PREFIX is the character prefix to use.
  57 Argument CH-PREFIX is another character prefix to display."
  58   (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root)))
  59   (let ((myname (symbol-name this-root))
  60         (chl (aref (class-v this-root) class-children))
  61         (fprefix (concat ch-prefix "  +--"))
  62         (mprefix (concat ch-prefix "  |  "))
  63         (lprefix (concat ch-prefix "     ")))
  64     (insert prefix myname "\n")
  65     (while (cdr chl)
  66       (eieio-browse-tree (car chl) fprefix mprefix)
  67       (setq chl (cdr chl)))
  68     (if chl
  69         (eieio-browse-tree (car chl) fprefix lprefix))
  70     ))
  71
  72 ;;; CLASS COMPLETION / DOCUMENTATION
  73
  74 (defalias 'describe-class 'eieio-describe-class)
  75
  76 (defun eieio-describe-class (class &optional headerfcn)
  77   "Describe a CLASS defined by a string or symbol.
  78 If CLASS is actually an object, then also display current values of that object.
  79 Optional HEADERFCN should be called to insert a few bits of info first."
  80   (interactive (list (eieio-read-class "Class: ")))
  81   (with-output-to-temp-buffer (help-buffer) ;"*Help*"
  82     (help-setup-xref (list #'eieio-describe-class class headerfcn)
  83                      (called-interactively-p 'interactive))
  84
  85     (when headerfcn (funcall headerfcn))
  86
  87     (if (class-option class :abstract)
  88         (princ "Abstract "))
  89     (princ "Class ")
  90     (prin1 class)
  91     (terpri)
  92     ;; Inheritence tree information
  93     (let ((pl (class-parents class)))
  94       (when pl
  95         (princ " Inherits from ")
  96         (while pl
  97           (princ "`") (prin1 (car pl)) (princ "'")
  98           (setq pl (cdr pl))
  99           (if pl (princ ", ")))
 100         (terpri)))
 101     (let ((ch (class-children class)))
 102       (when ch
 103         (princ " Children ")
 104         (while ch
 105           (princ "`") (prin1 (car ch)) (princ "'")
 106           (setq ch (cdr ch))
 107           (if ch (princ ", ")))
 108         (terpri)))
 109     (terpri)
 110     ;; System documentation
 111     (let ((doc (documentation-property class 'variable-documentation)))
 112       (when doc
 113         (princ "Documentation:")
 114         (terpri)
 115         (princ doc)
 116         (terpri)
 117         (terpri)))
 118     ;; Describe all the slots in this class
 119     (eieio-describe-class-slots class)
 120     ;; Describe all the methods specific to this class.
 121     (let ((methods (eieio-all-generic-functions class))
 122           (doc nil))
 123       (if (not methods) nil
 124         (princ "Specialized Methods:")
 125         (terpri)
 126         (terpri)
 127         (while methods
 128           (setq doc (eieio-method-documentation (car methods) class))
 129           (princ "`")
 130           (prin1 (car methods))
 131           (princ "'")
 132           (if (not doc)
 133               (princ "  Undocumented")
 134             (if (car doc)
 135                 (progn
 136                   (princ "  :STATIC ")
 137                   (prin1 (car (car doc)))
 138                   (terpri)
 139                   (princ (cdr (car doc)))))
 140             (setq doc (cdr doc))
 141             (if (car doc)
 142                 (progn
 143                   (princ "  :BEFORE ")
 144                   (prin1 (car (car doc)))
 145                   (terpri)
 146                   (princ (cdr (car doc)))))
 147             (setq doc (cdr doc))
 148             (if (car doc)
 149                 (progn
 150                   (princ "  :PRIMARY ")
 151                   (prin1 (car (car doc)))
 152                   (terpri)
 153                   (princ (cdr (car doc)))))
 154             (setq doc (cdr doc))
 155             (if (car doc)
 156                 (progn
 157                   (princ "  :AFTER ")
 158                   (prin1 (car (car doc)))
 159                   (terpri)
 160                   (princ (cdr (car doc)))))
 161             (terpri)
 162             (terpri))
 163           (setq methods (cdr methods))))))
 164   (save-excursion
 165     (set-buffer (help-buffer))
 166     (buffer-string)))
 167
 168 (defun eieio-describe-class-slots (class)
 169   "Describe the slots in CLASS.
 170 Outputs to the standard output."
 171   (let* ((cv (class-v class))
 172          (docs   (aref cv class-public-doc))
 173          (names  (aref cv class-public-a))
 174          (deflt  (aref cv class-public-d))
 175          (types  (aref cv class-public-type))
 176          (publp (aref cv class-public-printer))
 177          (i      0)
 178          (prot   (aref cv class-protection))
 179          )
 180     (princ "Instance Allocated Slots:")
 181     (terpri)
 182     (terpri)
 183     (while names
 184       (if (car prot) (princ "Private "))
 185       (princ "Slot: ")
 186       (prin1 (car names))
 187       (when (not (eq (aref types i) t))
 188         (princ "    type = ")
 189         (prin1 (aref types i)))
 190       (unless (eq (car deflt) eieio-unbound)
 191         (princ "    default = ")
 192         (prin1 (car deflt)))
 193       (when (car publp)
 194         (princ "    printer = ")
 195         (prin1 (car publp)))
 196       (when (car docs)
 197         (terpri)
 198         (princ "  ")
 199         (princ (car docs))
 200         (terpri))
 201       (terpri)
 202       (setq names (cdr names)
 203             docs (cdr docs)
 204             deflt (cdr deflt)
 205             publp (cdr publp)
 206             prot (cdr prot)
 207             i (1+ i)))
 208     (setq docs  (aref cv class-class-allocation-doc)
 209           names (aref cv class-class-allocation-a)
 210           types (aref cv class-class-allocation-type)
 211           i     0
 212           prot  (aref cv class-class-allocation-protection))
 213     (when names
 214         (terpri)
 215         (princ "Class Allocated Slots:"))
 216         (terpri)
 217         (terpri)
 218     (while names
 219       (when (car prot)
 220         (princ "Private "))
 221       (princ "Slot: ")
 222       (prin1 (car names))
 223       (unless (eq (aref types i) t)
 224         (princ "    type = ")
 225         (prin1 (aref types i)))
 226       (condition-case nil
 227           (let ((value (eieio-oref class (car names))))
 228             (princ "   value = ")
 229             (prin1 value))
 230           (error nil))
 231       (when (car docs)
 232         (terpri)
 233         (princ "  ")
 234         (princ (car docs))
 235         (terpri))
 236       (terpri)
 237       (setq names (cdr names)
 238             docs (cdr docs)
 239             prot (cdr prot)
 240             i (1+ i)))))
 241
 242 (defun eieio-describe-constructor (fcn)
 243   "Describe the constructor function FCN.
 244 Uses `eieio-describe-class' to describe the class being constructed."
 245   (interactive
 246    ;; Use eieio-read-class since all constructors have the same name as
 247    ;; the class they create.
 248    (list (eieio-read-class "Class: ")))
 249   (eieio-describe-class
 250    fcn (lambda ()
 251          ;; Describe the constructor part.
 252          (princ "Object Constructor Function: ")
 253          (prin1 fcn)
 254          (terpri)
 255          (princ "Creates an object of class ")
 256          (prin1 fcn)
 257          (princ ".")
 258          (terpri)
 259          (terpri)
 260          ))
 261   )
 262
 263 (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
 264   "Return an alist of all currently active classes for completion purposes.
 265 Optional argument CLASS is the class to start with.
 266 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 267 are not abstract, otherwise allow all classes.
 268 Optional argument BUILDLIST is more list to attach and is used internally."
 269   (let* ((cc (or class eieio-default-superclass))
 270          (sublst (aref (class-v cc) class-children)))
 271     (if (or (not instantiable-only) (not (class-abstract-p cc)))
 272         (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))
 273     (while sublst
 274       (setq buildlist (eieio-build-class-alist
 275                        (car sublst) instantiable-only buildlist))
 276       (setq sublst (cdr sublst)))
 277     buildlist))
 278
 279 (defvar eieio-read-class nil
 280   "History of the function `eieio-read-class' prompt.")
 281
 282 (defun eieio-read-class (prompt &optional histvar instantiable-only)
 283   "Return a class chosen by the user using PROMPT.
 284 Optional argument HISTVAR is a variable to use as history.
 285 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 286 are not abstract."
 287   (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only)
 288                            nil t nil
 289                            (or histvar 'eieio-read-class))))
 290
 291 (defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
 292   "Return a class chosen by the user using PROMPT.
 293 CLASS is the base class, and completion occurs across all subclasses.
 294 Optional argument HISTVAR is a variable to use as history.
 295 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 296 are not abstract."
 297   (intern (completing-read prompt
 298                            (eieio-build-class-alist class instantiable-only)
 299                            nil t nil
 300                            (or histvar 'eieio-read-class))))
 301
 302 ;;; METHOD COMPLETION / DOC
 303
 304 (defalias 'describe-method 'eieio-describe-generic)
 305 (defalias 'describe-generic 'eieio-describe-generic)
 306 (defalias 'eieio-describe-method 'eieio-describe-generic)
 307
 308 (defun eieio-describe-generic (generic)
 309   "Describe the generic function GENERIC.
 310 Also extracts information about all methods specific to this generic."
 311   (interactive (list (eieio-read-generic "Generic Method: ")))
 312   (if (not (generic-p generic))
 313       (signal 'wrong-type-argument '(generic-p generic)))
 314   (with-output-to-temp-buffer (help-buffer) ; "*Help*"
 315     (help-setup-xref (list #'eieio-describe-generic generic)
 316                      (called-interactively-p 'interactive))
 317
 318     (prin1 generic)
 319     (princ " is a generic function")
 320     (when (generic-primary-only-p generic)
 321       (princ " with only ")
 322       (when (generic-primary-only-one-p generic)
 323         (princ "one "))
 324       (princ "primary method")
 325       (when (not (generic-primary-only-one-p generic))
 326         (princ "s"))
 327       )
 328     (princ ".")
 329     (terpri)
 330     (terpri)
 331     (let ((d (documentation generic)))
 332       (if (not d)
 333           (princ "The generic is not documented.\n")
 334         (princ "Documentation:")
 335         (terpri)
 336         (princ d)
 337         (terpri)
 338         (terpri)))
 339     (princ "Implementations:")
 340     (terpri)
 341     (terpri)
 342     (let ((i 3)
 343           (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
 344       ;; Loop over fanciful generics
 345       (while (< i 6)
 346         (let ((gm (aref (get generic 'eieio-method-tree) i)))
 347           (when gm
 348             (princ "Generic ")
 349             (princ (aref prefix (- i 3)))
 350             (terpri)
 351             (princ (or (nth 2 gm) "Undocumented"))
 352             (terpri)
 353             (terpri)))
 354         (setq i (1+ i)))
 355       (setq i 0)
 356       ;; Loop over defined class-specific methods
 357       (while (< i 3)
 358         (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))))
 359           (while gm
 360             (princ "`")
 361             (prin1 (car (car gm)))
 362             (princ "'")
 363             ;; prefix type
 364             (princ " ")
 365             (princ (aref prefix i))
 366             (princ " ")
 367             ;; argument list
 368             (let* ((func (cdr (car gm)))
 369                    (arglst (eieio-lambda-arglist func)))
 370               (prin1 arglst))
 371             (terpri)
 372             ;; 3 because of cdr
 373             (princ (or (documentation (cdr (car gm)))
 374                        "Undocumented"))
 375             (setq gm (cdr gm))
 376             (terpri)
 377             (terpri)))
 378         (setq i (1+ i)))))
 379   (save-excursion
 380     (set-buffer (help-buffer))
 381     (buffer-string)))
 382
 383 (defun eieio-lambda-arglist (func)
 384   "Return the argument list of FUNC, a function body."
 385   (if (symbolp func) (setq func (symbol-function func)))
 386   (if (byte-code-function-p func)
 387       (eieio-compiled-function-arglist func)
 388     (car (cdr func))))
 389
 390 (defun eieio-all-generic-functions (&optional class)
 391   "Return a list of all generic functions.
 392 Optional CLASS argument returns only those functions that contain methods for CLASS."
 393   (let ((l nil) tree (cn (if class (symbol-name class) nil)))
 394     (mapatoms
 395      (lambda (symbol)
 396        (setq tree (get symbol 'eieio-method-obarray))
 397        (if tree
 398            (progn
 399              ;; A symbol might be interned for that class in one of
 400              ;; these three slots in the method-obarray.
 401              (if (or (not class)
 402                      (fboundp (intern-soft cn (aref tree 0)))
 403                      (fboundp (intern-soft cn (aref tree 1)))
 404                      (fboundp (intern-soft cn (aref tree 2))))
 405                  (setq l (cons symbol l)))))))
 406     l))
 407
 408 (defun eieio-method-documentation (generic class)
 409   "Return a list of the specific documentation of GENERIC for CLASS.
 410 If there is not an explicit method for CLASS in GENERIC, or if that
 411 function has no documentation, then return nil."
 412   (let ((tree (get generic 'eieio-method-obarray))
 413         (cn (symbol-name class))
 414         before primary after)
 415     (if (not tree)
 416         nil
 417       ;; A symbol might be interned for that class in one of
 418       ;; these three slots in the method-obarray.
 419       (setq before (intern-soft cn (aref tree 0))
 420             primary (intern-soft cn (aref tree 1))
 421             after (intern-soft cn (aref tree 2)))
 422       (if (not (or (fboundp before)
 423                    (fboundp primary)
 424                    (fboundp after)))
 425           nil
 426         (list (if (fboundp before)
 427                   (cons (eieio-lambda-arglist before)
 428                         (documentation before))
 429                 nil)
 430               (if (fboundp primary)
 431                   (cons (eieio-lambda-arglist primary)
 432                         (documentation primary))
 433                 nil)
 434               (if (fboundp after)
 435                   (cons (eieio-lambda-arglist after)
 436                         (documentation after))
 437                 nil))))))
 438
 439 (defvar eieio-read-generic nil
 440   "History of the `eieio-read-generic' prompt.")
 441
 442 (defun eieio-read-generic-p (fn)
 443   "Function used in function `eieio-read-generic'.
 444 This is because `generic-p' is a macro.
 445 Argument FN is the function to test."
 446   (generic-p fn))
 447
 448 (defun eieio-read-generic (prompt &optional historyvar)
 449   "Read a generic function from the minibuffer with PROMPT.
 450 Optional argument HISTORYVAR is the variable to use as history."
 451   (intern (completing-read prompt obarray 'eieio-read-generic-p
 452                            t nil (or historyvar 'eieio-read-generic))))
 453
 454 ;;; METHOD STATS
 455 ;;
 456 ;; Dump out statistics about all the active methods in a session.
 457 (defun eieio-display-method-list ()
 458   "Display a list of all the methods and what features are used."
 459   (interactive)
 460   (let* ((meth1 (eieio-all-generic-functions))
 461          (meth (sort meth1 (lambda (a b)
 462                              (string< (symbol-name a)
 463                                       (symbol-name b)))))
 464          (buff (get-buffer-create "*EIEIO Method List*"))
 465          (methidx 0)
 466          (standard-output buff)
 467          (slots '(method-static
 468                   method-before
 469                   method-primary
 470                   method-after
 471                   method-generic-before
 472                   method-generic-primary
 473                   method-generic-after))
 474          (slotn '("static"
 475                   "before"
 476                   "primary"
 477                   "after"
 478                   "G bef"
 479                   "G prim"
 480                   "G aft"))
 481          (idxarray (make-vector (length slots) 0))
 482          (primaryonly 0)
 483          (oneprimary 0)
 484          )
 485     (switch-to-buffer-other-window buff)
 486     (erase-buffer)
 487     (dolist (S slotn)
 488       (princ S)
 489       (princ "\t")
 490       )
 491     (princ "Method Name")
 492     (terpri)
 493     (princ "--------------------------------------------------------------------")
 494     (terpri)
 495     (dolist (M meth)
 496       (let ((mtree (get M 'eieio-method-tree))
 497             (P nil) (numP)
 498             (!P nil))
 499         (dolist (S slots)
 500           (let ((num (length (aref mtree (symbol-value S)))))
 501             (aset idxarray (symbol-value S)
 502                   (+ num (aref idxarray (symbol-value S))))
 503             (prin1 num)
 504             (princ "\t")
 505             (when (< 0 num)
 506               (if (eq S 'method-primary)
 507                   (setq P t numP num)
 508                 (setq !P t)))
 509             ))
 510         ;; Is this a primary-only impl method?
 511         (when (and P (not !P))
 512           (setq primaryonly (1+ primaryonly))
 513           (when (= numP 1)
 514             (setq oneprimary (1+ oneprimary))
 515             (princ "*"))
 516           (princ "* ")
 517           )
 518         (prin1 M)
 519         (terpri)
 520         (setq methidx (1+ methidx))
 521         )
 522       )
 523     (princ "--------------------------------------------------------------------")
 524     (terpri)
 525     (dolist (S slots)
 526       (prin1 (aref idxarray (symbol-value S)))
 527       (princ "\t")
 528       )
 529     (prin1 methidx)
 530     (princ " Total symbols")
 531     (terpri)
 532     (dolist (S slotn)
 533       (princ S)
 534       (princ "\t")
 535       )
 536     (terpri)
 537     (terpri)
 538     (princ "Methods Primary Only: ")
 539     (prin1 primaryonly)
 540     (princ "\t")
 541     (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
 542     (princ "% of total methods")
 543     (terpri)
 544     (princ "Only One Primary Impl: ")
 545     (prin1 oneprimary)
 546     (princ "\t")
 547     (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
 548     (princ "% of total primary methods")
 549     (terpri)
 550     ))
 551
 552 ;;; HELP AUGMENTATION
 553 ;;
 554 (defun eieio-help-mode-augmentation-maybee (&rest unused)
 555   "For buffers thrown into help mode, augment for eieio.
 556 Arguments UNUSED are not used."
 557   ;; Scan created buttons so far if we are in help mode.
 558   (when (eq major-mode 'help-mode)
 559     (save-excursion
 560       (goto-char (point-min))
 561       (let ((pos t) (inhibit-read-only t))
 562         (while pos
 563           (if (get-text-property (point) 'help-xref) ; move off reference
 564               (goto-char
 565                (or (next-single-property-change (point) 'help-xref)
 566                    (point))))
 567           (setq pos (next-single-property-change (point) 'help-xref))
 568           (when pos
 569             (goto-char pos)
 570             (let* ((help-data (get-text-property (point) 'help-xref))
 571                    ;(method (car help-data))
 572                    (args (cdr help-data)))
 573               (when (symbolp (car args))
 574                 (cond ((class-p (car args))
 575                        (setcar help-data 'eieio-describe-class))
 576                       ((generic-p (car args))
 577                        (setcar help-data 'eieio-describe-generic))
 578                       (t nil))
 579                 ))))
 580         ;; start back at the beginning, and highlight some sections
 581         (goto-char (point-min))
 582         (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t)
 583             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 584         (goto-char (point-min))
 585         (if (re-search-forward "^Specialized Methods:$" nil t)
 586             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 587         (goto-char (point-min))
 588         (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t)
 589             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 590         (goto-char (point-min))
 591         (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t)
 592             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 593         (goto-char (point-min))
 594         (while (re-search-forward "^\\(Private \\)?Slot:" nil t)
 595             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 596         ))))
 597
 598 ;;; SPEEDBAR SUPPORT
 599 ;;
 600 (eval-when-compile
 601   (condition-case nil
 602       (require 'speedbar)
 603     (error (message "Error loading speedbar... ignored."))))
 604
 605 (defvar eieio-class-speedbar-key-map nil
 606   "Keymap used when working with a project in speedbar.")
 607
 608 (defun eieio-class-speedbar-make-map ()
 609   "Make a keymap for eieio under speedbar."
 610   (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
 611
 612   ;; General viewing stuff
 613   (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
 614   (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
 615   (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
 616   )
 617
 618 (if eieio-class-speedbar-key-map
 619     nil
 620   (if (not (featurep 'speedbar))
 621       (add-hook 'speedbar-load-hook (lambda ()
 622                                       (eieio-class-speedbar-make-map)
 623                                       (speedbar-add-expansion-list
 624                                        '("EIEIO"
 625                                          eieio-class-speedbar-menu
 626                                          eieio-class-speedbar-key-map
 627                                          eieio-class-speedbar))))
 628     (eieio-class-speedbar-make-map)
 629     (speedbar-add-expansion-list '("EIEIO"
 630                                    eieio-class-speedbar-menu
 631                                    eieio-class-speedbar-key-map
 632                                    eieio-class-speedbar))))
 633
 634 (defvar eieio-class-speedbar-menu
 635   ()
 636   "Menu part in easymenu format used in speedbar while in `eieio' mode.")
 637
 638 (defun eieio-class-speedbar (dir-or-object depth)
 639   "Create buttons in speedbar that represents the current project.
 640 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current
 641 expansion depth."
 642   (when (eq (point-min) (point-max))
 643     ;; This function is only called once, to start the whole deal.
 644     ;; Ceate, and expand the default object.
 645     (eieio-class-button eieio-default-superclass 0)
 646     (forward-line -1)
 647     (speedbar-expand-line)))
 648
 649 (defun eieio-class-button (class depth)
 650   "Draw a speedbar button at the current point for CLASS at DEPTH."
 651   (if (not (class-p class))
 652       (signal 'wrong-type-argument (list 'class-p class)))
 653   (let ((subclasses (aref (class-v class) class-children)))
 654     (if subclasses
 655         (speedbar-make-tag-line 'angle ?+
 656                                 'eieio-sb-expand
 657                                 class
 658                                 (symbol-name class)
 659                                 'eieio-describe-class-sb
 660                                 class
 661                                 'speedbar-directory-face
 662                                 depth)
 663       (speedbar-make-tag-line 'angle ?  nil nil
 664                               (symbol-name class)
 665                               'eieio-describe-class-sb
 666                               class
 667                               'speedbar-directory-face
 668                               depth))))
 669
 670 (defun eieio-sb-expand (text class indent)
 671   "For button TEXT, expand CLASS at the current location.
 672 Argument INDENT is the depth of indentation."
 673   (cond ((string-match "+" text)        ;we have to expand this file
 674          (speedbar-change-expand-button-char ?-)
 675          (speedbar-with-writable
 676            (save-excursion
 677              (end-of-line) (forward-char 1)
 678              (let ((subclasses (aref (class-v class) class-children)))
 679                (while subclasses
 680                  (eieio-class-button (car subclasses) (1+ indent))
 681                  (setq subclasses (cdr subclasses)))))))
 682         ((string-match "-" text)        ;we have to contract this node
 683          (speedbar-change-expand-button-char ?+)
 684          (speedbar-delete-subblock indent))
 685         (t (error "Ooops...  not sure what to do")))
 686   (speedbar-center-buffer-smartly))
 687
 688 (defun eieio-describe-class-sb (text token indent)
 689   "Describe the class TEXT in TOKEN.
 690 INDENT is the current indentation level."
 691   (speedbar-with-attached-buffer
 692    (eieio-describe-class token))
 693   (speedbar-maybee-jump-to-attached-frame))
 694
 695 (provide 'eieio-opt)
 696
 697 ;;; eieio-opt.el ends here