X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cc7cb20d6abc0f862e5513b24831bba0eaecaa5f..0e963201d03d9229bb8ac4323291d2b0119526ed:/lisp/emacs-lisp/eieio-base.el diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 9931fbd114..b99905cf19 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -1,6 +1,6 @@ ;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*- -;;; Copyright (C) 2000-2002, 2004-2005, 2007-2015 Free Software +;;; Copyright (C) 2000-2002, 2004-2005, 2007-2016 Free Software ;;; Foundation, Inc. ;; Author: Eric M. Ludlam @@ -52,7 +52,7 @@ a parent instance. When a slot in the child is referenced, and has not been set, use values from the parent." :abstract t) -(defmethod slot-unbound ((object eieio-instance-inheritor) +(cl-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. SLOT-NAME is the offending slot. FN is the function signaling the error." @@ -61,16 +61,16 @@ SLOT-NAME is the offending slot. FN is the function signaling the error." ;; method if the parent instance's slot is unbound. (eieio-oref (oref object parent-instance) slot-name) ;; Throw the regular signal. - (call-next-method))) + (cl-call-next-method))) -(defmethod clone ((obj eieio-instance-inheritor) &rest _params) +(cl-defmethod clone ((obj eieio-instance-inheritor) &rest _params) "Clone OBJ, initializing `:parent' to OBJ. All slots are unbound, except those initialized with PARAMS." - (let ((nobj (call-next-method))) + (let ((nobj (cl-call-next-method))) (oset nobj parent-instance obj) nobj)) -(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) +(cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) slot) "Return non-nil if the instance inheritor OBJECT's SLOT is bound. See `slot-boundp' for details on binding slots. @@ -103,7 +103,7 @@ Inheritors from this class must overload `tracking-symbol' which is a variable symbol used to store a list of all instances." :abstract t) -(defmethod initialize-instance :AFTER ((this eieio-instance-tracker) +(cl-defmethod initialize-instance :after ((this eieio-instance-tracker) &rest _slots) "Make sure THIS is in our master list of this class. Optional argument SLOTS are the initialization arguments." @@ -112,7 +112,7 @@ Optional argument SLOTS are the initialization arguments." (if (not (memq this (symbol-value sym))) (set sym (append (symbol-value sym) (list this)))))) -(defmethod delete-instance ((this eieio-instance-tracker)) +(cl-defmethod delete-instance ((this eieio-instance-tracker)) "Remove THIS from the master list of this class." (set (oref this tracking-symbol) (delq this (symbol-value (oref this tracking-symbol))))) @@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) A singleton is a class which will only ever have one instance." :abstract t) -(defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots) +(cl-defmethod make-instance ((class (subclass eieio-singleton)) &rest _slots) "Constructor for singleton CLASS. NAME and SLOTS initialize the new object. This constructor guarantees that no matter how many you request, @@ -149,7 +149,7 @@ only one object ever exists." ;; with class allocated slots or default values. (let ((old (oref-default class singleton))) (if (eq old eieio-unbound) - (oset-default class singleton (call-next-method)) + (oset-default class singleton (cl-call-next-method)) old))) @@ -198,7 +198,7 @@ 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 +(cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt &optional name) "Prepare to save THIS. Use in an `interactive' statement. Query user for file name with PROMPT if THIS does not yet specify @@ -219,7 +219,7 @@ for CLASS. Optional ALLOW-SUBCLASS says that it is ok for being pedantic." (unless class (message "Unsafe call to `eieio-persistent-read'.")) - (when class (eieio--check-type class-p class)) + (when class (cl-check-type class class)) (let ((ret nil) (buffstr nil)) (unwind-protect @@ -254,25 +254,28 @@ malicious code. Note: This function recurses when a slot of :type of some object is identified, and needing more object creation." - (let ((objclass (nth 0 inputlist)) - ;; (objname (nth 1 inputlist)) - (slots (nthcdr 2 inputlist)) - (createslots nil)) - - ;; If OBJCLASS is an eieio autoload object, then we need to load it. - (eieio-class-un-autoload objclass) + (let* ((objclass (nth 0 inputlist)) + ;; (objname (nth 1 inputlist)) + (slots (nthcdr 2 inputlist)) + (createslots nil) + (class + (progn + ;; If OBJCLASS is an eieio autoload object, then we need to + ;; load it. + (eieio-class-un-autoload objclass) + (eieio--class-object objclass)))) (while slots - (let ((name (car slots)) + (let ((initarg (car slots)) (value (car (cdr slots)))) ;; Make sure that the value proposed for SLOT is valid. ;; In addition, strip out quotes, list functions, and update ;; object constructors as needed. (setq value (eieio-persistent-validate/fix-slot-value - (eieio--class-v objclass) name value)) + class (eieio--initarg-to-attribute class initarg) value)) - (push name createslots) + (push initarg createslots) (push value createslots) ) @@ -290,17 +293,12 @@ constructor functions are considered valid. Second, any text properties will be stripped from strings." (cond ((consp proposed-value) ;; Lists with something in them need special treatment. - (let ((slot-idx (eieio--slot-name-index class - nil slot)) - (type nil) - (classtype nil)) - (setq slot-idx (- slot-idx - (eval-when-compile eieio--object-num-slots))) - (setq type (aref (eieio--class-public-type class) - slot-idx)) - - (setq classtype (eieio-persistent-slot-type-is-class-p - type)) + (let* ((slot-idx (- (eieio--slot-name-index class slot) + (eval-when-compile + (length (cl-struct-slot-info 'eieio--object))))) + (type (cl--slot-descriptor-type (aref (eieio--class-slots class) + slot-idx))) + (classtype (eieio-persistent-slot-type-is-class-p type))) (cond ((eq (car proposed-value) 'quote) (car (cdr proposed-value))) @@ -417,51 +415,42 @@ If no class is referenced there, then return nil." ;; No match, not a class. nil))) -(defmethod object-write ((this eieio-persistent) &optional comment) +(cl-defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream. Optional argument COMMENT is a header line comment." - (call-next-method this (or comment (oref this file-header-line)))) + (cl-call-next-method this (or comment (oref this file-header-line)))) -(defmethod eieio-persistent-path-relative ((this eieio-persistent) file) +(cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file) "For object THIS, make absolute file name FILE relative." (file-relative-name (expand-file-name file) (file-name-directory (oref this file)))) -(defmethod eieio-persistent-save ((this eieio-persistent) &optional file) +(cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file) "Save persistent object THIS to disk. Optional argument FILE overrides the file name specified in the object instance." - (save-excursion - (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) - (default-directory (file-name-directory (oref this file))) - (cfn (oref this file))) - (unwind-protect - (save-excursion - (erase-buffer) - (let ((standard-output (current-buffer))) - (oset this file - (if file - (eieio-persistent-path-relative this file) - (file-name-nondirectory cfn))) - (object-write this (oref this file-header-line))) - (let ((backup-inhibited (not (oref this do-backups))) - (cs (car (find-coding-systems-region - (point-min) (point-max))))) - (unless (eq cs 'undecided) - (setq buffer-file-coding-system cs)) - ;; Old way - write file. Leaves message behind. - ;;(write-file cfn nil) - - ;; New way - Avoid the vast quantities of error checking - ;; just so I can get at the special flags that disable - ;; displaying random messages. - (write-region (point-min) (point-max) - cfn nil 1) - )) - ;; Restore :file, and kill the tmp buffer - (oset this file cfn) - (setq buffer-file-name nil) - (kill-buffer b))))) + (when file (setq file (expand-file-name file))) + (with-temp-buffer + (let* ((cfn (or file (oref this file))) + (default-directory (file-name-directory cfn))) + (cl-letf ((standard-output (current-buffer)) + ((oref this file) ;FIXME: Why change it? + (if file + ;; FIXME: Makes a name relative to (oref this file), + ;; whereas I think it should be relative to cfn. + (eieio-persistent-path-relative this file) + (file-name-nondirectory cfn)))) + (object-write this (oref this file-header-line))) + (let ((backup-inhibited (not (oref this do-backups))) + (coding-system-for-write 'utf-8-emacs)) + ;; Old way - write file. Leaves message behind. + ;;(write-file cfn nil) + + ;; New way - Avoid the vast quantities of error checking + ;; just so I can get at the special flags that disable + ;; displaying random messages. + (write-region (point-min) (point-max) cfn nil 1) + )))) ;; Notes on the persistent object: ;; It should also set up some hooks to help it keep itself up to date. @@ -474,21 +463,21 @@ instance." "Object with a name." :abstract t) -(defmethod eieio-object-name-string ((obj eieio-named)) +(cl-defmethod eieio-object-name-string ((obj eieio-named)) "Return a string which is OBJ's name." (or (slot-value obj 'object-name) (symbol-name (eieio-object-class obj)))) -(defmethod eieio-object-set-name-string ((obj eieio-named) name) +(cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) "Set the string which is OBJ's NAME." - (eieio--check-type stringp name) + (cl-check-type name string) (eieio-oset obj 'object-name name)) -(defmethod clone ((obj eieio-named) &rest params) +(cl-defmethod clone ((obj eieio-named) &rest params) "Clone OBJ, initializing `:parent' to OBJ. All slots are unbound, except those initialized with PARAMS." (let* ((newname (and (stringp (car params)) (pop params))) - (nobj (apply #'call-next-method obj params)) + (nobj (apply #'cl-call-next-method obj params)) (nm (slot-value obj 'object-name))) (eieio-oset obj 'object-name (or newname @@ -501,6 +490,15 @@ All slots are unbound, except those initialized with PARAMS." (concat nm "-1"))))) nobj)) +(cl-defmethod make-instance ((class (subclass eieio-named)) &rest args) + (if (not (stringp (car args))) + (cl-call-next-method) + (funcall (if eieio-backward-compatibility #'ignore #'message) + "Obsolete: name passed without :object-name to %S constructor" + class) + (apply #'cl-call-next-method class :object-name args))) + + (provide 'eieio-base) ;;; eieio-base.el ends here