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