[isidorus-cvs] r711 - in trunk/src: json/isidorus-json model rest_interface

lgiessmann at common-lisp.net lgiessmann at common-lisp.net
Thu Aug 4 19:01:14 UTC 2011


Author: lgiessmann
Date: Thu Aug  4 12:01:13 2011
New Revision: 711

Log:
trunk: datamodel: improved caching of serialized fragments

Modified:
   trunk/src/json/isidorus-json/json_exporter.lisp
   trunk/src/model/changes.lisp
   trunk/src/model/datamodel.lisp
   trunk/src/rest_interface/set-up-json-interface.lisp

Modified: trunk/src/json/isidorus-json/json_exporter.lisp
==============================================================================
--- trunk/src/json/isidorus-json/json_exporter.lisp	Thu Aug  4 09:42:28 2011	(r710)
+++ trunk/src/json/isidorus-json/json_exporter.lisp	Thu Aug  4 12:01:13 2011	(r711)
@@ -479,46 +479,4 @@
 		  (json:encode-json-to-string (getf entry :variable)) ":"
 		  (json:encode-json-to-string (getf entry :result)) ",")
 		 j-str))
-	  (concat (subseq j-str 0 (- (length j-str) 1)) "}")))))
-
-
-;; =============================================================================
-;; --- json data fragment-serializer-cache -------------------------------------
-;; =============================================================================
-
-(defgeneric set-fragment-cache (fragment)
-  (:documentation "sets the fragment cache, no matter if the
-                   fragment chaged or not.")
-  (:method ((fragment FragmentC))
-    (let ((top (topic fragment)))
-      (setf (slot-value fragment 'serializer-notes)
-	    (list :psis (length (psis top :revision 0))
-		  :iis (length (item-identifiers top :revision 0))
-		  :sls (length (locators top :revision 0))
-		  :names (length (names top :revision 0))
-		  :occurrences (length (occurrences top :revision 0))
-		  :roles (length (player-in-roles top :revision 0))))
-      (setf (slot-value fragment 'serializer-cache)
-	    (json-exporter:export-construct-as-isidorus-json-string
-	     fragment :revision 0))
-      (serializer-cache fragment))))
-
-
-(defgeneric serialize-fragment (fragment)
-  (:documentation "returns a string that represent the isidours-json
-                   serialization of the passed fragment instance.
-                   This method uses the fragments serializer-cache
-                   slot to perform faster, i.e. if the fragment has
-                   not changed since the last time, the serializer-cache
-                   is returned, otherwise the serialization is invoked
-                   again.")
-  (:method ((fragment FragmentC))
-    (cond ((null (serializer-notes fragment))
-	   (set-fragment-cache fragment))
-	  ((serializer-notes-changed-p fragment)
-	   (set-fragment-cache fragment))
-	  (t
-	   (serializer-cache fragment)))))
-	   
-	  
-		 
\ No newline at end of file
+	  (concat (subseq j-str 0 (- (length j-str) 1)) "}")))))
\ No newline at end of file

Modified: trunk/src/model/changes.lisp
==============================================================================
--- trunk/src/model/changes.lisp	Thu Aug  4 09:42:28 2011	(r710)
+++ trunk/src/model/changes.lisp	Thu Aug  4 12:01:13 2011	(r711)
@@ -332,18 +332,6 @@
                                      that can contain any string format,
                                      e.g. JTM, XTM, ... depending on the
                                      setter method.")
-   (serializer-notes :type List
-		     :initform nil
-		     :initarg :serializer-notes
-		     :documentation "contains a list of the forms
-                                     (:psis <int> :iis <int> :sls <int>
-                                      :names <int> :occurrences <int>
-                                      :roles <int>) that indicates the
-                                     number of elements this fragment's
-                                     topic is bound to. It is only necessary
-                                     to recognize mark-as-deleted elements,
-                                     since newly added elements will result
-                                     in a completely new fragment.")
    (referenced-topics
     :type list
     :initarg :referenced-topics
@@ -432,10 +420,12 @@
         (find-associations top :revision revision)))
 
 
