| 1 | ;;; eieio-base.el --- Base classes for EIEIO. |
| 2 | |
| 3 | ;;; Copyright (C) 2000-2002, 2004-2005, 2007-2013 Free Software |
| 4 | ;;; Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 7 | ;; Keywords: OO, lisp |
| 8 | ;; Package: eieio |
| 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 | (eval-when-compile (require 'cl)) ;FIXME: Use cl-lib! |
| 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. |
| 46 | If a slot of this class is referenced, and is unbound, then the parent |
| 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. |
| 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))) |
| 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 (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)) |
| 86 | |
| 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. |
| 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. |
| 154 | A singleton is a class which will only ever have one instance." |
| 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-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) |
| 214 | |
| 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)) |
| 227 | |
| 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 |
| 255 | ))) |
| 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)) |
| 261 | |
| 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. |
| 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)) |
| 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 | |
| 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))) |
| 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) |
| 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) |
| 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))) |
| 493 | |
| 494 | (provide 'eieio-base) |
| 495 | |
| 496 | ;;; eieio-base.el ends here |