From lgiessmann at common-lisp.net Wed Sep 1 12:09:44 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 01 Sep 2010 08:09:44 -0400 Subject: [isidorus-cvs] r312 - branches/new-datamodel/playground Message-ID: Author: lgiessmann Date: Wed Sep 1 08:09:38 2010 New Revision: 312 Log: added a test file for the threading problem with hunchentoot Added: branches/new-datamodel/playground/threading_debugging.lisp Modified: branches/new-datamodel/playground/isidorus_test.sh Modified: branches/new-datamodel/playground/isidorus_test.sh ============================================================================== --- branches/new-datamodel/playground/isidorus_test.sh (original) +++ branches/new-datamodel/playground/isidorus_test.sh Wed Sep 1 08:09:38 2010 @@ -10,9 +10,9 @@ Nil="false"; doReq1=$T; -doReq2=$Nil; -doReq3=$Nil; -doReq4=$Nil; +doReq2=$T; +doReq3=$T; +doReq4=$T; dir1="req1"; dir2="req2"; @@ -57,25 +57,25 @@ if [ $doReq1 == $T ]; then path1=$log1$counter; result1=$res1$counter; - wget -o $path1".log" -O $result1".res" $req1; + wget -o $path1".log" -O $result1".res" $req1; fi if [ $doReq2 == $T ]; then path2=$log2$counter; result2=$res2$counter; - wget -o $path2".log" -O $result2".res" $req2; + wget -o $path2".log" -O $result2".res" $req2; fi if [ $doReq3 == $T ]; then path3=$log3$counter; result3=$res3$counter; - wget -o $path3".log" -O $result3".res" $req3; + wget -o $path3".log" -O $result3".res" $req3; fi if [ $doReq4 == $T ]; then path4=$log4$counter; result4=$res4$counter; - wget -o $path4".log" -O $result4".res" $req4; + wget -o $path4".log" -O $result4".res" $req4; fi } Added: branches/new-datamodel/playground/threading_debugging.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/threading_debugging.lisp Wed Sep 1 08:09:38 2010 @@ -0,0 +1,67 @@ +(asdf:operate 'asdf:load-op :isidorus) +(xml-importer:setup-repository "textgrid.xtm" "data_base" + :tm-id "http://ztt.fh-worms.de/textgrid.xtm" + :xtm-id "textgrid.xtm") + + +(defun return-all-tmcl-types-test-handler (&optional param) + "similar to hunchentoot's corresponding handler - but without hunchentoot's + variables, e.g. hunchentoot:content-type, ..." + (declare (ignorable param)) + (handler-case (let ((topic-types + (isidorus-threading:with-reader-lock + (json-tmcl::return-all-tmcl-types :revision 0)))) + (json:encode-json-to-string + (map 'list #'(lambda(y) + (map 'list #'d:uri y)) + (map 'list #'d:psis topic-types)))) + (condition (err) (error (format nil "~a" err))))) + + +(defun return-all-topic-psis-test-handler (&optional param) + "similar to hunchentoot's corresponding handler - but without hunchentoot's + variables, e.g. hunchentoot:content-type, ..." + (declare (ignorable param)) + (handler-case (isidorus-threading:with-reader-lock + (json-exporter::get-all-topic-psis :revision 0)) + (condition (err) (error (format nil "~a" err))))) + + +(defun my-thread-function-1 () + (dotimes (i 100) + (return-all-tmcl-types-test-handler))) + + +(defun programm-1 (thread-fun) + (defvar *thread-1* (bordeaux-threads:make-thread thread-fun)) + (defvar *thread-2* (bordeaux-threads:make-thread thread-fun))) + + +(defun programm-2 (thread-fun) + (let ((thread-1 nil) + (thread-2 nil) + (max-iterations 50)) + (do ((c1 0 (+ c1 0)) + (c2 0 (+ c2 0))) + ((and (>= c1 max-iterations) (>= c2 max-iterations))) + (when (or (not thread-1) (not (bordeaux-threads:thread-alive-p thread-1))) + (setf thread-1 (bordeaux-threads:make-thread thread-fun)) + (incf c1) + (format t "c1: ~a c2: ~a~%" c1 c2)) + (when (or (not thread-2) (not (bordeaux-threads:thread-alive-p thread-2))) + (setf thread-2 (bordeaux-threads:make-thread thread-fun)) + (incf c2) + (format t "c1: ~a c2: ~a~%" c1 c2))))) + + + + + + + + +(defun main() + (programm-2 #'return-all-tmcl-types-test-handler)) + + +(main) \ No newline at end of file From lgiessmann at common-lisp.net Thu Sep 2 13:57:25 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 02 Sep 2010 09:57:25 -0400 Subject: [isidorus-cvs] r313 - branches/new-datamodel/playground Message-ID: Author: lgiessmann Date: Thu Sep 2 09:57:24 2010 New Revision: 313 Log: added some more examples Modified: branches/new-datamodel/playground/threading_debugging.lisp Modified: branches/new-datamodel/playground/threading_debugging.lisp ============================================================================== --- branches/new-datamodel/playground/threading_debugging.lisp (original) +++ branches/new-datamodel/playground/threading_debugging.lisp Thu Sep 2 09:57:24 2010 @@ -1,3 +1,4 @@ +(require :asdf) (asdf:operate 'asdf:load-op :isidorus) (xml-importer:setup-repository "textgrid.xtm" "data_base" :tm-id "http://ztt.fh-worms.de/textgrid.xtm" @@ -18,6 +19,21 @@ (condition (err) (error (format nil "~a" err))))) +(defun return-all-tmcl-instances-test-handler(&optional param) + "similar to hunchentoot's corresponding handler - but without hunchentoot's + variables, e.g. hunchentoot:content-type, ..." + (declare (ignorable param)) + (handler-case (let ((topic-instances + (isidorus-threading:with-reader-lock + (json-tmcl::return-all-tmcl-instances :revision 0)))) + (json:encode-json-to-string + (map 'list #'(lambda(y) + (map 'list #'d:uri y)) + (map 'list #'d:psis topic-instances)))) + (condition (err) (error (format nil "~a" err))))) + + + (defun return-all-topic-psis-test-handler (&optional param) "similar to hunchentoot's corresponding handler - but without hunchentoot's variables, e.g. hunchentoot:content-type, ..." @@ -33,14 +49,16 @@ (defun programm-1 (thread-fun) + "bordeaux-threads" (defvar *thread-1* (bordeaux-threads:make-thread thread-fun)) (defvar *thread-2* (bordeaux-threads:make-thread thread-fun))) (defun programm-2 (thread-fun) + "bordeaux-threads" (let ((thread-1 nil) (thread-2 nil) - (max-iterations 50)) + (max-iterations 150)) (do ((c1 0 (+ c1 0)) (c2 0 (+ c2 0))) ((and (>= c1 max-iterations) (>= c2 max-iterations))) @@ -54,14 +72,35 @@ (format t "c1: ~a c2: ~a~%" c1 c2))))) +(defun programm-3 (thread-fun) + "sb-thread" + (defvar *thread-3* (sb-thread:make-thread thread-fun)) + (defvar *thread-4* (sb-thread:make-thread thread-fun))) +(defun programm-4 (thread-fun) + "sb-thread" + (let ((thread-1 nil) + (thread-2 nil) + (max-iterations 150)) + (do ((c1 0 (+ c1 0)) + (c2 0 (+ c2 0))) + ((and (>= c1 max-iterations) (>= c2 max-iterations))) + (when (or (not thread-1) (not (sb-thread:thread-alive-p thread-1))) + (setf thread-1 (sb-thread:make-thread thread-fun)) + (incf c1) + (format t "c1: ~a c2: ~a~%" c1 c2)) + (when (or (not thread-2) (not (sb-thread:thread-alive-p thread-2))) + (setf thread-2 (sb-thread:make-thread thread-fun)) + (incf c2) + (format t "c1: ~a c2: ~a~%" c1 c2))))) + (defun main() - (programm-2 #'return-all-tmcl-types-test-handler)) + (programm-4 #'return-all-tmcl-types-test-handler)) (main) \ No newline at end of file From lgiessmann at common-lisp.net Tue Sep 7 10:50:41 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 07 Sep 2010 06:50:41 -0400 Subject: [isidorus-cvs] r314 - trunk/src/ajax/javascripts Message-ID: Author: lgiessmann Date: Tue Sep 7 06:50:41 2010 New Revision: 314 Log: The ajax host prefix in constants.js is set automatically --> different mappings works for the same server now; the admin needn't set the host prefix manually Modified: trunk/src/ajax/javascripts/constants.js Modified: trunk/src/ajax/javascripts/constants.js ============================================================================== --- trunk/src/ajax/javascripts/constants.js (original) +++ trunk/src/ajax/javascripts/constants.js Tue Sep 7 06:50:41 2010 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://localhost:8000/"; /*"192.168.178.23:8000/"; // of the form "http://(.+)/"*/ +var HOST_PREF = getHostPref(); var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; @@ -22,9 +22,9 @@ var INSTANCE_PSIS_URL = HOST_PREF + "json/tmcl/instances/"; var OWN_URL = HOST_PREF + "isidorus"; var SUMMARY_URL = HOST_PREF + "json/summary"; - var MARK_AS_DELETED_URL = HOST_PREF + "mark-as-deleted"; +var MARK_AS_DELETED_URL = HOST_PREF + "mark-as-deleted"; var TM_OVERVIEW = HOST_PREF + "json/tmcl/overview/"; -var TIMEOUT = 10000; // const TIMEOUT = 10000 --> "const" doesn't work under IE +var TIMEOUT = 20000; // const TIMEOUT = 10000 --> "const" doesn't work under IE @@ -95,4 +95,20 @@ "removeNameRow" : function(){ return "removeOccurrenceRow"; }, "removeOccurrenceRow" : function(){ return "removeNameRow"; }, "removeTopicRow" : function(){ return "removeTopicRow"; } - }; \ No newline at end of file + }; + + +// --- returns the current host prefix as string, so the user/admin needn't +// --- setting it manually +function getHostPref(){ + var splitter = "/"; + var splitterRate = 3; + var fullUrl = window.location.href; + var urlFragments = fullUrl.split("/"); + var hostPref = ""; + for(var i = 0; i !== splitterRate; ++i){ + hostPref += urlFragments[i]; + hostPref += "/"; + } + return hostPref; +} \ No newline at end of file From lgiessmann at common-lisp.net Tue Sep 7 10:50:53 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 07 Sep 2010 06:50:53 -0400 Subject: [isidorus-cvs] r315 - in branches/new-datamodel: playground src/ajax/javascripts src/rest_interface src/unit_tests Message-ID: Author: lgiessmann Date: Tue Sep 7 06:50:53 2010 New Revision: 315 Log: The ajax host prefix in constants.js is set automatically --> different mappings works for the same server now; the admin needn't set the host prefix manually Added: branches/new-datamodel/playground/url_test.html branches/new-datamodel/playground/url_test.js Modified: branches/new-datamodel/src/ajax/javascripts/constants.js branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp branches/new-datamodel/src/unit_tests/atom_test.lisp Added: branches/new-datamodel/playground/url_test.html ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/url_test.html Tue Sep 7 06:50:53 2010 @@ -0,0 +1,48 @@ + + + + + + + + + + + + + + + + isidorus + + + + + + + + + + + + + +
+

URL:

+
+ + Added: branches/new-datamodel/playground/url_test.js ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/url_test.js Tue Sep 7 06:50:53 2010 @@ -0,0 +1,16 @@ +function entryPoint(){ + var elem = getElem(); + var url = window.location.href; + var urlFrags = url.split("/"); + var newUrl = ""; + for(var i = 0; i !== urlFrags.length; ++i){ + if (newUrl.length !== 0) newUrl += "/"; + newUrl += urlFrags[i]; + } + elem.innerHTML = " " + newUrl; +} + + +function getElem(){ + return document.getElementById("content"); +} \ No newline at end of file Modified: branches/new-datamodel/src/ajax/javascripts/constants.js ============================================================================== --- branches/new-datamodel/src/ajax/javascripts/constants.js (original) +++ branches/new-datamodel/src/ajax/javascripts/constants.js Tue Sep 7 06:50:53 2010 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = getHostPref(); var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; @@ -90,4 +90,20 @@ "instances" : function(){ return "instances"; }, "subtypes" : function(){ return "subtypes"; }, "topicPsis" : function(){ return "topicPsis"; } - }; \ No newline at end of file + }; + + +// --- returns the current host prefix as string, so the user/admin needn't +// --- setting it manually +function getHostPref(){ + var splitter = "/"; + var splitterRate = 3; + var fullUrl = window.location.href; + var urlFragments = fullUrl.split("/"); + var hostPref = ""; + for(var i = 0; i !== splitterRate; ++i){ + hostPref += urlFragments[i]; + hostPref += "/"; + } + return hostPref; +} \ No newline at end of file Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Tue Sep 7 06:50:53 2010 @@ -133,6 +133,7 @@ (setf (hunchentoot:content-type*) "text") (format nil "Condition: \"~a\"" err))))) + (defun return-all-tmcl-instances(&optional param) "Returns all topic-psis that are valid instances of any topic type. The validity is only oriented on the typing of topics, e.g. Modified: branches/new-datamodel/src/unit_tests/atom_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/atom_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/atom_test.lisp Tue Sep 7 06:50:53 2010 @@ -103,9 +103,13 @@ (find 'atom::snapshots-feed (atom:subfeeds worms-feed) :key #'type-of))) + + (format t "~a~%~%~a~%" fragments-feed (map 'list #'atom::psi (atom:entries fragments-feed))) (is (= 11 (length (atom:entries fragments-feed)))) - (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" (link fragments-feed))) - (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" (link snapshots-feed))) + (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" + (link fragments-feed))) + (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" + (link snapshots-feed))) (format t "~a" (cxml:with-xml-output (cxml:make-string-sink :canonical t) From lgiessmann at common-lisp.net Mon Sep 27 20:26:49 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 27 Sep 2010 16:26:49 -0400 Subject: [isidorus-cvs] r316 - in branches/new-datamodel/src: model unit_tests Message-ID: Author: lgiessmann Date: Mon Sep 27 16:26:49 2010 New Revision: 316 Log: new-datamodel: adapted the unit-test exporter-test:test-fragments-xtm1.0-versions to the new data model; fixed a bug when creating FragmentC objects-> topics referenced by variants of the main topic are also added as topic stubs Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Mon Sep 27 16:26:49 2010 @@ -72,6 +72,11 @@ (themes characteristic :revision revision) (when (instance-of characteristic :revision revision) (list (instance-of characteristic :revision revision))) + (when (and (typep characteristic 'NameC) + (variants characteristic :revision revision)) + (remove-if #'null + (loop for var in (variants characteristic :revision revision) + append (find-referenced-topics var :revision revision)))) (when (and (typep characteristic 'OccurrenceC) (> (length (charvalue characteristic)) 0) (eq #\# (elt (charvalue characteristic) 0))) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Sep 27 16:26:49 2010 @@ -1140,15 +1140,16 @@ ((and current-version-info (= (end-revision current-version-info) 0)) (setf (end-revision current-version-info) start-revision) - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)) + (let ((vi (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision))) + (elephant:add-association vi 'versioned-construct construct))) (t - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)))))))) + (let ((vi (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision))) + (elephant:add-association vi 'versioned-construct construct))))))))) + (defmethod marked-as-deleted-p ((construct VersionedConstructC)) @@ -4222,7 +4223,7 @@ construct-1))) (move-referenced-constructs newer-tm older-tm :revision revision) (dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm))) - (add-to-tm top-or-assoc top-or-assoc)) + (add-to-tm older-tm top-or-assoc)) (add-to-version-history older-tm :start-revision revision) (mark-as-deleted newer-tm :revision revision) (when (exist-in-version-history-p newer-tm) Modified: branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp Mon Sep 27 16:26:49 2010 @@ -390,12 +390,10 @@ when (string= (uri item) psi) return (identified-construct item))) (t100-start-revision (d::start-revision (first (d::versions t100))))) - (d:get-fragments t100-start-revision) (let ((t100-fragment (loop for item in (elephant:get-instances-by-class 'FragmentC) when (eq (topic item) t100) return item))) - (with-open-file (stream *out-xtm1.0-file* :direction :output) (write-string (export-xtm-fragment t100-fragment :xtm-format '1.0) stream)))) @@ -443,7 +441,9 @@ (with-fixture merge-test-db () (handler-case (delete-file *out-xtm1.0-file*)(error () )) ;deletes file - if exist (export-xtm *out-xtm1.0-file* :revision fixtures::revision1 :xtm-format '1.0) - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) + (let ((document + (dom:document-element + (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) (t100-occurrences-resourceData (list "The ISO 19115 standard ..." "2003-01-01"))) ;local value->no type (check-document-structure document 47 7 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") @@ -1121,18 +1121,17 @@ (let ((new-t100 (loop for item in (elephant:get-instances-by-class 'd:PersistentIdC) when (string= (uri item) new-t100-psi) - return (identified-construct item)))) + return (identified-construct item :revision fixtures::revision3)))) (d:get-fragments fixtures::revision3) (let ((fragment (loop for item in (elephant:get-instances-by-class 'd:FragmentC) when (eq (topic item) new-t100) return item))) (with-open-file (stream *out-xtm1.0-file* :direction :output) (write-string (export-xtm-fragment fragment :xtm-format '1.0) stream)))) - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))) - (check-document-structure document 6 0 :ns-uri *xtm1.0-ns*) + (check-document-structure document 9 1 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") do (loop for subjectIndicatorRef across (xpath-child-elems-by-qname (xpath-single-child-elem-by-qname @@ -1145,6 +1144,12 @@ (check-topic-id topic)) ((string= href core-display-psi) (check-topic-id topic)) + ((string= href constants:*type-instance-psi*) + (check-topic-id topic)) + ((string= href constants:*type-psi*) + (check-topic-id topic)) + ((string= href constants:*instance-psi*) + (check-topic-id topic)) ((string= href t50a-psi) (check-topic-id topic)) ((string= href t3-psi) @@ -1154,28 +1159,35 @@ ((string= href new-t100-psi) (check-topic-id topic) (check-single-instanceOf document topic t3-psi :xtm-format '1.0) - (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence") + (loop for occurrence across (xpath-child-elems-by-qname + topic *xtm1.0-ns* "occurrence") do (let ((resourceRef (let ((resourceRef-nodes - (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "resourceRef"))) + (xpath-child-elems-by-qname + occurrence *xtm1.0-ns* "resourceRef"))) (is (= (length resourceRef-nodes) 1)) - (dom:get-attribute-ns (elt resourceRef-nodes 0) *xtm1.0-xlink* "href"))) + (dom:get-attribute-ns (elt resourceRef-nodes 0) + *xtm1.0-xlink* "href"))) (instanceOf (let ((instanceOf-nodes - (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "instanceOf"))) + (xpath-child-elems-by-qname + occurrence *xtm1.0-ns* "instanceOf"))) (is (= (length instanceOf-nodes) 1)) (let ((topicRef-nodes (xpath-child-elems-by-qname - (elt instanceOf-nodes 0) *xtm1.0-ns* "topicRef"))) + (elt instanceOf-nodes 0) *xtm1.0-ns* + "topicRef"))) (is (= (length topicRef-nodes) 1)) (get-subjectIndicatorRef-by-ref document (dom:get-attribute-ns (elt topicRef-nodes 0) *xtm1.0-xlink* "href")))))) (cond - ((string= resourceRef (first new-t100-occurrence-resourceRef-merge-2)) + ((string= resourceRef + (first new-t100-occurrence-resourceRef-merge-2)) (is (string= instanceOf t55-psi))) - ((string= resourceRef (second new-t100-occurrence-resourceRef-merge-2)) + ((string= resourceRef + (second new-t100-occurrence-resourceRef-merge-2)) (is (string= instanceOf t55-psi))) (t (is-true From lgiessmann at common-lisp.net Thu Sep 30 10:45:00 2010 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 30 Sep 2010 06:45:00 -0400 Subject: [isidorus-cvs] r317 - in branches/new-datamodel/src: model unit_tests xml/xtm Message-ID: Author: lgiessmann Date: Thu Sep 30 06:44:59 2010 New Revision: 317 Log: new-datamodel: adapted the threading+importer unit-tests to the latest elephant+sbcl version; adapted the exporter-unit-tests to the new datamodel and sbcl+elephant version; fixed a bug when importing scopes of namevariants; adapted the reification uint-tests for the xtm-importer ot the latest elephant+sbcl version and the new-datamodel Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp branches/new-datamodel/src/unit_tests/reification_test.lisp branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Thu Sep 30 06:44:59 2010 @@ -4083,7 +4083,7 @@ (merge-all-constructs (append all-equivalent (list construct)) :revision revision)))))) (merge-changed-associations older-topic :revision revision)) - + (defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) "Merges all associations that became TMDM-equal since two referenced topics Modified: branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp Thu Sep 30 06:44:59 2010 @@ -1002,8 +1002,7 @@ (xpath-child-elems-by-qname name *xtm1.0-ns* "variant"))) (is (= (length variant-nodes) 1)) (elt variant-nodes 0)))) - (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) - t101-variant-name nil))))) + (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) t101-variant-name nil))))) (check-single-instanceOf document topic t3a-psi :xtm-format '1.0) (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence") do (let ((instanceOf @@ -1131,7 +1130,7 @@ (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))) - (check-document-structure document 9 1 :ns-uri *xtm1.0-ns*) + (check-document-structure document 6 0 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") do (loop for subjectIndicatorRef across (xpath-child-elems-by-qname (xpath-single-child-elem-by-qname @@ -1144,12 +1143,6 @@ (check-topic-id topic)) ((string= href core-display-psi) (check-topic-id topic)) - ((string= href constants:*type-instance-psi*) - (check-topic-id topic)) - ((string= href constants:*type-psi*) - (check-topic-id topic)) - ((string= href constants:*instance-psi*) - (check-topic-id topic)) ((string= href t50a-psi) (check-topic-id topic)) ((string= href t3-psi) Modified: branches/new-datamodel/src/unit_tests/reification_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/reification_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/reification_test.lisp Thu Sep 30 06:44:59 2010 @@ -58,7 +58,7 @@ (test test-merge-reifier-topics - "Tests the function merge-reifier-topics." + "Tests the function merge-constructs." (let ((db-dir "data_base") (revision-1 100) (revision-2 200)) @@ -147,7 +147,7 @@ :start-revision revision-1))) (let ((name-1-1 (make-construct 'NameC :item-identifiers nil - :topic topic-1 + :parent topic-1 :themes (list scope-1) :instance-of name-type :charvalue "name-1-1" @@ -156,7 +156,7 @@ :item-identifiers (list (make-instance 'ItemIdentifierC :uri "name-2-1-ii-1" :start-revision revision-1)) - :topic topic-2 + :parent topic-2 :themes (list scope-2) :instance-of nil :charvalue "name-2-1" @@ -165,7 +165,7 @@ :item-identifiers (list (make-instance 'ItemIdentifierC :uri "occurrence-1-1-ii-1" :start-revision revision-1)) - :topic topic-2 + :parent topic-2 :themes (list scope-1 scope-2) :instance-of occurrence-type :charvalue "occurrence-2-1" @@ -173,7 +173,7 @@ :start-revision revision-2)) (occurrence-2-2 (make-construct 'OccurrenceC :item-identifiers nil - :topic topic-2 + :parent topic-2 :themes nil :instance-of occurrence-type :charvalue "occurrence-2-2" @@ -181,7 +181,7 @@ :start-revision revision-2)) (test-name (make-construct 'NameC :item-identifiers nil - :topic scope-2 + :parent scope-2 :themes (list scope-1 topic-2) :instance-of topic-2 :charvalue "test-name" @@ -194,19 +194,21 @@ (list (list :instance-of role-type :player topic-1 + :start-revision revision-2 :item-identifiers (list (make-instance 'ItemIdentifierC :uri "role-1" - :start-revision revision-1))) + :start-revision revision-2))) (list :instance-of role-type :player topic-2 + :start-revision revision-2 :item-identifiers (list (make-instance 'ItemIdentifierC :uri "role-2" - :start-revision revision-1)))) - :start-revision revision-1))) + :start-revision revision-2)))) + :start-revision revision-2))) (is (= (length (elephant:get-instances-by-class 'TopicC)) 8)) - (datamodel::merge-reifier-topics topic-1 topic-2) + (d::merge-constructs topic-1 topic-2 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) (is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2) (item-identifiers topic-1))) @@ -220,7 +222,7 @@ (is (= (length (union (names topic-1) (list name-1-1 name-2-1))) (length (list name-1-1 name-2-1)))) - (is (= (length (union (occurrences topic-1) + (is (= (length (union (occurrences topic-1 :revision 0) (list occurrence-2-1 occurrence-2-2))) (length (list occurrence-2-1 occurrence-2-2)))) (is (= (length (union (d:used-as-type topic-1) @@ -229,9 +231,9 @@ (is (= (length (union (d:used-as-theme topic-1) (list test-name))) (length (list test-name)))) - (is (eql (player (first (roles assoc))) topic-1)) - (is (eql (player (second (roles assoc))) topic-1)) - ;;TODO: check all objects and their version-infos + (is (= (length (roles assoc :revision 0)) 1)) + (is (= (length (d::slot-p assoc 'd::roles)) 2)) + (is (eql (player (first (roles assoc :revision 0)) :revision 0) topic-1)) (elephant:close-store)))))) @@ -282,21 +284,21 @@ (is-true reifier-married-assoc) (is-true reifier-husband-role) (is (eql (reifier homer-occurrence) reifier-occurrence)) - (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reified-construct reifier-occurrence) homer-occurrence)) (is (eql (reifier homer-name) reifier-name)) - (is (eql (reified reifier-name) homer-name)) + (is (eql (reified-construct reifier-name) homer-name)) (is (eql (reifier homer-variant) reifier-variant)) - (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reified-construct reifier-variant) homer-variant)) (is (eql (reifier married-assoc) reifier-married-assoc)) - (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reified-construct reifier-married-assoc) married-assoc)) (is (eql (reifier husband-role) reifier-husband-role)) - (is (eql (reified reifier-husband-role) husband-role)) + (is (eql (reified-construct reifier-husband-role) husband-role)) (is-true (handler-case (progn (d::delete-construct homer-occurrence) t) (condition () nil))) (is-false (occurrences homer)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) (elephant:close-store)))))) @@ -346,21 +348,21 @@ (is-true reifier-married-assoc) (is-true reifier-husband-role) (is (eql (reifier homer-occurrence) reifier-occurrence)) - (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reified-construct reifier-occurrence) homer-occurrence)) (is (eql (reifier homer-name) reifier-name)) - (is (eql (reified reifier-name) homer-name)) + (is (eql (reified-construct reifier-name) homer-name)) (is (eql (reifier homer-variant) reifier-variant)) - (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reified-construct reifier-variant) homer-variant)) (is (eql (reifier married-assoc) reifier-married-assoc)) - (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reified-construct reifier-married-assoc) married-assoc)) (is (eql (reifier husband-role) reifier-husband-role)) - (is (eql (reified reifier-husband-role) husband-role)) + (is (eql (reified-construct reifier-husband-role) husband-role)) (is-true (handler-case (progn (d::delete-construct homer-occurrence) t) (condition () nil))) (is-false (occurrences homer)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) (elephant:close-store)))))) @@ -621,9 +623,9 @@ "http://test/arcs/arc4")) (is (= (length (d:used-as-type arc1)) 1)) (is (eql (reifier (first (d:used-as-type arc1))) reification-1)) - (is (eql (reified reification-1) (first (d:used-as-type arc1)))) + (is (eql (reified-construct reification-1) (first (d:used-as-type arc1)))) (is (eql (reifier (first (d:used-as-type arc3))) reification-2)) - (is (eql (reified reification-2) (first (d:used-as-type arc3)))))))) + (is (eql (reified-construct reification-2) (first (d:used-as-type arc3)))))))) (elephant:close-store)) @@ -647,13 +649,13 @@ (is-true married) (is (= (length (used-as-type married)) 1)) (is-true (reifier (first (used-as-type married)))) - (is-true (reified (reifier (first (used-as-type married))))) + (is-true (reified-construct (reifier (first (used-as-type married))))) (is (= (length (psis (reifier (first (used-as-type married))))) 1)) (is (string= (uri (first (psis (reifier (first (used-as-type married)))))) "http://test-tm#married-arc")) (is (= (length (occurrences bart)) 1)) (is-true (reifier (first (occurrences bart)))) - (is-true (reified (reifier (first (occurrences bart))))) + (is-true (reified-construct (reifier (first (occurrences bart))))) (is (string= (uri (first (psis (reifier (first (occurrences bart)))))) "http://test-tm#lastName-arc")))) (elephant:close-store)) @@ -680,17 +682,17 @@ (is (= (length (variants name)) 1)) (let ((variant (first (variants name)))) (is-true (reifier name)) - (is-true (reified (reifier name))) + (is-true (reified-construct (reifier name))) (is (= (length (psis (reifier name))) 1)) (is (string= (uri (first (psis (reifier name)))) (concatenate 'string tm-id "lisa-name"))) (is-true (reifier variant)) - (is-true (reified (reifier variant))) + (is-true (reified-construct (reifier variant))) (is (= (length (psis (reifier variant))) 1)) (is (string= (uri (first (psis (reifier variant)))) (concatenate 'string tm-id "lisa-name-variant"))) (is-true (reifier occurrence)) - (is-true (reified (reifier occurrence))) + (is-true (reified-construct (reifier occurrence))) (is (= (length (psis (reifier occurrence))) 1)) (is (string= (uri (first (psis (reifier occurrence)))) (concatenate 'string tm-id "lisa-occurrence"))))))) @@ -717,7 +719,7 @@ (is (typep (first (used-as-type friendship)) 'd:AssociationC)) (let ((friendship-association (first (used-as-type friendship)))) (is-true (reifier friendship-association)) - (is-true (reified (reifier friendship-association))) + (is-true (reified-construct (reifier friendship-association))) (is (= (length (psis (reifier friendship-association))) 1)) (is (string= (uri (first (psis (reifier friendship-association)))) (concatenate 'string tm-id "friendship-association"))) @@ -728,7 +730,7 @@ (roles friendship-association)))) (is-true carl-role) (is-true (reifier carl-role)) - (is-true (reified (reifier carl-role))) + (is-true (reified-construct (reifier carl-role))) (is (= (length (psis (reifier carl-role))) 1)) (is (string= (uri (first (psis (reifier carl-role)))) (concatenate 'string tm-id "friend-role"))))))) Modified: branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp Thu Sep 30 06:44:59 2010 @@ -75,7 +75,7 @@ (from-parameters-elem-xtm1.0 (xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "parameters") start-revision :xtm-id xtm-id) - (themes parent-construct))))) + (themes parent-construct :revision start-revision))))) (variantName (from-resourceX-elem-xtm1.0 (xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "variantName"))) (parent-name (cond Modified: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Thu Sep 30 06:44:59 2010 @@ -188,12 +188,11 @@ (themes (append (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") start-revision :xtm-id xtm-id) - (themes name))) + (themes name :revision start-revision))) (variant-value (from-resourceX-elem variant-elem)) (reifier-topic (get-reifier-topic variant-elem start-revision))) (unless variant-value (error "VariantC: one of resourceRef and resourceData must be set")) - (make-construct 'VariantC :start-revision start-revision :item-identifiers item-identifiers