* emacs-lisp/chart.el:
* emacs-lisp/eieio-base.el: * emacs-lisp/eieio-comp.el: * emacs-lisp/eieio-custom.el: * emacs-lisp/eieio-opt.el: * emacs-lisp/eieio-speedbar.el: * emacs-lisp/eieio.el: New files.
This commit is contained in:
Chong Yidong
parent
c93d41ba11
commit
6dd12ef230
8 changed files with 5604 additions and 0 deletions
|
|
@ -1,3 +1,13 @@
|
|||
2009-09-28 Chong Yidong <cyd@stupidchicken.com>
|
||||
|
||||
* emacs-lisp/chart.el:
|
||||
* emacs-lisp/eieio-base.el:
|
||||
* emacs-lisp/eieio-comp.el:
|
||||
* emacs-lisp/eieio-custom.el:
|
||||
* emacs-lisp/eieio-opt.el:
|
||||
* emacs-lisp/eieio-speedbar.el:
|
||||
* emacs-lisp/eieio.el: New files.
|
||||
|
||||
2009-09-27 Chong Yidong <cyd@stupidchicken.com>
|
||||
|
||||
* menu-bar.el: Remove menu-bar-ediff-misc-menu from the Tools
|
||||
|
|
|
|||
754
lisp/emacs-lisp/chart.el
Normal file
754
lisp/emacs-lisp/chart.el
Normal file
|
|
@ -0,0 +1,754 @@
|
|||
;;; chart.el --- Draw charts (bar charts, etc)
|
||||
|
||||
;;; Copyright (C) 1996, 1998, 1999, 2001, 2004, 2005, 2007, 2008, 2009
|
||||
;;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, chart, graph
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This package is an experiment of mine aiding in the debugging of
|
||||
;; eieio, and proved to be neat enough that others may like to use
|
||||
;; it. To quickly see what you can do with chart, run the command
|
||||
;; `chart-test-it-all'.
|
||||
;;
|
||||
;; Chart current can display bar-charts in either of two
|
||||
;; directions. It also supports ranged (integer) axis, and axis
|
||||
;; defined by some set of strings or names. These name can be
|
||||
;; automatically derived from data sequences, which are just lists of
|
||||
;; anything encapsulated in a nice eieio object.
|
||||
;;
|
||||
;; Current example apps for chart can be accessed via these commands:
|
||||
;; `chart-file-count' - count files w/ matching extensions
|
||||
;; `chart-space-usage' - display space used by files/directories
|
||||
;; `chart-emacs-storage' - Emacs storage units used/free (garbage-collect)
|
||||
;; `chart-emacs-lists' - length of Emacs lists
|
||||
;; `chart-rmail-from' - who sends you the most mail (in -summary only)
|
||||
;;
|
||||
;; Customization:
|
||||
;;
|
||||
;; If you find the default colors and pixmaps unpleasant, or too
|
||||
;; short, you can change them. The variable `chart-face-color-list'
|
||||
;; contains a list of colors, and `chart-face-pixmap-list' contains
|
||||
;; all the pixmaps to use. The current pixmaps are those found on
|
||||
;; several systems I found. The two lists should be the same length,
|
||||
;; as the long list will just be truncated.
|
||||
;;
|
||||
;; If you would like to draw your own stipples, simply create some
|
||||
;; xbm's and put them in a directory, then you can add:
|
||||
;;
|
||||
;; (setq x-bitmap-file-path (cons "~/mybitmaps" x-bitmap-file-path))
|
||||
;;
|
||||
;; to your .emacs (or wherever) and load the `chart-face-pixmap-list'
|
||||
;; with all the bitmaps you want to use.
|
||||
|
||||
(require 'eieio)
|
||||
|
||||
;;; Code:
|
||||
(defvar chart-map nil "Keymap used in chart mode.")
|
||||
(if chart-map
|
||||
()
|
||||
(setq chart-map (make-sparse-keymap))
|
||||
)
|
||||
|
||||
(defvar chart-local-object nil
|
||||
"Local variable containing the locally displayed chart object.")
|
||||
(make-variable-buffer-local 'chart-local-object)
|
||||
|
||||
(defvar chart-face-list nil
|
||||
"Faces used to colorize charts.
|
||||
List is limited currently, which is ok since you really can't display
|
||||
too much in text characters anyways.")
|
||||
|
||||
(defvar chart-face-color-list '("red" "green" "blue"
|
||||
"cyan" "yellow" "purple")
|
||||
"Colors to use when generating `chart-face-list'.
|
||||
Colors will be the background color.")
|
||||
|
||||
(defvar chart-face-pixmap-list
|
||||
(if (and (fboundp 'display-graphic-p)
|
||||
(display-graphic-p))
|
||||
'("dimple1" "scales" "dot" "cross_weave" "boxes" "dimple3"))
|
||||
"If pixmaps are allowed, display these background pixmaps.
|
||||
Useful if new Emacs is used on B&W display")
|
||||
|
||||
(defcustom chart-face-use-pixmaps nil
|
||||
"*Non-nil to use fancy pixmaps in the background of chart face colors."
|
||||
:group 'eieio
|
||||
:type 'boolean)
|
||||
|
||||
(if (and (if (fboundp 'display-color-p)
|
||||
(display-color-p)
|
||||
window-system)
|
||||
(not chart-face-list))
|
||||
(let ((cl chart-face-color-list)
|
||||
(pl chart-face-pixmap-list)
|
||||
nf)
|
||||
(while cl
|
||||
(setq nf (make-face (intern (concat "chart-" (car cl) "-" (car pl)))))
|
||||
(if (condition-case nil
|
||||
(> (x-display-color-cells) 4)
|
||||
(error t))
|
||||
(set-face-background nf (car cl))
|
||||
(set-face-background nf "white"))
|
||||
(set-face-foreground nf "black")
|
||||
(if (and chart-face-use-pixmaps
|
||||
pl
|
||||
(fboundp 'set-face-background-pixmap))
|
||||
(condition-case nil
|
||||
(set-face-background-pixmap nf (car pl))
|
||||
(error (message "Cannot set background pixmap %s" (car pl)))))
|
||||
(setq chart-face-list (cons nf chart-face-list))
|
||||
(setq cl (cdr cl)
|
||||
pl (cdr pl)))))
|
||||
|
||||
(defun chart-mode ()
|
||||
"Define a mode in Emacs for displaying a chart."
|
||||
(kill-all-local-variables)
|
||||
(use-local-map chart-map)
|
||||
(setq major-mode 'chart-mode
|
||||
mode-name "CHART")
|
||||
(buffer-disable-undo)
|
||||
(set (make-local-variable 'font-lock-global-modes) nil)
|
||||
(font-lock-mode -1)
|
||||
(run-hooks 'chart-mode-hook)
|
||||
)
|
||||
|
||||
(defun chart-new-buffer (obj)
|
||||
"Create a new buffer NAME in which the chart OBJ is displayed.
|
||||
Returns the newly created buffer"
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer-create (format "*%s*" (oref obj title))))
|
||||
(chart-mode)
|
||||
(setq chart-local-object obj)
|
||||
(current-buffer)))
|
||||
|
||||
(defclass chart ()
|
||||
((title :initarg :title
|
||||
:initform "Emacs Chart")
|
||||
(title-face :initarg :title-face
|
||||
:initform 'bold-italic)
|
||||
(x-axis :initarg :x-axis
|
||||
:initform nil )
|
||||
(x-margin :initarg :x-margin
|
||||
:initform 5)
|
||||
(x-width :initarg :x-width
|
||||
)
|
||||
(y-axis :initarg :y-axis
|
||||
:initform nil)
|
||||
(y-margin :initarg :y-margin
|
||||
:initform 5)
|
||||
(y-width :initarg :y-width
|
||||
)
|
||||
(key-label :initarg :key-label
|
||||
:initform "Key")
|
||||
(sequences :initarg :sequences
|
||||
:initform nil)
|
||||
)
|
||||
"Superclass for all charts to be displayed in an emacs buffer")
|
||||
|
||||
(defmethod initialize-instance :AFTER ((obj chart) &rest fields)
|
||||
"Initialize the chart OBJ being created with FIELDS.
|
||||
Make sure the width/height is correct."
|
||||
(oset obj x-width (- (window-width) 10))
|
||||
(oset obj y-width (- (window-height) 12)))
|
||||
|
||||
(defclass chart-axis ()
|
||||
((name :initarg :name
|
||||
:initform "Generic Axis")
|
||||
(loweredge :initarg :loweredge
|
||||
:initform t)
|
||||
(name-face :initarg :name-face
|
||||
:initform 'bold)
|
||||
(labels-face :initarg :lables-face
|
||||
:initform 'italic)
|
||||
(chart :initarg :chart
|
||||
:initform nil)
|
||||
)
|
||||
"Superclass used for display of an axis.")
|
||||
|
||||
(defclass chart-axis-range (chart-axis)
|
||||
((bounds :initarg :bounds
|
||||
:initform '(0.0 . 50.0))
|
||||
)
|
||||
"Class used to display an axis defined by a range of values")
|
||||
|
||||
(defclass chart-axis-names (chart-axis)
|
||||
((items :initarg :items
|
||||
:initform nil)
|
||||
)
|
||||
"Class used to display an axis which represents different named items")
|
||||
|
||||
(defclass chart-sequece ()
|
||||
((data :initarg :data
|
||||
:initform nil)
|
||||
(name :initarg :name
|
||||
:initform "Data")
|
||||
)
|
||||
"Class used for all data in different charts")
|
||||
|
||||
(defclass chart-bar (chart)
|
||||
((direction :initarg :direction
|
||||
:initform vertical))
|
||||
"Subclass for bar charts. (Vertical or horizontal)")
|
||||
|
||||
(defmethod chart-draw ((c chart) &optional buff)
|
||||
"Start drawing a chart object C in optional BUFF.
|
||||
Erases current contents of buffer"
|
||||
(save-excursion
|
||||
(if buff (set-buffer buff))
|
||||
(erase-buffer)
|
||||
(insert (make-string 100 ?\n))
|
||||
;; Start by displaying the axis
|
||||
(chart-draw-axis c)
|
||||
;; Display title
|
||||
(chart-draw-title c)
|
||||
;; Display data
|
||||
(message "Rendering chart...")
|
||||
(sit-for 0)
|
||||
(chart-draw-data c)
|
||||
;; Display key
|
||||
; (chart-draw-key c)
|
||||
(message "Rendering chart...done")
|
||||
))
|
||||
|
||||
(defmethod chart-draw-title ((c chart))
|
||||
"Draw a title upon the chart.
|
||||
Argument C is the chart object."
|
||||
(chart-display-label (oref c title) 'horizontal 0 0 (window-width)
|
||||
(oref c title-face)))
|
||||
|
||||
(defmethod chart-size-in-dir ((c chart) dir)
|
||||
"Return the physical size of chart C in direction DIR."
|
||||
(if (eq dir 'vertical)
|
||||
(oref c y-width)
|
||||
(oref c x-width)))
|
||||
|
||||
(defmethod chart-draw-axis ((c chart))
|
||||
"Draw axis into the current buffer defined by chart C."
|
||||
(let ((ymarg (oref c y-margin))
|
||||
(xmarg (oref c x-margin))
|
||||
(ylen (oref c y-width))
|
||||
(xlen (oref c x-width)))
|
||||
(chart-axis-draw (oref c y-axis) 'vertical ymarg
|
||||
(if (oref (oref c y-axis) loweredge) nil xlen)
|
||||
xmarg (+ xmarg ylen))
|
||||
(chart-axis-draw (oref c x-axis) 'horizontal xmarg
|
||||
(if (oref (oref c x-axis) loweredge) nil ylen)
|
||||
ymarg (+ ymarg xlen)))
|
||||
)
|
||||
|
||||
(defmethod chart-axis-draw ((a chart-axis) &optional dir margin zone start end)
|
||||
"Draw some axis for A in direction DIR at with MARGIN in boundry.
|
||||
ZONE is a zone specification.
|
||||
START and END represent the boundary."
|
||||
(chart-draw-line dir (+ margin (if zone zone 0)) start end)
|
||||
(chart-display-label (oref a name) dir (if zone (+ zone margin 3)
|
||||
(if (eq dir 'horizontal)
|
||||
1 0))
|
||||
start end (oref a name-face)))
|
||||
|
||||
(defmethod chart-translate-xpos ((c chart) x)
|
||||
"Translate in chart C the coordinate X into a screen column."
|
||||
(let ((range (oref (oref c x-axis) bounds)))
|
||||
(+ (oref c x-margin)
|
||||
(round (* (float (- x (car range)))
|
||||
(/ (float (oref c x-width))
|
||||
(float (- (cdr range) (car range))))))))
|
||||
)
|
||||
|
||||
(defmethod chart-translate-ypos ((c chart) y)
|
||||
"Translate in chart C the coordinate Y into a screen row."
|
||||
(let ((range (oref (oref c y-axis) bounds)))
|
||||
(+ (oref c x-margin)
|
||||
(- (oref c y-width)
|
||||
(round (* (float (- y (car range)))
|
||||
(/ (float (oref c y-width))
|
||||
(float (- (cdr range) (car range)))))))))
|
||||
)
|
||||
|
||||
(defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone start end)
|
||||
"Draw axis information based upon a range to be spread along the edge.
|
||||
A is the chart to draw. DIR is the direction.
|
||||
MARGIN, ZONE, START, and END specify restrictions in chart space."
|
||||
(call-next-method)
|
||||
;; We prefer about 5 spaces between each value
|
||||
(let* ((i (car (oref a bounds)))
|
||||
(e (cdr (oref a bounds)))
|
||||
(z (if zone zone 0))
|
||||
(s nil)
|
||||
(rng (- e i))
|
||||
;; want to jump by units of 5 spaces or so
|
||||
(j (/ rng (/ (chart-size-in-dir (oref a chart) dir) 4)))
|
||||
p1)
|
||||
(if (= j 0) (setq j 1))
|
||||
(while (<= i e)
|
||||
(setq s
|
||||
(cond ((> i 999999)
|
||||
(format "%dM" (/ i 1000000)))
|
||||
((> i 999)
|
||||
(format "%dK" (/ i 1000)))
|
||||
(t
|
||||
(format "%d" i))))
|
||||
(if (eq dir 'vertical)
|
||||
(let ((x (+ (+ margin z) (if (oref a loweredge)
|
||||
(- (length s)) 1))))
|
||||
(if (< x 1) (setq x 1))
|
||||
(chart-goto-xy x (chart-translate-ypos (oref a chart) i)))
|
||||
(chart-goto-xy (chart-translate-xpos (oref a chart) i)
|
||||
(+ margin z (if (oref a loweredge) -1 1))))
|
||||
(setq p1 (point))
|
||||
(insert s)
|
||||
(chart-zap-chars (length s))
|
||||
(put-text-property p1 (point) 'face (oref a labels-face))
|
||||
(setq i (+ i j))))
|
||||
)
|
||||
|
||||
(defmethod chart-translate-namezone ((c chart) n)
|
||||
"Return a dot-pair representing a positional range for a name.
|
||||
The name in chart C of the Nth name resides.
|
||||
Automatically compensates for for direction."
|
||||
(let* ((dir (oref c direction))
|
||||
(w (if (eq dir 'vertical) (oref c x-width) (oref c y-width)))
|
||||
(m (if (eq dir 'vertical) (oref c y-margin) (oref c x-margin)))
|
||||
(ns (length
|
||||
(oref (if (eq dir 'vertical) (oref c x-axis) (oref c y-axis))
|
||||
items)))
|
||||
(lpn (/ (+ 1.0 (float w)) (float ns)))
|
||||
)
|
||||
(cons (+ m (round (* lpn (float n))))
|
||||
(+ m -1 (round (* lpn (+ 1.0 (float n))))))
|
||||
))
|
||||
|
||||
(defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone start end)
|
||||
"Draw axis information based upon A range to be spread along the edge.
|
||||
Optional argument DIR the direction of the chart.
|
||||
Optional argument MARGIN , ZONE, START and END specify boundaries of the drawing."
|
||||
(call-next-method)
|
||||
;; We prefer about 5 spaces between each value
|
||||
(let* ((i 0)
|
||||
(s (oref a items))
|
||||
(z (if zone zone 0))
|
||||
(r nil)
|
||||
(p nil)
|
||||
(odd nil)
|
||||
p1)
|
||||
(while s
|
||||
(setq odd (= (% (length s) 2) 1))
|
||||
(setq r (chart-translate-namezone (oref a chart) i))
|
||||
(if (eq dir 'vertical)
|
||||
(setq p (/ (+ (car r) (cdr r)) 2))
|
||||
(setq p (- (+ (car r) (/ (- (cdr r) (car r)) 2))
|
||||
(/ (length (car s)) 2))))
|
||||
(if (eq dir 'vertical)
|
||||
(let ((x (+ (+ margin z) (if (oref a loweredge)
|
||||
(- (length (car s)))
|
||||
(length (car s))))))
|
||||
(if (< x 1) (setq x 1))
|
||||
(if (> (length (car s)) (1- margin))
|
||||
(setq x (+ x margin)))
|
||||
(chart-goto-xy x p))
|
||||
(chart-goto-xy p (+ (+ margin z) (if (oref a loweredge)
|
||||
(if odd -2 -1)
|
||||
(if odd 2 1)))))
|
||||
(setq p1 (point))
|
||||
(insert (car s))
|
||||
(chart-zap-chars (length (car s)))
|
||||
(put-text-property p1 (point) 'face (oref a labels-face))
|
||||
(setq i (+ i 1)
|
||||
s (cdr s))))
|
||||
)
|
||||
|
||||
(defmethod chart-draw-data ((c chart-bar))
|
||||
"Display the data available in a bar chart C."
|
||||
(let* ((data (oref c sequences))
|
||||
(dir (oref c direction))
|
||||
(odir (if (eq dir 'vertical) 'horizontal 'vertical))
|
||||
)
|
||||
(while data
|
||||
(if (stringp (car (oref (car data) data)))
|
||||
;; skip string lists...
|
||||
nil
|
||||
;; display number lists...
|
||||
(let ((i 0)
|
||||
(seq (oref (car data) data)))
|
||||
(while seq
|
||||
(let* ((rng (chart-translate-namezone c i))
|
||||
(dp (if (eq dir 'vertical)
|
||||
(chart-translate-ypos c (car seq))
|
||||
(chart-translate-xpos c (car seq))))
|
||||
(zp (if (eq dir 'vertical)
|
||||
(chart-translate-ypos c 0)
|
||||
(chart-translate-xpos c 0)))
|
||||
(fc (if chart-face-list
|
||||
(nth (% i (length chart-face-list)) chart-face-list)
|
||||
'default))
|
||||
)
|
||||
(if (< dp zp)
|
||||
(progn
|
||||
(chart-draw-line dir (car rng) dp zp)
|
||||
(chart-draw-line dir (cdr rng) dp zp))
|
||||
(chart-draw-line dir (car rng) zp (1+ dp))
|
||||
(chart-draw-line dir (cdr rng) zp (1+ dp)))
|
||||
(if (= (car rng) (cdr rng)) nil
|
||||
(chart-draw-line odir dp (1+ (car rng)) (cdr rng))
|
||||
(chart-draw-line odir zp (car rng) (1+ (cdr rng))))
|
||||
(if (< dp zp)
|
||||
(chart-deface-rectangle dir rng (cons dp zp) fc)
|
||||
(chart-deface-rectangle dir rng (cons zp dp) fc))
|
||||
)
|
||||
;; find the bounds, and chart it!
|
||||
;; for now, only do one!
|
||||
(setq i (1+ i)
|
||||
seq (cdr seq)))))
|
||||
(setq data (cdr data))))
|
||||
)
|
||||
|
||||
(defmethod chart-add-sequence ((c chart) &optional seq axis-label)
|
||||
"Add to chart object C the sequence object SEQ.
|
||||
If AXIS-LABEL, then the axis stored in C is updated with the bounds of SEQ,
|
||||
or is created with the bounds of SEQ."
|
||||
(if axis-label
|
||||
(let ((axis (eieio-oref c axis-label)))
|
||||
(if (stringp (car (oref seq data)))
|
||||
(let ((labels (oref seq data)))
|
||||
(if (not axis)
|
||||
(setq axis (make-instance chart-axis-names
|
||||
:name (oref seq name)
|
||||
:items labels
|
||||
:chart c))
|
||||
(oset axis items labels)))
|
||||
(let ((range (cons 0 1))
|
||||
(l (oref seq data)))
|
||||
(if (not axis)
|
||||
(setq axis (make-instance chart-axis-range
|
||||
:name (oref seq name)
|
||||
:chart c)))
|
||||
(while l
|
||||
(if (< (car l) (car range)) (setcar range (car l)))
|
||||
(if (> (car l) (cdr range)) (setcdr range (car l)))
|
||||
(setq l (cdr l)))
|
||||
(oset axis bounds range)))
|
||||
(if (eq axis-label 'x-axis) (oset axis loweredge nil))
|
||||
(eieio-oset c axis-label axis)
|
||||
))
|
||||
(oset c sequences (append (oref c sequences) (list seq))))
|
||||
|
||||
;;; Charting optimizers
|
||||
|
||||
(defmethod chart-trim ((c chart) max)
|
||||
"Trim all sequences in chart C to be at most MAX elements long."
|
||||
(let ((s (oref c sequences)))
|
||||
(while s
|
||||
(let ((sl (oref (car s) data)))
|
||||
(if (> (length sl) max)
|
||||
(setcdr (nthcdr (1- max) sl) nil)))
|
||||
(setq s (cdr s))))
|
||||
)
|
||||
|
||||
(defmethod chart-sort ((c chart) pred)
|
||||
"Sort the data in chart C using predicate PRED.
|
||||
See `chart-sort-matchlist' for more details"
|
||||
(let* ((sl (oref c sequences))
|
||||
(s1 (car sl))
|
||||
(s2 (car (cdr sl)))
|
||||
(s nil))
|
||||
(if (stringp (car (oref s1 data)))
|
||||
(progn
|
||||
(chart-sort-matchlist s1 s2 pred)
|
||||
(setq s (oref s1 data)))
|
||||
(if (stringp (car (oref s2 data)))
|
||||
(progn
|
||||
(chart-sort-matchlist s2 s1 pred)
|
||||
(setq s (oref s2 data)))
|
||||
(error "Sorting of chart %s not supported" (object-name c))))
|
||||
(if (eq (oref c direction) 'horizontal)
|
||||
(oset (oref c y-axis) items s)
|
||||
(oset (oref c x-axis) items s)
|
||||
))
|
||||
)
|
||||
|
||||
(defun chart-sort-matchlist (namelst numlst pred)
|
||||
"Sort NAMELST and NUMLST (both SEQUENCE objects) based on predicate PRED.
|
||||
PRED should be the equivalent of '<, except it must expect two
|
||||
cons cells of the form (NAME . NUM). See SORT for more details."
|
||||
;; 1 - create 1 list of cons cells
|
||||
(let ((newlist nil)
|
||||
(alst (oref namelst data))
|
||||
(ulst (oref numlst data)))
|
||||
(while alst
|
||||
;; this is reversed, but were are sorting anyway
|
||||
(setq newlist (cons (cons (car alst) (car ulst)) newlist))
|
||||
(setq alst (cdr alst)
|
||||
ulst (cdr ulst)))
|
||||
;; 2 - Run sort routine on it
|
||||
(setq newlist (sort newlist pred)
|
||||
alst nil
|
||||
ulst nil)
|
||||
;; 3 - Separate the lists
|
||||
(while newlist
|
||||
(setq alst (cons (car (car newlist)) alst)
|
||||
ulst (cons (cdr (car newlist)) ulst))
|
||||
(setq newlist (cdr newlist)))
|
||||
;; 4 - Store them back
|
||||
(oset namelst data (reverse alst))
|
||||
(oset numlst data (reverse ulst))))
|
||||
|
||||
;;; Utilities
|
||||
|
||||
(defun chart-goto-xy (x y)
|
||||
"Move cursor to position X Y in buffer, and add spaces and CRs if needed."
|
||||
(let ((indent-tabs-mode nil)
|
||||
(num (progn (goto-char (point-min)) (forward-line y))))
|
||||
(if (and (= 0 num) (/= 0 (current-column))) (newline 1))
|
||||
(if (eobp) (newline num))
|
||||
(if (< x 0) (setq x 0))
|
||||
(if (< y 0) (setq y 0))
|
||||
;; Now, a quicky column moveto/forceto method.
|
||||
(or (= (move-to-column x) x)
|
||||
(let ((p (point)))
|
||||
(indent-to x)
|
||||
(remove-text-properties p (point) '(face))))))
|
||||
|
||||
(defun chart-zap-chars (n)
|
||||
"Zap up to N chars without deleteting EOLs."
|
||||
(if (not (eobp))
|
||||
(if (< n (- (save-excursion (end-of-line) (point)) (point)))
|
||||
(delete-char n)
|
||||
(delete-region (point) (save-excursion (end-of-line) (point))))))
|
||||
|
||||
(defun chart-display-label (label dir zone start end &optional face)
|
||||
"Display LABEL in direction DIR in column/row ZONE between START and END.
|
||||
Optional argument FACE is the property we wish to place on this text."
|
||||
(if (eq dir 'horizontal)
|
||||
(let (p1)
|
||||
(chart-goto-xy (+ start (- (/ (- end start) 2) (/ (length label) 2)))
|
||||
zone)
|
||||
(setq p1 (point))
|
||||
(insert label)
|
||||
(chart-zap-chars (length label))
|
||||
(put-text-property p1 (point) 'face face)
|
||||
)
|
||||
(let ((i 0)
|
||||
(stz (+ start (- (/ (- end start) 2) (/ (length label) 2)))))
|
||||
(while (< i (length label))
|
||||
(chart-goto-xy zone (+ stz i))
|
||||
(insert (aref label i))
|
||||
(chart-zap-chars 1)
|
||||
(put-text-property (1- (point)) (point) 'face face)
|
||||
(setq i (1+ i))))))
|
||||
|
||||
(defun chart-draw-line (dir zone start end)
|
||||
"Draw a line using line-drawing characters in direction DIR.
|
||||
Use column or row ZONE between START and END"
|
||||
(chart-display-label
|
||||
(make-string (- end start) (if (eq dir 'vertical) ?| ?\-))
|
||||
dir zone start end))
|
||||
|
||||
(defun chart-deface-rectangle (dir r1 r2 face)
|
||||
"Colorize a rectangle in direction DIR across range R1 by range R2.
|
||||
R1 and R2 are dotted pairs. Colorize it with FACE."
|
||||
(let* ((range1 (if (eq dir 'vertical) r1 r2))
|
||||
(range2 (if (eq dir 'vertical) r2 r1))
|
||||
(y (car range2)))
|
||||
(while (<= y (cdr range2))
|
||||
(chart-goto-xy (car range1) y)
|
||||
(put-text-property (point) (+ (point) (1+ (- (cdr range1) (car range1))))
|
||||
'face face)
|
||||
(setq y (1+ y)))))
|
||||
|
||||
;;; Helpful `I don't want to learn eieio just now' washover functions
|
||||
|
||||
(defun chart-bar-quickie (dir title namelst nametitle numlst numtitle
|
||||
&optional max sort-pred)
|
||||
"Wash over the complex eieio stuff and create a nice bar chart.
|
||||
Creat it going in direction DIR ['horizontal 'vertical] with TITLE
|
||||
using a name sequence NAMELST labeled NAMETITLE with values NUMLST
|
||||
labeled NUMTITLE.
|
||||
Optional arguments:
|
||||
Set the charts' max element display to MAX, and sort lists with
|
||||
SORT-PRED if desired."
|
||||
(let ((nc (make-instance chart-bar
|
||||
:title title
|
||||
:key-label "8-m" ; This is a text key pic
|
||||
:direction dir
|
||||
))
|
||||
(iv (eq dir 'vertical)))
|
||||
(chart-add-sequence nc
|
||||
(make-instance chart-sequece
|
||||
:data namelst
|
||||
:name nametitle)
|
||||
(if iv 'x-axis 'y-axis))
|
||||
(chart-add-sequence nc
|
||||
(make-instance chart-sequece
|
||||
:data numlst
|
||||
:name numtitle)
|
||||
(if iv 'y-axis 'x-axis))
|
||||
(if sort-pred (chart-sort nc sort-pred))
|
||||
(if (integerp max) (chart-trim nc max))
|
||||
(switch-to-buffer (chart-new-buffer nc))
|
||||
(chart-draw nc)))
|
||||
|
||||
;;; Test code
|
||||
|
||||
(defun chart-test-it-all ()
|
||||
"Test out various charting features."
|
||||
(interactive)
|
||||
(chart-bar-quickie 'vertical "Test Bar Chart"
|
||||
'( "U1" "ME2" "C3" "B4" "QT" "EZ") "Items"
|
||||
'( 5 -10 23 20 30 -3) "Values")
|
||||
)
|
||||
|
||||
;;; Sample utility function
|
||||
|
||||
(defun chart-file-count (dir)
|
||||
"Draw a chart displaying the number of different file extentions in DIR."
|
||||
(interactive "DDirectory: ")
|
||||
(if (not (string-match "/$" dir))
|
||||
(setq dir (concat dir "/")))
|
||||
(message "Collecting statistics...")
|
||||
(let ((flst (directory-files dir nil nil t))
|
||||
(extlst (list "<dir>"))
|
||||
(cntlst (list 0)))
|
||||
(while flst
|
||||
(let* ((j (string-match "[^\\.]\\(\\.[a-zA-Z]+\\|~\\|#\\)$" (car flst)))
|
||||
(s (if (file-accessible-directory-p (concat dir (car flst)))
|
||||
"<dir>"
|
||||
(if j
|
||||
(substring (car flst) (match-beginning 1) (match-end 1))
|
||||
nil)))
|
||||
(m (member s extlst)))
|
||||
(if (not s) nil
|
||||
(if m
|
||||
(let ((cell (nthcdr (- (length extlst) (length m)) cntlst)))
|
||||
(setcar cell (1+ (car cell))))
|
||||
(setq extlst (cons s extlst)
|
||||
cntlst (cons 1 cntlst)))))
|
||||
(setq flst (cdr flst)))
|
||||
;; Lets create the chart!
|
||||
(chart-bar-quickie 'vertical "Files Extension Distribution"
|
||||
extlst "File Extensions"
|
||||
cntlst "# of occurances"
|
||||
10
|
||||
'(lambda (a b) (> (cdr a) (cdr b))))
|
||||
))
|
||||
|
||||
(defun chart-space-usage (d)
|
||||
"Display a top usage chart for directory D."
|
||||
(interactive "DDirectory: ")
|
||||
(message "Collecting statistics...")
|
||||
(let ((nmlst nil)
|
||||
(cntlst nil)
|
||||
(b (get-buffer-create " *du-tmp*")))
|
||||
(set-buffer b)
|
||||
(erase-buffer)
|
||||
(insert "cd " d ";du -sk * \n")
|
||||
(message "Running `cd %s;du -sk *'..." d)
|
||||
(call-process-region (point-min) (point-max) shell-file-name t
|
||||
(current-buffer) nil)
|
||||
(goto-char (point-min))
|
||||
(message "Scanning output ...")
|
||||
(while (re-search-forward "^\\([0-9]+\\)[ \t]+\\([^ \n]+\\)$" nil t)
|
||||
(let* ((nam (buffer-substring (match-beginning 2) (match-end 2)))
|
||||
(num (buffer-substring (match-beginning 1) (match-end 1))))
|
||||
(setq nmlst (cons nam nmlst)
|
||||
;; * 1000 to put it into bytes
|
||||
cntlst (cons (* (string-to-number num) 1000) cntlst))))
|
||||
(if (not nmlst)
|
||||
(error "No files found!"))
|
||||
(chart-bar-quickie 'vertical (format "Largest files in %s" d)
|
||||
nmlst "File Name"
|
||||
cntlst "File Size"
|
||||
10
|
||||
'(lambda (a b) (> (cdr a) (cdr b))))
|
||||
))
|
||||
|
||||
(defun chart-emacs-storage ()
|
||||
"Chart the current storage requirements of Emacs."
|
||||
(interactive)
|
||||
(let* ((data (garbage-collect))
|
||||
(names '("strings/2" "vectors"
|
||||
"conses" "free cons"
|
||||
"syms" "free syms"
|
||||
"markers" "free mark"
|
||||
;; "floats" "free flt"
|
||||
))
|
||||
(nums (list (/ (nth 3 data) 2)
|
||||
(nth 4 data)
|
||||
(car (car data)) ; conses
|
||||
(cdr (car data))
|
||||
(car (nth 1 data)) ; syms
|
||||
(cdr (nth 1 data))
|
||||
(car (nth 2 data)) ; markers
|
||||
(cdr (nth 2 data))
|
||||
;(car (nth 5 data)) ; floats are Emacs only
|
||||
;(cdr (nth 5 data))
|
||||
)))
|
||||
;; Lets create the chart!
|
||||
(chart-bar-quickie 'vertical "Emacs Runtime Storage Usage"
|
||||
names "Storage Items"
|
||||
nums "Objects")))
|
||||
|
||||
(defun chart-emacs-lists ()
|
||||
"Chart out the size of various important lists."
|
||||
(interactive)
|
||||
(let* ((names '("buffers" "frames" "processes" "faces"))
|
||||
(nums (list (length (buffer-list))
|
||||
(length (frame-list))
|
||||
(length (process-list))
|
||||
(length (face-list))
|
||||
)))
|
||||
(if (fboundp 'x-display-list)
|
||||
(setq names (append names '("x-displays"))
|
||||
nums (append nums (list (length (x-display-list))))))
|
||||
;; Lets create the chart!
|
||||
(chart-bar-quickie 'vertical "Emacs List Size Chart"
|
||||
names "Various Lists"
|
||||
nums "Objects")))
|
||||
|
||||
(defun chart-rmail-from ()
|
||||
"If we are in an rmail summary buffer, then chart out the froms."
|
||||
(interactive)
|
||||
(if (not (eq major-mode 'rmail-summary-mode))
|
||||
(error "You must invoke chart-rmail-from in an rmail summary buffer"))
|
||||
(let ((nmlst nil)
|
||||
(cntlst nil))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t)
|
||||
(let* ((nam (buffer-substring (match-beginning 1) (match-end 1)))
|
||||
(m (member nam nmlst)))
|
||||
(message "Scanned username %s" nam)
|
||||
(if m
|
||||
(let ((cell (nthcdr (- (length nmlst) (length m)) cntlst)))
|
||||
(setcar cell (1+ (car cell))))
|
||||
(setq nmlst (cons nam nmlst)
|
||||
cntlst (cons 1 cntlst))))))
|
||||
(chart-bar-quickie 'vertical "Username Occurance in RMAIL box"
|
||||
nmlst "User Names"
|
||||
cntlst "# of occurances"
|
||||
10
|
||||
'(lambda (a b) (> (cdr a) (cdr b))))
|
||||
))
|
||||
|
||||
|
||||
(provide 'chart)
|
||||
|
||||
;;; chart.el ends here
|
||||
328
lisp/emacs-lisp/eieio-base.el
Normal file
328
lisp/emacs-lisp/eieio-base.el
Normal file
|
|
@ -0,0 +1,328 @@
|
|||
;;; eieio-base.el --- Base classes for EIEIO.
|
||||
|
||||
;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009
|
||||
;;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Base classes for EIEIO. These classes perform some basic tasks
|
||||
;; but are generally useless on their own. To use any of these classes,
|
||||
;; inherit from one or more of them.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'eieio)
|
||||
|
||||
;;; eieio-instance-inheritor
|
||||
;;
|
||||
;; Enable instance inheritance via the `clone' method.
|
||||
;; Works by using the `slot-unbound' method which usually throws an
|
||||
;; error if a slot is unbound.
|
||||
(defclass eieio-instance-inheritor ()
|
||||
((parent-instance :initarg :parent-instance
|
||||
:type eieio-instance-inheritor-child
|
||||
:documentation
|
||||
"The parent of this instance.
|
||||
If a slot of this class is reference, and is unbound, then the parent
|
||||
is checked for a value.")
|
||||
)
|
||||
"This special class can enable instance inheritance.
|
||||
Use `clone' to make a new object that does instance inheritance from
|
||||
a parent instance. When a slot in the child is referenced, and has
|
||||
not been set, use values from the parent."
|
||||
:abstract t)
|
||||
|
||||
(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
|
||||
"If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
|
||||
SLOT-NAME, is the offending slot. FN is the function signalling the error."
|
||||
(if (slot-boundp object 'parent-instance)
|
||||
;; It may not look like it, but this line recurses back into this
|
||||
;; method if the parent instance's slot is unbound.
|
||||
(eieio-oref (oref object parent-instance) slot-name)
|
||||
;; Throw the regular signal.
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod clone ((obj eieio-instance-inheritor) &rest params)
|
||||
"Clone OBJ, initializing `:parent' to OBJ.
|
||||
All slots are unbound, except those initialized with PARAMS."
|
||||
(let ((nobj (make-vector (length obj) eieio-unbound))
|
||||
(nm (aref obj object-name))
|
||||
(passname (and params (stringp (car params))))
|
||||
(num 1))
|
||||
(aset nobj 0 'object)
|
||||
(aset nobj object-class (aref obj object-class))
|
||||
;; The following was copied from the default clone.
|
||||
(if (not passname)
|
||||
(save-match-data
|
||||
(if (string-match "-\\([0-9]+\\)" nm)
|
||||
(setq num (1+ (string-to-number (match-string 1 nm)))
|
||||
nm (substring nm 0 (match-beginning 0))))
|
||||
(aset nobj object-name (concat nm "-" (int-to-string num))))
|
||||
(aset nobj object-name (car params)))
|
||||
;; Now initialize from params.
|
||||
(if params (shared-initialize nobj (if passname (cdr params) params)))
|
||||
(oset nobj parent-instance obj)
|
||||
nobj))
|
||||
|
||||
(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
|
||||
slot)
|
||||
"Non-nil if the instance inheritor OBJECT's SLOT is bound.
|
||||
See `slot-boundp' for for details on binding slots.
|
||||
The instance inheritor uses unbound slots as a way cascading cloned
|
||||
slot values, so testing for a slot being bound requires extra steps
|
||||
for this kind of object."
|
||||
(if (slot-boundp object slot)
|
||||
;; If it is regularly bound, return t.
|
||||
t
|
||||
(if (slot-boundp object 'parent-instance)
|
||||
(eieio-instance-inheritor-slot-boundp (oref object parent-instance)
|
||||
slot)
|
||||
nil)))
|
||||
|
||||
|
||||
;;; eieio-instance-tracker
|
||||
;;
|
||||
;; Track all created instances of this class.
|
||||
;; The class must initialize the `tracking-symbol' slot, and that
|
||||
;; symbol is then used to contain these objects.
|
||||
(defclass eieio-instance-tracker ()
|
||||
((tracking-symbol :type symbol
|
||||
:allocation :class
|
||||
:documentation
|
||||
"The symbol used to maintain a list of our instances.
|
||||
The instance list is treated as a variable, with new instances added to it.")
|
||||
)
|
||||
"This special class enables instance tracking.
|
||||
Inheritors from this class must overload `tracking-symbol' which is
|
||||
a variable symbol used to store a list of all instances."
|
||||
:abstract t)
|
||||
|
||||
(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
|
||||
&rest slots)
|
||||
"Make sure THIS is in our master list of this class.
|
||||
Optional argument SLOTS are the initialization arguments."
|
||||
;; Theoretically, this is never called twice for a given instance.
|
||||
(let ((sym (oref this tracking-symbol)))
|
||||
(if (not (memq this (symbol-value sym)))
|
||||
(set sym (append (symbol-value sym) (list this))))))
|
||||
|
||||
(defmethod delete-instance ((this eieio-instance-tracker))
|
||||
"Remove THIS from the master list of this class."
|
||||
(set (oref this tracking-symbol)
|
||||
(delq this (symbol-value (oref this tracking-symbol)))))
|
||||
|
||||
;; In retrospect, this is a silly function.
|
||||
(defun eieio-instance-tracker-find (key slot list-symbol)
|
||||
"Find KEY as an element of SLOT in the objects in LIST-SYMBOL.
|
||||
Returns the first match."
|
||||
(object-assoc key slot (symbol-value list-symbol)))
|
||||
|
||||
;;; eieio-singleton
|
||||
;;
|
||||
;; The singleton Design Pattern specifies that there is but one object
|
||||
;; of a given class ever created. The EIEIO singleton base class defines
|
||||
;; a CLASS allocated slot which contains the instance used. All calls to
|
||||
;; `make-instance' will either create a new instance and store it in this
|
||||
;; slot, or it will just return what is there.
|
||||
(defclass eieio-singleton ()
|
||||
((singleton :type eieio-singleton
|
||||
:allocation :class
|
||||
:documentation
|
||||
"The only instance of this class that will be instantiated.
|
||||
Multiple calls to `make-instance' will return this object."))
|
||||
"This special class causes subclasses to be singletons.
|
||||
A singleton is a class which will only ever have one instace."
|
||||
:abstract t)
|
||||
|
||||
(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots)
|
||||
"Constructor for singleton CLASS.
|
||||
NAME and SLOTS initialize the new object.
|
||||
This constructor guarantees that no matter how many you request,
|
||||
only one object ever exists."
|
||||
;; NOTE TO SELF: In next version, make `slot-boundp' support classes
|
||||
;; with class allocated slots or default values.
|
||||
(let ((old (oref-default class singleton)))
|
||||
(if (eq old eieio-unbound)
|
||||
(oset-default class singleton (call-next-method))
|
||||
old)))
|
||||
|
||||
|
||||
;;; eieio-persistent
|
||||
;;
|
||||
;; For objects which must save themselves to disk. Provides an
|
||||
;; `object-write' method to save an object to disk, and a
|
||||
;; `eieio-persistent-read' function to call to read an object
|
||||
;; from disk.
|
||||
;;
|
||||
;; Also provide the method `eieio-persistent-path-relative' to
|
||||
;; calculate path names relative to a given instance. This will
|
||||
;; make the saved object location independent by converting all file
|
||||
;; references to be relative to the directory the object is saved to.
|
||||
;; You must call `eieio-peristent-path-relative' on each file name
|
||||
;; saved in your object.
|
||||
(defclass eieio-persistent ()
|
||||
((file :initarg :file
|
||||
:type string
|
||||
:documentation
|
||||
"The save file for this persistent object.
|
||||
This must be a string, and must be specified when the new object is
|
||||
instantiated.")
|
||||
(extension :type string
|
||||
:allocation :class
|
||||
:initform ".eieio"
|
||||
:documentation
|
||||
"Extension of files saved by this object.
|
||||
Enables auto-choosing nice file names based on name.")
|
||||
(file-header-line :type string
|
||||
:allocation :class
|
||||
:initform ";; EIEIO PERSISTENT OBJECT"
|
||||
:documentation
|
||||
"Header line for the save file.
|
||||
This is used with the `object-write' method.")
|
||||
(do-backups :type boolean
|
||||
:allocation :class
|
||||
:initform t
|
||||
:documentation
|
||||
"Saving this object should make backup files.
|
||||
Setting to nil will mean no backups are made."))
|
||||
"This special class enables persistence through save files
|
||||
Use the `object-save' method to write this object to disk. The save
|
||||
format is Emacs Lisp code which calls the constructor for the saved
|
||||
object. For this reason, only slots which do not have an `:initarg'
|
||||
specified will not be saved."
|
||||
:abstract t)
|
||||
|
||||
(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
|
||||
&optional name)
|
||||
"Perpare to save THIS. Use in an `interactive' statement.
|
||||
Query user for file name with PROMPT if THIS does not yet specify
|
||||
a file. Optional argument NAME specifies a default file name."
|
||||
(unless (slot-boundp this 'file)
|
||||
(oset this file
|
||||
(read-file-name prompt nil
|
||||
(if name
|
||||
(concat name (oref this extension))
|
||||
))))
|
||||
(oref this file))
|
||||
|
||||
(defun eieio-persistent-read (filename)
|
||||
"Read a persistent object from FILENAME, and return it."
|
||||
(let ((ret nil)
|
||||
(buffstr nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer-create " *tmp eieio read*"))
|
||||
(insert-file-contents filename nil nil nil t)
|
||||
(goto-char (point-min))
|
||||
(setq buffstr (buffer-string)))
|
||||
;; Do the read in the buffer the read was initialized from
|
||||
;; so that any initialize-instance calls that depend on
|
||||
;; the current buffer will work.
|
||||
(setq ret (read buffstr))
|
||||
(if (not (child-of-class-p (car ret) 'eieio-persistent))
|
||||
(error "Corrupt object on disk"))
|
||||
(setq ret (eval ret))
|
||||
(oset ret file filename))
|
||||
(kill-buffer " *tmp eieio read*"))
|
||||
ret))
|
||||
|
||||
(defmethod object-write ((this eieio-persistent) &optional comment)
|
||||
"Write persistent object THIS out to the current stream.
|
||||
Optional argument COMMENT is a header line comment."
|
||||
(call-next-method this (or comment (oref this file-header-line))))
|
||||
|
||||
(defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
|
||||
"For object THIS, make absolute file name FILE relative."
|
||||
(file-relative-name (expand-file-name file)
|
||||
(file-name-directory (oref this file))))
|
||||
|
||||
(defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
|
||||
"Save persistent object THIS to disk.
|
||||
Optional argument FILE overrides the file name specified in the object
|
||||
instance."
|
||||
(save-excursion
|
||||
(let ((b (set-buffer (get-buffer-create " *tmp object write*")))
|
||||
(default-directory (file-name-directory (oref this file)))
|
||||
(cfn (oref this file)))
|
||||
(unwind-protect
|
||||
(save-excursion
|
||||
(erase-buffer)
|
||||
(let ((standard-output (current-buffer)))
|
||||
(oset this file
|
||||
(if file
|
||||
(eieio-persistent-path-relative this file)
|
||||
(file-name-nondirectory cfn)))
|
||||
(object-write this (oref this file-header-line)))
|
||||
(let ((backup-inhibited (not (oref this do-backups))))
|
||||
;; Old way - write file. Leaves message behind.
|
||||
;;(write-file cfn nil)
|
||||
|
||||
;; New way - Avoid the vast quantities of error checking
|
||||
;; just so I can get at the special flags that disable
|
||||
;; displaying random messages.
|
||||
(write-region (point-min) (point-max)
|
||||
cfn nil 1)
|
||||
))
|
||||
;; Restore :file, and kill the tmp buffer
|
||||
(oset this file cfn)
|
||||
(setq buffer-file-name nil)
|
||||
(kill-buffer b)))))
|
||||
|
||||
;; Notes on the persistent object:
|
||||
;; It should also set up some hooks to help it keep itself up to date.
|
||||
|
||||
|
||||
;;; Named object
|
||||
;;
|
||||
;; Named objects use the objects `name' as a slot, and that slot
|
||||
;; is accessed with the `object-name' symbol.
|
||||
|
||||
(defclass eieio-named ()
|
||||
()
|
||||
"Object with a name.
|
||||
Name storage already occurs in an object. This object provides get/set
|
||||
access to it."
|
||||
:abstract t)
|
||||
|
||||
(defmethod slot-missing ((obj eieio-named)
|
||||
slot-name operation &optional new-value)
|
||||
"Called when a on-existant slot is accessed.
|
||||
For variable `eieio-named', provide an imaginary `object-name' slot.
|
||||
Argument OBJ is the Named object.
|
||||
Argument SLOT-NAME is the slot that was attempted to be accessed.
|
||||
OPERATION is the type of access, such as `oref' or `oset'.
|
||||
NEW-VALUE is the value that was being set into SLOT if OPERATION were
|
||||
a set type."
|
||||
(if (or (eq slot-name 'object-name)
|
||||
(eq slot-name :object-name))
|
||||
(cond ((eq operation 'oset)
|
||||
(if (not (stringp new-value))
|
||||
(signal 'invalid-slot-type
|
||||
(list obj slot-name 'string new-value)))
|
||||
(object-set-name-string obj new-value))
|
||||
(t (object-name-string obj)))
|
||||
(call-next-method)))
|
||||
|
||||
(provide 'eieio-base)
|
||||
|
||||
;;; eieio-base.el ends here
|
||||
141
lisp/emacs-lisp/eieio-comp.el
Normal file
141
lisp/emacs-lisp/eieio-comp.el
Normal file
|
|
@ -0,0 +1,141 @@
|
|||
;;; eieio-comp.el -- eieio routines to help with byte compilation
|
||||
|
||||
;;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008,
|
||||
;;; 2009 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: oop, lisp, tools
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Byte compiler functions for defmethod. This will affect the new GNU
|
||||
;; byte compiler for Emacs 19 and better. This function will be called by
|
||||
;; the byte compiler whenever a `defmethod' is encountered in a file.
|
||||
;; It will output a function call to `eieio-defmethod' with the byte
|
||||
;; compiled function as a parameter.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(declare-function eieio-defgeneric-form "eieio" (method doc-string))
|
||||
|
||||
;; Some compatibility stuff
|
||||
(eval-and-compile
|
||||
(if (not (fboundp 'byte-compile-compiled-obj-to-list))
|
||||
(defun byte-compile-compiled-obj-to-list (moose) nil))
|
||||
|
||||
(if (not (boundp 'byte-compile-outbuffer))
|
||||
(defvar byte-compile-outbuffer nil))
|
||||
)
|
||||
|
||||
;; This teaches the byte compiler how to do this sort of thing.
|
||||
(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
|
||||
|
||||
;; Variables used free:
|
||||
(defvar outbuffer)
|
||||
(defvar filename)
|
||||
|
||||
(defun byte-compile-file-form-defmethod (form)
|
||||
"Mumble about the method we are compiling.
|
||||
This function is mostly ripped from `byte-compile-file-form-defun', but
|
||||
it's been modified to handle the special syntax of the defmethod
|
||||
command. There should probably be one for defgeneric as well, but
|
||||
that is called but rarely. Argument FORM is the body of the method."
|
||||
(setq form (cdr form))
|
||||
(let* ((meth (car form))
|
||||
(key (progn (setq form (cdr form))
|
||||
(cond ((or (eq ':BEFORE (car form))
|
||||
(eq ':before (car form)))
|
||||
(setq form (cdr form))
|
||||
":before ")
|
||||
((or (eq ':AFTER (car form))
|
||||
(eq ':after (car form)))
|
||||
(setq form (cdr form))
|
||||
":after ")
|
||||
((or (eq ':PRIMARY (car form))
|
||||
(eq ':primary (car form)))
|
||||
(setq form (cdr form))
|
||||
":primary ")
|
||||
((or (eq ':STATIC (car form))
|
||||
(eq ':static (car form)))
|
||||
(setq form (cdr form))
|
||||
":static ")
|
||||
(t ""))))
|
||||
(params (car form))
|
||||
(lamparams (byte-compile-defmethod-param-convert params))
|
||||
(arg1 (car params))
|
||||
(class (if (listp arg1) (nth 1 arg1) nil))
|
||||
(my-outbuffer (if (eval-when-compile (featurep 'xemacs))
|
||||
byte-compile-outbuffer
|
||||
(condition-case nil
|
||||
bytecomp-outbuffer
|
||||
(error outbuffer))))
|
||||
)
|
||||
(let ((name (format "%s::%s" (or class "#<generic>") meth)))
|
||||
(if byte-compile-verbose
|
||||
;; #### filename used free
|
||||
(message "Compiling %s... (%s)" (or filename "") name))
|
||||
(setq byte-compile-current-form name) ; for warnings
|
||||
)
|
||||
;; Flush any pending output
|
||||
(byte-compile-flush-pending)
|
||||
;; Byte compile the body. For the byte compiled forms, add the
|
||||
;; rest arguments, which will get ignored by the engine which will
|
||||
;; add them later (I hope)
|
||||
(let* ((new-one (byte-compile-lambda
|
||||
(append (list 'lambda lamparams)
|
||||
(cdr form))))
|
||||
(code (byte-compile-byte-code-maker new-one)))
|
||||
(princ "\n(eieio-defmethod '" my-outbuffer)
|
||||
(princ meth my-outbuffer)
|
||||
(princ " '(" my-outbuffer)
|
||||
(princ key my-outbuffer)
|
||||
(prin1 params my-outbuffer)
|
||||
(princ " " my-outbuffer)
|
||||
(prin1 code my-outbuffer)
|
||||
(princ "))" my-outbuffer)
|
||||
)
|
||||
;; Now add this function to the list of known functions.
|
||||
;; Don't bother with a doc string. Not relevant here.
|
||||
(add-to-list 'byte-compile-function-environment
|
||||
(cons meth
|
||||
(eieio-defgeneric-form meth "")))
|
||||
|
||||
;; Remove it from the undefined list if it is there.
|
||||
(let ((elt (assq meth byte-compile-unresolved-functions)))
|
||||
(if elt (setq byte-compile-unresolved-functions
|
||||
(delq elt byte-compile-unresolved-functions))))
|
||||
|
||||
;; nil prevents cruft from appearing in the output buffer.
|
||||
nil))
|
||||
|
||||
(defun byte-compile-defmethod-param-convert (paramlist)
|
||||
"Convert method params into the params used by the defmethod thingy.
|
||||
Argument PARAMLIST is the paramter list to convert."
|
||||
(let ((argfix nil))
|
||||
(while paramlist
|
||||
(setq argfix (cons (if (listp (car paramlist))
|
||||
(car (car paramlist))
|
||||
(car paramlist))
|
||||
argfix))
|
||||
(setq paramlist (cdr paramlist)))
|
||||
(nreverse argfix)))
|
||||
|
||||
(provide 'eieio-comp)
|
||||
|
||||
;;; eieio-comp.el ends here
|
||||
463
lisp/emacs-lisp/eieio-custom.el
Normal file
463
lisp/emacs-lisp/eieio-custom.el
Normal file
|
|
@ -0,0 +1,463 @@
|
|||
;;; eieio-custom.el -- eieio object customization
|
||||
|
||||
;;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009
|
||||
;;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This contains support customization of eieio objects. Enabling
|
||||
;; your object to be customizable requires use of the slot attirbute
|
||||
;; `:custom'.
|
||||
|
||||
(require 'eieio)
|
||||
(require 'widget)
|
||||
(require 'wid-edit)
|
||||
(require 'custom)
|
||||
|
||||
;;; Compatibility
|
||||
|
||||
;; (eval-and-compile
|
||||
;; (if (featurep 'xemacs)
|
||||
;; (defalias 'eieio-overlay-lists (lambda () (list (extent-list))))
|
||||
;; (defalias 'eieio-overlay-lists 'overlay-lists)))
|
||||
|
||||
;;; Code:
|
||||
(defclass eieio-widget-test-class nil
|
||||
((a-string :initarg :a-string
|
||||
:initform "The moose is loose"
|
||||
:custom string
|
||||
:label "Amorphous String"
|
||||
:group (default foo)
|
||||
:documentation "A string for testing custom.
|
||||
This is the next line of documentation.")
|
||||
(listostuff :initarg :listostuff
|
||||
:initform ("1" "2" "3")
|
||||
:type list
|
||||
:custom (repeat (string :tag "Stuff"))
|
||||
:label "List of Strings"
|
||||
:group foo
|
||||
:documentation "A list of stuff.")
|
||||
(uninitialized :initarg :uninitialized
|
||||
:type string
|
||||
:custom string
|
||||
:documentation "This slot is not initialized.
|
||||
Used to make sure that custom doesn't barf when it encounters one
|
||||
of these.")
|
||||
(a-number :initarg :a-number
|
||||
:initform 2
|
||||
:custom integer
|
||||
:documentation "A number of thingies."))
|
||||
"A class for testing the widget on.")
|
||||
|
||||
(defcustom eieio-widget-test (eieio-widget-test-class "Foo")
|
||||
"Test variable for editing an object."
|
||||
:type 'object
|
||||
:group 'eieio)
|
||||
|
||||
(defface eieio-custom-slot-tag-face '((((class color)
|
||||
(background dark))
|
||||
(:foreground "light blue"))
|
||||
(((class color)
|
||||
(background light))
|
||||
(:foreground "blue"))
|
||||
(t (:italic t)))
|
||||
"Face used for unpushable variable tags."
|
||||
:group 'custom-faces)
|
||||
|
||||
(defvar eieio-wo nil
|
||||
"Buffer local variable in object customize buffers for the current widget.")
|
||||
(defvar eieio-co nil
|
||||
"Buffer local variable in object customize buffers for the current obj.")
|
||||
(defvar eieio-cog nil
|
||||
"Buffer local variable in object customize buffers for the current group.")
|
||||
|
||||
(defvar eieio-custom-ignore-eieio-co nil
|
||||
"When true, all customizable slots of the current object are updated.
|
||||
Updates occur regardless of the current customization group.")
|
||||
|
||||
(define-widget 'object-slot 'group
|
||||
"Abstractly modify a single slot in an object."
|
||||
:tag "Slot"
|
||||
:format "%t %v%h\n"
|
||||
:convert-widget 'widget-types-convert-widget
|
||||
:value-create 'eieio-slot-value-create
|
||||
:value-get 'eieio-slot-value-get
|
||||
:value-delete 'widget-children-value-delete
|
||||
:validate 'widget-children-validate
|
||||
:match 'eieio-object-match ;; same
|
||||
)
|
||||
|
||||
(defun eieio-slot-value-create (widget)
|
||||
"Create the value of WIDGET."
|
||||
(let ((chil nil))
|
||||
(setq chil (cons
|
||||
(widget-create-child-and-convert
|
||||
widget (widget-get widget :childtype)
|
||||
:tag ""
|
||||
:value (widget-get widget :value))
|
||||
chil))
|
||||
(widget-put widget :children chil)))
|
||||
|
||||
(defun eieio-slot-value-get (widget)
|
||||
"Get the value of WIDGET."
|
||||
(widget-value (car (widget-get widget :children))))
|
||||
|
||||
(defun eieio-custom-toggle-hide (widget)
|
||||
"Toggle visibility of WIDGET."
|
||||
(let ((vc (car (widget-get widget :children))))
|
||||
(cond ((eq (widget-get vc :eieio-custom-state) 'hidden)
|
||||
(widget-put vc :eieio-custom-state 'visible)
|
||||
(widget-put vc :value-face (widget-get vc :orig-face)))
|
||||
(t
|
||||
(widget-put vc :eieio-custom-state 'hidden)
|
||||
(widget-put vc :orig-face (widget-get vc :value-face))
|
||||
(widget-put vc :value-face 'invisible)
|
||||
))
|
||||
(widget-value-set vc (widget-value vc))))
|
||||
|
||||
(defun eieio-custom-toggle-parent (widget &rest ignore)
|
||||
"Toggle visibility of parent of WIDGET.
|
||||
Optional argument IGNORE is an extraneous parameter."
|
||||
(eieio-custom-toggle-hide (widget-get widget :parent)))
|
||||
|
||||
(define-widget 'object-edit 'group
|
||||
"Abstractly modify a CLOS object."
|
||||
:tag "Object"
|
||||
:format "%v"
|
||||
:convert-widget 'widget-types-convert-widget
|
||||
:value-create 'eieio-object-value-create
|
||||
:value-get 'eieio-object-value-get
|
||||
:value-delete 'widget-children-value-delete
|
||||
:validate 'widget-children-validate
|
||||
:match 'eieio-object-match
|
||||
:clone-object-children nil
|
||||
)
|
||||
|
||||
(defun eieio-object-match (widget value)
|
||||
"Match info for WIDGET against VALUE."
|
||||
;; Write me
|
||||
t)
|
||||
|
||||
(defun eieio-filter-slot-type (widget slottype)
|
||||
"Filter WIDGETs SLOTTYPE."
|
||||
(if (widget-get widget :clone-object-children)
|
||||
slottype
|
||||
(cond ((eq slottype 'object)
|
||||
'object-edit)
|
||||
((and (listp slottype)
|
||||
(eq (car slottype) 'object))
|
||||
(cons 'object-edit (cdr slottype)))
|
||||
((equal slottype '(repeat object))
|
||||
'(repeat object-edit))
|
||||
((and (listp slottype)
|
||||
(equal (car slottype) 'repeat)
|
||||
(listp (car (cdr slottype)))
|
||||
(equal (car (car (cdr slottype))) 'object))
|
||||
(list 'repeat
|
||||
(cons 'object-edit
|
||||
(cdr (car (cdr slottype))))))
|
||||
(t slottype))))
|
||||
|
||||
(defun eieio-object-value-create (widget)
|
||||
"Create the value of WIDGET."
|
||||
(if (not (widget-get widget :value))
|
||||
(widget-put widget
|
||||
:value (cond ((widget-get widget :objecttype)
|
||||
(funcall (class-constructor
|
||||
(widget-get widget :objecttype))
|
||||
"Custom-new"))
|
||||
((widget-get widget :objectcreatefcn)
|
||||
(funcall (widget-get widget :objectcreatefcn)))
|
||||
(t (error "No create method specified")))))
|
||||
(let* ((chil nil)
|
||||
(obj (widget-get widget :value))
|
||||
(master-group (widget-get widget :eieio-group))
|
||||
(cv (class-v (object-class-fast obj)))
|
||||
(slots (aref cv class-public-a))
|
||||
(flabel (aref cv class-public-custom-label))
|
||||
(fgroup (aref cv class-public-custom-group))
|
||||
(fdoc (aref cv class-public-doc))
|
||||
(fcust (aref cv class-public-custom)))
|
||||
;; First line describes the object, but may not editable.
|
||||
(if (widget-get widget :eieio-show-name)
|
||||
(setq chil (cons (widget-create-child-and-convert
|
||||
widget 'string :tag "Object "
|
||||
:sample-face 'bold
|
||||
(object-name-string obj))
|
||||
chil)))
|
||||
;; Display information about the group being shown
|
||||
(when master-group
|
||||
(let ((groups (class-option (object-class-fast obj) :custom-groups)))
|
||||
(widget-insert "Groups:")
|
||||
(while groups
|
||||
(widget-insert " ")
|
||||
(if (eq (car groups) master-group)
|
||||
(widget-insert "*" (capitalize (symbol-name master-group)) "*")
|
||||
(widget-create 'push-button
|
||||
:thing (cons obj (car groups))
|
||||
:notify (lambda (widget &rest stuff)
|
||||
(eieio-customize-object
|
||||
(car (widget-get widget :thing))
|
||||
(cdr (widget-get widget :thing))))
|
||||
(capitalize (symbol-name (car groups)))))
|
||||
(setq groups (cdr groups)))
|
||||
(widget-insert "\n\n")))
|
||||
;; Loop over all the slots, creating child widgets.
|
||||
(while slots
|
||||
;; Output this slot if it has a customize flag associated with it.
|
||||
(when (and (car fcust)
|
||||
(or (not master-group) (member master-group (car fgroup)))
|
||||
(slot-boundp obj (car slots)))
|
||||
;; In this case, this slot has a custom type. Create it's
|
||||
;; children widgets.
|
||||
(let ((type (eieio-filter-slot-type widget (car fcust)))
|
||||
(stuff nil))
|
||||
;; This next bit is an evil hack to get some EDE functions
|
||||
;; working the way I like.
|
||||
(if (and (listp type)
|
||||
(setq stuff (member :slotofchoices type)))
|
||||
(let ((choices (eieio-oref obj (car (cdr stuff))))
|
||||
(newtype nil))
|
||||
(while (not (eq (car type) :slotofchoices))
|
||||
(setq newtype (cons (car type) newtype)
|
||||
type (cdr type)))
|
||||
(while choices
|
||||
(setq newtype (cons (list 'const (car choices))
|
||||
newtype)
|
||||
choices (cdr choices)))
|
||||
(setq type (nreverse newtype))))
|
||||
(setq chil (cons (widget-create-child-and-convert
|
||||
widget 'object-slot
|
||||
:childtype type
|
||||
:sample-face 'eieio-custom-slot-tag-face
|
||||
:tag
|
||||
(concat
|
||||
(make-string
|
||||
(or (widget-get widget :indent) 0)
|
||||
? )
|
||||
(if (car flabel)
|
||||
(car flabel)
|
||||
(let ((s (symbol-name
|
||||
(or
|
||||
(class-slot-initarg
|
||||
(object-class-fast obj)
|
||||
(car slots))
|
||||
(car slots)))))
|
||||
(capitalize
|
||||
(if (string-match "^:" s)
|
||||
(substring s (match-end 0))
|
||||
s)))))
|
||||
:value (slot-value obj (car slots))
|
||||
:doc (if (car fdoc) (car fdoc)
|
||||
"Slot not Documented.")
|
||||
:eieio-custom-visibility 'visible
|
||||
)
|
||||
chil))
|
||||
)
|
||||
)
|
||||
(setq slots (cdr slots)
|
||||
fdoc (cdr fdoc)
|
||||
fcust (cdr fcust)
|
||||
flabel (cdr flabel)
|
||||
fgroup (cdr fgroup)))
|
||||
(widget-put widget :children (nreverse chil))
|
||||
))
|
||||
|
||||
(defun eieio-object-value-get (widget)
|
||||
"Get the value of WIDGET."
|
||||
(let* ((obj (widget-get widget :value))
|
||||
(master-group eieio-cog)
|
||||
(cv (class-v (object-class-fast obj)))
|
||||
(fgroup (aref cv class-public-custom-group))
|
||||
(wids (widget-get widget :children))
|
||||
(name (if (widget-get widget :eieio-show-name)
|
||||
(car (widget-apply (car wids) :value-inline))
|
||||
nil))
|
||||
(chil (if (widget-get widget :eieio-show-name)
|
||||
(nthcdr 1 wids) wids))
|
||||
(cv (class-v (object-class-fast obj)))
|
||||
(slots (aref cv class-public-a))
|
||||
(fcust (aref cv class-public-custom)))
|
||||
;; If there are any prefix widgets, clear them.
|
||||
;; -- None yet
|
||||
;; Create a batch of initargs for each slot.
|
||||
(while (and slots chil)
|
||||
(if (and (car fcust)
|
||||
(or eieio-custom-ignore-eieio-co
|
||||
(not master-group) (member master-group (car fgroup)))
|
||||
(slot-boundp obj (car slots)))
|
||||
(progn
|
||||
;; Only customized slots have widgets
|
||||
(let ((eieio-custom-ignore-eieio-co t))
|
||||
(eieio-oset obj (car slots)
|
||||
(car (widget-apply (car chil) :value-inline))))
|
||||
(setq chil (cdr chil))))
|
||||
(setq slots (cdr slots)
|
||||
fgroup (cdr fgroup)
|
||||
fcust (cdr fcust)))
|
||||
;; Set any name updates on it.
|
||||
(if name (aset obj object-name name))
|
||||
;; This is the same object we had before.
|
||||
obj))
|
||||
|
||||
(defmethod eieio-done-customizing ((obj eieio-default-superclass))
|
||||
"When a applying change to a widget, call this method.
|
||||
This method is called by the default widget-edit commands. User made
|
||||
commands should also call this method when applying changes.
|
||||
Argument OBJ is the object that has been customized."
|
||||
nil)
|
||||
|
||||
(defun customize-object (obj &optional group)
|
||||
"Customize OBJ in a custom buffer.
|
||||
Optional argument GROUP is the sub-group of slots to display."
|
||||
(eieio-customize-object obj group))
|
||||
|
||||
(defmethod eieio-customize-object ((obj eieio-default-superclass)
|
||||
&optional group)
|
||||
"Customize OBJ in a specialized custom buffer.
|
||||
To override call the `eieio-custom-widget-insert' to just insert the
|
||||
object widget.
|
||||
Optional argument GROUP specifies a subgroup of slots to edit as a symbol.
|
||||
These groups are specified with the `:group' slot flag."
|
||||
;; Insert check for multiple edits here.
|
||||
(let* ((g (or group 'default)))
|
||||
(switch-to-buffer (get-buffer-create
|
||||
(concat "*CUSTOMIZE "
|
||||
(object-name obj) " "
|
||||
(symbol-name g) "*")))
|
||||
(toggle-read-only -1)
|
||||
(kill-all-local-variables)
|
||||
(erase-buffer)
|
||||
(let ((all (overlay-lists)))
|
||||
;; Delete all the overlays.
|
||||
(mapc 'delete-overlay (car all))
|
||||
(mapc 'delete-overlay (cdr all)))
|
||||
;; Add an apply reset option at the top of the buffer.
|
||||
(eieio-custom-object-apply-reset obj)
|
||||
(widget-insert "\n\n")
|
||||
(widget-insert "Edit object " (object-name obj) "\n\n")
|
||||
;; Create the widget editing the object.
|
||||
(make-local-variable 'eieio-wo)
|
||||
(setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
|
||||
;;Now generate the apply buttons
|
||||
(widget-insert "\n")
|
||||
(eieio-custom-object-apply-reset obj)
|
||||
;; Now initialize the buffer
|
||||
(use-local-map widget-keymap)
|
||||
(widget-setup)
|
||||
;;(widget-minor-mode)
|
||||
(goto-char (point-min))
|
||||
(widget-forward 3)
|
||||
(make-local-variable 'eieio-co)
|
||||
(setq eieio-co obj)
|
||||
(make-local-variable 'eieio-cog)
|
||||
(setq eieio-cog group)))
|
||||
|
||||
(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass))
|
||||
"Insert an Apply and Reset button into the object editor.
|
||||
Argument OBJ os the object being customized."
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
(widget-apply eieio-wo :value-get)
|
||||
(eieio-done-customizing eieio-co)
|
||||
(bury-buffer))
|
||||
"Accept")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
;; I think the act of getting it sets
|
||||
;; it's value through the get function.
|
||||
(message "Applying Changes...")
|
||||
(widget-apply eieio-wo :value-get)
|
||||
(eieio-done-customizing eieio-co)
|
||||
(message "Applying Changes...Done."))
|
||||
"Apply")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
(message "Resetting.")
|
||||
(eieio-customize-object eieio-co eieio-cog))
|
||||
"Reset")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
(bury-buffer))
|
||||
"Cancel"))
|
||||
|
||||
(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
|
||||
&rest flags)
|
||||
"Insert the widget used for editing object OBJ in the current buffer.
|
||||
Arguments FLAGS are widget compatible flags.
|
||||
Must return the created widget."
|
||||
(apply 'widget-create 'object-edit :value obj flags))
|
||||
|
||||
(define-widget 'object 'object-edit
|
||||
"Instance of a CLOS class."
|
||||
:format "%{%t%}:\n%v"
|
||||
:value-to-internal 'eieio-object-value-to-abstract
|
||||
:value-to-external 'eieio-object-abstract-to-value
|
||||
:clone-object-children t
|
||||
)
|
||||
|
||||
(defun eieio-object-value-to-abstract (widget value)
|
||||
"For WIDGET, convert VALUE to an abstract /safe/ representation."
|
||||
(if (eieio-object-p value) value
|
||||
(if (null value) value
|
||||
nil)))
|
||||
|
||||
(defun eieio-object-abstract-to-value (widget value)
|
||||
"For WIDGET, convert VALUE from an abstract /safe/ representation."
|
||||
value)
|
||||
|
||||
|
||||
;;; customization group functions
|
||||
;;
|
||||
;; These functions provide the ability to create dynamic menus to
|
||||
;; customize specific sections of an object. They do not hook directly
|
||||
;; into a filter, but can be used to create easymenu vectors.
|
||||
(defmethod eieio-customize-object-group ((obj eieio-default-superclass))
|
||||
"Create a list of vectors for customizing sections of OBJ."
|
||||
(mapcar (lambda (group)
|
||||
(vector (concat "Group " (symbol-name group))
|
||||
(list 'customize-object obj (list 'quote group))
|
||||
t))
|
||||
(class-option (object-class-fast obj) :custom-groups)))
|
||||
|
||||
(defvar eieio-read-custom-group-history nil
|
||||
"History for the custom group reader.")
|
||||
|
||||
(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
|
||||
"Do a completing read on the name of a customization group in OBJ.
|
||||
Return the symbol for the group, or nil"
|
||||
(let ((g (class-option (object-class-fast obj) :custom-groups)))
|
||||
(if (= (length g) 1)
|
||||
(car g)
|
||||
;; Make the association list
|
||||
(setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g))
|
||||
(cdr (assoc
|
||||
(completing-read (concat (oref obj name) " Custom Group: ")
|
||||
g nil t nil 'eieio-read-custom-group-history)
|
||||
g)))))
|
||||
|
||||
(provide 'eieio-custom)
|
||||
|
||||
;;; eieio-custom.el ends here
|
||||
696
lisp/emacs-lisp/eieio-opt.el
Normal file
696
lisp/emacs-lisp/eieio-opt.el
Normal file
|
|
@ -0,0 +1,696 @@
|
|||
;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
|
||||
|
||||
;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005,
|
||||
;;; 2008, 2009 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This contains support functions to eieio. These functions contain
|
||||
;; some small class browser and class printing functions.
|
||||
;;
|
||||
|
||||
(require 'eieio)
|
||||
|
||||
;;; Code:
|
||||
(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
|
||||
variable `eieio-default-superclass'."
|
||||
(interactive (if current-prefix-arg
|
||||
(list (read (completing-read "Class: "
|
||||
(eieio-build-class-alist)
|
||||
nil t)))
|
||||
nil))
|
||||
(if (not root-class) (setq root-class 'eieio-default-superclass))
|
||||
(if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class)))
|
||||
(display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer "*EIEIO OBJECT BROWSE*"))
|
||||
(erase-buffer)
|
||||
(goto-char 0)
|
||||
(eieio-browse-tree root-class "" "")
|
||||
))
|
||||
|
||||
(defun eieio-browse-tree (this-root prefix ch-prefix)
|
||||
"Recursively, draws the children of the given class on the screen.
|
||||
Argument THIS-ROOT is the local root of the tree.
|
||||
Argument PREFIX is the character prefix to use.
|
||||
Argument CH-PREFIX is another character prefix to display."
|
||||
(if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root)))
|
||||
(let ((myname (symbol-name this-root))
|
||||
(chl (aref (class-v this-root) class-children))
|
||||
(fprefix (concat ch-prefix " +--"))
|
||||
(mprefix (concat ch-prefix " | "))
|
||||
(lprefix (concat ch-prefix " ")))
|
||||
(insert prefix myname "\n")
|
||||
(while (cdr chl)
|
||||
(eieio-browse-tree (car chl) fprefix mprefix)
|
||||
(setq chl (cdr chl)))
|
||||
(if chl
|
||||
(eieio-browse-tree (car chl) fprefix lprefix))
|
||||
))
|
||||
|
||||
;;; CLASS COMPLETION / DOCUMENTATION
|
||||
|
||||
(defalias 'describe-class 'eieio-describe-class)
|
||||
|
||||
(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 obect.
|
||||
Optional HEADERFCN should be called to insert a few bits of info first."
|
||||
(interactive (list (eieio-read-class "Class: ")))
|
||||
(with-output-to-temp-buffer (help-buffer) ;"*Help*"
|
||||
(help-setup-xref (list #'eieio-describe-class class headerfcn)
|
||||
(interactive-p))
|
||||
|
||||
(when headerfcn (funcall headerfcn))
|
||||
|
||||
(if (class-option class :abstract)
|
||||
(princ "Abstract "))
|
||||
(princ "Class ")
|
||||
(prin1 class)
|
||||
(terpri)
|
||||
;; Inheritence tree information
|
||||
(let ((pl (class-parents class)))
|
||||
(when pl
|
||||
(princ " Inherits from ")
|
||||
(while pl
|
||||
(princ "`") (prin1 (car pl)) (princ "'")
|
||||
(setq pl (cdr pl))
|
||||
(if pl (princ ", ")))
|
||||
(terpri)))
|
||||
(let ((ch (class-children class)))
|
||||
(when ch
|
||||
(princ " Children ")
|
||||
(while ch
|
||||
(princ "`") (prin1 (car ch)) (princ "'")
|
||||
(setq ch (cdr ch))
|
||||
(if ch (princ ", ")))
|
||||
(terpri)))
|
||||
(terpri)
|
||||
;; System documentation
|
||||
(let ((doc (documentation-property class 'variable-documentation)))
|
||||
(when doc
|
||||
(princ "Documentation:")
|
||||
(terpri)
|
||||
(princ doc)
|
||||
(terpri)
|
||||
(terpri)))
|
||||
;; Describe all the slots in this class
|
||||
(eieio-describe-class-slots class)
|
||||
;; Describe all the methods specific to this class.
|
||||
(let ((methods (eieio-all-generic-functions class))
|
||||
(doc nil))
|
||||
(if (not methods) nil
|
||||
(princ "Specialized Methods:")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(while methods
|
||||
(setq doc (eieio-method-documentation (car methods) class))
|
||||
(princ "`")
|
||||
(prin1 (car methods))
|
||||
(princ "'")
|
||||
(if (not doc)
|
||||
(princ " Undocumented")
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :STATIC ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :BEFORE ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :PRIMARY ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :AFTER ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(terpri)
|
||||
(terpri))
|
||||
(setq methods (cdr methods))))))
|
||||
(save-excursion
|
||||
(set-buffer (help-buffer))
|
||||
(buffer-string)))
|
||||
|
||||
(defun eieio-describe-class-slots (class)
|
||||
"Describe the slots in CLASS.
|
||||
Outputs to the standard output."
|
||||
(let* ((cv (class-v class))
|
||||
(docs (aref cv class-public-doc))
|
||||
(names (aref cv class-public-a))
|
||||
(deflt (aref cv class-public-d))
|
||||
(types (aref cv class-public-type))
|
||||
(publp (aref cv class-public-printer))
|
||||
(i 0)
|
||||
(prot (aref cv class-protection))
|
||||
)
|
||||
(princ "Instance Allocated Slots:")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(while names
|
||||
(if (car prot) (princ "Private "))
|
||||
(princ "Slot: ")
|
||||
(prin1 (car names))
|
||||
(when (not (eq (aref types i) t))
|
||||
(princ " type = ")
|
||||
(prin1 (aref types i)))
|
||||
(unless (eq (car deflt) eieio-unbound)
|
||||
(princ " default = ")
|
||||
(prin1 (car deflt)))
|
||||
(when (car publp)
|
||||
(princ " printer = ")
|
||||
(prin1 (car publp)))
|
||||
(when (car docs)
|
||||
(terpri)
|
||||
(princ " ")
|
||||
(princ (car docs))
|
||||
(terpri))
|
||||
(terpri)
|
||||
(setq names (cdr names)
|
||||
docs (cdr docs)
|
||||
deflt (cdr deflt)
|
||||
publp (cdr publp)
|
||||
prot (cdr prot)
|
||||
i (1+ i)))
|
||||
(setq docs (aref cv class-class-allocation-doc)
|
||||
names (aref cv class-class-allocation-a)
|
||||
types (aref cv class-class-allocation-type)
|
||||
i 0
|
||||
prot (aref cv class-class-allocation-protection))
|
||||
(when names
|
||||
(terpri)
|
||||
(princ "Class Allocated Slots:"))
|
||||
(terpri)
|
||||
(terpri)
|
||||
(while names
|
||||
(when (car prot)
|
||||
(princ "Private "))
|
||||
(princ "Slot: ")
|
||||
(prin1 (car names))
|
||||
(unless (eq (aref types i) t)
|
||||
(princ " type = ")
|
||||
(prin1 (aref types i)))
|
||||
(condition-case nil
|
||||
(let ((value (eieio-oref class (car names))))
|
||||
(princ " value = ")
|
||||
(prin1 value))
|
||||
(error nil))
|
||||
(when (car docs)
|
||||
(terpri)
|
||||
(princ " ")
|
||||
(princ (car docs))
|
||||
(terpri))
|
||||
(terpri)
|
||||
(setq names (cdr names)
|
||||
docs (cdr docs)
|
||||
prot (cdr prot)
|
||||
i (1+ i)))))
|
||||
|
||||
(defun eieio-describe-constructor (fcn)
|
||||
"Describe the constructor function FCN.
|
||||
Uses `eieio-describe-class' to describe the class being constructed."
|
||||
(interactive
|
||||
;; Use eieio-read-class since all constructors have the same name as
|
||||
;; the class they create.
|
||||
(list (eieio-read-class "Class: ")))
|
||||
(eieio-describe-class
|
||||
fcn (lambda ()
|
||||
;; Describe the constructor part.
|
||||
(princ "Object Constructor Function: ")
|
||||
(prin1 fcn)
|
||||
(terpri)
|
||||
(princ "Creates an object of class ")
|
||||
(prin1 fcn)
|
||||
(princ ".")
|
||||
(terpri)
|
||||
(terpri)
|
||||
))
|
||||
)
|
||||
|
||||
(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.
|
||||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
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)))
|
||||
(while sublst
|
||||
(setq buildlist (eieio-build-class-alist
|
||||
(car sublst) instantiable-only buildlist))
|
||||
(setq sublst (cdr sublst)))
|
||||
buildlist))
|
||||
|
||||
(defvar eieio-read-class nil
|
||||
"History of the function `eieio-read-class' prompt.")
|
||||
|
||||
(defun eieio-read-class (prompt &optional histvar instantiable-only)
|
||||
"Return a class chosen by the user using PROMPT.
|
||||
Optional argument HISTVAR is a variable to use as history.
|
||||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract."
|
||||
(intern (completing-read prompt (eieio-build-class-alist nil instantiable-only)
|
||||
nil t nil
|
||||
(or histvar 'eieio-read-class))))
|
||||
|
||||
(defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
|
||||
"Return a class chosen by the user using PROMPT.
|
||||
CLASS is the base class, and completion occurs across all subclasses.
|
||||
Optional argument HISTVAR is a variable to use as history.
|
||||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract."
|
||||
(intern (completing-read prompt
|
||||
(eieio-build-class-alist class instantiable-only)
|
||||
nil t nil
|
||||
(or histvar 'eieio-read-class))))
|
||||
|
||||
;;; METHOD COMPLETION / DOC
|
||||
|
||||
(defalias 'describe-method 'eieio-describe-generic)
|
||||
(defalias 'describe-generic 'eieio-describe-generic)
|
||||
(defalias 'eieio-describe-method 'eieio-describe-generic)
|
||||
|
||||
(defun eieio-describe-generic (generic)
|
||||
"Describe the generic function GENERIC.
|
||||
Also extracts information about all methods specific to this generic."
|
||||
(interactive (list (eieio-read-generic "Generic Method: ")))
|
||||
(if (not (generic-p generic))
|
||||
(signal 'wrong-type-argument '(generic-p generic)))
|
||||
(with-output-to-temp-buffer (help-buffer) ; "*Help*"
|
||||
(help-setup-xref (list #'eieio-describe-generic generic) (interactive-p))
|
||||
|
||||
(prin1 generic)
|
||||
(princ " is a generic function")
|
||||
(when (generic-primary-only-p generic)
|
||||
(princ " with only ")
|
||||
(when (generic-primary-only-one-p generic)
|
||||
(princ "one "))
|
||||
(princ "primary method")
|
||||
(when (not (generic-primary-only-one-p generic))
|
||||
(princ "s"))
|
||||
)
|
||||
(princ ".")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(let ((d (documentation generic)))
|
||||
(if (not d)
|
||||
(princ "The generic is not documented.\n")
|
||||
(princ "Documentation:")
|
||||
(terpri)
|
||||
(princ d)
|
||||
(terpri)
|
||||
(terpri)))
|
||||
(princ "Implementations:")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(let ((i 3)
|
||||
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
|
||||
;; Loop over fanciful generics
|
||||
(while (< i 6)
|
||||
(let ((gm (aref (get generic 'eieio-method-tree) i)))
|
||||
(when gm
|
||||
(princ "Generic ")
|
||||
(princ (aref prefix (- i 3)))
|
||||
(terpri)
|
||||
(princ (or (nth 2 gm) "Undocumented"))
|
||||
(terpri)
|
||||
(terpri)))
|
||||
(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 gm
|
||||
(princ "`")
|
||||
(prin1 (car (car gm)))
|
||||
(princ "'")
|
||||
;; prefix type
|
||||
(princ " ")
|
||||
(princ (aref prefix i))
|
||||
(princ " ")
|
||||
;; argument list
|
||||
(let* ((func (cdr (car gm)))
|
||||
(arglst (eieio-lambda-arglist func)))
|
||||
(prin1 arglst))
|
||||
(terpri)
|
||||
;; 3 because of cdr
|
||||
(princ (or (documentation (cdr (car gm)))
|
||||
"Undocumented"))
|
||||
(setq gm (cdr gm))
|
||||
(terpri)
|
||||
(terpri)))
|
||||
(setq i (1+ i)))))
|
||||
(save-excursion
|
||||
(set-buffer (help-buffer))
|
||||
(buffer-string)))
|
||||
|
||||
(defun eieio-lambda-arglist (func)
|
||||
"Return the argument list of FUNC, a function body."
|
||||
(if (symbolp func) (setq func (symbol-function func)))
|
||||
(if (byte-code-function-p func)
|
||||
(eieio-compiled-function-arglist func)
|
||||
(car (cdr func))))
|
||||
|
||||
(defun eieio-all-generic-functions (&optional class)
|
||||
"Return a list of all generic functions.
|
||||
Optional CLASS argument returns only those functions that contain methods for CLASS."
|
||||
(let ((l nil) tree (cn (if class (symbol-name class) nil)))
|
||||
(mapatoms
|
||||
(lambda (symbol)
|
||||
(setq tree (get symbol 'eieio-method-obarray))
|
||||
(if tree
|
||||
(progn
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(if (or (not class)
|
||||
(fboundp (intern-soft cn (aref tree 0)))
|
||||
(fboundp (intern-soft cn (aref tree 1)))
|
||||
(fboundp (intern-soft cn (aref tree 2))))
|
||||
(setq l (cons symbol l)))))))
|
||||
l))
|
||||
|
||||
(defun eieio-method-documentation (generic class)
|
||||
"Return a list of the specific documentation of GENERIC for CLASS.
|
||||
If there is not an explicit method for CLASS in GENERIC, or if that
|
||||
function has no documentation, then return nil."
|
||||
(let ((tree (get generic 'eieio-method-obarray))
|
||||
(cn (symbol-name class))
|
||||
before primary after)
|
||||
(if (not tree)
|
||||
nil
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(setq before (intern-soft cn (aref tree 0))
|
||||
primary (intern-soft cn (aref tree 1))
|
||||
after (intern-soft cn (aref tree 2)))
|
||||
(if (not (or (fboundp before)
|
||||
(fboundp primary)
|
||||
(fboundp after)))
|
||||
nil
|
||||
(list (if (fboundp before)
|
||||
(cons (eieio-lambda-arglist before)
|
||||
(documentation before))
|
||||
nil)
|
||||
(if (fboundp primary)
|
||||
(cons (eieio-lambda-arglist primary)
|
||||
(documentation primary))
|
||||
nil)
|
||||
(if (fboundp after)
|
||||
(cons (eieio-lambda-arglist after)
|
||||
(documentation after))
|
||||
nil))))))
|
||||
|
||||
(defvar eieio-read-generic nil
|
||||
"History of the `eieio-read-generic' prompt.")
|
||||
|
||||
(defun eieio-read-generic-p (fn)
|
||||
"Function used in function `eieio-read-generic'.
|
||||
This is because `generic-p' is a macro.
|
||||
Argument FN is the function to test."
|
||||
(generic-p fn))
|
||||
|
||||
(defun eieio-read-generic (prompt &optional historyvar)
|
||||
"Read a generic function from the minibuffer with PROMPT.
|
||||
Optional argument HISTORYVAR is the variable to use as history."
|
||||
(intern (completing-read prompt obarray 'eieio-read-generic-p
|
||||
t nil (or historyvar 'eieio-read-generic))))
|
||||
|
||||
;;; METHOD STATS
|
||||
;;
|
||||
;; Dump out statistics about all the active methods in a session.
|
||||
(defun eieio-display-method-list ()
|
||||
"Display a list of all the methods and what features are used."
|
||||
(interactive)
|
||||
(let* ((meth1 (eieio-all-generic-functions))
|
||||
(meth (sort meth1 (lambda (a b)
|
||||
(string< (symbol-name a)
|
||||
(symbol-name b)))))
|
||||
(buff (get-buffer-create "*EIEIO Method List*"))
|
||||
(methidx 0)
|
||||
(standard-output buff)
|
||||
(slots '(method-static
|
||||
method-before
|
||||
method-primary
|
||||
method-after
|
||||
method-generic-before
|
||||
method-generic-primary
|
||||
method-generic-after))
|
||||
(slotn '("static"
|
||||
"before"
|
||||
"primary"
|
||||
"after"
|
||||
"G bef"
|
||||
"G prim"
|
||||
"G aft"))
|
||||
(idxarray (make-vector (length slots) 0))
|
||||
(primaryonly 0)
|
||||
(oneprimary 0)
|
||||
)
|
||||
(switch-to-buffer-other-window buff)
|
||||
(erase-buffer)
|
||||
(dolist (S slotn)
|
||||
(princ S)
|
||||
(princ "\t")
|
||||
)
|
||||
(princ "Method Name")
|
||||
(terpri)
|
||||
(princ "--------------------------------------------------------------------")
|
||||
(terpri)
|
||||
(dolist (M meth)
|
||||
(let ((mtree (get M 'eieio-method-tree))
|
||||
(P nil) (numP)
|
||||
(!P nil))
|
||||
(dolist (S slots)
|
||||
(let ((num (length (aref mtree (symbol-value S)))))
|
||||
(aset idxarray (symbol-value S)
|
||||
(+ num (aref idxarray (symbol-value S))))
|
||||
(prin1 num)
|
||||
(princ "\t")
|
||||
(when (< 0 num)
|
||||
(if (eq S 'method-primary)
|
||||
(setq P t numP num)
|
||||
(setq !P t)))
|
||||
))
|
||||
;; Is this a primary-only impl method?
|
||||
(when (and P (not !P))
|
||||
(setq primaryonly (1+ primaryonly))
|
||||
(when (= numP 1)
|
||||
(setq oneprimary (1+ oneprimary))
|
||||
(princ "*"))
|
||||
(princ "* ")
|
||||
)
|
||||
(prin1 M)
|
||||
(terpri)
|
||||
(setq methidx (1+ methidx))
|
||||
)
|
||||
)
|
||||
(princ "--------------------------------------------------------------------")
|
||||
(terpri)
|
||||
(dolist (S slots)
|
||||
(prin1 (aref idxarray (symbol-value S)))
|
||||
(princ "\t")
|
||||
)
|
||||
(prin1 methidx)
|
||||
(princ " Total symbols")
|
||||
(terpri)
|
||||
(dolist (S slotn)
|
||||
(princ S)
|
||||
(princ "\t")
|
||||
)
|
||||
(terpri)
|
||||
(terpri)
|
||||
(princ "Methods Primary Only: ")
|
||||
(prin1 primaryonly)
|
||||
(princ "\t")
|
||||
(princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
|
||||
(princ "% of total methods")
|
||||
(terpri)
|
||||
(princ "Only One Primary Impl: ")
|
||||
(prin1 oneprimary)
|
||||
(princ "\t")
|
||||
(princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
|
||||
(princ "% of total primary methods")
|
||||
(terpri)
|
||||
))
|
||||
|
||||
;;; HELP AUGMENTATION
|
||||
;;
|
||||
(defun eieio-help-mode-augmentation-maybee (&rest unused)
|
||||
"For buffers thrown into help mode, augment for eieio.
|
||||
Arguments UNUSED are not used."
|
||||
;; Scan created buttons so far if we are in help mode.
|
||||
(when (eq major-mode 'help-mode)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let ((pos t) (inhibit-read-only t))
|
||||
(while pos
|
||||
(if (get-text-property (point) 'help-xref) ; move off reference
|
||||
(goto-char
|
||||
(or (next-single-property-change (point) 'help-xref)
|
||||
(point))))
|
||||
(setq pos (next-single-property-change (point) 'help-xref))
|
||||
(when pos
|
||||
(goto-char pos)
|
||||
(let* ((help-data (get-text-property (point) 'help-xref))
|
||||
;(method (car help-data))
|
||||
(args (cdr help-data)))
|
||||
(when (symbolp (car args))
|
||||
(cond ((class-p (car args))
|
||||
(setcar help-data 'eieio-describe-class))
|
||||
((generic-p (car args))
|
||||
(setcar help-data 'eieio-describe-generic))
|
||||
(t nil))
|
||||
))))
|
||||
;; start back at the beginning, and highlight some sections
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(if (re-search-forward "^Specialized Methods:$" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^\\(Private \\)?Slot:" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
))))
|
||||
|
||||
;;; SPEEDBAR SUPPORT
|
||||
;;
|
||||
(eval-when-compile
|
||||
(condition-case nil
|
||||
(require 'speedbar)
|
||||
(error (message "Error loading speedbar... ignored."))))
|
||||
|
||||
(defvar eieio-class-speedbar-key-map nil
|
||||
"Keymap used when working with a project in speedbar.")
|
||||
|
||||
(defun eieio-class-speedbar-make-map ()
|
||||
"Make a keymap for eieio under speedbar."
|
||||
(setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
|
||||
|
||||
;; General viewing stuff
|
||||
(define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
|
||||
(define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
|
||||
(define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
|
||||
)
|
||||
|
||||
(if eieio-class-speedbar-key-map
|
||||
nil
|
||||
(if (not (featurep 'speedbar))
|
||||
(add-hook 'speedbar-load-hook (lambda ()
|
||||
(eieio-class-speedbar-make-map)
|
||||
(speedbar-add-expansion-list
|
||||
'("EIEIO"
|
||||
eieio-class-speedbar-menu
|
||||
eieio-class-speedbar-key-map
|
||||
eieio-class-speedbar))))
|
||||
(eieio-class-speedbar-make-map)
|
||||
(speedbar-add-expansion-list '("EIEIO"
|
||||
eieio-class-speedbar-menu
|
||||
eieio-class-speedbar-key-map
|
||||
eieio-class-speedbar))))
|
||||
|
||||
(defvar eieio-class-speedbar-menu
|
||||
()
|
||||
"Menu part in easymenu format used in speedbar while in `eieio' mode.")
|
||||
|
||||
(defun eieio-class-speedbar (dir-or-object depth)
|
||||
"Create buttons in speedbar that represents the current project.
|
||||
DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current
|
||||
expansion depth."
|
||||
(when (eq (point-min) (point-max))
|
||||
;; This function is only called once, to start the whole deal.
|
||||
;; Ceate, and expand the default object.
|
||||
(eieio-class-button eieio-default-superclass 0)
|
||||
(forward-line -1)
|
||||
(speedbar-expand-line)))
|
||||
|
||||
(defun eieio-class-button (class depth)
|
||||
"Draw a speedbar button at the current point for CLASS at DEPTH."
|
||||
(if (not (class-p class))
|
||||
(signal 'wrong-type-argument (list 'class-p class)))
|
||||
(let ((subclasses (aref (class-v class) class-children)))
|
||||
(if subclasses
|
||||
(speedbar-make-tag-line 'angle ?+
|
||||
'eieio-sb-expand
|
||||
class
|
||||
(symbol-name class)
|
||||
'eieio-describe-class-sb
|
||||
class
|
||||
'speedbar-directory-face
|
||||
depth)
|
||||
(speedbar-make-tag-line 'angle ? nil nil
|
||||
(symbol-name class)
|
||||
'eieio-describe-class-sb
|
||||
class
|
||||
'speedbar-directory-face
|
||||
depth))))
|
||||
|
||||
(defun eieio-sb-expand (text class indent)
|
||||
"For button TEXT, expand CLASS at the current location.
|
||||
Argument INDENT is the depth of indentation."
|
||||
(cond ((string-match "+" text) ;we have to expand this file
|
||||
(speedbar-change-expand-button-char ?-)
|
||||
(speedbar-with-writable
|
||||
(save-excursion
|
||||
(end-of-line) (forward-char 1)
|
||||
(let ((subclasses (aref (class-v class) class-children)))
|
||||
(while subclasses
|
||||
(eieio-class-button (car subclasses) (1+ indent))
|
||||
(setq subclasses (cdr subclasses)))))))
|
||||
((string-match "-" text) ;we have to contract this node
|
||||
(speedbar-change-expand-button-char ?+)
|
||||
(speedbar-delete-subblock indent))
|
||||
(t (error "Ooops... not sure what to do")))
|
||||
(speedbar-center-buffer-smartly))
|
||||
|
||||
(defun eieio-describe-class-sb (text token indent)
|
||||
"Describe the class TEXT in TOKEN.
|
||||
INDENT is the current indentation level."
|
||||
(speedbar-with-attached-buffer
|
||||
(eieio-describe-class token))
|
||||
(speedbar-maybee-jump-to-attached-frame))
|
||||
|
||||
(provide 'eieio-opt)
|
||||
|
||||
;;; eieio-opt.el ends here
|
||||
424
lisp/emacs-lisp/eieio-speedbar.el
Normal file
424
lisp/emacs-lisp/eieio-speedbar.el
Normal file
|
|
@ -0,0 +1,424 @@
|
|||
;;; eieio-speedbar.el -- Classes for managing speedbar displays.
|
||||
|
||||
;;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008 Free
|
||||
;;; Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, tools
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This provides some classes that can be used as a parent which
|
||||
;; will automatically provide SPEEDBAR support for any list of objects
|
||||
;; of that type.
|
||||
;;
|
||||
;; This file requires speedbar version 0.10 or later.
|
||||
|
||||
;;; Creating a new speedbar mode based on a pre-existing object hierarchy
|
||||
;;
|
||||
;; To create a new speedbar mode based on lists of objects is easier
|
||||
;; than creating a whole new speedbar mode from scratch.
|
||||
;;
|
||||
;; 1) Objects that will have lists of items that can be expanded
|
||||
;; should also inherit from the classes:
|
||||
;; * `eieio-speedbar' - specify your own button behavior
|
||||
;; * `eieio-speedbar-directory-button' - objects that behave like directories
|
||||
;; * `eieio-speedbar-file-button' - objects that behave like files
|
||||
;;
|
||||
;; 2) Objects that have lists of children should implement the method
|
||||
;; `eieio-speedbar-object-children' which returns a list of more
|
||||
;; objects, or a list of strings.
|
||||
;;
|
||||
;; 3) Objects that return a list of strings should also implement these
|
||||
;; methods:
|
||||
;; * `eieio-speedbar-child-make-tag-lines' - make tag lines for a child.
|
||||
;; * `eieio-speedbar-child-description' - describe non-object children
|
||||
;;
|
||||
;; 4) Objects which have expanded information should implement the method
|
||||
;; `eieio-speedbar-description' to produce more information.
|
||||
;;
|
||||
;; 5) Objects that are associated with a directory should implement
|
||||
;; the method `eieio-speedbar-derive-line-path' which returns a
|
||||
;; path.
|
||||
;;
|
||||
;; 6) Objects that have a specialized behavior when clicked should
|
||||
;; define the method `eieio-speedbar-handle-click'.
|
||||
;;
|
||||
;; To initialize a new eieio based speedbar display, do the following.
|
||||
;;
|
||||
;; 1) Create a keymap variable `foo-speedbar-key-map'.
|
||||
;; This keymap variable should be initialized in a function.
|
||||
;; If you have no special needs, use `eieio-speedbar-key-map'
|
||||
;;
|
||||
;; 2) Create a variable containing an easymenu definition compatible
|
||||
;; with speedbar. if you have no special needs, use
|
||||
;; `eieio-speedbar-menu'.
|
||||
;;
|
||||
;; 3) Create a function which returns the top-level list of children
|
||||
;; objects to be displayed in speedbar.
|
||||
;;
|
||||
;; 4) Call `eieio-speedbar-create' as specified in it's documentation
|
||||
;; string. This will automatically handle cases when speedbar is
|
||||
;; not already loaded, and specifying all overload functions.
|
||||
;;
|
||||
;; 5) Create an initliazer function which looks like this:
|
||||
;;
|
||||
;; (defun my-speedbar-mode-initilaize ()
|
||||
;; "documentation"
|
||||
;; (interactive)
|
||||
;; (speedbar-frame-mode 1)
|
||||
;; (speedbar-change-initial-expansion-list mymodename)
|
||||
;; (speedbar-get-focus))
|
||||
;;
|
||||
;; where `mymodename' is the same value as passed to `eieio-speedbar-create'
|
||||
;; as the MODENAME parameter.
|
||||
|
||||
;; @todo - Can we make this ECB friendly?
|
||||
|
||||
;;; Code:
|
||||
(require 'eieio)
|
||||
(require 'eieio-custom)
|
||||
(require 'speedbar)
|
||||
|
||||
;;; Support a way of adding generic object based modes into speedbar.
|
||||
;;
|
||||
(defun eieio-speedbar-make-map ()
|
||||
"Make the generic object based speedbar keymap."
|
||||
(let ((map (speedbar-make-specialized-keymap)))
|
||||
|
||||
;; General viewing things
|
||||
(define-key map "\C-m" 'speedbar-edit-line)
|
||||
(define-key map "+" 'speedbar-expand-line)
|
||||
(define-key map "=" 'speedbar-expand-line)
|
||||
(define-key map "-" 'speedbar-contract-line)
|
||||
|
||||
;; Some object based things
|
||||
(define-key map "C" 'eieio-speedbar-customize-line)
|
||||
map))
|
||||
|
||||
(defvar eieio-speedbar-key-map (eieio-speedbar-make-map)
|
||||
"A Generic object based speedbar display keymap.")
|
||||
|
||||
(defvar eieio-speedbar-menu
|
||||
'([ "Edit Object/Field" speedbar-edit-line t]
|
||||
[ "Expand Object" speedbar-expand-line
|
||||
(save-excursion (beginning-of-line)
|
||||
(looking-at "[0-9]+: *.\\+. "))]
|
||||
[ "Contract Object" speedbar-contract-line
|
||||
(save-excursion (beginning-of-line)
|
||||
(looking-at "[0-9]+: *.-. "))]
|
||||
"---"
|
||||
[ "Customize Object" eieio-speedbar-customize-line
|
||||
(eieio-object-p (speedbar-line-token)) ]
|
||||
)
|
||||
"Menu part in easymenu format used in speedbar while browsing objects.")
|
||||
|
||||
;; Note to self: Fix this silly thing!
|
||||
(defalias 'eieio-speedbar-customize-line 'speedbar-edit-line)
|
||||
|
||||
(defun eieio-speedbar-create (map-fn map-var menu-var modename fetcher)
|
||||
"Create a speedbar mode for displaying an object hierarchy.
|
||||
MAP-FN is the keymap generator function used for extra keys.
|
||||
MAP-VAR is the keymap variable used.
|
||||
MENU-VAR is the symbol containting an easymenu compatible menu part to use.
|
||||
MODENAME is a s tring used to identify this browser mode.
|
||||
FETCHER is a generic function used to fetch the base object list used when
|
||||
creating the speedbar display."
|
||||
(if (not (featurep 'speedbar))
|
||||
(add-hook 'speedbar-load-hook
|
||||
(list 'lambda nil
|
||||
(list 'eieio-speedbar-create-engine
|
||||
map-fn map-var menu-var modename fetcher)))
|
||||
(eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher)))
|
||||
|
||||
(defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher)
|
||||
"Create a speedbar mode for displaying an object hierarchy.
|
||||
Called from `eieio-speedbar-create', or the speedbar load-hook.
|
||||
MAP-FN, MAP-VAR, MENU-VAR, MODENAME, and FETCHER are the same as
|
||||
`eieio-speedbar-create'."
|
||||
;; make sure the keymap exists
|
||||
(funcall map-fn)
|
||||
;; Add to the expansion list.
|
||||
(speedbar-add-expansion-list
|
||||
(list modename
|
||||
menu-var
|
||||
map-var
|
||||
(list 'lambda '(dir depth)
|
||||
(list 'eieio-speedbar-buttons 'dir 'depth
|
||||
(list 'quote fetcher)))))
|
||||
;; Set the special functions.
|
||||
(speedbar-add-mode-functions-list
|
||||
(list modename
|
||||
'(speedbar-item-info . eieio-speedbar-item-info)
|
||||
'(speedbar-line-directory . eieio-speedbar-line-path))))
|
||||
|
||||
(defun eieio-speedbar-buttons (dir-or-object depth fetcher)
|
||||
"Create buttons for the speedbar display.
|
||||
Start in directory DIR-OR-OBJECT. If it is an object, just display that
|
||||
objects subelements.
|
||||
Argument DEPTH specifies how far down we have already been displayed.
|
||||
If it is a directory, use FETCHER to fetch all objects associated with
|
||||
that path."
|
||||
(let ((objlst (cond ((eieio-object-p dir-or-object)
|
||||
(list dir-or-object))
|
||||
((stringp dir-or-object)
|
||||
(funcall fetcher dir-or-object))
|
||||
(t dir-or-object))))
|
||||
(if (not objlst)
|
||||
(speedbar-make-tag-line nil nil nil nil "Empty display" nil nil nil
|
||||
depth)
|
||||
;; Dump all objects into speedbar
|
||||
(while objlst
|
||||
(eieio-speedbar-make-tag-line (car objlst) depth)
|
||||
(setq objlst (cdr objlst))))))
|
||||
|
||||
|
||||
;;; DEFAULT SUPERCLASS baseline methods
|
||||
;;
|
||||
;; First, define methods onto the superclass so all classes
|
||||
;; will have some minor support.
|
||||
|
||||
(defmethod eieio-speedbar-description ((object eieio-default-superclass))
|
||||
"Return a string describing OBJECT."
|
||||
(object-name-string object))
|
||||
|
||||
(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass))
|
||||
"Return the path which OBJECT has something to do with."
|
||||
nil)
|
||||
|
||||
(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass))
|
||||
"Return a string to use as a speedbar button for OBJECT."
|
||||
(object-name-string object))
|
||||
|
||||
(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass)
|
||||
depth)
|
||||
"Insert a tag line into speedbar at point for OBJECT.
|
||||
By default, all objects appear as simple TAGS with no need to inherit from
|
||||
the special `eieio-speedbar' classes. Child classes should redefine this
|
||||
method to create more accurate tag lines.
|
||||
Argument DEPTH is the depth at which the tag line is inserted."
|
||||
(speedbar-make-tag-line nil nil nil nil
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
'speedbar-tag-face
|
||||
depth))
|
||||
|
||||
(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass))
|
||||
"Handle a click action on OBJECT in speedbar.
|
||||
Any object can be represented as a tag in SPEEDBAR without special
|
||||
attributes. These default objects will be pulled up in a custom
|
||||
object edit buffer doing an in-place edit.
|
||||
|
||||
If your object represents some other item, override this method
|
||||
and take the apropriate action."
|
||||
(require 'eieio-custom)
|
||||
(speedbar-with-attached-buffer
|
||||
(eieio-customize-object object))
|
||||
(speedbar-maybee-jump-to-attached-frame))
|
||||
|
||||
|
||||
;;; Class definitions
|
||||
;;
|
||||
;; Now define a special speedbar class with some
|
||||
;; variables with :allocation class which can be attached into
|
||||
;; object hierarchies.
|
||||
;;
|
||||
;; These more complex types are for objects which wish to display
|
||||
;; lists of children buttons.
|
||||
|
||||
(defclass eieio-speedbar nil
|
||||
((buttontype :initform nil
|
||||
:type symbol
|
||||
:documentation
|
||||
"The type of expansion button used for objects of this class.
|
||||
Possible values are those symbols supported by the `exp-button-type' argument
|
||||
to `speedbar-make-tag-line'."
|
||||
:allocation :class)
|
||||
(buttonface :initform speedbar-tag-face
|
||||
:type (or symbol face)
|
||||
:documentation
|
||||
"The face used on the textual part of the button for this class.
|
||||
See `speedbar-make-tag-line' for details."
|
||||
:allocation :class)
|
||||
(expanded :initform nil
|
||||
:type boolean
|
||||
:documentation
|
||||
"State of an object being expanded in speedbar.")
|
||||
)
|
||||
"Class which provides basic speedbar support for child classes.
|
||||
Add one of thie child classes to this class to the parent list of a class."
|
||||
:method-invocation-order :depth-first
|
||||
:abstract t)
|
||||
|
||||
(defclass eieio-speedbar-directory-button (eieio-speedbar)
|
||||
((buttontype :initform angle)
|
||||
(buttonface :initform speedbar-directory-face))
|
||||
"Class providing support for objects which behave like a directory."
|
||||
:method-invocation-order :depth-first
|
||||
:abstract t)
|
||||
|
||||
(defclass eieio-speedbar-file-button (eieio-speedbar)
|
||||
((buttontype :initform bracket)
|
||||
(buttonface :initform speedbar-file-face))
|
||||
"Class providing support for objects which behave like a directory."
|
||||
:method-invocation-order :depth-first
|
||||
:abstract t)
|
||||
|
||||
|
||||
;;; Methods to eieio-speedbar-* which do not need to be overriden
|
||||
;;
|
||||
(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar)
|
||||
depth)
|
||||
"Insert a tag line into speedbar at point for OBJECT.
|
||||
All objects a child of symbol `eieio-speedbar' can be created from this
|
||||
method. Override this if you need non-traditional tag lines.
|
||||
Argument DEPTH is the depth at which the tag line is inserted."
|
||||
(let ((children (eieio-speedbar-object-children object))
|
||||
(exp (oref object expanded)))
|
||||
(if (not children)
|
||||
(if (eq (oref object buttontype) 'expandtag)
|
||||
(speedbar-make-tag-line 'statictag
|
||||
? nil nil
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
(oref object buttonface)
|
||||
depth)
|
||||
(speedbar-make-tag-line (oref object buttontype)
|
||||
? nil nil
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
(oref object buttonface)
|
||||
depth))
|
||||
(speedbar-make-tag-line (oref object buttontype)
|
||||
(if exp ?- ?+)
|
||||
'eieio-speedbar-object-expand
|
||||
object
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
(oref object buttonface)
|
||||
depth)
|
||||
(if exp
|
||||
(eieio-speedbar-expand object (1+ depth))))))
|
||||
|
||||
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth)
|
||||
"Base method for creating tag lines for non-object children."
|
||||
(error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
|
||||
(object-name object)))
|
||||
|
||||
(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
|
||||
"Expand OBJECT at indentation DEPTH.
|
||||
Inserts a list of new tag lines representing expanded elements withing
|
||||
OBJECT."
|
||||
(let ((children (eieio-speedbar-object-children object)))
|
||||
(cond ((eieio-object-p (car children))
|
||||
(mapcar (lambda (car)
|
||||
(eieio-speedbar-make-tag-line car depth))
|
||||
children))
|
||||
(children (eieio-speedbar-child-make-tag-lines object depth)))))
|
||||
|
||||
|
||||
;;; Speedbar specific function callbacks.
|
||||
;;
|
||||
(defun eieio-speedbar-object-click (text token indent)
|
||||
"Handle a user click on TEXT representing object TOKEN.
|
||||
The object is at indentation level INDENT."
|
||||
(eieio-speedbar-handle-click token))
|
||||
|
||||
(defun eieio-speedbar-object-expand (text token indent)
|
||||
"Expand object represented by TEXT. TOKEN is the object.
|
||||
INDENT is the current indentation level."
|
||||
(cond ((string-match "+" text) ;we have to expand this file
|
||||
(speedbar-change-expand-button-char ?-)
|
||||
(oset token expanded t)
|
||||
(speedbar-with-writable
|
||||
(save-excursion
|
||||
(end-of-line) (forward-char 1)
|
||||
(eieio-speedbar-expand token (1+ indent)))))
|
||||
((string-match "-" text) ;we have to contract this node
|
||||
(speedbar-change-expand-button-char ?+)
|
||||
(oset token expanded nil)
|
||||
(speedbar-delete-subblock indent))
|
||||
(t (error "Ooops... not sure what to do")))
|
||||
(speedbar-center-buffer-smartly))
|
||||
|
||||
(defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
|
||||
"Return a description for a child of OBJ which is not an object."
|
||||
(error "You must implement `eieio-speedbar-child-description' for %s"
|
||||
(object-name obj)))
|
||||
|
||||
(defun eieio-speedbar-item-info ()
|
||||
"Display info for the current line when in EDE display mode."
|
||||
;; Switch across the types of the tokens.
|
||||
(let ((tok (speedbar-line-token)))
|
||||
(cond ((eieio-object-p tok)
|
||||
(message (eieio-speedbar-description tok)))
|
||||
(t
|
||||
(let ((no (eieio-speedbar-find-nearest-object)))
|
||||
(if no
|
||||
(eieio-speedbar-child-description no)))))))
|
||||
|
||||
(defun eieio-speedbar-find-nearest-object (&optional depth)
|
||||
"Search backwards to the first line associated with an object.
|
||||
Optional argument DEPTH is the current depth of the search."
|
||||
(save-excursion
|
||||
(if (not depth)
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
(when (looking-at "^\\([0-9]+\\):")
|
||||
(setq depth (string-to-number (match-string 1))))))
|
||||
(when depth
|
||||
(while (and (not (eieio-object-p (speedbar-line-token)))
|
||||
(> depth 0))
|
||||
(setq depth (1- depth))
|
||||
(re-search-backward (format "^%d:" depth) nil t))
|
||||
(speedbar-line-token))))
|
||||
|
||||
(defun eieio-speedbar-line-path (&optional depth)
|
||||
"If applicable, return the path to the file the cursor is on.
|
||||
Optional DEPTH is the depth we start at."
|
||||
(save-match-data
|
||||
(if (not depth)
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
(looking-at "^\\([0-9]+\\):")
|
||||
(setq depth (string-to-number (match-string 1)))))
|
||||
;; This whole function is presently bogus. Make it better later.
|
||||
(let ((tok (eieio-speedbar-find-nearest-object depth)))
|
||||
(if (eieio-object-p tok)
|
||||
(eieio-speedbar-derive-line-path tok)
|
||||
default-directory))))
|
||||
|
||||
|
||||
;;; Methods to the eieio-speedbar-* classes which need to be overriden.
|
||||
;;
|
||||
(defmethod eieio-speedbar-object-children ((object eieio-speedbar))
|
||||
"Return a list of children to be displayed in SPEEDBAR.
|
||||
If the return value is a list of OBJECTs, then those objects are
|
||||
queried for details. If the return list is made of strings,
|
||||
then this object will be queried for the details needed
|
||||
to create a speedbar button."
|
||||
nil)
|
||||
|
||||
(provide 'eieio-speedbar)
|
||||
|
||||
;;; eieio-speedbar.el ends here
|
||||
2788
lisp/emacs-lisp/eieio.el
Normal file
2788
lisp/emacs-lisp/eieio.el
Normal file
File diff suppressed because it is too large
Load diff
Loading…
Add table
Reference in a new issue