Commit | Line | Data |
---|---|---|
da26d003 DC |
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 | ||
0386c736 | 10 | |
11 | ||
12 | (defmacro action (args &body body) | |
13 | `(lambda ,args | |
14 | (with-call/cc | |
15 | ,@body))) | |
16 | ||
da26d003 | 17 | ;;;; ** Initialisation |
6f63d3a4 DC |
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 | ||
da26d003 | 50 | ;;;; The following macros are used to initialise a set of database tables as LoL objects. |
b8c89851 | 51 | |
da26d003 | 52 | (eval-when (:compile-toplevel :load-toplevel :execute) |
d5e996b3 | 53 | (defun generate-define-view-for-table (table) |
da26d003 DC |
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 | |
0386c736 | 59 | (def-view-class-from-table ,table) |
60 | (set-default-attributes (quote ,(meta-model::sql->sym table)))))) | |
da26d003 | 61 | |
d5e996b3 | 62 | (defmacro define-view-for-table (&rest tables) |
da26d003 DC |
63 | " expand to a form which initialises TABLES for use with LOL" |
64 | `(progn | |
d5e996b3 | 65 | ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) |
da26d003 DC |
66 | (values))) |
67 | ||
d5e996b3 | 68 | (defmacro define-views-for-database () |
da26d003 | 69 | "expands to init-i-f-t using the listing of tables provided by meta-model" |
d5e996b3 DC |
70 | `(define-view-for-table ,@(meta-model::list-tables))) |
71 | ||
2259a106 | 72 | |
38a016c7 DC |
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 | ||
b890d449 | 85 | |
b890d449 | 86 | |
e8f6e086 | 87 | |
b890d449 | 88 | |
38a016c7 DC |
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) | |
487243db | 100 | (apply #'word-search class-name slots (list s) args)) |
38a016c7 DC |
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 | ||
b890d449 DC |
113 | |
114 |