lisp/emacs-lisp/eieio-base.el

   1 ;;; eieio-base.el --- Base classes for EIEIO.
   2
   3 ;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009, 2010, 2011, 2012
   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.
  45 If a slot of this class is referenced, and is unbound, then the parent
  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.
  56 SLOT-NAME is the offending slot.  FN is the function signalling the error."
  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)
  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
  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.
 153 A singleton is a class which will only ever have one instance."
 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)
 216   "Prepare to save THIS.  Use in an `interactive' statement.
 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
 233           (with-current-buffer (get-buffer-create " *tmp eieio read*")
 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)))
 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))
 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)
 312   "Called when a non-existent slot is accessed.
 313 For variable `eieio-named', provide an imaginary `object-name' slot.
 314 Argument OBJ is the named object.
 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
 331 ;; arch-tag: 6260571e-9e8a-41a0-880f-a937b0c2ea8b
 332 ;;; eieio-base.el ends here