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