Ignore:
Timestamp:
02/25/10 19:20:51 (15 years ago)
Author:
lgiessmann
Message:

new-datamodel: added some unit-tests for add-reifier, reifier and delete-reifier; fixed alos msome problems in these functions; changed some key-parameters --> (reivision 0) was changed to (revision *TM-REVISION*) in all adder-functions, e.g. add-psi

Location:
branches/new-datamodel/src
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • TabularUnified branches/new-datamodel/src/model/datamodel.lisp

    r206 r207  
    9595
    9696
     97;;TODO: finalize add-reifier
    9798;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
    9899;;      initarg in make-construct
    … …  
    254255                     :documentation "A relation to all item-identifiers of
    255256                                     this construct.")
    256    (reifier :associate (ReifierAssociationC reified-construct)
     257   (reifier :associate (ReifierAssociationC reifiable-construct)
    257258            :inherit t
    258259            :documentation "A relation to a reifier-topic."))
    … …  
    317318                                  topic that is a theme with its scoppable
    318319                                  object.")
    319    (reified-construct :associate (ReifiedAssociationC reifier-topic)
     320   (reified-construct :associate (ReifierAssociationC reifier-topic)
    320321                      :documentation "Contains all association objects that
    321322                                      relate a topic that is a reifier with
    … …  
    412413                        :associate ReifiableConstructC
    413414                        :documentation "The actual construct which is reified
    414                                       by a topic.")
     415                                        by a topic.")
    415416   (reifier-topic :initarg :reifier-topic
    416417                  :accessor reifier-topic
    … …  
    787788                   the identified-constructs are merged.")
    788789  (:method ((construct TopicC) (topic-identifier TopicIdentificationC)
    789             &key (revision 0))
     790            &key (revision *TM-REVISION*))
    790791    (let ((all-ids
    791792           (map 'list #'identifier (slot-p construct 'topic-identifiers)))
    … …  
    841842                   the identified-constructs are merged.")
    842843  (:method ((construct TopicC) (psi PersistentIdC)
    843             &key (revision 0))
     844            &key (revision *TM-REVISION*))
    844845    (let ((all-ids
    845846           (map 'list #'identifier (slot-p construct 'psis)))
    … …  
    894895                   the identified-constructs are merged.")
    895896  (:method ((construct TopicC) (locator SubjectLocatorC)
    896             &key (revision 0))
     897            &key (revision *TM-REVISION*))
    897898    (let ((all-ids
    898899           (map 'list #'identifier (slot-p construct 'locators)))
    … …  
    947948                   an error is thrown.")
    948949  (:method ((construct TopicC) (name NameC)
    949             &key (revision 0))
     950            &key (revision *TM-REVISION*))
    950951    (when (not (eql (parent name) construct))
    951952      (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
    … …  
    960961                               return name-assoc)))
    961962            (add-to-version-history name-assoc :start-revision revision))
    962           (make-instance 'NameAssociationC
    963                          :start-revision revision
    964                          :parent-construct construct
    965                          :characteristic name))
    966       construct)))
     963          (let ((assoc
     964                 (make-instance 'NameAssociationC
     965                                :parent-construct construct
     966                                :characteristic name)))
     967            (add-to-version-history assoc :start-revision revision))))
     968    construct))
    967969
    968970
    … …  
    996998                   an error is thrown.")
    997999  (:method ((construct TopicC) (occurrence OccurrenceC)
    998             &key (revision 0))
     1000            &key (revision *TM-REVISION*))
    9991001    (when (not (eql (parent occurrence) construct))
    10001002      (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
    … …  
    10091011                              return occ-assoc)))
    10101012            (add-to-version-history occ-assoc :start-revision revision))
    1011           (make-instance 'OccurrenceAssociationC
    1012                          :start-revision revision
    1013                          :parent-construct construct
    1014                          :characteristic occurrence))
    1015       construct)))
     1013          (let ((assoc
     1014                 (make-instance 'OccurrenceAssociationC
     1015                                :parent-construct construct
     1016                                :characteristic occurrence)))
     1017            (add-to-version-history assoc :start-revision revision))))
     1018    construct))
    10161019
    10171020
    … …  
    10621065    (let ((assocs (filter-slot-value-by-revision
    10631066                   construct 'reified-construct :start-revision revision)))
    1064       (map 'list #'reifiable-construct assocs))))
     1067      (when assocs
     1068        (reifiable-construct (first assocs))))))
    10651069
    10661070
    … …  
    11851189                   scopable-construct.")
    11861190  (:method ((construct NameC) (variant VariantC)
    1187             &key (revision 0))
     1191            &key (revision *TM-REVISION*))
    11881192    (when (not (eql (parent variant) construct))
    11891193      (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
    … …  
    11991203                    return variant-assoc)))
    12001204            (add-to-version-history variant-assoc :start-revision revision))
    1201           (make-instance 'VariantAssociationC
    1202                          :start-revision revision
    1203                          :characteristic variant
    1204                          :parent-construct construct)))
     1205          (let ((assoc
     1206                 (make-instance 'VariantAssociationC
     1207                                :characteristic variant
     1208                                :parent-construct construct)))
     1209            (add-to-version-history assoc :start-revision revision))))
    12051210    construct))
    12061211
    … …  
    12511256
    12521257(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
    1253                        &key (revision 0))
     1258                       &key (revision *TM-REVISION*))
    12541259  (let ((already-set-topic
    12551260           (map 'list #'parent-construct
    … …  
    12651270               (add-to-version-history parent-assoc :start-revision revision)))
    12661271            ((not already-set-topic)
    1267              (make-instance (if (typep construct 'OccurrenceC)
    1268                                 'OccurrenceAssociationC
    1269                                 'NameAssociationC)
    1270                             :start-revision revision
    1271                             :parent-construct parent-construct
    1272                             :characteristic construct))
     1272             (let ((assoc
     1273                    (make-instance (if (typep construct 'OccurrenceC)
     1274                                       'OccurrenceAssociationC
     1275                                       'NameAssociationC)
     1276                                   :parent-construct parent-construct
     1277                                   :characteristic construct)))
     1278               (add-to-version-history assoc :start-revision revision)))
    12731279            (t
    12741280             (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
    … …  
    12781284
    12791285(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
    1280                        &key (revision 0))
     1286                       &key (revision *TM-REVISION*))
    12811287  (let ((already-set-name
    12821288           (map 'list #'characteristic
    … …  
    12911297               (add-to-version-history parent-assoc :start-revision revision)))
    12921298            ((not already-set-name)
    1293              (make-instance 'VariantAssociationC
    1294                             :start-revision revision
    1295                             :parent-construct parent-construct
    1296                             :characteristic construct))
     1299             (let ((assoc
     1300                    (make-instance 'VariantAssociationC
     1301                                   :parent-construct parent-construct
     1302                                   :characteristic construct)))
     1303               (add-to-version-history assoc :start-revision revision)))
    12971304            (t
    12981305             (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
    … …  
    14491456  (:documentation "Adds the given role to the passed association-construct.")
    14501457  (:method ((construct AssociationC) (role RoleC)
    1451             &key (revision 0))
     1458            &key (revision *TM-REVISION*))
    14521459    (let ((all-roles
    14531460           (map 'list #'role
    … …  
    14591466                    return role-assoc)))
    14601467            (add-to-version-history role-assoc  :start-revision revision))
    1461           (make-instance 'RoleAssociationC
    1462                          :start-revision revision
    1463                          :role role
    1464                          :association construct)))
     1468          (let ((assoc
     1469                 (make-instance 'RoleAssociationC
     1470                                :role role
     1471                                :association construct)))
     1472            (add-to-version-history assoc :start-revision revision))))
    14651473    construct))
    14661474
    … …  
    15021510
    15031511(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
    1504                             &key (revision 0))
     1512                            &key (revision *TM-REVISION*))
    15051513  (let ((already-set-parent
    15061514           (map 'list #'parent
    … …  
    15161524               (add-to-version-history parent-assoc :start-revision revision)))
    15171525            ((not already-set-parent)
    1518              (make-instance 'RoleAssociationC
    1519                             :start-revision revision
    1520                             :role construct
    1521                             :parent-construct parent-construct))
     1526             (let ((assoc (make-instance 'RoleAssociationC
     1527                                         :role construct
     1528                                         :parent-construct parent-construct)))
     1529               (add-to-version-history assoc :start-revision revision)))
    15221530            (t
    15231531             (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a"
    … …  
    15511559  (:documentation "Adds a topic as a player to a role in the given revision.")
    15521560  (:method ((construct RoleC) (player-topic TopicC)
    1553             &key (revision 0))
     1561            &key (revision *TM-REVISION*))
    15541562    (let ((already-set-player
    15551563           (map 'list #'player-topic
    … …  
    15641572               (add-to-version-history player-assoc :start-revision revision)))
    15651573            ((not already-set-player)
    1566              (make-instance 'PlayerAssociationC
    1567                             :start-revision revision
    1568                             :parent-construct construct
    1569                             :player-topic player-topic))
     1574             (let ((assoc (make-instance 'PlayerAssociationC
     1575                                         :parent-construct construct
     1576                                         :player-topic player-topic)))
     1577               (add-to-version-history assoc :start-revision revision)))
    15701578            (t
    15711579             (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a"
    … …  
    16031611  (:method ((construct ReifiableConstructC) &key (revision 0))
    16041612    (let ((assocs (filter-slot-value-by-revision
    1605                    construct 'item-identifiers :start-revision revision)))
     1613                   construct 'reifier :start-revision revision)))
    16061614      (when assocs ;assocs must be nil or a list with exactly one item
    1607         (reifier (first assocs))))))
     1615        (reifier-topic (first assocs))))))
    16081616
    16091617
    … …  
    16251633                   the identified-constructs are merged.")
    16261634  (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
    1627             &key (revision 0))
     1635            &key (revision *TM-REVISION*))
    16281636    (let ((all-ids
    16291637           (map 'list #'identifier (slot-p construct 'item-identifiers)))
    … …  
    16701678                   the reified-constructs are merged.")
    16711679  (:method ((construct ReifiableConstructC) (reifier-topic TopicC)
    1672             &key (revision 0))
     1680            &key (revision *TM-REVISION*))
    16731681    (let ((merged-reifier-topic
    1674            (when (reifier construct)
    1675              (merge-constructs (reifier construct) reifier-topic))))
     1682           (if (reifier construct)
     1683               (merge-constructs (reifier construct) reifier-topic)
     1684               reifier-topic)))
    16761685      (let ((all-constructs
    1677              (remove-if #'marked-as-deleted-p
    1678                         (slot-p reifier-topic 'reified-construct))))
     1686             (let ((inner-construct (reified-construct merged-reifier-topic
     1687                                                       :revision revision)))
     1688               (when inner-construct
     1689                 (list inner-construct)))))
    16791690        (cond ((find construct all-constructs)
    16801691               (let ((reifier-assoc
    … …  
    16891700               (merge-constructs (first all-constructs) construct))
    16901701              (t
    1691                (make-instance 'ReifierAssociationC
    1692                               :start-revision revision
    1693                               :reifiable-construct construct
    1694                               :reifier-topic merged-reifier-topic)
    1695                construct))))))
     1702               (let ((assoc
     1703                      (make-instance 'ReifierAssociationC
     1704                                     :reifiable-construct construct
     1705                                     :reifier-topic merged-reifier-topic)))
     1706                 (add-to-version-history assoc :start-revision revision))))
     1707        construct))))
    16961708
    16971709
    … …  
    17301742                   scopable-construct.")
    17311743  (:method ((construct ScopableC) (theme-topic TopicC)
    1732             &key (revision 0))
     1744            &key (revision *TM-REVISION*))
    17331745    (let ((all-themes
    17341746           (map 'list #'theme-topic
    … …  
    17401752                    return theme-assoc)))
    17411753            (add-to-version-history theme-assoc  :start-revision revision))
    1742           (make-instance 'ScopeAssociationC
    1743                          :start-revision revision
    1744                          :theme-topic theme-topic
    1745                          :scopable-construct construct)))
     1754          (let ((assoc
     1755                 (make-instance 'ScopeAssociationCn
     1756                                :theme-topic theme-topic
     1757                                :scopable-construct construct)))
     1758            (add-to-version-history assoc :start-revision revision))))
    17461759    construct))
    17471760
    … …  
    17831796                   set at the same revision.")
    17841797  (:method ((construct TypableC) (type-topic TopicC)
    1785             &key (revision 0))
     1798            &key (revision *TM-REVISION*))
    17861799    (let ((already-set-type
    17871800           (map 'list #'type-topic
    … …  
    17961809               (add-to-version-history type-assoc :start-revision revision)))
    17971810            ((not already-set-type)
    1798              (make-instance 'TypeAssociationC
    1799                             :start-revision revision
    1800                             :type-topic type-topic
    1801                             :typable-construct construct))
     1811             (let ((assoc
     1812                    (make-instance 'TypeAssociationC
     1813                                   :type-topic type-topic
     1814                                   :typable-construct construct)))
     1815               (add-to-version-history assoc :start-revision revision)))
    18021816            (t
    18031817             (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a"
    … …  
    18321846
    18331847;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1834 (defgeneric merge-constructs(construc-1 construct-2 &key revision)
     1848(defgeneric merge-constructs(construct-1 construct-2 &key revision)
    18351849  (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
    1836             &key (revision 0))
    1837     (or construct-1 construct-2 revision)))
     1850            &key (revision *TM-REVISION*))
     1851    (or revision)
     1852    (if construct-1 construct-1 construct-2)))
    18381853
    18391854

  • TabularUnified branches/new-datamodel/src/unit_tests/datamodel_test.lisp

    r206 r207  
    2727           :test-get-item-by-item-identifier
    2828           :test-get-item-by-locator
    29            :test-get-item-by-psi))
    30 
    31 
    32 ;;TODO: test merges-constructs when merging was caused by an item-dentifier
    33 ;;TODO: test merges-constructs when merging was caused by an psi
    34 ;;TODO: test merges-constructs when merging was caused by an subject-locator
    35 ;;TODO: test merges-constructs when merging was caused by a topic-id
     29           :test-get-item-by-psi
     30           :test-ReifiableConstructC))
     31
     32
     33;;TODO: test delete-construct
     34;;TODO: test merge-constructs when merging was caused by an item-dentifier
     35;;TODO: test merge-constructs when merging was caused by an psi
     36;;TODO: test merge-constructs when merging was caused by an subject-locator
     37;;TODO: test merge-constructs when merging was caused by a topic-id
     38;;TODO: test merge-constructs when merging was caused by reifiers
     39;;      (occurrences, names, variants, associations, roles)
     40;;TODO: test ReifiableConstructC --> reifier has to be merged
    3641
    3742
    … …  
    368373
    369374(test test-get-item-by-item-identifier ()
    370     "Tests the function test-get-item-by-id."
     375    "Tests the function test-get-item-by-item-identifier."
    371376    (with-fixture with-empty-db (*db-dir*)
    372377      (let ((ii-1 (make-instance 'ItemIdentifierC
    … …  
    410415
    411416(test test-get-item-by-locator ()
    412     "Tests the function test-get-item-by-id."
     417    "Tests the function test-get-item-by-locator."
    413418    (with-fixture with-empty-db (*db-dir*)
    414419      (let ((sl-1 (make-instance 'SubjectLocatorC
    … …  
    452457
    453458(test test-get-item-by-psi ()
    454     "Tests the function test-get-item-by-id."
     459    "Tests the function test-get-item-by-psi."
    455460    (with-fixture with-empty-db (*db-dir*)
    456461      (let ((psi-1 (make-instance 'PersistentIdC
    … …  
    493498
    494499
     500(test test-ReifiableConstructC ()
     501    "Tests variuas functions of the ReifialeConstructC."
     502    (with-fixture with-empty-db (*db-dir*)
     503      (let ((reifier-top (make-instance 'TopicC))
     504            (reified-rc (make-instance 'd::ReifiableConstructC)))
     505        (is-false (reifier reified-rc))
     506        (is-false (reified-construct reifier-top))
     507        (add-reifier reified-rc reifier-top :revision 100)
     508        (is (eql reifier-top (reifier reified-rc)))
     509        (is (eql reified-rc (reified-construct reifier-top)))
     510        (is (eql reifier-top (reifier reified-rc :revision 200)))
     511        (is (eql reified-rc (reified-construct reifier-top :revision 200)))
     512        (is-false (reifier reified-rc :revision 50))
     513        (is-false (reified-construct reifier-top :revision 50)))))
     514
     515
    495516(defun run-datamodel-tests()
    496517  (it.bese.fiveam:run! 'test-VersionInfoC)
    … …  
    504525  (it.bese.fiveam:run! 'test-get-item-by-locator)
    505526  (it.bese.fiveam:run! 'test-get-item-by-psi)
     527  (it.bese.fiveam:run! 'test-ReifiableConstructC)
    506528)
Note: See TracChangeset for help on using the changeset viewer.