-(defun create-latest-fragment-of-topic (topic-psi)
+(defun create-latest-fragment-of-topic (topic-or-psi)
   "Returns the latest fragment of the passed topic-psi"
-  (declare (string topic-psi))
-  (let ((topic (get-latest-topic-by-psi topic-psi)))
+  (declare (type (or TopicC String) topic-or-psi))
+  (let ((topic (if (stringp topic-or-psi)
+		   (get-latest-topic-by-psi topic-or-psi)
+		   topic-or-psi)))
     (when topic
       (let ((start-revision
 	     (start-revision
@@ -459,10 +449,12 @@
 			     :topic topic)))))))
 
 
-(defun get-latest-fragment-of-topic (topic-psi)
+(defun get-latest-fragment-of-topic (topic-or-psi)
   "Returns the latest existing fragment of the passed topic-psi."
-  (declare (string topic-psi))
-  (let ((topic (get-latest-topic-by-psi topic-psi)))
+  (declare (type (or String TopicC) topic-or-psi))
+  (let ((topic (if (stringp topic-or-psi)
+		   (get-latest-topic-by-psi topic-or-psi)
+		   topic-or-psi)))
     (when topic
       (let ((existing-fragments
 	     (elephant:get-instances-by-value 'FragmentC 'topic topic)))
@@ -480,30 +472,19 @@
       (slot-value fragment 'serializer-cache))))
 
 
-(defgeneric serializer-notes (fragment)
-  (:documentation "returns the slot value of serializer-notes or nil,
-                   if it is unbound.")
-  (:method ((fragment FragmentC))
-    (when (slot-boundp fragment 'serializer-notes)
-      (slot-value fragment 'serializer-notes))))
-
-
-(defgeneric serializer-notes-changed-p (fragment)
-  (:documentation "Returns t if the serializer-notes slot contains
-                   a value that does not correspond to the actual
-                   values of the fragment.")
-  (:method ((fragment FragmentC))
-    (let ((top (topic fragment))
-	  (sn (serializer-notes fragment)))
-      (or (/= (length (psis top :revision 0))
-	      (getf sn :psis))
-	  (/= (length (item-identifiers top :revision 0))
-	      (getf sn :iis))
-	  (/= (length (locators top :revision 0))
-	      (getf sn :sls))
-	  (/= (length (names top :revision 0))
-	      (getf sn :names))
-	  (/= (length (occurrences top :revision 0))
-	      (getf sn :occurrences))
-	  (/= (length (player-in-roles top :revision 0))
-	      (getf sn :roles))))))
\ No newline at end of file
+(defgeneric serialize-fragment (fragment serializer)
+  (:documentation "returns a string that represents the serialization
+                   of the passed fragment instance.
+                   This method uses the fragments serializer-cache
+                   slot to perform faster, i.e. if the fragment was
+                   once serialized, the next time the cached serialized
+                   data is used again.")
+  (:method ((fragment FragmentC) (serializer Function))
+    (cond ((null (serializer-cache fragment))
+	   (setf (slot-value fragment 'serializer-cache)
+		 (funcall serializer fragment)))
+	  (t
+	   (serializer-cache fragment)))))
+	   
+	  
+		 
\ No newline at end of file

Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp	Thu Aug  4 09:42:28 2011	(r710)
+++ trunk/src/model/datamodel.lisp	Thu Aug  4 12:01:13 2011	(r711)
@@ -43,9 +43,8 @@
 	   :FragmentC
 
 	   ;;methods, functions and macros
-	   :serializer-notes
+	   :serialize-fragment
 	   :serializer-cache
-	   :serializer-notes-changed-p
 	   :instanceOf-association-p
 	   :has-identifier
 	   :get-all-identifiers-of-construct

Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp	Thu Aug  4 09:42:28 2011	(r710)
+++ trunk/src/rest_interface/set-up-json-interface.lisp	Thu Aug  4 12:01:13 2011	(r711)
@@ -487,18 +487,53 @@
 					    :force-text t)))
 	    (with-writer-lock
 	      (handler-case
-		  (let ((result (json-delete-interface:mark-as-deleted-from-json
-				 json-data :revision (d:get-revision))))
+		  (let* ((rev (d:get-revision))
+			 (result (json-delete-interface:mark-as-deleted-from-json
+				  json-data :revision rev)))
 		    (if result
 			(progn
-			  (when (typep result 'd:TopicC)
-			    (append ;;the append function is used only for suppress
-			            ;;style warnings of unused delete return values
-			     (setf *type-table*
-				   (delete (elephant::oid result) *type-table*))
-			     (setf *instance-table*
-				   (delete (elephant::oid result) *instance-table*))
-			     (remove-topic-from-list result)))
+			  (cond ((typep result 'd:TopicC)
+				 (setf *type-table*
+				       (delete (elephant::oid result) *type-table*))
+				 (setf *instance-table*
+				       (delete (elephant::oid result) *instance-table*))
+				 (remove-topic-from-list result)
+				 (map nil (lambda(fragment)
+					    (when (eql (d:topic fragment) result)
+					      (elephant:drop-instance fragment)))
+				      (elephant:get-instances-by-value
+				       'd:FragmentC 'd:topic result)))
+				((typep result 'd:AssociationC)
+				 (let ((players
+					(delete-if
+					 #'null
+					 (map 'list
+					      (lambda(role)
+						(let ((top (player role
+								   :revision (1- rev))))
+						  (when (psis top :revision 0)
+						    top)))
+					      (roles result :revision (1- rev))))))
+				   (map nil
+					(lambda(plr)
+					  (map nil #'elephant:drop-instance 
+					       (elephant:get-instances-by-value
+						'd:FragmentC 'd:topic plr))
+					  (d:serialize-fragment
+					   (create-latest-fragment-of-topic plr)
+					   (fragment-serializer)))
+					players)))
+				((or (typep result 'd:NameC)
+				     (typep result 'd:OccurrenceC))
+				 (let ((top (parent result :revision (1- rev))))
+				   (when (and top (psis top :revision 0))
+				     (map nil (lambda(frg)
+						(setf (slot-value frg 'd::serializer-cache) nil)
+						(d:serialize-fragment
+						 (get-latest-fragment-of-topic top)
+						 (fragment-serializer)))
+					  (elephant:get-instances-by-value
+					   'd:FragmentC 'd:topic top))))))
 			  (format nil "")) ;operation succeeded
 			(progn
 			  (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
@@ -653,16 +688,24 @@
 (defun init-fragments ()
   "Creates fragments of all topics that have a PSI."
   (format t "creating fragments: ")
-  (map 'list #'(lambda(top)
-		 (let ((psis-of-top (psis top)))
-		   (when psis-of-top
-		     (format t ".")
-		     (let ((fragment
-			    (create-latest-fragment-of-topic
-			     (uri (first psis-of-top)))))
-		       (json-exporter:serialize-fragment fragment)
-		       fragment))))
-       (elephant:get-instances-by-class 'd:TopicC)))
+  (map
+   nil
+   (lambda(top)
+     (let ((psis-of-top (psis top)))
+       (when psis-of-top
+	 (format t ".")
+	 (let ((fragment
+		(create-latest-fragment-of-topic
+		 (uri (first psis-of-top)))))
+	   (d:serialize-fragment fragment (fragment-serializer))
+	   fragment))))
+	 (elephant:get-instances-by-class 'd:TopicC)))
+
+
+(defun fragment-serializer ()
+  (lambda(frg)
+    (json-exporter:export-construct-as-isidorus-json-string
+     frg :revision 0)))
 
 
 (defun update-list (top psis)




More information about the Isidorus-cvs mailing list