src/lisp-on-lines.lisp

   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 attributes args)
  34
  35       (when attributes
  36         (setf args
  37               (cons `(:attributes ,attributes) args)))
  38       `(mewa:make-presentation
  39         ,object
  40         :type ,type
  41         ,@(when args
  42                 `(:initargs
  43                   '(,@ (mapcan #'identity args)))))))
  44
  45 (defmethod make-view (object &rest args &key (type :viewer) (attributes nil)
  46                       &allow-other-keys )
  47   (apply #'make-presentation (cdr (%make-view object type attributes args))))
  48
  49 (defmacro present-view ((object &optional (type :viewer) (parent 'self))
  50                         &body attributes-and-args)
  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))))
  58
  59
  60 (defmacro call-view ((object &optional (type :viewer) (component 'self component-supplied-p))
  61                      &body attributes-and-args)
  62   `(ucw:call-component
  63     ,component
  64     ,(%make-view object type (car attributes-and-args) (cdr attributes-and-args))))
  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
  72
  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
  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
  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
 120
 121