taxonomy: (SETF ITEM-TERMS)
authorMaciej Pasternacki <maciej@pasternacki.net>
Sun, 12 Apr 2009 00:13:33 +0000 (12 02:13 +0200)
committerMaciej Pasternacki <maciej@pasternacki.net>
Sun, 12 Apr 2009 00:13:33 +0000 (12 02:13 +0200)
src/taxonomy.lisp

index ad870bc..bccb8d6 100644 (file)
@@ -367,6 +367,27 @@ If TAXONOMY is not given, returns terms in all taxonomies."
                                (:= 'term.term-id 'item-term.term-id)))
                 'item-term.item-term-order))))
 
+(defun (setf item-terms) (new-terms item &optional taxonomy)
+  "Resets ITEM's terms to NEW-TERMS.  Restricts to terms in TAXONOMY, if needed.
+
+Doesn't touch values or order of terms that are left.  Sets order of
+added terms to NULL."
+  (let* ((old-terms (item-terms item taxonomy))
+         (new-ids (mapcar #'id new-terms))
+         (old-ids (mapcar #'id old-terms))
+         (ids-to-del (set-difference old-ids new-ids))
+         (ids-to-add (set-difference new-ids old-ids)))
+    (with-transaction ()
+      (when ids-to-del
+        (execute (:delete-from 'item-term :where
+                               (:and (:= 'item-id (id item))
+                                     (:in 'term-id (:set ids-to-del))))))
+      (when ids-to-add
+        (execute (:insert-rows-into 'item-term
+                                    :columns 'item-id 'term-id
+                                    :values (loop for id in ids-to-add
+                                               collect (list (id item) id))))))))
+
 (defun order-case-ssql (column values)
   `(:case
        ,@(loop