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 | 45 | |
da26d003 | 46 | (eval-when (:compile-toplevel :load-toplevel :execute) |
d5e996b3 | 47 | (defun generate-define-view-for-table (table) |
da26d003 DC |
48 | " |
49 | Generates a form that, when evaluated, initialises the given table as an lol object. | |
50 | This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation" | |
51 | ||
52 | `(progn | |
5a4eea11 | 53 | (def-view-class-from-table ,table) |
da26d003 DC |
54 | (set-default-attributes (quote ,(meta-model::sql->sym table)))))) |
55 | ||
d5e996b3 | 56 | (defmacro define-view-for-table (&rest tables) |
da26d003 DC |
57 | " expand to a form which initialises TABLES for use with LOL" |
58 | `(progn | |
d5e996b3 | 59 | ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) |
da26d003 DC |
60 | (values))) |
61 | ||
d5e996b3 | 62 | (defmacro define-views-for-database () |
da26d003 | 63 | "expands to init-i-f-t using the listing of tables provided by meta-model" |
d5e996b3 DC |
64 | `(define-view-for-table ,@(meta-model::list-tables))) |
65 | ||
2259a106 DC |
66 | |
67 | ||
68 | ;;;; These are some macros over the old presentation system. | |
69 | ;;;; Considered depreciated, they will eventually be implemented in terms of the new | |
70 | ;;;; display system, and delegated to backwards-compat-0.2.lisp | |
71 | ||
d5e996b3 | 72 | (eval-when (:compile-toplevel :load-toplevel :execute) |
b890d449 DC |
73 | (defun %make-view (object type attributes args) |
74 | ||
2259a106 DC |
75 | (when attributes |
76 | (setf args | |
77 | (cons `(:attributes ,attributes) args))) | |
78 | `(mewa::make-presentation | |
79 | ,object | |
80 | :type ,type | |
81 | ,@(when args | |
82 | `(:initargs | |
83 | '(,@ (mapcan #'identity args))))))) | |
d5e996b3 | 84 | |
598f1fa8 | 85 | (defmethod make-view (object &rest args &key (type :viewer) |
d5e996b3 | 86 | &allow-other-keys ) |
598f1fa8 DC |
87 | (remf args :type) |
88 | ;(warn "~A ~A" args `(:type ,type :initargs ,@args)) | |
89 | (apply #'make-presentation object `(:type ,type ,@ (when args | |
90 | `(:initargs ,args))))) | |
d5e996b3 | 91 | |
b890d449 | 92 | (defmacro present-view ((object &optional (type :viewer) (parent 'self)) |
d5e996b3 | 93 | &body attributes-and-args) |
b890d449 | 94 | (arnesi:with-unique-names (view) |
b8c89851 | 95 | `(let ((,view (lol::make-view ,object |
b890d449 | 96 | :type ,type |
598f1fa8 DC |
97 | ,@(when (car attributes-and-args) |
98 | `(:attributes ',(car attributes-and-args))) | |
b890d449 DC |
99 | ,@ (cdr attributes-and-args)))) |
100 | (setf (ucw::parent ,view) ,parent) | |
b8c89851 | 101 | (lol::present ,view)))) |
d5e996b3 DC |
102 | |
103 | ||
104 | (defmacro call-view ((object &optional (type :viewer) (component 'self component-supplied-p)) | |
b890d449 | 105 | &body attributes-and-args) |
d5e996b3 DC |
106 | `(ucw:call-component |
107 | ,component | |
b890d449 | 108 | ,(%make-view object type (car attributes-and-args) (cdr attributes-and-args)))) |
d5e996b3 DC |
109 | |
110 | (defmethod slot-view ((self mewa) slot-name) | |
111 | (mewa::find-attribute-slot self slot-name)) | |
112 | ||
113 | (defmethod present-slot-view ((self mewa) slot-name &optional (instance (instance self))) | |
14a7e1bc DC |
114 | (let ((v (slot-view self slot-name))) |
115 | ||
116 | (if v | |
117 | (present-slot v instance) | |
118 | (<:as-html slot-name)))) | |
d5e996b3 | 119 | |
38a016c7 | 120 | |
38a016c7 DC |
121 | (defmethod find-slots-of-type (model &key (type 'string) |
122 | (types '((string)) types-supplied-p)) | |
123 | "returns a list of slots matching TYPE, or matching any of TYPES" | |
124 | (let (ty) | |
125 | (if types-supplied-p | |
126 | (setf ty types) | |
127 | (setf ty (list type))) | |
128 | (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) | |
129 | (first st))) | |
130 | (lisp-on-lines::list-slot-types model))))) | |
131 | ||
132 | ||
b890d449 | 133 | |
b890d449 | 134 | |
e8f6e086 | 135 | |
b890d449 | 136 | |
38a016c7 DC |
137 | (defmethod word-search (class-name slots search-terms |
138 | &key (limit 10) (where (sql-and t))) | |
139 | (select class-name | |
140 | :where (sql-and | |
141 | where | |
142 | (word-search-where class-name slots search-terms :format-string "~a%")) | |
143 | :flatp t | |
144 | :limit limit)) | |
145 | ||
146 | ||
147 | (defmethod word-search (class-name slots (s string) &rest args) | |
487243db | 148 | (apply #'word-search class-name slots (list s) args)) |
38a016c7 DC |
149 | |
150 | (defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%")) | |
151 | (sql-or | |
152 | (mapcar #'(lambda (term) | |
153 | (apply #'sql-or | |
154 | (mapcar #'(lambda (slot) | |
155 | (sql-uplike | |
156 | (sql-slot-value class-name slot) | |
157 | (format nil format-string term))) | |
158 | slots))) | |
159 | search-terms))) | |
160 | ||
b890d449 DC |
161 | |
162 |