Merge from emacs-24; up to 2014-07-17T10:18:19Z!dmantipov@yandex.ru
[emacs.git] / lisp / emacs-lisp / eieio-base.el
blob150724e648412fc98f8ca55c612888788ec21054
1 ;;; eieio-base.el --- Base classes for EIEIO.
3 ;;; Copyright (C) 2000-2002, 2004-2005, 2007-2014 Free Software
4 ;;; Foundation, Inc.
6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
7 ;; Keywords: OO, lisp
8 ;; Package: eieio
10 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;;; Commentary:
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.
31 ;;; Code:
33 (require 'eieio)
34 (eval-when-compile (require 'cl)) ;FIXME: Use cl-lib!
36 ;;; eieio-instance-inheritor
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.
46 If a slot of this class is referenced, and is unbound, then the parent
47 is checked for a value.")
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)
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.
57 SLOT-NAME is the offending slot. FN is the function signaling the error."
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)))
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 (eieio--object-name obj))
70 (passname (and params (stringp (car params))))
71 (num 1))
72 (aset nobj 0 'object)
73 (setf (eieio--object-class nobj) (eieio--object-class obj))
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 (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
81 (setf (eieio--object-name nobj) (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))
87 (defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
88 slot)
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
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.
97 (if (slot-boundp object 'parent-instance)
98 (eieio-instance-inheritor-slot-boundp (oref object parent-instance)
99 slot)
100 nil)))
103 ;;; eieio-instance-tracker
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.")
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)
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))))))
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)))))
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)))
140 ;;; eieio-singleton
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.
154 A singleton is a class which will only ever have one instance."
155 :abstract t)
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)))
170 ;;; eieio-persistent
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.
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-persistent-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)
215 (defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
216 &optional name)
217 "Prepare to save THIS. Use in an `interactive' statement.
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))
228 (defun eieio-persistent-read (filename &optional class allow-subclass)
229 "Read a persistent object from FILENAME, and return it.
230 Signal an error if the object in FILENAME is not a constructor
231 for CLASS. Optional ALLOW-SUBCLASS says that it is ok for
232 `eieio-persistent-read' to load in subclasses of class instead of
233 being pedantic."
234 (unless class
235 (message "Unsafe call to `eieio-persistent-read'."))
236 (when class (eieio--check-type class-p class))
237 (let ((ret nil)
238 (buffstr nil))
239 (unwind-protect
240 (progn
241 (with-current-buffer (get-buffer-create " *tmp eieio read*")
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))
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
256 (error "Corrupt object on disk: Invalid saved class"))
257 (setq ret (eieio-persistent-convert-list-to-object ret))
258 (oset ret file filename))
259 (kill-buffer " *tmp eieio read*"))
260 ret))
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.
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))
276 ;; If OBJCLASS is an eieio autoload object, then we need to load it.
277 (eieio-class-un-autoload objclass)
279 (while slots
280 (let ((name (car slots))
281 (value (car (cdr slots))))
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))
289 (push name createslots)
290 (push value createslots)
293 (setq slots (cdr (cdr slots))))
295 (apply 'make-instance objclass objname (nreverse createslots))
297 ;;(eval inputlist)
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.
304 Second, any text properties will be stripped from strings."
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 (eieio--class-public-type (class-v class))
312 slot-idx))
314 (setq classtype (eieio-persistent-slot-type-is-class-p
315 type))
317 (cond ((eq (car proposed-value) 'quote)
318 (car (cdr proposed-value)))
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)
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))
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))))
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))
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")))
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)))
365 proposed-value))))
367 ((stringp proposed-value)
368 ;; Else, check for strings, remove properties.
369 (substring-no-properties proposed-value))
372 ;; Else, just return whatever the constant was.
373 proposed-value))
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)
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))))
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))
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))
411 ;; No match, not a class.
412 nil)))
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))))
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))))
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)))
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))
446 ;; Old way - write file. Leaves message behind.
447 ;;(write-file cfn nil)
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)
455 ;; Restore :file, and kill the tmp buffer
456 (oset this file cfn)
457 (setq buffer-file-name nil)
458 (kill-buffer b)))))
460 ;; Notes on the persistent object:
461 ;; It should also set up some hooks to help it keep itself up to date.
464 ;;; Named object
466 ;; Named objects use the objects `name' as a slot, and that slot
467 ;; is accessed with the `object-name' symbol.
469 (defclass eieio-named ()
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)
476 (defmethod slot-missing ((obj eieio-named)
477 slot-name operation &optional new-value)
478 "Called when a non-existent slot is accessed.
479 For variable `eieio-named', provide an imaginary `object-name' slot.
480 Argument OBJ is the named object.
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 (memq slot-name '(object-name :object-name))
486 (cond ((eq operation 'oset)
487 (if (not (stringp new-value))
488 (signal 'invalid-slot-type
489 (list obj slot-name 'string new-value)))
490 (eieio-object-set-name-string obj new-value))
491 (t (eieio-object-name-string obj)))
492 (call-next-method)))
494 (provide 'eieio-base)
496 ;;; eieio-base.el ends here