cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/eieio-base.el

   1 ;;; eieio-base.el --- Base classes for EIEIO.
   2
   3 ;;;
   4 ;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007 Eric M. Ludlam
   5 ;;
   6 ;; Author: <zappo@gnu.org>
   7 ;; RCS: $Id: eieio-base.el,v 1.3 2007-11-26 15:01:03 michaels Exp $
   8 ;; Keywords: OO, lisp
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;; Please send bug reports, etc. to zappo@gnu.org
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; Base classes for EIEIO.  These classes perform some basic tasks
  30 ;; but are generally useless on their own.  To use any of these classes,
  31 ;; inherit from one or more of them.
  32
  33 (require 'eieio)
  34
  35 ;;; Code:
  36 \f
  37 ;;; eieio-instance-inheritor
  38 ;;
  39 ;; Enable instance inheritance via the `clone' method.
  40 ;; Works by using the `slot-unbound' method which usually throws an
  41 ;; error if a slot is unbound.
  42 (defclass eieio-instance-inheritor ()
  43   ((parent-instance :initarg :parent-instance
  44                     :type eieio-instance-inheritor-child
  45                     :documentation
  46                     "The parent of this instance.
  47 If a slot of this class is reference, and is unbound, then  the parent
  48 is checked for a value.")
  49    )
  50   "This special class can enable instance inheritance.
  51 Use `clone' to make a new object that does instance inheritance from
  52 a parent instance.  When a slot in the child is referenced, and has
  53 not been set, use values from the parent."
  54   :abstract t)
  55
  56 (defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
  57   "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
  58 SLOT-NAME, is the offending slot.  FN is the function signalling the error."
  59   (if (slot-boundp object 'parent-instance)
  60       (eieio-oref (oref object parent-instance) slot-name)
  61     (call-next-method)))
  62
  63 (defmethod clone ((obj eieio-instance-inheritor) &rest params)
  64   "Clone OBJ, initializing `:parent' to OBJ.
  65 All slots are unbound, except those initialized with PARAMS."
  66   (let ((nobj (make-vector (length obj) eieio-unbound))
  67         (nm (aref obj object-name))
  68         (passname (and params (stringp (car params))))
  69         (num 1))
  70     (aset nobj 0 'object)
  71     (aset nobj object-class (aref obj object-class))
  72     ;; The following was copied from the default clone.
  73     (if (not passname)
  74         (save-match-data
  75           (if (string-match "-\\([0-9]+\\)" nm)
  76               (setq num (1+ (string-to-number (match-string 1 nm)))
  77                     nm (substring nm 0 (match-beginning 0))))
  78           (aset nobj object-name (concat nm "-" (int-to-string num))))
  79       (aset nobj object-name (car params)))
  80     ;; Now initialize from params.
  81     (if params (shared-initialize nobj (if passname (cdr params) params)))
  82     (oset nobj parent-instance obj)
  83     nobj))
  84
  85 \f
  86 ;;; eieio-instance-tracker
  87 ;;
  88 ;; Track all created instances of this class.
  89 ;; The class must initialize the `tracking-symbol' slot, and that
  90 ;; symbol is then used to contain these objects.
  91 (defclass eieio-instance-tracker ()
  92   ((tracking-symbol :type symbol
  93                     :allocation :class
  94                     :documentation
  95                     "The symbol used to maintain a list of our instances.
  96 The instance list is treated as a variable, with new instances added to it.")
  97    )
  98   "This special class enables instance tracking.
  99 Inheritors from this class must overload `tracking-symbol' which is
 100 a variable symbol used to store a list of all instances."
 101   :abstract t)
 102
 103 (defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
 104                                        &rest fields)
 105   "Make sure THIS is in our master list of this class.
 106 Optional argument FIELDS are the initialization arguments."
 107   ;; Theoretically, this is never called twice for a given instance.
 108   (let ((sym (oref this tracking-symbol)))
 109     (if (not (memq this (symbol-value sym)))
 110         (set sym (append (symbol-value sym) (list this))))))
 111
 112 (defmethod delete-instance ((this eieio-instance-tracker))
 113   "Remove THIS from the master list of this class."
 114   (set (oref this tracking-symbol)
 115        (delq this (symbol-value (oref this tracking-symbol)))))
 116
 117 ;; In retrospect, this is a silly function.
 118 (defun eieio-instance-tracker-find (key field list-symbol)
 119   "Find KEY as an element of FIELD in the objects in LIST-SYMBOL.
 120 Returns the first match."
 121   (object-assoc key field (symbol-value list-symbol)))
 122
 123 ;;; eieio-singleton
 124 ;;
 125 ;; The singleton Design Pattern specifies that there is but one object
 126 ;; of a given class ever created.  The EIEIO singleton base class defines
 127 ;; a CLASS allocated slot which contains the instance used.  All calls to
 128 ;; `make-instance' will either create a new instance and store it in this
 129 ;; slot, or it will just return what is there.
 130 (defclass eieio-singleton ()
 131   ((singleton :type eieio-singleton
 132               :allocation :class
 133               :documentation
 134               "The only instance of this class that will be instantiated.
 135 Multiple calls to `make-instance' will return this object."))
 136   "This special class causes subclasses to be singletons.
 137 A singleton is a class which will only ever have one instace."
 138   :abstract t)
 139
 140 (defmethod constructor :STATIC ((class eieio-singleton) name &rest fields)
 141   "Constructor for singleton CLASS.
 142 NAME and FIELDS initialize the new object.
 143 This constructor guarantees that no matter how many you request,
 144 only one object ever exists."
 145   ;; NOTE TO SELF: In next version, make `slot-boundp' support classes
 146   ;; with class allocated slots or default values.
 147   (let ((old (oref-default class singleton)))
 148     (if (eq old eieio-unbound)
 149         (oset-default class singleton (call-next-method))
 150       old)))
 151
 152 \f
 153 ;;; eieio-persistent
 154 ;;
 155 ;; For objects which must save themselves to disk.  Provides an
 156 ;; `object-write' method to save an object to disk, and a
 157 ;; `eieio-persistent-read' function to call to read an object
 158 ;; from disk.
 159 ;;
 160 ;; Also provide the method `eieio-persistent-path-relative' to
 161 ;; calculate path names relative to a given instance.  This will
 162 ;; make the saved object location independent by converting all file
 163 ;; references to be relative to the directory the object is saved to.
 164 ;; You must call `eieio-peristent-path-relative' on each file name
 165 ;; saved in your object.
 166 (defclass eieio-persistent ()
 167   ((file :initarg :file
 168          :type string
 169          :documentation
 170          "The save file for this persistent object.
 171 This must be a string, and must be specified when the new object is
 172 instantiated.")
 173    (extension :type string
 174               :allocation :class
 175               :initform ".eieio"
 176               :documentation
 177               "Extension of files saved by this object.
 178 Enables auto-choosing nice file names based on name.")
 179    (file-header-line :type string
 180                      :allocation :class
 181                      :initform ";; EIEIO PERSISTENT OBJECT"
 182                      :documentation
 183                      "Header line for the save file.
 184 This is used with the `object-write' method."))
 185   "This special class enables persistence through save files
 186 Use the `object-save' method to write this object to disk.  The save
 187 format is Emacs Lisp code which calls the constructor for the saved
 188 object.  For this reason, only slots which do not have an `:initarg'
 189 specified will not be saved."
 190   :abstract t)
 191
 192 (defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
 193                                               &optional name)
 194   "Perpare to save THIS.  Use in an `interactive' statement.
 195 Query user for file name with PROMPT if THIS does not yet specify
 196 a file.  Optional argument NAME specifies a default file name."
 197   (unless (slot-boundp this 'file)
 198       (oset this file
 199             (read-file-name prompt nil
 200                             (if   name
 201                                 (concat name (oref this extension))
 202                               ))))
 203   (oref this file))
 204
 205 (defun eieio-persistent-read (filename)
 206   "Read a persistent object from FILENAME."
 207   (save-excursion
 208     (let ((ret nil))
 209       (set-buffer (get-buffer-create " *tmp eieio read*"))
 210       (unwind-protect
 211           (progn
 212             (insert-file-contents filename nil nil nil t)
 213             (goto-char (point-min))
 214             (setq ret (read (current-buffer)))
 215             (if (not (child-of-class-p (car ret) 'eieio-persistent))
 216                 (error "Corrupt object on disk"))
 217             (setq ret (eval ret))
 218             (oset ret file filename))
 219         (kill-buffer " *tmp eieio read*"))
 220       ret)))
 221
 222 (defmethod object-write ((this eieio-persistent) &optional comment)
 223   "Write persistent object THIS out to the current stream.
 224 Optional argument COMMENT is a header line comment."
 225   (call-next-method this (or comment (oref this file-header-line))))
 226
 227 (defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
 228   "For object THIS, make absolute file name FILE relative."
 229   (file-relative-name (expand-file-name file)
 230                       (file-name-directory (oref this file))))
 231
 232 (defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
 233   "Save persistent object THIS to disk.
 234 Optional argument FILE overrides the file name specified in the object
 235 instance."
 236   (save-excursion
 237     (let ((b (set-buffer (get-buffer-create " *tmp object write*")))
 238           (default-directory (file-name-directory (oref this file)))
 239           (cfn (oref this file)))
 240       (unwind-protect
 241           (save-excursion
 242             (erase-buffer)
 243             (let ((standard-output (current-buffer)))
 244               (oset this file
 245                     (if file
 246                         (eieio-persistent-path-relative this file)
 247                       (file-name-nondirectory cfn)))
 248               (object-write this (oref this file-header-line)))
 249             (write-file cfn nil))
 250         ;; Restore :file, and kill the tmp buffer
 251         (oset this file cfn)
 252         (setq buffer-file-name nil)
 253         (kill-buffer b)))))
 254
 255 ;; Notes on the persistent object:
 256 ;; It should also set up some hooks to help it keep itself up to date.
 257
 258 \f
 259 ;;; Named object
 260 ;;
 261 ;; Named objects use the objects `name' as a slot, and that slot
 262 ;; is accessed with the `object-name' symbol.
 263
 264 (defclass eieio-named ()
 265   ()
 266   "Object with a name.
 267 Name storage already occurs in an object.  This object provides get/set
 268 access to it."
 269   :abstract t)
 270
 271 (defmethod slot-missing ((obj eieio-named)
 272                          slot-name operation &optional new-value)
 273   "Called when a on-existant slot is accessed.
 274 For variable `eieio-named', provide an imaginary `object-name' slot.
 275 Argument OBJ is the Named object.
 276 Argument SLOT-NAME is the slot that was attempted to be accessed.
 277 OPERATION is the type of access, such as `oref' or `oset'.
 278 NEW-VALUE is the value that was being set into SLOT if OPERATION were
 279 a set type."
 280   (if (or (eq slot-name 'object-name)
 281           (eq slot-name :object-name))
 282       (cond ((eq operation 'oset)
 283              (if (not (stringp new-value))
 284                  (signal 'invalid-slot-type
 285                          (list obj slot-name 'string new-value)))
 286              (object-set-name-string obj new-value))
 287             (t (object-name-string obj)))
 288     (call-next-method)))
 289
 290 (provide 'eieio-base)
 291
 292 ;;; eieio-base.el ends here