src/attributes/relational-attributes.lisp

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