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. | |
12 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
d5e996b3 | 13 | (defun generate-define-view-for-table (table) |
da26d003 DC |
14 | " |
15 | Generates a form that, when evaluated, initialises the given table as an lol object. | |
16 | This involves creating a meta-model, a clsql view-class, and the setting up the default attributes for a mewa presentation" | |
17 | ||
18 | `(progn | |
5a4eea11 | 19 | (def-view-class-from-table ,table) |
da26d003 DC |
20 | (set-default-attributes (quote ,(meta-model::sql->sym table)))))) |
21 | ||
d5e996b3 | 22 | (defmacro define-view-for-table (&rest tables) |
da26d003 DC |
23 | " expand to a form which initialises TABLES for use with LOL" |
24 | `(progn | |
d5e996b3 | 25 | ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) |
da26d003 DC |
26 | (values))) |
27 | ||
d5e996b3 | 28 | (defmacro define-views-for-database () |
da26d003 | 29 | "expands to init-i-f-t using the listing of tables provided by meta-model" |
d5e996b3 DC |
30 | `(define-view-for-table ,@(meta-model::list-tables))) |
31 | ||
32 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
b890d449 DC |
33 | (defun %make-view (object type attributes args) |
34 | ||
35 | (when attributes | |
36 | (setf args | |
37 | (cons `(:attributes ,attributes) args))) | |
d5e996b3 DC |
38 | `(mewa:make-presentation |
39 | ,object | |
40 | :type ,type | |
b890d449 DC |
41 | ,@(when args |
42 | `(:initargs | |
43 | '(,@ (mapcan #'identity args))))))) | |
d5e996b3 DC |
44 | |
45 | (defmethod make-view (object &rest args &key (type :viewer) (attributes nil) | |
46 | &allow-other-keys ) | |
b890d449 | 47 | (apply #'make-presentation (cdr (%make-view object type attributes args)))) |
d5e996b3 | 48 | |
b890d449 | 49 | (defmacro present-view ((object &optional (type :viewer) (parent 'self)) |
d5e996b3 | 50 | &body attributes-and-args) |
b890d449 DC |
51 | (arnesi:with-unique-names (view) |
52 | `(let ((,view (lol:make-view ,object | |
53 | :type ,type | |
54 | :attributes ,(car attributes-and-args) | |
55 | ,@ (cdr attributes-and-args)))) | |
56 | (setf (ucw::parent ,view) ,parent) | |
57 | (lol:present ,view)))) | |
d5e996b3 DC |
58 | |
59 | ||
60 | (defmacro call-view ((object &optional (type :viewer) (component 'self component-supplied-p)) | |
b890d449 | 61 | &body attributes-and-args) |
d5e996b3 DC |
62 | `(ucw:call-component |
63 | ,component | |
b890d449 | 64 | ,(%make-view object type (car attributes-and-args) (cdr attributes-and-args)))) |
d5e996b3 DC |
65 | |
66 | (defmethod slot-view ((self mewa) slot-name) | |
67 | (mewa::find-attribute-slot self slot-name)) | |
68 | ||
69 | (defmethod present-slot-view ((self mewa) slot-name &optional (instance (instance self))) | |
70 | (present-slot (slot-view self slot-name) instance)) | |
71 | ||
38a016c7 | 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 DC |
85 | |
86 | (defun %delete-item (item) | |
87 | (ignore-errors | |
88 | (clsql:delete-instance-records item))) | |
89 | ||
90 | (defaction delete-item ((self component) instance) | |
91 | (if (%delete-item instance) | |
92 | (answer nil) | |
93 | (call 'info-message :message "Could not remove item. Try removing associated items first."))) | |
94 | ||
38a016c7 DC |
95 | (defmethod word-search (class-name slots search-terms |
96 | &key (limit 10) (where (sql-and t))) | |
97 | (select class-name | |
98 | :where (sql-and | |
99 | where | |
100 | (word-search-where class-name slots search-terms :format-string "~a%")) | |
101 | :flatp t | |
102 | :limit limit)) | |
103 | ||
104 | ||
105 | (defmethod word-search (class-name slots (s string) &rest args) | |
106 | (apply #'word-search class-name slots | |
107 | (split-sequence:split-sequence #\Space s) args)) | |
108 | ||
109 | (defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%")) | |
110 | (sql-or | |
111 | (mapcar #'(lambda (term) | |
112 | (apply #'sql-or | |
113 | (mapcar #'(lambda (slot) | |
114 | (sql-uplike | |
115 | (sql-slot-value class-name slot) | |
116 | (format nil format-string term))) | |
117 | slots))) | |
118 | search-terms))) | |
119 | ||
b890d449 DC |
120 | |
121 |