| 1 | ;;+----------------------------------------------------------------------------- |
|---|
| 2 | ;;+ Isidorus |
|---|
| 3 | ;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann |
|---|
| 4 | ;;+ |
|---|
| 5 | ;;+ Isidorus is freely distributable under the LGPL license. |
|---|
| 6 | ;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. |
|---|
| 7 | ;;+----------------------------------------------------------------------------- |
|---|
| 8 | (in-package :rdf-importer) |
|---|
| 9 | |
|---|
| 10 | (defun setup-rdf-module (rdf-xml-path repository-path |
|---|
| 11 | &key tm-id (document-id (get-uuid))) |
|---|
| 12 | "Sets up the data base by importing core_psis.xtm and |
|---|
| 13 | rdf_core_psis.xtm afterwards the file corresponding |
|---|
| 14 | to the give file path is imported." |
|---|
| 15 | (declare ((or pathname string) rdf-xml-path)) |
|---|
| 16 | (declare ((or pathname string) repository-path)) |
|---|
| 17 | (unless elephant:*store-controller* |
|---|
| 18 | (elephant:open-store |
|---|
| 19 | (get-store-spec repository-path))) |
|---|
| 20 | (xml-importer:init-isidorus) |
|---|
| 21 | (init-rdf-module) |
|---|
| 22 | (rdf-importer rdf-xml-path repository-path :tm-id tm-id |
|---|
| 23 | :document-id document-id) |
|---|
| 24 | (when elephant:*store-controller* |
|---|
| 25 | (elephant:close-store))) |
|---|
| 26 | |
|---|
| 27 | |
|---|
| 28 | (defun rdf-importer (rdf-xml-path repository-path |
|---|
| 29 | &key |
|---|
| 30 | (tm-id nil) |
|---|
| 31 | (document-id (get-uuid)) |
|---|
| 32 | (start-revision (d:get-revision))) |
|---|
| 33 | "Imports the file correponding to the given path." |
|---|
| 34 | (setf *document-id* document-id) |
|---|
| 35 | (tm-id-p tm-id "rdf-importer") |
|---|
| 36 | (with-writer-lock |
|---|
| 37 | (unless elephant:*store-controller* |
|---|
| 38 | (elephant:open-store |
|---|
| 39 | (get-store-spec repository-path))) |
|---|
| 40 | (let ((rdf-dom |
|---|
| 41 | (dom:document-element (cxml:parse-file |
|---|
| 42 | (truename rdf-xml-path) |
|---|
| 43 | (cxml-dom:make-dom-builder))))) |
|---|
| 44 | (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) |
|---|
| 45 | (map-to-tm tm-id start-revision :document-id document-id) |
|---|
| 46 | (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" |
|---|
| 47 | (length (elephant:get-instances-by-class 'TopicC)) |
|---|
| 48 | (length (elephant:get-instances-by-class 'AssociationC))) |
|---|
| 49 | (elephant:close-store) |
|---|
| 50 | (setf *_n-map* nil))) |
|---|
| 51 | |
|---|
| 52 | |
|---|
| 53 | (defun init-rdf-module (&optional (revision (get-revision))) |
|---|
| 54 | "Imports the file rdf_core_psis.xtm. core_psis.xtm has to be imported |
|---|
| 55 | before." |
|---|
| 56 | (with-writer-lock |
|---|
| 57 | (with-tm (revision "rdf.xtm" "http://isidorus/rdf2tm_mapping/rdf.xtm") |
|---|
| 58 | (let |
|---|
| 59 | ((core-dom |
|---|
| 60 | (cxml:parse-file *rdf_core_psis.xtm* (cxml-dom:make-dom-builder)))) |
|---|
| 61 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 62 | (loop for top-elem across |
|---|
| 63 | (xpath-child-elems-by-qname (dom:document-element core-dom) |
|---|
| 64 | *xtm2.0-ns* "topic") |
|---|
| 65 | do |
|---|
| 66 | (let |
|---|
| 67 | ((top |
|---|
| 68 | (from-topic-elem-to-stub top-elem revision |
|---|
| 69 | :xtm-id *rdf-core-xtm*))) |
|---|
| 70 | (add-to-tm xml-importer::tm top)))))))) |
|---|
| 71 | |
|---|
| 72 | |
|---|
| 73 | (defun import-dom (rdf-dom start-revision |
|---|
| 74 | &key (tm-id nil) (document-id *document-id*)) |
|---|
| 75 | "Imports the entire dom of an rdf-xml-file." |
|---|
| 76 | (setf *_n-map* nil) ;in case of an failed last call |
|---|
| 77 | (tm-id-p tm-id "import-dom") |
|---|
| 78 | (let ((xml-base (get-xml-base rdf-dom)) |
|---|
| 79 | (xml-lang (get-xml-lang rdf-dom)) |
|---|
| 80 | (elem-name (get-node-name rdf-dom)) |
|---|
| 81 | (elem-ns (dom:namespace-uri rdf-dom))) |
|---|
| 82 | (if (and (string= elem-ns *rdf-ns*) |
|---|
| 83 | (string= elem-name "RDF")) |
|---|
| 84 | (let ((children (child-nodes-or-text rdf-dom :trim t))) |
|---|
| 85 | (when children |
|---|
| 86 | (loop for child across children |
|---|
| 87 | do (import-node child tm-id start-revision |
|---|
| 88 | :document-id document-id |
|---|
| 89 | :parent-xml-base xml-base |
|---|
| 90 | :parent-xml-lang xml-lang)))) |
|---|
| 91 | (import-node rdf-dom tm-id start-revision |
|---|
| 92 | :document-id document-id |
|---|
| 93 | :parent-xml-base xml-base |
|---|
| 94 | :parent-xml-lang xml-lang))) |
|---|
| 95 | (setf *_n-map* nil)) |
|---|
| 96 | |
|---|
| 97 | |
|---|
| 98 | (defun import-node (elem tm-id start-revision &key (document-id *document-id*) |
|---|
| 99 | (parent-xml-base nil) (parent-xml-lang nil)) |
|---|
| 100 | "Imports an RDF node with all its properties and 'child' RDF nodes." |
|---|
| 101 | (tm-id-p tm-id "import-node") |
|---|
| 102 | (parse-node elem) |
|---|
| 103 | (let ((about (get-absolute-attribute elem tm-id parent-xml-base "about")) |
|---|
| 104 | (nodeID (get-ns-attribute elem "nodeID")) |
|---|
| 105 | (ID (get-absolute-attribute elem tm-id parent-xml-base "ID")) |
|---|
| 106 | (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) |
|---|
| 107 | (parse-properties-of-node elem (or about nodeID ID UUID)) |
|---|
| 108 | (let ((literals (append (get-literals-of-node elem parent-xml-lang) |
|---|
| 109 | (get-literals-of-node-content |
|---|
| 110 | elem tm-id parent-xml-base parent-xml-lang))) |
|---|
| 111 | (associations (get-associations-of-node-content elem tm-id |
|---|
| 112 | parent-xml-base)) |
|---|
| 113 | (types (get-types-of-node elem tm-id |
|---|
| 114 | :parent-xml-base parent-xml-base)) |
|---|
| 115 | (super-classes |
|---|
| 116 | (get-super-classes-of-node-content elem tm-id parent-xml-base))) |
|---|
| 117 | (with-tm (start-revision document-id tm-id) |
|---|
| 118 | (let ((this |
|---|
| 119 | (make-topic-stub |
|---|
| 120 | about ID nodeID UUID start-revision xml-importer::tm |
|---|
| 121 | :document-id document-id))) |
|---|
| 122 | (make-literals this literals tm-id start-revision |
|---|
| 123 | :document-id document-id) |
|---|
| 124 | (make-associations this associations xml-importer::tm |
|---|
| 125 | start-revision :document-id document-id) |
|---|
| 126 | (make-types this types xml-importer::tm start-revision |
|---|
| 127 | :document-id document-id) |
|---|
| 128 | (make-super-classes this super-classes xml-importer::tm |
|---|
| 129 | start-revision :document-id document-id) |
|---|
| 130 | (make-recursion-from-node elem tm-id start-revision |
|---|
| 131 | :document-id document-id |
|---|
| 132 | :parent-xml-base parent-xml-base |
|---|
| 133 | :parent-xml-lang parent-xml-lang) |
|---|
| 134 | this))))) |
|---|
| 135 | |
|---|
| 136 | |
|---|
| 137 | (defun import-arc (elem tm-id start-revision |
|---|
| 138 | &key (document-id *document-id*) |
|---|
| 139 | (parent-xml-base nil) (parent-xml-lang nil)) |
|---|
| 140 | "Imports a property that is a blank_node and continues the recursion |
|---|
| 141 | on this element." |
|---|
| 142 | (declare (dom:element elem)) |
|---|
| 143 | (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) |
|---|
| 144 | (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) |
|---|
| 145 | (parseType (get-ns-attribute elem "parseType")) |
|---|
| 146 | (content (child-nodes-or-text elem :trim t))) |
|---|
| 147 | (with-tm (start-revision document-id tm-id) |
|---|
| 148 | (if (and (string= parseType "Collection") |
|---|
| 149 | (= (length content) 0)) |
|---|
| 150 | (make-topic-stub *rdf-nil* nil nil nil start-revision |
|---|
| 151 | xml-importer::tm :document-id document-id) |
|---|
| 152 | (let ((this-topic |
|---|
| 153 | (when (or (not parseType) |
|---|
| 154 | (and parseType |
|---|
| 155 | (string/= parseType "Collection"))) |
|---|
| 156 | (when UUID |
|---|
| 157 | (parse-properties-of-node elem UUID) |
|---|
| 158 | (let ((this |
|---|
| 159 | (get-item-by-id UUID :xtm-id document-id |
|---|
| 160 | :revision start-revision))) |
|---|
| 161 | (let ((literals |
|---|
| 162 | (append (get-literals-of-property |
|---|
| 163 | elem xml-lang) |
|---|
| 164 | (get-literals-of-node-content |
|---|
| 165 | elem tm-id parent-xml-base |
|---|
| 166 | parent-xml-lang))) |
|---|
| 167 | (associations |
|---|
| 168 | (get-associations-of-node-content |
|---|
| 169 | elem tm-id parent-xml-base)) |
|---|
| 170 | (types |
|---|
| 171 | (remove-if |
|---|
| 172 | #'null |
|---|
| 173 | (append |
|---|
| 174 | (get-types-of-node-content elem tm-id |
|---|
| 175 | parent-xml-base) |
|---|
| 176 | (when (get-ns-attribute elem "type") |
|---|
| 177 | (list :ID nil |
|---|
| 178 | :topicid (get-ns-attribute elem "type") |
|---|
| 179 | :psi (get-ns-attribute elem "type")))))) |
|---|
| 180 | (super-classes |
|---|
| 181 | (get-super-classes-of-node-content |
|---|
| 182 | elem tm-id parent-xml-base))) |
|---|
| 183 | (make-literals this literals tm-id start-revision |
|---|
| 184 | :document-id document-id) |
|---|
| 185 | (make-associations this associations xml-importer::tm |
|---|
| 186 | start-revision :document-id document-id) |
|---|
| 187 | (make-types this types xml-importer::tm start-revision |
|---|
| 188 | :document-id document-id) |
|---|
| 189 | (make-super-classes |
|---|
| 190 | this super-classes xml-importer::tm |
|---|
| 191 | start-revision :document-id document-id)) |
|---|
| 192 | this))))) |
|---|
| 193 | (make-recursion-from-arc elem tm-id start-revision |
|---|
| 194 | :document-id document-id |
|---|
| 195 | :parent-xml-base parent-xml-base |
|---|
| 196 | :parent-xml-lang parent-xml-lang) |
|---|
| 197 | this-topic))))) |
|---|
| 198 | |
|---|
| 199 | |
|---|
| 200 | (defun make-collection (elem tm-id start-revision |
|---|
| 201 | &key (document-id *document-id*) |
|---|
| 202 | (parent-xml-base nil) (parent-xml-lang nil)) |
|---|
| 203 | "Creates a collection structure of a node that contains |
|---|
| 204 | parseType='Collection." |
|---|
| 205 | (declare (dom:element elem)) |
|---|
| 206 | (with-tm (start-revision document-id tm-id) |
|---|
| 207 | (let ((xml-base (get-xml-base elem :old-base parent-xml-base)) |
|---|
| 208 | (xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) |
|---|
| 209 | (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) |
|---|
| 210 | (let ((this (make-topic-stub nil nil nil UUID start-revision |
|---|
| 211 | xml-importer::tm |
|---|
| 212 | :document-id document-id)) |
|---|
| 213 | (items (loop for item across (child-nodes-or-text elem :trim t) |
|---|
| 214 | collect (import-node item tm-id start-revision |
|---|
| 215 | :document-id document-id |
|---|
| 216 | :parent-xml-base xml-base |
|---|
| 217 | :parent-xml-lang xml-lang)))) |
|---|
| 218 | (let ((last-blank-node this)) |
|---|
| 219 | (dotimes (index (length items)) |
|---|
| 220 | (let ((is-end |
|---|
| 221 | (if (= index (- (length items) 1)) |
|---|
| 222 | t |
|---|
| 223 | nil))) |
|---|
| 224 | (let ((new-blank-node |
|---|
| 225 | (make-collection-association |
|---|
| 226 | last-blank-node (elt items index) tm-id start-revision |
|---|
| 227 | :is-end is-end :document-id document-id))) |
|---|
| 228 | (setf last-blank-node new-blank-node))))))))) |
|---|
| 229 | |
|---|
| 230 | |
|---|
| 231 | (defun make-collection-association (current-blank-node first-object tm-id |
|---|
| 232 | start-revision &key (is-end nil) |
|---|
| 233 | (document-id *document-id*)) |
|---|
| 234 | "Creates a 'first'-association between the current-blank-node and the |
|---|
| 235 | first-object. If is-end is set to true another association between |
|---|
| 236 | current-blank-node and the topic rdf:nil is created. Otherwise this |
|---|
| 237 | associaiton is made from the current-blank-node to a new created blank |
|---|
| 238 | node." |
|---|
| 239 | (declare (d:TopicC current-blank-node first-object)) |
|---|
| 240 | (with-tm (start-revision document-id tm-id) |
|---|
| 241 | (let ((first-arc |
|---|
| 242 | (make-topic-stub *rdf-first* nil nil nil start-revision |
|---|
| 243 | xml-importer::tm :document-id document-id)) |
|---|
| 244 | (rest-arc |
|---|
| 245 | (make-topic-stub *rdf-rest* nil nil nil start-revision |
|---|
| 246 | xml-importer::tm :document-id document-id))) |
|---|
| 247 | (make-association-with-nodes current-blank-node first-object first-arc |
|---|
| 248 | xml-importer::tm start-revision |
|---|
| 249 | :document-id document-id) |
|---|
| 250 | (if is-end |
|---|
| 251 | (let ((rdf-nil (make-topic-stub *rdf-nil* nil nil nil |
|---|
| 252 | start-revision xml-importer::tm |
|---|
| 253 | :document-id document-id))) |
|---|
| 254 | (make-association-with-nodes |
|---|
| 255 | current-blank-node rdf-nil rest-arc xml-importer::tm |
|---|
| 256 | start-revision :document-id document-id) |
|---|
| 257 | nil) |
|---|
| 258 | (let ((new-blank-node (make-topic-stub |
|---|
| 259 | nil nil nil (get-uuid) start-revision |
|---|
| 260 | xml-importer::tm :document-id document-id))) |
|---|
| 261 | (make-association-with-nodes |
|---|
| 262 | current-blank-node new-blank-node rest-arc xml-importer::tm |
|---|
| 263 | start-revision :document-id document-id) |
|---|
| 264 | new-blank-node))))) |
|---|
| 265 | |
|---|
| 266 | |
|---|
| 267 | (defun make-literals (owner-top literals tm-id start-revision |
|---|
| 268 | &key (document-id *document-id*)) |
|---|
| 269 | "Creates Topic Maps constructs (occurrences) of the passed |
|---|
| 270 | named list literals related to the topic owner-top." |
|---|
| 271 | (declare (d:TopicC owner-top)) |
|---|
| 272 | (map 'list #'(lambda(literal) |
|---|
| 273 | (make-occurrence owner-top literal start-revision |
|---|
| 274 | tm-id :document-id document-id)) |
|---|
| 275 | literals)) |
|---|
| 276 | |
|---|
| 277 | |
|---|
| 278 | (defun make-associations (owner-top associations tm start-revision |
|---|
| 279 | &key (document-id *document-id*)) |
|---|
| 280 | "Creates Topic Maps constructs (assocaitions) of the passed |
|---|
| 281 | named list literals related to the topic owner-top." |
|---|
| 282 | (declare (d:TopicC owner-top)) |
|---|
| 283 | (map 'list #'(lambda(assoc) |
|---|
| 284 | (make-association owner-top assoc tm |
|---|
| 285 | start-revision |
|---|
| 286 | :document-id document-id)) |
|---|
| 287 | associations)) |
|---|
| 288 | |
|---|
| 289 | |
|---|
| 290 | (defun make-types (owner-top types tm start-revision |
|---|
| 291 | &key (document-id *document-id*)) |
|---|
| 292 | "Creates instance-of associations corresponding to the passed |
|---|
| 293 | topic owner-top and the passed types." |
|---|
| 294 | (declare (d:TopicC owner-top)) |
|---|
| 295 | (map 'list |
|---|
| 296 | #'(lambda(type) |
|---|
| 297 | (let ((type-topic |
|---|
| 298 | (make-topic-stub (getf type :psi) |
|---|
| 299 | nil |
|---|
| 300 | (getf type :topicid) |
|---|
| 301 | nil start-revision tm |
|---|
| 302 | :document-id document-id)) |
|---|
| 303 | (ID (getf type :ID))) |
|---|
| 304 | (make-instance-of-association owner-top type-topic |
|---|
| 305 | ID start-revision tm |
|---|
| 306 | :document-id document-id))) |
|---|
| 307 | types)) |
|---|
| 308 | |
|---|
| 309 | |
|---|
| 310 | (defun make-super-classes (owner-top super-classes tm start-revision |
|---|
| 311 | &key (document-id *document-id*)) |
|---|
| 312 | "Creates supertype-subtype associations corresponding to the passed |
|---|
| 313 | topic owner-top and the passed super classes." |
|---|
| 314 | (declare (d:TopicC owner-top)) |
|---|
| 315 | (map 'list |
|---|
| 316 | #'(lambda(class) |
|---|
| 317 | (let ((class-topic |
|---|
| 318 | (make-topic-stub (getf class :psi) |
|---|
| 319 | nil |
|---|
| 320 | (getf class :topicid) |
|---|
| 321 | nil start-revision tm |
|---|
| 322 | :document-id document-id)) |
|---|
| 323 | (ID (getf class :ID))) |
|---|
| 324 | (make-supertype-subtype-association |
|---|
| 325 | owner-top class-topic ID start-revision tm |
|---|
| 326 | :document-id document-id))) |
|---|
| 327 | super-classes)) |
|---|
| 328 | |
|---|
| 329 | |
|---|
| 330 | (defun make-supertype-subtype-association (sub-top super-top reifier-id |
|---|
| 331 | start-revision tm |
|---|
| 332 | &key (document-id *document-id*)) |
|---|
| 333 | "Creates an supertype-subtype association." |
|---|
| 334 | (declare (TopicC sub-top super-top)) |
|---|
| 335 | (declare (TopicMapC tm)) |
|---|
| 336 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 337 | (let ((assoc-type |
|---|
| 338 | (make-topic-stub *supertype-subtype-psi* nil nil nil |
|---|
| 339 | start-revision tm :document-id document-id)) |
|---|
| 340 | (role-type-1 |
|---|
| 341 | (make-topic-stub *supertype-psi* nil nil nil |
|---|
| 342 | start-revision tm :document-id document-id)) |
|---|
| 343 | (role-type-2 |
|---|
| 344 | (make-topic-stub *subtype-psi* nil nil nil |
|---|
| 345 | start-revision tm :document-id document-id)) |
|---|
| 346 | (err-pref "From make-supertype-subtype-association(): ")) |
|---|
| 347 | (unless assoc-type |
|---|
| 348 | (error "~athe association type ~a is missing!" |
|---|
| 349 | err-pref *supertype-subtype-psi*)) |
|---|
| 350 | (unless (or role-type-1 role-type-2) |
|---|
| 351 | (error "~aone of the role types ~a ~a is missing!" |
|---|
| 352 | err-pref *supertype-psi* *subtype-psi*)) |
|---|
| 353 | (let ((a-roles (list (list :instance-of role-type-1 |
|---|
| 354 | :player super-top |
|---|
| 355 | :start-revision start-revision) |
|---|
| 356 | (list :instance-of role-type-2 |
|---|
| 357 | :player sub-top |
|---|
| 358 | :start-revision start-revision)))) |
|---|
| 359 | (let ((assoc |
|---|
| 360 | (add-to-tm |
|---|
| 361 | tm |
|---|
| 362 | (make-construct 'AssociationC |
|---|
| 363 | :start-revision start-revision |
|---|
| 364 | :instance-of assoc-type |
|---|
| 365 | :roles a-roles)))) |
|---|
| 366 | (when reifier-id |
|---|
| 367 | (make-reification reifier-id assoc start-revision tm |
|---|
| 368 | :document-id document-id)) |
|---|
| 369 | (format t "a") |
|---|
| 370 | assoc))))) |
|---|
| 371 | |
|---|
| 372 | |
|---|
| 373 | (defun make-instance-of-association (instance-top type-top reifier-id |
|---|
| 374 | start-revision tm |
|---|
| 375 | &key (document-id *document-id*)) |
|---|
| 376 | "Creates and returns an instance-of association." |
|---|
| 377 | (declare (TopicC type-top instance-top)) |
|---|
| 378 | (declare (TopicMapC tm)) |
|---|
| 379 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 380 | (let ((assoc-type |
|---|
| 381 | (make-topic-stub *type-instance-psi* nil nil nil |
|---|
| 382 | start-revision tm :document-id document-id)) |
|---|
| 383 | (roletype-1 |
|---|
| 384 | (make-topic-stub *type-psi* nil nil nil |
|---|
| 385 | start-revision tm :document-id document-id)) |
|---|
| 386 | (roletype-2 |
|---|
| 387 | (make-topic-stub *instance-psi* nil nil nil |
|---|
| 388 | start-revision tm :document-id document-id)) |
|---|
| 389 | (err-pref "From make-instance-of-association(): ")) |
|---|
| 390 | (unless assoc-type |
|---|
| 391 | (error "~athe association type ~a is missing!" |
|---|
| 392 | err-pref *type-instance-psi*)) |
|---|
| 393 | (unless (or roletype-1 roletype-2) |
|---|
| 394 | (error "~aone of the role types ~a ~a is missing!" |
|---|
| 395 | err-pref *type-psi* *instance-psi*)) |
|---|
| 396 | (let ((a-roles (list (list :instance-of roletype-1 |
|---|
| 397 | :player type-top |
|---|
| 398 | :start-revision start-revision) |
|---|
| 399 | (list :instance-of roletype-2 |
|---|
| 400 | :player instance-top |
|---|
| 401 | :start-revision start-revision)))) |
|---|
| 402 | (let ((assoc |
|---|
| 403 | (add-to-tm |
|---|
| 404 | tm |
|---|
| 405 | (make-construct 'AssociationC |
|---|
| 406 | :start-revision start-revision |
|---|
| 407 | :instance-of assoc-type |
|---|
| 408 | :roles a-roles)))) |
|---|
| 409 | (when reifier-id |
|---|
| 410 | (make-reification reifier-id assoc start-revision tm |
|---|
| 411 | :document-id document-id)) |
|---|
| 412 | (format t "a") |
|---|
| 413 | assoc))))) |
|---|
| 414 | |
|---|
| 415 | |
|---|
| 416 | (defun make-topic-stub (about ID nodeId UUID start-revision |
|---|
| 417 | tm &key (document-id *document-id*)) |
|---|
| 418 | "Returns a topic corresponding to the passed parameters. |
|---|
| 419 | When the searched topic does not exist there will be created one. |
|---|
| 420 | If about or ID is set there will also be created a new PSI." |
|---|
| 421 | (declare (TopicMapC tm)) |
|---|
| 422 | (let ((topic-id (or about ID nodeID UUID)) |
|---|
| 423 | (psi-uri (or about ID)) |
|---|
| 424 | (ii-uri (unless (or about ID) |
|---|
| 425 | (concatenate 'string *rdf2tm-blank-node-prefix* |
|---|
| 426 | (or nodeID UUID))))) |
|---|
| 427 | (let ((top (get-item-by-id topic-id :xtm-id document-id |
|---|
| 428 | :revision start-revision))) |
|---|
| 429 | (if top |
|---|
| 430 | (progn |
|---|
| 431 | (d::add-to-version-history top :start-revision start-revision) |
|---|
| 432 | top) |
|---|
| 433 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 434 | (let ((psis (when psi-uri |
|---|
| 435 | (list |
|---|
| 436 | (make-construct 'PersistentIdC |
|---|
| 437 | :uri psi-uri |
|---|
| 438 | :start-revision start-revision)))) |
|---|
| 439 | (iis (when ii-uri |
|---|
| 440 | (list |
|---|
| 441 | (make-construct 'ItemIdentifierC |
|---|
| 442 | :uri ii-uri |
|---|
| 443 | :start-revision start-revision)))) |
|---|
| 444 | (topic-ids (when topic-id |
|---|
| 445 | (list |
|---|
| 446 | (make-construct 'TopicIdentificationC |
|---|
| 447 | :uri topic-id |
|---|
| 448 | :xtm-id document-id |
|---|
| 449 | :start-revision start-revision))))) |
|---|
| 450 | (handler-case (let ((top |
|---|
| 451 | (add-to-tm |
|---|
| 452 | tm |
|---|
| 453 | (make-construct |
|---|
| 454 | 'TopicC |
|---|
| 455 | :topic-identifiers topic-ids |
|---|
| 456 | :psis psis |
|---|
| 457 | :item-identifiers iis |
|---|
| 458 | :xtm-id document-id |
|---|
| 459 | :start-revision start-revision)))) |
|---|
| 460 | (format t "t") |
|---|
| 461 | top) |
|---|
| 462 | (Condition (err)(error "Creating topic ~a failed: ~a" |
|---|
| 463 | topic-id err))))))))) |
|---|
| 464 | |
|---|
| 465 | |
|---|
| 466 | (defun make-lang-topic (lang start-revision tm |
|---|
| 467 | &key (document-id *document-id*)) |
|---|
| 468 | "Returns a topic with the topicid tm-id/lang. If no such topic exist |
|---|
| 469 | there will be created one." |
|---|
| 470 | (when lang |
|---|
| 471 | (let ((psi-and-topic-id |
|---|
| 472 | (concatenate-uri *rdf2tm-scope-prefix* lang))) |
|---|
| 473 | (make-topic-stub psi-and-topic-id nil nil nil start-revision |
|---|
| 474 | tm :document-id document-id)))) |
|---|
| 475 | |
|---|
| 476 | |
|---|
| 477 | (defun make-association (top association tm start-revision |
|---|
| 478 | &key (document-id *document-id*)) |
|---|
| 479 | "Creates an association depending on the given parameters and |
|---|
| 480 | returns the elephat-associaton object." |
|---|
| 481 | (declare (TopicC top)) |
|---|
| 482 | (declare (TopicMapC tm)) |
|---|
| 483 | (let ((type (getf association :type)) |
|---|
| 484 | (player-id (getf association :topicid)) |
|---|
| 485 | (player-psi (getf association :psi)) |
|---|
| 486 | (ID (getf association :ID))) |
|---|
| 487 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 488 | (let ((player-1 (make-topic-stub player-psi nil player-id nil |
|---|
| 489 | start-revision |
|---|
| 490 | tm :document-id document-id)) |
|---|
| 491 | (role-type-1 |
|---|
| 492 | (make-topic-stub *rdf2tm-object* nil nil nil |
|---|
| 493 | start-revision tm :document-id document-id)) |
|---|
| 494 | (role-type-2 |
|---|
| 495 | (make-topic-stub *rdf2tm-subject* nil nil nil |
|---|
| 496 | start-revision tm :document-id document-id)) |
|---|
| 497 | (type-top (make-topic-stub type nil nil nil start-revision |
|---|
| 498 | tm :document-id document-id))) |
|---|
| 499 | (let ((roles (list (list :instance-of role-type-1 |
|---|
| 500 | :player player-1 |
|---|
| 501 | :start-revision start-revision) |
|---|
| 502 | (list :instance-of role-type-2 |
|---|
| 503 | :player top |
|---|
| 504 | :start-revision start-revision)))) |
|---|
| 505 | (let ((assoc |
|---|
| 506 | (add-to-tm tm (make-construct 'AssociationC |
|---|
| 507 | :start-revision start-revision |
|---|
| 508 | :instance-of type-top |
|---|
| 509 | :roles roles)))) |
|---|
| 510 | (when ID |
|---|
| 511 | (make-reification ID assoc start-revision tm |
|---|
| 512 | :document-id document-id)) |
|---|
| 513 | (format t "a") |
|---|
| 514 | assoc)))))) |
|---|
| 515 | |
|---|
| 516 | |
|---|
| 517 | (defun make-association-with-nodes (subject-topic object-topic |
|---|
| 518 | associationtype-topic tm start-revision |
|---|
| 519 | &key (document-id *document-id*)) |
|---|
| 520 | "Creates an association with two roles that contains the given players." |
|---|
| 521 | (declare (TopicC subject-topic object-topic associationtype-topic)) |
|---|
| 522 | (declare (TopicMapC tm)) |
|---|
| 523 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 524 | (let ((role-type-1 |
|---|
| 525 | (make-topic-stub *rdf2tm-subject* nil nil nil start-revision |
|---|
| 526 | tm :document-id document-id)) |
|---|
| 527 | (role-type-2 |
|---|
| 528 | (make-topic-stub *rdf2tm-object* nil nil nil start-revision |
|---|
| 529 | tm :document-id document-id))) |
|---|
| 530 | (let ((roles (list (list :instance-of role-type-1 |
|---|
| 531 | :player subject-topic |
|---|
| 532 | :start-revision start-revision) |
|---|
| 533 | (list :instance-of role-type-2 |
|---|
| 534 | :player object-topic |
|---|
| 535 | :start-revision start-revision)))) |
|---|
| 536 | (let ((assoc |
|---|
| 537 | (add-to-tm |
|---|
| 538 | tm (make-construct 'AssociationC |
|---|
| 539 | :start-revision start-revision |
|---|
| 540 | :instance-of associationtype-topic |
|---|
| 541 | :roles roles)))) |
|---|
| 542 | (format t "a") |
|---|
| 543 | assoc))))) |
|---|
| 544 | |
|---|
| 545 | |
|---|
| 546 | |
|---|
| 547 | (defun make-reification(reifier-id reifiable-construct start-revision tm &key |
|---|
| 548 | (document-id *document-id*)) |
|---|
| 549 | (declare (string reifier-id)) |
|---|
| 550 | (declare (ReifiableConstructC reifiable-construct)) |
|---|
| 551 | (declare (TopicMapC tm)) |
|---|
| 552 | (let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm |
|---|
| 553 | :document-id document-id))) |
|---|
| 554 | (add-reifier reifiable-construct reifier-topic :revision start-revision))) |
|---|
| 555 | |
|---|
| 556 | |
|---|
| 557 | (defun make-occurrence (top literal start-revision tm-id |
|---|
| 558 | &key (document-id *document-id*)) |
|---|
| 559 | "Creates an accorrence from the literal list and returns |
|---|
| 560 | the created elephant-occurrence-object." |
|---|
| 561 | (declare (TopicC top)) |
|---|
| 562 | (tm-id-p tm-id "make-occurrence") |
|---|
| 563 | (with-tm (start-revision document-id tm-id) |
|---|
| 564 | (let ((type (getf literal :type)) |
|---|
| 565 | (value (getf literal :value)) |
|---|
| 566 | (lang (getf literal :lang)) |
|---|
| 567 | (datatype (getf literal :datatype)) |
|---|
| 568 | (ID (getf literal :ID))) |
|---|
| 569 | (elephant:ensure-transaction (:txn-nosync t) |
|---|
| 570 | (let ((type-top (make-topic-stub type nil nil nil start-revision |
|---|
| 571 | xml-importer::tm |
|---|
| 572 | :document-id document-id)) |
|---|
| 573 | (lang-top (make-lang-topic lang start-revision |
|---|
| 574 | xml-importer::tm |
|---|
| 575 | :document-id document-id))) |
|---|
| 576 | (let ((occurrence |
|---|
| 577 | (make-construct 'OccurrenceC |
|---|
| 578 | :start-revision start-revision |
|---|
| 579 | :parent top |
|---|
| 580 | :themes (when lang-top |
|---|
| 581 | (list lang-top)) |
|---|
| 582 | :instance-of type-top |
|---|
| 583 | :charvalue value |
|---|
| 584 | :datatype datatype))) |
|---|
| 585 | (when ID |
|---|
| 586 | (make-reification ID occurrence start-revision xml-importer::tm |
|---|
| 587 | :document-id document-id)) |
|---|
| 588 | occurrence)))))) |
|---|
| 589 | |
|---|
| 590 | |
|---|
| 591 | (defun get-literals-of-node-content (node tm-id parent-xml-base parent-xml-lang) |
|---|
| 592 | "Returns a list of literals that is produced of a node's content." |
|---|
| 593 | (declare (dom:element node)) |
|---|
| 594 | (tm-id-p tm-id "get-literals-of-noode-content") |
|---|
| 595 | (let ((properties (child-nodes-or-text node :trim t)) |
|---|
| 596 | (xml-base (get-xml-base node :old-base parent-xml-base)) |
|---|
| 597 | (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) |
|---|
| 598 | (let ((literals |
|---|
| 599 | (when properties |
|---|
| 600 | (loop for property across properties |
|---|
| 601 | when (let ((datatype (get-ns-attribute property "datatype")) |
|---|
| 602 | (parseType (get-ns-attribute property "parseType")) |
|---|
| 603 | (nodeID (get-ns-attribute property "nodeID")) |
|---|
| 604 | (resource (get-ns-attribute property "resource")) |
|---|
| 605 | (UUID (get-ns-attribute property "UUID" |
|---|
| 606 | :ns-uri *rdf2tm-ns*)) |
|---|
| 607 | (type (get-ns-attribute property "type")) |
|---|
| 608 | (prop-literals (get-literals-of-property |
|---|
| 609 | property nil)) |
|---|
| 610 | (prop-content (child-nodes-or-text property))) |
|---|
| 611 | (and (or datatype |
|---|
| 612 | (and parseType |
|---|
| 613 | (string= parseType "Literal")) |
|---|
| 614 | (and (not (or nodeID resource UUID parseType)) |
|---|
| 615 | (or (not prop-content) |
|---|
| 616 | (stringp prop-content)))) |
|---|
| 617 | (not (or prop-literals type)) |
|---|
| 618 | (string/= parseType "Collection") |
|---|
| 619 | (string/= parseType "Resource"))) |
|---|
| 620 | collect (let ((content (child-nodes-or-text property)) |
|---|
| 621 | (ID (get-absolute-attribute property tm-id |
|---|
| 622 | xml-base "ID")) |
|---|
| 623 | (child-xml-lang |
|---|
| 624 | (get-xml-lang property :old-lang xml-lang))) |
|---|
| 625 | (let ((full-name (get-type-of-node-name property)) |
|---|
| 626 | (datatype (get-datatype property tm-id xml-base)) |
|---|
| 627 | (text |
|---|
| 628 | (cond |
|---|
| 629 | ((= (length content) 0) |
|---|
| 630 | "") |
|---|
| 631 | ((not (stringp content)) ;must be an element |
|---|
| 632 | (let ((text-val "")) |
|---|
| 633 | (when (dom:child-nodes property) |
|---|
| 634 | (loop for content-node across |
|---|
| 635 | (dom:child-nodes property) |
|---|
| 636 | do (push-string |
|---|
| 637 | (node-to-string content-node) |
|---|
| 638 | text-val))) |
|---|
| 639 | text-val)) |
|---|
| 640 | (t content)))) |
|---|
| 641 | (list :type full-name |
|---|
| 642 | :value text |
|---|
| 643 | :ID ID |
|---|
| 644 | :lang child-xml-lang |
|---|
| 645 | :datatype datatype))))))) |
|---|
| 646 | literals))) |
|---|
| 647 | |
|---|
| 648 | |
|---|
| 649 | (defun get-types-of-node-content (node tm-id parent-xml-base) |
|---|
| 650 | "Returns a list of type-uris that corresponds to the node's content |
|---|
| 651 | or attributes." |
|---|
| 652 | (tm-id-p tm-id "get-types-of-node-content") |
|---|
| 653 | (let ((xml-base (get-xml-base node :old-base parent-xml-base))) |
|---|
| 654 | (let ((attr-type |
|---|
| 655 | (if (get-ns-attribute node "type") |
|---|
| 656 | (list |
|---|
| 657 | (list :topicid (absolutize-value (get-ns-attribute node "type") |
|---|
| 658 | xml-base tm-id) |
|---|
| 659 | :psi (absolutize-value (get-ns-attribute node "type") |
|---|
| 660 | xml-base tm-id) |
|---|
| 661 | :ID nil)) |
|---|
| 662 | nil)) |
|---|
| 663 | (content-types |
|---|
| 664 | (when (child-nodes-or-text node :trim t) |
|---|
| 665 | (loop for child across (child-nodes-or-text node :trim t) |
|---|
| 666 | when (and (string= (dom:namespace-uri child) *rdf-ns*) |
|---|
| 667 | (string= (get-node-name child) "type")) |
|---|
| 668 | collect (let ((nodeID (get-ns-attribute child "nodeID")) |
|---|
| 669 | (resource (get-absolute-attribute |
|---|
| 670 | child tm-id xml-base "resource")) |
|---|
| 671 | (UUID (get-ns-attribute child "UUID" |
|---|
| 672 | :ns-uri *rdf2tm-ns*)) |
|---|
| 673 | (ID (get-absolute-attribute child tm-id |
|---|
| 674 | xml-base "ID"))) |
|---|
| 675 | (if (or nodeID resource UUID) |
|---|
| 676 | (list :topicid (or nodeID resource UUID) |
|---|
| 677 | :psi resource |
|---|
| 678 | :ID ID) |
|---|
| 679 | (let ((child-xml-base |
|---|
| 680 | (get-xml-base child :old-base xml-base))) |
|---|
| 681 | (let ((refs |
|---|
| 682 | (get-node-refs |
|---|
| 683 | (child-nodes-or-text child :trim t) |
|---|
| 684 | tm-id child-xml-base))) |
|---|
| 685 | (list :topicid (getf (first refs) :topicid) |
|---|
| 686 | :psi (getf (first refs) :psi) |
|---|
| 687 | :ID ID))))))))) |
|---|
| 688 | (remove-if #'null (append attr-type content-types))))) |
|---|
| 689 | |
|---|
| 690 | |
|---|
| 691 | (defun get-literals-of-property (property parent-xml-lang) |
|---|
| 692 | "Returns a list of attributes that are treated as literal nodes." |
|---|
| 693 | (let ((xml-lang (get-xml-lang property :old-lang parent-xml-lang)) |
|---|
| 694 | (attributes nil)) |
|---|
| 695 | (dom:map-node-map |
|---|
| 696 | #'(lambda(attr) |
|---|
| 697 | (let ((attr-ns (dom:namespace-uri attr)) |
|---|
| 698 | (attr-name (get-node-name attr))) |
|---|
| 699 | (let ((l-type (get-type-of-node-name attr)) |
|---|
| 700 | (l-value (if (get-ns-attribute property attr-name |
|---|
| 701 | :ns-uri attr-ns) |
|---|
| 702 | (get-ns-attribute property attr-name |
|---|
| 703 | :ns-uri attr-ns) |
|---|
| 704 | ""))) |
|---|
| 705 | (cond |
|---|
| 706 | ((string= attr-ns *rdf-ns*) |
|---|
| 707 | (unless (or (string= attr-name "ID") |
|---|
| 708 | (string= attr-name "resource") |
|---|
| 709 | (string= attr-name "nodeID") |
|---|
| 710 | (string= attr-name "type") |
|---|
| 711 | (string= attr-name "parseType") |
|---|
| 712 | (string= attr-name "datatype")) |
|---|
| 713 | (push (list :type l-type |
|---|
| 714 | :value l-value |
|---|
| 715 | :ID nil |
|---|
| 716 | :lang xml-lang |
|---|
| 717 | :datatype *xml-string*) |
|---|
| 718 | attributes))) |
|---|
| 719 | ((or (string= attr-ns *xml-ns*) |
|---|
| 720 | (string= attr-ns *xmlns-ns*)) |
|---|
| 721 | nil);;do nothing, all xml-attributes are no literals |
|---|
| 722 | (t |
|---|
| 723 | (unless (and (string= attr-ns *rdf2tm-ns*) |
|---|
| 724 | (string= attr-name "UUID")) |
|---|
| 725 | (push (list :type l-type |
|---|
| 726 | :value l-value |
|---|
| 727 | :ID nil |
|---|
| 728 | :lang xml-lang |
|---|
| 729 | :datatype *xml-string*) |
|---|
| 730 | attributes))))))) |
|---|
| 731 | (dom:attributes property)) |
|---|
| 732 | attributes)) |
|---|
| 733 | |
|---|
| 734 | |
|---|
| 735 | (defun get-literals-of-node (node parent-xml-lang) |
|---|
| 736 | "Returns alist of attributes that are treated as literal nodes." |
|---|
| 737 | (let ((xml-lang (get-xml-lang node :old-lang parent-xml-lang)) |
|---|
| 738 | (attributes nil)) |
|---|
| 739 | (dom:map-node-map |
|---|
| 740 | #'(lambda(attr) |
|---|
| 741 | (let ((attr-ns (dom:namespace-uri attr)) |
|---|
| 742 | (attr-name (get-node-name attr))) |
|---|
| 743 | (let ((l-type (get-type-of-node-name attr)) |
|---|
| 744 | (l-value (if (get-ns-attribute node attr-name :ns-uri attr-ns) |
|---|
| 745 | (get-ns-attribute node attr-name :ns-uri attr-ns) |
|---|
| 746 | ""))) |
|---|
| 747 | (cond |
|---|
| 748 | ((string= attr-ns *rdf-ns*) |
|---|
| 749 | (unless (or (string= attr-name "ID") |
|---|
| 750 | (string= attr-name "about") |
|---|
| 751 | (string= attr-name "nodeID") |
|---|
| 752 | (string= attr-name "type")) |
|---|
| 753 | (push (list :type l-type |
|---|
| 754 | :value l-value |
|---|
| 755 | :ID nil |
|---|
| 756 | :lang xml-lang |
|---|
| 757 | :datatype *xml-string*) |
|---|
| 758 | attributes))) |
|---|
| 759 | ((or (string= attr-ns *xml-ns*) |
|---|
| 760 | (string= attr-ns *xmlns-ns*)) |
|---|
| 761 | nil);;do nothing, all xml-attributes are no literals |
|---|
| 762 | (t |
|---|
| 763 | (unless (and (string= attr-ns *rdf2tm-ns*) |
|---|
| 764 | (string= attr-name "UUID")) |
|---|
| 765 | (push (list :type l-type |
|---|
| 766 | :value l-value |
|---|
| 767 | :ID nil |
|---|
| 768 | :lang xml-lang |
|---|
| 769 | :datatype *xml-string*) |
|---|
| 770 | attributes))))))) |
|---|
| 771 | (dom:attributes node)) |
|---|
| 772 | attributes)) |
|---|
| 773 | |
|---|
| 774 | |
|---|
| 775 | (defun get-super-classes-of-node-content (node tm-id parent-xml-base) |
|---|
| 776 | "Returns a list of super-classes and IDs." |
|---|
| 777 | (declare (dom:element node)) |
|---|
| 778 | (tm-id-p tm-id "get-super-classes-of-node-content") |
|---|
| 779 | (let ((content (child-nodes-or-text node :trim t)) |
|---|
| 780 | (xml-base (get-xml-base node :old-base parent-xml-base))) |
|---|
| 781 | (when content |
|---|
| 782 | (loop for property across content |
|---|
| 783 | when (let ((prop-name (get-node-name property)) |
|---|
| 784 | (prop-ns (dom:namespace-uri property))) |
|---|
| 785 | (and (string= prop-name "subClassOf") |
|---|
| 786 | (string= prop-ns *rdfs-ns*))) |
|---|
| 787 | collect (let ((prop-xml-base (get-xml-base property |
|---|
| 788 | :old-base xml-base))) |
|---|
| 789 | (let ((ID (get-absolute-attribute property tm-id |
|---|
| 790 | xml-base "ID")) |
|---|
| 791 | (nodeID (get-ns-attribute property "nodeID")) |
|---|
| 792 | (resource |
|---|
| 793 | (get-absolute-attribute property tm-id |
|---|
| 794 | xml-base "resource")) |
|---|
| 795 | (UUID (get-ns-attribute property "UUID" |
|---|
| 796 | :ns-uri *rdf2tm-ns*))) |
|---|
| 797 | (if (or nodeID resource UUID) |
|---|
| 798 | (list :topicid (or nodeID resource UUID) |
|---|
| 799 | :psi resource |
|---|
| 800 | :ID ID) |
|---|
| 801 | (let ((refs (get-node-refs |
|---|
| 802 | (child-nodes-or-text property :trim t) |
|---|
| 803 | tm-id prop-xml-base))) |
|---|
| 804 | (list :topicid (getf (first refs) :topicid) |
|---|
| 805 | :psi (getf (first refs) :psi) |
|---|
| 806 | :ID ID))))))))) |
|---|
| 807 | |
|---|
| 808 | |
|---|
| 809 | (defun get-associations-of-node-content (node tm-id parent-xml-base) |
|---|
| 810 | "Returns a list of associations with a type, value and ID member." |
|---|
| 811 | (declare (dom:element node)) |
|---|
| 812 | (let ((properties (child-nodes-or-text node :trim t)) |
|---|
| 813 | (xml-base (get-xml-base node :old-base parent-xml-base))) |
|---|
| 814 | (loop for property across properties |
|---|
| 815 | when (let ((prop-name (get-node-name property)) |
|---|
| 816 | (prop-ns (dom:namespace-uri property)) |
|---|
| 817 | (prop-content (child-nodes-or-text property)) |
|---|
| 818 | (resource (get-absolute-attribute property tm-id |
|---|
| 819 | xml-base "resource")) |
|---|
| 820 | (nodeID (get-ns-attribute property "nodeID")) |
|---|
| 821 | (type (get-ns-attribute property "type")) |
|---|
| 822 | (parseType (get-ns-attribute property "parseType")) |
|---|
| 823 | (UUID (get-ns-attribute property "UUID" |
|---|
| 824 | :ns-uri *rdf2tm-ns*))) |
|---|
| 825 | (and (or resource nodeID type UUID |
|---|
| 826 | (and parseType |
|---|
| 827 | (or (string= parseType "Collection") |
|---|
| 828 | (string= parseType "Resource"))) |
|---|
| 829 | (and (> (length prop-content) 0) |
|---|
| 830 | (not (stringp prop-content))) |
|---|
| 831 | (> (length (get-literals-of-property property nil)) 0)) |
|---|
| 832 | (not (and (string= prop-name "type") |
|---|
| 833 | (string= prop-ns *rdf-ns*))) |
|---|
| 834 | (not (and (string= prop-name "subClassOf") |
|---|
| 835 | (string= prop-ns *rdfs-ns*))))) |
|---|
| 836 | collect (let ((prop-xml-base (get-xml-base property |
|---|
| 837 | :old-base xml-base)) |
|---|
| 838 | (content (child-nodes-or-text property :trim t)) |
|---|
| 839 | (parseType (get-ns-attribute property "parseType"))) |
|---|
| 840 | (let ((resource |
|---|
| 841 | (if (and (string= parseType "Collection") |
|---|
| 842 | (= (length content) 0)) |
|---|
| 843 | *rdf-nil* |
|---|
| 844 | (get-absolute-attribute property tm-id |
|---|
| 845 | xml-base "resource"))) |
|---|
| 846 | (nodeID (get-ns-attribute property "nodeID")) |
|---|
| 847 | (UUID (get-ns-attribute property "UUID" |
|---|
| 848 | :ns-uri *rdf2tm-ns*)) |
|---|
| 849 | (ID (get-absolute-attribute property tm-id |
|---|
| 850 | xml-base "ID")) |
|---|
| 851 | (full-name (get-type-of-node-name property))) |
|---|
| 852 | (if (or nodeID resource UUID) |
|---|
| 853 | (list :type full-name |
|---|
| 854 | :topicid (or resource nodeID UUID) |
|---|
| 855 | :psi resource |
|---|
| 856 | :ID ID) |
|---|
| 857 | (let ((refs (get-node-refs |
|---|
| 858 | (child-nodes-or-text property :trim t) |
|---|
| 859 | tm-id prop-xml-base))) |
|---|
| 860 | (list :type full-name |
|---|
| 861 | :topicid (getf (first refs) :topicid) |
|---|
| 862 | :psi (getf (first refs) :psi) |
|---|
| 863 | :ID ID)))))))) |
|---|
| 864 | |
|---|
| 865 | |
|---|
| 866 | (defun make-recursion-from-node (node tm-id start-revision |
|---|
| 867 | &key (document-id *document-id*) |
|---|
| 868 | (parent-xml-base nil) (parent-xml-lang nil)) |
|---|
| 869 | "Calls the next function that handles all DOM child elements |
|---|
| 870 | of the passed element as arcs." |
|---|
| 871 | (declare (dom:element node)) |
|---|
| 872 | (let ((content (child-nodes-or-text node :trim t)) |
|---|
| 873 | (err-pref "From make-recursion-from-node(): ") |
|---|
| 874 | (xml-base (get-xml-base node :old-base parent-xml-base)) |
|---|
| 875 | (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) |
|---|
| 876 | (when (stringp content) |
|---|
| 877 | (error "~aliteral content not allowed here: ~a" |
|---|
| 878 | err-pref content)) |
|---|
| 879 | (loop for arc across content |
|---|
| 880 | collect (import-arc arc tm-id start-revision :document-id document-id |
|---|
| 881 | :parent-xml-base xml-base |
|---|
| 882 | :parent-xml-lang xml-lang)))) |
|---|
| 883 | |
|---|
| 884 | |
|---|
| 885 | (defun make-recursion-from-arc (arc tm-id start-revision |
|---|
| 886 | &key (document-id *document-id*) |
|---|
| 887 | (parent-xml-base nil) (parent-xml-lang nil)) |
|---|
| 888 | "Calls the next function that handles the arcs content nodes/arcs." |
|---|
| 889 | (declare (dom:element arc)) |
|---|
| 890 | (let ((xml-base (get-xml-base arc :old-base parent-xml-base)) |
|---|
| 891 | (xml-lang (get-xml-lang arc :old-lang parent-xml-lang)) |
|---|
| 892 | (content (child-nodes-or-text arc)) |
|---|
| 893 | (parseType (get-ns-attribute arc "parseType"))) |
|---|
| 894 | (let ((datatype (get-absolute-attribute arc tm-id |
|---|
| 895 | parent-xml-base "datatype")) |
|---|
| 896 | (type (get-absolute-attribute arc tm-id parent-xml-base "type")) |
|---|
| 897 | (resource (get-absolute-attribute arc tm-id |
|---|
| 898 | parent-xml-base "resource")) |
|---|
| 899 | (nodeID (get-ns-attribute arc "nodeID")) |
|---|
| 900 | (literals (get-literals-of-property arc parent-xml-lang))) |
|---|
| 901 | (if (and parseType |
|---|
| 902 | (string= parseType "Collection")) |
|---|
| 903 | (make-collection arc tm-id start-revision |
|---|
| 904 | :document-id document-id |
|---|
| 905 | :parent-xml-base parent-xml-base |
|---|
| 906 | :parent-xml-lang parent-xml-lang) |
|---|
| 907 | (if (or datatype resource nodeID |
|---|
| 908 | (and parseType |
|---|
| 909 | (string= parseType "Literal")) |
|---|
| 910 | (and content |
|---|
| 911 | (stringp content))) |
|---|
| 912 | nil;; do nothing current elem is a literal node that has been |
|---|
| 913 | ;; already imported as an occurrence |
|---|
| 914 | (if (or type literals |
|---|
| 915 | (and parseType |
|---|
| 916 | (string= parseType "Resource"))) |
|---|
| 917 | (loop for item across content |
|---|
| 918 | collect (import-arc item tm-id start-revision |
|---|
| 919 | :document-id document-id |
|---|
| 920 | :parent-xml-base xml-base |
|---|
| 921 | :parent-xml-lang xml-lang)) |
|---|
| 922 | (loop for item across content |
|---|
| 923 | collect (import-node item tm-id start-revision |
|---|
| 924 | :document-id document-id |
|---|
| 925 | :parent-xml-base xml-base |
|---|
| 926 | :parent-xml-lang xml-lang)))))))) |
|---|
