[elpa] externals/ebdb 7bed578 11/33: Provide more careful control of finding related records

[Eric Abrahamsen]

branch: externals/ebdb
commit 7bed578e827be49a337ad715f6c9d67b3a98eb9c
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>

    Provide more careful control of finding related records
    
    * ebdb.el (ebdb-related-unfound): New error.
      (ebdb-record-related): Raise the new error in this method, if no
      related record is found. Also, raise it in the base method.
      (ebdb-init-field, ebdb-delete-field, ebdb-string): Use method and
      error in these methods for role fields.
      (ebdb-record-related): Raise the error in all implementations of
      this method.
    * ebdb-com.el (ebdb-fmt-field): We can now collapse formatting of
      roles-on-people and roles-on-organizations into one method.
      (ebdb-follow-related): Handle error here.
    * ebdb-test.el (ebdb-test-with-records): Also shadow the
      ebdb-org-hashtable variable, even though we didn't end up using it
      here.
      (ebdb-cant-find-related-role): New sanity test for raising the
      error.
      (ebdb-unload-db-with-relations): New test for breaking cross-db
      relations.
---
 ebdb-com.el  |  58 +++++++++++++------------------
 ebdb-test.el |  44 ++++++++++++++++++++++-
 ebdb.el      | 112 ++++++++++++++++++++++++++++++++++++-----------------------
 3 files changed, 135 insertions(+), 79 deletions(-)

diff --git a/ebdb-com.el b/ebdb-com.el
index 3310fc0..c42cc08 100644
--- a/ebdb-com.el
+++ b/ebdb-com.el
@@ -471,32 +471,21 @@ property is the field instance itself."
 (cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter-ebdb)
                              (field ebdb-field-role)
                              _style
