[isidorus-cvs] r131 - in trunk/src: . unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Sep 3 14:57:43 UTC 2009
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 @@
" <sw:arc rdf:nodeID=\"node-id-4\"/>"
" </rdf:Description>"
" <sw:Node rdf:nodeID=\"node-id-4\" "
- " xml:base=\"http://base/\">"
+ " xml:base=\"http://base/\""
+ " xml:lang=\"de\">"
" <sw:arc>"
" <rdf:Description rdf:nodeID=\"node-id-1\" "
" xml:base=\"suffix\"/>"
@@ -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 "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ " xmlns:sw=\"http://test/arcs/\""
+ " xmlns:isi=\"" *tm2rdf-ns* "\">"
+ " <rdf:Description rdf:nodeID=\"association-1\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-association-type-uri* "\"/>"
+ " <isi:associationtype rdf:resource=\"http://associationtype-1\"/>"
+ " <isi:scope>"
+ " <rdf:Description rdf:about=\"http://scope-1\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-topic-type-uri* "\"/>"
+ " <isi:subjectLocator rdf:datatype=\"" *xml-uri* "\">http://sl-1</isi:subjectLocator>"
+ " <isi:subjectLocator rdf:datatype=\"" *xml-uri* "\">http://sl-2</isi:subjectLocator>"
+ " <isi:name rdf:parseType=\"Resource\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-name-type-uri* "\"/>"
+ " <isi:nametype rdf:resource=\"http://nametype-1\"/>"
+ " <isi:value rdf:datatype=\"" *xml-string* "\">value-1</isi:value>"
+ " <isi:scope rdf:parseType=\"Resource\">"
+ " <sw:arc rdf:parseType=\"Literal\">value-of-arc</sw:arc>"
+ " </isi:scope>"
+ " </isi:name>"
+ " </rdf:Description>"
+ " </isi:scope>"
+ " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-a1</isi:itemIdentity>"
+ " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-a2</isi:itemIdentity>"
+ " <isi:role rdf:nodeID=\"role-1\"/>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:nodeID=\"role-1\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-role-type-uri* "\"/>"
+ " <isi:player rdf:resource=\"http://player-1\"/>"
+ " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-3</isi:itemIdentity>"
+ " <isi:roletype rdf:nodeID=\"roletype-1\"/>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:nodeID=\"association-1\">"
+ " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-a1</isi:itemIdentity>"
+ " <isi:scope rdf:resource=\"http://scope-2\"/>"
+ " <isi:role rdf:parseType=\"Resource\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-role-type-uri* "\"/>"
+ " <isi:player rdf:nodeID=\"player-2\"/>"
+ " <isi:roletype rdf:resource=\"http://roletype-2\"/>"
+ " </isi:role>"
+ " <isi:role>"
+ " <rdf:Description rdf:nodeID=\"role-1\">"
+ " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-3</isi:itemIdentity>"
+ " </rdf:Description>"
+ " </isi:role>"
+ " </rdf:Description>"
+ "</rdf:RDF>")))
+ (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 <TopicC> :player <TopicC> :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 <dom:element> :xml-base <string>
+ :xml-lang <string>."
+ (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*)
More information about the Isidorus-cvs
mailing list