2 ;;; Inspiration: http://svn.automattic.com/wordpress/trunk/wp-includes/taxonomy.php
4 ;;;; Copyright (c) 2008, Maciej Pasternacki <maciej@pasternacki.net>
5 ;;;; All rights reserved. This file is available on the terms
6 ;;;; detailed in COPYING file included with it.
9 ;;; - Customizable dao table, support table and support function names (common prefix)
11 (defpackage #:trane-taxonomy
12 (:use
#:common-lisp
#:trane-common
#:iterate
#:postmodern
)
13 (:export
#:taxonomy
#:taxonomy-name
#:taxonomy-slug
14 #:item-dao-class
#:valued-taxonomy
15 #:cl-store-valued-taxonomy
#:deftaxonomy
#:ensure-taxonomy
16 #:ensure-term
#:term
#:term-text
17 #:slug
#:term-taxonomy-name
18 #:description
#:term-taxonomy
19 #:id
#:find-terms
#:new-term
#:apply-term
20 #:term-value
#:item-terms
#:order-item-terms
21 #:unbind-term
:term-item-ids
#:term-items
22 #:setup-taxonomy-sql
))
24 (in-package #:trane-taxonomy
)
26 (defvar *taxonomies
* nil
27 "A list of defined taxonomies."
28 ;; It is supposed to be just a few of them, hash table overhead
33 ((name :initarg
:name
:reader taxonomy-name
)
34 (item-dao-class :initarg
:item-dao-class
:reader item-dao-class
))
35 (:documentation
"Base taxonomy class.
37 Taxonomy has a name (symbol or string, which is transformed to a
38 keyword by DEFTAXONOMY), and refers to DAO classes of taxonomy's ITEM.
39 DAO classes are required to have an integer primary key, accessible by
42 (defmethod print-object ((taxonomy taxonomy
) stream
)
43 (print-unreadable-object (taxonomy stream
:type t
:identity t
)
44 (princ (taxonomy-name taxonomy
) stream
)))
46 (defun taxonomy-slug (taxonomy)
47 "Return name of taxonomy for database or URL (lowercased string).
49 Applicable to taxonomy objects, symbols and strings."
50 (string-downcase (string (if (or (stringp taxonomy
)
53 (taxonomy-name taxonomy
)))))
55 (defclass valued-taxonomy
(taxonomy)
56 ((value-encoder-function :initarg
:encoder
:reader value-encoder-function
:initform
#'identity
)
57 (value-decoder-function :initarg
:decoder
:reader value-decoder-function
:initform
#'identity
))
58 (:documentation
"Taxonomy where items applied to terms may have values.
60 Defines encoder and decoder function slots, which are responsible
61 for translating value from a Lisp value to DB-safe string. By
62 default it is identity function, which means values need to be
65 (defun encode-value (taxonomy value
)
66 "Encode VALUE for database, as TAXONOMY specifies.
68 TAXONOMY should be a VALUED-TAXONOMY instance, and VALUE should
69 be any value supported by the taxonomy. When VALUE is NIL, it is
70 encoded as database NULL."
72 (funcall (value-encoder-function taxonomy
)
76 (defun decode-value (taxonomy value
)
77 "Decode VALUE from database, as TAXONOMY specifies.
79 TAXONOMY should be a VALUED-TAXONOMY instance."
80 (unless (eq :null value
)
81 (funcall (value-decoder-function taxonomy
) value
)))
83 (defmacro deftaxonomy
(name (&optional
(class 'taxonomy
)) &rest args
)
84 "Defines taxonomy named NAME, with class CLASS and initargs ARGS, and remembers it in *TAXONOMIES*.
86 NAME is symbol or string, which will be transformed to a keyword anyway."
88 (cons (make-instance ',class
89 :name
,(make-keyword name
)
91 (delete ,(make-keyword name
) *taxonomies
*
92 :key
#'taxonomy-name
))))
94 (defun ensure-taxonomy (taxonomy)
95 "If TAXONOMY is a taxonomy object, return it, otherwise find and return taxonomy named TAXONOMY."
96 (if (subtypep (class-of taxonomy
) (find-class 'taxonomy
))
98 (find (make-keyword taxonomy
) *taxonomies
*
99 :key
#'taxonomy-name
)))
102 ((term-id :col-type serial
:reader id
)
103 (term-text :col-type
(varchar 255) :initarg
:text
:accessor term-text
:documentation
"Full text of term")
104 (term-slug :col-type
(varchar 255) :accessor slug
:documentation
"URL-friendly version of term text, initially chosen by database")
105 (term-taxonomy :col-type
(varchar 32) :col-default
"" :reader term-taxonomy-name
:initarg
:taxonomy-name
:documentation
"Name of term's taxonomy")
106 (term-description :col-type
(or db-null text
) :accessor description
:initarg
:description
:documentation
"Textual description of a term"))
107 (:metaclass dao-class
)
109 (:documentation
"Class for a term associated with taxonomy."))
111 ;;; TODO: pathnames (relative and absolute) as EXECUTE* parameters.
112 (defun setup-taxonomy-sql (&key item
)
113 "List of SQL statements, suitable for TRANE-COMMON:EXECUTE*, to initialize database for Trane Taxonomy module.
115 ITEM is an optional arguments that, if given, specifies foreign key
116 reference on term's associated item_id columns. It can be a DAO
117 class, a symbol naming one, or a list literally specifying S-SQL's
118 foreign key (as for :CREATE-TABLE sql-op :REFERENCES constraint)."
119 (list (dao-table-definition 'term
)
120 `(:alter-table
,(dao-table-name 'term
) :add
:unique term-text term-taxonomy
)
121 `(:alter-table
,(dao-table-name 'term
) :add
:unique term-slug term-taxonomy
)
122 `(:alter-table
,(dao-table-name 'term
) :add
:check
(:raw
"(term_slug SIMILAR TO '[a-z0-9-]+')"))
124 item-term
; FIXME:name
125 ((item-id :type int
,@ (etypecase item
128 `(:references
(,(dao-table-name item
))))
129 (list (cons :references item
))))
130 (term-id :type int
:references
(term))
131 (item-term-value :type
(or db-null text
))
132 (item-term-order :type
(or db-null int
)))
133 (:primary-key item-id term-id
))
135 ;; Create new term. Signals error if term exists.
136 ;; FIXME: count existing slugs starting with new slug
137 "CREATE OR REPLACE FUNCTION new_term(
138 the_text VARCHAR, the_slug VARCHAR, the_taxonomy VARCHAR)
146 INSERT INTO term(term_text, term_slug, term_taxonomy)
147 VALUES (the_text, the_slug, the_taxonomy);
149 WHEN unique_violation THEN
150 SELECT count(*) FROM term WHERE term_slug LIKE the_slug||'%' INTO i;
153 IF i > 999 THEN RAISE EXCEPTION 'Afraid of infinite loop.';
156 INSERT INTO term(term_text, term_slug, term_taxonomy)
157 VALUES (the_text, the_slug||'-'||i, the_taxonomy);
158 EXCEPTION WHEN unique_violation THEN
159 IF POSITION('_slug_' IN SQLERRM) <> 0 THEN CONTINUE; END IF;
160 RAISE EXCEPTION 'Duplicate term. How to re-raise from PL/PgSQL?';
162 EXIT; -- Exit loop when no unique_violation.
165 SELECT INTO res * FROM term WHERE term_id=CURRVAL('term_term_id_seq');
168 $body$ LANGUAGE plpgsql;"
170 ;; Selects or inserts term named `the_text' in taxonomy
171 ;; `the_taxonomy'. Returns found/new term. No support for
172 ;; description or parent for new term, this function is
173 ;; intended to work with simple terms only (e.g. tags).
174 "CREATE OR REPLACE FUNCTION ensure_term(
176 suggested_slug VARCHAR,
177 the_taxonomy VARCHAR)
183 SELECT INTO res * FROM term
184 WHERE term_text=the_text
185 AND term_taxonomy=the_taxonomy;
187 THEN res = new_term(the_text, suggested_slug, the_taxonomy);
191 $body$ LANGUAGE plpgsql;"
193 ;; Sets term value for item (UPDATE or INSERT if needed). When value
194 ;; is NULL, just ensures that an association is established.
195 "CREATE OR REPLACE FUNCTION set_item_term_value(
203 SET item_term_value=the_new_value
204 WHERE item_id=the_item_id AND term_id=the_term_id;
206 INSERT INTO item_term(item_id, term_id, item_term_value)
207 VALUES(the_item_id, the_term_id, the_new_value);
210 $body$ LANGUAGE PLPGSQL;"))
212 (defmethod print-object ((term term
) stream
)
213 (print-unreadable-object (term stream
:type t
:identity t
)
214 (princ (slug term
) stream
)))
216 (defun term-taxonomy (term)
217 "TERM's taxonomy object"
218 (ensure-taxonomy (term-taxonomy-name term
)))
220 (defun ensure-term (taxonomy &key text slug create-p
)
221 "Find or create term in taxonomy TAXONOMY.
223 TEXT is a full text of term; if TEXT is given, CREATE-P is
224 non-NIL and term is not found, new term is inserted into
227 If SLUG is given instead of TEXT, only search is possible, not
229 #+b0rken
(assert (and (or text slug
)
230 (not (and text slug
)))
232 "Either TEXT or SLUG should be given, but not both.")
236 (query-dao 'term
(:select
'* :from
(:ensure-term text
(or slug
(slugify text
)) (taxonomy-slug taxonomy
))))
237 (select-dao 'term
(:and
(:= 'term-text text
)
238 (:= 'term-taxonomy
(taxonomy-slug taxonomy
)))))
241 (warn "CREATE-P is meaningful only with TEXT defined."))
242 (select-dao 'term
(:and
(:= 'term-slug slug
)
243 (:= 'term-taxonomy
(taxonomy-slug taxonomy
))))))))
245 (defun new-term (taxonomy text
&optional parent
)
246 "Create new term in TAXONOMY, with full name TEXT."
247 (first (query-dao 'term
249 (:new-term text
(taxonomy-slug taxonomy
) (if parent
(slug parent
) :null
))))))
251 (defun find-terms-where-clause (&key taxonomy text slug
254 (push (list := 'term-taxonomy
(taxonomy-slug taxonomy
))
258 (push (list := 'term-text text
) query
))
261 (push (list := 'term-slug slug
) query
))
263 (if (> (length query
) 1)
265 (setf query
(first query
)))
269 (defun find-terms (&key taxonomy text slug
)
270 "Find list of terms satisfying given keywords."
272 (sql-compile `(:order-by
(select '* :from
'term
273 :where
,(find-terms-where-clause :taxonomy taxonomy
278 (defun apply-term (item term
&key value order
)
279 "Apply TERM to ITEM, optionally setting its value to VALUE."
280 (query (:insert-into
'item-term
:set
283 'item-term-value
(encode-value (taxonomy term
) value
)
284 'item-term-order
(null-or order
))))
286 (defun term-value (item term
287 &aux
(encoded (query (:select
'item-term-value
'item-term-order
289 :where
(:and
(:= 'item-id
(id item
))
290 (:= 'term-id
(id term
))))
292 "Returns value that association of ITEM and TERM is set to.
294 As a second value returns T if an association was found at all,
295 NIL otherwise. This makes it possible to tell between an
296 association with a NIL value and no association at all.
298 Third value is a term ordering value, if ordering is set."
300 (values (decode-value (taxonomy term
) (first encoded
)) t
(unless-null (second encoded
)))
301 (values nil nil nil
)))
303 (defun (setf term-value
) (new-value item term
)
304 "Set new value for association of ITEM and TERM.
306 New association between ITEM and TERM is established if it was
308 (query (:select
(:set-item-term-value
(id item
) (id term
)
309 (encode-value (taxonomy term
) new-value
)))
312 (defun unbind-term (item term
)
313 "Deletes association between ITEM and TERM.
315 If PURGE-EMPTY is non-NIL (default), deletes also from TERM table if
316 no more items refer to this term."
317 (execute (:delete-from
'item-term
:where
318 (:and
(:= 'item-id
(id item
))
319 (:= 'term-id
(id term
)))))
320 (execute (:delete-from
'term
:where
(:and
(:= 'term-id
(id term
))
321 (:not
(:exists
(:select
'* :from
'item-term
322 :where
(:= 'term-id
(id term
)))))))))
324 (defun item-terms (item &optional taxonomy
)
325 "List TERMs associated with ITEM in given TAXONOMY.
327 If TAXONOMY is not given, returns terms in all taxonomies."
331 (:select
'term.
* :from
'term
'item-term
:where
332 (:and
,@(when taxonomy
335 (taxonomy-slug taxonomy
))))
336 (:= 'item-term.item-id
,(id item
))
337 (:= 'term.term-id
'item-term.term-id
)))
338 'item-term.item-term-order
))))
340 (defun order-case-ssql (column values
)
345 collect
`((:= ,column
,v
) ,i
))
348 (defun order-item-terms (item terms
&key taxonomy null-other-terms
349 &aux
(term-ids (mapcar #'id terms
)))
350 "Set TERMS (a list of terms or term IDs), associated with ITEM, in given order.
352 If NULL-OTHER-TERMS is not NIL, terms not listed in TERMS get their
353 order column set to NULL. If TAXONOMY is given, restrict changes to
354 terms of given taxonomy."
358 :set item-term-order
,(if terms
359 (order-case-ssql 'term-id term-ids
)
361 :where
(:and
(:= 'item-id
,(id item
))
362 ,@(if null-other-terms
364 `((:exists
(:select t
366 :where
(:and
(:= 'term-id
'item-term.term-id
)
368 ,(taxonomy-slug taxonomy
)))))))
369 `((:in
'term-id
(:set
,@term-ids
)))))))))
371 (defun term-item-ids (term)
372 "IDs of items associated with given TERM."
373 (query (:select
'item-id
:from
'item-term
:where
(:= 'term-id
(id term
)))
376 (defun term-items (term &aux
(class (item-dao-class (taxonomy (if (integerp term
) ; FIXME
379 "Items associated with given TERM."
380 (mapcar #'(lambda (id)
382 (term-item-ids term
)))
384 #+cl-trane.taxonomy.use-cl-store
386 (defun store-to-base64 (obj)
387 (base64:usb8-array-to-base64-string
388 (flex:with-output-to-sequence
(s)
389 (cl-store:store obj s
))))
391 (defun restore-from-base64 (b64)
392 (flex:with-input-from-sequence
(s (base64:base64-string-to-usb8-array b64
))
393 (cl-store:restore s
)))
395 (defclass cl-store-valued-taxonomy
(valued-taxonomy)
397 (:default-initargs
:encoder
#'store-to-base64
:decoder
#'restore-from-base64
)
398 (:documentation
"Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string.")))