| 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 | |
| 11 | |
| 12 | (defmacro action (args &body body) |
| 13 | `(lambda ,args |
| 14 | (with-call/cc |
| 15 | ,@body))) |
| 16 | |
| 17 | ;;;; ** Initialisation |
| 18 | (defmethod find-default-attributes ((object t)) |
| 19 | "return the default attributes for a given object using the meta-model's meta-data" |
| 20 | (append (mapcar #'(lambda (s) |
| 21 | (cons (car s) |
| 22 | (gen-pslot |
| 23 | (if (meta-model:foreign-key-p object (car s)) |
| 24 | 'foreign-key |
| 25 | (cadr s)) |
| 26 | (string (car s)) (car s)))) |
| 27 | (meta-model:list-slot-types object)) |
| 28 | (mapcar #'(lambda (s) |
| 29 | (cons s (append (gen-pslot 'has-many (string s) s) |
| 30 | `(:presentation |
| 31 | (make-presentation |
| 32 | ,object |
| 33 | :type :one-line))))) |
| 34 | (meta-model:list-has-many object)) |
| 35 | (find-default-presentation-attribute-definitions))) |
| 36 | |
| 37 | (defmethod set-default-attributes ((object t)) |
| 38 | "Set the default attributes for MODEL" |
| 39 | (clear-attributes object) |
| 40 | (mapcar #'(lambda (x) |
| 41 | (setf (find-attribute object (car x)) (cdr x))) |
| 42 | (find-default-attributes object))) |
| 43 | |
| 44 | ;;;; This automagically initialises any meta model |
| 45 | |
| 46 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 47 | (defmethod meta-model::generate-base-class-expander :after (meta-model name args) |
| 48 | (set-default-attributes name))) |
| 49 | |
| 50 | ;;;; The following macros are used to initialise a set of database tables as LoL objects. |
| 51 | |
| 52 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 53 | (defun generate-define-view-for-table (table) |
| 54 | " |
| 55 | Generates a form that, when evaluated, initialises the given table as an lol object. |
| 56 | This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation" |
| 57 | |
| 58 | `(progn |
| 59 | (rofl::gen-view-class ,table :generate-joins :all) |
| 60 | (set-default-attributes (quote ,(meta-model::sql->sym table)))))) |
| 61 | |
| 62 | (defmacro define-view-for-table (&rest tables) |
| 63 | " expand to a form which initialises TABLES for use with LOL" |
| 64 | `(progn |
| 65 | ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) |
| 66 | (values))) |
| 67 | |
| 68 | (defmacro define-views-for-database () |
| 69 | "expands to init-i-f-t using the listing of tables provided by meta-model" |
| 70 | `(define-view-for-table ,@(meta-model::list-tables))) |
| 71 | |
| 72 | |
| 73 | (defmethod find-slots-of-type (model &key (type 'string) |
| 74 | (types '((string)) types-supplied-p)) |
| 75 | "returns a list of slots matching TYPE, or matching any of TYPES" |
| 76 | (let (ty) |
| 77 | (if types-supplied-p |
| 78 | (setf ty types) |
| 79 | (setf ty (list type))) |
| 80 | (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) |
| 81 | (first st))) |
| 82 | (lisp-on-lines::list-slot-types model))))) |
| 83 | |
| 84 | |
| 85 | |
| 86 | |
| 87 | |
| 88 | |
| 89 | (defmethod word-search (class-name slots search-terms |
| 90 | &key (limit 10) (where (sql-and t))) |
| 91 | (select class-name |
| 92 | :where (sql-and |
| 93 | where |
| 94 | (word-search-where class-name slots search-terms :format-string "~a%")) |
| 95 | :flatp t |
| 96 | :limit limit)) |
| 97 | |
| 98 | |
| 99 | (defmethod word-search (class-name slots (s string) &rest args) |
| 100 | (apply #'word-search class-name slots (list s) args)) |
| 101 | |
| 102 | (defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%")) |
| 103 | (sql-or |
| 104 | (mapcar #'(lambda (term) |
| 105 | (apply #'sql-or |
| 106 | (mapcar #'(lambda (slot) |
| 107 | (sql-uplike |
| 108 | (sql-slot-value class-name slot) |
| 109 | (format nil format-string term))) |
| 110 | slots))) |
| 111 | search-terms))) |
| 112 | |
| 113 | |
| 114 | |