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