| 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) |
| 13 | (defun generate-define-view-for-table (table) |
| 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 |
| 19 | (def-view-class-from-table ,table) |
| 20 | (set-default-attributes (quote ,(meta-model::sql->sym table)))))) |
| 21 | |
| 22 | (defmacro define-view-for-table (&rest tables) |
| 23 | " expand to a form which initialises TABLES for use with LOL" |
| 24 | `(progn |
| 25 | ,@(loop for tbl in tables collect (generate-define-view-for-table tbl)) |
| 26 | (values))) |
| 27 | |
| 28 | (defmacro define-views-for-database () |
| 29 | "expands to init-i-f-t using the listing of tables provided by meta-model" |
| 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 | |
| 67 | |
| 68 | |
| 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 | |