[isidorus-cvs] r125 - in trunk/src: . unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Aug 31 15:30:18 UTC 2009
Author: lgiessmann
Date: Mon Aug 31 11:30:16 2009
New Revision: 125
Log:
rdf-importer: added some helper functions to be able to recognize constructs that were imported by isidorus, e.g. isidorus:name, etc.
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 Mon Aug 31 11:30:16 2009
@@ -39,7 +39,19 @@
:*rdf2tm-object*
:*rdf2tm-subject*
:*rdf2tm-scope-prefix*
- :*tm2rdf-ns*))
+ :*tm2rdf-ns*
+ :*tm2rdf-topic-type-uri*
+ :*tm2rdf-name-type-uri*
+ :*tm2rdf-name-property*
+ :*tm2rdf-variant-type-uri*
+ :*tm2rdf-variant-property*
+ :*tm2rdf-occurrence-type-uri*
+ :*tm2rdf-occurrence-property*
+ :*tm2rdf-role-type-uri*
+ :*tm2rdf-role-property*
+ :*tm2rdf-association-type-uri*
+ :*tm2rdf-associaiton-property*))
+
(in-package :constants)
(defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/")
@@ -80,24 +92,46 @@
(defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/")
-(defparameter *rdf-statement* "http://www.w3.org/1999/02/22-rdf-syntax-ns#Statement")
+(defparameter *rdf-statement* (concatenate 'string *rdf-ns* "Statement"))
-(defparameter *rdf-object* "http://www.w3.org/1999/02/22-rdf-syntax-ns#object")
+(defparameter *rdf-object* (concatenate 'string *rdf-ns* "object"))
-(defparameter *rdf-subject* "http://www.w3.org/1999/02/22-rdf-syntax-ns#subject")
+(defparameter *rdf-subject* (concatenate 'string *rdf-ns* "subject"))
-(defparameter *rdf-predicate* "http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate")
+(defparameter *rdf-predicate* (concatenate 'string *rdf-ns* "predicate"))
-(defparameter *rdf-nil* "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")
+(defparameter *rdf-nil* (concatenate 'string *rdf-ns* "nil"))
-(defparameter *rdf-first* "http://www.w3.org/1999/02/22-rdf-syntax-ns#first")
+(defparameter *rdf-first* (concatenate 'string *rdf-ns* "first"))
-(defparameter *rdf-rest* "http://www.w3.org/1999/02/22-rdf-syntax-ns#rest")
+(defparameter *rdf-rest* (concatenate 'string *rdf-ns* "rest"))
-(defparameter *rdf2tm-object* "http://isidorus/rdf2tm_mapping/object")
+(defparameter *rdf2tm-object* (concatenate 'string *rdf2tm-ns* "object"))
-(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping/subject")
+(defparameter *rdf2tm-subject* (concatenate 'string *rdf2tm-ns* "subject"))
-(defparameter *rdf2tm-scope-prefix* "http://isidorus/rdf2tm_mapping/scope/")
+(defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/"))
-(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
\ No newline at end of file
+(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
+
+(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "Topic"))
+
+(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "Name"))
+
+(defparameter *tm2rdf-name-property* (concatenate 'string *tm2rdf-ns* "name"))
+
+(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "Variant"))
+
+(defparameter *tm2rdf-variant-property* (concatenate 'string *tm2rdf-ns* "variant"))
+
+(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "Occurrence"))
+
+(defparameter *tm2rdf-occurrence-property* (concatenate 'string *tm2rdf-ns* "occurrence"))
+
+(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "Role"))
+
+(defparameter *tm2rdf-role-property* (concatenate 'string *tm2rdf-ns* "role"))
+
+(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "Association"))
+
+(defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association"))
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 Mon Aug 31 11:30:16 2009
@@ -18,6 +18,7 @@
*rdf-ns*
*rdfs-ns*
*rdf2tm-ns*
+ *tm2rdf-ns*
*xml-ns*
*xml-string*
*instance-psi*
@@ -32,7 +33,13 @@
*rdf-subject*
*rdf-object*
*rdf-predicate*
- *rdf-statement*)
+ *rdf-statement*
+ *tm2rdf-topic-type-uri*
+ *tm2rdf-name-type-uri*
+ *tm2rdf-variant-type-uri*
+ *tm2rdf-occurrence-type-uri*
+ *tm2rdf-role-type-uri*
+ *tm2rdf-association-type-uri*)
(:import-from :xml-tools
xpath-child-elems-by-qname
xpath-single-child-elem-by-qname
@@ -59,7 +66,10 @@
:test-poems-rdf-topics
:test-empty-collection
:test-collection
- :test-xml-base))
+ :test-xml-base
+ :test-get-type-psis
+ :test-get-all-type-psis
+ :test-isidorus-type-p))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -3054,7 +3064,200 @@
"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 "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:sw=\"http://test/arcs/\">"
+ " <sw:Node rdf:about=\"http://sw/node\""
+ " rdf:type=\"http://sw/Node-1\">"
+ " <sw:type rdf:resource=\"anyResource\"/>"
+ " <rdf:type rdf:resource=\"Node-2\"/>"
+ " <rdf:type rdf:resource=\"http://sw/Node-3\"/>"
+ " <rdf:type rdf:nodeID=\"anyType\"/>"
+ " </sw:Node>"
+
+ " <rdf:Description rdf:about=\"http://sw/emtpy\"/>"
+ "</rdf:RDF>")))
+ (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 "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:sw=\"http://test/arcs/\">"
+ " <rdf:Description rdf:nodeID=\"anyNode\">"
+ " <rdf:type rdf:resource=\"http://type-1\"/>"
+ " <sw:arc>"
+ " <rdf:Description rdf:nodeID=\"anyNode\" "
+ " rdf:type=\"http://type-2\"/>"
+ " </sw:arc>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:nodeID=\"anotherNode\">"
+ " <rdf:type rdf:resource=\"http://type-3\"/>"
+ " </rdf:Description>"
+
+ " <sw:NodeType rdf:nodeID=\"anyNode\"/>"
+
+ " <rdf:Description rdf:nodeID=\"anyNode\" "
+ " rdf:datatype=\"anyDatatype\">"
+ " <rdf:type rdf:resource=\"http://type-7\"/>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:about=\"http://a-node\">"
+ " <sw:arc>"
+ " <rdf:Description rdf:about=\"http://b-node\">"
+ " <rdf:type rdf:resource=\"http://type-5\"/>"
+ " <rdf:arc>"
+ " <rdf:Description rdf:nodeID=\"anyNode\">"
+ " <rdf:type rdf:resource=\"http://type-5\"/>"
+ " <rdf:type rdf:resource=\"http://type-6\"/>"
+ " </rdf:Description>"
+ " </rdf:arc>"
+ " </rdf:Description>"
+ " </sw:arc>"
+ " </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)) 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 "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:sw=\"http://test/arcs/\" "
+ "xmlns:isi=\"" *tm2rdf-ns* "\">"
+ " <isi:Topic rdf:about=\"http://node-1\">"
+ " <isi:name>"
+ " <rdf:Description rdf:nodeID=\"name-id\"/>"
+ " </isi:name>"
+ " <isi:occurrence rdf:nodeID=\"occurrence-id\"/>"
+ " <isi:occurrence>"
+ " <rdf:Description>"
+ " <rdf:type rdf:resource=\""
+ *tm2rdf-occurrence-type-uri* "\"/>"
+ " </rdf:Description>"
+ " </isi:occurrence>"
+ " </isi:Topic>"
+
+ " <rdf:Description rdf:nodeID=\"name-id\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-name-type-uri*"\"/>"
+ " <isi:variant>"
+ " <isi:Variant rdf:nodeID=\"variant-id\"/>"
+ " </isi:variant>"
+ " </rdf:Description>"
+
+ " <isi:Occurrence rdf:nodeID=\"occurrence-id\"/>"
+
+ " <rdf:Description rdf:nodeID=\"association-id\">"
+ " <rdf:type rdf:resource=\""
+ *tm2rdf-association-type-uri* "\"/>"
+ " <isi:role>"
+ " <isi:Role rdf:nodeID=\"role-id\"/>"
+ " </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)) 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)))))))
+
+
(defun run-rdf-importer-tests()
+ "Runs all defined tests."
(when elephant:*store-controller*
(elephant:close-store))
(it.bese.fiveam:run! 'test-get-literals-of-node)
@@ -3075,4 +3278,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-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
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Mon Aug 31 11:30:16 2009
@@ -96,8 +96,7 @@
(format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove
(tm-id-p tm-id "import-node")
(parse-node elem)
- (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
- (fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
+ (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"))
@@ -108,16 +107,7 @@
(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 (list
- (unless (string= (get-type-of-node-name elem)
- (concatenate 'string *rdf-ns*
- "Description"))
- (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 fn-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)
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Mon Aug 31 11:30:16 2009
@@ -31,7 +31,18 @@
*rdf-nil*
*rdf-first*
*rdf-rest*
- *rdf2tm-scope-prefix*)
+ *rdf2tm-scope-prefix*
+ *tm2rdf-topic-type-uri*
+ *tm2rdf-name-type-uri*
+ *tm2rdf-name-property*
+ *tm2rdf-variant-type-uri*
+ *tm2rdf-variant-property*
+ *tm2rdf-occurrence-type-uri*
+ *tm2rdf-occurrence-property*
+ *tm2rdf-role-type-uri*
+ *tm2rdf-role-property*
+ *tm2rdf-association-type-uri*
+ *tm2rdf-association-property*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
@@ -369,8 +380,7 @@
datatype))
(when (and (or nodeID resource)
(> (length content) 0))
- ;(set-_n-name property _n-counter)))
- (error "~awhen ~a is set no content is allowed: ~a!"
+ (error "~awhen ~a is set no content is allowed: ~a!"
err-pref
(cond
(nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
@@ -469,4 +479,187 @@
"Checks the validity of the passed tm-id."
(unless (absolute-uri-p tm-id)
(error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!"
- fun-name tm-id)))
\ No newline at end of file
+ fun-name tm-id)))
+
+
+(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 <string> :psi <string> :ID <string>)."
+ (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)))))
+
+
+(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 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:<Type> and is
+ contained in a porperty isidorus:<type>."
+ (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*))
+ (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))))))))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list