-                             (record ebdb-record-organization))
-  (let* ((person (ebdb-gethash (slot-value field 'record-uuid) 'uuid))
-        (mail (slot-value field 'mail))
-        (value (if mail
-                   (format "%s (%s)"
-                           (ebdb-string person)
-                           (ebdb-fmt-field fmt mail 'oneline record))
-                 (ebdb-string person))))
-    (if (slot-value field 'defunct)
-       (propertize value 'face 'ebdb-defunct)
-      value)))
-
-(cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter-ebdb)
-                             (field ebdb-field-role)
-                             _style
-                             (record ebdb-record-person))
-  (let* ((org (ebdb-gethash (slot-value field 'org-uuid) 'uuid))
-        (mail (slot-value field 'mail))
-        (value (if mail
-                   (format "%s (%s)"
-                           (ebdb-string org)
-                           (ebdb-fmt-field fmt mail 'oneline record))
-                 (ebdb-string org))))
-    (if (slot-value field 'defunct)
-       (propertize value 'face 'ebdb-defunct)
-      value)))
+                             (record ebdb-record))
+  (with-slots (mail defunct) field
+    (let* ((rec-string
+           (condition-case nil
+               (ebdb-record-name
+                (ebdb-record-related record field))
+             (ebdb-related-unfound "record not loaded")))
+          (value (if mail
+                     (format "%s (%s)"
+                             rec-string
+                             (ebdb-fmt-field fmt mail 'oneline record))
+                   rec-string)))
+      (if defunct
+         (propertize value 'face 'ebdb-defunct)
+       value))))
 
 (defsubst ebdb-indent-string (string column)
   "Indent nonempty lines in STRING to COLUMN (except first line).
@@ -1192,14 +1181,15 @@ With prefix N move backwards N (sub)fields."
   related record."
   (interactive (list (ebdb-current-record)
                     (ebdb-current-field)))
-  (let ((related (ebdb-record-related record field)))
-    (if related
-       (ebdb-display-records (cons related
-                                   (mapcar #'car ebdb-records))
-                             ebdb-default-multiline-formatter
-                             t)
-      (message "Field %s provides no relationships"
-              (ebdb-field-readable-name field)))))
+  (condition-case nil
+      (ebdb-display-records
+       (cons (ebdb-record-related record field)
+            (mapcar #'car ebdb-records))
+       ebdb-default-multiline-formatter
+       t)
+    (ebdb-related-unfound
+     (message "Field %s provides no relationships"
+             (ebdb-field-readable-name field)))))
 
 (defun ebdb-toggle-record-mark (record &optional mark)
   "Mark or unmark RECORD."
diff --git a/ebdb-test.el b/ebdb-test.el
index f46c7a5..d676759 100644
--- a/ebdb-test.el
+++ b/ebdb-test.el
@@ -27,6 +27,7 @@
 
 (require 'ert)
 (require 'ebdb)
+(require 'ebdb-com)
 (require 'ebdb-snarf)
 (require 'ebdb-vcard)
 
@@ -40,7 +41,7 @@
                                                :dirty t))
         ebdb-db-list)
      ;; Save sets sync-time.
-     (ebdb-db-save ,(car db-and-filename))
+     (ebdb-db-save ,(car db-and-filename) nil t)
      ;; Load adds to `ebdb-db-list'.
      (ebdb-db-load ,(car db-and-filename))
      (unwind-protect
@@ -52,6 +53,7 @@
   "Don't let EBDB tests pollute `ebdb-record-tracker'."
   (declare (indent 0) (debug t))
   `(let ((ebdb-hashtable (make-hash-table :test 'equal))
+        (ebdb-org-hashtable (make-hash-table :test 'equal))
         ebdb-record-tracker)
      ,@body))
 
@@ -130,6 +132,46 @@
            rec (ebdb-parse 'ebdb-field-mail "address@hidden"))
           :type 'ebdb-readonly-db))))))
 
+(ert-deftest ebdb-cant-find-related-role ()
+  "Find org record from a role field.
+If it doesn't exist, raise `ebdb-related-unfound'."
+  (ebdb-test-with-records
+   (let ((rec (make-instance
+              'ebdb-record-person
+              :uuid (make-instance 'ebdb-field-uuid :uuid "bob")))
+        (role
+         (make-instance
+          'ebdb-field-role :record-uuid "bob"
+          :org-uuid "bogus")))
+     (ebdb-record-insert-field rec role)
+     (should-error
+      (ebdb-record-related rec role)
+      :type 'ebdb-related-unfound))))
+
+(ert-deftest ebdb-unload-db-with-relations ()
+  "Cross-db relations break correctly when a db is unloaded."
+  (ebdb-test-with-records
+    (ebdb-test-with-database (db1 ebdb-test-database-1)
+      (ebdb-test-with-database (db2 ebdb-test-database-2)
+       (let ((rec1 (make-instance 'ebdb-record-person))
+             (rec2 (make-instance 'ebdb-record-person))
+             rel-f)
+         (ebdb-db-add-record db1 rec1)
+         (ebdb-db-add-record db2 rec2)
+         (setq rel-f (make-instance
+                      'ebdb-field-relation :rel-uuid (ebdb-record-uuid rec2)))
+         (ebdb-record-insert-field rec1 rel-f)
+         (ebdb-db-unload db2)
+         (should-error
+          (ebdb-record-related rec1 rel-f)
+          :type 'ebdb-related-unfound)
+         (should
+          (string=
+           (ebdb-fmt-field
+            ebdb-default-multiline-formatter
+            rel-f 'oneline rec1)
+           "record not loaded")))))))
+
 (ert-deftest ebdb-test-with-record-edits ()
   "Test the `ebdb-with-record-edits' macro."
   (ebdb-test-with-records
diff --git a/ebdb.el b/ebdb.el
index 1b3ebe3..184f90f 100644
--- a/ebdb.el
+++ b/ebdb.el
@@ -801,6 +801,8 @@ if you want to call `ebdb-change-hook' and update the 
record unconditionally.")
 
 (define-error 'ebdb-duplicate-uuid "Duplicate EBDB UUID" 'ebdb-error)
 
+(define-error 'ebdb-related-unfound "Could not find related record" 
'ebdb-error)
+
 (define-error 'ebdb-unsynced-db "EBDB DB unsynced" 'ebdb-error)
 
 (define-error 'ebdb-disabled-db "EBDB DB disabled" 'ebdb-error)
@@ -1399,51 +1401,59 @@ first one."
 
 (cl-defmethod ebdb-init-field ((role ebdb-field-role) &optional record)
   (when record
-    (let* ((org-uuid (slot-value role 'org-uuid))
-          (org (ebdb-gethash org-uuid 'uuid))
-          (org-string (if org (ebdb-record-name org)
-                        "record not loaded"))
-          ;; TODO: Guard against org-entry not being found.
-          (org-entry (gethash org-uuid ebdb-org-hashtable))
-          (record-uuid (ebdb-record-uuid record))
-          (role-mail (slot-value role 'mail)))
-      ;; Setting the 'record-uuid slot value when it wasn't set before
-      ;; technically means that the record is now "dirty".  That's
-      ;; okay in our current database implementation, because
-      ;; `ebdb-record-insert-field' first calls
-      ;; `ebdb-db-add-record-field', which sets the record "dirty",
-      ;; and then calls this `ebdb-init' method -- ie, record is
-      ;; "dirty" when we get here.  Theoretically, however, nothing in
-      ;; `ebdb-init-field' should change a record's slots.
-      (unless (slot-value role 'record-uuid)
-       (setf (slot-value role 'record-uuid) record-uuid))
-      (object-add-to-list (ebdb-record-cache record) 'organizations org-string)
-      ;; Init the role mail against the record.
-      (when (and role-mail (slot-value role-mail 'mail))
-       (ebdb-init-field role-mail record))
-      ;; Make sure this role is in the `ebdb-org-hashtable'.
-      (unless (member role org-entry)
-       (push role org-entry))
-      (puthash org-uuid org-entry ebdb-org-hashtable)))
+    (with-slots (org-uuid mail (role-record-uuid record-uuid)) role
+      (let* (;; TODO: Guard against org-entry not being found.
+            (org-entry (gethash org-uuid ebdb-org-hashtable))
+            (record-uuid (ebdb-record-uuid record))
+            (org-string
+             (condition-case nil
+                 (ebdb-record-name
+                  (ebdb-record-related record role))
+               (ebdb-related-unfound
+                "record not loaded"))))
+
+       ;; Setting the 'record-uuid slot value when it wasn't set before
+       ;; technically means that the record is now "dirty".  That's
+       ;; okay in our current database implementation, because
+       ;; `ebdb-record-insert-field' first calls
+       ;; `ebdb-db-add-record-field', which sets the record "dirty",
+       ;; and then calls this `ebdb-init' method -- ie, record is
+       ;; "dirty" when we get here.  Theoretically, however, nothing in
+       ;; `ebdb-init-field' should change a record's slots.
+       (unless role-record-uuid
+         (setf role-record-uuid record-uuid))
+       (object-add-to-list (ebdb-record-cache record) 'organizations 
org-string)
+       ;; Init the role mail against the record.
+       (when (and mail (slot-value mail 'mail))
+         (ebdb-init-field mail record))
+       ;; Make sure this role is in the `ebdb-org-hashtable'.
+       (unless (member role org-entry)
+         (push role org-entry))
+       (puthash org-uuid org-entry ebdb-org-hashtable))))
   (cl-call-next-method))
 
 (cl-defmethod ebdb-delete-field ((role ebdb-field-role) &optional record 
unload)
   (when record
     (let* ((org-uuid (slot-value role 'org-uuid))
-          (org (ebdb-gethash org-uuid 'uuid))
           (org-string
-           (if org
-               (ebdb-record-name org)
-             "bogus"))
+           (condition-case nil
+               (ebdb-record-name
+                (ebdb-record-related record role))
+             (ebdb-related-unfound
+              nil)))
           (org-entry (gethash org-uuid ebdb-org-hashtable))
           (record-uuid (ebdb-record-uuid record)))
       (setq org-entry (delete role org-entry))
       (if org-entry
          (puthash org-uuid org-entry ebdb-org-hashtable)
        (remhash org-uuid ebdb-org-hashtable))
-      (when (null (assoc-string record-uuid (object-assoc-list 'record-uuid 
org-entry)))
+      (when (and org-string
+                (null (assoc-string
+                       record-uuid
+                       (object-assoc-list 'record-uuid org-entry))))
        ;; RECORD no long has any roles at ORG.
-       (object-remove-from-list (ebdb-record-cache record) 'organizations 
org-string))))
+       (object-remove-from-list (ebdb-record-cache record)
+                                'organizations org-string))))
   (when (slot-value role 'mail)
     (ebdb-delete-field (slot-value role 'mail) record unload))
   (cl-call-next-method))
@@ -1464,10 +1474,12 @@ first one."
   ;; This is used in person records headers, so it just shows the
   ;; organization name. Perhaps this could have a multi-line option
   ;; later.
-  (let ((org (ebdb-gethash (slot-value role 'org-uuid) 'uuid)))
-    (if org
-       (ebdb-string org)
-      "record not loaded")))
+  (let ((rec (ebdb-gethash (slot-value role 'record-uuid) 'uuid)))
+    (condition-case nil
+       (ebdb-record-name
+        (ebdb-record-related rec role))
+      (ebdb-related-unfound
+       "record not loaded"))))
 
 ;;; Mail fields.
 
@@ -2596,11 +2608,6 @@ only return fields that are suitable for user editing.")
 (cl-defmethod ebdb-record-alt-names ((record ebdb-record))
   (slot-value (ebdb-record-cache record) 'alt-names))
 
-(cl-defmethod ebdb-record-related ((_record ebdb-record)
-                                  (_field ebdb-field))
-  "Provide a base method that does nothing."
-  nil)
-
 (when (fboundp 'cl-print-object)
   (cl-defmethod cl-print-object ((record ebdb-record) stream)
     (princ (format "#<%S %s>"
@@ -2608,6 +2615,17 @@ only return fields that are suitable for user editing.")
                   (ebdb-string record))
           stream)))
 
+(cl-defgeneric ebdb-record-related (record field)
+  "Return the record related to RECORD, according to FIELD.
+This method is implemented for role fields, and relation fields.
+It is responsible for returning the related record as specified
+by the field, or else raising the error `ebdb-related-unfound'.")
+
+(cl-defmethod ebdb-record-related ((_record ebdb-record)
+                                  (_field ebdb-field))
+  "Provide a base method that raises `ebdb-related-unfound'."
+  (signal 'ebdb-related-unfound))
+
 ;; The following functions are here because they need to come after
 ;; `ebdb-record' has been defined.
 
@@ -2958,11 +2976,15 @@ priority."
 
 (cl-defmethod ebdb-record-related ((_record ebdb-record-person)
                                   (field ebdb-field-relation))
-  (ebdb-gethash (slot-value field 'rel-uuid) 'uuid))
+  (or
+   (ebdb-gethash (slot-value field 'rel-uuid) 'uuid)
+   (signal 'ebdb-related-unfound (list (slot-value field 'rel-uuid)))))
 
 (cl-defmethod ebdb-record-related ((_record ebdb-record-person)
                                   (field ebdb-field-role))
-  (ebdb-gethash (slot-value field 'org-uuid) 'uuid))
+  (or
+   (ebdb-gethash (slot-value field 'org-uuid) 'uuid)
+   (signal 'ebdb-related-unfound (list (slot-value field 'org-uuid)))))
 
 (cl-defmethod ebdb-record-organizations ((record ebdb-record-person))
   "Return a list of organization string names from RECORD's cache."
@@ -3202,7 +3224,9 @@ appropriate person record."
 
 (cl-defmethod ebdb-record-related ((_record ebdb-record-organization)
                                   (field ebdb-field-role))
-  (ebdb-gethash (slot-value field 'record-uuid) 'uuid))
+  (or
+   (ebdb-gethash (slot-value field 'record-uuid) 'uuid)
+   (signal 'ebdb-related-unfound (list (slot-value field 'record-uuid)))))
 
 (cl-defmethod ebdb-record-add-org-role ((record ebdb-record-person)
                                     (org ebdb-record-organization)