bug#29220: 26.0.90; eieio-persistent-read fail to restore saved object.

[Pierre Téchoueyres]

Noam Postavsky <npostavs@users.sourceforge.net> writes:

> tags 29220 fixed
> close 29220 26.1
> quit
> [...]
>
> Closing.
>
Sorry but I not certain everything is working as expected.

I'm trying to add another test to the eieio part
(test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el) but when I did
try the simple receipt which Eric had posted some times ago I end in the
debugger.

#+BEGIN_SRC debugger
Debugger entered--Lisp error: (wrong-type-argument sequencep person)
  mapc(#f(compiled-function (elt) #<bytecode 0x237e645>) person)
  seq-do(#f(compiled-function (elt) #<bytecode 0x237e645>) person)
  seq-some(#f(compiled-function (elt) #<bytecode 0x237e299>) person)
  eieio-persistent-validate/fix-slot-value(#s(eieio--class :name classy 
:docstring nil :parents (#s(eieio--class :name eieio-persistent :docstring 
"This special class enables persistence through save files\nUse the 
`object-save' method to write this object to disk.  The save\nformat is Emacs 
Lisp code which calls the constructor for the saved\nobject.  For this reason, 
only slots which do not have an `:initarg'\nspecified will not be saved." 
:parents nil :slots [#s(cl-slot-descriptor :name file :initform unbound :type 
string :props ((:documentation . "The save file for this persistent 
object.\nThis must be a string, and must be specified when the new object 
is\ninstantiated.")))] :index-table #<hash-table eq 1/65 0x129c671> :children 
(classy pcache-repository) :initarg-tuples ((:file . file)) :class-slots 
[#s(cl-slot-descriptor :name do-backups :initform t :type boolean :props 
((:documentation . "Saving this object should make backup files.\nSetting to 
nil will mean no backups are made."))) #s(cl-slot-descriptor :name 
file-header-line :initform ";; EIEIO PERSISTENT OBJECT" :type string :props 
((:documentation . "Header line for the save file.\nThis is used with the 
`object-write' method."))) #s(cl-slot-descriptor :name extension :initform 
".eieio" :type string :props ((:documentation . "Extension of files saved by 
this object.\nEnables auto-choosing nice file names based on name.")))] 
:class-allocation-values [t ";; EIEIO PERSISTENT OBJECT" ".eieio"] 
:default-object-cache #<eieio-persistent eieio-persistent> :options 
(:custom-groups nil :documentation "This special class enables persistence 
through save files\nUse the `object-save' method to write this object to disk.  
The save\nformat is Emacs Lisp code which calls the constructor for the 
saved\nobject.  For this reason, only slots which do not have an 
`:initarg'\nspecified will not be saved." :abstract t))) :slots 
[#s(cl-slot-descriptor :name file :initform unbound :type string :props 
((:documentation . "The save file for this persistent object.\nThis must be a 
string, and must be specified when the new object is\ninstantiated."))) 
#s(cl-slot-descriptor :name teacher :initform unbound :type person :props nil) 
#s(cl-slot-descriptor :name students :initform (make-hash-table) :type t :props 
nil)] :index-table #<hash-table eq 3/65 0x14d45a5> :children nil 
:initarg-tuples ((:file . file) (:teacher . teacher) (:students . students)) 
:class-slots [#s(cl-slot-descriptor :name extension :initform ".eieio" :type 
string :props ((:documentation . "Extension of files saved by this 
object.\nEnables auto-choosing nice file names based on name."))) 
#s(cl-slot-descriptor :name file-header-line :initform ";; EIEIO PERSISTENT 
OBJECT" :type string :props ((:documentation . "Header line for the save 
file.\nThis is used with the `object-write' method."))) #s(cl-slot-descriptor 
:name do-backups :initform t :type boolean :props ((:documentation . "Saving 
this object should make backup files.\nSetting to nil will mean no backups are 
made.")))] :class-allocation-values [".eieio" ";; EIEIO PERSISTENT OBJECT" t] 
:default-object-cache #<classy classy> :options (:custom-groups nil)) teacher 
(person "person" :name "Jane"))
  eieio-persistent-convert-list-to-object((classy "classy" :file 
"classy-26.0.90.eieio" :teacher (person "person" :name "Jane") :students 
#<hash-table eql 1/65 0x237e271>))
  eieio-persistent-read("classy-26.0.90.eieio" classy t)
  (let* ((jane (make-instance 'person :name "Jane")) (bob (make-instance 
'person :name "Bob")) (class (make-instance 'classy :teacher jane :file (concat 
"classy-" emacs-version ".eieio")))) (puthash "Bob" bob (slot-value class 
'students)) (eieio-persistent-save class (concat "classy-" emacs-version 
".eieio")) (eieio-persistent-read (concat "classy-" emacs-version ".eieio") 
'classy t))
  (progn (let* ((jane (make-instance 'person :name "Jane")) (bob (make-instance 
'person :name "Bob")) (class (make-instance 'classy :teacher jane :file (concat 
"classy-" emacs-version ".eieio")))) (puthash "Bob" bob (slot-value class 
'students)) (eieio-persistent-save class (concat "classy-" emacs-version 
".eieio")) (eieio-persistent-read (concat "classy-" emacs-version ".eieio") 
'classy t)))
  eval((progn (let* ((jane (make-instance 'person :name "Jane")) (bob 
(make-instance 'person :name "Bob")) (class (make-instance 'classy :teacher 
jane :file (concat "classy-" emacs-version ".eieio")))) (puthash "Bob" bob 
(slot-value class 'students)) (eieio-persistent-save class (concat "classy-" 
emacs-version ".eieio")) (eieio-persistent-read (concat "classy-" emacs-version 
".eieio") 'classy t))) t)
  elisp--eval-last-sexp(nil)
  eval-last-sexp(nil)
  funcall-interactively(eval-last-sexp nil)
  call-interactively(eval-last-sexp nil nil)
  command-execute(eval-last-sexp)
#+END_SRC

;;; -*- lexical-binding: t -*-
(require 'eieio)
(require 'eieio-base)

(defclass person ()
  ((name :type string :initarg :name)))

(defclass classy (eieio-persistent)
  ((teacher
    :type person
    :initarg :teacher)
   (students
    :initarg :students :initform (make-hash-table))))

(let* ((jane (make-instance 'person :name "Jane"))
       (bob  (make-instance 'person :name "Bob"))
       (class (make-instance 'classy
                             :teacher jane
                             :file (concat "classy-" emacs-version ".eieio"))))
  (puthash "Bob" bob (slot-value class 'students))
  (eieio-persistent-save class (concat "classy-" emacs-version ".eieio"))
  (eieio-persistent-read (concat "classy-" emacs-version ".eieio") 'classy t))

;;; eieio-test-persist.el --- Tests for eieio-persistent class

;; Copyright (C) 2011-2017 Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <eric@siege-engine.com>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; The eieio-persistent base-class provides a vital service, that
;; could be used to accidentally load in malicious code.  As such,
;; something as simple as calling eval on the generated code can't be
;; used.  These tests exercises various flavors of data that might be
;; in a persistent object, and tries to save/load them.

;;; Code:
(require 'eieio)
(require 'eieio-base)
(require 'ert)

(defun eieio--attribute-to-initarg (class attribute)
  "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag.
This is usually a symbol that starts with `:'."
  (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class))))
    (if tuple
        (car tuple)
      nil)))

(defun hash-equal (hash1 hash2)
  "Compare two hash tables to see whether they are equal."
  (and (= (hash-table-count hash1)
          (hash-table-count hash2))
       (catch 'flag (maphash (lambda (x y)
                               (or (equal (gethash x hash2) y)
                                   (throw 'flag nil)))
                             hash1)
              (throw 'flag t))))

(defun persist-test-save-and-compare (original)
  "Compare the object ORIGINAL against the one read fromdisk."

  (eieio-persistent-save original)

  (let* ((file (oref original file))
         (class (eieio-object-class original))
         (fromdisk (eieio-persistent-read file class))
         (cv (cl--find-class class))
         (slots  (eieio--class-slots cv)))

    (unless (object-of-class-p fromdisk class)
      (error "Persistent class %S != original class %S"
             (eieio-object-class fromdisk)
             class))

    (dotimes (i (length slots))
      (let* ((slot (aref slots i))
             (oneslot (cl--slot-descriptor-name slot))
             (origvalue (eieio-oref original oneslot))
             (fromdiskvalue (eieio-oref fromdisk oneslot))
             (initarg-p (eieio--attribute-to-initarg
                         (cl--find-class class) oneslot)))

        (if initarg-p
            (unless
                (cond ((and (hash-table-p origvalue) (hash-table-p 
fromdiskvalue))
                       (hash-equal origvalue fromdiskvalue))
                      (t (equal origvalue fromdiskvalue)))
              (error "Slot %S Original Val %S != Persistent Val %S"
                     oneslot origvalue fromdiskvalue))
          ;; Else !initarg-p
          (let ((origval (cl--slot-descriptor-initform slot))
                (diskval fromdiskvalue))
            (unless
                (cond ((and (hash-table-p origval) (hash-table-p diskval))
                       (hash-equal origval diskval))
                      (t (equal origval diskval)))
            (error "Slot %S Persistent Val %S != Default Value %S"
                   oneslot diskval origvalue))))
        ))))

;;; Simple Case
;;
;; Simplest case is a mix of slots with and without initargs.

(defclass persist-simple (eieio-persistent)
  ((slot1 :initarg :slot1
          :type symbol
          :initform moose)
   (slot2 :initarg :slot2
          :initform "foo")
   (slot3 :initform 2))
  "A Persistent object with two initializable slots, and one not.")

(ert-deftest eieio-test-persist-simple-1 ()
  (let ((persist-simple-1
         (persist-simple "simple 1" :slot1 'goose :slot2 "testing"
                         :file (concat default-directory "test-ps1.pt"))))
    (should persist-simple-1)

    ;; When the slot w/out an initarg has not been changed
    (persist-test-save-and-compare persist-simple-1)

    ;; When the slot w/out an initarg HAS been changed
    (oset persist-simple-1 slot3 3)
    (persist-test-save-and-compare persist-simple-1)
    (delete-file (oref persist-simple-1 file))))

;;; Slot Writers
;;
;; Replica of the test in eieio-tests.el -

(defclass persist-:printer (eieio-persistent)
  ((slot1 :initarg :slot1
          :initform 'moose
          :printer PO-slot1-printer)
   (slot2 :initarg :slot2
          :initform "foo"))
  "A Persistent object with two initializable slots.")

(defun PO-slot1-printer (slotvalue)
  "Print the slot value SLOTVALUE to stdout.
Assume SLOTVALUE is a symbol of some sort."
  (princ "'")
  (princ (symbol-name slotvalue))
  (princ " ;; RAN PRINTER")
  nil)

(ert-deftest eieio-test-persist-printer ()
  (let ((persist-:printer-1
         (persist-:printer "persist" :slot1 'goose :slot2 "testing"
                           :file (concat default-directory "test-ps2.pt"))))
    (should persist-:printer-1)
    (persist-test-save-and-compare persist-:printer-1)

    (let* ((find-file-hook nil)
           (tbuff (find-file-noselect "test-ps2.pt"))
           )
      (condition-case nil
          (unwind-protect
              (with-current-buffer tbuff
                (goto-char (point-min))
                (re-search-forward "RAN PRINTER"))
            (kill-buffer tbuff))
        (error "persist-:printer-1's Slot1 printer function didn't work.")))
    (delete-file (oref persist-:printer-1 file))))

;;; Slot with Object
;;
;; A slot that contains another object that isn't persistent
(defclass persist-not-persistent ()
  ((slot1 :initarg :slot1
          :initform 1)
   (slot2 :initform 2))
  "Class for testing persistent saving of an object that isn't
persistent.  This class is instead used as a slot value in a
persistent class.")

(defclass persistent-with-objs-slot (eieio-persistent)
  ((pnp :initarg :pnp
        :type (or null persist-not-persistent)
        :initform nil))
  "Class for testing the saving of slots with objects in them.")

(ert-deftest eieio-test-non-persistent-as-slot ()
  (let ((persist-wos
         (persistent-with-objs-slot
          "persist wos 1"
          :pnp (persist-not-persistent "pnp 1" :slot1 3)
          :file (concat default-directory "test-ps3.pt"))))

    (persist-test-save-and-compare persist-wos)
    (delete-file (oref persist-wos file))))

;;; Slot with Object child of :type
;;
;; A slot that contains another object that isn't persistent
(defclass persist-not-persistent-subclass (persist-not-persistent)
  ((slot3 :initarg :slot1
          :initform 1)
   (slot4 :initform 2))
  "Class for testing persistent saving of an object subclass that isn't
persistent.  This class is instead used as a slot value in a
persistent class.")

(defclass persistent-with-objs-slot-subs (eieio-persistent)
  ((pnp :initarg :pnp
        :type (or null persist-not-persistent)
        :initform nil))
  "Class for testing the saving of slots with objects in them.")

(ert-deftest eieio-test-non-persistent-as-slot-child ()
  (let ((persist-woss
         (persistent-with-objs-slot-subs
          "persist woss 1"
          :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3)
          :file (concat default-directory "test-ps4.pt"))))

    (persist-test-save-and-compare persist-woss)
    (delete-file (oref persist-woss file))))

;; A slot that can contain one of two different classes, to exercise
;; the `or' slot type.

(defclass persistent-random-class ()
  ())

(defclass persistent-multiclass-slot (eieio-persistent)
  ((slot1 :initarg :slot1
          :type (or persistent-random-class null persist-not-persistent))
   (slot2 :initarg :slot2
          :type (or persist-not-persistent persist-random-class null))))

(ert-deftest eieio-test-multiple-class-slot ()
  (let ((persist
         (persistent-multiclass-slot "random string"
          :slot1 (persistent-random-class)
          :slot2 (persist-not-persistent)
          :file (concat default-directory "test-ps5.pt"))))
    (unwind-protect
        (persist-test-save-and-compare persist)
     (ignore-errors (delete-file (oref persist file))))))

;;; Slot with a list of Objects
;;
;; A slot that contains another object that isn't persistent
(defclass persistent-with-objs-list-slot (eieio-persistent)
  ((pnp :initarg :pnp
        :type (list-of persist-not-persistent)
        :initform nil))
  "Class for testing the saving of slots with objects in them.")

(ert-deftest eieio-test-slot-with-list-of-objects ()
  (let ((persist-wols
         (persistent-with-objs-list-slot
          "persist wols 1"
          :pnp (list (persist-not-persistent "pnp 1" :slot1 3)
                     (persist-not-persistent "pnp 2" :slot1 4)
                     (persist-not-persistent "pnp 3" :slot1 5))
          :file (concat default-directory "test-ps5.pt"))))

    (persist-test-save-and-compare persist-wols)
    (delete-file (oref persist-wols file))))

(defclass person ()
  ((name :type string :initarg :name)))

(defclass classy (eieio-persistent)
  ((teacher
    :type person
    :initarg :teacher)
   (students
    :initarg :students :initform (make-hash-table))))

(ert-deftest eieio-test-persist-hash-and-objects ()
  (let* ((jane (make-instance 'person :name "Jane"))
         (bob  (make-instance 'person :name "Bob"))
         (class (make-instance 'classy
                               :teacher jane
                               :file (concat default-directory "classy-" 
emacs-version ".eieio"))))
    (puthash "Bob" bob (slot-value class 'students))
    (persist-test-save-and-compare class)
    (delete-file (oref class file))))


;;; eieio-test-persist.el ends here