From mkuster at common-lisp.net Sun Feb 1 21:44:18 2009 From: mkuster at common-lisp.net (Marc Wilhelm Kuster) Date: Sun, 01 Feb 2009 21:44:18 +0000 Subject: [isidorus-cvs] r12 - in trunk/src: . model unit_tests xml Message-ID: Author: mkuster Date: Sun Feb 1 21:44:18 2009 New Revision: 12 Log: instanceOf associations are now also filtered by TM Added: trunk/src/unit_tests/multiple_tms_ont.xtm trunk/src/unit_tests/multiple_tms_worms.xtm Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/xml/exporter.lisp trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/exporter_xtm2.0.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sun Feb 1 21:44:18 2009 @@ -35,7 +35,8 @@ :depends-on ("importer_xtm2.0" "importer_xtm1.0")) (:file "exporter_xtm1.0") - (:file "exporter_xtm2.0") + (:file "exporter_xtm2.0" + :depends-on ("exporter_xtm1.0")) (:file "exporter" :depends-on ("exporter_xtm1.0" "exporter_xtm2.0"))) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Feb 1 21:44:18 2009 @@ -948,6 +948,10 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision))) +(defgeneric in-topicmaps (topic) + (:method ((topic TopicC)) + (filter-slot-value-by-revision topic 'in-topicmaps :start-revision *TM-REVISION*))) + (defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis)) @@ -1135,19 +1139,29 @@ (:documentation "Test for the existence of PSIs") (:method ((top TopicC)) (slot-predicate top 'psis))) -(defgeneric list-instanceOf (topic) - (:method ((topic TopicC)))) - -(defmethod list-instanceOf ((topic TopicC)) - (remove-if #'null - (map 'list #'(lambda(x) - (when (loop for psi in (psis (instance-of x)) - when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance") - return t) - (loop for role in (roles (parent x)) - when (not (eq role x)) - return (player role)))) - (player-in-roles topic)))) +(defgeneric list-instanceOf (topic &key tm) + (:documentation "Generate a list of all topics that this topic is an + instance of, optionally filtered by a topic map")) + +(defmethod list-instanceOf ((topic TopicC) &key (tm nil)) + (remove-if + #'null + (map 'list #'(lambda(x) + (when (loop for psi in (psis (instance-of x)) + when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance") + return t) + (loop for role in (roles (parent x)) + when (not (eq role x)) + return (player role)))) + (if tm + (remove-if-not + (lambda (role) + (format t "player: ~a" (player role)) + (format t "parent: ~a" (parent role)) + (format t "topic: ~a~&" topic) + (in-topicmap tm (parent role))) + (player-in-roles topic)) + (player-in-roles topic))))) (defun string-starts-with (str prefix) "Checks if string str starts with a given prefix" Added: trunk/src/unit_tests/multiple_tms_ont.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/multiple_tms_ont.xtm Sun Feb 1 21:44:18 2009 @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file Added: trunk/src/unit_tests/multiple_tms_worms.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/multiple_tms_worms.xtm Sun Feb 1 21:44:18 2009 @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + \ No newline at end of file Modified: trunk/src/xml/exporter.lisp ============================================================================== --- trunk/src/xml/exporter.lisp (original) +++ trunk/src/xml/exporter.lisp Sun Feb 1 21:44:18 2009 @@ -1,9 +1,9 @@ (in-package :exporter) -(defun instanceofs-to-elem (ios) - (when ios - (map 'list (lambda (io) (cxml:with-element "t:instanceOf" (ref-to-elem io))) ios))) +;; (defun instanceofs-to-elem (ios) +;; (when ios +;; (map 'list (lambda (io) (cxml:with-element "t:instanceOf" (ref-to-elem io))) ios))) (defun list-extern-associations () @@ -39,15 +39,18 @@ , at body)))) (defmacro export-to-elem (tm to-elem) - `(map 'list ,to-elem + `(setf *export-tm* ,tm) + `(format t "*export-tm*: ~a" *export-tm*) + `(map 'list + ,to-elem (remove-if #'null (map 'list #'(lambda(top) (d:find-item-by-revision top revision)) (if ,tm - (union - (d:topics ,tm) (d:associations ,tm)) + (union + (d:topics ,tm) (d:associations ,tm)) (union (elephant:get-instances-by-class 'd:TopicC) (list-extern-associations))))))) @@ -60,6 +63,7 @@ ((tm (when tm-id (get-item-by-item-identifier tm-id :revision revision)))) + (setf *export-tm* tm) (with-revision revision (with-open-file (stream xtm-path :direction :output) (cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil) Modified: trunk/src/xml/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/exporter_xtm1.0.lisp Sun Feb 1 21:44:18 2009 @@ -13,6 +13,8 @@ (in-package :exporter) +(defparameter *export-tm* nil "TopicMap which is exported (nil if all is to be exported") + (defgeneric to-elem-xtm1.0 (instance) (:documentation "converts the Topic Maps construct instance to an XTM 1.0 element")) @@ -115,8 +117,8 @@ (baseName | occurrence)* }" (cxml:with-element "t:topic" (cxml:attribute "id" (topicid topic)) - (when (list-instanceOf topic) - (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic))) + (when (list-instanceOf topic :tm *export-tm*) + (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic :tm *export-tm*))) (when (or (psis topic) (locators topic)) (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic)))) (when (names topic) Modified: trunk/src/xml/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/exporter_xtm2.0.lisp Sun Feb 1 21:44:18 2009 @@ -118,9 +118,9 @@ (map 'list #'to-elem (item-identifiers topic)) (map 'list #'to-elem (locators topic)) (map 'list #'to-elem (psis topic)) - (when (list-instanceOf topic) + (when (list-instanceOf topic :tm *export-tm*) (cxml:with-element "t:instanceOf" - (loop for item in (list-instanceOf topic) + (loop for item in (list-instanceOf topic :tm *export-tm*) do (cxml:with-element "t:topicRef" (cxml:attribute "href" (concatenate 'string "#" (topicid item))))))) (map 'list #'to-elem (names topic)) From cludwig at common-lisp.net Sun Feb 1 21:48:06 2009 From: cludwig at common-lisp.net (Christoph Ludwig) Date: Sun, 01 Feb 2009 21:48:06 +0000 Subject: [isidorus-cvs] r13 - trunk/src/rest_interface Message-ID: Author: cludwig Date: Sun Feb 1 21:48:06 2009 New Revision: 13 Log: check if we already imported any snapshot Modified: trunk/src/rest_interface/read.lisp Modified: trunk/src/rest_interface/read.lisp ============================================================================== --- trunk/src/rest_interface/read.lisp (original) +++ trunk/src/rest_interface/read.lisp Sun Feb 1 21:48:06 2009 @@ -83,39 +83,48 @@ (t (string-max (rest string-list) max)))) -(defun import-snapshots-feed (snapshot-feed-url &key tm-id) - ;this finds the most recent snapshot and imports that. It returns the entry - ;corresponding to that snapshot +(defun most-recent-entry (entry-list) + (let + ((most-recent-update (string-max (mapcar #'atom:updated entry-list)))) + (find most-recent-update entry-list :key #'updated :test #'string=))) + +(defun most-recent-imported-snapshot (all-snapshot-entries) + (let + ((all-imported-entries + (remove-if-not #'xtm-id-p all-snapshot-entries :key #'atom:id))) + (most-recent-entry all-imported-entries))) - (let +(defun import-snapshots-feed (snapshot-feed-url &key tm-id) + "checks if we already imported any of this feed's snapshots. If not, +finds the most recent snapshot and imports that. It returns the entry +corresponding to the snapshot imported (now or previously)." + (let* ((feed (read-snapshots-feed snapshot-feed-url)) - (revision (get-revision))) - (let* - ((most-recent-update (string-max (mapcar #'atom:updated (slot-value feed 'atom:entries)))) - (entry - (find - most-recent-update - (slot-value feed 'atom:entries) :key #'updated :test #'string=)) - (xtm-id (id entry))) - ;;that *should* be the algorithm... - ;; If a client has a local topic map that contains topic map - ;; data from more than one server and wants to fetch and update - ;; the latest full topic map from ONE source then it MUST do the - ;; following. Apply the delete topic algorithm from below, but - ;; apply it to the entire topic map. Then proceed in terms of 'A - ;; Clean Start', by fetching the topic map and merging it in - ;; (1b, 1.4.3.2) - (unless (xtm-id-p xtm-id) - (importer-xtm1.0 - (dom:document-element - (cxml:parse-rod (read-url (link entry)) (cxml-dom:make-dom-builder))) - :tm-id tm-id - :xtm-id xtm-id :revision revision)) - entry))) + (all-entries (slot-value feed 'atom:entries)) + (most-recent-imported-entry all-entries)) + (if most-recent-imported-entry + most-recent-imported-entry + (let* + ((entry (most-recent-entry all-entries)) + (snapshot-dom + (dom:document-element + (cxml:parse-rod (read-url (link entry)) (cxml-dom:make-dom-builder)))) + (xtm-id (id entry)) + (revision (get-revision))) + ;;that *should* be the algorithm... + ;; If a client has a local topic map that contains topic map + ;; data from more than one server and wants to fetch and update + ;; the latest full topic map from ONE source then it MUST do the + ;; following. Apply the delete topic algorithm from below, but + ;; apply it to the entire topic map. Then proceed in terms of 'A + ;; Clean Start', by fetching the topic map and merging it in + ;; (1b, 1.4.3.2) + (importer-xtm1.0 snapshot-dom :tm-id tm-id :xtm-id xtm-id :revision revision) + entry)))) (defun import-tm-feed (feed-url &optional (processed-feed-urls nil)) - "takes the feed url of a collection feed, imports the first snapshot if -necessary and then applies all fragments to it" + "takes the feed url of a collection feed, processes the dependencies, +imports the first snapshot if necessary and then applies all fragments to it" ;the implementation may be a bit brutal, but relies only on ;guaranteed rel-attributes on the links (let* @@ -146,7 +155,8 @@ (format t "Recursively processing feed ~a~&" dependent-feed-url) (import-tm-feed dependent-feed-url (append processed-feed-urls feed-url))))) - + ;; import a snapshot (if necessary) and the process all fragments more + ;; recent than the snapshot (let ((imported-snapshot-entry (import-snapshots-feed From cludwig at common-lisp.net Sun Feb 1 23:22:26 2009 From: cludwig at common-lisp.net (Christoph Ludwig) Date: Sun, 01 Feb 2009 23:22:26 +0000 Subject: [isidorus-cvs] r14 - trunk/src/rest_interface Message-ID: Author: cludwig Date: Sun Feb 1 23:22:25 2009 New Revision: 14 Log: fix the computation of the most recent already imported snapshot Modified: trunk/src/rest_interface/read.lisp Modified: trunk/src/rest_interface/read.lisp ============================================================================== --- trunk/src/rest_interface/read.lisp (original) +++ trunk/src/rest_interface/read.lisp Sun Feb 1 23:22:25 2009 @@ -101,7 +101,7 @@ (let* ((feed (read-snapshots-feed snapshot-feed-url)) (all-entries (slot-value feed 'atom:entries)) - (most-recent-imported-entry all-entries)) + (most-recent-imported-entry (most-recent-entry all-entries))) (if most-recent-imported-entry most-recent-imported-entry (let*