removing historical implementation

[clinton/lisp-on-lines.git] / src / attributes / relational-attributes.lisp

diff --git a/src/attributes/relational-attributes.lisp b/src/attributes/relational-attributes.lisp
deleted file mode 100644 (file)
index de3fcc2..0000000
--- a/src/attributes/relational-attributes.lisp
+++ /dev/null
@@ -1,132 +0,0 @@
-(in-package :lisp-on-lines)
-
-;;;; * Relational Attributes
-
-
-(defvar *parent-relations* nil)
-
-;;;; ** has-a
-;;;; Used for foreign keys, currently only works with clsql.
-
-(defattribute relational-attribute ()
-  ())
-
-(defdisplay :wrap-around ((attribute relational-attribute) object)
-           (print (cons "parent-r" *parent-relations*))
- (dletf (((value attribute) (attribute-value object attribute)))
-   (unless (find (value attribute) *parent-relations* :test #'meta-model::generic-equal)
-     (call-next-method))))
-
-(defattribute has-a (relational-attribute)
-  ()
-  (:default-properties
-      :has-a nil
-    :test 'meta-model::generic-equal))
-
-;;
-(define-layered-method attribute-value (object (attribute has-a))
- (multiple-value-bind (obj key class)
-     (meta-model:explode-foreign-key object (slot-name attribute) :nilp t)                    
-  (if (persistentp object)
-      obj
-      (first  (select class
-                     :where [= [slot-value class key] (call-next-method)]
-                     :flatp t
-                     )))))                    
-
-(define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
-  (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
-    (setf (attribute-value object attribute) val)))
-
-(define-layered-function find-all-foreign-objects (o a))
-
-(define-layered-method find-all-foreign-objects (object (attribute has-a))
-  (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
-                      
-(defdisplay ((attribute has-a) object)
-  (let ((args (plist-union (description.properties attribute) (has-a attribute)))
-       (val (attribute-value object attribute)))
-    (when val
-      (setf (getf args :type)
-           'lol::one-line))
-    (apply #'display* val
-          args)))
-
-
-(defdisplay
-  :in-layer editor ((attribute has-a) object)
- (<ucw:select
-  :accessor (attribute-value object attribute)
-
-  :test (test attribute)
-  (dolist* (obj (find-all-foreign-objects object attribute))
-    (<ucw:option
-     :value obj
-     (display* obj :layers '(+ as-string))))))
-
-;;;; ** Has-Many attribute
-
-(defattribute has-many ()
-  ()
-  (:default-properties
-      :add-new-label "Add New"
-    :has-many nil
-    :sort-arguments  (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
-  (:default-initargs
-      :type 'lol::one-line))
-
-(define-layered-method
-    attribute-value (object (has-many has-many))
-    (slot-value object (slot-name has-many)))
-
-
-(defdisplay ((attribute has-many) object)
-    ;
-  ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
-           
- (<:div  :style "clear:both;"
-        (let* ((i (apply #'sort (slot-value object (slot-name attribute))
-                         (sort-arguments attribute)))
-               (*parent-relations* (cons object *parent-relations*)))
-
-          (apply #'display* i (has-many attribute)))))
-
-
-(defun find-many-to-many-class (slot-name instance)
-  (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
-                   :db-info))
-        (jc (make-instance (getf imd :join-class)))
-        (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
-                    :db-info)))
-    (getf jcmd :join-class)))
-
-
-(defattribute many-to-many ()
-  ())
-
-
-
-(defdisplay ((attribute many-to-many) object)
-  (<:as-html "ASDASD"))
-
-  #+nil(let ((instances (select-instances object t))
-       new-instance)
-    (<:ul
-     (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
-                       (<:as-html "Add New")))
-     (<:li  (<ucw:button :action (add-new-relation component object new-instance)
-                        (<:as-html "Add:"))
-           (<ucw:select :accessor new-instance
-                        (arnesi:dolist* (i instances)
-                          (<ucw:option
-                           :value i
-                           (display component i :type 'one-line)))))
-     (dolist* (i (attribute-value object attribute))
-       (<:li
-       (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
-               (<:as-html "(view) "))
-       (<ucw:a :action (delete-relationship slot (second i) instance)
-               (<:as-html "(remove) "))
-       (display component object)))))
-  ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
-                     
\ No newline at end of file