src/lisp-on-lines.lisp

(in-package :lisp-on-lines)

;;;; *LoL Entry points
;;;;

;;;; This file contains the high level functions and macros
;;;; that are part of LoL proper, that is to say, not Mewa
;;;; or Meta-Model.

;;;; ** Initialisation
;;;; The following macros are used to initialise a set of database tables as LoL objects.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun generate-initialize-lol-for-table (table)
    "
Generates a form that, when evaluated, initialises the given table as an lol object.
This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation"

    `(progn
      (def-view-class-from-table ,table)
      (set-default-attributes (quote ,(meta-model::sql->sym table))))))

(defmacro initialize-lol-for-table (&rest tables)
  " expand to a form which initialises TABLES for use with LOL"
  `(progn
    ,@(loop for tbl in tables collect (generate-initialize-lol-for-table tbl))
    (values)))

(defmacro initialize-lol-for-database ()
  "expands to init-i-f-t using the listing of tables provided by meta-model"
  `(initialize-lol-for-table ,@(meta-model::list-tables)))

;;;; * AJAX stuff

;;;; TODO: This search stuff should probably me refactored elsewhere

(defmethod find-slots-of-type (model &key (type 'string)
			      (types '((string)) types-supplied-p))
  "returns a list of slots matching TYPE, or matching any of TYPES"
  (let (ty)
    (if types-supplied-p
	(setf ty types)
	(setf ty (list type)))
    (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
					 (first st)))
	     (lisp-on-lines::list-slot-types model)))))


(defmethod word-search (class-name slots search-terms
			&key (limit 10) (where (sql-and t)))
  (select class-name
	  :where (sql-and
		  where
		  (word-search-where class-name slots search-terms :format-string "~a%"))
			   :flatp t
			   :limit limit))


(defmethod word-search (class-name slots (s string) &rest args)
  (apply #'word-search class-name slots
	 (split-sequence:split-sequence #\Space s) args))

(defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%"))
  (sql-or
   (mapcar #'(lambda (term)
	       (apply #'sql-or
		      (mapcar #'(lambda (slot)
				  (sql-uplike
				   (sql-slot-value class-name slot)
				   (format nil format-string  term)))
			      slots)))
	   search-terms)))
Commit	Line	Data
	1	(in-package :lisp-on-lines)
	2
	3	;;;; *LoL Entry points
	4	;;;;
	5
	6	;;;; This file contains the high level functions and macros
	7	;;;; that are part of LoL proper, that is to say, not Mewa
	8	;;;; or Meta-Model.
	9
	10	;;;; ** Initialisation
	11	;;;; The following macros are used to initialise a set of database tables as LoL objects.
	12	(eval-when (:compile-toplevel :load-toplevel :execute)
	13	(defun generate-initialize-lol-for-table (table)
	14	"
	15	Generates a form that, when evaluated, initialises the given table as an lol object.
	16	This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation"
	17
	18	`(progn
	19	(def-view-class-from-table ,table)
	20	(set-default-attributes (quote ,(meta-model::sql->sym table))))))
	21
	22	(defmacro initialize-lol-for-table (&rest tables)
	23	" expand to a form which initialises TABLES for use with LOL"
	24	`(progn
	25	,@(loop for tbl in tables collect (generate-initialize-lol-for-table tbl))
	26	(values)))
	27
	28	(defmacro initialize-lol-for-database ()
	29	"expands to init-i-f-t using the listing of tables provided by meta-model"
	30	`(initialize-lol-for-table ,@(meta-model::list-tables)))
	31
	32	;;;; * AJAX stuff
	33
	34	;;;; TODO: This search stuff should probably me refactored elsewhere
	35
	36	(defmethod find-slots-of-type (model &key (type 'string)
	37	(types '((string)) types-supplied-p))
	38	"returns a list of slots matching TYPE, or matching any of TYPES"
	39	(let (ty)
	40	(if types-supplied-p
	41	(setf ty types)
	42	(setf ty (list type)))
	43	(remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
	44	(first st)))
	45	(lisp-on-lines::list-slot-types model)))))
	46
	47
	48	(defmethod word-search (class-name slots search-terms
	49	&key (limit 10) (where (sql-and t)))
	50	(select class-name
	51	:where (sql-and
	52	where
	53	(word-search-where class-name slots search-terms :format-string "~a%"))
	54	:flatp t
	55	:limit limit))
	56
	57
	58	(defmethod word-search (class-name slots (s string) &rest args)
	59	(apply #'word-search class-name slots
	60	(split-sequence:split-sequence #\Space s) args))
	61
	62	(defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%"))
	63	(sql-or
	64	(mapcar #'(lambda (term)
	65	(apply #'sql-or
	66	(mapcar #'(lambda (slot)
	67	(sql-uplike
	68	(sql-slot-value class-name slot)
	69	(format nil format-string term)))
	70	slots)))
	71	search-terms)))
	72