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 | ||
10 | ;;;; ** Initialisation | |
6f63d3a4 DC |
11 | (defmethod find-default-attributes ((object t)) |
12 | "return the default attributes for a given object using the meta-model's meta-data" | |
13 | (append (mapcar #'(lambda (s) | |
14 | (cons (car s) | |
15 | (gen-pslot | |
16 | (if (meta-model:foreign-key-p object (car s)) | |
17 | 'foreign-key | |
18 | (cadr s)) | |
19 | (string (car s)) (car s)))) | |
20 | (meta-model:list-slot-types object)) | |
21 | (mapcar #'(lambda (s) | |
22 | (cons s (append (gen-pslot 'has-many (string s) s) | |
23 | `(:presentation | |
24 | (make-presentation | |
25 | ,object | |
26 | :type :one-line))))) | |
27 | (meta-model:list-has-many object)) | |
28 | (find-default-presentation-attribute-definitions))) | |
29 | ||
30 | (defmethod set-default-attributes ((object t)) | |
31 | "Set the default attributes for MODEL" | |
32 | (clear-attributes object) | |
33 | (mapcar #'(lambda (x) | |
34 | (setf (find-attribute object (car x)) (cdr x))) | |
35 | (find-default-attributes object))) | |
36 | ||
37 | ;;;; This automagically initialises any meta model | |
38 | ||
39 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
40 | (defmethod meta-model::generate-base-class-expander :after (meta-model name args) | |
41 | (set-default-attributes name))) | |
42 | ||
da26d003 | 43 | ;;;; The following macros are used to initialise a set of database tables as LoL objects. |
b8c89851 | 44 | |
6f63d3a4 DC |
45 | |
46 | ||
da26d003 | 47 | (eval-when (:compile-toplevel :load-toplevel :execute) |
d5e996b3 | 48 | (defun generate-define-view-for-table (table) |
da26d003 DC |
49 | " |
50 | Generates a form that, when evaluated, initialises the given table as an lol object. | |
51 | This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation" | |
52 | ||
53 | `(progn | |
5a4eea11 | 54 | (def-view-class-from-table ,table) |
da26d003 DC |
55 | (set-default-attributes (quote ,(meta-model::sql->sym table)))))) |
56 | ||
d5e996b3 | 57 | (defmacro define-view-for-table (&rest tables) |
da26d003 DC |
58 | " expand to a form which initialises TABLES for use with LOL" |
59 | `(progn | |
d5e996b3 | 60 | ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) |
da26d003 DC |
61 | (values))) |
62 | ||
d5e996b3 | 63 | (defmacro define-views-for-database () |
da26d003 | 64 | "expands to init-i-f-t using the listing of tables provided by meta-model" |
d5e996b3 DC |
65 | `(define-view-for-table ,@(meta-model::list-tables))) |
66 | ||
67 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
b890d449 DC |
68 | (defun %make-view (object type attributes args) |
69 | ||
70 | (when attributes | |
71 | (setf args | |
72 | (cons `(:attributes ,attributes) args))) | |
b8c89851 | 73 | `(mewa::make-presentation |
d5e996b3 DC |
74 | ,object |
75 | :type ,type | |
b890d449 DC |
76 | ,@(when args |
77 | `(:initargs | |
78 | '(,@ (mapcan #'identity args))))))) | |
d5e996b3 | 79 | |
598f1fa8 | 80 | (defmethod make-view (object &rest args &key (type :viewer) |
d5e996b3 | 81 | &allow-other-keys ) |
598f1fa8 DC |
82 | (remf args :type) |
83 | ;(warn "~A ~A" args `(:type ,type :initargs ,@args)) | |
84 | (apply #'make-presentation object `(:type ,type ,@ (when args | |
85 | `(:initargs ,args))))) | |
d5e996b3 | 86 | |
b890d449 | 87 | (defmacro present-view ((object &optional (type :viewer) (parent 'self)) |
d5e996b3 | 88 | &body attributes-and-args) |
b890d449 | 89 | (arnesi:with-unique-names (view) |
b8c89851 | 90 | `(let ((,view (lol::make-view ,object |
b890d449 | 91 | :type ,type |
598f1fa8 DC |
92 | ,@(when (car attributes-and-args) |
93 | `(:attributes ',(car attributes-and-args))) | |
b890d449 DC |
94 | ,@ (cdr attributes-and-args)))) |
95 | (setf (ucw::parent ,view) ,parent) | |
b8c89851 | 96 | (lol::present ,view)))) |
d5e996b3 DC |
97 | |
98 | ||
99 | (defmacro call-view ((object &optional (type :viewer) (component 'self component-supplied-p)) | |
b890d449 | 100 | &body attributes-and-args) |
d5e996b3 DC |
101 | `(ucw:call-component |
102 | ,component | |
b890d449 | 103 | ,(%make-view object type (car attributes-and-args) (cdr attributes-and-args)))) |
d5e996b3 DC |
104 | |
105 | (defmethod slot-view ((self mewa) slot-name) | |
106 | (mewa::find-attribute-slot self slot-name)) | |
107 | ||
108 | (defmethod present-slot-view ((self mewa) slot-name &optional (instance (instance self))) | |
109 | (present-slot (slot-view self slot-name) instance)) | |
110 | ||
38a016c7 | 111 | |
38a016c7 DC |
112 | (defmethod find-slots-of-type (model &key (type 'string) |
113 | (types '((string)) types-supplied-p)) | |
114 | "returns a list of slots matching TYPE, or matching any of TYPES" | |
115 | (let (ty) | |
116 | (if types-supplied-p | |
117 | (setf ty types) | |
118 | (setf ty (list type))) | |
119 | (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) | |
120 | (first st))) | |
121 | (lisp-on-lines::list-slot-types model))))) | |
122 | ||
123 | ||
b890d449 | 124 | |
b890d449 | 125 | |
e8f6e086 | 126 | |
b890d449 | 127 | |
38a016c7 DC |
128 | (defmethod word-search (class-name slots search-terms |
129 | &key (limit 10) (where (sql-and t))) | |
130 | (select class-name | |
131 | :where (sql-and | |
132 | where | |
133 | (word-search-where class-name slots search-terms :format-string "~a%")) | |
134 | :flatp t | |
135 | :limit limit)) | |
136 | ||
137 | ||
138 | (defmethod word-search (class-name slots (s string) &rest args) | |
487243db | 139 | (apply #'word-search class-name slots (list s) args)) |
38a016c7 DC |
140 | |
141 | (defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%")) | |
142 | (sql-or | |
143 | (mapcar #'(lambda (term) | |
144 | (apply #'sql-or | |
145 | (mapcar #'(lambda (slot) | |
146 | (sql-uplike | |
147 | (sql-slot-value class-name slot) | |
148 | (format nil format-string term))) | |
149 | slots))) | |
150 | search-terms))) | |
151 | ||
b890d449 DC |
152 | |
153 |