From lgiessmann at common-lisp.net Wed Sep 2 10:58:34 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 02 Sep 2009 06:58:34 -0400 Subject: [isidorus-cvs] r128 - in trunk/src: . unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Wed Sep 2 06:58:33 2009 New Revision: 128 Log: rdf-importer: added handling for the isidorus-types Topic, Name and Variant; currently importing isidorus:Association and isidorus:Role is missing Modified: trunk/src/constants.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Wed Sep 2 06:58:33 2009 @@ -53,7 +53,14 @@ :*tm2rdf-associaiton-property* :*tm2rdf-subjectIdentifier-property* :*tm2rdf-itemIdentity-property* - :*tm2rdf-subjectLocator-property*)) + :*tm2rdf-subjectLocator-property* + :*tm2rdf-value-property* + :*tm2rdf-nametype-property* + :*tm2rdf-scope-property* + :*tm2rdf-varianttype-property* + :*tm2rdf-occurrencetype-property* + :*tm2rdf-roletype-property* + :*tm2rdf-associationtype-property*)) (in-package :constants) @@ -144,3 +151,17 @@ (defparameter *tm2rdf-subjectLocator-property* (concatenate 'string *tm2rdf-ns* "subjectLocator")) (defparameter *tm2rdf-itemIdentity-property* (concatenate 'string *tm2rdf-ns* "itemIdentity")) + +(defparameter *tm2rdf-value-property* (concatenate 'string *tm2rdf-ns* "value")) + +(defparameter *tm2rdf-nametype-property* (concatenate 'string *tm2rdf-ns* "nametype")) + +(defparameter *tm2rdf-scope-property* (concatenate 'string *tm2rdf-ns* "scope")) + +(defparameter *tm2rdf-varianttype-property* (concatenate 'string *tm2rdf-ns* "varianttype")) + +(defparameter *tm2rdf-occurrencetype-property* (concatenate 'string *tm2rdf-ns* "occurrencetype")) + +(defparameter *tm2rdf-roletype-property* (concatenate 'string *tm2rdf-ns* "roletype")) + +(defparameter *tm2rdf-associationtype-property* (concatenate 'string *tm2rdf-ns* "associationtype")) Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Wed Sep 2 06:58:33 2009 @@ -21,6 +21,7 @@ *tm2rdf-ns* *xml-ns* *xml-string* + *xml-uri* *instance-psi* *type-psi* *type-instance-psi* @@ -69,7 +70,9 @@ :test-xml-base :test-get-type-psis :test-get-all-type-psis - :test-isidorus-type-p)) + :test-isidorus-type-p + :test-get-all-isidorus-nodes-by-id + :test-import-isidorus-name)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -3256,6 +3259,227 @@ 'rdf-importer::occurrence))))))) +(test test-get-all-isidorus-nodes-by-id + "Tests the function get-all-isidorus-nodes-by-id." + (let ((doc-1 + (concatenate 'string "" + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + ""))) + (let ((root (elt (dom:child-nodes (cxml:parse doc-1 + (cxml-dom:make-dom-builder))) + 0)) + (description (concatenate 'string *rdf-ns* "Description")) + (sw-node "http://test/arcs/Node")) + (let ((node-id-1 (list + (list :elem (elt (rdf-importer::child-nodes-or-text + root) 0) + :xml-base nil) + (list :elem (elt (rdf-importer::child-nodes-or-text + root) 2) + :xml-base nil) + (list :elem (elt + (rdf-importer::child-nodes-or-text + (elt + (rdf-importer::child-nodes-or-text + (elt (rdf-importer::child-nodes-or-text + root) 4)) 0)) 0) + :xml-base "http://base/suffix"))) + (node-id-2 (elt (rdf-importer::child-nodes-or-text root) 1)) + (node-id-3 (elt (rdf-importer::child-nodes-or-text root) 3)) + (node-id-4 (elt (rdf-importer::child-nodes-or-text root) 4))) + (is (= (length (rdf-importer::child-nodes-or-text root)) 5)) + (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-3" root nil)) 1)) + (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-3" root nil)) :elem) + node-id-3)) + (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-2" root nil)) 1)) + (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-2" root description)) :elem) + node-id-2)) + (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-4" root sw-node)) :elem) + node-id-4)) + (is (string= (getf (first (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-4" root sw-node)) :xml-base) + "http://base/")) + (is (= (length (intersection + node-id-1 + (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-1" root description) + :test #'(lambda(x y) + (and (eql (getf x :elem) (getf y :elem)) + (string= (getf x :xml-base) + (getf y :xml-base)))))) + (length node-id-1))))))) + + +(test test-import-isidorus-name + "Tests all functions that are responsible to import a resource + representing isidorus:Name." + (let ((revision-1 100) + (tm-id "http://test/tm-id") + (document-id "doc-id") + (db-dir "./data_base") + (doc-1 + (concatenate 'string "" + " " + " http://topic-psi-1" + " http://topic-sl-1" + " http://topic-ii-1" + " " + " " + " " + " http://itemIdentity-1" + " http://itemIdentity-2" + " " + " " + " value-1" + " " + " " + " " + " " + " " + " " + " http://itemIdentity-4" + " value-3" + " " + " " + " " + " " + " " + " value-4" + " " + " " + " " + " " + " " + " " + + " " + " " + " value-2" + " " + + " " + " http://itemIdentity-3" + " " + " " + " " + ""))) + (let ((root (elt (dom:child-nodes (cxml:parse doc-1 + (cxml-dom:make-dom-builder))) + 0))) + (is (= (length (rdf-importer::child-nodes-or-text root)) 3)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (rdf-importer::import-dom root revision-1 :tm-id tm-id + :document-id document-id) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 27)) + (is-false (find-if #'(lambda(x) + (not (d:psis x))) + (elephant:get-instances-by-class 'd:TopicC))) + (is-true (d:get-item-by-psi "http://node-1")) + (is-true (d:get-item-by-psi "http://topic-psi-1")) + (is-true (d:get-item-by-psi "http://resource-1")) + (is-true (d:get-item-by-psi "http://scope-1")) + (is-true (d:get-item-by-psi "http://scope-2")) + (is-true (d:get-item-by-psi "http://scope-3")) + (is-true (d:get-item-by-psi "http://scope-4")) + (is-true (d:get-item-by-psi "http://nametype-1")) + (is-true (d:get-item-by-psi "http://nametype-1")) + (is-true (d:get-item-by-psi "http://test/arcs/arc")) + (let ((top (d:get-item-by-psi "http://node-1")) + (nt-1 (d:get-item-by-psi "http://nametype-1")) + (nt-2 (d:get-item-by-psi "http://nametype-2")) + (scope-1 (d:get-item-by-psi "http://scope-1")) + (scope-2 (d:get-item-by-psi "http://scope-2")) + (scope-3 (d:get-item-by-psi "http://scope-3")) + (scope-4 (d:get-item-by-psi "http://scope-4"))) + (is (= (length (d:psis top)) 2)) + (is-true (find (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri + "http://topic-psi-1") + (d:psis top))) + (is (= (length (d:item-identifiers top)) 1)) + (is (string= (d:uri (first (d:item-identifiers top))) + "http://topic-ii-1")) + (is (= (length (d:locators top)) 1)) + (is (string= (d:uri (first (d:locators top))) + "http://topic-sl-1")) + (is (= (length (d:names top)) 2)) + (let ((name-1 (find-if #'(lambda(x) + (eql (d:instance-of x) nt-1)) + (d:names top))) + (name-2 (find-if #'(lambda(x) + (eql (d:instance-of x) nt-2)) + (d:names top)))) + (is-true name-1) + (is-true name-2) + (is (= (length (d:item-identifiers name-1)) 2)) + (is (= (length + (intersection + (d:item-identifiers name-1) + (list (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://itemIdentity-1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://itemIdentity-2")))) + 2)) + (is (= (length (d:item-identifiers name-2)) 1)) + (is (string= (d:uri (first (d:item-identifiers name-2))) + "http://itemIdentity-4")) + (is (= (length (d:themes name-1)) 2)) + (is (= (length (intersection (list scope-1 scope-2) + (d:themes name-1))) + 2)) + (is-false (d:themes name-2)) + (is (string= (d:charvalue name-1) "value-1")) + (is (string= (d:charvalue name-2) "value-3")) + (is (= (length (d:variants name-1)) 1)) + (is (= (length (d:variants name-2)) 1)) + (let ((variant-1 (first (d:variants name-1))) + (variant-2 (first (d:variants name-2)))) + (is (= (length (d:item-identifiers variant-1)) 1)) + (is (string= (d:uri (first (d:item-identifiers variant-1))) + "http://itemIdentity-3")) + (is-false (d:item-identifiers variant-2)) + (is (= (length (d:themes variant-1)) 4)) + (is (= (length (intersection (list scope-3 scope-4 + scope-1 scope-2) + (d:themes variant-1))) + 4)) + (is (= (length (d:themes variant-2)) 1)) + (is (eql scope-3 (first (d:themes variant-2)))) + (is (string= (d:charvalue variant-1) + "value-2")) + (is (string= (d:charvalue variant-2) + "value-4")) + (is (string= (d:datatype variant-1) + (concatenate 'string tm-id "/dt-2"))) + (is (string= (d:datatype variant-2) + *xml-string*)))))))) + + + (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3281,4 +3505,6 @@ (it.bese.fiveam:run! 'test-xml-base) (it.bese.fiveam:run! 'test-get-type-psis) (it.bese.fiveam:run! 'test-get-all-type-psis) - (it.bese.fiveam:run! 'test-isidorus-type-p)) \ No newline at end of file + (it.bese.fiveam:run! 'test-isidorus-type-p) + (it.bese.fiveam:run! 'test-get-all-isidorus-nodes-by-id) + (it.bese.fiveam:run! 'test-import-isidorus-name)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 2 06:58:33 2009 @@ -84,6 +84,7 @@ (let ((children (child-nodes-or-text rdf-dom :trim t))) (when children (loop for child across children + when (non-isidorus-type-p child tm-id :parent-xml-base xml-base) do (import-node child tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) (import-node rdf-dom tm-id start-revision :document-id document-id @@ -96,31 +97,37 @@ (format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove (tm-id-p tm-id "import-node") (parse-node elem) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))) + (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) + (fn-xml-base (get-xml-base elem :old-base xml-base))) (let ((about (get-absolute-attribute elem tm-id xml-base "about")) (nodeID (get-ns-attribute elem "nodeID")) (ID (get-absolute-attribute elem tm-id xml-base "ID")) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (parse-properties-of-node elem (or about nodeID ID UUID)) - + ;TODO: create associaitons and roles (let ((literals (append (get-literals-of-node elem fn-xml-lang) (get-literals-of-node-content elem tm-id xml-base fn-xml-lang))) (associations (get-associations-of-node-content elem tm-id xml-base)) (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) (super-classes - (get-super-classes-of-node-content elem tm-id xml-base))) - ;TODO: collect isidorus' subjectIdentifiers, itemIdentities, - ; subjectLocators, names and occurrences - ; add the collected constructs to the topic-stub - - ;TODO: collect associations and association roles and create the - ; corresponding constructs and stops the recusrion + (get-super-classes-of-node-content elem tm-id xml-base)) + (subject-identities (make-isidorus-identifiers + elem start-revision :what "subjectIdentifier")) + (item-identifiers (make-isidorus-identifiers elem start-revision)) + (subject-locators (make-isidorus-identifiers elem start-revision + :what "subjectLocator"))) (with-tm (start-revision document-id tm-id) (let ((this (make-topic-stub about ID nodeID UUID start-revision xml-importer::tm - :document-id document-id))) + :document-id document-id + :additional-subject-identifiers subject-identities + :item-identifiers item-identifiers + :subject-locators subject-locators))) + (make-isidorus-names elem this tm-id start-revision + :owner-xml-base fn-xml-base) + ;TODO: create topic occurrences (make-literals this literals tm-id start-revision :document-id document-id) (make-associations this associations xml-importer::tm @@ -136,6 +143,257 @@ this)))))) + +(defun make-isidorus-names (owner-elem owner-topic tm-id start-revision + &key (owner-xml-base nil) + (document-id *document-id*)) + "Creates all names of a resource node that are in a property isidorus:name + and have the type isidorus:Name." + (declare (dom:element owner-elem)) + (declare (string tm-id)) + (declare (TopicC owner-topic)) + (let ((content (child-nodes-or-text owner-elem :trim t)) + (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0))) + (when (and (not (stringp content)) + (> (length content) 0)) + (loop for property across content + when (isidorus-type-p property tm-id 'name + :parent-xml-base owner-xml-base) + collect + (let ((xml-base (get-xml-base property + :old-base owner-xml-base))) + (let ((nodes + (let ((nodeID (get-ns-attribute property "nodeID"))) + (if nodeID + (get-all-isidorus-nodes-by-id + nodeID root *tm2rdf-name-type-uri*) + (list (self-or-child-node + property *tm2rdf-name-type-uri* + :xml-base xml-base)))))) + (let ((item-identities + (remove-if #'null + (loop for node in nodes + append (make-isidorus-identifiers + (getf node :elem) start-revision)))) + (name-type (make-name-type nodes tm-id start-revision + :document-id document-id)) + (name-value (getf (make-value nodes tm-id) :value)) + (name-scopes (make-scopes nodes tm-id start-revision + :document-id document-id))) + ;(format t "ii: ~a~%type: ~a~%value: ~a~%scopes: ~a~%~%" + ; item-identities name-type name-value name-scopes) + (let ((this + (make-construct 'NameC + :start-revision start-revision + :topic owner-topic + :charvalue name-value + :instance-of name-type + :item-identifiers item-identities + :themes name-scopes))) + (make-isidorus-variants nodes this tm-id start-revision + :document-id document-id))))))))) + + +(defun make-isidorus-variants (name-nodes owner-name tm-id start-revision + &key (document-id *document-id*)) + "Creates name variants of the passed name-nodes." + (declare (NameC owner-name)) + (declare (string tm-id)) + (let ((root + (when name-nodes + (elt (dom:child-nodes + (dom:owner-document (getf (first name-nodes) :elem))) 0)))) + (remove-if + #'null + (loop for name-node in name-nodes + collect (let ((content (child-nodes-or-text (getf name-node :elem)))) + (when (and (not (stringp content)) + (> (length content) 0)) + (loop for property across content + when (isidorus-type-p + property tm-id 'variant + :parent-xml-base (getf name-node :xml-base)) + collect + (let ((nodes + (let ((nodeID + (get-ns-attribute property "nodeID"))) + (if nodeID + (get-all-isidorus-nodes-by-id + nodeID root *tm2rdf-name-type-uri*) + (list (self-or-child-node + property + *tm2rdf-variant-type-uri* + :xml-base + (get-xml-base + property + :old-base + (getf name-node :xml-base)))))))) + (let ((item-identities + (remove-if + #'null + (loop for node in nodes + append (make-isidorus-identifiers + (getf node :elem) start-revision)))) + (variant-scopes + (append + (make-scopes nodes tm-id start-revision + :document-id document-id) + (themes owner-name))) ;XTM 2.0: 4.12 + (value-and-type (make-value nodes tm-id))) + (make-construct 'VariantC + :start-revision start-revision + :item-identifiers item-identities + :themes variant-scopes + :charvalue + (getf value-and-type :value) + :datatype + (getf value-and-type :datatype) + :name owner-name)))))))))) + + +(defun self-or-child-node (property-node type-uri &key (xml-base)) + "Returns either the passed node or the child-node when it is + rdf:Description." + (declare (dom:element property-node)) + (let ((content (child-nodes-or-text property-node :trim t))) + (if (and (= (length content) 1) + (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*) + (string= (get-node-name (elt content 0)) "Description")) + (string= (concatenate-uri (dom:namespace-uri (elt content 0)) + (get-node-name (elt content 0))) + type-uri))) + (list :elem (elt content 0) + :xml-base (get-xml-base (elt content 0) :old-base xml-base)) + (list :elem property-node + :xml-base xml-base)))) + + +(defun make-scopes (node-list tm-id start-revision + &key (document-id *document-id*)) + "Creates for every found scope a corresponding topic stub." + (let ((properties + (remove-if + #'null + (loop for node in node-list + append (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + *tm2rdf-scope-property*)) + collect (list :elem property + :xml-base (get-xml-base + property + :old-base + (getf node :xml-base))))))))) + (let ((scope-uris + (remove-if #'null + (map 'list #'(lambda(x) + (get-ref-of-property (getf x :elem) tm-id + (getf x :xml-base))) + properties)))) + (with-tm (start-revision document-id tm-id) + (map 'list #'(lambda(x) + (let ((topicid (getf x :topicid)) + (psi (getf x :psi))) + (make-topic-stub psi nil topicid nil start-revision + xml-importer::tm + :document-id document-id))) + scope-uris))))) + + +(defun make-value (node-list tm-id) + "Returns the literal value of a property of the type isidorus:value." + (let ((property + (loop for node in node-list + when (or (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + *tm2rdf-value-property*)) + return property)) + (get-ns-attribute (getf node :elem) + "value" :ns-uri *tm2rdf-ns*)) + return (or (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + *tm2rdf-value-property*)) + return property)) + (get-ns-attribute (getf node :elem) + "value" :ns-uri *tm2rdf-ns*))))) + (if property + (if (stringp property) + (list :value property :datatype *xml-string*) + (let ((prop-content (child-nodes-or-text property)) + (type (let ((dt + (get-datatype + property tm-id + (find-if #'(lambda(x) + (eql property (getf x :elem))) + node-list)))) + (if dt dt *xml-string*)))) + (cond + ((= (length prop-content) 0) + (list :value "" :datatype type)) + ((not (stringp prop-content)) ;must be an element + (let ((text-val "")) + (when (dom:child-nodes property) + (loop for content-node across + (dom:child-nodes property) + do (push-string + (node-to-string content-node) + text-val))) + (list :value text-val :datatype type))) + (t (list :value prop-content :datatype type))))) + (list :value "" :datatype *xml-string*)))) + + + +(defun make-name-type (node-list tm-id start-revision + &key (document-id *document-id*)) + "Creates a topic stub that is the type of the name represented by the + passed nodes." + (let ((property + (loop for node in node-list + when (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + *tm2rdf-nametype-property*)) + return property)) + return (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + *tm2rdf-nametype-property*)) + return (list + :elem property + :xml-base (get-xml-base property + :old-base + (getf + node + :xml-base)))))))) + (when property + (let ((type-uri (get-ref-of-property (getf property :elem) tm-id + (getf property :xml-base)))) + (unless type-uri + (error "From make-name-type(): type-uri is missing!")) + (with-tm (start-revision document-id tm-id) + (make-topic-stub (getf type-uri :psi) nil + (getf type-uri :topicid) nil start-revision + xml-importer::tm :document-id document-id)))))) + + (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) @@ -144,7 +402,6 @@ (declare (dom:element elem)) (format t ">> import-arc: ~a <<~%" (dom:node-name elem)) ;TODO: remove (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) - (fn-xml-base (get-xml-base elem :old-base xml-base)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (parseType (get-ns-attribute elem "parseType")) (content (child-nodes-or-text elem :trim t))) @@ -159,42 +416,51 @@ (string/= parseType "Collection"))) (when UUID (parse-properties-of-node elem UUID) - (let ((this - (get-item-by-id UUID :xtm-id document-id - :revision start-revision))) - (let ((literals - (append (get-literals-of-property - elem fn-xml-lang) - (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations - (get-associations-of-node-content - elem tm-id xml-base)) - (types - (remove-if - #'null - (append - (get-types-of-node-content elem tm-id fn-xml-base) - (when (get-ns-attribute elem "type") - (list :ID nil - :topicid (get-ns-attribute elem "type") - :psi (get-ns-attribute elem "type")))))) - (super-classes - (get-super-classes-of-node-content - elem tm-id xml-base))) - ;TODO: collect isidorus' subjectIdentifiers, itemIdentities, - ; subjectLocators, names and occurrences - ; add the collected constructs to the topic-stub - (make-literals this literals tm-id start-revision - :document-id document-id) - (make-associations this associations xml-importer::tm - start-revision :document-id document-id) - (make-types this types xml-importer::tm start-revision - :document-id document-id) - (make-super-classes - this super-classes xml-importer::tm - start-revision :document-id document-id)) - this))))) + (let ((subject-identifiers + (make-isidorus-identifiers + elem start-revision :what "subjectIdentifier")) + (item-identities + (make-isidorus-identifiers elem start-revision)) + (subject-locators + (make-isidorus-identifiers elem start-revision + :what "subjectLocator"))) + (let ((this + (make-topic-stub + nil nil nil UUID start-revision xml-importer::tm + :additional-subject-identifiers + subject-identifiers + :item-identifiers item-identities + :subject-locators subject-locators + :document-id document-id))) + (let ((literals + (append (get-literals-of-property + elem fn-xml-lang) + (get-literals-of-node-content + elem tm-id xml-base fn-xml-lang))) + (associations + (get-associations-of-node-content + elem tm-id xml-base)) + (types (get-types-of-property + elem tm-id + :parent-xml-base xml-base)) + (super-classes + (get-super-classes-of-node-content + elem tm-id xml-base))) + (make-isidorus-names elem this tm-id start-revision + :owner-xml-base xml-base + :document-id document-id) + ;TDOD: create topic occurrences + (make-literals this literals tm-id start-revision + :document-id document-id) + (make-associations + this associations xml-importer::tm + start-revision :document-id document-id) + (make-types this types xml-importer::tm start-revision + :document-id document-id) + (make-super-classes + this super-classes xml-importer::tm + start-revision :document-id document-id)) + this)))))) (make-recursion-from-arc elem tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang) @@ -276,7 +542,7 @@ (map 'list #'(lambda(literal) (make-occurrence owner-top literal start-revision tm-id :document-id document-id)) - literals)) + (filter-isidorus-literals literals))) (defun make-associations (owner-top associations tm start-revision @@ -408,7 +674,9 @@ (defun make-topic-stub (about ID nodeId UUID start-revision - tm &key (document-id *document-id*)) + tm &key (document-id *document-id*) + (additional-subject-identifiers nil) + (item-identifiers nil) (subject-locators nil)) "Returns a topic corresponding to the passed parameters. When the searched topic does not exist there will be created one. If about or ID is set there will also be created a new PSI." @@ -429,15 +697,23 @@ inner-top)))) (if top top - (let ((psi (when psi-uri - (make-instance 'PersistentIdC - :uri psi-uri - :start-revision start-revision)))) + (let ((psis (if psi-uri + (remove-if + #'null + (append + (list + (make-instance 'PersistentIdC + :uri psi-uri + :start-revision start-revision)) + additional-subject-identifiers)) + additional-subject-identifiers))) (handler-case (add-to-topicmap tm (make-construct 'TopicC :topicid topic-id - :psis (when psi (list psi)) + :psis psis + :item-identifiers item-identifiers + :locators subject-locators :xtm-id document-id :start-revision start-revision)) (Condition (err)(error "Creating topic ~a failed: ~a" @@ -917,4 +1193,46 @@ collect (import-node item tm-id start-revision :document-id document-id :xml-base xml-base - :xml-lang xml-lang)))))))) \ No newline at end of file + :xml-lang xml-lang)))))))) + + +(defun make-isidorus-identifiers (owner-elem start-revision &key (what "itemIdentity")) + "Returns a list oc created identifier objects that can be + used directly in make-topic-stub." + (declare (dom:element owner-elem)) + (declare (string what)) + (when (and (string/= what "itemIdentity") + (string/= what "subjectIdentifier") + (string/= what "subjectLocator")) + (error "From make-identifiers(): what must be set to: ~a but is ~a" + (list "itemIdentity" "subjectIdentifiers" "subjectLocator") + what)) + (let ((content (child-nodes-or-text owner-elem :trim t)) + (class-symbol (cond + ((string= what "itemIdentity") + 'ItemIdentifierC) + ((string= what "subjectIdentifier") + 'PersistentIdC) + ((string= what "subjectLocator") + 'SubjectLocatorC)))) + (unless (stringp content) + (let ((identifiers + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property)) + (prop-content (child-nodes-or-text property :trim t))) + (and (string= prop-ns *tm2rdf-ns*) + (string= prop-name what) + (stringp prop-content) + (> (length prop-content) 0))) + collect (let ((uri (child-nodes-or-text property :trim t))) + (make-instance class-symbol + :uri uri + :start-revision start-revision)))) + (identifier-attr + (let ((attr (get-ns-attribute owner-elem what :ns-uri *tm2rdf-ns*))) + (when attr + (list (make-instance class-symbol + :uri attr + :start-revision start-revision)))))) + (remove-if #'null (append identifiers identifier-attr)))))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 2 06:58:33 2009 @@ -45,7 +45,15 @@ *tm2rdf-association-property* *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* - *tm2rdf-subjectLocator-property*) + *tm2rdf-subjectLocator-property* + *tm2rdf-ns* + *tm2rdf-value-property* + *tm2rdf-nametype-property* + *tm2rdf-scope-property* + *tm2rdf-varianttype-property* + *tm2rdf-occurrencetype-property* + *tm2rdf-roletype-property* + *tm2rdf-associationtype-property*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) @@ -290,6 +298,29 @@ :psi (or ID about))))))) +(defun get-ref-of-property (property-elem tm-id xml-base) + "Returns a plist of the form (:topicid :psi ). + That contains the property's value." + (declare (dom:element property-elem)) + (declare (string tm-id)) + (let ((nodeId (get-ns-attribute property-elem "nodeID")) + (resource (get-ns-attribute property-elem "resource")) + (content (let ((node-refs + (get-node-refs (child-nodes-or-text property-elem) + tm-id xml-base))) + (when node-refs + (first node-refs))))) + (cond + (nodeID + (list :topicid nodeID + :psi nil)) + (resource + (list :topicid resource + :psi resource)) + (content + content)))) + + (defun parse-property-name (property owner-identifier) "Parses the given property's name to the known rdf/rdfs nodes and arcs. If the given name es equal to an node an error is thrown otherwise @@ -501,6 +532,19 @@ (get-types-of-node-content elem tm-id xml-base))))) +(defun get-types-of-property (elem tm-id &key (parent-xml-base nil)) + "Returns a plist of all property's types of the form + (:topicid :psi :ID )." + (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) + (remove-if #'null + (append + (get-types-of-node-content elem tm-id xml-base) + (when (get-ns-attribute elem "type") + (list :ID nil + :topicid (get-ns-attribute elem "type") + :psi (get-ns-attribute elem "type"))))))) + + (defun get-type-psis (elem tm-id &key (parent-xml-base nil)) "Returns a list of type-uris of the passed node." @@ -617,6 +661,34 @@ (string= uri property-name-uri)))) +(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil) + (ignore-topic nil)) + "Returns t if the passed element is not of an isidorus' type. + The environmental property is not analysed by this function!" + (declare (dom:element elem)) + (declare (string tm-id)) + (let ((nodeID (get-ns-attribute elem "nodeID")) + (document (dom:owner-document elem)) + (types + (let ((b-types + (list + *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri* + *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri* + *tm2rdf-role-type-uri*)) + (a-types (list *tm2rdf-topic-type-uri*))) + (if ignore-topic + b-types + (append a-types b-types))))) + (if nodeID + (not (loop for type in types + when (type-of-id-p nodeId type tm-id document) + return t)) + (not (loop for type in types + when (type-p elem type tm-id + :parent-xml-base parent-xml-base) + return t))))) + + (defun isidorus-type-p (property-elem-or-node-elem tm-id what &key(parent-xml-base nil)) "Returns t if the node elem is of the type isidorus: and is @@ -654,7 +726,16 @@ property-elem-or-node-elem) (get-node-name property-elem-or-node-elem)))) (if (or (string= type *tm2rdf-topic-type-uri*) - (string= type *tm2rdf-association-type-uri*)) + (string= type *tm2rdf-association-type-uri*) + (let ((parseType (get-ns-attribute property-elem-or-node-elem + "parseType"))) + (and parseType + (string= parseType "Resource"))) + (get-ns-attribute property-elem-or-node-elem "type") + (get-ns-attribute property-elem-or-node-elem "value" + :ns-uri *tm2rdf-ns*) + (get-ns-attribute property-elem-or-node-elem "itemIdentity" + :ns-uri *tm2rdf-ns*)) (type-p property-elem-or-node-elem type tm-id :parent-xml-base parent-xml-base) (when (string= elem-uri property) @@ -686,5 +767,85 @@ (string= x-uri *tm2rdf-role-property*) (string= x-uri *tm2rdf-subjectIdentifier-property*) (string= x-uri *tm2rdf-itemIdentity-property*) + (string= x-uri *tm2rdf-value-property*) + (string= x-uri *tm2rdf-scope-property*) + (string= x-uri *tm2rdf-nametype-property*) + (string= x-uri *tm2rdf-varianttype-property*) + (string= x-uri *tm2rdf-associationtype-property*) + (string= x-uri *tm2rdf-occurrencetype-property*) + (string= x-uri *tm2rdf-roletype-property*) (string= x-uri *tm2rdf-subjectLocator-property*)))) - content)))) \ No newline at end of file + content)))) + + +(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri + &key (parent-xml-base nil) + (collected-nodes nil)) + "Returns a list of all nodes that own the given nodeID and are of + type type-uri, rdf:Description or when the rdf:parseType is set to + Resource or the isidorus:value attribute is set." + (declare (dom:element current-node)) + (declare (string node-id)) + (let ((datatype (when (get-ns-attribute current-node "datatype") + t)) + (parseType (let ((attr (get-ns-attribute current-node "parseType"))) + (when (and attr + (string= attr "Literal")) + t))) + (content (child-nodes-or-text current-node :trim t)) + (xml-base (get-xml-base current-node :old-base parent-xml-base)) + (nodeID (get-ns-attribute current-node "nodeID")) + (node-uri-p (let ((node-uri + (concatenate-uri (dom:namespace-uri current-node) + (get-node-name current-node))) + (description (concatenate 'string *rdf-ns* + "Description"))) + (or (string= node-uri (if type-uri type-uri "")) + (string= node-uri description) + (get-ns-attribute current-node "type") + (get-ns-attribute current-node "value" + :ns-uri *tm2rdf-ns*) + (get-ns-attribute current-node "itemIdentity" + :ns-uri *tm2rdf-ns*) + (let ((parseType (get-ns-attribute current-node + "parseType"))) + (when parseType + (string= parseType "Resource"))))))) + (remove-duplicates + (remove-if + #'null + (if (or datatype parseType (stringp content) (not content)) + (if (and (string= nodeID node-id) node-uri-p) + (append (list (list :elem current-node + :xml-base xml-base)) + collected-nodes) + collected-nodes) + (if (and (string= nodeID node-id) node-uri-p) + (loop for item across content + append (get-all-isidorus-nodes-by-id + node-id item type-uri + :collected-nodes (append + (list (list :elem current-node + :xml-base xml-base)) + collected-nodes) + :parent-xml-base xml-base)) + (loop for item across content + append (get-all-isidorus-nodes-by-id + node-id item type-uri + :collected-nodes collected-nodes + :parent-xml-base xml-base))))) + :test #'(lambda(x y) + (eql (getf x :elem) (getf y :elem)))))) + + +(defun filter-isidorus-literals (literals) + "Removes all literals that are known isidorus properties which + are able to contain literal data." + (remove-if #'(lambda(x) + (or (string= (getf x :type) + *tm2rdf-subjectIdentifier-property*) + (string= (getf x :type) + *tm2rdf-itemIdentity-property*) + (string= (getf x :type) + *tm2rdf-subjectLocator-property*))) + literals)) \ No newline at end of file From lgiessmann at common-lisp.net Wed Sep 2 12:56:18 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 02 Sep 2009 08:56:18 -0400 Subject: [isidorus-cvs] r129 - in trunk/src: . xml/rdf Message-ID: Author: lgiessmann Date: Wed Sep 2 08:56:17 2009 New Revision: 129 Log: rdf-importer: cleaned some code passages of the rdf module. Added: trunk/src/xml/rdf/isidorus_constructs_tools.lisp Modified: trunk/src/isidorus.asd trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Wed Sep 2 08:56:17 2009 @@ -53,8 +53,10 @@ "exporter_xtm2.0")))) (:module "rdf" :components ((:file "rdf_tools") - (:file "importer" + (:file "isidorus_constructs_tools" :depends-on ("rdf_tools")) + (:file "importer" + :depends-on ("rdf_tools" "isidorus_constructs_tools")) (:file "exporter")) :depends-on ("xtm"))) :depends-on ("constants" Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 2 08:56:17 2009 @@ -180,8 +180,6 @@ (name-value (getf (make-value nodes tm-id) :value)) (name-scopes (make-scopes nodes tm-id start-revision :document-id document-id))) - ;(format t "ii: ~a~%type: ~a~%value: ~a~%scopes: ~a~%~%" - ; item-identities name-type name-value name-scopes) (let ((this (make-construct 'NameC :start-revision start-revision @@ -248,25 +246,8 @@ (getf value-and-type :value) :datatype (getf value-and-type :datatype) - :name owner-name)))))))))) - + :name owner-name)))))))))) -(defun self-or-child-node (property-node type-uri &key (xml-base)) - "Returns either the passed node or the child-node when it is - rdf:Description." - (declare (dom:element property-node)) - (let ((content (child-nodes-or-text property-node :trim t))) - (if (and (= (length content) 1) - (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*) - (string= (get-node-name (elt content 0)) "Description")) - (string= (concatenate-uri (dom:namespace-uri (elt content 0)) - (get-node-name (elt content 0))) - type-uri))) - (list :elem (elt content 0) - :xml-base (get-xml-base (elt content 0) :old-base xml-base)) - (list :elem property-node - :xml-base xml-base)))) - (defun make-scopes (node-list tm-id start-revision &key (document-id *document-id*)) Added: trunk/src/xml/rdf/isidorus_constructs_tools.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Wed Sep 2 08:56:17 2009 @@ -0,0 +1,320 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- +(in-package :rdf-importer) + + +(defun get-type-psis (elem tm-id + &key (parent-xml-base nil)) + "Returns a list of type-uris of the passed node." + (let ((types (get-types-of-node elem tm-id + :parent-xml-base parent-xml-base))) + (remove-if #'null + (map 'list #'(lambda(x) + (getf x :psi)) + types)))) + + +(defun get-all-type-psis-of-id (nodeID tm-id document) + "Returns a list of type-uris for resources identified by the given + nodeID by analysing the complete XML-DOM." + (let ((root (elt (dom:child-nodes document) 0))) + (remove-duplicates + (remove-if #'null + (if (and (string= (dom:namespace-uri root) *rdf-ns*) + (string= (get-node-name root)"RDF")) + (loop for node across (child-nodes-or-text root) + append (get-all-type-psis-across-dom + root tm-id :resource-id nodeID)) + (get-all-type-psis-across-dom + root tm-id :resource-id nodeID))) + :test #'string=))) + + +(defun get-all-type-psis (elem tm-id &key (parent-xml-base nil)) + "Returns a list of type-uris for the element by analysing the complete + XML-DOM." + (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) + (let ((root (elt (dom:child-nodes (dom:owner-document elem)) 0)) + (nodeID (get-ns-attribute elem "nodeID")) + (about (get-absolute-attribute elem tm-id xml-base "about"))) + (remove-duplicates + (remove-if #'null + (if (or nodeID about) + (if (and (string= (dom:namespace-uri root) *rdf-ns*) + (string= (get-node-name root) "RDF")) + (loop for node across (child-nodes-or-text root) + append (get-all-type-psis-across-dom + root tm-id :resource-uri about + :resource-id nodeID)) + (get-all-type-psis-across-dom + root tm-id :resource-uri about + :resource-id nodeID)) + (get-type-psis elem tm-id :parent-xml-base parent-xml-base))) + :test #'string=)))) + + +(defun get-all-type-psis-across-dom (elem tm-id &key (parent-xml-base nil) + (resource-uri nil) (resource-id nil) + (types nil)) + "Returns a list of type PSI strings collected over the complete XML-DOM + corresponding to the passed id's or uri." + (when (or resource-uri resource-id) + (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) + (let ((datatype (when (get-ns-attribute elem "datatype") + t)) + (parseType (when (get-ns-attribute elem "parseType") + (string= (get-ns-attribute elem "parseType") + "Literal")))) + (if (or datatype parseType) + types + (let ((nodeID (get-ns-attribute elem "nodeID")) + (about (get-absolute-attribute elem tm-id xml-base "about"))) + (let ((fn-types + (append types + (when (or (and about resource-uri + (string= about resource-uri)) + (and nodeID resource-id + (string= nodeID resource-id))) + (get-type-psis elem tm-id + :parent-xml-base xml-base)))) + (content (child-nodes-or-text elem :trim t))) + (if (or (stringp content) + (not content)) + fn-types + (loop for child-node across content + append (get-all-type-psis-across-dom + child-node tm-id :parent-xml-base xml-base + :resource-uri resource-uri + :resource-id resource-id + :types fn-types)))))))))) + + +(defun type-p (elem type-uri tm-id &key (parent-xml-base nil)) + "Returns t if the type-uri is a type of elem." + (declare (string tm-id type-uri)) + (declare (dom:element elem)) + (tm-id-p tm-id "type-p") + (find type-uri (get-all-type-psis elem tm-id + :parent-xml-base parent-xml-base) + :test #'string=)) + + +(defun type-of-id-p (node-id type-uri tm-id document) + "Returns t if type-uri is a type of the passed node-id." + (declare (string node-id type-uri tm-id)) + (declare (dom:document document)) + (tm-id-p tm-id "type-of-ndoe-id-p") + (find type-uri (get-all-type-psis-of-id node-id tm-id document) + :test #'string=)) + + +(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil) + (ignore-topic nil)) + "Returns t if the passed element is not of an isidorus' type. + The environmental property is not analysed by this function!" + (declare (dom:element elem)) + (declare (string tm-id)) + (let ((nodeID (get-ns-attribute elem "nodeID")) + (document (dom:owner-document elem)) + (types + (let ((b-types + (list + *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri* + *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri* + *tm2rdf-role-type-uri*)) + (a-types (list *tm2rdf-topic-type-uri*))) + (if ignore-topic + b-types + (append a-types b-types))))) + (if nodeID + (not (loop for type in types + when (type-of-id-p nodeId type tm-id document) + return t)) + (not (loop for type in types + when (type-p elem type tm-id + :parent-xml-base parent-xml-base) + return t))))) + + +(defun isidorus-type-p (property-elem-or-node-elem tm-id what + &key(parent-xml-base nil)) + "Returns t if the node elem is of the type isidorus: and is + contained in a porperty isidorus:." + (declare (dom:element property-elem-or-node-elem)) + (declare (symbol what)) + (tm-id-p tm-id "isidorus-type-p") + (let ((xml-base (get-xml-base property-elem-or-node-elem + :old-base parent-xml-base)) + (type-and-property (cond + ((eql what 'name) + (list :type *tm2rdf-name-type-uri* + :property *tm2rdf-name-property*)) + ((eql what 'variant) + (list :type *tm2rdf-variant-type-uri* + :property *tm2rdf-variant-property*)) + ((eql what 'occurrence) + (list :type *tm2rdf-occurrence-type-uri* + :property *tm2rdf-occurrence-property*)) + ((eql what 'role) + (list :type *tm2rdf-role-type-uri* + :property *tm2rdf-role-property*)) + ((eql what 'topic) + (list :type *tm2rdf-topic-type-uri*)) + ((eql what 'association) + (list :type + *tm2rdf-association-type-uri*))))) + (when type-and-property + (let ((type (getf type-and-property :type)) + (property (getf type-and-property :property)) + (nodeID (get-ns-attribute property-elem-or-node-elem "nodeID")) + (document (dom:owner-document property-elem-or-node-elem)) + (elem-uri (concatenate-uri + (dom:namespace-uri + property-elem-or-node-elem) + (get-node-name property-elem-or-node-elem)))) + (if (or (string= type *tm2rdf-topic-type-uri*) + (string= type *tm2rdf-association-type-uri*) + (let ((parseType (get-ns-attribute property-elem-or-node-elem + "parseType"))) + (and parseType + (string= parseType "Resource"))) + (get-ns-attribute property-elem-or-node-elem "type") + (get-ns-attribute property-elem-or-node-elem "value" + :ns-uri *tm2rdf-ns*) + (get-ns-attribute property-elem-or-node-elem "itemIdentity" + :ns-uri *tm2rdf-ns*)) + (type-p property-elem-or-node-elem type tm-id + :parent-xml-base parent-xml-base) + (when (string= elem-uri property) + (if nodeID + (type-of-id-p nodeId type tm-id document) + (let ((content (child-nodes-or-text property-elem-or-node-elem + :trim t))) + (when (and (= (length content) 1) + (not (stringp content))) + (type-p (elt content 0) type tm-id + :parent-xml-base xml-base)))))))))) + + +(defun non-isidorus-child-nodes-or-text (elem &key (trim nil)) + "Returns a list of node elements that are no isidorus properties, e.g. + isidorus:name, string-content or nil." + (let ((content (child-nodes-or-text elem :trim trim))) + (if (or (not content) + (stringp content)) + content + (remove-if #'(lambda(x) + (let ((x-uri (if (dom:namespace-uri x) + (concatenate-uri (dom:namespace-uri x) + (get-node-name x)) + (get-node-name x)))) + (or (string= x-uri *tm2rdf-name-property*) + (string= x-uri *tm2rdf-variant-property*) + (string= x-uri *tm2rdf-occurrence-property*) + (string= x-uri *tm2rdf-role-property*) + (string= x-uri *tm2rdf-subjectIdentifier-property*) + (string= x-uri *tm2rdf-itemIdentity-property*) + (string= x-uri *tm2rdf-value-property*) + (string= x-uri *tm2rdf-scope-property*) + (string= x-uri *tm2rdf-nametype-property*) + (string= x-uri *tm2rdf-varianttype-property*) + (string= x-uri *tm2rdf-associationtype-property*) + (string= x-uri *tm2rdf-occurrencetype-property*) + (string= x-uri *tm2rdf-roletype-property*) + (string= x-uri *tm2rdf-subjectLocator-property*)))) + content)))) + + +(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri + &key (parent-xml-base nil) + (collected-nodes nil)) + "Returns a list of all nodes that own the given nodeID and are of + type type-uri, rdf:Description or when the rdf:parseType is set to + Resource or the isidorus:value attribute is set." + (declare (dom:element current-node)) + (declare (string node-id)) + (let ((datatype (when (get-ns-attribute current-node "datatype") + t)) + (parseType (let ((attr (get-ns-attribute current-node "parseType"))) + (when (and attr + (string= attr "Literal")) + t))) + (content (child-nodes-or-text current-node :trim t)) + (xml-base (get-xml-base current-node :old-base parent-xml-base)) + (nodeID (get-ns-attribute current-node "nodeID")) + (node-uri-p (let ((node-uri + (concatenate-uri (dom:namespace-uri current-node) + (get-node-name current-node))) + (description (concatenate 'string *rdf-ns* + "Description"))) + (or (string= node-uri (if type-uri type-uri "")) + (string= node-uri description) + (get-ns-attribute current-node "type") + (get-ns-attribute current-node "value" + :ns-uri *tm2rdf-ns*) + (get-ns-attribute current-node "itemIdentity" + :ns-uri *tm2rdf-ns*) + (let ((parseType (get-ns-attribute current-node + "parseType"))) + (when parseType + (string= parseType "Resource"))))))) + (remove-duplicates + (remove-if + #'null + (if (or datatype parseType (stringp content) (not content)) + (if (and (string= nodeID node-id) node-uri-p) + (append (list (list :elem current-node + :xml-base xml-base)) + collected-nodes) + collected-nodes) + (if (and (string= nodeID node-id) node-uri-p) + (loop for item across content + append (get-all-isidorus-nodes-by-id + node-id item type-uri + :collected-nodes (append + (list (list :elem current-node + :xml-base xml-base)) + collected-nodes) + :parent-xml-base xml-base)) + (loop for item across content + append (get-all-isidorus-nodes-by-id + node-id item type-uri + :collected-nodes collected-nodes + :parent-xml-base xml-base))))) + :test #'(lambda(x y) + (eql (getf x :elem) (getf y :elem)))))) + + +(defun filter-isidorus-literals (literals) + "Removes all literals that are known isidorus properties which + are able to contain literal data." + (remove-if #'(lambda(x) + (or (string= (getf x :type) + *tm2rdf-subjectIdentifier-property*) + (string= (getf x :type) + *tm2rdf-itemIdentity-property*) + (string= (getf x :type) + *tm2rdf-subjectLocator-property*))) + literals)) + + +(defun self-or-child-node (property-node type-uri &key (xml-base)) + "Returns either the passed node or the child-node when it is + rdf:Description." + (declare (dom:element property-node)) + (let ((content (child-nodes-or-text property-node :trim t))) + (if (and (= (length content) 1) + (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*) + (string= (get-node-name (elt content 0)) "Description")) + (string= (concatenate-uri (dom:namespace-uri (elt content 0)) + (get-node-name (elt content 0))) + type-uri))) + (list :elem (elt content 0) + :xml-base (get-xml-base (elt content 0) :old-base xml-base)) + (list :elem property-node + :xml-base xml-base)))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 2 08:56:17 2009 @@ -545,307 +545,3 @@ :psi (get-ns-attribute elem "type"))))))) -(defun get-type-psis (elem tm-id - &key (parent-xml-base nil)) - "Returns a list of type-uris of the passed node." - (let ((types (get-types-of-node elem tm-id - :parent-xml-base parent-xml-base))) - (remove-if #'null - (map 'list #'(lambda(x) - (getf x :psi)) - types)))) - - -(defun get-all-type-psis-of-id (nodeID tm-id document) - "Returns a list of type-uris for resources identified by the given - nodeID by analysing the complete XML-DOM." - (let ((root (elt (dom:child-nodes document) 0))) - (remove-duplicates - (remove-if #'null - (if (and (string= (dom:namespace-uri root) *rdf-ns*) - (string= (get-node-name root)"RDF")) - (loop for node across (child-nodes-or-text root) - append (get-all-type-psis-across-dom - root tm-id :resource-id nodeID)) - (get-all-type-psis-across-dom - root tm-id :resource-id nodeID))) - :test #'string=))) - - -(defun get-all-type-psis (elem tm-id &key (parent-xml-base nil)) - "Returns a list of type-uris for the element by analysing the complete - XML-DOM." - (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) - (let ((root (elt (dom:child-nodes (dom:owner-document elem)) 0)) - (nodeID (get-ns-attribute elem "nodeID")) - (about (get-absolute-attribute elem tm-id xml-base "about"))) - (remove-duplicates - (remove-if #'null - (if (or nodeID about) - (if (and (string= (dom:namespace-uri root) *rdf-ns*) - (string= (get-node-name root) "RDF")) - (loop for node across (child-nodes-or-text root) - append (get-all-type-psis-across-dom - root tm-id :resource-uri about - :resource-id nodeID)) - (get-all-type-psis-across-dom - root tm-id :resource-uri about - :resource-id nodeID)) - (get-type-psis elem tm-id :parent-xml-base parent-xml-base))) - :test #'string=)))) - - -(defun get-all-type-psis-across-dom (elem tm-id &key (parent-xml-base nil) - (resource-uri nil) (resource-id nil) - (types nil)) - "Returns a list of type PSI strings collected over the complete XML-DOM - corresponding to the passed id's or uri." - (when (or resource-uri resource-id) - (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) - (let ((datatype (when (get-ns-attribute elem "datatype") - t)) - (parseType (when (get-ns-attribute elem "parseType") - (string= (get-ns-attribute elem "parseType") - "Literal")))) - (if (or datatype parseType) - types - (let ((nodeID (get-ns-attribute elem "nodeID")) - (about (get-absolute-attribute elem tm-id xml-base "about"))) - (let ((fn-types - (append types - (when (or (and about resource-uri - (string= about resource-uri)) - (and nodeID resource-id - (string= nodeID resource-id))) - (get-type-psis elem tm-id - :parent-xml-base xml-base)))) - (content (child-nodes-or-text elem :trim t))) - (if (or (stringp content) - (not content)) - fn-types - (loop for child-node across content - append (get-all-type-psis-across-dom - child-node tm-id :parent-xml-base xml-base - :resource-uri resource-uri - :resource-id resource-id - :types fn-types)))))))))) - - -(defun type-p (elem type-uri tm-id &key (parent-xml-base nil)) - "Returns t if the type-uri is a type of elem." - (declare (string tm-id type-uri)) - (declare (dom:element elem)) - (tm-id-p tm-id "type-p") - (find type-uri (get-all-type-psis elem tm-id - :parent-xml-base parent-xml-base) - :test #'string=)) - - -(defun type-of-id-p (node-id type-uri tm-id document) - "Returns t if type-uri is a type of the passed node-id." - (declare (string node-id type-uri tm-id)) - (declare (dom:document document)) - (tm-id-p tm-id "type-of-ndoe-id-p") - (find type-uri (get-all-type-psis-of-id node-id tm-id document) - :test #'string=)) - - -(defun property-name-of-node-p (elem property-name-uri) - "Returns t if the elements tag-name and namespace are equal - to the given uri." - (declare (dom:element elem)) - (declare (string property-name-uri)) - (when property-name-uri - (let ((uri (concatenate-uri (dom:namespace-uri elem) - (get-node-name elem)))) - (string= uri property-name-uri)))) - - -(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil) - (ignore-topic nil)) - "Returns t if the passed element is not of an isidorus' type. - The environmental property is not analysed by this function!" - (declare (dom:element elem)) - (declare (string tm-id)) - (let ((nodeID (get-ns-attribute elem "nodeID")) - (document (dom:owner-document elem)) - (types - (let ((b-types - (list - *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri* - *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri* - *tm2rdf-role-type-uri*)) - (a-types (list *tm2rdf-topic-type-uri*))) - (if ignore-topic - b-types - (append a-types b-types))))) - (if nodeID - (not (loop for type in types - when (type-of-id-p nodeId type tm-id document) - return t)) - (not (loop for type in types - when (type-p elem type tm-id - :parent-xml-base parent-xml-base) - return t))))) - - -(defun isidorus-type-p (property-elem-or-node-elem tm-id what - &key(parent-xml-base nil)) - "Returns t if the node elem is of the type isidorus: and is - contained in a porperty isidorus:." - (declare (dom:element property-elem-or-node-elem)) - (declare (symbol what)) - (tm-id-p tm-id "isidorus-type-p") - (let ((xml-base (get-xml-base property-elem-or-node-elem - :old-base parent-xml-base)) - (type-and-property (cond - ((eql what 'name) - (list :type *tm2rdf-name-type-uri* - :property *tm2rdf-name-property*)) - ((eql what 'variant) - (list :type *tm2rdf-variant-type-uri* - :property *tm2rdf-variant-property*)) - ((eql what 'occurrence) - (list :type *tm2rdf-occurrence-type-uri* - :property *tm2rdf-occurrence-property*)) - ((eql what 'role) - (list :type *tm2rdf-role-type-uri* - :property *tm2rdf-role-property*)) - ((eql what 'topic) - (list :type *tm2rdf-topic-type-uri*)) - ((eql what 'association) - (list :type - *tm2rdf-association-type-uri*))))) - (when type-and-property - (let ((type (getf type-and-property :type)) - (property (getf type-and-property :property)) - (nodeID (get-ns-attribute property-elem-or-node-elem "nodeID")) - (document (dom:owner-document property-elem-or-node-elem)) - (elem-uri (concatenate-uri - (dom:namespace-uri - property-elem-or-node-elem) - (get-node-name property-elem-or-node-elem)))) - (if (or (string= type *tm2rdf-topic-type-uri*) - (string= type *tm2rdf-association-type-uri*) - (let ((parseType (get-ns-attribute property-elem-or-node-elem - "parseType"))) - (and parseType - (string= parseType "Resource"))) - (get-ns-attribute property-elem-or-node-elem "type") - (get-ns-attribute property-elem-or-node-elem "value" - :ns-uri *tm2rdf-ns*) - (get-ns-attribute property-elem-or-node-elem "itemIdentity" - :ns-uri *tm2rdf-ns*)) - (type-p property-elem-or-node-elem type tm-id - :parent-xml-base parent-xml-base) - (when (string= elem-uri property) - (if nodeID - (type-of-id-p nodeId type tm-id document) - (let ((content (child-nodes-or-text property-elem-or-node-elem - :trim t))) - (when (and (= (length content) 1) - (not (stringp content))) - (type-p (elt content 0) type tm-id - :parent-xml-base xml-base)))))))))) - - -(defun non-isidorus-child-nodes-or-text (elem &key (trim nil)) - "Returns a list of node elements that are no isidorus properties, e.g. - isidorus:name, string-content or nil." - (let ((content (child-nodes-or-text elem :trim trim))) - (if (or (not content) - (stringp content)) - content - (remove-if #'(lambda(x) - (let ((x-uri (if (dom:namespace-uri x) - (concatenate-uri (dom:namespace-uri x) - (get-node-name x)) - (get-node-name x)))) - (or (string= x-uri *tm2rdf-name-property*) - (string= x-uri *tm2rdf-variant-property*) - (string= x-uri *tm2rdf-occurrence-property*) - (string= x-uri *tm2rdf-role-property*) - (string= x-uri *tm2rdf-subjectIdentifier-property*) - (string= x-uri *tm2rdf-itemIdentity-property*) - (string= x-uri *tm2rdf-value-property*) - (string= x-uri *tm2rdf-scope-property*) - (string= x-uri *tm2rdf-nametype-property*) - (string= x-uri *tm2rdf-varianttype-property*) - (string= x-uri *tm2rdf-associationtype-property*) - (string= x-uri *tm2rdf-occurrencetype-property*) - (string= x-uri *tm2rdf-roletype-property*) - (string= x-uri *tm2rdf-subjectLocator-property*)))) - content)))) - - -(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri - &key (parent-xml-base nil) - (collected-nodes nil)) - "Returns a list of all nodes that own the given nodeID and are of - type type-uri, rdf:Description or when the rdf:parseType is set to - Resource or the isidorus:value attribute is set." - (declare (dom:element current-node)) - (declare (string node-id)) - (let ((datatype (when (get-ns-attribute current-node "datatype") - t)) - (parseType (let ((attr (get-ns-attribute current-node "parseType"))) - (when (and attr - (string= attr "Literal")) - t))) - (content (child-nodes-or-text current-node :trim t)) - (xml-base (get-xml-base current-node :old-base parent-xml-base)) - (nodeID (get-ns-attribute current-node "nodeID")) - (node-uri-p (let ((node-uri - (concatenate-uri (dom:namespace-uri current-node) - (get-node-name current-node))) - (description (concatenate 'string *rdf-ns* - "Description"))) - (or (string= node-uri (if type-uri type-uri "")) - (string= node-uri description) - (get-ns-attribute current-node "type") - (get-ns-attribute current-node "value" - :ns-uri *tm2rdf-ns*) - (get-ns-attribute current-node "itemIdentity" - :ns-uri *tm2rdf-ns*) - (let ((parseType (get-ns-attribute current-node - "parseType"))) - (when parseType - (string= parseType "Resource"))))))) - (remove-duplicates - (remove-if - #'null - (if (or datatype parseType (stringp content) (not content)) - (if (and (string= nodeID node-id) node-uri-p) - (append (list (list :elem current-node - :xml-base xml-base)) - collected-nodes) - collected-nodes) - (if (and (string= nodeID node-id) node-uri-p) - (loop for item across content - append (get-all-isidorus-nodes-by-id - node-id item type-uri - :collected-nodes (append - (list (list :elem current-node - :xml-base xml-base)) - collected-nodes) - :parent-xml-base xml-base)) - (loop for item across content - append (get-all-isidorus-nodes-by-id - node-id item type-uri - :collected-nodes collected-nodes - :parent-xml-base xml-base))))) - :test #'(lambda(x y) - (eql (getf x :elem) (getf y :elem)))))) - - -(defun filter-isidorus-literals (literals) - "Removes all literals that are known isidorus properties which - are able to contain literal data." - (remove-if #'(lambda(x) - (or (string= (getf x :type) - *tm2rdf-subjectIdentifier-property*) - (string= (getf x :type) - *tm2rdf-itemIdentity-property*) - (string= (getf x :type) - *tm2rdf-subjectLocator-property*))) - literals)) \ No newline at end of file From lgiessmann at common-lisp.net Wed Sep 2 14:15:47 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 02 Sep 2009 10:15:47 -0400 Subject: [isidorus-cvs] r130 - in trunk/src: unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Wed Sep 2 10:15:46 2009 New Revision: 130 Log: rdf-importer: added the functionality of importing isidorus:Occurrence nodes; added also some unti tests Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/isidorus_constructs_tools.lisp Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Wed Sep 2 10:15:46 2009 @@ -72,7 +72,8 @@ :test-get-all-type-psis :test-isidorus-type-p :test-get-all-isidorus-nodes-by-id - :test-import-isidorus-name)) + :test-import-isidorus-name + :test-import-isidorus-occurrence)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -3479,6 +3480,103 @@ *xml-string*)))))))) +(test test-import-isidorus-occurrence + "Tests all functions that are responsible to import a resource + representing isidorus:Occurrence." + (let ((revision-1 100) + (tm-id "http://test/tm-id") + (document-id "doc-id") + (db-dir "./data_base") + (doc-1 + (concatenate 'string "" + " " + " " + " " + " " + " value-1" + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + " " + + " " + " " + " value-2" + " " + " http://itemIdentity-1" + " http://itemIdentity-2" + " anyText" + " " + ""))) + (let ((root (elt (dom:child-nodes (cxml:parse doc-1 + (cxml-dom:make-dom-builder))) + 0))) + (is (= (length (rdf-importer::child-nodes-or-text root)) 2)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (rdf-importer::import-dom root revision-1 :tm-id tm-id + :document-id document-id) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd:NameC))) 0) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 26)) + (let ((node-1 (d:get-item-by-psi "http://node-1")) + (occurrence-1 (d:get-item-by-psi "http://occurrence-1")) + (occurrence-2 (d:get-item-by-psi "http://occurrence-2")) + (occurrence-3 (d:get-item-by-psi "http://occurrence-3")) + (scope-1 (d:get-item-by-psi "http://scope-1")) + (scope-2 (d:get-item-by-psi "http://scope-2"))) + (is-true node-1) + (is-true occurrence-1) + (is-true occurrence-2) + (is-true occurrence-3) + (is-true scope-1) + (is-true scope-2) + (let ((occ-1 (find-if #'(lambda(x) + (eql (d:instance-of x) occurrence-1)) + (d:occurrences node-1))) + (occ-2 (find-if #'(lambda(x) + (eql (d:instance-of x) occurrence-2)) + (d:occurrences node-1))) + (occ-3 (find-if #'(lambda(x) + (eql (d:instance-of x) occurrence-3)) + (d:occurrences node-1)))) + (is-true occ-1) + (is-true occ-2) + (is-true occ-3) + (is-false (d:item-identifiers occ-1)) + (is-false (d:themes occ-1)) + (is (string= (d:charvalue occ-1) "value-1")) + (is (string= (d:datatype occ-1) (concatenate 'string tm-id "/dt-1"))) + (is (= (length (intersection + (d:item-identifiers occ-2) + (list (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri + "http://itemIdentity-1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri + "http://itemIdentity-2")))) + 2)) + (is (= (length (intersection (list scope-1 scope-2) + (d:themes occ-2))) + 2)) + (is (string= (d:charvalue occ-2) "value-2")) + (is (string= (d:datatype occ-2) *xml-string*)) + (is-false (d:item-identifiers occ-3)) + (is-false (d:themes occ-3)) + (is (string= (d:charvalue occ-3) "")) + (is (string= (d:datatype occ-3) *xml-string*))))))) + (defun run-rdf-importer-tests() "Runs all defined tests." @@ -3507,4 +3605,5 @@ (it.bese.fiveam:run! 'test-get-all-type-psis) (it.bese.fiveam:run! 'test-isidorus-type-p) (it.bese.fiveam:run! 'test-get-all-isidorus-nodes-by-id) - (it.bese.fiveam:run! 'test-import-isidorus-name)) \ No newline at end of file + (it.bese.fiveam:run! 'test-import-isidorus-name) + (it.bese.fiveam:run! 'test-import-isidorus-occurrence)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 2 10:15:46 2009 @@ -104,7 +104,8 @@ (ID (get-absolute-attribute elem tm-id xml-base "ID")) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (parse-properties-of-node elem (or about nodeID ID UUID)) - ;TODO: create associaitons and roles + ;TODO: create associations and roles -> and iterate in import-dom + ; over those elements (let ((literals (append (get-literals-of-node elem fn-xml-lang) (get-literals-of-node-content elem tm-id xml-base fn-xml-lang))) @@ -126,8 +127,11 @@ :item-identifiers item-identifiers :subject-locators subject-locators))) (make-isidorus-names elem this tm-id start-revision - :owner-xml-base fn-xml-base) - ;TODO: create topic occurrences + :owner-xml-base fn-xml-base + :document-id document-id) + (make-isidorus-occurrences elem this tm-id start-revision + :owner-xml-base fn-xml-base + :document-id document-id) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations this associations xml-importer::tm @@ -143,17 +147,70 @@ this)))))) +(defun make-isidorus-occurrences (owner-elem owner-topic tm-id start-revision + &key (owner-xml-base nil) + (document-id *document-id*)) + "Creates all occurrences of resource nodes that are in a + property isidorus:occurrence and have the type isidorus:Occurrence." + (declare (dom:element owner-elem)) + (declare (string tm-id)) + (declare (TopicC owner-topic)) + (let ((content (child-nodes-or-text owner-elem :trim t)) + (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) + (err-pref "From make-isidorus-occurrence(): ")) + (when (and (not (stringp content)) + (> (length content) 0)) + (loop for property across content + when (isidorus-type-p property tm-id 'occurrence + :parent-xml-base owner-xml-base) + collect + (let ((xml-base (get-xml-base property + :old-base owner-xml-base))) + (let ((nodes + (let ((nodeID (nodeID-of-property-or-child property))) + (if nodeID + (get-all-isidorus-nodes-by-id + nodeID root *tm2rdf-occurrence-type-uri*) + (list (self-or-child-node + property *tm2rdf-occurrence-type-uri* + :xml-base xml-base)))))) + (let ((item-identities + (remove-if #'null + (loop for node in nodes + append (make-isidorus-identifiers + (getf node :elem) start-revision)))) + (occurrence-type (make-x-type + nodes tm-id start-revision + *tm2rdf-occurrencetype-property* + :document-id document-id)) + (value-and-datatype (make-value nodes tm-id)) + (occurrence-scopes (make-scopes nodes tm-id start-revision + :document-id document-id))) + (unless occurrence-type + (error "~aoccurrencetype is missing!" + err-pref)) + (make-construct 'OccurrenceC + :start-revision start-revision + :topic owner-topic + :themes occurrence-scopes + :item-identifiers item-identities + :instance-of occurrence-type + :charvalue (getf value-and-datatype :value) + :datatype (getf value-and-datatype + :datatype))))))))) + (defun make-isidorus-names (owner-elem owner-topic tm-id start-revision &key (owner-xml-base nil) (document-id *document-id*)) - "Creates all names of a resource node that are in a property isidorus:name + "Creates all names of resource nodes that are in a property isidorus:name and have the type isidorus:Name." (declare (dom:element owner-elem)) (declare (string tm-id)) (declare (TopicC owner-topic)) (let ((content (child-nodes-or-text owner-elem :trim t)) - (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0))) + (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) + (err-pref "From make-isidorus-name(): ")) (when (and (not (stringp content)) (> (length content) 0)) (loop for property across content @@ -163,7 +220,7 @@ (let ((xml-base (get-xml-base property :old-base owner-xml-base))) (let ((nodes - (let ((nodeID (get-ns-attribute property "nodeID"))) + (let ((nodeID (nodeID-of-property-or-child property))) (if nodeID (get-all-isidorus-nodes-by-id nodeID root *tm2rdf-name-type-uri*) @@ -175,11 +232,15 @@ (loop for node in nodes append (make-isidorus-identifiers (getf node :elem) start-revision)))) - (name-type (make-name-type nodes tm-id start-revision - :document-id document-id)) + (name-type (make-x-type nodes tm-id start-revision + *tm2rdf-nametype-property* + :document-id document-id)) (name-value (getf (make-value nodes tm-id) :value)) (name-scopes (make-scopes nodes tm-id start-revision :document-id document-id))) + (unless name-type + (error "~anametype is missing!" + err-pref)) (let ((this (make-construct 'NameC :start-revision start-revision @@ -200,7 +261,8 @@ (let ((root (when name-nodes (elt (dom:child-nodes - (dom:owner-document (getf (first name-nodes) :elem))) 0)))) + (dom:owner-document (getf (first name-nodes) :elem))) 0))) + (err-pref "From make-isidorus-variant(): ")) (remove-if #'null (loop for name-node in name-nodes @@ -237,7 +299,10 @@ (make-scopes nodes tm-id start-revision :document-id document-id) (themes owner-name))) ;XTM 2.0: 4.12 - (value-and-type (make-value nodes tm-id))) + (value-and-type (make-value nodes tm-id))) + (unless variant-scopes + (error "~ascope is missing!" + err-pref)) (make-construct 'VariantC :start-revision start-revision :item-identifiers item-identities @@ -336,7 +401,7 @@ -(defun make-name-type (node-list tm-id start-revision +(defun make-x-type (node-list tm-id start-revision uri-of-property &key (document-id *document-id*)) "Creates a topic stub that is the type of the name represented by the passed nodes." @@ -348,7 +413,7 @@ when (let ((prop-ns (dom:namespace-uri property)) (prop-name (get-node-name property))) (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-nametype-property*)) + uri-of-property)) return property)) return (let ((content (child-nodes-or-text (getf node :elem) :trim t))) @@ -356,7 +421,7 @@ when (let ((prop-ns (dom:namespace-uri property)) (prop-name (get-node-name property))) (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-nametype-property*)) + uri-of-property)) return (list :elem property :xml-base (get-xml-base property @@ -368,7 +433,7 @@ (let ((type-uri (get-ref-of-property (getf property :elem) tm-id (getf property :xml-base)))) (unless type-uri - (error "From make-name-type(): type-uri is missing!")) + (error "From make-x-type(): type-uri is missing!")) (with-tm (start-revision document-id tm-id) (make-topic-stub (getf type-uri :psi) nil (getf type-uri :topicid) nil start-revision @@ -430,7 +495,9 @@ (make-isidorus-names elem this tm-id start-revision :owner-xml-base xml-base :document-id document-id) - ;TDOD: create topic occurrences + (make-isidorus-occurrences + elem this tm-id start-revision + :owner-xml-base xml-base :document-id document-id) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations Modified: trunk/src/xml/rdf/isidorus_constructs_tools.lisp ============================================================================== --- trunk/src/xml/rdf/isidorus_constructs_tools.lisp (original) +++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Wed Sep 2 10:15:46 2009 @@ -317,4 +317,19 @@ (list :elem (elt content 0) :xml-base (get-xml-base (elt content 0) :old-base xml-base)) (list :elem property-node - :xml-base xml-base)))) \ No newline at end of file + :xml-base xml-base)))) + + +(defun nodeID-of-property-or-child (elem) + "Returns either the nodeID of the given element or if tere isn't one + the nodeID of the element's first child node. If there is no nodeID + at all, nil is returned." + (declare (dom:element elem)) + (let ((elem-nodeID (get-ns-attribute elem "nodeID"))) + (if elem-nodeID + elem-nodeID + (let ((elem-content (child-nodes-or-text elem :trim t))) + (when (and (> (length elem-content) 0) + (not (stringp elem-content))) + (get-ns-attribute (elt elem-content 0) "nodeID")))))) + \ No newline at end of file From lgiessmann at common-lisp.net Thu Sep 3 14:57:43 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 03 Sep 2009 10:57:43 -0400 Subject: [isidorus-cvs] r131 - in trunk/src: . unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Thu Sep 3 10:57:42 2009 New Revision: 131 Log: rdf-importer: fixed some problems with importing isidorus-types; added importers and unit tests for isidorus:Association and isidorus:Role Modified: trunk/src/constants.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/isidorus_constructs_tools.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Thu Sep 3 10:57:42 2009 @@ -60,7 +60,8 @@ :*tm2rdf-varianttype-property* :*tm2rdf-occurrencetype-property* :*tm2rdf-roletype-property* - :*tm2rdf-associationtype-property*)) + :*tm2rdf-associationtype-property* + :*tm2rdf-player-property*)) (in-package :constants) @@ -165,3 +166,5 @@ (defparameter *tm2rdf-roletype-property* (concatenate 'string *tm2rdf-ns* "roletype")) (defparameter *tm2rdf-associationtype-property* (concatenate 'string *tm2rdf-ns* "associationtype")) + +(defparameter *tm2rdf-player-property* (concatenate 'string *tm2rdf-ns* "player")) Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Thu Sep 3 10:57:42 2009 @@ -73,7 +73,8 @@ :test-isidorus-type-p :test-get-all-isidorus-nodes-by-id :test-import-isidorus-name - :test-import-isidorus-occurrence)) + :test-import-isidorus-occurrence + :test-import-isidorus-association)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -3275,7 +3276,8 @@ " " " " " " + " xml:base=\"http://base/\"" + " xml:lang=\"de\">" " " " " @@ -3300,7 +3302,8 @@ (rdf-importer::child-nodes-or-text (elt (rdf-importer::child-nodes-or-text root) 4)) 0)) 0) - :xml-base "http://base/suffix"))) + :xml-base "http://base/" + :xml-lang "de"))) (node-id-2 (elt (rdf-importer::child-nodes-or-text root) 1)) (node-id-3 (elt (rdf-importer::child-nodes-or-text root) 3)) (node-id-4 (elt (rdf-importer::child-nodes-or-text root) 4))) @@ -3318,9 +3321,10 @@ (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id "node-id-4" root sw-node)) :elem) node-id-4)) - (is (string= (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :xml-base) - "http://base/")) + (is-false (getf (first (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-4" root sw-node)) :xml-base)) + (is-false (getf (first (rdf-importer::get-all-isidorus-nodes-by-id + "node-id-4" root sw-node)) :xml-lang)) (is (= (length (intersection node-id-1 (rdf-importer::get-all-isidorus-nodes-by-id @@ -3578,6 +3582,136 @@ (is (string= (d:datatype occ-3) *xml-string*))))))) +(test test-import-isidorus-association + "Tests all functions that are responsible to import a resource + representing isidorus:Association." + (let ((revision-1 100) + (tm-id "http://test/tm-id") + (document-id "doc-id") + (db-dir "./data_base") + (doc-1 + (concatenate 'string "" + " " + " " + " " + " " + " " + " " + " http://sl-1" + " http://sl-2" + " " + " " + " " + " value-1" + " " + " value-of-arc" + " " + " " + " " + " " + " http://itemIdentity-a1" + " http://itemIdentity-a2" + " " + " " + + " " + " " + " " + " http://itemIdentity-3" + " " + " " + + " " + " http://itemIdentity-a1" + " " + " " + " " + " " + " " + " " + " " + " " + " http://itemIdentity-3" + " " + " " + " " + ""))) + (let ((root (elt (dom:child-nodes (cxml:parse doc-1 + (cxml-dom:make-dom-builder))) + 0))) + (is (= (length (rdf-importer::child-nodes-or-text root)) 3)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (rdf-importer::import-dom root revision-1 :tm-id tm-id + :document-id document-id) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (setf d::*current-xtm* document-id) + (let ((assoc (first (elephant:get-instances-by-class 'd:AssociationC))) + (assoc-type (d:get-item-by-psi "http://associationtype-1")) + (scope-1 (d:get-item-by-psi "http://scope-1")) + (player-1 (d:get-item-by-psi "http://player-1")) + (player-2 (d:get-item-by-id "player-2")) + (roletype-1 (d:get-item-by-id "roletype-1")) + (roletype-2 (d:get-item-by-psi "http://roletype-2")) + (nametype-1 (d:get-item-by-psi "http://nametype-1")) + (scope-2 (d:get-item-by-psi "http://scope-2"))) + (let ((role-1 (first (d:used-as-type roletype-1))) + (role-2 (first (d:used-as-type roletype-2)))) + (is-true scope-1) + (is (= (length (intersection + (list + (elephant:get-instance-by-value 'd:SubjectLocatorC + 'd:uri "http://sl-1") + (elephant:get-instance-by-value 'd:SubjectLocatorC + 'd:uri "http://sl-2")) + (d:locators scope-1))) + 2)) + (is (= (length (d:names scope-1)) 1)) + (is (eql (d:instance-of (first (d:names scope-1))) nametype-1)) + (is (string= (d:charvalue (first (d:names scope-1))) "value-1")) + (is (= (length (d:themes (first (d:names scope-1)))) 1)) + (is-false (d:psis (first (d:themes (first (d:names scope-1)))))) + (is-true player-1) + (is-true player-2) + (is-true roletype-1) + (is (string= (d:uri (first (d::topic-identifiers roletype-1))) + "roletype-1")) + (is-true roletype-2) + (is-true assoc-type) + (is-true scope-2) + (is-true role-1) + (is (= (length (intersection + (list + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://itemIdentity-3")) + (d:item-identifiers role-1))) + 1)) + (is (eql player-1 (d:player role-1))) + (is-true role-2) + (is-false (d:item-identifiers role-2)) + (is (eql player-2 (d:player role-2))) + (is (= (length (intersection (d:roles assoc) + (list role-1 role-2))) + 2)) + (is (= (length (intersection + (d:themes assoc) + (list scope-1 scope-2))) + 2)) + (is (= (length + (intersection + (d:item-identifiers assoc) + (list + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://itemIdentity-a1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://itemIdentity-a2")))) + 2))))))) + + (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3606,4 +3740,5 @@ (it.bese.fiveam:run! 'test-isidorus-type-p) (it.bese.fiveam:run! 'test-get-all-isidorus-nodes-by-id) (it.bese.fiveam:run! 'test-import-isidorus-name) - (it.bese.fiveam:run! 'test-import-isidorus-occurrence)) \ No newline at end of file + (it.bese.fiveam:run! 'test-import-isidorus-occurrence) + (it.bese.fiveam:run! 'test-import-isidorus-association)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Thu Sep 3 10:57:42 2009 @@ -86,9 +86,19 @@ (loop for child across children when (non-isidorus-type-p child tm-id :parent-xml-base xml-base) do (import-node child tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang))) + :xml-base xml-base :xml-lang xml-lang) + when (isidorus-type-p child tm-id 'association + :parent-xml-base xml-base) + do (make-isidorus-association child tm-id start-revision + :parent-xml-base xml-base + :document-id document-id)))) + (if (isidorus-type-p rdf-dom tm-id 'association + :parent-xml-base xml-base) + (make-isidorus-association rdf-dom tm-id start-revision + :parent-xml-base xml-base + :document-id document-id) + (import-node rdf-dom tm-id start-revision :document-id document-id + :xml-base xml-base :xml-lang xml-lang)))) (setf *_n-map* nil)) @@ -104,47 +114,166 @@ (ID (get-absolute-attribute elem tm-id xml-base "ID")) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (parse-properties-of-node elem (or about nodeID ID UUID)) - ;TODO: create associations and roles -> and iterate in import-dom - ; over those elements - (let ((literals (append (get-literals-of-node elem fn-xml-lang) - (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations (get-associations-of-node-content elem tm-id xml-base)) - (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) - (super-classes - (get-super-classes-of-node-content elem tm-id xml-base)) - (subject-identities (make-isidorus-identifiers - elem start-revision :what "subjectIdentifier")) - (item-identifiers (make-isidorus-identifiers elem start-revision)) - (subject-locators (make-isidorus-identifiers elem start-revision - :what "subjectLocator"))) - (with-tm (start-revision document-id tm-id) - (let ((this - (make-topic-stub - about ID nodeID UUID start-revision xml-importer::tm - :document-id document-id - :additional-subject-identifiers subject-identities - :item-identifiers item-identifiers - :subject-locators subject-locators))) - (make-isidorus-names elem this tm-id start-revision - :owner-xml-base fn-xml-base - :document-id document-id) - (make-isidorus-occurrences elem this tm-id start-revision - :owner-xml-base fn-xml-base - :document-id document-id) - (make-literals this literals tm-id start-revision - :document-id document-id) - (make-associations this associations xml-importer::tm - start-revision :document-id document-id) - (make-types this types xml-importer::tm start-revision - :document-id document-id) - (make-super-classes this super-classes xml-importer::tm - start-revision :document-id document-id) - (make-recursion-from-node elem tm-id start-revision - :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) - this)))))) + (let ((literals (append (get-literals-of-node elem fn-xml-lang) + (get-literals-of-node-content + elem tm-id xml-base fn-xml-lang))) + (associations (get-associations-of-node-content elem tm-id xml-base)) + (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) + (super-classes + (get-super-classes-of-node-content elem tm-id xml-base)) + (subject-identities (make-isidorus-identifiers + (list elem) + start-revision :what "subjectIdentifier")) + (item-identifiers (make-isidorus-identifiers (list elem) + start-revision)) + (subject-locators (make-isidorus-identifiers + (list elem) start-revision :what "subjectLocator"))) + (with-tm (start-revision document-id tm-id) + (let ((this + (make-topic-stub + about ID nodeID UUID start-revision xml-importer::tm + :document-id document-id + :additional-subject-identifiers subject-identities + :item-identifiers item-identifiers + :subject-locators subject-locators))) + (make-isidorus-names elem this tm-id start-revision + :owner-xml-base fn-xml-base + :document-id document-id) + (make-isidorus-occurrences elem this tm-id start-revision + :owner-xml-base fn-xml-base + :document-id document-id) + (make-literals this literals tm-id start-revision + :document-id document-id) + (make-associations this associations xml-importer::tm + start-revision :document-id document-id) + (make-types this types xml-importer::tm start-revision + :document-id document-id) + (make-super-classes this super-classes xml-importer::tm + start-revision :document-id document-id) + (make-recursion-from-node elem tm-id start-revision + :document-id document-id + :xml-base xml-base + :xml-lang xml-lang) + this)))))) + + +(defun make-isidorus-association (elem tm-id start-revision + &key (parent-xml-base nil) + (document-id *document-id*)) + "Creates an association element of the passed DOM node." + (declare (dom:element elem)) + (declare (string tm-id)) + (let ((nodeID (get-ns-attribute elem "nodeID")) + (err-pref "From make-isidorus-association(): ") + (root (elt (dom:child-nodes (dom:owner-document elem)) 0))) + (let ((nodes (if nodeID + (get-all-isidorus-nodes-by-id + nodeId root *tm2rdf-association-type-uri*) + (list (list :elem elem + :xml-base parent-xml-base))))) + (let ((item-identities + (make-isidorus-identifiers + (map 'list #'(lambda(x) + (getf x :elem)) + nodes) start-revision)) + (association-type (import-topic-of-property + nodes tm-id start-revision + *tm2rdf-associationtype-property* + :document-id document-id)) + (association-scopes (make-scopes nodes tm-id start-revision + :document-id document-id)) + (association-roles (make-isidorus-roles + nodes tm-id start-revision + :document-id document-id))) + (unless association-type + (error "~aassociation type is missing!" err-pref)) + (unless association-roles + (error "~aassociation roles are missing!" err-pref)) + (with-tm (start-revision document-id tm-id) + (add-to-topicmap + xml-importer::tm + (make-construct 'AssociationC + :start-revision start-revision + :item-identifiers item-identities + :instance-of association-type + :themes association-scopes + :roles association-roles))))))) + + +(defun make-isidorus-roles (association-nodes tm-id start-revision + &key (document-id *document-id*)) + "Returns a list of property list of the form + (:instance-of :player :item-identifiers <(ItemIdentifierC)>)." + (declare (string tm-id)) + (let ((err-pref "From make-isidorus-roles(): ") + (all-role-nodes (get-all-role-nodes association-nodes)) + (root (elt (dom:child-nodes (dom:owner-document + (getf (first association-nodes) + :elem))) 0))) + (when (and (not (stringp all-role-nodes)) + (> (length all-role-nodes) 0)) + (loop for property in all-role-nodes + collect + (let ((nodeID (nodeId-of-property-or-child (getf property :elem)))) + (let ((nodes (if nodeID + (get-all-isidorus-nodes-by-id + nodeId root *tm2rdf-role-type-uri*) + (list (list :elem (getf property :elem) + :xml-base (getf property :xml-base) + :xml-lang + (getf property :xml-lang)))))) + (let ((item-identities + (make-isidorus-identifiers + (map 'list #'(lambda(x) + (getf x :elem)) + nodes) start-revision)) + (role-player (import-topic-of-property + nodes tm-id start-revision + *tm2rdf-player-property* + :document-id document-id)) + (role-type (import-topic-of-property + nodes tm-id start-revision + *tm2rdf-roletype-property* + :document-id document-id))) + (unless role-type + (error "~arole type is missing!" err-pref)) + (unless role-player + (error "~arole player is missing!" err-pref)) + (list :instance-of role-type + :player role-player + :item-identifiers item-identities)))))))) + + +(defun get-all-role-nodes (association-nodes) + "Returns all role nodes of the passed association nodes as a + property list of the form (:elem :xml-base + :xml-lang ." + (let ((nodes + (loop for association in association-nodes + append + (let ((content (child-nodes-or-text (getf association :elem) + :trim t)) + (xml-base (getf association :xml-base)) + (xml-lang (getf association :xml-lang))) + (unless (stringp content) + (loop for property across content + when (let ((node-ns (dom:namespace-uri property)) + (node-name (get-node-name property))) + (string= (concatenate-uri node-ns node-name) + *tm2rdf-role-property*)) + collect (list :elem property + :xml-base (get-xml-base + (getf association :elem) + :old-base xml-base) + :xml-lang + (get-xml-lang (getf association :elem) + :old-lang xml-lang)))))))) + (remove-duplicates + (remove-if #'null nodes) + :test #'(lambda(x y) + (string= (nodeId-of-property-or-child (getf x :elem)) + (nodeID-of-property-or-child (getf y :elem))))))) + (defun make-isidorus-occurrences (owner-elem owner-topic tm-id start-revision @@ -175,11 +304,11 @@ property *tm2rdf-occurrence-type-uri* :xml-base xml-base)))))) (let ((item-identities - (remove-if #'null - (loop for node in nodes - append (make-isidorus-identifiers - (getf node :elem) start-revision)))) - (occurrence-type (make-x-type + (make-isidorus-identifiers + (map 'list #'(lambda(x) + (getf x :elem)) + nodes) start-revision)) + (occurrence-type (import-topic-of-property nodes tm-id start-revision *tm2rdf-occurrencetype-property* :document-id document-id)) @@ -228,13 +357,14 @@ property *tm2rdf-name-type-uri* :xml-base xml-base)))))) (let ((item-identities - (remove-if #'null - (loop for node in nodes - append (make-isidorus-identifiers - (getf node :elem) start-revision)))) - (name-type (make-x-type nodes tm-id start-revision - *tm2rdf-nametype-property* - :document-id document-id)) + (make-isidorus-identifiers + (map 'list #'(lambda(x) + (getf x :elem)) + nodes) start-revision)) + (name-type (import-topic-of-property + nodes tm-id start-revision + *tm2rdf-nametype-property* + :document-id document-id)) (name-value (getf (make-value nodes tm-id) :value)) (name-scopes (make-scopes nodes tm-id start-revision :document-id document-id))) @@ -289,11 +419,10 @@ :old-base (getf name-node :xml-base)))))))) (let ((item-identities - (remove-if - #'null - (loop for node in nodes - append (make-isidorus-identifiers - (getf node :elem) start-revision)))) + (make-isidorus-identifiers + (map 'list #'(lambda(x) + (getf x :elem)) + nodes) start-revision)) (variant-scopes (append (make-scopes nodes tm-id start-revision @@ -317,36 +446,57 @@ (defun make-scopes (node-list tm-id start-revision &key (document-id *document-id*)) "Creates for every found scope a corresponding topic stub." - (let ((properties + (let ((scopes (remove-if #'null (loop for node in node-list - append (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-scope-property*)) - collect (list :elem property - :xml-base (get-xml-base - property - :old-base - (getf node :xml-base))))))))) - (let ((scope-uris - (remove-if #'null - (map 'list #'(lambda(x) - (get-ref-of-property (getf x :elem) tm-id - (getf x :xml-base))) - properties)))) - (with-tm (start-revision document-id tm-id) - (map 'list #'(lambda(x) - (let ((topicid (getf x :topicid)) - (psi (getf x :psi))) - (make-topic-stub psi nil topicid nil start-revision - xml-importer::tm - :document-id document-id))) - scope-uris))))) + append + (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + *tm2rdf-scope-property*)) + collect + (let ((nodeID (get-ns-attribute property "nodeID")) + (resource (get-absolute-attribute + property tm-id (getf node :xml-base) + "resource")) + (children (child-nodes-or-text property + :trim t)) + (parseType (let ((pT + (get-ns-attribute property + "parseType"))) + (string= pT "Resource"))) + (type (get-ns-attribute property "type"))) + (if (or parseType type) + (progn + (parse-property property "") + (import-arc property tm-id start-revision + :document-id document-id + :xml-base (getf node :xml-base) + :xml-lang (getf node :xml-lang))) + (if (or nodeID resource) + (with-tm (start-revision document-id tm-id) + (make-topic-stub resource nil nodeID nil + start-revision xml-importer::tm + :document-id document-id)) + (if (and (= (length children) 1) + (not (stringp children))) + (import-node (elt children 0) tm-id + start-revision + :document-id document-id + :xml-base + (get-xml-base + (elt children 0) + :old-base (getf node :xml-base)) + :xml-lang + (get-xml-lang + (elt children 0) + :old-lang (getf node :xml-lang))) + (error "From make-scopes(): scope-property must contain one resource!"))))))))))) + (remove-duplicates scopes))) (defun make-value (node-list tm-id) @@ -401,43 +551,72 @@ -(defun make-x-type (node-list tm-id start-revision uri-of-property - &key (document-id *document-id*)) +(defun import-topic-of-property (node-list tm-id start-revision uri-of-property + &key (document-id *document-id*)) "Creates a topic stub that is the type of the name represented by the passed nodes." - (let ((property - (loop for node in node-list - when (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - uri-of-property)) - return property)) - return (let ((content (child-nodes-or-text (getf node :elem) + (let ((err-pref "From import-topic-of-property(): ")) + (let ((tops + (loop for node in node-list + when (let ((content (child-nodes-or-text (getf node :elem) :trim t))) (loop for property across content when (let ((prop-ns (dom:namespace-uri property)) (prop-name (get-node-name property))) (string= (concatenate-uri prop-ns prop-name) uri-of-property)) - return (list - :elem property - :xml-base (get-xml-base property - :old-base - (getf - node - :xml-base)))))))) - (when property - (let ((type-uri (get-ref-of-property (getf property :elem) tm-id - (getf property :xml-base)))) - (unless type-uri - (error "From make-x-type(): type-uri is missing!")) - (with-tm (start-revision document-id tm-id) - (make-topic-stub (getf type-uri :psi) nil - (getf type-uri :topicid) nil start-revision - xml-importer::tm :document-id document-id)))))) + return property)) + append + (let ((content (child-nodes-or-text (getf node :elem) + :trim t))) + (loop for property across content + when (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property))) + (string= (concatenate-uri prop-ns prop-name) + uri-of-property)) + collect + (let ((nodeID (get-ns-attribute property "nodeID")) + (resource (get-absolute-attribute + property tm-id (getf node :xml-base) + "resource")) + (children (child-nodes-or-text property + :trim t)) + (parseType (let ((pT + (get-ns-attribute property + "parseType"))) + (string= pT "Resource"))) + (type (get-ns-attribute property "type"))) + (if (or parseType type) + (progn + (parse-property (getf node :elem) "") + (import-arc property tm-id start-revision + :document-id document-id + :xml-base (getf node :xml-base) + :xml-lang (getf node :xml-lang))) + (if (or nodeID resource) + (with-tm (start-revision document-id tm-id) + (make-topic-stub resource nil nodeID nil + start-revision xml-importer::tm + :document-id document-id)) + (if (and (= (length children) 1) + (not (stringp children))) + (import-node (elt children 0) tm-id + start-revision + :document-id document-id + :xml-base + (get-xml-base + (elt children 0) + :old-base (getf node :xml-base)) + :xml-lang + (get-xml-lang + (elt children 0) + :old-lang (getf node :xml-lang))) + (error "~aproperty must contain one resource!" + err-pref)))))))))) + (if (> (length (remove-duplicates tops)) 1) + (error "~aproperty must contain one resource node: ~a!" + err-pref (length (remove-duplicates tops))) + (first tops))))) (defun import-arc (elem tm-id start-revision @@ -464,11 +643,11 @@ (parse-properties-of-node elem UUID) (let ((subject-identifiers (make-isidorus-identifiers - elem start-revision :what "subjectIdentifier")) + (list elem) start-revision :what "subjectIdentifier")) (item-identities - (make-isidorus-identifiers elem start-revision)) + (make-isidorus-identifiers (list elem) start-revision)) (subject-locators - (make-isidorus-identifiers elem start-revision + (make-isidorus-identifiers (list elem) start-revision :what "subjectLocator"))) (let ((this (make-topic-stub @@ -608,21 +787,24 @@ (defun make-types (owner-top types tm start-revision &key (document-id *document-id*)) "Creates instance-of associations corresponding to the passed - topic owner-top and the passed types." + topic owner-top and the passed types but not isidorus:Topic." (declare (d:TopicC owner-top)) - (map 'list - #'(lambda(type) - (let ((type-topic - (make-topic-stub (getf type :psi) - nil - (getf type :topicid) - nil start-revision tm - :document-id document-id)) - (ID (getf type :ID))) - (make-instance-of-association owner-top type-topic - ID start-revision tm - :document-id document-id))) - types)) + (remove-if + #'null + (map 'list + #'(lambda(type) + (when (string/= (getf type :psi) *tm2rdf-topic-type-uri*) + (let ((type-topic + (make-topic-stub (getf type :psi) + nil + (getf type :topicid) + nil start-revision tm + :document-id document-id)) + (ID (getf type :ID))) + (make-instance-of-association owner-top type-topic + ID start-revision tm + :document-id document-id)))) + types))) (defun make-super-classes (owner-top super-classes tm start-revision @@ -1244,10 +1426,9 @@ :xml-lang xml-lang)))))))) -(defun make-isidorus-identifiers (owner-elem start-revision &key (what "itemIdentity")) +(defun make-isidorus-identifiers (owner-list start-revision &key (what "itemIdentity")) "Returns a list oc created identifier objects that can be used directly in make-topic-stub." - (declare (dom:element owner-elem)) (declare (string what)) (when (and (string/= what "itemIdentity") (string/= what "subjectIdentifier") @@ -1255,32 +1436,42 @@ (error "From make-identifiers(): what must be set to: ~a but is ~a" (list "itemIdentity" "subjectIdentifiers" "subjectLocator") what)) - (let ((content (child-nodes-or-text owner-elem :trim t)) - (class-symbol (cond - ((string= what "itemIdentity") - 'ItemIdentifierC) - ((string= what "subjectIdentifier") - 'PersistentIdC) - ((string= what "subjectLocator") - 'SubjectLocatorC)))) - (unless (stringp content) - (let ((identifiers - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property)) - (prop-content (child-nodes-or-text property :trim t))) - (and (string= prop-ns *tm2rdf-ns*) - (string= prop-name what) - (stringp prop-content) - (> (length prop-content) 0))) - collect (let ((uri (child-nodes-or-text property :trim t))) - (make-instance class-symbol - :uri uri - :start-revision start-revision)))) - (identifier-attr - (let ((attr (get-ns-attribute owner-elem what :ns-uri *tm2rdf-ns*))) - (when attr - (list (make-instance class-symbol - :uri attr - :start-revision start-revision)))))) - (remove-if #'null (append identifiers identifier-attr)))))) \ No newline at end of file + (let ((class-symbol + (cond + ((string= what "itemIdentity") + 'ItemIdentifierC) + ((string= what "subjectIdentifier") + 'PersistentIdC) + ((string= what "subjectLocator") + 'SubjectLocatorC)))) + (let ((uris + (loop for owner-elem in owner-list + append + (let ((content (child-nodes-or-text owner-elem :trim t))) + (unless (stringp content) + (let ((identifier-uris + (loop for property across content + when + (let ((prop-ns (dom:namespace-uri property)) + (prop-name (get-node-name property)) + (prop-content (child-nodes-or-text + property :trim t))) + (and (string= prop-ns *tm2rdf-ns*) + (string= prop-name what) + (stringp prop-content) + (> (length prop-content) 0))) + collect + (child-nodes-or-text property :trim t))) + (attr-uri + (let ((attr (get-ns-attribute owner-elem what + :ns-uri *tm2rdf-ns*))) + (when attr + (list attr))))) + (append identifier-uris attr-uri))))))) + (map 'list #'(lambda(x) + (make-instance class-symbol + :uri x + :start-revision start-revision)) + (remove-duplicates + (remove-if #'null uris) + :test #'string=))))) \ No newline at end of file Modified: trunk/src/xml/rdf/isidorus_constructs_tools.lisp ============================================================================== --- trunk/src/xml/rdf/isidorus_constructs_tools.lisp (original) +++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Thu Sep 3 10:57:42 2009 @@ -226,12 +226,14 @@ (string= x-uri *tm2rdf-associationtype-property*) (string= x-uri *tm2rdf-occurrencetype-property*) (string= x-uri *tm2rdf-roletype-property*) - (string= x-uri *tm2rdf-subjectLocator-property*)))) + (string= x-uri *tm2rdf-subjectLocator-property*) + (string= x-uri *tm2rdf-player-property*)))) content)))) (defun get-all-isidorus-nodes-by-id (node-id current-node type-uri &key (parent-xml-base nil) + (parent-xml-lang nil) (collected-nodes nil)) "Returns a list of all nodes that own the given nodeID and are of type type-uri, rdf:Description or when the rdf:parseType is set to @@ -246,6 +248,7 @@ t))) (content (child-nodes-or-text current-node :trim t)) (xml-base (get-xml-base current-node :old-base parent-xml-base)) + (xml-lang (get-xml-lang current-node :old-lang parent-xml-lang)) (nodeID (get-ns-attribute current-node "nodeID")) (node-uri-p (let ((node-uri (concatenate-uri (dom:namespace-uri current-node) @@ -269,7 +272,8 @@ (if (or datatype parseType (stringp content) (not content)) (if (and (string= nodeID node-id) node-uri-p) (append (list (list :elem current-node - :xml-base xml-base)) + :xml-base parent-xml-base + :xml-lang parent-xml-lang)) collected-nodes) collected-nodes) (if (and (string= nodeID node-id) node-uri-p) @@ -277,15 +281,19 @@ append (get-all-isidorus-nodes-by-id node-id item type-uri :collected-nodes (append - (list (list :elem current-node - :xml-base xml-base)) + (list (list + :elem current-node + :xml-base parent-xml-base + :xml-lang parent-xml-lang)) collected-nodes) - :parent-xml-base xml-base)) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)) (loop for item across content append (get-all-isidorus-nodes-by-id node-id item type-uri :collected-nodes collected-nodes - :parent-xml-base xml-base))))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang))))) :test #'(lambda(x y) (eql (getf x :elem) (getf y :elem)))))) Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Thu Sep 3 10:57:42 2009 @@ -53,7 +53,8 @@ *tm2rdf-varianttype-property* *tm2rdf-occurrencetype-property* *tm2rdf-roletype-property* - *tm2rdf-associationtype-property*) + *tm2rdf-associationtype-property* + *tm2rdf-player-property*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) From lgiessmann at common-lisp.net Sat Sep 5 15:53:28 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sat, 05 Sep 2009 11:53:28 -0400 Subject: [isidorus-cvs] r132 - in trunk/src: . model unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Sat Sep 5 11:53:27 2009 New Revision: 132 Log: rdf-importer: rollback to revision 127 of the rdf-importer, added a new file for mapping already imported topics to occurrences, names, associaitons, etc.; fixed also some problems in the importer; currently a bug seems to exist in the rdf-importer, therefor versioning is not working corretcly Added: trunk/src/xml/rdf/map_to_tm.lisp Removed: trunk/src/xml/rdf/isidorus_constructs_tools.lisp Modified: trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/unit_tests/poems.xtm trunk/src/unit_tests/rdf_exporter_test.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Sat Sep 5 11:53:27 2009 @@ -125,25 +125,25 @@ (defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/") -(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "Topic")) +(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic")) -(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "Name")) +(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "types/Name")) (defparameter *tm2rdf-name-property* (concatenate 'string *tm2rdf-ns* "name")) -(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "Variant")) +(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "types/Variant")) (defparameter *tm2rdf-variant-property* (concatenate 'string *tm2rdf-ns* "variant")) -(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "Occurrence")) +(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "types/Occurrence")) (defparameter *tm2rdf-occurrence-property* (concatenate 'string *tm2rdf-ns* "occurrence")) -(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "Role")) +(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "types/Role")) (defparameter *tm2rdf-role-property* (concatenate 'string *tm2rdf-ns* "role")) -(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "Association")) +(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "types/Association")) (defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association")) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sat Sep 5 11:53:27 2009 @@ -53,10 +53,10 @@ "exporter_xtm2.0")))) (:module "rdf" :components ((:file "rdf_tools") - (:file "isidorus_constructs_tools" + (:file "map_to_tm" :depends-on ("rdf_tools")) (:file "importer" - :depends-on ("rdf_tools" "isidorus_constructs_tools")) + :depends-on ("rdf_tools" "map_to_tm")) (:file "exporter")) :depends-on ("xtm"))) :depends-on ("constants" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sat Sep 5 11:53:27 2009 @@ -329,8 +329,8 @@ (lambda(version) (and (>= revision (start-revision version)) (or - (< revision (end-revision version)) - (= 0 (end-revision version))))) + (< revision (end-revision version)) + (= 0 (end-revision version))))) (versions constr)) constr)))) Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Sat Sep 5 11:53:27 2009 @@ -2605,7 +2605,7 @@ - + @@ -2618,7 +2618,7 @@ - + Modified: trunk/src/unit_tests/rdf_exporter_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_exporter_test.lisp (original) +++ trunk/src/unit_tests/rdf_exporter_test.lisp Sat Sep 5 11:53:27 2009 @@ -86,23 +86,30 @@ "Returns t if the owner-element has a node that corresponds to a role with the given parameters." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (length (dom:child-nodes item)) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (= (length (dom:child-nodes descr)) (+ 3 (length item-identifiers))) (string= node-ns *tm2rdf-ns*) (string= node-name "role") - (type-p item (concatenate 'string *tm2rdf-ns* "Role")) + (type-p descr (concatenate 'string *tm2rdf-ns* "types/Role")) (if player-uri - (property-p item *tm2rdf-ns* "player" + (property-p descr *tm2rdf-ns* "player" :resource player-uri) - (property-p item *tm2rdf-ns* "player" + (property-p descr *tm2rdf-ns* "player" :nodeID player-id)) - (property-p item *tm2rdf-ns* "roletype" + (property-p descr *tm2rdf-ns* "roletype" :resource roletype-uri) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))))) return t)) @@ -193,26 +200,35 @@ "Returns t if the owner contains a variant element with the passed characteristics." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (+ (length variant-scopes) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (rdf-importer::get-ns-attribute descr "nodeID") + (= (+ (length variant-scopes) (length item-identifiers) 2) (length (dom:child-nodes owner-elem))) (string= node-ns *tm2rdf-ns*) (string= node-name "variant") - (literal-p item *tm2rdf-ns* "value" variant-value + (literal-p descr *tm2rdf-ns* "value" variant-value :datatype datatype) (= (length variant-scopes) (length (loop for scope in variant-scopes - when (property-p item *tm2rdf-ns* "scope" + when (property-p descr *tm2rdf-ns* "scope" :resource scope) collect scope))) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))) - (type-p item (concatenate 'string *tm2rdf-ns* "Variant")))) + (type-p descr (concatenate 'string *tm2rdf-ns* + "types/Variant")))) return t)) @@ -220,35 +236,43 @@ &key (variants nil)) "Returns t if the parent node owns a name with the given characterics." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (length (dom:child-nodes item)) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (rdf-importer::get-ns-attribute descr "nodeID") + (= (length (dom:child-nodes descr)) (+ 3 (length name-scopes) (length item-identifiers) (length variants))) (string= node-ns *tm2rdf-ns*) (string= node-name "name") - (type-p item (concatenate 'string *tm2rdf-ns* - "Name")) - (property-p item *tm2rdf-ns* "nametype" :resource name-type) + (type-p descr (concatenate 'string *tm2rdf-ns* + "types/Name")) + (property-p descr *tm2rdf-ns* "nametype" :resource name-type) (= (length name-scopes) (length (loop for scope in name-scopes - when (property-p item *tm2rdf-ns* "scope" + when (property-p descr *tm2rdf-ns* "scope" :resource scope) collect scope))) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))) (= (length variants) (length (loop for variant in variants when (variant-p - item (getf variant :scopes) + descr (getf variant :scopes) (getf variant :item-identifiers) (getf variant :value) :datatype (getf variant :datatype)) collect variant))) - (literal-p item *tm2rdf-ns* "value" name-value))) + (literal-p descr *tm2rdf-ns* "value" name-value))) return t)) @@ -257,27 +281,34 @@ &key (datatype *xml-string*)) "Returns t if the parent node owns an occurrence with the given characterics." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (length (dom:child-nodes item)) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (= (length (dom:child-nodes descr)) (+ 3 (length occurrence-scopes) (length item-identifiers))) (string= node-ns *tm2rdf-ns*) (string= node-name "occurrence") - (type-p item (concatenate 'string *tm2rdf-ns* - "Occurrence")) - (property-p item *tm2rdf-ns* "occurrencetype" + (type-p descr (concatenate 'string *tm2rdf-ns* + "types/Occurrence")) + (property-p descr *tm2rdf-ns* "occurrencetype" :resource occurrence-type) (= (length occurrence-scopes) (length (loop for scope in occurrence-scopes - when (property-p item *tm2rdf-ns* "scope" + when (property-p descr *tm2rdf-ns* "scope" :resource scope) collect scope))) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))) - (literal-p item *tm2rdf-ns* "value" occurrence-value + (literal-p descr *tm2rdf-ns* "value" occurrence-value :datatype datatype))) return t)) @@ -308,7 +339,7 @@ (= (length (dom:child-nodes x)) 7)) goethes))) (is-true me) - (is (type-p me "http://isidorus/tm2rdf_mapping/Topic")) + (is (type-p me "http://isidorus/tm2rdf_mapping/types/Topic")) (is (type-p me "http://some.where/types/Author")) (is (literal-p me *sw-arc* "lastName" "von Goethe")) @@ -352,7 +383,7 @@ erlkoenigs))) (is-true me) (is-true (type-p me "http://some.where/types/Ballad")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Topic"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) (is-true (literal-p me *sw-arc* "content" "Wer reitet so sp?t durch Nacht und Wind? ..." :xml-lang "de")) @@ -410,7 +441,7 @@ zauberlehrlings))) (is-true me) (is-true (type-p me "http://some.where/types/Poem")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Topic"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) (is-true (identifier-p me "http://some.where/poem/Zauberlehrling" :what "subjectIdentifier")) (is-true (identifier-p @@ -694,7 +725,7 @@ (is (= (length (get-resources-by-id schiller-id)) 1)) (let ((me (elt (get-resources-by-id schiller-id) 0))) (is-true (type-p me "http://some.where/types/Author")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Topic"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) (is-true (literal-p me *sw-arc* "authorInfo" "http://de.wikipedia.org/wiki/Schiller" :datatype *xml-uri*)) @@ -828,7 +859,7 @@ (is (= (length assocs))) (let ((me (elt assocs 0))) (is (= (length (dom:child-nodes me)) 7)) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Association"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Association"))) (is-true (identifier-p me "http://some.where/test-association")) (is-true (property-p me *tm2rdf-ns* "associationtype" :resource (concatenate Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Sat Sep 5 11:53:27 2009 @@ -21,7 +21,6 @@ *tm2rdf-ns* *xml-ns* *xml-string* - *xml-uri* *instance-psi* *type-psi* *type-instance-psi* @@ -67,14 +66,7 @@ :test-poems-rdf-topics :test-empty-collection :test-collection - :test-xml-base - :test-get-type-psis - :test-get-all-type-psis - :test-isidorus-type-p - :test-get-all-isidorus-nodes-by-id - :test-import-isidorus-name - :test-import-isidorus-occurrence - :test-import-isidorus-association)) + :test-xml-base)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -3068,650 +3060,6 @@ "/test") "http://base-3/test"))))))) - -(test test-get-type-psis - "Tests the function get-type-psis." - (let ((tm-id "http://test-tm/") - (doc-1 - (concatenate 'string "" - " " - " " - " " - " " - " " - " " - - " " - ""))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) - (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) - (is (= (length (rdf-importer::child-nodes-or-text rdf-node)) 2)) - (let ((resource-1 - (elt (rdf-importer::child-nodes-or-text rdf-node) 0)) - (resource-2 - (elt (rdf-importer::child-nodes-or-text rdf-node) 1)) - (types (list "http://test/arcs/Node" "http://sw/Node-1" - "http://xml-base/Node-2" "http://sw/Node-3")) - (types-2 (list "http://test/arcs/Node" "http://sw/Node-1" - (concatenate 'string tm-id "Node-2") - "http://sw/Node-3"))) - (is-true resource-1) - (is-true resource-2) - (is (= (length - (intersection - types - (rdf-importer::get-type-psis - resource-1 tm-id - :parent-xml-base "http://xml-base/") - :test #'string=)) - (length types))) - (is (= (length - (intersection - types-2 - (rdf-importer::get-type-psis resource-1 tm-id) - :test #'string=)) - (length types-2))) - (is-false (rdf-importer::get-type-psis - resource-2 tm-id - :parent-xml-base "http://xml-base/"))))))) - - -(test test-get-all-type-psis - "Tests the functions get-all-type-psis, get-type-psis-across-dom and - get-type-psis." - (let ((tm-id "http://test-tm/") - (doc-1 - (concatenate 'string "" - " " - " " - " " - " " - " " - " " - - " " - " " - " " - - " " - - " " - " " - " " - - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - ""))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 5)) - (let ((any-node-1 (elt (rdf-importer::child-nodes-or-text root) 0)) - (another-node (elt (rdf-importer::child-nodes-or-text root) 1)) - (fn-types (list "http://type-1" "http://type-2" - "http://test/arcs/NodeType" "http://type-5" - "http://type-6")) - (any-node-4 (elt (rdf-importer::child-nodes-or-text root) 3))) - (let ((types-1 (rdf-importer::get-all-type-psis any-node-1 tm-id)) - (types-4 (rdf-importer::get-all-type-psis any-node-4 tm-id)) - (types-another-node (rdf-importer::get-all-type-psis - another-node tm-id))) - (is (= (length (intersection fn-types types-1 :test #'string=)) - (length fn-types))) - (is (= (length types-another-node) 1)) - (is (string= "http://type-3" - (first types-another-node))) - (is (= (length (intersection fn-types types-4 :test #'string=)) - (length fn-types)))))))) - - -(test test-isidorus-type-p - "Tests the function isidorus-type-p." - (let ((tm-id "http://test-tm/") - (doc-1 - (concatenate 'string "" - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - - " " - " " - " " - " " - " " - " " - - " " - - " " - " " - " " - " " - " " - " " - ""))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 4)) - (let ((topic-node (elt (rdf-importer::child-nodes-or-text root) 0)) - (association-node (elt (rdf-importer::child-nodes-or-text root) 3))) - (let ((topic-name (elt (rdf-importer::child-nodes-or-text topic-node) - 0)) - (topic-occurrence-1 (elt (rdf-importer::child-nodes-or-text - topic-node) - 1)) - (topic-occurrence-2 (elt (rdf-importer::child-nodes-or-text - topic-node) - 2)) - (association-role (elt (rdf-importer::child-nodes-or-text - association-node) - 1)) - (name-variant (elt (rdf-importer::child-nodes-or-text - (elt (rdf-importer::child-nodes-or-text root) - 1)) - 1))) - (is-true (rdf-importer::isidorus-type-p topic-node tm-id - 'rdf-importer::topic)) - (is-true (rdf-importer::isidorus-type-p association-node tm-id - 'rdf-importer::association)) - (is-true (rdf-importer::isidorus-type-p topic-name tm-id - 'rdf-importer::name)) - (is-true (rdf-importer::isidorus-type-p name-variant tm-id - 'rdf-importer::variant)) - (is-true (rdf-importer::isidorus-type-p topic-occurrence-1 tm-id - 'rdf-importer::occurrence)) - (is-true (rdf-importer::isidorus-type-p topic-occurrence-2 tm-id - 'rdf-importer::occurrence)) - (is-true (rdf-importer::isidorus-type-p association-role tm-id - 'rdf-importer::role)) - (is-false (rdf-importer::isidorus-type-p - (elt (rdf-importer::child-nodes-or-text root) 1) tm-id - 'rdf-importer::name)) - (is-false (rdf-importer::isidorus-type-p - (elt (rdf-importer::child-nodes-or-text root) 2) tm-id - 'rdf-importer::occurrence))))))) - - -(test test-get-all-isidorus-nodes-by-id - "Tests the function get-all-isidorus-nodes-by-id." - (let ((doc-1 - (concatenate 'string "" - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - ""))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0)) - (description (concatenate 'string *rdf-ns* "Description")) - (sw-node "http://test/arcs/Node")) - (let ((node-id-1 (list - (list :elem (elt (rdf-importer::child-nodes-or-text - root) 0) - :xml-base nil) - (list :elem (elt (rdf-importer::child-nodes-or-text - root) 2) - :xml-base nil) - (list :elem (elt - (rdf-importer::child-nodes-or-text - (elt - (rdf-importer::child-nodes-or-text - (elt (rdf-importer::child-nodes-or-text - root) 4)) 0)) 0) - :xml-base "http://base/" - :xml-lang "de"))) - (node-id-2 (elt (rdf-importer::child-nodes-or-text root) 1)) - (node-id-3 (elt (rdf-importer::child-nodes-or-text root) 3)) - (node-id-4 (elt (rdf-importer::child-nodes-or-text root) 4))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 5)) - (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-3" root nil)) 1)) - (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-3" root nil)) :elem) - node-id-3)) - (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-2" root nil)) 1)) - (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-2" root description)) :elem) - node-id-2)) - (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :elem) - node-id-4)) - (is-false (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :xml-base)) - (is-false (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :xml-lang)) - (is (= (length (intersection - node-id-1 - (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-1" root description) - :test #'(lambda(x y) - (and (eql (getf x :elem) (getf y :elem)) - (string= (getf x :xml-base) - (getf y :xml-base)))))) - (length node-id-1))))))) - - -(test test-import-isidorus-name - "Tests all functions that are responsible to import a resource - representing isidorus:Name." - (let ((revision-1 100) - (tm-id "http://test/tm-id") - (document-id "doc-id") - (db-dir "./data_base") - (doc-1 - (concatenate 'string "" - " " - " http://topic-psi-1" - " http://topic-sl-1" - " http://topic-ii-1" - " " - " " - " " - " http://itemIdentity-1" - " http://itemIdentity-2" - " " - " " - " value-1" - " " - " " - " " - " " - " " - " " - " http://itemIdentity-4" - " value-3" - " " - " " - " " - " " - " " - " value-4" - " " - " " - " " - " " - " " - " " - - " " - " " - " value-2" - " " - - " " - " http://itemIdentity-3" - " " - " " - " " - ""))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 3)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (rdf-importer::import-dom root revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:NameC)) 2)) - (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 27)) - (is-false (find-if #'(lambda(x) - (not (d:psis x))) - (elephant:get-instances-by-class 'd:TopicC))) - (is-true (d:get-item-by-psi "http://node-1")) - (is-true (d:get-item-by-psi "http://topic-psi-1")) - (is-true (d:get-item-by-psi "http://resource-1")) - (is-true (d:get-item-by-psi "http://scope-1")) - (is-true (d:get-item-by-psi "http://scope-2")) - (is-true (d:get-item-by-psi "http://scope-3")) - (is-true (d:get-item-by-psi "http://scope-4")) - (is-true (d:get-item-by-psi "http://nametype-1")) - (is-true (d:get-item-by-psi "http://nametype-1")) - (is-true (d:get-item-by-psi "http://test/arcs/arc")) - (let ((top (d:get-item-by-psi "http://node-1")) - (nt-1 (d:get-item-by-psi "http://nametype-1")) - (nt-2 (d:get-item-by-psi "http://nametype-2")) - (scope-1 (d:get-item-by-psi "http://scope-1")) - (scope-2 (d:get-item-by-psi "http://scope-2")) - (scope-3 (d:get-item-by-psi "http://scope-3")) - (scope-4 (d:get-item-by-psi "http://scope-4"))) - (is (= (length (d:psis top)) 2)) - (is-true (find (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri - "http://topic-psi-1") - (d:psis top))) - (is (= (length (d:item-identifiers top)) 1)) - (is (string= (d:uri (first (d:item-identifiers top))) - "http://topic-ii-1")) - (is (= (length (d:locators top)) 1)) - (is (string= (d:uri (first (d:locators top))) - "http://topic-sl-1")) - (is (= (length (d:names top)) 2)) - (let ((name-1 (find-if #'(lambda(x) - (eql (d:instance-of x) nt-1)) - (d:names top))) - (name-2 (find-if #'(lambda(x) - (eql (d:instance-of x) nt-2)) - (d:names top)))) - (is-true name-1) - (is-true name-2) - (is (= (length (d:item-identifiers name-1)) 2)) - (is (= (length - (intersection - (d:item-identifiers name-1) - (list (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-1") - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-2")))) - 2)) - (is (= (length (d:item-identifiers name-2)) 1)) - (is (string= (d:uri (first (d:item-identifiers name-2))) - "http://itemIdentity-4")) - (is (= (length (d:themes name-1)) 2)) - (is (= (length (intersection (list scope-1 scope-2) - (d:themes name-1))) - 2)) - (is-false (d:themes name-2)) - (is (string= (d:charvalue name-1) "value-1")) - (is (string= (d:charvalue name-2) "value-3")) - (is (= (length (d:variants name-1)) 1)) - (is (= (length (d:variants name-2)) 1)) - (let ((variant-1 (first (d:variants name-1))) - (variant-2 (first (d:variants name-2)))) - (is (= (length (d:item-identifiers variant-1)) 1)) - (is (string= (d:uri (first (d:item-identifiers variant-1))) - "http://itemIdentity-3")) - (is-false (d:item-identifiers variant-2)) - (is (= (length (d:themes variant-1)) 4)) - (is (= (length (intersection (list scope-3 scope-4 - scope-1 scope-2) - (d:themes variant-1))) - 4)) - (is (= (length (d:themes variant-2)) 1)) - (is (eql scope-3 (first (d:themes variant-2)))) - (is (string= (d:charvalue variant-1) - "value-2")) - (is (string= (d:charvalue variant-2) - "value-4")) - (is (string= (d:datatype variant-1) - (concatenate 'string tm-id "/dt-2"))) - (is (string= (d:datatype variant-2) - *xml-string*)))))))) - - -(test test-import-isidorus-occurrence - "Tests all functions that are responsible to import a resource - representing isidorus:Occurrence." - (let ((revision-1 100) - (tm-id "http://test/tm-id") - (document-id "doc-id") - (db-dir "./data_base") - (doc-1 - (concatenate 'string "" - " " - " " - " " - " " - " value-1" - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - " " - - " " - " " - " value-2" - " " - " http://itemIdentity-1" - " http://itemIdentity-2" - " anyText" - " " - ""))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 2)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (rdf-importer::import-dom root revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 3)) - (is (= (length (elephant:get-instances-by-class 'd:NameC))) 0) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 26)) - (let ((node-1 (d:get-item-by-psi "http://node-1")) - (occurrence-1 (d:get-item-by-psi "http://occurrence-1")) - (occurrence-2 (d:get-item-by-psi "http://occurrence-2")) - (occurrence-3 (d:get-item-by-psi "http://occurrence-3")) - (scope-1 (d:get-item-by-psi "http://scope-1")) - (scope-2 (d:get-item-by-psi "http://scope-2"))) - (is-true node-1) - (is-true occurrence-1) - (is-true occurrence-2) - (is-true occurrence-3) - (is-true scope-1) - (is-true scope-2) - (let ((occ-1 (find-if #'(lambda(x) - (eql (d:instance-of x) occurrence-1)) - (d:occurrences node-1))) - (occ-2 (find-if #'(lambda(x) - (eql (d:instance-of x) occurrence-2)) - (d:occurrences node-1))) - (occ-3 (find-if #'(lambda(x) - (eql (d:instance-of x) occurrence-3)) - (d:occurrences node-1)))) - (is-true occ-1) - (is-true occ-2) - (is-true occ-3) - (is-false (d:item-identifiers occ-1)) - (is-false (d:themes occ-1)) - (is (string= (d:charvalue occ-1) "value-1")) - (is (string= (d:datatype occ-1) (concatenate 'string tm-id "/dt-1"))) - (is (= (length (intersection - (d:item-identifiers occ-2) - (list (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri - "http://itemIdentity-1") - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri - "http://itemIdentity-2")))) - 2)) - (is (= (length (intersection (list scope-1 scope-2) - (d:themes occ-2))) - 2)) - (is (string= (d:charvalue occ-2) "value-2")) - (is (string= (d:datatype occ-2) *xml-string*)) - (is-false (d:item-identifiers occ-3)) - (is-false (d:themes occ-3)) - (is (string= (d:charvalue occ-3) "")) - (is (string= (d:datatype occ-3) *xml-string*))))))) - - -(test test-import-isidorus-association - "Tests all functions that are responsible to import a resource - representing isidorus:Association." - (let ((revision-1 100) - (tm-id "http://test/tm-id") - (document-id "doc-id") - (db-dir "./data_base") - (doc-1 - (concatenate 'string "" - " " - " " - " " - " " - " " - " " - " http://sl-1" - " http://sl-2" - " " - " " - " " - " value-1" - " " - " value-of-arc" - " " - " " - " " - " " - " http://itemIdentity-a1" - " http://itemIdentity-a2" - " " - " " - - " " - " " - " " - " http://itemIdentity-3" - " " - " " - - " " - " http://itemIdentity-a1" - " " - " " - " " - " " - " " - " " - " " - " " - " http://itemIdentity-3" - " " - " " - " " - ""))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 3)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (rdf-importer::import-dom root revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28)) - (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 1)) - (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) - (setf d::*current-xtm* document-id) - (let ((assoc (first (elephant:get-instances-by-class 'd:AssociationC))) - (assoc-type (d:get-item-by-psi "http://associationtype-1")) - (scope-1 (d:get-item-by-psi "http://scope-1")) - (player-1 (d:get-item-by-psi "http://player-1")) - (player-2 (d:get-item-by-id "player-2")) - (roletype-1 (d:get-item-by-id "roletype-1")) - (roletype-2 (d:get-item-by-psi "http://roletype-2")) - (nametype-1 (d:get-item-by-psi "http://nametype-1")) - (scope-2 (d:get-item-by-psi "http://scope-2"))) - (let ((role-1 (first (d:used-as-type roletype-1))) - (role-2 (first (d:used-as-type roletype-2)))) - (is-true scope-1) - (is (= (length (intersection - (list - (elephant:get-instance-by-value 'd:SubjectLocatorC - 'd:uri "http://sl-1") - (elephant:get-instance-by-value 'd:SubjectLocatorC - 'd:uri "http://sl-2")) - (d:locators scope-1))) - 2)) - (is (= (length (d:names scope-1)) 1)) - (is (eql (d:instance-of (first (d:names scope-1))) nametype-1)) - (is (string= (d:charvalue (first (d:names scope-1))) "value-1")) - (is (= (length (d:themes (first (d:names scope-1)))) 1)) - (is-false (d:psis (first (d:themes (first (d:names scope-1)))))) - (is-true player-1) - (is-true player-2) - (is-true roletype-1) - (is (string= (d:uri (first (d::topic-identifiers roletype-1))) - "roletype-1")) - (is-true roletype-2) - (is-true assoc-type) - (is-true scope-2) - (is-true role-1) - (is (= (length (intersection - (list - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-3")) - (d:item-identifiers role-1))) - 1)) - (is (eql player-1 (d:player role-1))) - (is-true role-2) - (is-false (d:item-identifiers role-2)) - (is (eql player-2 (d:player role-2))) - (is (= (length (intersection (d:roles assoc) - (list role-1 role-2))) - 2)) - (is (= (length (intersection - (d:themes assoc) - (list scope-1 scope-2))) - 2)) - (is (= (length - (intersection - (d:item-identifiers assoc) - (list - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-a1") - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-a2")))) - 2))))))) - - (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3734,11 +3082,4 @@ (it.bese.fiveam:run! 'test-poems-rdf-topics) (it.bese.fiveam:run! 'test-empty-collection) (it.bese.fiveam:run! 'test-collection) - (it.bese.fiveam:run! 'test-xml-base) - (it.bese.fiveam:run! 'test-get-type-psis) - (it.bese.fiveam:run! 'test-get-all-type-psis) - (it.bese.fiveam:run! 'test-isidorus-type-p) - (it.bese.fiveam:run! 'test-get-all-isidorus-nodes-by-id) - (it.bese.fiveam:run! 'test-import-isidorus-name) - (it.bese.fiveam:run! 'test-import-isidorus-occurrence) - (it.bese.fiveam:run! 'test-import-isidorus-association)) \ No newline at end of file + (it.bese.fiveam:run! 'test-xml-base)) \ No newline at end of file Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Sat Sep 5 11:53:27 2009 @@ -20,7 +20,13 @@ *rdf2tm-scope-prefix* *tm2rdf-ns* *type-instance-psi* - *supertype-subtype-psi*) + *supertype-subtype-psi* + *tm2rdf-name-type-uri* + *tm2rdf-variant-type-uri* + *tm2rdf-occurrence-type-uri* + *tm2rdf-topic-type-uri* + *tm2rdf-association-type-uri* + *tm2rdf-role-type-uri*) (:import-from :isidorus-threading with-reader-lock with-writer-lock) @@ -123,11 +129,11 @@ (setf *ns-map* nil)) -(defun make-isi-type (type) +(defun make-isi-type (type-uri) "Creates a rdf:type property with the URL-prefix of *tm2rdf-ns*." - (declare (string type)) + (declare (string type-uri)) (cxml:with-element "rdf:type" - (cxml:attribute "rdf:resource" (concatenate 'string *tm2rdf-ns* type)))) + (cxml:attribute "rdf:resource" type-uri))) (defun get-ns-prefix (ns-uri) @@ -273,27 +279,31 @@ "Creates a blank node that represents a VariantC element with the properties itemIdentity, scope and value." (cxml:with-element "isi:variant" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Variant") - (map 'list #'to-rdf-elem (item-identifiers construct)) - (scopes-to-rdf-elems construct) - (resourceX-to-rdf-elem construct))) + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + ;(cxml:attribute "rdf:parseType" "Resource") + (make-isi-type *tm2rdf-variant-type-uri*) + (map 'list #'to-rdf-elem (item-identifiers construct)) + (scopes-to-rdf-elems construct) + (resourceX-to-rdf-elem construct)))) (defmethod to-rdf-elem ((construct NameC)) "Creates a blank node that represents a name element with the properties itemIdentity, nametype, value, variant and scope." (cxml:with-element "isi:name" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Name") - (map 'list #'to-rdf-elem (item-identifiers construct)) - (cxml:with-element "isi:nametype" - (make-topic-reference (instance-of construct))) - (scopes-to-rdf-elems construct) - (cxml:with-element "isi:value" - (cxml:attribute "rdf:datatype" *xml-string*) - (cxml:text (charvalue construct))) - (map 'list #'to-rdf-elem (variants construct)))) + ;(cxml:attribute "rdf:parseType" "Resource") + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + (make-isi-type *tm2rdf-name-type-uri*) + (map 'list #'to-rdf-elem (item-identifiers construct)) + (cxml:with-element "isi:nametype" + (make-topic-reference (instance-of construct))) + (scopes-to-rdf-elems construct) + (cxml:with-element "isi:value" + (cxml:attribute "rdf:datatype" *xml-string*) + (cxml:text (charvalue construct))) + (map 'list #'to-rdf-elem (variants construct))))) (defmethod to-rdf-elem ((construct OccurrenceC)) @@ -308,13 +318,15 @@ (item-identifiers construct) (/= (length (psis (instance-of construct))) 1)) (cxml:with-element "isi:occurrence" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Occurrence") - (map 'list #'to-rdf-elem (item-identifiers construct)) - (cxml:with-element "isi:occurrencetype" - (make-topic-reference (instance-of construct))) - (scopes-to-rdf-elems construct) - (resourceX-to-rdf-elem construct)) + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + ;(cxml:attribute "rdf:parseType" "Resource") + (make-isi-type *tm2rdf-occurrence-type-uri*) + (map 'list #'to-rdf-elem (item-identifiers construct)) + (cxml:with-element "isi:occurrencetype" + (make-topic-reference (instance-of construct))) + (scopes-to-rdf-elems construct) + (resourceX-to-rdf-elem construct))) (with-property construct (cxml:attribute "rdf:datatype" (datatype construct)) (when (themes construct) @@ -349,7 +361,7 @@ (when (or (> (length (psis construct)) 1) ii sl t-names (isi-occurrence-p construct)) - (make-isi-type "Topic")) + (make-isi-type *tm2rdf-topic-type-uri*)) (map 'list #'to-rdf-elem (remove psi (psis construct))) (map 'list #'to-rdf-elem sl) (map 'list #'to-rdf-elem ii) @@ -413,7 +425,7 @@ (association-roles (roles association))) (cxml:with-element "rdf:Description" (cxml:attribute "rdf:nodeID" (make-object-id association)) - (make-isi-type "Association") + (make-isi-type *tm2rdf-association-type-uri*) (cxml:with-element "isi:associationtype" (make-topic-reference association-type)) (map 'list #'to-rdf-elem ii) @@ -428,13 +440,15 @@ (role-type (instance-of construct)) (player-top (player construct))) (cxml:with-element "isi:role" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Role") - (map 'list #'to-rdf-elem ii) - (cxml:with-element "isi:roletype" - (make-topic-reference role-type)) - (cxml:with-element "isi:player" - (make-topic-reference player-top))))) + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + ;(cxml:attribute "rdf:parseType" "Resource") + (make-isi-type *tm2rdf-role-type-uri*) + (map 'list #'to-rdf-elem ii) + (cxml:with-element "isi:roletype" + (make-topic-reference role-type)) + (cxml:with-element "isi:player" + (make-topic-reference player-top)))))) (defun rdf-mapped-association-to-rdf-elem (association) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Sat Sep 5 11:53:27 2009 @@ -7,10 +7,6 @@ ;;+----------------------------------------------------------------------------- (in-package :rdf-importer) - -(defvar *document-id* "isidorus-rdf-document") - - (defun setup-rdf-module (rdf-xml-path repository-path &key tm-id (document-id (get-uuid))) "Sets up the data base by importing core_psis.xtm and @@ -41,13 +37,16 @@ (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - (elephant:ensure-transaction (:txn-nosync t) - (let ((rdf-dom - (dom:document-element (cxml:parse-file - (truename rdf-xml-path) - (cxml-dom:make-dom-builder))))) - (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) - (setf *_n-map* nil)))) + (let ((rdf-dom + (dom:document-element (cxml:parse-file + (truename rdf-xml-path) + (cxml-dom:make-dom-builder))))) + (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) + (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" + (length (elephant:get-instances-by-class 'TopicC)) + (length (elephant:get-instances-by-class 'AssociationC))) + (elephant:close-store) + (setf *_n-map* nil))) (defun init-rdf-module (&optional (revision (get-revision))) @@ -84,539 +83,49 @@ (let ((children (child-nodes-or-text rdf-dom :trim t))) (when children (loop for child across children - when (non-isidorus-type-p child tm-id :parent-xml-base xml-base) do (import-node child tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang) - when (isidorus-type-p child tm-id 'association - :parent-xml-base xml-base) - do (make-isidorus-association child tm-id start-revision - :parent-xml-base xml-base - :document-id document-id)))) - (if (isidorus-type-p rdf-dom tm-id 'association - :parent-xml-base xml-base) - (make-isidorus-association rdf-dom tm-id start-revision - :parent-xml-base xml-base - :document-id document-id) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) + :xml-base xml-base :xml-lang xml-lang)))) + (import-node rdf-dom tm-id start-revision :document-id document-id + :xml-base xml-base :xml-lang xml-lang))) (setf *_n-map* nil)) (defun import-node (elem tm-id start-revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) - (format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove (tm-id-p tm-id "import-node") (parse-node elem) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) - (fn-xml-base (get-xml-base elem :old-base xml-base))) + (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))) (let ((about (get-absolute-attribute elem tm-id xml-base "about")) (nodeID (get-ns-attribute elem "nodeID")) (ID (get-absolute-attribute elem tm-id xml-base "ID")) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (parse-properties-of-node elem (or about nodeID ID UUID)) - (let ((literals (append (get-literals-of-node elem fn-xml-lang) - (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations (get-associations-of-node-content elem tm-id xml-base)) - (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) - (super-classes - (get-super-classes-of-node-content elem tm-id xml-base)) - (subject-identities (make-isidorus-identifiers - (list elem) - start-revision :what "subjectIdentifier")) - (item-identifiers (make-isidorus-identifiers (list elem) - start-revision)) - (subject-locators (make-isidorus-identifiers - (list elem) start-revision :what "subjectLocator"))) - (with-tm (start-revision document-id tm-id) - (let ((this - (make-topic-stub - about ID nodeID UUID start-revision xml-importer::tm - :document-id document-id - :additional-subject-identifiers subject-identities - :item-identifiers item-identifiers - :subject-locators subject-locators))) - (make-isidorus-names elem this tm-id start-revision - :owner-xml-base fn-xml-base - :document-id document-id) - (make-isidorus-occurrences elem this tm-id start-revision - :owner-xml-base fn-xml-base - :document-id document-id) - (make-literals this literals tm-id start-revision - :document-id document-id) - (make-associations this associations xml-importer::tm - start-revision :document-id document-id) - (make-types this types xml-importer::tm start-revision - :document-id document-id) - (make-super-classes this super-classes xml-importer::tm - start-revision :document-id document-id) - (make-recursion-from-node elem tm-id start-revision - :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) - this)))))) - - -(defun make-isidorus-association (elem tm-id start-revision - &key (parent-xml-base nil) - (document-id *document-id*)) - "Creates an association element of the passed DOM node." - (declare (dom:element elem)) - (declare (string tm-id)) - (let ((nodeID (get-ns-attribute elem "nodeID")) - (err-pref "From make-isidorus-association(): ") - (root (elt (dom:child-nodes (dom:owner-document elem)) 0))) - (let ((nodes (if nodeID - (get-all-isidorus-nodes-by-id - nodeId root *tm2rdf-association-type-uri*) - (list (list :elem elem - :xml-base parent-xml-base))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (association-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-associationtype-property* - :document-id document-id)) - (association-scopes (make-scopes nodes tm-id start-revision - :document-id document-id)) - (association-roles (make-isidorus-roles - nodes tm-id start-revision - :document-id document-id))) - (unless association-type - (error "~aassociation type is missing!" err-pref)) - (unless association-roles - (error "~aassociation roles are missing!" err-pref)) - (with-tm (start-revision document-id tm-id) - (add-to-topicmap - xml-importer::tm - (make-construct 'AssociationC - :start-revision start-revision - :item-identifiers item-identities - :instance-of association-type - :themes association-scopes - :roles association-roles))))))) - - -(defun make-isidorus-roles (association-nodes tm-id start-revision - &key (document-id *document-id*)) - "Returns a list of property list of the form - (:instance-of :player :item-identifiers <(ItemIdentifierC)>)." - (declare (string tm-id)) - (let ((err-pref "From make-isidorus-roles(): ") - (all-role-nodes (get-all-role-nodes association-nodes)) - (root (elt (dom:child-nodes (dom:owner-document - (getf (first association-nodes) - :elem))) 0))) - (when (and (not (stringp all-role-nodes)) - (> (length all-role-nodes) 0)) - (loop for property in all-role-nodes - collect - (let ((nodeID (nodeId-of-property-or-child (getf property :elem)))) - (let ((nodes (if nodeID - (get-all-isidorus-nodes-by-id - nodeId root *tm2rdf-role-type-uri*) - (list (list :elem (getf property :elem) - :xml-base (getf property :xml-base) - :xml-lang - (getf property :xml-lang)))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (role-player (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-player-property* - :document-id document-id)) - (role-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-roletype-property* - :document-id document-id))) - (unless role-type - (error "~arole type is missing!" err-pref)) - (unless role-player - (error "~arole player is missing!" err-pref)) - (list :instance-of role-type - :player role-player - :item-identifiers item-identities)))))))) - - -(defun get-all-role-nodes (association-nodes) - "Returns all role nodes of the passed association nodes as a - property list of the form (:elem :xml-base - :xml-lang ." - (let ((nodes - (loop for association in association-nodes - append - (let ((content (child-nodes-or-text (getf association :elem) - :trim t)) - (xml-base (getf association :xml-base)) - (xml-lang (getf association :xml-lang))) - (unless (stringp content) - (loop for property across content - when (let ((node-ns (dom:namespace-uri property)) - (node-name (get-node-name property))) - (string= (concatenate-uri node-ns node-name) - *tm2rdf-role-property*)) - collect (list :elem property - :xml-base (get-xml-base - (getf association :elem) - :old-base xml-base) - :xml-lang - (get-xml-lang (getf association :elem) - :old-lang xml-lang)))))))) - (remove-duplicates - (remove-if #'null nodes) - :test #'(lambda(x y) - (string= (nodeId-of-property-or-child (getf x :elem)) - (nodeID-of-property-or-child (getf y :elem))))))) - - - -(defun make-isidorus-occurrences (owner-elem owner-topic tm-id start-revision - &key (owner-xml-base nil) - (document-id *document-id*)) - "Creates all occurrences of resource nodes that are in a - property isidorus:occurrence and have the type isidorus:Occurrence." - (declare (dom:element owner-elem)) - (declare (string tm-id)) - (declare (TopicC owner-topic)) - (let ((content (child-nodes-or-text owner-elem :trim t)) - (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) - (err-pref "From make-isidorus-occurrence(): ")) - (when (and (not (stringp content)) - (> (length content) 0)) - (loop for property across content - when (isidorus-type-p property tm-id 'occurrence - :parent-xml-base owner-xml-base) - collect - (let ((xml-base (get-xml-base property - :old-base owner-xml-base))) - (let ((nodes - (let ((nodeID (nodeID-of-property-or-child property))) - (if nodeID - (get-all-isidorus-nodes-by-id - nodeID root *tm2rdf-occurrence-type-uri*) - (list (self-or-child-node - property *tm2rdf-occurrence-type-uri* - :xml-base xml-base)))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (occurrence-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-occurrencetype-property* - :document-id document-id)) - (value-and-datatype (make-value nodes tm-id)) - (occurrence-scopes (make-scopes nodes tm-id start-revision - :document-id document-id))) - (unless occurrence-type - (error "~aoccurrencetype is missing!" - err-pref)) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic owner-topic - :themes occurrence-scopes - :item-identifiers item-identities - :instance-of occurrence-type - :charvalue (getf value-and-datatype :value) - :datatype (getf value-and-datatype - :datatype))))))))) - - -(defun make-isidorus-names (owner-elem owner-topic tm-id start-revision - &key (owner-xml-base nil) - (document-id *document-id*)) - "Creates all names of resource nodes that are in a property isidorus:name - and have the type isidorus:Name." - (declare (dom:element owner-elem)) - (declare (string tm-id)) - (declare (TopicC owner-topic)) - (let ((content (child-nodes-or-text owner-elem :trim t)) - (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) - (err-pref "From make-isidorus-name(): ")) - (when (and (not (stringp content)) - (> (length content) 0)) - (loop for property across content - when (isidorus-type-p property tm-id 'name - :parent-xml-base owner-xml-base) - collect - (let ((xml-base (get-xml-base property - :old-base owner-xml-base))) - (let ((nodes - (let ((nodeID (nodeID-of-property-or-child property))) - (if nodeID - (get-all-isidorus-nodes-by-id - nodeID root *tm2rdf-name-type-uri*) - (list (self-or-child-node - property *tm2rdf-name-type-uri* - :xml-base xml-base)))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (name-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-nametype-property* - :document-id document-id)) - (name-value (getf (make-value nodes tm-id) :value)) - (name-scopes (make-scopes nodes tm-id start-revision - :document-id document-id))) - (unless name-type - (error "~anametype is missing!" - err-pref)) - (let ((this - (make-construct 'NameC - :start-revision start-revision - :topic owner-topic - :charvalue name-value - :instance-of name-type - :item-identifiers item-identities - :themes name-scopes))) - (make-isidorus-variants nodes this tm-id start-revision - :document-id document-id))))))))) - - -(defun make-isidorus-variants (name-nodes owner-name tm-id start-revision - &key (document-id *document-id*)) - "Creates name variants of the passed name-nodes." - (declare (NameC owner-name)) - (declare (string tm-id)) - (let ((root - (when name-nodes - (elt (dom:child-nodes - (dom:owner-document (getf (first name-nodes) :elem))) 0))) - (err-pref "From make-isidorus-variant(): ")) - (remove-if - #'null - (loop for name-node in name-nodes - collect (let ((content (child-nodes-or-text (getf name-node :elem)))) - (when (and (not (stringp content)) - (> (length content) 0)) - (loop for property across content - when (isidorus-type-p - property tm-id 'variant - :parent-xml-base (getf name-node :xml-base)) - collect - (let ((nodes - (let ((nodeID - (get-ns-attribute property "nodeID"))) - (if nodeID - (get-all-isidorus-nodes-by-id - nodeID root *tm2rdf-name-type-uri*) - (list (self-or-child-node - property - *tm2rdf-variant-type-uri* - :xml-base - (get-xml-base - property - :old-base - (getf name-node :xml-base)))))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (variant-scopes - (append - (make-scopes nodes tm-id start-revision - :document-id document-id) - (themes owner-name))) ;XTM 2.0: 4.12 - (value-and-type (make-value nodes tm-id))) - (unless variant-scopes - (error "~ascope is missing!" - err-pref)) - (make-construct 'VariantC - :start-revision start-revision - :item-identifiers item-identities - :themes variant-scopes - :charvalue - (getf value-and-type :value) - :datatype - (getf value-and-type :datatype) - :name owner-name)))))))))) - - -(defun make-scopes (node-list tm-id start-revision - &key (document-id *document-id*)) - "Creates for every found scope a corresponding topic stub." - (let ((scopes - (remove-if - #'null - (loop for node in node-list - append - (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-scope-property*)) - collect - (let ((nodeID (get-ns-attribute property "nodeID")) - (resource (get-absolute-attribute - property tm-id (getf node :xml-base) - "resource")) - (children (child-nodes-or-text property - :trim t)) - (parseType (let ((pT - (get-ns-attribute property - "parseType"))) - (string= pT "Resource"))) - (type (get-ns-attribute property "type"))) - (if (or parseType type) - (progn - (parse-property property "") - (import-arc property tm-id start-revision - :document-id document-id - :xml-base (getf node :xml-base) - :xml-lang (getf node :xml-lang))) - (if (or nodeID resource) - (with-tm (start-revision document-id tm-id) - (make-topic-stub resource nil nodeID nil - start-revision xml-importer::tm - :document-id document-id)) - (if (and (= (length children) 1) - (not (stringp children))) - (import-node (elt children 0) tm-id - start-revision - :document-id document-id - :xml-base - (get-xml-base - (elt children 0) - :old-base (getf node :xml-base)) - :xml-lang - (get-xml-lang - (elt children 0) - :old-lang (getf node :xml-lang))) - (error "From make-scopes(): scope-property must contain one resource!"))))))))))) - (remove-duplicates scopes))) - - -(defun make-value (node-list tm-id) - "Returns the literal value of a property of the type isidorus:value." - (let ((property - (loop for node in node-list - when (or (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-value-property*)) - return property)) - (get-ns-attribute (getf node :elem) - "value" :ns-uri *tm2rdf-ns*)) - return (or (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-value-property*)) - return property)) - (get-ns-attribute (getf node :elem) - "value" :ns-uri *tm2rdf-ns*))))) - (if property - (if (stringp property) - (list :value property :datatype *xml-string*) - (let ((prop-content (child-nodes-or-text property)) - (type (let ((dt - (get-datatype - property tm-id - (find-if #'(lambda(x) - (eql property (getf x :elem))) - node-list)))) - (if dt dt *xml-string*)))) - (cond - ((= (length prop-content) 0) - (list :value "" :datatype type)) - ((not (stringp prop-content)) ;must be an element - (let ((text-val "")) - (when (dom:child-nodes property) - (loop for content-node across - (dom:child-nodes property) - do (push-string - (node-to-string content-node) - text-val))) - (list :value text-val :datatype type))) - (t (list :value prop-content :datatype type))))) - (list :value "" :datatype *xml-string*)))) - - - -(defun import-topic-of-property (node-list tm-id start-revision uri-of-property - &key (document-id *document-id*)) - "Creates a topic stub that is the type of the name represented by the - passed nodes." - (let ((err-pref "From import-topic-of-property(): ")) - (let ((tops - (loop for node in node-list - when (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - uri-of-property)) - return property)) - append - (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - uri-of-property)) - collect - (let ((nodeID (get-ns-attribute property "nodeID")) - (resource (get-absolute-attribute - property tm-id (getf node :xml-base) - "resource")) - (children (child-nodes-or-text property - :trim t)) - (parseType (let ((pT - (get-ns-attribute property - "parseType"))) - (string= pT "Resource"))) - (type (get-ns-attribute property "type"))) - (if (or parseType type) - (progn - (parse-property (getf node :elem) "") - (import-arc property tm-id start-revision - :document-id document-id - :xml-base (getf node :xml-base) - :xml-lang (getf node :xml-lang))) - (if (or nodeID resource) - (with-tm (start-revision document-id tm-id) - (make-topic-stub resource nil nodeID nil - start-revision xml-importer::tm - :document-id document-id)) - (if (and (= (length children) 1) - (not (stringp children))) - (import-node (elt children 0) tm-id - start-revision - :document-id document-id - :xml-base - (get-xml-base - (elt children 0) - :old-base (getf node :xml-base)) - :xml-lang - (get-xml-lang - (elt children 0) - :old-lang (getf node :xml-lang))) - (error "~aproperty must contain one resource!" - err-pref)))))))))) - (if (> (length (remove-duplicates tops)) 1) - (error "~aproperty must contain one resource node: ~a!" - err-pref (length (remove-duplicates tops))) - (first tops))))) + + (let ((literals (append (get-literals-of-node elem fn-xml-lang) + (get-literals-of-node-content + elem tm-id xml-base fn-xml-lang))) + (associations (get-associations-of-node-content elem tm-id xml-base)) + (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) + (super-classes + (get-super-classes-of-node-content elem tm-id xml-base))) + (with-tm (start-revision document-id tm-id) + (let ((this + (make-topic-stub + about ID nodeID UUID start-revision xml-importer::tm + :document-id document-id))) + (make-literals this literals tm-id start-revision + :document-id document-id) + (make-associations this associations xml-importer::tm + start-revision :document-id document-id) + (make-types this types xml-importer::tm start-revision + :document-id document-id) + (make-super-classes this super-classes xml-importer::tm + start-revision :document-id document-id) + (make-recursion-from-node elem tm-id start-revision + :document-id document-id + :xml-base xml-base + :xml-lang xml-lang) + this)))))) (defun import-arc (elem tm-id start-revision @@ -625,8 +134,8 @@ "Imports a property that is an blank_node and continues the recursion on this element." (declare (dom:element elem)) - (format t ">> import-arc: ~a <<~%" (dom:node-name elem)) ;TODO: remove (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) + (fn-xml-base (get-xml-base elem :old-base xml-base)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (parseType (get-ns-attribute elem "parseType")) (content (child-nodes-or-text elem :trim t))) @@ -641,53 +150,39 @@ (string/= parseType "Collection"))) (when UUID (parse-properties-of-node elem UUID) - (let ((subject-identifiers - (make-isidorus-identifiers - (list elem) start-revision :what "subjectIdentifier")) - (item-identities - (make-isidorus-identifiers (list elem) start-revision)) - (subject-locators - (make-isidorus-identifiers (list elem) start-revision - :what "subjectLocator"))) - (let ((this - (make-topic-stub - nil nil nil UUID start-revision xml-importer::tm - :additional-subject-identifiers - subject-identifiers - :item-identifiers item-identities - :subject-locators subject-locators - :document-id document-id))) - (let ((literals - (append (get-literals-of-property - elem fn-xml-lang) - (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations - (get-associations-of-node-content - elem tm-id xml-base)) - (types (get-types-of-property - elem tm-id - :parent-xml-base xml-base)) - (super-classes - (get-super-classes-of-node-content - elem tm-id xml-base))) - (make-isidorus-names elem this tm-id start-revision - :owner-xml-base xml-base - :document-id document-id) - (make-isidorus-occurrences - elem this tm-id start-revision - :owner-xml-base xml-base :document-id document-id) - (make-literals this literals tm-id start-revision - :document-id document-id) - (make-associations - this associations xml-importer::tm - start-revision :document-id document-id) - (make-types this types xml-importer::tm start-revision - :document-id document-id) - (make-super-classes - this super-classes xml-importer::tm - start-revision :document-id document-id)) - this)))))) + (let ((this + (get-item-by-id UUID :xtm-id document-id + :revision start-revision))) + (let ((literals + (append (get-literals-of-property + elem fn-xml-lang) + (get-literals-of-node-content + elem tm-id xml-base fn-xml-lang))) + (associations + (get-associations-of-node-content + elem tm-id xml-base)) + (types + (remove-if + #'null + (append + (get-types-of-node-content elem tm-id fn-xml-base) + (when (get-ns-attribute elem "type") + (list :ID nil + :topicid (get-ns-attribute elem "type") + :psi (get-ns-attribute elem "type")))))) + (super-classes + (get-super-classes-of-node-content + elem tm-id xml-base))) + (make-literals this literals tm-id start-revision + :document-id document-id) + (make-associations this associations xml-importer::tm + start-revision :document-id document-id) + (make-types this types xml-importer::tm start-revision + :document-id document-id) + (make-super-classes + this super-classes xml-importer::tm + start-revision :document-id document-id)) + this))))) (make-recursion-from-arc elem tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang) @@ -769,7 +264,7 @@ (map 'list #'(lambda(literal) (make-occurrence owner-top literal start-revision tm-id :document-id document-id)) - (filter-isidorus-literals literals))) + literals)) (defun make-associations (owner-top associations tm start-revision @@ -787,24 +282,21 @@ (defun make-types (owner-top types tm start-revision &key (document-id *document-id*)) "Creates instance-of associations corresponding to the passed - topic owner-top and the passed types but not isidorus:Topic." + topic owner-top and the passed types." (declare (d:TopicC owner-top)) - (remove-if - #'null - (map 'list - #'(lambda(type) - (when (string/= (getf type :psi) *tm2rdf-topic-type-uri*) - (let ((type-topic - (make-topic-stub (getf type :psi) - nil - (getf type :topicid) - nil start-revision tm - :document-id document-id)) - (ID (getf type :ID))) - (make-instance-of-association owner-top type-topic - ID start-revision tm - :document-id document-id)))) - types))) + (map 'list + #'(lambda(type) + (let ((type-topic + (make-topic-stub (getf type :psi) + nil + (getf type :topicid) + nil start-revision tm + :document-id document-id)) + (ID (getf type :ID))) + (make-instance-of-association owner-top type-topic + ID start-revision tm + :document-id document-id))) + types)) (defun make-super-classes (owner-top super-classes tm start-revision @@ -833,36 +325,40 @@ "Creates an supertype-subtype association." (declare (TopicC sub-top super-top)) (declare (TopicMapC tm)) - (let ((assoc-type - (make-topic-stub *supertype-subtype-psi* nil nil nil - start-revision tm :document-id document-id)) - (role-type-1 - (make-topic-stub *supertype-psi* nil nil nil - start-revision tm :document-id document-id)) - (role-type-2 - (make-topic-stub *subtype-psi* nil nil nil - start-revision tm :document-id document-id)) - (err-pref "From make-supertype-subtype-association(): ")) - (unless assoc-type - (error "~athe association type ~a is missing!" - err-pref *supertype-subtype-psi*)) - (unless (or role-type-1 role-type-2) - (error "~aone of the role types ~a ~a is missing!" - err-pref *supertype-psi* *subtype-psi*)) - (let ((a-roles (list (list :instance-of role-type-1 - :player super-top) - (list :instance-of role-type-2 - :player sub-top)))) - (when reifier-id - (make-reification reifier-id sub-top super-top - assoc-type start-revision tm - :document-id document-id)) - (add-to-topicmap - tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of assoc-type - :roles a-roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((assoc-type + (make-topic-stub *supertype-subtype-psi* nil nil nil + start-revision tm :document-id document-id)) + (role-type-1 + (make-topic-stub *supertype-psi* nil nil nil + start-revision tm :document-id document-id)) + (role-type-2 + (make-topic-stub *subtype-psi* nil nil nil + start-revision tm :document-id document-id)) + (err-pref "From make-supertype-subtype-association(): ")) + (unless assoc-type + (error "~athe association type ~a is missing!" + err-pref *supertype-subtype-psi*)) + (unless (or role-type-1 role-type-2) + (error "~aone of the role types ~a ~a is missing!" + err-pref *supertype-psi* *subtype-psi*)) + (let ((a-roles (list (list :instance-of role-type-1 + :player super-top) + (list :instance-of role-type-2 + :player sub-top)))) + (when reifier-id + (make-reification reifier-id sub-top super-top + assoc-type start-revision tm + :document-id document-id)) + (let ((assoc + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles)))) + (format t "a") + assoc))))) (defun make-instance-of-association (instance-top type-top reifier-id @@ -871,42 +367,44 @@ "Creates and returns an instance-of association." (declare (TopicC type-top instance-top)) (declare (TopicMapC tm)) - (let ((assoc-type - (make-topic-stub *type-instance-psi* nil nil nil - start-revision tm :document-id document-id)) - (roletype-1 - (make-topic-stub *type-psi* nil nil nil - start-revision tm :document-id document-id)) - (roletype-2 - (make-topic-stub *instance-psi* nil nil nil - start-revision tm :document-id document-id)) - (err-pref "From make-instance-of-association(): ")) - (unless assoc-type - (error "~athe association type ~a is missing!" - err-pref *type-instance-psi*)) - (unless (or roletype-1 roletype-2) - (error "~aone of the role types ~a ~a is missing!" - err-pref *type-psi* *instance-psi*)) - (let ((a-roles (list (list :instance-of roletype-1 - :player type-top) - (list :instance-of roletype-2 - :player instance-top)))) - (when reifier-id - (make-reification reifier-id instance-top type-top - assoc-type start-revision tm - :document-id document-id)) - (add-to-topicmap - tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of assoc-type - :roles a-roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((assoc-type + (make-topic-stub *type-instance-psi* nil nil nil + start-revision tm :document-id document-id)) + (roletype-1 + (make-topic-stub *type-psi* nil nil nil + start-revision tm :document-id document-id)) + (roletype-2 + (make-topic-stub *instance-psi* nil nil nil + start-revision tm :document-id document-id)) + (err-pref "From make-instance-of-association(): ")) + (unless assoc-type + (error "~athe association type ~a is missing!" + err-pref *type-instance-psi*)) + (unless (or roletype-1 roletype-2) + (error "~aone of the role types ~a ~a is missing!" + err-pref *type-psi* *instance-psi*)) + (let ((a-roles (list (list :instance-of roletype-1 + :player type-top) + (list :instance-of roletype-2 + :player instance-top)))) + (when reifier-id + (make-reification reifier-id instance-top type-top + assoc-type start-revision tm + :document-id document-id)) + (let ((assoc + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles)))) + (format t "a") + assoc))))) (defun make-topic-stub (about ID nodeId UUID start-revision - tm &key (document-id *document-id*) - (additional-subject-identifiers nil) - (item-identifiers nil) (subject-locators nil)) + tm &key (document-id *document-id*)) "Returns a topic corresponding to the passed parameters. When the searched topic does not exist there will be created one. If about or ID is set there will also be created a new PSI." @@ -914,40 +412,47 @@ (let ((topic-id (or about ID nodeID UUID)) (psi-uri (or about ID))) (let ((top - ;seems like there is a bug in get-item-by-id: + ;seems like there is a bug in d:get-item-by-id: ;this functions returns an emtpy topic although there is no one - ;witha corresponding topic id and/or version and/or xtm-id + ;with a corresponding topic id and/or version and/or xtm-id (let ((inner-top (get-item-by-id topic-id :xtm-id document-id :revision start-revision))) + ;;(when inner-top + ;; (let ((versions (d::versions inner-top))) + ;; (unless (find-if #'(lambda(version) + ;; (= start-revision + ;; (d::start-revision version))) + ;; versions) + ;; (d::add-to-version-history inner-top + ;; :start-revision start-revision) + ;; (add-to-topicmap tm inner-top))))))) (when (and inner-top - (find-if #'(lambda(x) - (= (d::start-revision x) start-revision)) - (d::versions inner-top))) + (find-if #'(lambda(x) + (= (d::start-revision x) start-revision)) + (d::versions inner-top))) inner-top)))) (if top top - (let ((psis (if psi-uri - (remove-if - #'null - (append - (list - (make-instance 'PersistentIdC - :uri psi-uri - :start-revision start-revision)) - additional-subject-identifiers)) - additional-subject-identifiers))) - (handler-case (add-to-topicmap - tm - (make-construct 'TopicC - :topicid topic-id - :psis psis - :item-identifiers item-identifiers - :locators subject-locators - :xtm-id document-id - :start-revision start-revision)) - (Condition (err)(error "Creating topic ~a failed: ~a" - topic-id err)))))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((psis (when psi-uri + (list + (make-instance 'PersistentIdC + :uri psi-uri + :start-revision start-revision))))) + (handler-case (let ((top + (add-to-topicmap + tm + (make-construct + 'TopicC + :topicid topic-id + :psis psis + :xtm-id document-id + :start-revision start-revision)))) + (format t "t") + top) + (Condition (err)(error "Creating topic ~a failed: ~a" + topic-id err))))))))) (defun make-lang-topic (lang start-revision tm @@ -975,28 +480,32 @@ (player-id (getf association :topicid)) (player-psi (getf association :psi)) (ID (getf association :ID))) - (let ((player-1 (make-topic-stub player-psi nil player-id nil - start-revision - tm :document-id document-id)) - (role-type-1 - (make-topic-stub *rdf2tm-object* nil nil nil - start-revision tm :document-id document-id)) - (role-type-2 - (make-topic-stub *rdf2tm-subject* nil nil nil - start-revision tm :document-id document-id)) - (type-top (make-topic-stub type nil nil nil start-revision - tm :document-id document-id))) - (let ((roles (list (list :instance-of role-type-1 - :player player-1) - (list :instance-of role-type-2 - :player top)))) - (when ID - (make-reification ID top player-1 type-top start-revision - tm :document-id document-id)) - (add-to-topicmap tm (make-construct 'AssociationC - :start-revision start-revision - :instance-of type-top - :roles roles)))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((player-1 (make-topic-stub player-psi nil player-id nil + start-revision + tm :document-id document-id)) + (role-type-1 + (make-topic-stub *rdf2tm-object* nil nil nil + start-revision tm :document-id document-id)) + (role-type-2 + (make-topic-stub *rdf2tm-subject* nil nil nil + start-revision tm :document-id document-id)) + (type-top (make-topic-stub type nil nil nil start-revision + tm :document-id document-id))) + (let ((roles (list (list :instance-of role-type-1 + :player player-1) + (list :instance-of role-type-2 + :player top)))) + (when ID + (make-reification ID top player-1 type-top start-revision + tm :document-id document-id)) + (let ((assoc + (add-to-topicmap tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of type-top + :roles roles)))) + (format t "a") + assoc)))))) (defun make-association-with-nodes (subject-topic object-topic @@ -1005,20 +514,25 @@ "Creates an association with two roles that contains the given players." (declare (TopicC subject-topic object-topic associationtype-topic)) (declare (TopicMapC tm)) - (let ((role-type-1 - (make-topic-stub *rdf2tm-subject* nil nil nil start-revision - tm :document-id document-id)) - (role-type-2 - (make-topic-stub *rdf2tm-object* nil nil nil start-revision - tm :document-id document-id))) - (let ((roles (list (list :instance-of role-type-1 - :player subject-topic) - (list :instance-of role-type-2 - :player object-topic)))) - (add-to-topicmap tm (make-construct 'AssociationC - :start-revision start-revision - :instance-of associationtype-topic - :roles roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((role-type-1 + (make-topic-stub *rdf2tm-subject* nil nil nil start-revision + tm :document-id document-id)) + (role-type-2 + (make-topic-stub *rdf2tm-object* nil nil nil start-revision + tm :document-id document-id))) + (let ((roles (list (list :instance-of role-type-1 + :player subject-topic) + (list :instance-of role-type-2 + :player object-topic)))) + (let ((assoc + (add-to-topicmap + tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of associationtype-topic + :roles roles)))) + (format t "a") + assoc))))) (defun make-reification (reifier-id subject object predicate start-revision tm @@ -1028,34 +542,36 @@ (declare ((or OccurrenceC TopicC) object)) (declare (TopicC subject predicate)) (declare (TopicMapC tm)) - - (let ((reifier (make-topic-stub reifier-id nil nil nil start-revision tm - :document-id document-id)) - (predicate-arc (make-topic-stub *rdf-predicate* nil nil nil start-revision + (elephant:ensure-transaction (:txn-nosync t) + (let ((reifier (make-topic-stub reifier-id nil nil nil start-revision tm + :document-id document-id)) + (predicate-arc (make-topic-stub *rdf-predicate* nil nil nil + start-revision + tm :document-id document-id)) + (object-arc (make-topic-stub *rdf-object* nil nil nil start-revision + tm :document-id document-id)) + (subject-arc (make-topic-stub *rdf-subject* nil nil nil + start-revision tm :document-id document-id)) - (object-arc (make-topic-stub *rdf-object* nil nil nil start-revision - tm :document-id document-id)) - (subject-arc (make-topic-stub *rdf-subject* nil nil nil start-revision - tm :document-id document-id)) - (statement (make-topic-stub *rdf-statement* nil nil nil start-revision - tm :document-id document-id))) - (make-instance-of-association reifier statement nil start-revision tm - :document-id document-id) - (make-association-with-nodes reifier subject subject-arc tm - start-revision :document-id document-id) - (make-association-with-nodes reifier predicate predicate-arc - tm start-revision :document-id document-id) - (if (typep object 'd:TopicC) - (make-association-with-nodes reifier object object-arc - tm start-revision - :document-id document-id) - (make-construct 'd:OccurrenceC - :start-revision start-revision - :topic reifier - :themes (themes object) - :instance-of (instance-of object) - :charvalue (charvalue object) - :datatype (datatype object))))) + (statement (make-topic-stub *rdf-statement* nil nil nil start-revision + tm :document-id document-id))) + (make-instance-of-association reifier statement nil start-revision tm + :document-id document-id) + (make-association-with-nodes reifier subject subject-arc tm + start-revision :document-id document-id) + (make-association-with-nodes reifier predicate predicate-arc + tm start-revision :document-id document-id) + (if (typep object 'd:TopicC) + (make-association-with-nodes reifier object object-arc + tm start-revision + :document-id document-id) + (make-construct 'd:OccurrenceC + :start-revision start-revision + :topic reifier + :themes (themes object) + :instance-of (instance-of object) + :charvalue (charvalue object) + :datatype (datatype object)))))) (defun make-occurrence (top literal start-revision tm-id @@ -1070,32 +586,33 @@ (lang (getf literal :lang)) (datatype (getf literal :datatype)) (ID (getf literal :ID))) - (let ((type-top (make-topic-stub type nil nil nil start-revision - xml-importer::tm - :document-id document-id)) - (lang-top (make-lang-topic lang start-revision - xml-importer::tm - :document-id document-id))) - (let ((occurrence - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes (when lang-top - (list lang-top)) - :instance-of type-top - :charvalue value - :datatype datatype))) - (when ID - (make-reification ID top occurrence type-top start-revision - xml-importer::tm :document-id document-id)) - occurrence))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((type-top (make-topic-stub type nil nil nil start-revision + xml-importer::tm + :document-id document-id)) + (lang-top (make-lang-topic lang start-revision + xml-importer::tm + :document-id document-id))) + (let ((occurrence + (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes (when lang-top + (list lang-top)) + :instance-of type-top + :charvalue value + :datatype datatype))) + (when ID + (make-reification ID top occurrence type-top start-revision + xml-importer::tm :document-id document-id)) + occurrence)))))) (defun get-literals-of-node-content (node tm-id xml-base xml-lang) "Returns a list of literals that is produced of a node's content." (declare (dom:element node)) (tm-id-p tm-id "get-literals-of-noode-content") - (let ((properties (non-isidorus-child-nodes-or-text node :trim t)) + (let ((properties (child-nodes-or-text node :trim t)) (fn-xml-base (get-xml-base node :old-base xml-base)) (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) (let ((literals @@ -1164,8 +681,8 @@ :ID nil)) nil)) (content-types - (when (non-isidorus-child-nodes-or-text node :trim t) - (loop for child across (non-isidorus-child-nodes-or-text node :trim t) + (when (child-nodes-or-text node :trim t) + (loop for child across (child-nodes-or-text node :trim t) when (and (string= (dom:namespace-uri child) *rdf-ns*) (string= (get-node-name child) "type")) collect (let ((nodeID (get-ns-attribute child "nodeID")) @@ -1279,7 +796,7 @@ "Returns a list of super-classes and IDs." (declare (dom:element node)) (tm-id-p tm-id "get-super-classes-of-node-content") - (let ((content (non-isidorus-child-nodes-or-text node :trim t)) + (let ((content (child-nodes-or-text node :trim t)) (fn-xml-base (get-xml-base node :old-base xml-base))) (when content (loop for property across content @@ -1312,7 +829,7 @@ (defun get-associations-of-node-content (node tm-id xml-base) "Returns a list of associations with a type, value and ID member." (declare (dom:element node)) - (let ((properties (non-isidorus-child-nodes-or-text node :trim t)) + (let ((properties (child-nodes-or-text node :trim t)) (fn-xml-base (get-xml-base node :old-base xml-base))) (loop for property across properties when (let ((prop-name (get-node-name property)) @@ -1372,7 +889,7 @@ "Calls the next function that handles all DOM child elements of the passed element as arcs." (declare (dom:element node)) - (let ((content (non-isidorus-child-nodes-or-text node :trim t)) + (let ((content (child-nodes-or-text node :trim t)) (err-pref "From make-recursion-from-node(): ") (fn-xml-base (get-xml-base node :old-base xml-base)) (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) @@ -1391,7 +908,7 @@ (declare (dom:element arc)) (let ((fn-xml-base (get-xml-base arc :old-base xml-base)) (fn-xml-lang (get-xml-lang arc :old-lang xml-lang)) - (content (non-isidorus-child-nodes-or-text arc)) + (content (child-nodes-or-text arc)) (parseType (get-ns-attribute arc "parseType"))) (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype")) (type (get-absolute-attribute arc tm-id xml-base "type")) @@ -1423,55 +940,4 @@ collect (import-node item tm-id start-revision :document-id document-id :xml-base xml-base - :xml-lang xml-lang)))))))) - - -(defun make-isidorus-identifiers (owner-list start-revision &key (what "itemIdentity")) - "Returns a list oc created identifier objects that can be - used directly in make-topic-stub." - (declare (string what)) - (when (and (string/= what "itemIdentity") - (string/= what "subjectIdentifier") - (string/= what "subjectLocator")) - (error "From make-identifiers(): what must be set to: ~a but is ~a" - (list "itemIdentity" "subjectIdentifiers" "subjectLocator") - what)) - (let ((class-symbol - (cond - ((string= what "itemIdentity") - 'ItemIdentifierC) - ((string= what "subjectIdentifier") - 'PersistentIdC) - ((string= what "subjectLocator") - 'SubjectLocatorC)))) - (let ((uris - (loop for owner-elem in owner-list - append - (let ((content (child-nodes-or-text owner-elem :trim t))) - (unless (stringp content) - (let ((identifier-uris - (loop for property across content - when - (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property)) - (prop-content (child-nodes-or-text - property :trim t))) - (and (string= prop-ns *tm2rdf-ns*) - (string= prop-name what) - (stringp prop-content) - (> (length prop-content) 0))) - collect - (child-nodes-or-text property :trim t))) - (attr-uri - (let ((attr (get-ns-attribute owner-elem what - :ns-uri *tm2rdf-ns*))) - (when attr - (list attr))))) - (append identifier-uris attr-uri))))))) - (map 'list #'(lambda(x) - (make-instance class-symbol - :uri x - :start-revision start-revision)) - (remove-duplicates - (remove-if #'null uris) - :test #'string=))))) \ No newline at end of file + :xml-lang xml-lang)))))))) \ No newline at end of file Added: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/map_to_tm.lisp Sat Sep 5 11:53:27 2009 @@ -0,0 +1,77 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- +(in-package :rdf-importer) + +(defun map-to-tm (tm-id start-revision + &key (document-id *document-id*)) + (let ((topics-to-map (get-isi-topics tm-id start-revision + :document-id document-id))) + )) + + +(defun get-isi-topics (tm-id start-revision + &key (document-id *document-id*)) + "Returns all topics of the given tm and revision." + (let ((isi-topic-type (get-item-by-id *tm2rdf-topic-type-uri* + :xtm-id document-id + :revision start-revision)) + (type-instance (get-item-by-psi *type-instance-psi* + :revision start-revision)) + (instance (get-item-by-psi *instance-psi* + :revision start-revision))) + (when (and isi-topic-type type-instance instance) + (with-revision start-revision + (let ((type-associations + (remove-if #'null + (map 'list + #'(lambda(role) + (when (eql (instance-of (parent role)) + type-instance) + (parent role))) + (player-in-roles isi-topic-type))))) + (let ((instances + (remove-if #'null + (map 'list + #'(lambda(assoc) + (let ((role + (find-if #'(lambda(role) + (eql (instance-of role) + instance)) + (roles assoc)))) + (when role + (player role)))) + type-associations)))) + (let ((instances-of-tm + (with-tm (start-revision document-id tm-id) + (intersection (topics xml-importer::tm) instances)))) + (remove-if #'null + (map 'list + #'(lambda(x) + (find-item-by-revision x start-revision)) + instances-of-tm))))))))) + + +(defun map-isi-identifiers (top start-revision + &key (prop-uri *tm2rdf-itemIdentity-property*)) + (declare (TopicC top)) + (with-revision start-revision + (let ((identifier-occs + (remove-if #'null + (map 'list + #'(lambda(occurrence) + (let ((type (instance-of occurrence))) + (let ((type-psi + (find-if #'(lambda(psi) + (string= prop-uri + (uri psi))) + (psis type)))) + (format t "~a~%" type-psi) + (when type-psi + occurrence)))) + (occurrences top))))) + identifier-occs))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Sat Sep 5 11:53:27 2009 @@ -45,16 +45,7 @@ *tm2rdf-association-property* *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* - *tm2rdf-subjectLocator-property* - *tm2rdf-ns* - *tm2rdf-value-property* - *tm2rdf-nametype-property* - *tm2rdf-scope-property* - *tm2rdf-varianttype-property* - *tm2rdf-occurrencetype-property* - *tm2rdf-roletype-property* - *tm2rdf-associationtype-property* - *tm2rdf-player-property*) + *tm2rdf-subjectLocator-property*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) @@ -92,7 +83,8 @@ (:export :setup-rdf-module :rdf-importer :init-rdf-module - :*rdf-core-xtm*)) + :*rdf-core-xtm* + :*document-id*)) (in-package :rdf-importer) @@ -113,6 +105,8 @@ (defvar *_n-map* nil) +(defvar *document-id* "isidorus-rdf-document") + (defun _n-p (node) "Returns t if the given value is of the form _[0-9]+" @@ -299,29 +293,6 @@ :psi (or ID about))))))) -(defun get-ref-of-property (property-elem tm-id xml-base) - "Returns a plist of the form (:topicid :psi ). - That contains the property's value." - (declare (dom:element property-elem)) - (declare (string tm-id)) - (let ((nodeId (get-ns-attribute property-elem "nodeID")) - (resource (get-ns-attribute property-elem "resource")) - (content (let ((node-refs - (get-node-refs (child-nodes-or-text property-elem) - tm-id xml-base))) - (when node-refs - (first node-refs))))) - (cond - (nodeID - (list :topicid nodeID - :psi nil)) - (resource - (list :topicid resource - :psi resource)) - (content - content)))) - - (defun parse-property-name (property owner-identifier) "Parses the given property's name to the known rdf/rdfs nodes and arcs. If the given name es equal to an node an error is thrown otherwise @@ -531,18 +502,3 @@ :psi (get-type-of-node-name elem) :ID nil))) (get-types-of-node-content elem tm-id xml-base))))) - - -(defun get-types-of-property (elem tm-id &key (parent-xml-base nil)) - "Returns a plist of all property's types of the form - (:topicid :psi :ID )." - (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) - (remove-if #'null - (append - (get-types-of-node-content elem tm-id xml-base) - (when (get-ns-attribute elem "type") - (list :ID nil - :topicid (get-ns-attribute elem "type") - :psi (get-ns-attribute elem "type"))))))) - - From lgiessmann at common-lisp.net Mon Sep 7 08:44:20 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 07 Sep 2009 04:44:20 -0400 Subject: [isidorus-cvs] r133 - trunk/src/xml/rdf Message-ID: Author: lgiessmann Date: Mon Sep 7 04:44:19 2009 New Revision: 133 Log: rdf-importer: mapping isidorus:topics to full TM constructs is implemented by manipulating imported constructs from rdf in the db Modified: trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Sep 7 04:44:19 2009 @@ -42,6 +42,7 @@ (truename rdf-xml-path) (cxml-dom:make-dom-builder))))) (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) + (map-to-tm tm-id start-revision :document-id document-id) (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC))) Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 04:44:19 2009 @@ -10,54 +10,320 @@ (defun map-to-tm (tm-id start-revision &key (document-id *document-id*)) (let ((topics-to-map (get-isi-topics tm-id start-revision - :document-id document-id))) - )) + :document-id document-id)) + (associations-to-map (get-isi-topics + tm-id start-revision + :document-id document-id + :type-psi *tm2rdf-association-type-uri*))) + (let ((mapped-topics + (map 'list #'(lambda(top) + (map-isi-topic top start-revision)) + topics-to-map)) + (mapped-associations associations-to-map)) + + (append mapped-topics mapped-associations) + ;check-for-duplicate-identifiers + ;delete-construct: + ; *item-identifier-property + ; *subject-identifier-property + ; *subject-locator-proeprty* + ; *topic-type + ; *occurrence-type + ; *occurrence-property + ; *name-type + ; *name-property + ; *variant-type + ; *variant-property + ; *occurrence-type-property + ; *value-property + ; *scope-property + ; *nametype-property + ))) + + +(defun map-isi-topic(top start-revision) + "maps a passed topic with all its isidorus:types to a TM topic." + (declare (integer start-revision)) + (declare(TopicC top)) + (let ((new-psis (map-isi-identifiers + top start-revision + :id-type-uri *tm2rdf-subjectidentifier-property*)) + (new-locators (map-isi-identifiers + top start-revision + :id-type-uri *tm2rdf-subjectlocator-property*)) + (new-item-ids (map-isi-identifiers top start-revision)) + (occurrence-topics (get-isi-occurrences top start-revision)) + (name-topics (get-isi-names top start-revision))) + (bound-subject-identifiers top new-psis) + (bound-subject-locators top new-locators) + (bound-item-identifiers top new-item-ids) + (map 'list #'(lambda(occ-top) + (map-isi-occurrence top occ-top start-revision)) + occurrence-topics) + (map 'list #'(lambda(name-top) + (map-isi-name top name-top start-revision)) + name-topics)) + top) + + +(defun get-isi-variants(name-top start-revision) + "Returns all topics representing a name's variant." + (declare (TopicC name-top)) + (declare (integer start-revision)) + (let ((variant-assocs + (get-associations-by-type name-top start-revision + *tm2rdf-variant-property* + *rdf2tm-subject*))) + (let ((players + (get-players-by-role-type variant-assocs start-revision + *rdf2tm-object*))) + (map 'list #'d::delete-construct variant-assocs) + players))) + + +(defun map-isi-variant (name variant-top start-revision) + "Maps the passed variant-topic to a TM variant." + (declare (TopicC variant-top)) + (declare (NameC name)) + (declare (integer start-revision)) + (let ((ids (map-isi-identifiers variant-top start-revision)) + (scope-assocs + (get-associations-by-type + variant-top start-revision + (concatenate 'string *tm2rdf-ns* "scope") + *rdf2tm-subject*)) + (value-type-topic + (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (let ((scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (value-and-datatype + (let ((value-occ + (find-if #'(lambda(occ) + (eql (instance-of occ) value-type-topic)) + (occurrences variant-top)))) + (if value-occ + (list :value (charvalue value-occ) + :datatype (datatype value-occ)) + (list :value "" + :datatype *xml-string*))))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct scope-assocs) + (d::delete-construct variant-top) + (make-construct 'VariantC + :start-revision start-revision + :item-identifiers ids + :themes scopes + :charvalue (getf value-and-datatype :value) + :datatype (getf value-and-datatype :datatype) + :name name))))) + + +(defun map-isi-name (top name-top start-revision) + "Maps the passed occurrence-topic to a TM occurrence." + (declare (TopicC top name-top)) + (declare (integer start-revision)) + (let ((err-pref "From map-isi-name(): ") + (ids (map-isi-identifiers name-top start-revision)) + (type-assocs + (get-associations-by-type + name-top start-revision + (concatenate 'string *tm2rdf-ns* "nametype") + *rdf2tm-subject*)) + (scope-assocs + (get-associations-by-type + name-top start-revision + (concatenate 'string *tm2rdf-ns* "scope") + *rdf2tm-subject*)) + (value-type-topic + (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value"))) + (variant-topics (get-isi-variants name-top start-revision))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (value + (let ((value-occ + (find-if #'(lambda(occ) + (eql (instance-of occ) value-type-topic)) + (occurrences name-top)))) + (if value-occ + (charvalue value-occ) + "")))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct scope-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (let ((name (make-construct 'NameC + :start-revision start-revision + :topic top + :charvalue value + :instance-of (first types) + :item-identifiers ids + :themes scopes))) + (map 'list #'(lambda(variant-top) + (map-isi-variant name variant-top start-revision)) + variant-topics) + (d::delete-construct name-top) + name))))) + + +(defun get-isi-names(top start-revision) + "Returns all topics that represents names for the passed top." + (declare (TopicC top)) + (declare (integer start-revision)) + (let ((assocs (get-associations-by-type + top start-revision *tm2rdf-name-property* + *rdf2tm-subject*))) + (let ((occ-tops (get-players-by-role-type + assocs start-revision *rdf2tm-object*))) + (map 'list #'d::delete-construct assocs) + occ-tops))) + + +(defun map-isi-occurrence(top occ-top start-revision) + "Maps all topics that represents occurrences of the passed topic top + to occurrence objects." + (declare (TopicC top occ-top)) + (declare (integer start-revision)) + (let ((err-pref "From map-isi-occurrence(): ") + (ids (map-isi-identifiers occ-top start-revision)) + (type-assocs + (get-associations-by-type + occ-top start-revision + (concatenate 'string *tm2rdf-ns* "occurrencetype") + *rdf2tm-subject*)) + (scope-assocs + (get-associations-by-type + occ-top start-revision + (concatenate 'string *tm2rdf-ns* "scope") + *rdf2tm-subject*)) + (value-type-topic + (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (value-and-datatype + (let ((value-occ + (find-if #'(lambda(occ) + (eql (instance-of occ) value-type-topic)) + (occurrences occ-top)))) + (if value-occ + (list :value (charvalue value-occ) + :datatype (datatype value-occ)) + (list :value "" + :datatype *xml-string*))))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct scope-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (d::delete-construct occ-top) + (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes scopes + :item-identifiers ids + :instance-of (first types) + :charvalue (getf value-and-datatype :value) + :datatype (getf value-and-datatype :datatype)))))) + + +(defun get-isi-occurrences(top start-revision) + "Returns all topics that represents occurrences for the passed top." + (declare (TopicC top)) + (declare (integer start-revision)) + (let ((assocs (get-associations-by-type + top start-revision *tm2rdf-occurrence-property* + *rdf2tm-subject*))) + (let ((occ-tops (get-players-by-role-type + assocs start-revision *rdf2tm-object*))) + (map 'list #'d::delete-construct assocs) + occ-tops))) (defun get-isi-topics (tm-id start-revision - &key (document-id *document-id*)) + &key (document-id *document-id*) + (type-psi *tm2rdf-topic-type-uri*)) "Returns all topics of the given tm and revision." - (let ((isi-topic-type (get-item-by-id *tm2rdf-topic-type-uri* - :xtm-id document-id - :revision start-revision)) - (type-instance (get-item-by-psi *type-instance-psi* - :revision start-revision)) - (instance (get-item-by-psi *instance-psi* - :revision start-revision))) - (when (and isi-topic-type type-instance instance) - (with-revision start-revision - (let ((type-associations - (remove-if #'null - (map 'list + (let ((type-topic (get-item-by-psi type-psi + :revision start-revision))) + (when type-topic + (let ((assocs (get-associations-by-type + type-topic start-revision *type-instance-psi* + *type-psi*))) + (let ((isi-topics (get-players-by-role-type + assocs start-revision *instance-psi*))) + (let ((topics-in-tm + (with-tm (start-revision document-id tm-id) + (intersection isi-topics (topics xml-importer::tm))))) + (map 'list #'(lambda(top) + (map 'list #'(lambda(role) - (when (eql (instance-of (parent role)) - type-instance) - (parent role))) - (player-in-roles isi-topic-type))))) - (let ((instances - (remove-if #'null - (map 'list - #'(lambda(assoc) - (let ((role - (find-if #'(lambda(role) - (eql (instance-of role) - instance)) - (roles assoc)))) - (when role - (player role)))) - type-associations)))) - (let ((instances-of-tm - (with-tm (start-revision document-id tm-id) - (intersection (topics xml-importer::tm) instances)))) - (remove-if #'null - (map 'list - #'(lambda(x) - (find-item-by-revision x start-revision)) - instances-of-tm))))))))) + (when (find (parent role) assocs) + (d::delete-construct (parent role)))) + (player-in-roles top))) + topics-in-tm) + topics-in-tm)))))) -(defun map-isi-identifiers (top start-revision - &key (prop-uri *tm2rdf-itemIdentity-property*)) +(defun get-associations-by-type (top start-revision association-type-psi + role-type-psi) + "Returns all associations of the passed associaiton type where the + topic top is a player in a role of the given roletype." + (declare (TopicC top)) + (declare (string association-type-psi role-type-psi)) + (declare (integer start-revision)) + (let ((assoc-type (get-item-by-psi association-type-psi + :revision start-revision)) + (role-type (get-item-by-psi role-type-psi + :revision start-revision))) + (when (and assoc-type role-type) + (let ((assocs + (remove-if + #'null + (map 'list + #'(lambda(role) + (when (and (eql (instance-of (parent role)) assoc-type) + (eql (instance-of role) role-type)) + (parent role))) + (player-in-roles top))))) + assocs)))) + + +(defun get-players-by-role-type (associations start-revision + role-type-psi) + "Returns all players of the passed associaiton that are contained + in roles of the given type." + (declare (list associations)) + (declare (integer start-revision)) + (declare (string role-type-psi)) + (let ((role-type (get-item-by-psi role-type-psi + :revision start-revision))) + (let ((players + (remove-if + #'null + (map 'list + #'(lambda(assoc) + (let ((role + (find-if #'(lambda(role) + (eql role-type (instance-of role))) + (roles assoc)))) + (when role + (player role)))) + associations)))) + players))) + + + +(defun get-occurrences-by-type (top start-revision + &key (occurrence-type-uri + *tm2rdf-itemIdentity-property*)) + "Returns all occurrences of the given topic, that is of the type + bound to occurrence-type-uri." (declare (TopicC top)) (with-revision start-revision (let ((identifier-occs @@ -67,11 +333,69 @@ (let ((type (instance-of occurrence))) (let ((type-psi (find-if #'(lambda(psi) - (string= prop-uri - (uri psi))) + (string= + occurrence-type-uri + (uri psi))) (psis type)))) - (format t "~a~%" type-psi) (when type-psi occurrence)))) (occurrences top))))) - identifier-occs))) \ No newline at end of file + identifier-occs))) + + +(defun map-isi-identifiers (top start-revision + &key (id-type-uri + *tm2rdf-itemIdentity-property*)) + "Maps identifiers of the type depending on id-type-uri from topic occurrences + imported from RDF to the corresponding TM constructs." + (declare (TopicC top)) + (let ((id-occs (get-occurrences-by-type top start-revision + :occurrence-type-uri id-type-uri)) + (class-symbol (cond + ((string= id-type-uri + *tm2rdf-itemIdentity-property*) + 'ItemIdentifierC) + ((string= id-type-uri + *tm2rdf-subjectLocator-property*) + 'SubjectLocatorC) + ((string= id-type-uri + *tm2rdf-subjectIdentifier-property*) + 'PersistentIdC)))) + (let ((id-uris (map 'list #'charvalue id-occs))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct id-occs) + (let ((ids (map 'list + #'(lambda(id-uri) + (make-instance class-symbol + :uri id-uri + :start-revision start-revision)) + id-uris))) + ids))))) + + +(defun bound-item-identifiers (construct identifiers) + "Bounds the passed item-identifier to the passed construct." + (declare (ReifiableConstructC construct)) + (dolist (id identifiers) + (declare (ItemIdentifierC id)) + (setf (identified-construct id) construct)) + construct) + + +(defun bound-subject-identifiers (top identifiers) + "Bounds the passed psis to the passed topic." + (declare (TopicC top)) + (dolist (id identifiers) + (declare (PersistentIdC id)) + (setf (identified-construct id) top)) + top) + + +(defun bound-subject-locators (top locators) + "Bounds the passed locators to the passed topic." + (declare (TopicC top)) + (dolist (id locators) + (declare (SubjectLocatorC id)) + (setf (identified-construct id) top)) + top) + Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Sep 7 04:44:19 2009 @@ -45,7 +45,8 @@ *tm2rdf-association-property* *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* - *tm2rdf-subjectLocator-property*) + *tm2rdf-subjectLocator-property* + *tm2rdf-ns*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) From lgiessmann at common-lisp.net Mon Sep 7 11:21:34 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 07 Sep 2009 07:21:34 -0400 Subject: [isidorus-cvs] r134 - in trunk/src: model xml/rdf Message-ID: Author: lgiessmann Date: Mon Sep 7 07:21:34 2009 New Revision: 134 Log: rdf-importer: all rdf-isidorus-types are mapped to the corresponding TM-constructs; fixed a bug in datamodel with deleteing associations and topics from topicMaps Modified: trunk/src/model/datamodel.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Mon Sep 7 07:21:34 2009 @@ -272,6 +272,7 @@ (dolist (versioninfo (versions construct)) (delete-construct versioninfo))) + (defgeneric add-to-version-history (construct &key start-revision end-revision) (:documentation "Add version history to a topic map construct")) @@ -990,7 +991,9 @@ (used-as-type construct))) (delete-construct dependent)) (dolist (theme (used-as-theme construct)) - (elephant:remove-association construct 'used-as-theme theme))) + (elephant:remove-association construct 'used-as-theme theme)) + (dolist (tm (in-topicmaps construct)) + (elephant:remove-association construct 'in-topicmaps tm))) (defun get-all-constructs-by-uri (uri) (delete @@ -1422,7 +1425,9 @@ (defmethod delete-construct :before ((construct AssociationC)) (dolist (role (roles construct)) - (delete-construct role))) + (delete-construct role)) + (dolist (tm (in-topicmaps construct)) + (elephant:remove-association construct 'in-topicmaps tm))) (defmethod find-all-equivalent ((construct AssociationC)) (let Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 07:21:34 2009 @@ -19,32 +19,179 @@ (map 'list #'(lambda(top) (map-isi-topic top start-revision)) topics-to-map)) - (mapped-associations associations-to-map)) - - (append mapped-topics mapped-associations) - ;check-for-duplicate-identifiers - ;delete-construct: - ; *item-identifier-property - ; *subject-identifier-property - ; *subject-locator-proeprty* - ; *topic-type - ; *occurrence-type - ; *occurrence-property - ; *name-type - ; *name-property - ; *variant-type - ; *variant-property - ; *occurrence-type-property - ; *value-property - ; *scope-property - ; *nametype-property - ))) + (mapped-associations + (map 'list #'(lambda(top) + (map-isi-association top start-revision tm-id + :document-id document-id)) + associations-to-map))) + (let ((constructs + (append mapped-topics mapped-associations))) + (clear-store start-revision) + (map 'list #'d::check-for-duplicate-identifiers constructs) + constructs)))) + + +(defun clear-store(start-revision) + "Deletes all topics that are neede for RDF2TM mapping and are not + referenced in an associaiton, as type or scope." + (let ((psi-uris + (list *tm2rdf-topic-type-uri* *tm2rdf-name-type-uri* + *tm2rdf-variant-type-uri* *tm2rdf-occurrence-type-uri* + *tm2rdf-association-type-uri* *tm2rdf-role-type-uri* + *tm2rdf-itemIdentity-property* *tm2rdf-subjectLocator-property* + *tm2rdf-subjectIdentifier-property* *tm2rdf-role-property* + *tm2rdf-subjectIdentifier-property* *tm2rdf-player-property* + *tm2rdf-nametype-property* *tm2rdf-value-property* + *tm2rdf-occurrence-property* *tm2rdf-roletype-property* + *tm2rdf-variant-property* *tm2rdf-occurrencetype-property* + *tm2rdf-name-property* *tm2rdf-associationtype-property* + *tm2rdf-scope-property*))) + (dolist (uri psi-uris) + (delete-topic-if-not-referenced uri start-revision)))) + + +(defun delete-topic-if-not-referenced(type-psi start-revision) + "Deletes a topic when it is not referenced." + (declare (string type-psi)) + (declare (integer start-revision)) + (let ((type-topic (get-item-by-psi type-psi + :revision start-revision))) + (when type-topic + (when (and (not (player-in-roles type-topic)) + (not (used-as-type type-topic)) + (not (used-as-theme type-topic))) + (d::delete-construct type-topic))))) + + +(defun delete-instance-of-association(instance-topic type-topic) + "Deletes a type-instance associaiton that corresponds woith the passed + parameters." + (when (and instance-topic type-topic) + (let ((instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (type (get-item-by-psi *type-psi*))) + (declare (TopicC instance-topic type-topic)) + (let ((assocs (map 'list + #'(lambda(role) + (when (and (eql (instance-of role) instance) + (eql (instance-of (parent role)) + type-instance)) + (parent role))) + (player-in-roles instance-topic)))) + (map 'list #'(lambda(assoc) + (when (find-if #'(lambda(role) + (and (eql (instance-of role) type) + (eql (player role) type-topic))) + (roles assoc)) + (d::delete-construct assoc))) + assocs) + nil)))) + + +(defun get-isi-roles(assoc-top start-revision) + "Returns all topics representing association-roles." + (declare (TopicC assoc-top)) + (declare (integer start-revision)) + (let ((role-assocs + (get-associations-by-type assoc-top start-revision + *tm2rdf-role-property* + *rdf2tm-subject*))) + (let ((players + (get-players-by-role-type role-assocs start-revision + *rdf2tm-object*))) + (map 'list #'d::delete-construct role-assocs) + players))) + + +(defun map-isi-role(role-top start-revision) + "Maps a passed topic with all its isidorus:types to a + property list representing an association-role." + (declare (TopicC role-top)) + (declare (integer start-revision)) + (let ((err-pref "From map-isi-role(): ") + (role-type-topic (get-item-by-psi *tm2rdf-role-type-uri* + :revision start-revision)) + (ids (map-isi-identifiers role-top start-revision)) + (type-assocs + (get-associations-by-type + role-top start-revision *tm2rdf-roletype-property* + *rdf2tm-subject*)) + (player-assocs + (get-associations-by-type + role-top start-revision *tm2rdf-player-property* + *rdf2tm-subject*))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (role-players (get-players-by-role-type + player-assocs start-revision *rdf2tm-object*))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct player-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (when (= 0 (length role-players)) + (error "~aexpect one player but found: ~a" + err-pref (length role-players))) + (delete-instance-of-association role-top role-type-topic) + (d::delete-construct role-top) + (list :instance-of (first types) + :player (first role-players) + :item-identifiers ids))))) + + +(defun map-isi-association(assoc-top start-revision tm-id + &key (document-id *document-id*)) + "Maps a passed topic with all its isidorus:types to a TM association." + (declare (TopicC assoc-top)) + (declare (integer start-revision)) + (format t "A") + (let ((err-pref "From map-isi-association(): ") + (ids (map-isi-identifiers assoc-top start-revision)) + (type-assocs + (get-associations-by-type + assoc-top start-revision *tm2rdf-associationtype-property* + *rdf2tm-subject*)) + (scope-assocs + (get-associations-by-type + assoc-top start-revision *tm2rdf-scope-property* + *rdf2tm-subject*)) + (role-tops (get-isi-roles assoc-top start-revision))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (assoc-roles + (remove-if #'null (map 'list + #'(lambda(role-top) + (map-isi-role role-top start-revision)) + role-tops)))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct scope-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (when (= 0 (length assoc-roles)) + (error "~aexpect at least one role but found: ~a" + err-pref (length assoc-roles))) + (d::delete-construct assoc-top) + (with-tm (start-revision document-id tm-id) + (add-to-topicmap + xml-importer::tm + (make-construct 'AssociationC + :start-revision start-revision + :item-identifiers ids + :instance-of (first types) + :themes scopes + :roles assoc-roles))))))) (defun map-isi-topic(top start-revision) - "maps a passed topic with all its isidorus:types to a TM topic." + "Maps a passed topic with all its isidorus:types to a TM topic." (declare (integer start-revision)) (declare(TopicC top)) + (format t "T") (let ((new-psis (map-isi-identifiers top start-revision :id-type-uri *tm2rdf-subjectidentifier-property*)) @@ -87,13 +234,14 @@ (declare (NameC name)) (declare (integer start-revision)) (let ((ids (map-isi-identifiers variant-top start-revision)) + (variant-type-topic (get-item-by-psi *tm2rdf-variant-type-uri* + :revision start-revision)) (scope-assocs (get-associations-by-type - variant-top start-revision - (concatenate 'string *tm2rdf-ns* "scope") + variant-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (get-item-by-psi *tm2rdf-value-property*))) (let ((scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value-and-datatype @@ -108,6 +256,7 @@ :datatype *xml-string*))))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) + (delete-instance-of-association variant-top variant-type-topic) (d::delete-construct variant-top) (make-construct 'VariantC :start-revision start-revision @@ -123,19 +272,19 @@ (declare (TopicC top name-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-name(): ") + (name-type-topic (get-item-by-psi *tm2rdf-name-type-uri* + :revision start-revision)) (ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type - name-top start-revision - (concatenate 'string *tm2rdf-ns* "nametype") + name-top start-revision *tm2rdf-nametype-property* *rdf2tm-subject*)) (scope-assocs (get-associations-by-type - name-top start-revision - (concatenate 'string *tm2rdf-ns* "scope") + name-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value"))) + (get-item-by-psi *tm2rdf-value-property*)) (variant-topics (get-isi-variants name-top start-revision))) (let ((types (get-players-by-role-type type-assocs start-revision *rdf2tm-object*)) @@ -165,6 +314,7 @@ (map 'list #'(lambda(variant-top) (map-isi-variant name variant-top start-revision)) variant-topics) + (delete-instance-of-association name-top name-type-topic) (d::delete-construct name-top) name))))) @@ -189,18 +339,18 @@ (declare (integer start-revision)) (let ((err-pref "From map-isi-occurrence(): ") (ids (map-isi-identifiers occ-top start-revision)) + (occurrence-type-topic (get-item-by-psi *tm2rdf-occurrence-type-uri* + :revision start-revision)) (type-assocs (get-associations-by-type - occ-top start-revision - (concatenate 'string *tm2rdf-ns* "occurrencetype") + occ-top start-revision *tm2rdf-occurrencetype-property* *rdf2tm-subject*)) (scope-assocs (get-associations-by-type - occ-top start-revision - (concatenate 'string *tm2rdf-ns* "scope") + occ-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (get-item-by-psi *tm2rdf-value-property*))) (let ((types (get-players-by-role-type type-assocs start-revision *rdf2tm-object*)) (scopes (get-players-by-role-type @@ -221,6 +371,7 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) + (delete-instance-of-association occ-top occurrence-type-topic) (d::delete-construct occ-top) (make-construct 'OccurrenceC :start-revision start-revision @@ -316,7 +467,6 @@ (player role)))) associations)))) players))) - (defun get-occurrences-by-type (top start-revision @@ -378,16 +528,24 @@ (declare (ReifiableConstructC construct)) (dolist (id identifiers) (declare (ItemIdentifierC id)) - (setf (identified-construct id) construct)) + (if (find-if #'(lambda(ii) + (string= (uri ii) (uri id))) + (item-identifiers construct)) + (d::delete-construct id) + (setf (identified-construct id) construct))) construct) (defun bound-subject-identifiers (top identifiers) - "Bounds the passed psis to the passed topic." + "Bounds the passed psis to the passed topic." (declare (TopicC top)) (dolist (id identifiers) (declare (PersistentIdC id)) - (setf (identified-construct id) top)) + (if (find-if #'(lambda(psi) + (string= (uri psi) (uri id))) + (psis top)) + (d::delete-construct id) + (setf (identified-construct id) top))) top) @@ -396,6 +554,9 @@ (declare (TopicC top)) (dolist (id locators) (declare (SubjectLocatorC id)) - (setf (identified-construct id) top)) + (if (find-if #'(lambda(locator) + (string= (uri locator) (uri id))) + (locators top)) + (d::delete-construct id) + (setf (identified-construct id) top))) top) - Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Sep 7 07:21:34 2009 @@ -46,7 +46,14 @@ *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* *tm2rdf-subjectLocator-property* - *tm2rdf-ns*) + *tm2rdf-ns* + *tm2rdf-value-property* + *tm2rdf-scope-property* + *tm2rdf-nametype-property* + *tm2rdf-occurrencetype-property* + *tm2rdf-roletype-property* + *tm2rdf-player-property* + *tm2rdf-associationtype-property*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) From lgiessmann at common-lisp.net Mon Sep 7 14:43:54 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 07 Sep 2009 10:43:54 -0400 Subject: [isidorus-cvs] r135 - in trunk/src: . unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Mon Sep 7 10:43:54 2009 New Revision: 135 Log: rdf-importer: added an RDF test file with exported and mapped TM constructs. Added: trunk/src/unit_tests/full_mapping.rdf Modified: trunk/src/isidorus.asd trunk/src/xml/rdf/map_to_tm.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Sep 7 10:43:54 2009 @@ -110,6 +110,7 @@ (:static-file "poems.rdf") (:static-file "poems_light.rdf") (:static-file "poems_light.xtm") + (:static-file "full_mapping.rdf") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Added: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- (empty file) +++ trunk/src/unit_tests/full_mapping.rdf Mon Sep 7 10:43:54 2009 @@ -0,0 +1,131 @@ + + + + + + + + + + Marjorie + + + + + + + Simpson + + + Housewife + + + + + + + Housewife + + + + + + + + Marge + + + + + + http://simpsons/marjorie + + + + + + http://simpsons/homer_simpson + http://some.where/resource + http://simpsons/ii/homer + + + + + Homer J. + + + + + Homer + + + + + + + + + + Simpson + + + + + + + + Safety Inspector + + + + + + + + Homer J. + + + + + Homer + + + + + + + + + http://simpsons/married/ii-1 + + + http://simpsons/role-husband/ii + + + + + + + + + + + + + + + + http://simpsons/maried/ii-2 + + + http://simpsons/role-wife/ii + + + + + + + \ No newline at end of file Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 10:43:54 2009 @@ -302,8 +302,8 @@ (map 'list #'d::delete-construct type-assocs) (map 'list #'d::delete-construct scope-assocs) (when (/= 1 (length types)) - (error "~aexpect one type topic but found: ~a" - err-pref (length types))) + (error "~aexpect one type topic but found: ~a (~a)" + err-pref (length types) value)) (let ((name (make-construct 'NameC :start-revision start-revision :topic top From lgiessmann at common-lisp.net Tue Sep 8 08:51:37 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 08 Sep 2009 04:51:37 -0400 Subject: [isidorus-cvs] r136 - in trunk/src: . unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Tue Sep 8 04:51:36 2009 New Revision: 136 Log: rdf-exporter: fixed a bug with missing name-types; rdf-importer: fixed a bug with merging/versioning of blank_nodes --> they get an item-identifier concatenated of a predefined prefix and their nodeID or a UUID Modified: trunk/src/constants.lisp trunk/src/unit_tests/full_mapping.rdf trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Tue Sep 8 04:51:36 2009 @@ -61,7 +61,8 @@ :*tm2rdf-occurrencetype-property* :*tm2rdf-roletype-property* :*tm2rdf-associationtype-property* - :*tm2rdf-player-property*)) + :*tm2rdf-player-property* + :*rdf2tm-blank-node-prefix*)) (in-package :constants) @@ -123,6 +124,8 @@ (defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/")) +(defparameter *rdf2tm-blank-node-prefix* (concatenate 'string *rdf2tm-ns* "blank_node/")) + (defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/") (defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic")) Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 04:51:36 2009 @@ -64,7 +64,7 @@ - + @@ -102,7 +102,7 @@ http://simpsons/married/ii-1 - http://simpsons/role-husband/ii + http://simpsons/role-husband/ii @@ -117,15 +117,29 @@ + + http://simpsons/role-wife/ii + + - http://simpsons/maried/ii-2 + + http://simpsons/married/ii-1 + http://simpsons/married/ii-2 + - - http://simpsons/role-wife/ii + + http://simpsons/role-wife/ii + + + + + + + - \ No newline at end of file + Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Tue Sep 8 04:51:36 2009 @@ -39,7 +39,7 @@ to be exported, the same mechanism as in xtm-exporter") -(defvar *ns-map* nil) ;; ((:prefix :uri )) +(defvar *ns-map* nil "((:prefix :uri ))") (defun rdf-li-or-uri (uri) @@ -297,8 +297,9 @@ (cxml:attribute "rdf:nodeID" (make-object-id construct)) (make-isi-type *tm2rdf-name-type-uri*) (map 'list #'to-rdf-elem (item-identifiers construct)) - (cxml:with-element "isi:nametype" - (make-topic-reference (instance-of construct))) + (when (slot-boundp construct 'instance-of) + (cxml:with-element "isi:nametype" + (make-topic-reference (instance-of construct)))) (scopes-to-rdf-elems construct) (cxml:with-element "isi:value" (cxml:attribute "rdf:datatype" *xml-string*) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Tue Sep 8 04:51:36 2009 @@ -411,28 +411,25 @@ If about or ID is set there will also be created a new PSI." (declare (TopicMapC tm)) (let ((topic-id (or about ID nodeID UUID)) - (psi-uri (or about ID))) + (psi-uri (or about ID)) + (ii-uri (unless (or about ID) + (concatenate 'string *rdf2tm-blank-node-prefix* + (or nodeID UUID))))) (let ((top ;seems like there is a bug in d:get-item-by-id: ;this functions returns an emtpy topic although there is no one - ;with a corresponding topic id and/or version and/or xtm-id + ;with a corresponding topic id and/or version. + ;Thus the version is temporary checked manually. (let ((inner-top (get-item-by-id topic-id :xtm-id document-id :revision start-revision))) - ;;(when inner-top - ;; (let ((versions (d::versions inner-top))) - ;; (unless (find-if #'(lambda(version) - ;; (= start-revision - ;; (d::start-revision version))) - ;; versions) - ;; (d::add-to-version-history inner-top - ;; :start-revision start-revision) - ;; (add-to-topicmap tm inner-top))))))) - (when (and inner-top - (find-if #'(lambda(x) - (= (d::start-revision x) start-revision)) - (d::versions inner-top))) - inner-top)))) + (when inner-top + (let ((versions (d::versions inner-top))) + (when (find-if #'(lambda(version) + (= start-revision + (d::start-revision version))) + versions) + inner-top)))))) (if top top (elephant:ensure-transaction (:txn-nosync t) @@ -440,7 +437,12 @@ (list (make-instance 'PersistentIdC :uri psi-uri - :start-revision start-revision))))) + :start-revision start-revision)))) + (iis (when ii-uri + (list + (make-instance 'ItemIdentifierC + :uri ii-uri + :start-revision start-revision))))) (handler-case (let ((top (add-to-topicmap tm @@ -448,6 +450,7 @@ 'TopicC :topicid topic-id :psis psis + :item-identifiers iis :xtm-id document-id :start-revision start-revision)))) (format t "t") @@ -463,12 +466,12 @@ (when lang (let ((psi-and-topic-id (concatenate-uri *rdf2tm-scope-prefix* lang))) - (let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id - :revision start-revision))) - (if top - top - (make-topic-stub psi-and-topic-id nil nil nil start-revision - tm :document-id document-id)))))) + ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id +; :revision start-revision))) +; (if top +; top + (make-topic-stub psi-and-topic-id nil nil nil start-revision + tm :document-id document-id)))) (defun make-association (top association tm start-revision Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 04:51:36 2009 @@ -71,13 +71,15 @@ (type-instance (get-item-by-psi *type-instance-psi*)) (type (get-item-by-psi *type-psi*))) (declare (TopicC instance-topic type-topic)) - (let ((assocs (map 'list - #'(lambda(role) - (when (and (eql (instance-of role) instance) - (eql (instance-of (parent role)) - type-instance)) - (parent role))) - (player-in-roles instance-topic)))) + (let ((assocs (remove-if + #'null + (map 'list + #'(lambda(role) + (when (and (eql (instance-of role) instance) + (eql (instance-of (parent role)) + type-instance)) + (parent role))) + (player-in-roles instance-topic))))) (map 'list #'(lambda(assoc) (when (find-if #'(lambda(role) (and (eql (instance-of role) type) @@ -86,6 +88,13 @@ (d::delete-construct assoc))) assocs) nil)))) + + +(defun delete-related-associations (top) + "Deletes all associaitons related to the passed topic." + (dolist (assoc-role (player-in-roles top)) + (d::delete-construct (parent assoc-role))) + top) (defun get-isi-roles(assoc-top start-revision) @@ -109,8 +118,6 @@ (declare (TopicC role-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-role(): ") - (role-type-topic (get-item-by-psi *tm2rdf-role-type-uri* - :revision start-revision)) (ids (map-isi-identifiers role-top start-revision)) (type-assocs (get-associations-by-type @@ -133,7 +140,7 @@ (when (= 0 (length role-players)) (error "~aexpect one player but found: ~a" err-pref (length role-players))) - (delete-instance-of-association role-top role-type-topic) + (delete-related-associations role-top) (d::delete-construct role-top) (list :instance-of (first types) :player (first role-players) @@ -175,6 +182,7 @@ (when (= 0 (length assoc-roles)) (error "~aexpect at least one role but found: ~a" err-pref (length assoc-roles))) + (delete-related-associations assoc-top) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) (add-to-topicmap @@ -234,8 +242,6 @@ (declare (NameC name)) (declare (integer start-revision)) (let ((ids (map-isi-identifiers variant-top start-revision)) - (variant-type-topic (get-item-by-psi *tm2rdf-variant-type-uri* - :revision start-revision)) (scope-assocs (get-associations-by-type variant-top start-revision *tm2rdf-scope-property* @@ -256,7 +262,7 @@ :datatype *xml-string*))))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) - (delete-instance-of-association variant-top variant-type-topic) + (delete-related-associations variant-top) (d::delete-construct variant-top) (make-construct 'VariantC :start-revision start-revision @@ -272,8 +278,6 @@ (declare (TopicC top name-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-name(): ") - (name-type-topic (get-item-by-psi *tm2rdf-name-type-uri* - :revision start-revision)) (ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type @@ -314,7 +318,7 @@ (map 'list #'(lambda(variant-top) (map-isi-variant name variant-top start-revision)) variant-topics) - (delete-instance-of-association name-top name-type-topic) + (delete-related-associations name-top) (d::delete-construct name-top) name))))) @@ -339,8 +343,6 @@ (declare (integer start-revision)) (let ((err-pref "From map-isi-occurrence(): ") (ids (map-isi-identifiers occ-top start-revision)) - (occurrence-type-topic (get-item-by-psi *tm2rdf-occurrence-type-uri* - :revision start-revision)) (type-assocs (get-associations-by-type occ-top start-revision *tm2rdf-occurrencetype-property* @@ -371,7 +373,7 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) - (delete-instance-of-association occ-top occurrence-type-topic) + (delete-related-associations occ-top) (d::delete-construct occ-top) (make-construct 'OccurrenceC :start-revision start-revision Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Tue Sep 8 04:51:36 2009 @@ -53,7 +53,8 @@ *tm2rdf-occurrencetype-property* *tm2rdf-roletype-property* *tm2rdf-player-property* - *tm2rdf-associationtype-property*) + *tm2rdf-associationtype-property* + *rdf2tm-blank-node-prefix*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) @@ -509,4 +510,4 @@ (list :topicid (get-type-of-node-name elem) :psi (get-type-of-node-name elem) :ID nil))) - (get-types-of-node-content elem tm-id xml-base))))) + (get-types-of-node-content elem tm-id xml-base))))) \ No newline at end of file From lgiessmann at common-lisp.net Tue Sep 8 10:54:19 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 08 Sep 2009 06:54:19 -0400 Subject: [isidorus-cvs] r137 - trunk/src/unit_tests Message-ID: Author: lgiessmann Date: Tue Sep 8 06:54:19 2009 New Revision: 137 Log: rdf-importer: added some unit-tests Modified: trunk/src/unit_tests/full_mapping.rdf trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 06:54:19 2009 @@ -31,7 +31,7 @@ - + @@ -121,13 +121,13 @@ http://simpsons/role-wife/ii - + http://simpsons/married/ii-1 http://simpsons/married/ii-2 - + http://simpsons/role-wife/ii @@ -135,7 +135,7 @@ - + Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Tue Sep 8 06:54:19 2009 @@ -66,7 +66,10 @@ :test-poems-rdf-topics :test-empty-collection :test-collection - :test-xml-base)) + :test-xml-base + :test-full-mapping-marge + :test-full-mapping-homer + :test-full-mapping-association)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -79,6 +82,14 @@ (in-suite rdf-importer-test) +(defun empty-p (top) + (declare (TopicC top)) + (and (not (d:item-identifiers top)) + (not (d:locators top)) + (not (d:names top)) + (not (d:occurrences top)))) + + (test test-get-literals-of-node "Tests the helper function get-literals-of-node." (let ((doc-1 @@ -3060,6 +3071,306 @@ "/test") "http://base-3/test"))))))) + +(test test-full-mapping-marge + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((firstName (get-item-by-id "http://simpsons/firstName")) + (lastName (get-item-by-id "http://simpsons/lastName")) + (display (get-item-by-id "http://simpsons/display")) + (profession (get-item-by-id "http://simpsons/profession")) + (married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (en (get-item-by-id "http://simpsons/en")) + (type (get-item-by-psi *type-psi*)) + (instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (isi-object (get-item-by-psi *rdf2tm-object*)) + (isi-subject (get-item-by-psi *rdf2tm-subject*)) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true firstName) + (is-true (empty-p firstName)) + (is-true lastName) + (is-true (empty-p lastName)) + (is-true display) + (is-true (empty-p display)) + (is-true profession) + (is-true (empty-p profession)) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true en) + (is-true (empty-p en)) + (is-true type) + (is-true (empty-p type)) + (is-true instance) + (is-true (empty-p instance)) + (is-true type-instance) + (is-true (empty-p type-instance)) + (is-true isi-object) + (is-true (empty-p isi-object)) + (is-true isi-subject) + (is-true (empty-p isi-subject)) + (is-true role-husband) + (is-true role-wife) + (is-true homer) + (is (= (length (d:psis marge)) 2)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/marjorie")) + (d:psis marge))) + (is (= (length (d:names marge)) 2)) + (let ((marge-fn (find-if #'(lambda(x) + (eql (instance-of x) firstName)) + (d:names marge))) + (marge-ln (find-if #'(lambda(x) + (eql (instance-of x) lastName)) + (d:names marge))) + (marge-occ (find-if #'(lambda(x) + (eql (instance-of x) profession)) + (d:occurrences marge)))) + (is-true marge-fn) + (is-true marge-ln) + (is (string= (d:charvalue marge-fn) "Marjorie")) + (is (string= (d:charvalue marge-ln) "Simpson")) + (is (= (length (d:variants marge-fn)) 1)) + (is (= (length (d:themes (first (d:variants marge-fn)))) 1)) + (is (eql (first (d:themes (first (d:variants marge-fn)))) display)) + (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge")) + (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*)) + (is-true marge-occ) + (is (string= (d:charvalue marge-occ) "Housewife")) + (is (string= (d:datatype marge-occ) *xml-string*)) + (is (= (length (d:themes marge-occ)) 0)) + (is (= (length (d:psis marge)) 2)))))) + + +(test test-full-mapping-homer + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((firstName (get-item-by-id "http://simpsons/firstName")) + (lastName (get-item-by-id "http://simpsons/lastName")) + (display (get-item-by-id "http://simpsons/display")) + (profession (get-item-by-id "http://simpsons/profession")) + (married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (en (get-item-by-id "http://simpsons/en")) + (type (get-item-by-psi *type-psi*)) + (instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (isi-object (get-item-by-psi *rdf2tm-object*)) + (isi-subject (get-item-by-psi *rdf2tm-subject*)) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true firstName) + (is-true (empty-p firstName)) + (is-true lastName) + (is-true (empty-p lastName)) + (is-true display) + (is-true (empty-p display)) + (is-true profession) + (is-true (empty-p profession)) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true en) + (is-true (empty-p en)) + (is-true type) + (is-true (empty-p type)) + (is-true instance) + (is-true (empty-p instance)) + (is-true type-instance) + (is-true (empty-p type-instance)) + (is-true isi-object) + (is-true (empty-p isi-object)) + (is-true isi-subject) + (is-true (empty-p isi-subject)) + (is-true role-husband) + (is-true role-wife) + (is-true marge) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/homer_simpson")) + (d:psis homer))) + (is (= (length (d:locators homer)) 1)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://some.where/resource")) + (d:locators homer))) + (is (= (length (d:item-identifiers homer)) 1)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/ii/homer")) + (d:item-identifiers homer))) + (is (= (length (d:names homer)) 2)) + (let ((homer-fn (find-if #'(lambda(x) + (eql (instance-of x) firstName)) + (d:names homer))) + (homer-ln (find-if #'(lambda(x) + (eql (instance-of x) lastName)) + (d:names homer))) + (homer-occ (find-if #'(lambda(x) + (eql (instance-of x) profession)) + (d:occurrences homer)))) + (is-true homer-fn) + (is-true homer-ln) + (is (string= (d:charvalue homer-fn) "Homer J.")) + (is (string= (d:charvalue homer-ln) "Simpson")) + (is (= (length (d:variants homer-fn)) 1)) + (is (= (length (d:themes (first (d:variants homer-fn)))) 1)) + (is (eql (first (d:themes (first (d:variants homer-fn)))) display)) + (is (string= (d:charvalue (first (d:variants homer-fn))) "Homer")) + (is (string= (d:datatype (first (d:variants homer-fn))) *xml-string*)) + (is-true homer-occ) + (is (string= (d:charvalue homer-occ) "Safety Inspector")) + (is (string= (d:datatype homer-occ) *xml-string*)) + (is (= (length (d:themes homer-occ)) 1)) + (is (eql (first (d:themes homer-occ)) en)))))) + + +(test test-full-mapping-association + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (assoc (first (elephant:get-instances-by-class 'd:AssociationC))) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true role-husband) + (is-true role-wife) + (is-true marge) + (is-true homer) + (is (= (length (intersection (list role-husband role-wife) + (d:roles assoc))) + 2)) + (is (eql (d:instance-of assoc) married)) + (is (= (length (d:item-identifiers assoc)) 2)) + (is (= (length + (intersection + (list + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-2")) + (d:item-identifiers assoc))) + 2)) + (is (eql (d:instance-of role-husband) husband)) + (is (eql (d:instance-of role-wife) wife)) + (is (eql (d:player role-husband) homer)) + (is (eql (d:player role-wife) marge)) + (is (= (length (d:item-identifiers role-husband)) 1)) + (is (= (length (d:item-identifiers role-wife)) 1)) + (is (string= (d:uri (first (d:item-identifiers role-husband))) + "http://simpsons/role-husband/ii")) + (is (string= (d:uri (first (d:item-identifiers role-wife))) + "http://simpsons/role-wife/ii"))))) + + (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3082,4 +3393,7 @@ (it.bese.fiveam:run! 'test-poems-rdf-topics) (it.bese.fiveam:run! 'test-empty-collection) (it.bese.fiveam:run! 'test-collection) - (it.bese.fiveam:run! 'test-xml-base)) \ No newline at end of file + (it.bese.fiveam:run! 'test-xml-base) + (it.bese.fiveam:run! 'test-full-mapping-marge) + (it.bese.fiveam:run! 'test-full-mapping-homer) + (it.bese.fiveam:run! 'test-full-mapping-association)) \ No newline at end of file Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Tue Sep 8 06:54:19 2009 @@ -30,7 +30,8 @@ :*atom_test.xtm* :*atom-conf.lisp* :*poems_light.rdf* - :*poems_light.xtm*)) + :*poems_light.xtm* + :*full_mapping.rdf*)) (in-package :unittests-constants) @@ -99,3 +100,7 @@ (defparameter *poems_light.xtm* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light.xtm"))) + +(defparameter *full_mapping.rdf* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "full_mapping.rdf"))) \ No newline at end of file From lgiessmann at common-lisp.net Tue Sep 8 13:37:27 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 08 Sep 2009 09:37:27 -0400 Subject: [isidorus-cvs] r138 - trunk/src/xml/rdf Message-ID: Author: lgiessmann Date: Tue Sep 8 09:37:26 2009 New Revision: 138 Log: rdf-importer: fixed a bug when importing rdf-isidorus-names without nametypes. Modified: trunk/src/xml/rdf/map_to_tm.lisp Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 09:37:26 2009 @@ -277,8 +277,7 @@ "Maps the passed occurrence-topic to a TM occurrence." (declare (TopicC top name-top)) (declare (integer start-revision)) - (let ((err-pref "From map-isi-name(): ") - (ids (map-isi-identifiers name-top start-revision)) + (let ((ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type name-top start-revision *tm2rdf-nametype-property* @@ -290,8 +289,11 @@ (value-type-topic (get-item-by-psi *tm2rdf-value-property*)) (variant-topics (get-isi-variants name-top start-revision))) - (let ((types (get-players-by-role-type - type-assocs start-revision *rdf2tm-object*)) + (let ((types (let ((fn-types + (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*))) + (when fn-types + (first fn-types)))) (scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value @@ -305,14 +307,11 @@ (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct type-assocs) (map 'list #'d::delete-construct scope-assocs) - (when (/= 1 (length types)) - (error "~aexpect one type topic but found: ~a (~a)" - err-pref (length types) value)) (let ((name (make-construct 'NameC :start-revision start-revision :topic top :charvalue value - :instance-of (first types) + :instance-of types :item-identifiers ids :themes scopes))) (map 'list #'(lambda(variant-top) From lgiessmann at common-lisp.net Wed Sep 9 07:42:01 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 09 Sep 2009 03:42:01 -0400 Subject: [isidorus-cvs] r139 - trunk/src/xml/rdf Message-ID: Author: lgiessmann Date: Wed Sep 9 03:42:00 2009 New Revision: 139 Log: rdf-importer: fixed a bug with xml:base and xml:lang; renamed some parameters for a better understanding Modified: trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 9 03:42:00 2009 @@ -84,31 +84,36 @@ (let ((children (child-nodes-or-text rdf-dom :trim t))) (when children (loop for child across children - do (import-node child tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang))) + do (import-node child tm-id start-revision + :document-id document-id + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) + (import-node rdf-dom tm-id start-revision + :document-id document-id + :parent-xml-base xml-base + :parent-xml-lang xml-lang))) (setf *_n-map* nil)) (defun import-node (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) + "Imports an RDF node with all its properties and 'child' RDF nodes." (tm-id-p tm-id "import-node") (parse-node elem) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))) - (let ((about (get-absolute-attribute elem tm-id xml-base "about")) - (nodeID (get-ns-attribute elem "nodeID")) - (ID (get-absolute-attribute elem tm-id xml-base "ID")) - (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) - (parse-properties-of-node elem (or about nodeID ID UUID)) - - (let ((literals (append (get-literals-of-node elem fn-xml-lang) + (let ((about (get-absolute-attribute elem tm-id parent-xml-base "about")) + (nodeID (get-ns-attribute elem "nodeID")) + (ID (get-absolute-attribute elem tm-id parent-xml-base "ID")) + (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) + (parse-properties-of-node elem (or about nodeID ID UUID)) + (let ((literals (append (get-literals-of-node elem parent-xml-lang) (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations (get-associations-of-node-content elem tm-id xml-base)) - (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) + elem tm-id parent-xml-base parent-xml-lang))) + (associations (get-associations-of-node-content elem tm-id + parent-xml-base)) + (types (get-types-of-node elem tm-id + :parent-xml-base parent-xml-base)) (super-classes - (get-super-classes-of-node-content elem tm-id xml-base))) + (get-super-classes-of-node-content elem tm-id parent-xml-base))) (with-tm (start-revision document-id tm-id) (let ((this (make-topic-stub @@ -124,19 +129,18 @@ start-revision :document-id document-id) (make-recursion-from-node elem tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) - this)))))) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) + this))))) (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Imports a property that is an blank_node and continues the recursion on this element." (declare (dom:element elem)) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) - (fn-xml-base (get-xml-base elem :old-base xml-base)) + (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (parseType (get-ns-attribute elem "parseType")) (content (child-nodes-or-text elem :trim t))) @@ -156,24 +160,26 @@ :revision start-revision))) (let ((literals (append (get-literals-of-property - elem fn-xml-lang) + elem xml-lang) (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) + elem tm-id parent-xml-base + parent-xml-lang))) (associations (get-associations-of-node-content - elem tm-id xml-base)) + elem tm-id parent-xml-base)) (types (remove-if #'null (append - (get-types-of-node-content elem tm-id fn-xml-base) + (get-types-of-node-content elem tm-id + parent-xml-base) (when (get-ns-attribute elem "type") (list :ID nil :topicid (get-ns-attribute elem "type") :psi (get-ns-attribute elem "type")))))) (super-classes (get-super-classes-of-node-content - elem tm-id xml-base))) + elem tm-id parent-xml-base))) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations this associations xml-importer::tm @@ -186,19 +192,20 @@ this))))) (make-recursion-from-arc elem tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) this-topic))))) (defun make-collection (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Creates a collection structure of a node that contains parseType='Collection." (declare (dom:element elem)) (with-tm (start-revision document-id tm-id) - (let ((fn-xml-base (get-xml-base elem :old-base xml-base)) - (fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) + (let ((xml-base (get-xml-base elem :old-base parent-xml-base)) + (xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (let ((this (make-topic-stub nil nil nil UUID start-revision xml-importer::tm @@ -206,8 +213,8 @@ (items (loop for item across (child-nodes-or-text elem :trim t) collect (import-node item tm-id start-revision :document-id document-id - :xml-base fn-xml-base - :xml-lang fn-xml-lang)))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) (let ((last-blank-node this)) (dotimes (index (length items)) (let ((is-end @@ -466,10 +473,6 @@ (when lang (let ((psi-and-topic-id (concatenate-uri *rdf2tm-scope-prefix* lang))) - ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id -; :revision start-revision))) -; (if top -; top (make-topic-stub psi-and-topic-id nil nil nil start-revision tm :document-id document-id)))) @@ -612,13 +615,13 @@ occurrence)))))) -(defun get-literals-of-node-content (node tm-id xml-base xml-lang) +(defun get-literals-of-node-content (node tm-id parent-xml-base parent-xml-lang) "Returns a list of literals that is produced of a node's content." (declare (dom:element node)) (tm-id-p tm-id "get-literals-of-noode-content") (let ((properties (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base)) - (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (xml-base (get-xml-base node :old-base parent-xml-base)) + (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) (let ((literals (when properties (loop for property across properties @@ -643,11 +646,11 @@ (string/= parseType "Resource"))) collect (let ((content (child-nodes-or-text property)) (ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (child-xml-lang - (get-xml-lang property :old-lang fn-xml-lang))) + (get-xml-lang property :old-lang xml-lang))) (let ((full-name (get-type-of-node-name property)) - (datatype (get-datatype property tm-id fn-xml-base)) + (datatype (get-datatype property tm-id xml-base)) (text (cond ((= (length content) 0) @@ -670,18 +673,18 @@ literals))) -(defun get-types-of-node-content (node tm-id xml-base) +(defun get-types-of-node-content (node tm-id parent-xml-base) "Returns a list of type-uris that corresponds to the node's content or attributes." (tm-id-p tm-id "get-types-of-node-content") - (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + (let ((xml-base (get-xml-base node :old-base parent-xml-base))) (let ((attr-type (if (get-ns-attribute node "type") (list (list :topicid (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + xml-base tm-id) :psi (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + xml-base tm-id) :ID nil)) nil)) (content-types @@ -691,17 +694,17 @@ (string= (get-node-name child) "type")) collect (let ((nodeID (get-ns-attribute child "nodeID")) (resource (get-absolute-attribute - child tm-id fn-xml-base "resource")) + child tm-id xml-base "resource")) (UUID (get-ns-attribute child "UUID" :ns-uri *rdf2tm-ns*)) (ID (get-absolute-attribute child tm-id - fn-xml-base "ID"))) + xml-base "ID"))) (if (or nodeID resource UUID) (list :topicid (or nodeID resource UUID) :psi resource :ID ID) (let ((child-xml-base - (get-xml-base child :old-base fn-xml-base))) + (get-xml-base child :old-base xml-base))) (let ((refs (get-node-refs (child-nodes-or-text child :trim t) @@ -712,9 +715,9 @@ (remove-if #'null (append attr-type content-types))))) -(defun get-literals-of-property (property xml-lang) +(defun get-literals-of-property (property parent-xml-lang) "Returns a list of attributes that are treated as literal nodes." - (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang)) + (let ((xml-lang (get-xml-lang property :old-lang parent-xml-lang)) (attributes nil)) (dom:map-node-map #'(lambda(attr) @@ -737,7 +740,7 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))) ((or (string= attr-ns *xml-ns*) @@ -749,16 +752,16 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))))))) (dom:attributes property)) attributes)) -(defun get-literals-of-node (node xml-lang) +(defun get-literals-of-node (node parent-xml-lang) "Returns alist of attributes that are treated as literal nodes." - (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang)) + (let ((xml-lang (get-xml-lang node :old-lang parent-xml-lang)) (attributes nil)) (dom:map-node-map #'(lambda(attr) @@ -777,7 +780,7 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))) ((or (string= attr-ns *xml-ns*) @@ -789,19 +792,19 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))))))) (dom:attributes node)) attributes)) -(defun get-super-classes-of-node-content (node tm-id xml-base) +(defun get-super-classes-of-node-content (node tm-id parent-xml-base) "Returns a list of super-classes and IDs." (declare (dom:element node)) (tm-id-p tm-id "get-super-classes-of-node-content") (let ((content (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base))) + (xml-base (get-xml-base node :old-base parent-xml-base))) (when content (loop for property across content when (let ((prop-name (get-node-name property)) @@ -809,13 +812,13 @@ (and (string= prop-name "subClassOf") (string= prop-ns *rdfs-ns*))) collect (let ((prop-xml-base (get-xml-base property - :old-base fn-xml-base))) + :old-base xml-base))) (let ((ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (nodeID (get-ns-attribute property "nodeID")) (resource (get-absolute-attribute property tm-id - fn-xml-base "resource")) + xml-base "resource")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*))) (if (or nodeID resource UUID) @@ -830,17 +833,17 @@ :ID ID))))))))) -(defun get-associations-of-node-content (node tm-id xml-base) +(defun get-associations-of-node-content (node tm-id parent-xml-base) "Returns a list of associations with a type, value and ID member." (declare (dom:element node)) (let ((properties (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base))) + (xml-base (get-xml-base node :old-base parent-xml-base))) (loop for property across properties when (let ((prop-name (get-node-name property)) (prop-ns (dom:namespace-uri property)) (prop-content (child-nodes-or-text property)) (resource (get-absolute-attribute property tm-id - fn-xml-base "resource")) + xml-base "resource")) (nodeID (get-ns-attribute property "nodeID")) (type (get-ns-attribute property "type")) (parseType (get-ns-attribute property "parseType")) @@ -858,7 +861,7 @@ (not (and (string= prop-name "subClassOf") (string= prop-ns *rdfs-ns*))))) collect (let ((prop-xml-base (get-xml-base property - :old-base fn-xml-base)) + :old-base xml-base)) (content (child-nodes-or-text property :trim t)) (parseType (get-ns-attribute property "parseType"))) (let ((resource @@ -866,12 +869,12 @@ (= (length content) 0)) *rdf-nil* (get-absolute-attribute property tm-id - fn-xml-base "resource"))) + xml-base "resource"))) (nodeID (get-ns-attribute property "nodeID")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*)) (ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (full-name (get-type-of-node-name property))) (if (or nodeID resource UUID) (list :type full-name @@ -889,42 +892,45 @@ (defun make-recursion-from-node (node tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Calls the next function that handles all DOM child elements of the passed element as arcs." (declare (dom:element node)) (let ((content (child-nodes-or-text node :trim t)) (err-pref "From make-recursion-from-node(): ") - (fn-xml-base (get-xml-base node :old-base xml-base)) - (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (xml-base (get-xml-base node :old-base parent-xml-base)) + (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) (when (stringp content) (error "~aliteral content not allowed here: ~a" err-pref content)) (loop for arc across content collect (import-arc arc tm-id start-revision :document-id document-id - :xml-base fn-xml-base :xml-lang fn-xml-lang)))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) (defun make-recursion-from-arc (arc tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Calls the next function that handles the arcs content nodes/arcs." (declare (dom:element arc)) - (let ((fn-xml-base (get-xml-base arc :old-base xml-base)) - (fn-xml-lang (get-xml-lang arc :old-lang xml-lang)) + (let ((xml-base (get-xml-base arc :old-base parent-xml-base)) + (xml-lang (get-xml-lang arc :old-lang parent-xml-lang)) (content (child-nodes-or-text arc)) (parseType (get-ns-attribute arc "parseType"))) - (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype")) - (type (get-absolute-attribute arc tm-id xml-base "type")) - (resource (get-absolute-attribute arc tm-id xml-base "resource")) + (let ((datatype (get-absolute-attribute arc tm-id + parent-xml-base "datatype")) + (type (get-absolute-attribute arc tm-id parent-xml-base "type")) + (resource (get-absolute-attribute arc tm-id + parent-xml-base "resource")) (nodeID (get-ns-attribute arc "nodeID")) - (literals (get-literals-of-property arc xml-lang))) + (literals (get-literals-of-property arc parent-xml-lang))) (if (and parseType (string= parseType "Collection")) (make-collection arc tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) (if (or datatype resource nodeID (and parseType (string= parseType "Literal")) @@ -938,10 +944,10 @@ (loop for item across content collect (import-arc item tm-id start-revision :document-id document-id - :xml-base fn-xml-base - :xml-lang fn-xml-lang)) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)) (loop for item across content collect (import-node item tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang)))))))) \ No newline at end of file + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))))))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 9 03:42:00 2009 @@ -282,21 +282,21 @@ t) -(defun get-node-refs (nodes tm-id xml-base) +(defun get-node-refs (nodes tm-id parent-xml-base) "Returns a list of node references that can be used as topic IDs." (when (and nodes (> (length nodes) 0)) (loop for node across nodes - collect (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + collect (let ((xml-base (get-xml-base node :old-base parent-xml-base))) (parse-node node) (let ((ID (when (get-ns-attribute node "ID") (absolutize-id (get-ns-attribute node "ID") - fn-xml-base tm-id))) + xml-base tm-id))) (nodeID (get-ns-attribute node "nodeID")) (about (when (get-ns-attribute node "about") (absolutize-value (get-ns-attribute node "about") - fn-xml-base tm-id))) + xml-base tm-id))) (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*))) (list :topicid (or ID about nodeID UUID) :psi (or ID about))))))) @@ -465,29 +465,28 @@ t) -(defun get-absolute-attribute (elem tm-id xml-base attr-name +(defun get-absolute-attribute (elem tm-id parent-xml-base attr-name &key (ns-uri *rdf-ns*)) "Returns an absolute 'attribute' or nil." (declare (dom:element elem)) (declare (string attr-name)) (tm-id-p tm-id "get-ID") (let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri)) - (fn-xml-base (get-xml-base elem :old-base xml-base))) + (xml-base (get-xml-base elem :old-base parent-xml-base))) (when attr (if (and (string= ns-uri *rdf-ns*) (string= attr-name "ID")) - (absolutize-id attr fn-xml-base tm-id) - (absolutize-value attr fn-xml-base tm-id))))) + (absolutize-id attr xml-base tm-id) + (absolutize-value attr xml-base tm-id))))) -(defun get-datatype (elem tm-id xml-base) +(defun get-datatype (elem tm-id parent-xml-base) "Returns a datatype value. The default is xml:string." - (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) - (let ((datatype - (get-absolute-attribute elem tm-id fn-xml-base "datatype"))) - (if datatype - datatype - *xml-string*)))) + (let ((datatype + (get-absolute-attribute elem tm-id parent-xml-base "datatype"))) + (if datatype + datatype + *xml-string*))) (defun tm-id-p (tm-id fun-name) @@ -500,14 +499,13 @@ (defun get-types-of-node (elem tm-id &key (parent-xml-base nil)) "Returns a plist of all node's types of the form (:topicid :psi :ID )." - (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) - (remove-if - #'null - (append (unless (string= (get-type-of-node-name elem) - (concatenate 'string *rdf-ns* - "Description")) - (list - (list :topicid (get-type-of-node-name elem) - :psi (get-type-of-node-name elem) - :ID nil))) - (get-types-of-node-content elem tm-id xml-base))))) \ No newline at end of file + (remove-if + #'null + (append (unless (string= (get-type-of-node-name elem) + (concatenate 'string *rdf-ns* + "Description")) + (list + (list :topicid (get-type-of-node-name elem) + :psi (get-type-of-node-name elem) + :ID nil))) + (get-types-of-node-content elem tm-id parent-xml-base)))) \ No newline at end of file From lgiessmann at common-lisp.net Wed Sep 9 07:56:23 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 09 Sep 2009 03:56:23 -0400 Subject: [isidorus-cvs] r140 - trunk/src/unit_tests Message-ID: Author: lgiessmann Date: Wed Sep 9 03:56:23 2009 New Revision: 140 Log: unit-tests: added functions of the for run--tests to all unit-tests without such a function -> consiteny Modified: trunk/src/unit_tests/atom_test.lisp trunk/src/unit_tests/versions_test.lisp Modified: trunk/src/unit_tests/atom_test.lisp ============================================================================== --- trunk/src/unit_tests/atom_test.lisp (original) +++ trunk/src/unit_tests/atom_test.lisp Wed Sep 9 03:56:23 2009 @@ -28,7 +28,9 @@ duplicate-identifier-error) (:export :atom-test :test-feed-to-string - :test-collection-configuration)) + :test-collection-configuration + :test-changes-feeds + :run-atom-tests)) ;test configuration (in-package :atom-test) @@ -204,3 +206,8 @@ (mapcar #'type-of collection-entries))) ))) + +(defun run-atom-tests() + (it.bese.fiveam:run! 'test-feed-to-string) + (it.bese.fiveam:run! 'test-changes-feeds) + (it.bese.fiveam:run! 'test-collection-configuration)) \ No newline at end of file Modified: trunk/src/unit_tests/versions_test.lisp ============================================================================== --- trunk/src/unit_tests/versions_test.lisp (original) +++ trunk/src/unit_tests/versions_test.lisp Wed Sep 9 03:56:23 2009 @@ -32,7 +32,7 @@ :test-change-lists :test-changed-p :versions-test - )) + :run-versions-tests)) (declaim (optimize (debug 3))) (in-package :versions-test) @@ -363,4 +363,12 @@ :revision (1+ fixtures::revision3)))))) - \ No newline at end of file + +(defun run-versions-tests() + (it.bese.fiveam:run! 'test-get-item-by-id-t100) + (it.bese.fiveam:run! 'test-get-item-by-id-t301) + (it.bese.fiveam:run! 'test-norwegian-curriculum-association) + (it.bese.fiveam:run! 'test-instance-of-t64) + (it.bese.fiveam:run! 'test-change-lists) + (it.bese.fiveam:run! 'test-changed-p) + (it.bese.fiveam:run! 'test-mark-as-deleted)) \ No newline at end of file From lgiessmann at common-lisp.net Thu Sep 10 10:12:48 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 10 Sep 2009 06:12:48 -0400 Subject: [isidorus-cvs] r141 - in trunk/src: model unit_tests Message-ID: Author: lgiessmann Date: Thu Sep 10 06:12:47 2009 New Revision: 141 Log: datamodel: added a 1:1 elephant-assocation to ReifiableConstructC and TopicC realizing reification; extended the functions delete-construct and initialize-instance of the affected classes Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/importer_test.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Thu Sep 10 06:12:47 2009 @@ -101,6 +101,8 @@ :variants :xor :create-latest-fragment-of-topic + :reified + :reifier :*current-xtm* ;; special variables :*TM-REVISION* @@ -372,11 +374,11 @@ (symbol-value '*TM-REVISION*)) (t 0))) (properties (slot-value construct slot-name))) - ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) + ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) (cond ((not properties) nil) ;if we don't have any properties, we don't have to worry - ;about revisions + ;about revisions ((= 0 revision) (remove nil @@ -599,26 +601,45 @@ :inherit t :documentation "Slot that realizes a 1 to N relation between reifiable constructs and their - identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")) + identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs") + (reifier + :associate TopicC + :inherit t + :documentation "Represents a reifier association to a topic, i.e. + it stands for a 1:1 association between this class and TopicC")) (:documentation "Reifiable constructs as per TMDM")) + +(defgeneric reifier (construct &key revision) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (when (slot-boundp construct 'reifier) + (filter-slot-value-by-revision construct 'reifier :start-revision revision)))) + +(defgeneric (setf reifier) (topic TopicC) + (:method (topic (construct ReifiableConstructC)) + (setf (slot-value construct 'reifier) topic) + (setf (reified topic) construct))) + (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) -(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil)) +(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil)) "adds associations to these ids after the instance was initialized." (declare (list item-identifiers)) (call-next-method) (dolist (id item-identifiers) (declare (ItemIdentifierC id)) (setf (identified-construct id) instance)) + (when reifier + (setf (reifier instance) reifier)) instance) - (defmethod delete-construct :before ((construct ReifiableConstructC)) (dolist (id (item-identifiers construct)) - (delete-construct id))) + (delete-construct id)) + (when (reifier construct) + (slot-makunbound (reifier construct) 'reified))) (defgeneric item-identifiers-p (constr) (:documentation "Test for the existence of item identifiers") @@ -928,9 +949,23 @@ (in-topicmaps :associate (TopicMapC topics) :many-to-many t - :documentation "list of all topic maps this topic is part of")) + :documentation "list of all topic maps this topic is part of") + (reified + :associate ReifiableConstructC + :documentation "contains a reified object, represented as 1:1 association")) (:documentation "Topic in a Topic Map")) + +(defgeneric reified (topic &key revision) + (:method ((topic TopicC) &key (revision *TM-REVISION*)) + (when (slot-boundp topic 'reified) + (filter-slot-value-by-revision topic 'reified :start-revision revision)))) + +(defgeneric (setf reified) (reifiable ReifiableConstructC) + (:method (reifiable (topic TopicC)) + (setf (slot-value topic 'reified) reifiable) + (setf (reifier reifiable) topic))) + (defgeneric occurrences (topic &key revision) (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'occurrences :start-revision revision))) @@ -966,19 +1001,21 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) -(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil)) +(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis)) (declare (list locators)) (call-next-method) - ;item-identifiers are handled in the around-method for ReifiableConstructs, - ;TopicIdentificationCs are handled in make-construct of TopicC + ;item-identifiers are handled in the around-method for ReifiableConstructs, + ;TopicIdentificationCs are handled in make-construct of TopicC (dolist (persistent-id psis) (declare (PersistentIdC persistent-id)) (setf (identified-construct persistent-id) instance)) (dolist (subject-locator locators) (declare (SubjectLocatorC subject-locator)) - (setf (identified-construct subject-locator) instance))) + (setf (identified-construct subject-locator) instance)) + (when reified + (setf (reified instance) reified))) (defmethod delete-construct :before ((construct TopicC)) @@ -993,7 +1030,9 @@ (dolist (theme (used-as-theme construct)) (elephant:remove-association construct 'used-as-theme theme)) (dolist (tm (in-topicmaps construct)) - (elephant:remove-association construct 'in-topicmaps tm))) + (elephant:remove-association construct 'in-topicmaps tm)) + (when (reified construct) + (slot-makunbound (reified construct) 'reifier))) (defun get-all-constructs-by-uri (uri) (delete Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Thu Sep 10 06:12:47 2009 @@ -662,6 +662,5 @@ ;as (importer-test:run-importer-tests) (defun run-importer-tests () (run! 'importer-test)) -;or (it.bese.fiveam.run! )