Source

eieio / eieio-base.el

Diff from to

eieio-base.el

 ;;; eieio-base.el --- Base classes for EIEIO.
 
 ;;;
-;; Copyright (C) 2000, 2001 Eric M. Ludlam
+;; Copyright (C) 2000, 2001, 2002 Eric M. Ludlam
 ;;
 ;; Author: <zappo@gnu.org>
 ;; RCS: $Id$
 
 (require 'eieio)
 
-(if (not (fboundp 'compare-strings))
-    (require 'compare-strings))
-
 ;;; Code:
 
 ;;; eieio-instance-inheritor
 ;; error if a slot is unbound.
 (defclass eieio-instance-inheritor ()
   ((parent-instance :initarg :parent-instance
-		    :type eieio-instance-inheritor
+		    :type eieio-instance-inheritor-child
 		    :documentation
 		    "The parent of this instance.
 If a slot of this class is reference, and is unbound, then  the parent
   "This special class can enable instance inheritance.
 Use `clone' to make a new object that does instance inheritance from
 a parent instance.  When a slot in the child is referenced, and has
-not been set, use values from the parent.")
+not been set, use values from the parent."
+  :abstract t)
 
 (defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
   "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
 ;; symbol is then used to contain these objects.
 (defclass eieio-instance-tracker ()
   ((tracking-symbol :type symbol
-		    :allocation class
+		    :allocation :class
 		    :documentation
 		    "The symbol used to maintain a list of our instances.
 The instance list is treated as a variable, with new instances added to it.")
    )
   "This special class enables instance tracking.
 Inheritors from this class must overload `tracking-symbol' which is
-a variable symbol used to store a list of all instances.")
+a variable symbol used to store a list of all instances."
+  :abstract t)
 
 (defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
 				       &rest fields)
 Returns the first match."
   (object-assoc key field (symbol-value list-symbol)))
 
+;;; eieio-singleton
+;;
+;; The singleton Design Pattern specifies that there is but one object
+;; of a given class ever created.  The EIEIO singleton base class defines
+;; a CLASS allocated slot which contains the instance used.  All calls to
+;; `make-instance' will either create a new instance and store it in this
+;; slot, or it will just return what is there.
+(defclass eieio-singleton ()
+  ((singleton :type eieio-singleton
+	      :allocation :class
+	      :documentation
+	      "The only instance of this class that will be instantiated.
+Multiple calls to `make-instance' will return this object."))
+  "This special class causes subclasses to be singletons.
+A singleton is a class which will only ever have one instace."
+  :abstract t)
+
+(defmethod constructor :STATIC ((class eieio-singleton) name &rest fields)
+  "Constructor for singleton CLASS.
+NAME and FIELDS initialize the new object.
+This constructor guarantees that no matter how many you request,
+only one object ever exists."
+  (let ((old (oref-default class singleton)))
+    (or old (call-next-method))))
+
 
 ;;; eieio-persistent
 ;;
 	 "The save file for this persistent object.
 This must be a string, and must be specified when the new object is
 instantiated.")
+   (extension :type string
+	      :allocation :class
+	      :initform ".eieio"
+	      :documentation
+	      "Extension of files saved by this object.
+Enables auto-choosing nice file names based on name.")
    (file-header-line :type string
-		     :allocation class
+		     :allocation :class
 		     :initform ";; EIEIO PERSISTENT OBJECT"
 		     :documentation
 		     "Header line for the save file.
 This is used with the `object-write' method."))
-  "This special class enables persistence through save files.
-Use the `object-save' method to write this object to disk.")
+  "This special class enables persistence through save files
+Use the `object-save' method to write this object to disk.  The save
+format is Emacs Lisp code which calls the constructor for the saved
+object.  For this reason, only slots which do not have an `:initarg'
+specified will not be saved."
+  :abstract t)
+
+(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
+					      &optional name)
+  "Perpare to save THIS.  Use in an `interactive' statement.
+Query user for file name with PROMPT if THIS does not yet specify
+a file.  Optional argument NAME specifies a default file name."
+  (unless (slot-boundp this 'file)
+      (oset this file
+	    (read-file-name prompt nil
+			    (if   name
+				(concat name (oref this extension))
+			      ))))
+  (oref this file))
 
 (defun eieio-persistent-read (filename)
   "Read a persistent object from FILENAME."
 
 (defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
   "For object THIS, make absolute file name FILE relative."
-  (let* ((src (expand-file-name file))
-	 (dest (file-name-directory (oref this file)))
-	 (cs1  (compare-strings src 0 nil dest 0 nil))
-	 diff abdest absrc)
-    ;; Find the common directory part
-    (setq diff (substring src 0 cs1))
-    (setq cs1 (split-string diff "[\\/]"))
-    (setq cs1 (length (nth (1- (length cs1)) cs1)))
-    (setq diff (substring diff 0 (- (length diff) cs1)))
-    ;; Get the uncommon bits from dest and src.
-    (setq abdest (substring dest (length diff))
-	  absrc (substring src (length diff)))
-    ;; Find number if dirs in absrc, and add those as ".." to dest.
-    ;; Rember we have a file name, so that is the 1-.
-    (setq cs1 (1- (length (split-string absrc "[\\/]"))))
-    (while (> cs1 0)
-      (setq abdest (concat "../" abdest)
-	    cs1 (1- cs1)))
-    absrc))
+  ;; Woah!  Look at `file-relative-name' as a solution.
+  (file-relative-name (expand-file-name file)
+		      (file-name-directory (oref this file))))
 
 (defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
   "Save persistent object THIS to disk.
 	    (write-file cfn nil))
 	;; Restore :file, and kill the tmp buffer
 	(oset this file cfn)
+	(setq buffer-file-name nil)
 	(kill-buffer b)))))
 
 ;; Notes on the persistent object:
 ;; It should also set up some hooks to help it keep itself up to date.
 
+
+;;; Named object
+;;
+;; Named objects use the objects `name' as a slot, and that slot
+;; is accessed with the `object-name' symbol.
+
+(defclass eieio-named ()
+  ()
+  "Object with a name.
+Name storage already occurs in an object.  This object provides get/set
+access to it."
+  :abstract t)
+
+(defmethod slot-missing ((obj eieio-named)
+			 slot-name operation &optional new-value)
+  "Called when a on-existant slot is accessed.
+For variable `eieio-named', provide an imaginary `object-nam' slot.
+Argument OBJ is the Named object.
+Argument SLOT-NAME is the slot that was attempted to be accessed.
+OPERATION is the type of access, such as `oref' or `oset'.
+NEW-VALUE is the value that was being set into SLOT if OPERATION were
+a set type."
+  (if (or (eq slot-name 'object-name)
+	  (eq slot-name :object-name))
+      (cond ((eq operation 'oset)
+	     (if (not (stringp new-value))
+		 (signal 'invalid-slot-type
+			 (list obj slot-name 'string new-value)))
+	     (object-set-name-string obj new-value))
+	    (t (object-name-string obj)))
+    (call-next-method)))
 
 (provide 'eieio-base)