src/relational-attributes.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; * Relational Attributes
   4
   5
   6 ;;;; ** has-a
   7 ;;;; Used for foreign keys, currently only works with clsql.
   8
   9 (defattribute has-a ()
  10   ()
  11   (:default-properties
  12       :has-a nil
  13     :test 'meta-model::generic-equal))
  14
  15 ;;
  16 (define-layered-method attribute-value (object (attribute has-a))
  17  (meta-model:explode-foreign-key object (slot-name attribute) :nilp t))
  18
  19 (define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
  20   (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
  21     (setf (attribute-value object attribute) val)))
  22
  23
  24
  25 (define-layered-function find-all-foreign-objects (o a))
  26
  27 (define-layered-method find-all-foreign-objects (object (attribute has-a))
  28   (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
  29
  30 (defdisplay ((attribute has-a) object)
  31   (let ((args (plist-union (description.properties attribute) (has-a attribute)))
  32         (val (attribute-value object attribute)))
  33     (when val
  34       (setf (getf args :type)
  35             'lol::one-line))
  36     (apply #'display* val
  37            args)))
  38
  39
  40 (defdisplay
  41   :in-layer editor ((attribute has-a) object)
  42  (<ucw:select
  43   :accessor (attribute-value object attribute)
  44
  45   :test (test attribute)
  46   (dolist* (obj (find-all-foreign-objects object attribute))
  47     (<ucw:option
  48      :value obj
  49      (display* obj :type 'as-string)))))
  50
  51
  52 ;;;; ** Has-Many attribute
  53
  54 (defattribute has-many ()
  55   ()
  56   (:default-properties
  57       :add-new-label "Add New"
  58     :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
  59   (:default-initargs
  60       :type 'lol::one-line))
  61
  62 (define-layered-method
  63     attribute-value (object (has-many has-many))
  64     (slot-value object (slot-name has-many)))
  65
  66 (defdisplay ((attribute has-many) object)
  67     ;
  68   ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
  69
  70  (<:div  :style "clear:both;"
  71          (let* ((i (apply #'sort (slot-value object (slot-name attribute))
  72                           (sort-arguments attribute))))
  73            (<:ul
  74             (dolist* (x i)
  75               (<:li (display* x
  76                               :type 'lol::one-line
  77                               :layers '(+ wrap-link - label-attributes))))))))
  78
  79
  80 (defun find-many-to-many-class (slot-name instance)
  81   (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
  82                     :db-info))
  83          (jc (make-instance (getf imd :join-class)))
  84          (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
  85                      :db-info)))
  86     (getf jcmd :join-class)))
  87
  88
  89 (defattribute many-to-many ()
  90   ())
  91
  92
  93
  94 (defdisplay ((attribute many-to-many) object)
  95   (<:as-html "ASDASD"))
  96
  97   #+nil(let ((instances (select-instances object t))
  98         new-instance)
  99     (<:ul
 100      (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
 101                         (<:as-html "Add New")))
 102      (<:li  (<ucw:button :action (add-new-relation component object new-instance)
 103                          (<:as-html "Add:"))
 104             (<ucw:select :accessor new-instance
 105                          (arnesi:dolist* (i instances)
 106                            (<ucw:option
 107                             :value i
 108                             (display component i :type 'one-line)))))
 109      (dolist* (i (attribute-value object attribute))
 110        (<:li
 111         (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
 112                 (<:as-html "(view) "))
 113         (<ucw:a :action (delete-relationship slot (second i) instance)
 114                 (<:as-html "(remove) "))
 115         (display component object)))))
 116   ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
 117