source: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp

Last change on this file was 317, checked in by lgiessmann, 14 years ago

new-datamodel: adapted the threading+importer unit-tests to the latest elephant+sbcl version; adapted the exporter-unit-tests to the new datamodel and sbcl+elephant version; fixed a bug when importing scopes of namevariants; adapted the reification uint-tests for the xtm-importer ot the latest elephant+sbcl version and the new-datamodel
  • Property svn:eol-style set to native
File size: 16.3 KB
Line 
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
9
10(in-package :xml-importer)
11
12(defun get-reifier-topic(reifiable-elem start-revision)
13  "Returns the reifier topic of the reifierable-element or nil."
14  (declare (dom:element reifiable-elem))
15  (let ((reifier-uri (get-attribute reifiable-elem "reifier"))
16        (err "From get-reifier-topic(): "))
17    (when (and (stringp reifier-uri)
18               (> (length reifier-uri) 0))
19      (let ((ii
20             (elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri reifier-uri)))
21        (if ii
22            (let ((reifier-topic (identified-construct ii :revision start-revision)))
23              (if reifier-topic
24                  reifier-topic
25                  (error "~aitem-identifier ~a not found" err reifier-uri)))
26            (error "~aitem-identifier ~a not found" err reifier-uri))))))
27
28
29(defun from-identifier-elem (classsymbol elem start-revision)
30  "Generate an identifier object of type 'classsymbol' (a subclass of
31IdentifierC) from a given identifier element for a revision and return
32that object"
33  (declare (symbol classsymbol))
34  (declare (dom:element elem))
35  (declare (integer start-revision))
36  (let
37      ((id (make-construct classsymbol
38                          :uri (get-attribute elem "href")
39                          :start-revision start-revision)))
40    id))
41 
42         
43(defun make-identifiers (classsymbol start-elem elem-name start-revision)
44  (map 'list 
45       (lambda (elem) 
46         (from-identifier-elem classsymbol elem start-revision))
47       (xpath-child-elems-by-qname 
48        start-elem
49        *xtm2.0-ns* elem-name)))
50
51
52(defun from-type-elem (type-elem start-revision &key (xtm-id *current-xtm*))
53  "Returns the topic that reifies this type or nil if no element is
54input"
55  ; type = element type { topicRef }
56  ;the from-type-elem function does not need a revision element as it
57  ;just points to an existing topic with its own revision history
58  (when type-elem
59    (let*
60        ((topicid 
61          (get-topicref-uri 
62            (xpath-single-child-elem-by-qname 
63             type-elem 
64             *xtm2.0-ns* "topicRef")))
65         (top (get-item-by-id topicid :xtm-id xtm-id :revision start-revision)))
66      (declare (dom:element type-elem))
67      (unless top
68        (error (make-condition 'missing-reference-error
69                               :message (format nil "Could not resolve topicid ~a" topicid))))
70      top)))
71
72
73(defun from-scope-elem (scope-elem start-revision &key (xtm-id *current-xtm*))
74  "Generate set of themes (= topics) from this scope element and
75return that set. If the input is nil, the list of themes is empty
76 scope = element scope { topicRef+ }"
77  ;the from-scope-elem function does not need a revision element as it
78  ;just points to existing topics with their own revision histories
79  (when scope-elem
80    (let*
81        ((topicrefs
82          (map 'list 
83               #'get-topicref-uri
84               (xpath-child-elems-by-qname 
85                scope-elem 
86                *xtm2.0-ns* "topicRef")))
87         (tops 
88          (map 'list 
89               (lambda (topicid)
90                 (let
91                     ((top
92                       (get-item-by-id topicid :xtm-id xtm-id 
93                                       :revision start-revision)))
94                   (if top
95                       top
96                       (error (make-condition 'missing-reference-error
97                               :message (format nil "from-scope-elem: could not resolve reference ~a" topicid))))))
98               topicrefs)))
99      (declare (dom:element scope-elem))
100      (unless (>= (length tops) 1)
101        (error "need at least one topic in a scope"))
102      tops)))
103
104   
105(defun from-name-elem (name-elem top start-revision &key (xtm-id *current-xtm*))
106  "Generate a NameC object from a name element name = element name {
107   reifiable, type?, scope?, value, variant* }. If a topic is given, the
108   name first checks for possible equality and then adds an association
109   to it"
110  (declare (dom:element name-elem))
111  (declare (TopicC top))
112  (declare (optimize (debug 3)))
113  (let 
114      ((item-identifiers
115        (make-identifiers 'ItemIdentifierC name-elem "itemIdentity" start-revision))
116       (namevalue
117         (xpath-fn-string (xpath-single-child-elem-by-qname 
118          name-elem 
119          *xtm2.0-ns* "value")))
120       (themes
121        (from-scope-elem 
122         (xpath-single-child-elem-by-qname 
123          name-elem  *xtm2.0-ns* "scope")
124         start-revision :xtm-id xtm-id))     
125        (instance-of
126         (from-type-elem (xpath-single-child-elem-by-qname 
127                          name-elem 
128                          *xtm2.0-ns* "type") start-revision :xtm-id xtm-id))
129       (reifier-topic (get-reifier-topic name-elem start-revision)))
130    (unless namevalue
131        (error "A name must have exactly one namevalue"))
132    (let ((name (make-construct 'NameC 
133                                :start-revision start-revision
134                                :parent top
135                                :charvalue namevalue
136                                :instance-of instance-of
137                                :item-identifiers item-identifiers
138                                :reifier reifier-topic
139                                :themes themes)))
140      (loop for variant-elem across (xpath-child-elems-by-qname name-elem *xtm2.0-ns* "variant")
141         do (from-variant-elem variant-elem name start-revision :xtm-id xtm-id))
142      name)))
143
144
145(defun from-resourceX-elem (parent-elem)
146  "handles the following problem: { resourceRef | resourceData }
147   and returns a list with a data and a type node"
148  (when parent-elem
149       (let ((data
150              (let
151                  ((href 
152                    (get-attribute
153                     (xpath-single-child-elem-by-qname
154                      parent-elem
155                      *xtm2.0-ns* "resourceRef") "href")))
156                (if href
157                    href
158                    (xpath-fn-string 
159                     (xpath-single-child-elem-by-qname
160                      parent-elem
161                      *xtm2.0-ns* "resourceData")))))
162             (type
163              (let
164                  ((resourcedata-elem
165                    (xpath-single-child-elem-by-qname
166                     parent-elem
167                     *xtm2.0-ns* "resourceData")))
168                (if resourcedata-elem
169                    (let ((attr (get-attribute resourcedata-elem "datatype")))
170                      (if attr
171                          attr         
172                          "http://www.w3.org/2001/XMLSchema#string"))
173                    "http://www.w3.org/2001/XMLSchema#anyURI")))) ;the datatype of resourceRefs is IRI, cf. TMDM 4.4 and 5.6
174         (unless data
175           (error "from-resourceX-elem: one of resourceRef or resourceData must be set"))
176         (list :data data :type type))))
177
178
179(defun from-variant-elem (variant-elem name start-revision &key (xtm-id *current-xtm*))
180  "Generate a VariantC object from a variant element
181   variant = element variant { reifiable, scope, (resourceRef | resourceData) }"
182  (declare (dom:element variant-elem))
183  (declare (optimize (debug 3)))
184  (declare (NameC name))
185  (let 
186      ((item-identifiers (make-identifiers 'ItemIdentifierC variant-elem "itemIdentity" start-revision))
187       ;;all themes of the parent name element are inherited to the variant elements
188       (themes (append
189                (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope")
190                                 start-revision :xtm-id xtm-id)
191                (themes name :revision start-revision)))
192       (variant-value (from-resourceX-elem variant-elem))
193       (reifier-topic (get-reifier-topic variant-elem start-revision)))
194    (unless variant-value
195      (error "VariantC: one of resourceRef and resourceData must be set"))
196    (make-construct 'VariantC
197                    :start-revision start-revision
198                    :item-identifiers item-identifiers
199                    :themes themes
200                    :charvalue (getf variant-value :data)
201                    :datatype (getf variant-value :type)
202                    :reifier reifier-topic
203                    :parent name)))
204                           
205
206(defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*))
207  "Generate an OccurrenceC object from an occurrence element
208occurrence = element occurrence { reifiable,
209  type, scope?, ( resourceRef | resourceData ) }"
210  (declare (dom:element occ-elem))
211  (declare (TopicC top))
212  (declare (integer start-revision))
213  (let
214      ((themes
215        (from-scope-elem (xpath-single-child-elem-by-qname 
216                          occ-elem  *xtm2.0-ns* "scope") start-revision :xtm-id xtm-id))
217       (item-identifiers
218        (make-identifiers 'ItemIdentifierC occ-elem "itemIdentity" start-revision))
219       (instance-of 
220        (from-type-elem (xpath-single-child-elem-by-qname 
221                          occ-elem 
222                          *xtm2.0-ns* "type") start-revision :xtm-id xtm-id))
223       (occurrence-value (from-resourceX-elem occ-elem))
224       (reifier-topic (get-reifier-topic occ-elem start-revision)))
225    (unless occurrence-value
226      (error "OccurrenceC: one of resourceRef and resourceData must be set"))
227    (make-construct 'OccurrenceC 
228                    :start-revision start-revision
229                    :parent top
230                    :themes themes
231                    :item-identifiers item-identifiers
232                    :instance-of instance-of
233                    :charvalue (getf occurrence-value :data)
234                    :reifier reifier-topic
235                    :datatype (getf occurrence-value :type))))
236   
237   
238
239(defun from-topic-elem-to-stub (topic-elem start-revision
240                                &key 
241                                (xtm-id d:*current-xtm*))
242  "Creates the pure stub of a topic together with topicid, PSI and
243subject locators. Merges new topic stubs with existing stubs if
244applicable"
245  (declare (dom:element topic-elem))
246  (declare (integer start-revision))
247  (elephant:ensure-transaction (:txn-nosync t) 
248    (let 
249        ((itemidentifiers
250          (make-identifiers 'ItemIdentifierC topic-elem "itemIdentity" start-revision))
251         (subjectidentifiers
252          (make-identifiers 'PersistentIdC topic-elem "subjectIdentifier" start-revision))
253         (subjectlocators
254          (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision))
255         (topic-ids (when (get-attribute topic-elem "id")
256                      (list (make-construct 'TopicIdentificationC
257                                            :uri (get-attribute topic-elem "id")
258                                            :xtm-id xtm-id)))))
259      (make-construct 'TopicC
260                      :start-revision start-revision
261                      :item-identifiers itemidentifiers
262                      :locators subjectlocators
263                      :psis subjectidentifiers
264                      :topic-identifiers topic-ids))))
265         
266
267(defun merge-topic-elem (topic-elem start-revision
268                         &key tm (xtm-id *current-xtm*))
269  "Adds further elements (names, occurrences) and instanceOf
270associations to the topic"
271  (declare (dom:element topic-elem))
272  (declare (integer start-revision))
273  (declare (TopicMapC tm))
274  (elephant:ensure-transaction (:txn-nosync t) 
275    (let
276        ((top  ;retrieve the already existing topic stub
277          (get-item-by-id (get-attribute topic-elem "id") 
278           :xtm-id xtm-id :revision start-revision)))
279      (let
280          ((instanceof-topicrefs
281            (map 'list 
282               #'get-topicref-uri
283               (xpath-select-location-path
284                topic-elem
285                '((*xtm2.0-ns* "instanceOf")
286                  (*xtm2.0-ns* "topicRef"))))))
287      (unless top
288        (error "topic ~a could not be found (xtm-id: ~a, revision: ~a)"
289               (get-attribute topic-elem "id") xtm-id start-revision))
290      (map 'list
291       (lambda
292           (name-elem)
293         (from-name-elem name-elem top start-revision :xtm-id xtm-id))
294       (xpath-child-elems-by-qname 
295        topic-elem 
296        *xtm2.0-ns* "name"))
297      (map 'list
298       (lambda
299           (occ-elem)
300         (from-occurrence-elem occ-elem top start-revision :xtm-id xtm-id))
301       (xpath-child-elems-by-qname 
302        topic-elem 
303        *xtm2.0-ns* "occurrence"))
304
305      ;this is a very special process
306      (dolist (topicref instanceof-topicrefs)
307        (create-instanceof-association topicref top start-revision
308                                       :tm tm
309                                       :xtm-id xtm-id))
310      (add-to-tm tm top)
311      top))))
312
313
314(defun from-role-elem (role-elem start-revision &key (xtm-id *current-xtm*))
315  "Constructs a tuple of (instance-of, player, item-identifiers) from
316a role element and returns it role = element role { reifiable, type,
317topicRef }"
318  (declare (dom:element role-elem))
319  (declare (integer start-revision))
320  (elephant:ensure-transaction (:txn-nosync t) 
321    (let 
322        ((item-identifiers
323          (make-identifiers 'ItemIdentifierC role-elem "itemIdentity" start-revision))
324         (instance-of
325          (from-type-elem 
326           (xpath-single-child-elem-by-qname
327            role-elem *xtm2.0-ns* "type")
328           start-revision :xtm-id xtm-id))
329         (player
330          (get-item-by-id (get-topicref-uri 
331                           (xpath-single-child-elem-by-qname 
332                            role-elem *xtm2.0-ns* "topicRef"))
333                          :xtm-id xtm-id :revision start-revision))
334         (reifier-topic (get-reifier-topic role-elem start-revision)))
335      (unless player ;instance-of will be set later - if there is no one
336        (error "Role in association with topicref ~a not complete" (get-topicref-uri 
337            (xpath-single-child-elem-by-qname 
338             role-elem
339             *xtm2.0-ns*
340             "topicRef"))))
341      (list :start-revision start-revision
342            :reifier reifier-topic
343            :instance-of instance-of
344            :player player
345            :item-identifiers item-identifiers))))
346
347
348(defun from-association-elem (assoc-elem start-revision
349                              &key
350                              tm
351                              (xtm-id *current-xtm*))
352  "Constructs an AssociationC object from an association element
353   association = element association { reifiable, type, scope?, role+ }"
354  (declare (dom:element assoc-elem))
355  (declare (integer start-revision))
356  (declare (TopicMapC tm))
357  (elephant:ensure-transaction (:txn-nosync t) 
358    (let
359        ((item-identifiers
360          (make-identifiers 'ItemIdentifierC assoc-elem "itemIdentity" start-revision))
361         (instance-of
362          (from-type-elem 
363           (xpath-single-child-elem-by-qname 
364            assoc-elem *xtm2.0-ns* "type") 
365           start-revision :xtm-id xtm-id))
366         (themes
367          (from-scope-elem 
368           (xpath-single-child-elem-by-qname assoc-elem *xtm2.0-ns* "scope")
369           start-revision :xtm-id xtm-id))
370         (roles ;a list of tuples
371          (map 'list 
372               (lambda 
373                   (role-elem)
374                 (from-role-elem role-elem start-revision :xtm-id xtm-id))
375               (xpath-child-elems-by-qname 
376                assoc-elem
377                *xtm2.0-ns* "role")))
378         (reifier-topic (get-reifier-topic assoc-elem start-revision)))
379      (setf roles (set-standard-role-types roles start-revision)); sets standard role types if there are missing some of them
380      (add-to-tm
381       tm 
382       (make-construct 'AssociationC
383                       :start-revision start-revision
384                       :item-identifiers item-identifiers
385                       :instance-of instance-of
386                       :themes themes
387                       :reifier reifier-topic
388                       :roles roles)))))
389
390(defun get-topic-elems (xtm-dom)
391  (xpath-child-elems-by-qname xtm-dom
392                              *xtm2.0-ns* "topic"))
393
394
395(defun get-association-elems (xtm-dom)
396  (xpath-child-elems-by-qname  xtm-dom
397                               *xtm2.0-ns* "association"))
398
399(defun import-only-topics
400    (xtm-dom
401     &key   
402     (tm-id (error "you must provide a stable identifier (PSI-style) for this TM"))
403     (xtm-id d:*current-xtm*)
404     (revision (get-revision)))
405  (with-tm (revision xtm-id tm-id)
406    (let
407        ((topic-vector (get-topic-elems xtm-dom)))
408      (loop for top-elem across topic-vector do
409           (add-to-tm 
410            tm 
411            (from-topic-elem-to-stub top-elem revision 
412                                     :xtm-id xtm-id))))))
413
414(defun importer (xtm-dom 
415                 &key 
416                 (tm-id (error "you must provide a stable identifier (PSI-style) for this TM"))
417                 (xtm-id d:*current-xtm*)
418                 (revision (get-revision)))
419  (declare (dom:element xtm-dom))
420  (declare (integer revision))        ;all topics that are imported in one go share the same revision
421  (assert elephant:*store-controller*)
422  (with-writer-lock
423    (with-tm (revision xtm-id tm-id)
424      (let
425          ((topic-vector (get-topic-elems xtm-dom))
426           (assoc-vector (get-association-elems xtm-dom)))
427        (loop for top-elem across topic-vector do
428             (from-topic-elem-to-stub top-elem revision 
429                                      :xtm-id xtm-id))
430        (loop for top-elem across topic-vector do
431             (format t "t")
432             (merge-topic-elem top-elem revision 
433                               :tm tm
434                               :xtm-id xtm-id))
435        (loop for assoc-elem across assoc-vector do
436             (format t "a")
437             (from-association-elem assoc-elem revision 
438                                    :tm tm
439                                    :xtm-id xtm-id))))))
Note: See TracBrowser for help on using the repository browser.