From: Maciej Pasternacki Date: Wed, 17 Dec 2008 23:24:40 +0000 (+0100) Subject: - drop term-site association, it was wrong idea from the beginning. If it's needed... X-Git-Url: https://repo.or.cz/w/cl-trane.git/commitdiff_plain/21c8e96c156a49f4c7e5fdf96669d2cbe495e3fb - drop term-site association, it was wrong idea from the beginning. If it's needed, it can be resurrected as a subclass. - minor polishing of taxonomy. --- diff --git a/src/taxonomy.lisp b/src/taxonomy.lisp index 87db263..5cd8204 100644 --- a/src/taxonomy.lisp +++ b/src/taxonomy.lisp @@ -10,13 +10,12 @@ (defpackage #:trane-taxonomy (:use #:common-lisp #:trane-common #:iterate #:postmodern) - (:export #:taxonomy #:taxonomy-name #:taxonomy-slug #:site-dao-class - #:item-dao-class #:taxonomy-value-mixin - #:taxonomy-cl-store-value-mixin #:valued-taxonomy + (:export #:taxonomy #:taxonomy-name #:taxonomy-slug + #:item-dao-class #:valued-taxonomy #:cl-store-valued-taxonomy #:deftaxonomy #:ensure-taxonomy #:ensure-term #:term #:term-text - #:slug #:term-site-id #:term-taxonomy-name - #:description #:parent-id #:term-taxonomy #:term-site + #:slug #:term-taxonomy-name + #:description #:term-taxonomy #:id #:find-terms #:new-term #:apply-term #:term-value #:item-terms #:order-item-terms #:unbind-term :term-item-ids #:term-items @@ -32,14 +31,13 @@ (defclass taxonomy () ((name :initarg :name :reader taxonomy-name) - (site-dao-class :initarg :site-dao-class :reader site-dao-class) (item-dao-class :initarg :item-dao-class :reader item-dao-class)) (:documentation "Base taxonomy class. Taxonomy has a name (symbol or string, which is transformed to a -keyword by DEFTAXONOMY), and refers to DAO classes of taxonomy's -SITE and ITEM. DAO classes are required to have an integer -primary key, accessible by reader named ID.")) +keyword by DEFTAXONOMY), and refers to DAO classes of taxonomy's ITEM. +DAO classes are required to have an integer primary key, accessible by +reader named ID.")) (defmethod print-object ((taxonomy taxonomy) stream) (print-unreadable-object (taxonomy stream :type t :identity t) @@ -104,33 +102,24 @@ NAME is symbol or string, which will be transformed to a keyword anyway." ((term-id :col-type serial :reader id) (term-text :col-type (varchar 255) :initarg :text :accessor term-text :documentation "Full text of term") (term-slug :col-type (varchar 255) :accessor slug :documentation "URL-friendly version of term text, initially chosen by database") - (site-id :col-type integer :reader term-site-id :initarg :site-id :documentation "ID of term's site") (term-taxonomy :col-type (varchar 32) :col-default "" :reader term-taxonomy-name :initarg :taxonomy-name :documentation "Name of term's taxonomy") (term-description :col-type (or db-null text) :accessor description :initarg :description :documentation "Textual description of a term")) (:metaclass dao-class) (:keys term-id) - (:documentation "Class for a term associated with taxonomy and a site.")) + (:documentation "Class for a term associated with taxonomy.")) ;;; TODO: pathnames (relative and absolute) as EXECUTE* parameters. -(defun setup-taxonomy-sql (&key site item) +(defun setup-taxonomy-sql (&key item) "List of SQL statements, suitable for TRANE-COMMON:EXECUTE*, to initialize database for Trane Taxonomy module. -SITE and ITEM are optional arguments that, if given, specify foreign -key reference on term's site and associated item_id columns. Any of -those can be a DAO class or a symbol naming one, or a list literally -specifying S-SQL's foreign key (as for :CREATE-TABLE -sql-op :REFERENCES constraint)." +ITEM is an optional arguments that, if given, specifies foreign key +reference on term's associated item_id columns. It can be a DAO +class, a symbol naming one, or a list literally specifying S-SQL's +foreign key (as for :CREATE-TABLE sql-op :REFERENCES constraint)." (list (dao-table-definition 'term) - `(:alter-table ,(dao-table-name 'term) :add :unique term-text site-id term-taxonomy) - `(:alter-table ,(dao-table-name 'term) :add :unique term-slug site-id term-taxonomy) + `(:alter-table ,(dao-table-name 'term) :add :unique term-text term-taxonomy) + `(:alter-table ,(dao-table-name 'term) :add :unique term-slug term-taxonomy) `(:alter-table ,(dao-table-name 'term) :add :check (:raw "(term_slug SIMILAR TO '[a-z0-9-]+')")) - (when site - `(:alter-table ,(dao-table-name 'term) :add :foreign-key (site-id) - ,@ (etypecase site - ((or symbol class) - (list (dao-table-name site))) - (list site)))) - `(:create-table item-term ; FIXME:name ((item-id :type int ,@ (etypecase item @@ -146,7 +135,7 @@ sql-op :REFERENCES constraint)." ;; Create new term. Signals error if term exists. ;; FIXME: count existing slugs starting with new slug "CREATE OR REPLACE FUNCTION new_term( - the_text VARCHAR, the_slug VARCHAR, the_site_id INTEGER, the_taxonomy VARCHAR) + the_text VARCHAR, the_slug VARCHAR, the_taxonomy VARCHAR) RETURNS term AS $body$ DECLARE @@ -154,8 +143,8 @@ DECLARE i INTEGER; BEGIN BEGIN - INSERT INTO term(term_text, term_slug, site_id, term_taxonomy) - VALUES (the_text, the_slug, the_site_id, the_taxonomy); + INSERT INTO term(term_text, term_slug, term_taxonomy) + VALUES (the_text, the_slug, the_taxonomy); EXCEPTION WHEN unique_violation THEN SELECT count(*) FROM term WHERE term_slug LIKE the_slug||'%' INTO i; @@ -164,8 +153,8 @@ BEGIN IF i > 999 THEN RAISE EXCEPTION 'Afraid of infinite loop.'; END IF; BEGIN - INSERT INTO term(term_text, term_slug, site_id, term_taxonomy) - VALUES (the_text, the_slug||'-'||i, the_site_id, the_taxonomy); + INSERT INTO term(term_text, term_slug, term_taxonomy) + VALUES (the_text, the_slug||'-'||i, the_taxonomy); EXCEPTION WHEN unique_violation THEN IF POSITION('_slug_' IN SQLERRM) <> 0 THEN CONTINUE; END IF; RAISE EXCEPTION 'Duplicate term. How to re-raise from PL/PgSQL?'; @@ -178,16 +167,13 @@ BEGIN END; $body$ LANGUAGE plpgsql;" - ;; Selects or inserts term named `the_text' for site `the_site_id' in - ;; taxonomy `the_taxonomy'. Returns found/new term. No support for - ;; description or parent for new term, this function is intended to - ;; work with simple terms only (e.g. tags). + ;; Selects or inserts term named `the_text' in taxonomy + ;; `the_taxonomy'. Returns found/new term. No support for + ;; description or parent for new term, this function is + ;; intended to work with simple terms only (e.g. tags). "CREATE OR REPLACE FUNCTION ensure_term( the_text VARCHAR, suggested_slug VARCHAR, - the_site_id INTEGER, -- CUSTOMIZE? function with the_site - -- VARCHAR which selects id by slug - -- and calls this one the_taxonomy VARCHAR) RETURNS term AS $body$ @@ -196,10 +182,9 @@ DECLARE BEGIN SELECT INTO res * FROM term WHERE term_text=the_text - AND site_id=the_site_id AND term_taxonomy=the_taxonomy; IF NOT FOUND - THEN res = new_term(the_text, suggested_slug, the_site_id, the_taxonomy); + THEN res = new_term(the_text, suggested_slug, the_taxonomy); END IF; RETURN res; END; @@ -228,18 +213,12 @@ $body$ LANGUAGE PLPGSQL;")) (print-unreadable-object (term stream :type t :identity t) (princ (slug term) stream))) -(defun taxonomy (term) +(defun term-taxonomy (term) "TERM's taxonomy object" (ensure-taxonomy (term-taxonomy-name term))) -(defun term-site (term) - "TERM's site object, if TERM is associated with a SITE." - (let ((id (term-site-id term))) - (when id - (get-dao (site-dao-class (taxonomy term)) id)))) - -(defun ensure-term (taxonomy site &key text slug create-p) - "Find or create term in taxonomy TAXONOMY for site SITE. +(defun ensure-term (taxonomy &key text slug create-p) + "Find or create term in taxonomy TAXONOMY. TEXT is a full text of term; if TEXT is given, CREATE-P is non-NIL and term is not found, new term is inserted into @@ -254,33 +233,27 @@ creation." (first (if text (if create-p - (query-dao 'term (:select '* :from (:ensure-term text (or slug (slugify text)) (id site) (taxonomy-slug taxonomy)))) + (query-dao 'term (:select '* :from (:ensure-term text (or slug (slugify text)) (taxonomy-slug taxonomy)))) (select-dao 'term (:and (:= 'term-text text) - (:= 'site-id (id site)) (:= 'term-taxonomy (taxonomy-slug taxonomy))))) (progn (when create-p (warn "CREATE-P is meaningful only with TEXT defined.")) (select-dao 'term (:and (:= 'term-slug slug) - (:= 'site-id (id site)) (:= 'term-taxonomy (taxonomy-slug taxonomy)))))))) -(defun new-term (taxonomy site text &optional parent) - "Create new term in SITE for TAXONOMY, with full name TEXT." +(defun new-term (taxonomy text &optional parent) + "Create new term in TAXONOMY, with full name TEXT." (first (query-dao 'term (:select '* :from - (:new-term text (id site) (taxonomy-slug taxonomy) (if parent (slug parent) :null)))))) + (:new-term text (taxonomy-slug taxonomy) (if parent (slug parent) :null)))))) -(defun find-terms-where-clause (&key taxonomy site text slug +(defun find-terms-where-clause (&key taxonomy text slug &aux (query ())) (when taxonomy (push (list := 'term-taxonomy (taxonomy-slug taxonomy)) query)) - (when site - (push (list := 'site-id (id site)) - query)) - (when text (push (list := 'term-text text) query)) @@ -293,12 +266,11 @@ creation." query) -(defun find-terms (&key taxonomy site text slug) +(defun find-terms (&key taxonomy text slug) "Find list of terms satisfying given keywords." (query-dao 'term (sql-compile `(:order-by (select '* :from 'term :where ,(find-terms-where-clause :taxonomy taxonomy - :site site :text text :slug slug)) 'term-text))))