Commit | Line | Data |
---|---|---|
6dd12ef2 CY |
1 | ;;; eieio-base.el --- Base classes for EIEIO. |
2 | ||
ab422c4d PE |
3 | ;;; Copyright (C) 2000-2002, 2004-2005, 2007-2013 Free Software |
4 | ;;; Foundation, Inc. | |
6dd12ef2 CY |
5 | |
6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
6dd12ef2 | 7 | ;; Keywords: OO, lisp |
bd78fa1d | 8 | ;; Package: eieio |
6dd12ef2 CY |
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. | |
8350f087 | 56 | SLOT-NAME is the offending slot. FN is the function signaling 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. | |
e1dbe924 | 180 | ;; You must call `eieio-persistent-path-relative' on each file name |
6dd12ef2 CY |
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 | ||
62a81506 CY |
227 | (defun eieio-persistent-read (filename &optional class allow-subclass) |
228 | "Read a persistent object from FILENAME, and return it. | |
229 | Signal an error if the object in FILENAME is not a constructor | |
230 | for CLASS. Optional ALLOW-SUBCLASS says that it is ok for | |
735135f9 PE |
231 | `eieio-persistent-read' to load in subclasses of class instead of |
232 | being pedantic." | |
62a81506 CY |
233 | (unless class |
234 | (message "Unsafe call to `eieio-persistent-read'.")) | |
235 | (when (and class (not (class-p class))) | |
236 | (signal 'wrong-type-argument (list 'class-p class))) | |
6dd12ef2 CY |
237 | (let ((ret nil) |
238 | (buffstr nil)) | |
239 | (unwind-protect | |
240 | (progn | |
9a529312 | 241 | (with-current-buffer (get-buffer-create " *tmp eieio read*") |
6dd12ef2 CY |
242 | (insert-file-contents filename nil nil nil t) |
243 | (goto-char (point-min)) | |
244 | (setq buffstr (buffer-string))) | |
245 | ;; Do the read in the buffer the read was initialized from | |
246 | ;; so that any initialize-instance calls that depend on | |
247 | ;; the current buffer will work. | |
248 | (setq ret (read buffstr)) | |
62a81506 CY |
249 | (when (not (child-of-class-p (car ret) 'eieio-persistent)) |
250 | (error "Corrupt object on disk: Unknown saved object")) | |
251 | (when (and class | |
252 | (not (or (eq (car ret) class ) ; same class | |
253 | (and allow-subclass | |
254 | (child-of-class-p (car ret) class)) ; subclasses | |
255 | ))) | |
256 | (error "Corrupt object on disk: Invalid saved class")) | |
257 | (setq ret (eieio-persistent-convert-list-to-object ret)) | |
6dd12ef2 CY |
258 | (oset ret file filename)) |
259 | (kill-buffer " *tmp eieio read*")) | |
260 | ret)) | |
261 | ||
62a81506 CY |
262 | (defun eieio-persistent-convert-list-to-object (inputlist) |
263 | "Convert the INPUTLIST, representing object creation to an object. | |
264 | While it is possible to just `eval' the INPUTLIST, this code instead | |
265 | validates the existing list, and explicitly creates objects instead of | |
266 | calling eval. This avoids the possibility of accidentally running | |
267 | malicious code. | |
268 | ||
269 | Note: This function recurses when a slot of :type of some object is | |
270 | identified, and needing more object creation." | |
271 | (let ((objclass (nth 0 inputlist)) | |
272 | (objname (nth 1 inputlist)) | |
273 | (slots (nthcdr 2 inputlist)) | |
274 | (createslots nil)) | |
275 | ||
276 | ;; If OBJCLASS is an eieio autoload object, then we need to load it. | |
277 | (eieio-class-un-autoload objclass) | |
278 | ||
279 | (while slots | |
280 | (let ((name (car slots)) | |
281 | (value (car (cdr slots)))) | |
282 | ||
283 | ;; Make sure that the value proposed for SLOT is valid. | |
284 | ;; In addition, strip out quotes, list functions, and update | |
285 | ;; object constructors as needed. | |
286 | (setq value (eieio-persistent-validate/fix-slot-value | |
287 | objclass name value)) | |
288 | ||
289 | (push name createslots) | |
290 | (push value createslots) | |
291 | ) | |
292 | ||
293 | (setq slots (cdr (cdr slots)))) | |
294 | ||
295 | (apply 'make-instance objclass objname (nreverse createslots)) | |
296 | ||
297 | ;;(eval inputlist) | |
298 | )) | |
299 | ||
300 | (defun eieio-persistent-validate/fix-slot-value (class slot proposed-value) | |
301 | "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix. | |
302 | A limited number of functions, such as quote, list, and valid object | |
303 | constructor functions are considered valid. | |
735135f9 | 304 | Second, any text properties will be stripped from strings." |
62a81506 CY |
305 | (cond ((consp proposed-value) |
306 | ;; Lists with something in them need special treatment. | |
307 | (let ((slot-idx (eieio-slot-name-index class nil slot)) | |
308 | (type nil) | |
309 | (classtype nil)) | |
310 | (setq slot-idx (- slot-idx 3)) | |
311 | (setq type (aref (aref (class-v class) class-public-type) | |
312 | slot-idx)) | |
313 | ||
314 | (setq classtype (eieio-persistent-slot-type-is-class-p | |
315 | type)) | |
316 | ||
317 | (cond ((eq (car proposed-value) 'quote) | |
318 | (car (cdr proposed-value))) | |
319 | ||
320 | ;; An empty list sometimes shows up as (list), which is dumb, but | |
321 | ;; we need to support it for backward compat. | |
322 | ((and (eq (car proposed-value) 'list) | |
323 | (= (length proposed-value) 1)) | |
324 | nil) | |
325 | ||
326 | ;; We have a slot with a single object that can be | |
327 | ;; saved here. Recurse and evaluate that | |
328 | ;; sub-object. | |
329 | ((and classtype (class-p classtype) | |
330 | (child-of-class-p (car proposed-value) classtype)) | |
331 | (eieio-persistent-convert-list-to-object | |
332 | proposed-value)) | |
333 | ||
334 | ;; List of object constructors. | |
335 | ((and (eq (car proposed-value) 'list) | |
336 | ;; 2nd item is a list. | |
337 | (consp (car (cdr proposed-value))) | |
338 | ;; 1st elt of 2nd item is a class name. | |
339 | (class-p (car (car (cdr proposed-value)))) | |
340 | ) | |
341 | ||
342 | ;; Check the value against the input class type. | |
343 | ;; If something goes wrong, issue a smart warning | |
344 | ;; about how a :type is needed for this to work. | |
345 | (unless (and | |
346 | ;; Do we have a type? | |
347 | (consp classtype) (class-p (car classtype))) | |
348 | (error "In save file, list of object constructors found, but no :type specified for slot %S" | |
349 | slot)) | |
350 | ||
351 | ;; We have a predicate, but it doesn't satisfy the predicate? | |
352 | (dolist (PV (cdr proposed-value)) | |
353 | (unless (child-of-class-p (car PV) (car classtype)) | |
354 | (error "Corrupt object on disk"))) | |
355 | ||
356 | ;; We have a list of objects here. Lets load them | |
357 | ;; in. | |
358 | (let ((objlist nil)) | |
359 | (dolist (subobj (cdr proposed-value)) | |
360 | (push (eieio-persistent-convert-list-to-object subobj) | |
361 | objlist)) | |
362 | ;; return the list of objects ... reversed. | |
363 | (nreverse objlist))) | |
364 | (t | |
365 | proposed-value)))) | |
366 | ||
367 | ((stringp proposed-value) | |
368 | ;; Else, check for strings, remove properties. | |
369 | (substring-no-properties proposed-value)) | |
370 | ||
371 | (t | |
372 | ;; Else, just return whatever the constant was. | |
373 | proposed-value)) | |
374 | ) | |
375 | ||
376 | (defun eieio-persistent-slot-type-is-class-p (type) | |
377 | "Return the class refered to in TYPE. | |
378 | If no class is referenced there, then return nil." | |
379 | (cond ((class-p type) | |
380 | ;; If the type is a class, then return it. | |
381 | type) | |
382 | ||
383 | ((and (symbolp type) (string-match "-child$" (symbol-name type)) | |
384 | (class-p (intern-soft (substring (symbol-name type) 0 | |
385 | (match-beginning 0))))) | |
386 | ;; If it is the predicate ending with -child, then return | |
387 | ;; that class. Unfortunately, in EIEIO, typep of just the | |
388 | ;; class is the same as if we used -child, so no further work needed. | |
389 | (intern-soft (substring (symbol-name type) 0 | |
390 | (match-beginning 0)))) | |
391 | ||
392 | ((and (symbolp type) (string-match "-list$" (symbol-name type)) | |
393 | (class-p (intern-soft (substring (symbol-name type) 0 | |
394 | (match-beginning 0))))) | |
395 | ;; If it is the predicate ending with -list, then return | |
396 | ;; that class and the predicate to use. | |
397 | (cons (intern-soft (substring (symbol-name type) 0 | |
398 | (match-beginning 0))) | |
399 | type)) | |
400 | ||
401 | ((and (consp type) (eq (car type) 'or)) | |
402 | ;; If type is a list, and is an or, it is possibly something | |
403 | ;; like (or null myclass), so check for that. | |
404 | (let ((ans nil)) | |
405 | (dolist (subtype (cdr type)) | |
406 | (setq ans (eieio-persistent-slot-type-is-class-p | |
407 | subtype))) | |
408 | ans)) | |
409 | ||
410 | (t | |
411 | ;; No match, not a class. | |
412 | nil))) | |
413 | ||
6dd12ef2 CY |
414 | (defmethod object-write ((this eieio-persistent) &optional comment) |
415 | "Write persistent object THIS out to the current stream. | |
416 | Optional argument COMMENT is a header line comment." | |
417 | (call-next-method this (or comment (oref this file-header-line)))) | |
418 | ||
419 | (defmethod eieio-persistent-path-relative ((this eieio-persistent) file) | |
420 | "For object THIS, make absolute file name FILE relative." | |
421 | (file-relative-name (expand-file-name file) | |
422 | (file-name-directory (oref this file)))) | |
423 | ||
424 | (defmethod eieio-persistent-save ((this eieio-persistent) &optional file) | |
425 | "Save persistent object THIS to disk. | |
426 | Optional argument FILE overrides the file name specified in the object | |
427 | instance." | |
428 | (save-excursion | |
429 | (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) | |
430 | (default-directory (file-name-directory (oref this file))) | |
431 | (cfn (oref this file))) | |
432 | (unwind-protect | |
433 | (save-excursion | |
434 | (erase-buffer) | |
435 | (let ((standard-output (current-buffer))) | |
436 | (oset this file | |
437 | (if file | |
438 | (eieio-persistent-path-relative this file) | |
439 | (file-name-nondirectory cfn))) | |
440 | (object-write this (oref this file-header-line))) | |
67d3ffe4 CY |
441 | (let ((backup-inhibited (not (oref this do-backups))) |
442 | (cs (car (find-coding-systems-region | |
443 | (point-min) (point-max))))) | |
444 | (unless (eq cs 'undecided) | |
445 | (setq buffer-file-coding-system cs)) | |
6dd12ef2 CY |
446 | ;; Old way - write file. Leaves message behind. |
447 | ;;(write-file cfn nil) | |
448 | ||
449 | ;; New way - Avoid the vast quantities of error checking | |
450 | ;; just so I can get at the special flags that disable | |
451 | ;; displaying random messages. | |
452 | (write-region (point-min) (point-max) | |
453 | cfn nil 1) | |
454 | )) | |
455 | ;; Restore :file, and kill the tmp buffer | |
456 | (oset this file cfn) | |
457 | (setq buffer-file-name nil) | |
458 | (kill-buffer b))))) | |
459 | ||
460 | ;; Notes on the persistent object: | |
461 | ;; It should also set up some hooks to help it keep itself up to date. | |
462 | ||
463 | \f | |
464 | ;;; Named object | |
465 | ;; | |
466 | ;; Named objects use the objects `name' as a slot, and that slot | |
467 | ;; is accessed with the `object-name' symbol. | |
468 | ||
469 | (defclass eieio-named () | |
470 | () | |
471 | "Object with a name. | |
472 | Name storage already occurs in an object. This object provides get/set | |
473 | access to it." | |
474 | :abstract t) | |
475 | ||
476 | (defmethod slot-missing ((obj eieio-named) | |
477 | slot-name operation &optional new-value) | |
d1f18ec0 | 478 | "Called when a non-existent slot is accessed. |
6dd12ef2 | 479 | For variable `eieio-named', provide an imaginary `object-name' slot. |
a8f316ca | 480 | Argument OBJ is the named object. |
6dd12ef2 CY |
481 | Argument SLOT-NAME is the slot that was attempted to be accessed. |
482 | OPERATION is the type of access, such as `oref' or `oset'. | |
483 | NEW-VALUE is the value that was being set into SLOT if OPERATION were | |
484 | a set type." | |
485 | (if (or (eq slot-name 'object-name) | |
486 | (eq slot-name :object-name)) | |
487 | (cond ((eq operation 'oset) | |
488 | (if (not (stringp new-value)) | |
489 | (signal 'invalid-slot-type | |
490 | (list obj slot-name 'string new-value))) | |
491 | (object-set-name-string obj new-value)) | |
492 | (t (object-name-string obj))) | |
493 | (call-next-method))) | |
494 | ||
495 | (provide 'eieio-base) | |
496 | ||
497 | ;;; eieio-base.el ends here |