diff options
| author | Chong Yidong | 2009-08-30 02:04:33 +0000 |
|---|---|---|
| committer | Chong Yidong | 2009-08-30 02:04:33 +0000 |
| commit | 55d99fe08fdb642fe1737dd011dd88dbff915d10 (patch) | |
| tree | f72edfd08ad65bb9fac70cced726130fa8948ba5 | |
| parent | 71dd0880452ff8cc1019e99531192424df26a708 (diff) | |
| download | emacs-55d99fe08fdb642fe1737dd011dd88dbff915d10.tar.gz emacs-55d99fe08fdb642fe1737dd011dd88dbff915d10.zip | |
Directory eieio removed.
| -rw-r--r-- | lisp/eieio/eieio-base.el | 328 |
1 files changed, 0 insertions, 328 deletions
diff --git a/lisp/eieio/eieio-base.el b/lisp/eieio/eieio-base.el deleted file mode 100644 index 6bd09a778c3..00000000000 --- a/lisp/eieio/eieio-base.el +++ /dev/null | |||
| @@ -1,328 +0,0 @@ | |||
| 1 | ;;; eieio-base.el --- Base classes for EIEIO. | ||
| 2 | |||
| 3 | ;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009 | ||
| 4 | ;;; Free Software Foundation, Inc. | ||
| 5 | |||
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 7 | ;; Version: 0.2 | ||
| 8 | ;; Keywords: OO, lisp | ||
| 9 | |||
| 10 | ;; This file is part of GNU Emacs. | ||
| 11 | |||
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 13 | ;; it under the terms of the GNU General Public License as published by | ||
| 14 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 15 | ;; (at your option) any later version. | ||
| 16 | |||
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 20 | ;; GNU General Public License for more details. | ||
| 21 | |||
| 22 | ;; You should have received a copy of the GNU General Public License | ||
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 24 | |||
| 25 | ;;; Commentary: | ||
| 26 | ;; | ||
| 27 | ;; Base classes for EIEIO. These classes perform some basic tasks | ||
| 28 | ;; but are generally useless on their own. To use any of these classes, | ||
| 29 | ;; inherit from one or more of them. | ||
| 30 | |||
| 31 | ;;; Code: | ||
| 32 | |||
| 33 | (require 'eieio) | ||
| 34 | |||
| 35 | ;;; eieio-instance-inheritor | ||
| 36 | ;; | ||
| 37 | ;; Enable instance inheritance via the `clone' method. | ||
| 38 | ;; Works by using the `slot-unbound' method which usually throws an | ||
| 39 | ;; error if a slot is unbound. | ||
| 40 | (defclass eieio-instance-inheritor () | ||
| 41 | ((parent-instance :initarg :parent-instance | ||
| 42 | :type eieio-instance-inheritor-child | ||
| 43 | :documentation | ||
| 44 | "The parent of this instance. | ||
| 45 | If a slot of this class is reference, and is unbound, then the parent | ||
| 46 | is checked for a value.") | ||
| 47 | ) | ||
| 48 | "This special class can enable instance inheritance. | ||
| 49 | Use `clone' to make a new object that does instance inheritance from | ||
| 50 | a parent instance. When a slot in the child is referenced, and has | ||
| 51 | not been set, use values from the parent." | ||
| 52 | :abstract t) | ||
| 53 | |||
| 54 | (defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn) | ||
| 55 | "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. | ||
| 56 | SLOT-NAME, is the offending slot. FN is the function signalling the error." | ||
| 57 | (if (slot-boundp object 'parent-instance) | ||
| 58 | ;; It may not look like it, but this line recurses back into this | ||
| 59 | ;; method if the parent instance's slot is unbound. | ||
| 60 | (eieio-oref (oref object parent-instance) slot-name) | ||
| 61 | ;; Throw the regular signal. | ||
| 62 | (call-next-method))) | ||
| 63 | |||
| 64 | (defmethod clone ((obj eieio-instance-inheritor) &rest params) | ||
| 65 | "Clone OBJ, initializing `:parent' to OBJ. | ||
| 66 | All slots are unbound, except those initialized with PARAMS." | ||
| 67 | (let ((nobj (make-vector (length obj) eieio-unbound)) | ||
| 68 | (nm (aref obj object-name)) | ||
| 69 | (passname (and params (stringp (car params)))) | ||
| 70 | (num 1)) | ||
| 71 | (aset nobj 0 'object) | ||
| 72 | (aset nobj object-class (aref obj object-class)) | ||
| 73 | ;; The following was copied from the default clone. | ||
| 74 | (if (not passname) | ||
| 75 | (save-match-data | ||
| 76 | (if (string-match "-\\([0-9]+\\)" nm) | ||
| 77 | (setq num (1+ (string-to-number (match-string 1 nm))) | ||
| 78 | nm (substring nm 0 (match-beginning 0)))) | ||
| 79 | (aset nobj object-name (concat nm "-" (int-to-string num)))) | ||
| 80 | (aset nobj object-name (car params))) | ||
| 81 | ;; Now initialize from params. | ||
| 82 | (if params (shared-initialize nobj (if passname (cdr params) params))) | ||
| 83 | (oset nobj parent-instance obj) | ||
| 84 | nobj)) | ||
| 85 | |||
| 86 | (defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) | ||
| 87 | slot) | ||
| 88 | "Non-nil if the instance inheritor OBJECT's SLOT is bound. | ||
| 89 | See `slot-boundp' for for details on binding slots. | ||
| 90 | The instance inheritor uses unbound slots as a way cascading cloned | ||
| 91 | slot values, so testing for a slot being bound requires extra steps | ||
| 92 | for this kind of object." | ||
| 93 | (if (slot-boundp object slot) | ||
| 94 | ;; If it is regularly bound, return t. | ||
| 95 | t | ||
| 96 | (if (slot-boundp object 'parent-instance) | ||
| 97 | (eieio-instance-inheritor-slot-boundp (oref object parent-instance) | ||
| 98 | slot) | ||
| 99 | nil))) | ||
| 100 | |||
| 101 | |||
| 102 | ;;; eieio-instance-tracker | ||
| 103 | ;; | ||
| 104 | ;; Track all created instances of this class. | ||
| 105 | ;; The class must initialize the `tracking-symbol' slot, and that | ||
| 106 | ;; symbol is then used to contain these objects. | ||
| 107 | (defclass eieio-instance-tracker () | ||
| 108 | ((tracking-symbol :type symbol | ||
| 109 | :allocation :class | ||
| 110 | :documentation | ||
| 111 | "The symbol used to maintain a list of our instances. | ||
| 112 | The instance list is treated as a variable, with new instances added to it.") | ||
| 113 | ) | ||
| 114 | "This special class enables instance tracking. | ||
| 115 | Inheritors from this class must overload `tracking-symbol' which is | ||
| 116 | a variable symbol used to store a list of all instances." | ||
| 117 | :abstract t) | ||
| 118 | |||
| 119 | (defmethod initialize-instance :AFTER ((this eieio-instance-tracker) | ||
| 120 | &rest slots) | ||
| 121 | "Make sure THIS is in our master list of this class. | ||
| 122 | Optional argument SLOTS are the initialization arguments." | ||
| 123 | ;; Theoretically, this is never called twice for a given instance. | ||
| 124 | (let ((sym (oref this tracking-symbol))) | ||
| 125 | (if (not (memq this (symbol-value sym))) | ||
| 126 | (set sym (append (symbol-value sym) (list this)))))) | ||
| 127 | |||
| 128 | (defmethod delete-instance ((this eieio-instance-tracker)) | ||
| 129 | "Remove THIS from the master list of this class." | ||
| 130 | (set (oref this tracking-symbol) | ||
| 131 | (delq this (symbol-value (oref this tracking-symbol))))) | ||
| 132 | |||
| 133 | ;; In retrospect, this is a silly function. | ||
| 134 | (defun eieio-instance-tracker-find (key slot list-symbol) | ||
| 135 | "Find KEY as an element of SLOT in the objects in LIST-SYMBOL. | ||
| 136 | Returns the first match." | ||
| 137 | (object-assoc key slot (symbol-value list-symbol))) | ||
| 138 | |||
| 139 | ;;; eieio-singleton | ||
| 140 | ;; | ||
| 141 | ;; The singleton Design Pattern specifies that there is but one object | ||
| 142 | ;; of a given class ever created. The EIEIO singleton base class defines | ||
| 143 | ;; a CLASS allocated slot which contains the instance used. All calls to | ||
| 144 | ;; `make-instance' will either create a new instance and store it in this | ||
| 145 | ;; slot, or it will just return what is there. | ||
| 146 | (defclass eieio-singleton () | ||
| 147 | ((singleton :type eieio-singleton | ||
| 148 | :allocation :class | ||
| 149 | :documentation | ||
| 150 | "The only instance of this class that will be instantiated. | ||
| 151 | Multiple calls to `make-instance' will return this object.")) | ||
| 152 | "This special class causes subclasses to be singletons. | ||
| 153 | A singleton is a class which will only ever have one instace." | ||
| 154 | :abstract t) | ||
| 155 | |||
| 156 | (defmethod constructor :STATIC ((class eieio-singleton) name &rest slots) | ||
| 157 | "Constructor for singleton CLASS. | ||
| 158 | NAME and SLOTS initialize the new object. | ||
| 159 | This constructor guarantees that no matter how many you request, | ||
| 160 | only one object ever exists." | ||
| 161 | ;; NOTE TO SELF: In next version, make `slot-boundp' support classes | ||
| 162 | ;; with class allocated slots or default values. | ||
| 163 | (let ((old (oref-default class singleton))) | ||
| 164 | (if (eq old eieio-unbound) | ||
| 165 | (oset-default class singleton (call-next-method)) | ||
| 166 | old))) | ||
| 167 | |||
| 168 | |||
| 169 | ;;; eieio-persistent | ||
| 170 | ;; | ||
| 171 | ;; For objects which must save themselves to disk. Provides an | ||
| 172 | ;; `object-write' method to save an object to disk, and a | ||
| 173 | ;; `eieio-persistent-read' function to call to read an object | ||
| 174 | ;; from disk. | ||
| 175 | ;; | ||
| 176 | ;; Also provide the method `eieio-persistent-path-relative' to | ||
| 177 | ;; calculate path names relative to a given instance. This will | ||
| 178 | ;; make the saved object location independent by converting all file | ||
| 179 | ;; references to be relative to the directory the object is saved to. | ||
| 180 | ;; You must call `eieio-peristent-path-relative' on each file name | ||
| 181 | ;; saved in your object. | ||
| 182 | (defclass eieio-persistent () | ||
| 183 | ((file :initarg :file | ||
| 184 | :type string | ||
| 185 | :documentation | ||
| 186 | "The save file for this persistent object. | ||
| 187 | This must be a string, and must be specified when the new object is | ||
| 188 | instantiated.") | ||
| 189 | (extension :type string | ||
| 190 | :allocation :class | ||
| 191 | :initform ".eieio" | ||
| 192 | :documentation | ||
| 193 | "Extension of files saved by this object. | ||
| 194 | Enables auto-choosing nice file names based on name.") | ||
| 195 | (file-header-line :type string | ||
| 196 | :allocation :class | ||
| 197 | :initform ";; EIEIO PERSISTENT OBJECT" | ||
| 198 | :documentation | ||
| 199 | "Header line for the save file. | ||
| 200 | This is used with the `object-write' method.") | ||
| 201 | (do-backups :type boolean | ||
| 202 | :allocation :class | ||
| 203 | :initform t | ||
| 204 | :documentation | ||
| 205 | "Saving this object should make backup files. | ||
| 206 | Setting to nil will mean no backups are made.")) | ||
| 207 | "This special class enables persistence through save files | ||
| 208 | Use the `object-save' method to write this object to disk. The save | ||
| 209 | format is Emacs Lisp code which calls the constructor for the saved | ||
| 210 | object. For this reason, only slots which do not have an `:initarg' | ||
| 211 | specified will not be saved." | ||
| 212 | :abstract t) | ||
| 213 | |||
| 214 | (defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt | ||
| 215 | &optional name) | ||
| 216 | "Perpare to save THIS. Use in an `interactive' statement. | ||
| 217 | Query user for file name with PROMPT if THIS does not yet specify | ||
| 218 | a file. Optional argument NAME specifies a default file name." | ||
| 219 | (unless (slot-boundp this 'file) | ||
| 220 | (oset this file | ||
| 221 | (read-file-name prompt nil | ||
| 222 | (if name | ||
| 223 | (concat name (oref this extension)) | ||
| 224 | )))) | ||
| 225 | (oref this file)) | ||
| 226 | |||
| 227 | (defun eieio-persistent-read (filename) | ||
| 228 | "Read a persistent object from FILENAME, and return it." | ||
| 229 | (let ((ret nil) | ||
| 230 | (buffstr nil)) | ||
| 231 | (unwind-protect | ||
| 232 | (progn | ||
| 233 | (save-excursion | ||
| 234 | (set-buffer (get-buffer-create " *tmp eieio read*")) | ||
| 235 | (insert-file-contents filename nil nil nil t) | ||
| 236 | (goto-char (point-min)) | ||
| 237 | (setq buffstr (buffer-string))) | ||
| 238 | ;; Do the read in the buffer the read was initialized from | ||
| 239 | ;; so that any initialize-instance calls that depend on | ||
| 240 | ;; the current buffer will work. | ||
| 241 | (setq ret (read buffstr)) | ||
| 242 | (if (not (child-of-class-p (car ret) 'eieio-persistent)) | ||
| 243 | (error "Corrupt object on disk")) | ||
| 244 | (setq ret (eval ret)) | ||
| 245 | (oset ret file filename)) | ||
| 246 | (kill-buffer " *tmp eieio read*")) | ||
| 247 | ret)) | ||
| 248 | |||
| 249 | (defmethod object-write ((this eieio-persistent) &optional comment) | ||
| 250 | "Write persistent object THIS out to the current stream. | ||
| 251 | Optional argument COMMENT is a header line comment." | ||
| 252 | (call-next-method this (or comment (oref this file-header-line)))) | ||
| 253 | |||
| 254 | (defmethod eieio-persistent-path-relative ((this eieio-persistent) file) | ||
| 255 | "For object THIS, make absolute file name FILE relative." | ||
| 256 | (file-relative-name (expand-file-name file) | ||
| 257 | (file-name-directory (oref this file)))) | ||
| 258 | |||
| 259 | (defmethod eieio-persistent-save ((this eieio-persistent) &optional file) | ||
| 260 | "Save persistent object THIS to disk. | ||
| 261 | Optional argument FILE overrides the file name specified in the object | ||
| 262 | instance." | ||
| 263 | (save-excursion | ||
| 264 | (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) | ||
| 265 | (default-directory (file-name-directory (oref this file))) | ||
| 266 | (cfn (oref this file))) | ||
| 267 | (unwind-protect | ||
| 268 | (save-excursion | ||
| 269 | (erase-buffer) | ||
| 270 | (let ((standard-output (current-buffer))) | ||
| 271 | (oset this file | ||
| 272 | (if file | ||
| 273 | (eieio-persistent-path-relative this file) | ||
| 274 | (file-name-nondirectory cfn))) | ||
| 275 | (object-write this (oref this file-header-line))) | ||
| 276 | (let ((backup-inhibited (not (oref this do-backups)))) | ||
| 277 | ;; Old way - write file. Leaves message behind. | ||
| 278 | ;;(write-file cfn nil) | ||
| 279 | |||
| 280 | ;; New way - Avoid the vast quantities of error checking | ||
| 281 | ;; just so I can get at the special flags that disable | ||
| 282 | ;; displaying random messages. | ||
| 283 | (write-region (point-min) (point-max) | ||
| 284 | cfn nil 1) | ||
| 285 | )) | ||
| 286 | ;; Restore :file, and kill the tmp buffer | ||
| 287 | (oset this file cfn) | ||
| 288 | (setq buffer-file-name nil) | ||
| 289 | (kill-buffer b))))) | ||
| 290 | |||
| 291 | ;; Notes on the persistent object: | ||
| 292 | ;; It should also set up some hooks to help it keep itself up to date. | ||
| 293 | |||
| 294 | |||
| 295 | ;;; Named object | ||
| 296 | ;; | ||
| 297 | ;; Named objects use the objects `name' as a slot, and that slot | ||
| 298 | ;; is accessed with the `object-name' symbol. | ||
| 299 | |||
| 300 | (defclass eieio-named () | ||
| 301 | () | ||
| 302 | "Object with a name. | ||
| 303 | Name storage already occurs in an object. This object provides get/set | ||
| 304 | access to it." | ||
| 305 | :abstract t) | ||
| 306 | |||
| 307 | (defmethod slot-missing ((obj eieio-named) | ||
| 308 | slot-name operation &optional new-value) | ||
| 309 | "Called when a on-existant slot is accessed. | ||
| 310 | For variable `eieio-named', provide an imaginary `object-name' slot. | ||
| 311 | Argument OBJ is the Named object. | ||
| 312 | Argument SLOT-NAME is the slot that was attempted to be accessed. | ||
| 313 | OPERATION is the type of access, such as `oref' or `oset'. | ||
| 314 | NEW-VALUE is the value that was being set into SLOT if OPERATION were | ||
| 315 | a set type." | ||
| 316 | (if (or (eq slot-name 'object-name) | ||
| 317 | (eq slot-name :object-name)) | ||
| 318 | (cond ((eq operation 'oset) | ||
| 319 | (if (not (stringp new-value)) | ||
| 320 | (signal 'invalid-slot-type | ||
| 321 | (list obj slot-name 'string new-value))) | ||
| 322 | (object-set-name-string obj new-value)) | ||
| 323 | (t (object-name-string obj))) | ||
| 324 | (call-next-method))) | ||
| 325 | |||
| 326 | (provide 'eieio-base) | ||
| 327 | |||
| 328 | ;;; eieio-base.el ends here | ||