Commit | Line | Data |
---|---|---|
6dd12ef2 CY |
1 | ;;; eieio-base.el --- Base classes for EIEIO. |
2 | ||
114f9c96 | 3 | ;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009, 2010 |
6dd12ef2 CY |
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. | |
a8f316ca | 45 | If a slot of this class is referenced, and is unbound, then the parent |
6dd12ef2 CY |
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. | |
a8f316ca | 56 | SLOT-NAME is the offending slot. FN is the function signalling the error." |
6dd12ef2 CY |
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) | |
a8f316ca JB |
88 | "Return non-nil if the instance inheritor OBJECT's SLOT is bound. |
89 | See `slot-boundp' for details on binding slots. | |
90 | The instance inheritor uses unbound slots as a way of cascading cloned | |
6dd12ef2 CY |
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 | \f | |
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. | |
d1f18ec0 | 153 | A singleton is a class which will only ever have one instance." |
6dd12ef2 CY |
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 | \f | |
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) | |
a8f316ca | 216 | "Prepare to save THIS. Use in an `interactive' statement. |
6dd12ef2 CY |
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 | |
9a529312 | 233 | (with-current-buffer (get-buffer-create " *tmp eieio read*") |
6dd12ef2 CY |
234 | (insert-file-contents filename nil nil nil t) |
235 | (goto-char (point-min)) | |
236 | (setq buffstr (buffer-string))) | |
237 | ;; Do the read in the buffer the read was initialized from | |
238 | ;; so that any initialize-instance calls that depend on | |
239 | ;; the current buffer will work. | |
240 | (setq ret (read buffstr)) | |
241 | (if (not (child-of-class-p (car ret) 'eieio-persistent)) | |
242 | (error "Corrupt object on disk")) | |
243 | (setq ret (eval ret)) | |
244 | (oset ret file filename)) | |
245 | (kill-buffer " *tmp eieio read*")) | |
246 | ret)) | |
247 | ||
248 | (defmethod object-write ((this eieio-persistent) &optional comment) | |
249 | "Write persistent object THIS out to the current stream. | |
250 | Optional argument COMMENT is a header line comment." | |
251 | (call-next-method this (or comment (oref this file-header-line)))) | |
252 | ||
253 | (defmethod eieio-persistent-path-relative ((this eieio-persistent) file) | |
254 | "For object THIS, make absolute file name FILE relative." | |
255 | (file-relative-name (expand-file-name file) | |
256 | (file-name-directory (oref this file)))) | |
257 | ||
258 | (defmethod eieio-persistent-save ((this eieio-persistent) &optional file) | |
259 | "Save persistent object THIS to disk. | |
260 | Optional argument FILE overrides the file name specified in the object | |
261 | instance." | |
262 | (save-excursion | |
263 | (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) | |
264 | (default-directory (file-name-directory (oref this file))) | |
265 | (cfn (oref this file))) | |
266 | (unwind-protect | |
267 | (save-excursion | |
268 | (erase-buffer) | |
269 | (let ((standard-output (current-buffer))) | |
270 | (oset this file | |
271 | (if file | |
272 | (eieio-persistent-path-relative this file) | |
273 | (file-name-nondirectory cfn))) | |
274 | (object-write this (oref this file-header-line))) | |
67d3ffe4 CY |
275 | (let ((backup-inhibited (not (oref this do-backups))) |
276 | (cs (car (find-coding-systems-region | |
277 | (point-min) (point-max))))) | |
278 | (unless (eq cs 'undecided) | |
279 | (setq buffer-file-coding-system cs)) | |
6dd12ef2 CY |
280 | ;; Old way - write file. Leaves message behind. |
281 | ;;(write-file cfn nil) | |
282 | ||
283 | ;; New way - Avoid the vast quantities of error checking | |
284 | ;; just so I can get at the special flags that disable | |
285 | ;; displaying random messages. | |
286 | (write-region (point-min) (point-max) | |
287 | cfn nil 1) | |
288 | )) | |
289 | ;; Restore :file, and kill the tmp buffer | |
290 | (oset this file cfn) | |
291 | (setq buffer-file-name nil) | |
292 | (kill-buffer b))))) | |
293 | ||
294 | ;; Notes on the persistent object: | |
295 | ;; It should also set up some hooks to help it keep itself up to date. | |
296 | ||
297 | \f | |
298 | ;;; Named object | |
299 | ;; | |
300 | ;; Named objects use the objects `name' as a slot, and that slot | |
301 | ;; is accessed with the `object-name' symbol. | |
302 | ||
303 | (defclass eieio-named () | |
304 | () | |
305 | "Object with a name. | |
306 | Name storage already occurs in an object. This object provides get/set | |
307 | access to it." | |
308 | :abstract t) | |
309 | ||
310 | (defmethod slot-missing ((obj eieio-named) | |
311 | slot-name operation &optional new-value) | |
d1f18ec0 | 312 | "Called when a non-existent slot is accessed. |
6dd12ef2 | 313 | For variable `eieio-named', provide an imaginary `object-name' slot. |
a8f316ca | 314 | Argument OBJ is the named object. |
6dd12ef2 CY |
315 | Argument SLOT-NAME is the slot that was attempted to be accessed. |
316 | OPERATION is the type of access, such as `oref' or `oset'. | |
317 | NEW-VALUE is the value that was being set into SLOT if OPERATION were | |
318 | a set type." | |
319 | (if (or (eq slot-name 'object-name) | |
320 | (eq slot-name :object-name)) | |
321 | (cond ((eq operation 'oset) | |
322 | (if (not (stringp new-value)) | |
323 | (signal 'invalid-slot-type | |
324 | (list obj slot-name 'string new-value))) | |
325 | (object-set-name-string obj new-value)) | |
326 | (t (object-name-string obj))) | |
327 | (call-next-method))) | |
328 | ||
329 | (provide 'eieio-base) | |
330 | ||
3999968a | 331 | ;; arch-tag: 6260571e-9e8a-41a0-880f-a937b0c2ea8b |
6dd12ef2 | 332 | ;;; eieio-base.el ends here |