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) | |
33 | (defun %make-view (object type &rest attributes-and-args) | |
34 | (let ((attributes (car attributes-and-args)) | |
35 | (args (cdr attributes-and-args))) | |
36 | `(mewa:make-presentation | |
37 | ,object | |
38 | :type ,type | |
39 | :initargs | |
40 | '(,@ (when attributes | |
41 | `(:attributes ,attributes))) | |
42 | ,@args)))) | |
43 | ||
44 | (defmethod make-view (object &rest args &key (type :viewer) (attributes nil) | |
45 | &allow-other-keys ) | |
46 | (apply #'make-presentation (cdr (%make-view object type (cons attributes args))))) | |
47 | ||
48 | (defmacro present-view ((object &optional (type :viewer)) | |
49 | &body attributes-and-args) | |
50 | `(present ,(%make-view object type attributes-and-args))) | |
51 | ||
52 | ||
53 | (defmacro call-view ((object &optional (type :viewer) (component 'self component-supplied-p)) | |
54 | &body attributes-and-args) | |
55 | ||
56 | ||
57 | `(ucw:call-component | |
58 | ,component | |
59 | ,(%make-view object type attributes-and-args))) | |
60 | ||
61 | (defmethod slot-view ((self mewa) slot-name) | |
62 | (mewa::find-attribute-slot self slot-name)) | |
63 | ||
64 | (defmethod present-slot-view ((self mewa) slot-name &optional (instance (instance self))) | |
65 | (present-slot (slot-view self slot-name) instance)) | |
66 | ||
38a016c7 | 67 | |
38a016c7 | 68 | |
38a016c7 DC |
69 | |
70 | (defmethod find-slots-of-type (model &key (type 'string) | |
71 | (types '((string)) types-supplied-p)) | |
72 | "returns a list of slots matching TYPE, or matching any of TYPES" | |
73 | (let (ty) | |
74 | (if types-supplied-p | |
75 | (setf ty types) | |
76 | (setf ty (list type))) | |
77 | (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) | |
78 | (first st))) | |
79 | (lisp-on-lines::list-slot-types model))))) | |
80 | ||
81 | ||
82 | (defmethod word-search (class-name slots search-terms | |
83 | &key (limit 10) (where (sql-and t))) | |
84 | (select class-name | |
85 | :where (sql-and | |
86 | where | |
87 | (word-search-where class-name slots search-terms :format-string "~a%")) | |
88 | :flatp t | |
89 | :limit limit)) | |
90 | ||
91 | ||
92 | (defmethod word-search (class-name slots (s string) &rest args) | |
93 | (apply #'word-search class-name slots | |
94 | (split-sequence:split-sequence #\Space s) args)) | |
95 | ||
96 | (defmethod word-search-where (class-name slots search-terms &key (format-string "%~a%")) | |
97 | (sql-or | |
98 | (mapcar #'(lambda (term) | |
99 | (apply #'sql-or | |
100 | (mapcar #'(lambda (slot) | |
101 | (sql-uplike | |
102 | (sql-slot-value class-name slot) | |
103 | (format nil format-string term))) | |
104 | slots))) | |
105 | search-terms))) | |
106 |