[clinton/lisp-on-lines.git] / src / slot-presentations.lisp

(in-package :lisp-on-lines)

(defun multiple-value-funcall->list (function &rest args)
  "The function to be called by m-v-bf"
		   (multiple-value-call #'list (apply function args)))

(defmacro multiple-value-bindf (vars form &body body)
  "Like M-V-B, only it works in actions. form must be a function call"
		   `(destructuring-bind ,vars 
		     (multiple-value-funcall->list #',(car form) ,@(cdr form))
		     ,@body))


;;;; ** Textarea Slot Presentation

(defslot-presentation text-slot-presentation ()
  ((rows :initarg :rows :accessor rows :initform 5)
   (columns :initarg :columns :accessor columns :initform 40)
   (escape-html-p :initarg :escape-html-p :accessor escape-html-p :initform nil))
  (:type-name text))

(defmethod present-slot ((slot text-slot-presentation) instance)
    (if (editablep slot)
	(<ucw:textarea
	 :accessor (presentation-slot-value slot instance)
	 :reader (or (presentation-slot-value slot instance)
		 "")
	 :rows (rows slot)
	 :cols (columns slot))
	(if (escape-html-p slot)
	    (<:as-html (presentation-slot-value slot instance))
	    (<:as-is (presentation-slot-value slot instance)))))


(defcomponent mewa-slot-presentation ()
  ((slot-name :accessor slot-name 
	      :initarg :slot-name 
	      :documentation 
	      "The name of the slot being accessed")
   (fill-gaps-only-p :accessor fill-gaps-only-p 
		     :initarg :fill-gaps-only-p
		     :initform nil
		     :documentation 
		     "When nil, the instance is syncronised with the database. 
When T, only the default value for primary keys and the joins are updated.")
   (show-label-p :accessor show-label-p :initarg :show-label-p :initform t))
  (:documentation "The superclass of all Mewa slot presentations"))

;;;; this has to be in the eval when i would think
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun generate-slot-presentation-definition-for-type (type)
    (let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
	   (sp-name (intern (format nil "MEWA-~A" u-name)))
	   (t-name (intern (format nil "MEWA-~A" type))))
      `(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
	()
	(:type-name ,t-name)))))

(defmacro define-base-mewa-presentations (&body types)
  "Define the mewa-slot-presentations by subclassing the base UCW ones"
    `(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
		      types)))

;;;then actually define the base presentations :
(define-base-mewa-presentations 
  boolean
  string
  number
  integer
  currency)

(defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
       ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
	(trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)))
       (:type-name clsql-sys:wall-time))

(defmethod presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
  (let ((date (call-next-method)))
    (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
      (format nil "~a/~a/~a" m d y)))))

(defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
  (let ((new-time (clsql:parse-date-time (remove #\Space value)))
	(old-time (when (slot-boundp instance (slot-name slot))
		    (slot-value instance (slot-name slot)))))
    (unless (or (eql old-time new-time)
		(when (and new-time old-time)
		  (equal :equal (clsql:time-compare new-time old-time))))
    (setf (presentation-slot-value slot instance) new-time ))))

(defmethod label :around ((slot clsql-wall-time-slot-presentation))
  (concatenate 'string (call-next-method) "  (m/d/y)"))

(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
  (let ((date (presentation-slot-value slot instance)))
    (if (and date (not (editablep slot)))
	(<:as-html date))
    (when (editablep slot)
      (<ucw:input :accessor (presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
      (<:button :id (trigger-id slot) (<:as-html "[...]"))
      (<:script :type "text/javascript" 
		(<:as-is (format nil " 
      
Calendar.setup({
 inputField     :    \"~a\",
 button         :    \"~a\",
 ifFormat       :    \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))

(defslot-presentation  mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
  ((foreign-instance :accessor foreign-instance)
   (linkedp :accessor linkedp :initarg :linkedp :initform t)
   (creator :accessor creator :initarg :creator :initform :editor)
   (new-instance :accessor new-instance :initform nil))
  (:type-name relation))

(defaction search-records ((slot mewa-relation-slot-presentation) instance)
  (multiple-value-bindf (finstance foreign-slot-name)
      (meta-model:explode-foreign-key instance (slot-name slot))
    (let ((new-instance (new-instance self)))
      (unless new-instance
	(setf (new-instance self)
	      (call-component 
	       (ucw::parent slot)
	       (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
				  'mewa::mewa-presentation-search)
			      :search-presentation
			      (mewa:make-presentation finstance 
						      :type :search-presentation)
			      :list-presentation 
			      (mewa:make-presentation finstance 
						      :type :listing)))))
      (sync-foreign-instance slot new-instance))))

(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
  (let ((instance (instance (ucw::parent slot))))
    (multiple-value-bind (foo f-slot-name)
	(meta-model:explode-foreign-key instance (slot-name slot))
      (setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
      (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))

    
(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
  (multiple-value-bindf (finstance foreign-slot-name)
      (meta-model:explode-foreign-key instance (slot-name slot))
    (let ((new-instance
           (call-component
            (ucw::parent slot)
            (mewa:make-presentation finstance :type (creator self)))))
      
      ;;;; TODO: this next bit is due to a bad design decision. 
      ;;;; Components should always have (ok) return self, but somewhere 
      ;;;; i've made in return (instance self) sometimes, and this
      ;;;; bahaviour is totatlly fucked.
      
     (when (typep new-instance 'mewa::mewa)
       (setf new-instance (instance new-instance)))

      ;;;; sorry about that, and now back t our regular program.
      
      (meta-model:sync-instance new-instance)
      (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
      (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
      

(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
 ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
  (let* ((i (foreign-instance slot))
	 (pres (mewa::make-presentation 
		i
		:type :one-line 
		:initargs (list 
			   :global-properties 
			   (list :editablep nil :linkedp nil)))))
      (when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
	(setf (component.place pres) (component.place (ucw::parent slot))))
      (when i (<ucw:render-component :component pres))))

(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
  (present-relation slot instance))

(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
  ()
  (:type-name foreign-key)
  (:default-initargs))

(defaction view-instance ((self component) instance &rest initargs)
  (call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
  ;; the viewed instance could have been changed/deleted, so we sync this instance
  (meta-model:sync-instance (instance (ucw::parent self))))


(defmethod  present-slot :around ((slot foreign-key-slot-presentation) instance)  
  (setf (foreign-instance slot) 
	(when (presentation-slot-value slot instance) 
	  (meta-model:explode-foreign-key instance (slot-name slot))))
  (flet ((render () (when (foreign-instance slot)(call-next-method))))
    (if (slot-boundp slot 'ucw::place)
        (cond 
          ((editablep slot)
	   (render)
           (<ucw:submit :action  (search-records slot instance) :value "Search" :style "display:inline")
           (<ucw:submit :action  (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
          ((linkedp slot)
           (<ucw:a :action (view-instance slot (foreign-instance slot)) 
                   (render)))
          (t       
           (render)))
	;; presentation is used only for rendering
        (render))))


(defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
  (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))))


;;;; HAS MANY 
(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
  ((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
  (:type-name has-many))

(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
  ;; if the instance is not stored we must make sure to mark it stored now!
  (unless (meta-model::persistentp instance)
    (setf (mewa::modifiedp (ucw::parent self)) t))
  ;; sync up the instance
  ;;(mewa:ensure-instance-sync (parent slot))
  (meta-model:sync-instance (instance (ucw::parent slot)))
  
  (multiple-value-bindf (class home foreign) 
      (meta-model:explode-has-many instance (slot-name slot))
    (let ((new (make-instance class)))
      (setf (slot-value new foreign) (slot-value instance home))
      (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
      (call-component (ucw::parent slot)  (mewa:make-presentation new :type (creator slot)))
      (meta-model:sync-instance instance))))

(defmethod present-slot ((slot has-many-slot-presentation) instance)
  (when (slot-boundp slot 'ucw::place)
    (<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
  (let* ((i (get-foreign-instances slot instance))
	 (presentation (and i (make-presentation (car  i) :type :one-line))))
    (when i
      (flet ((linker (i string)
	       (<ucw:a
		:action (view-instance slot i
				       :initargs
				       `(:global-properties ,
					 (list
					  :linkedp t
					  :editablep nil)))
		(<:as-html string))))
	(<:table
	 (<:tr
	  (<:th)			;empty col for (view) link
	  (dolist (s (slots presentation))
	    (<:th (<:as-html  (label s)))))
	 (dolist (s i)
	   (let ((s s))
	     (setf (foreign-instance slot) s)
	     (when (slot-boundp slot 'ucw::place)
	       (<:tr
		(<:td (linker s " (view) "))
		(dolist (p (slots (make-presentation s :type :one-line
						     :initargs
						     '(:global-properties
						       (:editablep nil)))))
		  (<:td 	     
				
		   (present-slot p s))))))))))))
		       

(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
  (slot-value instance (slot-name slot)))

(defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
  (get-foreign-instances slot instance))

(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
  ((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
   (current :accessor current :initform 0)
   (len :accessor len )
   (instances :accessor instances))
  (:type-name has-very-many))

(defmethod list-next ((slot has-very-many-slot-presentation))
  (setf (current slot) (incf (current slot) (number-to-display slot)))
  (when (< (len slot) (current slot))
    (setf (current slot) (- (number-to-display slot) (len slot)))))

(defmethod list-prev ((slot has-very-many-slot-presentation))
  (setf (current slot) (decf (current slot) (number-to-display slot)))
  (when  (> 0 (current slot))
    ;;what to do here is open to debate
    (setf (current slot) (- (len slot)(number-to-display slot)  ))))


(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
  ;;(<:as-html "isance: " instance)
  (if (slot-boundp slot 'ucw::place)
      (progn
        (<ucw:a :action (list-prev slot) (<:as-html "<<"))
        (let ((self (ucw::parent slot)))
          (<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
	        (<:as-html  (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
        (<ucw:a :action (list-next slot) (<:as-html ">>"))
        (call-next-method)
        (<:as-html "total :" (len slot)))
      (call-next-method)))

(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
  (let ((f (call-next-method)))
    (setf (len slot) (length f))
    (setf (instances slot) f)
  (loop for cons on (nthcdr (current slot) f)
		   for i from 0 upto (number-to-display slot)
		   collect (car cons))))


;;;; * Has-a
(defslot-presentation has-a-slot-presentation (mewa-relation-slot-presentation)
  ((allow-nil-p :accessor allow-nil-p :initarg :allow-nil-p :initform t)
   (attributes :accessor attributes :initarg :attributes :initform nil))
  (:type-name has-a))

(defmethod find-foreign-slot-value ((slot has-a-slot-presentation) (object t))
  (multiple-value-bind (c s)      
      (meta-model:explode-foreign-key (instance (ucw::parent slot)) (slot-name slot))
    (slot-value object s)))

(defmethod get-foreign-instances ((slot mewa-relation-slot-presentation) instance)
  (clsql:select (class-name (class-of
			     (meta-model:explode-foreign-key instance (slot-name slot))))
		:flatp t))

(defmethod present-slot ((slot has-a-slot-presentation) instance)
;      (<:as-html (presentation-slot-value slot instance))
  (if (editablep slot)
      (progn (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
        (when (allow-nil-p slot)
	  (<ucw:option :value nil (<:as-html "none")))
	(dolist (option (get-foreign-instances slot instance))
	  (<ucw:option :value (find-foreign-slot-value slot option)
		       (lol:present
			(lol:make-presentation option
			   :type :as-string
			   :initargs
			   `(:attributes ,(attributes slot)))
			))))
	     (<ucw:submit :action  (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline")) 
      (if (presentation-slot-value slot instance)
	  (progn
	   (lol:present
	    (lol:make-presentation (meta-model:explode-foreign-key instance (slot-name slot))
			   :type :one-line
			   :initargs
			   `(:attributes ,(attributes slot)))
			   ))
	  (<:as-html "--"))))

(defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
  ((list-view :accessor list-view :initarg :list-view :initform :one-line)
   (action-view :accessor action-view :initarg :action-view :initform :viewer)
   (create-view :initform :creator)
   (select-view :initform :as-string :accessor select-view))
  (:type-name many-to-many)
  (:default-initargs :label "many to many"))

(defun %delete-item (item)
  (clsql:with-default-database (clsql:*default-database*)
    (ignore-errors
    (clsql:delete-instance-records item))))

(defaction delete-item ((self component) instance)
  (multiple-value-bind (res err) (%delete-item instance)
  (if (not err) 
      (call 'info-message :message "Removed Instance")
      (call 'info-message :message (format nil "Could not remove item. Try removing associated items first. ~A" instance)))))

(defaction delete-relationship ((slot many-to-many-slot-presentation) rel instance)
  (delete-item (ucw::parent self) rel)
  (sync-instance instance)
  (answer-component (ucw::parent self)   t))


(defun find-many-to-many-join-class (slot instance)
  (let* ((imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
		    :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)))

(defmethod find-all-instances ((slot many-to-many-slot-presentation) instance)
  (clsql:select (find-many-to-many-join-class slot instance) :flatp t))

(defmethod present-slot ((slot many-to-many-slot-presentation) instance)  
  (let ((instances (slot-value instance (slot-name slot)))
	new-instance)
    (<:ul
     (<:li (<ucw:button :action (add-to-many-to-many slot instance)
			 (<:as-html "Add New")))
     (<:li  (<ucw:button :action (add-to-many-to-many slot instance new-instance)
			 (<:as-html "Add:"))
	    (<ucw:select :accessor new-instance
			 (arnesi:dolist* (i (find-all-instances slot instance))
			   (<ucw:option
			    :value i
			    (lol:present-view (i (select-view slot) slot))))))
     (dolist* (i instances)
       (<: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) "))
	(present-view ((car i) (list-view slot) (ucw::parent slot)))) ))))

(defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)
  ;;;; First things first, we sync.
  (sync-instance instance)
  (let* (new
	 (imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
		    :db-info))
	 (jc (make-instance (getf imd :join-class)))
	 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
		     :db-info))
	 (fc (make-instance (getf jcmd :join-class)))
	 (c (if
	     foreign-instance
	     foreign-instance
	     (call-view (fc :creator (ucw::parent slot))))))
    (when c
      (sync-instance c)
;      (error "~A ~A ~A" (getf imd :foreign-key) (getf jcmd :foreign-key) (getf imd :home-key))
      (setf (slot-value jc (getf imd :foreign-key))
	    (slot-value instance (getf imd :home-key)))
      (setf (slot-value jc (getf jcmd :home-key))
	    (slot-value c (getf jcmd :foreign-key)))
      (sync-instance jc)
      
      (sync-instance instance)
      c)))
Commit	Line	Data
5dea194e	1	(in-package :lisp-on-lines)
579597e3	2
19a82bd5	3	(defun multiple-value-funcall->list (function &rest args)
4e2ecf69	4	"The function to be called by m-v-bf"
19a82bd5	5	(multiple-value-call #'list (apply function args)))
	6
	7	(defmacro multiple-value-bindf (vars form &body body)
4e2ecf69	8	"Like M-V-B, only it works in actions. form must be a function call"
19a82bd5	9	`(destructuring-bind ,vars
	10	(multiple-value-funcall->list #',(car form) ,@(cdr form))
	11	,@body))
579597e3	12
44108fd6 DC	13
44108fd6 DC	14	;;;; ** Textarea Slot Presentation
44108fd6 DC	15
44108fd6 DC	16	(defslot-presentation text-slot-presentation ()
9f2bdea8	17	((rows :initarg :rows :accessor rows :initform 5)
d5e996b3 DC	18	(columns :initarg :columns :accessor columns :initform 40)
d5e996b3 DC	19	(escape-html-p :initarg :escape-html-p :accessor escape-html-p :initform nil))
44108fd6 DC	20	(:type-name text))
	21
	22	(defmethod present-slot ((slot text-slot-presentation) instance)
9f2bdea8 DC	23	(if (editablep slot)
	24	(<ucw:textarea
	25	:accessor (presentation-slot-value slot instance)
	26	:reader (or (presentation-slot-value slot instance)
	27	"")
	28	:rows (rows slot)
	29	:cols (columns slot))
	30	(if (escape-html-p slot)
	31	(<:as-html (presentation-slot-value slot instance))
e5b53af4	32	(<:as-is (presentation-slot-value slot instance)))))
44108fd6 DC	33
44108fd6 DC	34
e9454185 DC	35	(defcomponent mewa-slot-presentation ()
	36	((slot-name :accessor slot-name
	37	:initarg :slot-name
	38	:documentation
	39	"The name of the slot being accessed")
	40	(fill-gaps-only-p :accessor fill-gaps-only-p
	41	:initarg :fill-gaps-only-p
	42	:initform nil
	43	:documentation
	44	"When nil, the instance is syncronised with the database.
68a53dce DC	45	When T, only the default value for primary keys and the joins are updated.")
68a53dce DC	46	(show-label-p :accessor show-label-p :initarg :show-label-p :initform t))
e9454185 DC	47	(:documentation "The superclass of all Mewa slot presentations"))
	48
	49	;;;; this has to be in the eval when i would think
	50	(eval-when (:compile-toplevel :load-toplevel :execute)
	51	(defun generate-slot-presentation-definition-for-type (type)
	52	(let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
	53	(sp-name (intern (format nil "MEWA-~A" u-name)))
	54	(t-name (intern (format nil "MEWA-~A" type))))
	55	`(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
	56	()
	57	(:type-name ,t-name)))))
	58
	59	(defmacro define-base-mewa-presentations (&body types)
	60	"Define the mewa-slot-presentations by subclassing the base UCW ones"
	61	`(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
	62	types)))
	63
	64	;;;then actually define the base presentations :
	65	(define-base-mewa-presentations
	66	boolean
	67	string
	68	number
	69	integer
	70	currency)
9d6c69fb	71
f4170204	72	(defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
d5e996b3 DC	73	((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
d5e996b3 DC	74	(trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)))
579597e3	75	(:type-name clsql-sys:wall-time))
	76
	77	(defmethod presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
	78	(let ((date (call-next-method)))
	79	(when date (multiple-value-bind (y m d) (clsql:time-ymd date)
	80	(format nil "~a/~a/~a" m d y)))))
	81
	82	(defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
f4170204	83	(let ((new-time (clsql:parse-date-time (remove #\Space value)))
	84	(old-time (when (slot-boundp instance (slot-name slot))
	85	(slot-value instance (slot-name slot)))))
	86	(unless (or (eql old-time new-time)
ec4f5786	87	(when (and new-time old-time)
	88	(equal :equal (clsql:time-compare new-time old-time))))
	89	(setf (presentation-slot-value slot instance) new-time ))))
579597e3	90
19531fbd	91	(defmethod label :around ((slot clsql-wall-time-slot-presentation))
ec044146	92	(concatenate 'string (call-next-method) " (m/d/y)"))
19531fbd	93
579597e3	94	(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
d5e996b3	95	(let ((date (presentation-slot-value slot instance)))
579597e3	96	(if (and date (not (editablep slot)))
d2dbe50f	97	(<:as-html date))
579597e3	98	(when (editablep slot)
d5e996b3 DC	99	(<ucw:input :accessor (presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
d5e996b3 DC	100	(<:button :id (trigger-id slot) (<:as-html "[...]"))
579597e3	101	(<:script :type "text/javascript"
579597e3	102	(<:as-is (format nil "
d5e996b3 DC	103
	104	Calendar.setup({
	105	inputField : \"~a\",
	106	button : \"~a\",
	107	ifFormat : \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))
579597e3	108
e9454185 DC	109	(defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
e9454185 DC	110	((foreign-instance :accessor foreign-instance)
569ad9e6	111	(linkedp :accessor linkedp :initarg :linkedp :initform t)
38a016c7 DC	112	(creator :accessor creator :initarg :creator :initform :editor)
38a016c7 DC	113	(new-instance :accessor new-instance :initform nil))
579597e3	114	(:type-name relation))
579597e3	115
7d87c1d2	116	(defaction search-records ((slot mewa-relation-slot-presentation) instance)
e9454185 DC	117	(multiple-value-bindf (finstance foreign-slot-name)
e9454185 DC	118	(meta-model:explode-foreign-key instance (slot-name slot))
38a016c7 DC	119	(let ((new-instance (new-instance self)))
	120	(unless new-instance
	121	(setf (new-instance self)
	122	(call-component
	123	(ucw::parent slot)
	124	(make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
	125	'mewa::mewa-presentation-search)
	126	:search-presentation
	127	(mewa:make-presentation finstance
	128	:type :search-presentation)
	129	:list-presentation
	130	(mewa:make-presentation finstance
	131	:type :listing)))))
	132	(sync-foreign-instance slot new-instance))))
	133
	134	(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
	135	(let ((instance (instance (ucw::parent slot))))
	136	(multiple-value-bind (foo f-slot-name)
	137	(meta-model:explode-foreign-key instance (slot-name slot))
	138	(setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
	139	(meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
	140
	141
569ad9e6	142	(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
e9454185 DC	143	(multiple-value-bindf (finstance foreign-slot-name)
	144	(meta-model:explode-foreign-key instance (slot-name slot))
	145	(let ((new-instance
	146	(call-component
38a016c7	147	(ucw::parent slot)
569ad9e6 DC	148	(mewa:make-presentation finstance :type (creator self)))))
	149
	150	;;;; TODO: this next bit is due to a bad design decision.
	151	;;;; Components should always have (ok) return self, but somewhere
	152	;;;; i've made in return (instance self) sometimes, and this
	153	;;;; bahaviour is totatlly fucked.
	154
	155	(when (typep new-instance 'mewa::mewa)
	156	(setf new-instance (instance new-instance)))
	157
	158	;;;; sorry about that, and now back t our regular program.
	159
	160	(meta-model:sync-instance new-instance)
e9454185 DC	161	(setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
e9454185 DC	162	(meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
569ad9e6	163
e9454185	164
579597e3	165	(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
579597e3	166	;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
19531fbd	167	(let* ((i (foreign-instance slot))
579597e3	168	(pres (mewa::make-presentation
	169	i
	170	:type :one-line
	171	:initargs (list
	172	:global-properties
19531fbd	173	(list :editablep nil :linkedp nil)))))
9d6c69fb	174	(when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
498061f6	175	(setf (component.place pres) (component.place (ucw::parent slot))))
498061f6	176	(when i (<ucw:render-component :component pres))))
579597e3	177
	178	(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
	179	(present-relation slot instance))
	180
	181	(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
	182	()
	183	(:type-name foreign-key)
	184	(:default-initargs))
	185
	186	(defaction view-instance ((self component) instance &rest initargs)
38a016c7	187	(call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
12dcf3d4	188	;; the viewed instance could have been changed/deleted, so we sync this instance
38a016c7	189	(meta-model:sync-instance (instance (ucw::parent self))))
579597e3	190
498061f6	191
569ad9e6	192	(defmethod present-slot :around ((slot foreign-key-slot-presentation) instance)
f1ce8b6e DC	193	(setf (foreign-instance slot)
	194	(when (presentation-slot-value slot instance)
	195	(meta-model:explode-foreign-key instance (slot-name slot))))
f1ce8b6e	196	(flet ((render () (when (foreign-instance slot)(call-next-method))))
38a016c7	197	(if (slot-boundp slot 'ucw::place)
f1ce8b6e DC	198	(cond
f1ce8b6e DC	199	((editablep slot)
5dea194e	200	(render)
f1ce8b6e	201	(<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
569ad9e6	202	(<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
f1ce8b6e DC	203	((linkedp slot)
	204	(<ucw:a :action (view-instance slot (foreign-instance slot))
	205	(render)))
	206	(t
	207	(render)))
	208	;; presentation is used only for rendering
	209	(render))))
579597e3	210
d2512426	211
5dea194e DC	212	(defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
5dea194e DC	213	(clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))))
38a016c7	214
5dea194e	215
d2512426	216
579597e3	217	;;;; HAS MANY
579597e3	218	(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
12dcf3d4	219	((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
579597e3	220	(:type-name has-many))
579597e3	221
498061f6	222	(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
8e6e6b56	223	;; if the instance is not stored we must make sure to mark it stored now!
5dea194e	224	(unless (meta-model::persistentp instance)
38a016c7	225	(setf (mewa::modifiedp (ucw::parent self)) t))
8e6e6b56	226	;; sync up the instance
ec044146	227	;;(mewa:ensure-instance-sync (parent slot))
38a016c7	228	(meta-model:sync-instance (instance (ucw::parent slot)))
ec044146	229
85281029 DC	230	(multiple-value-bindf (class home foreign)
85281029 DC	231	(meta-model:explode-has-many instance (slot-name slot))
498061f6	232	(let ((new (make-instance class)))
498061f6	233	(setf (slot-value new foreign) (slot-value instance home))
e9454185	234	(meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
38a016c7	235	(call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
e9454185	236	(meta-model:sync-instance instance))))
498061f6	237
579597e3	238	(defmethod present-slot ((slot has-many-slot-presentation) instance)
38a016c7	239	(when (slot-boundp slot 'ucw::place)
f1ce8b6e	240	(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
d5e996b3 DC	241	(let* ((i (get-foreign-instances slot instance))
	242	(presentation (and i (make-presentation (car i) :type :one-line))))
	243	(when i
	244	(flet ((linker (i string)
	245	(<ucw:a
	246	:action (view-instance slot i
	247	:initargs
	248	`(:global-properties ,
	249	(list
	250	:linkedp t
	251	:editablep nil)))
	252	(<:as-html string))))
	253	(<:table
	254	(<:tr
	255	(<:th) ;empty col for (view) link
	256	(dolist (s (slots presentation))
	257	(<:th (<:as-html (label s)))))
	258	(dolist (s i)
	259	(let ((s s))
	260	(setf (foreign-instance slot) s)
	261	(when (slot-boundp slot 'ucw::place)
	262	(<:tr
	263	(<:td (linker s " (view) "))
	264	(dolist (p (slots (make-presentation s :type :one-line
	265	:initargs
	266	'(:global-properties
	267	(:editablep nil)))))
	268	(<:td
	269
	270	(present-slot p s))))))))))))
	271
579597e3	272
	273	(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
	274	(slot-value instance (slot-name slot)))
	275
ec4f5786	276	(defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
	277	(get-foreign-instances slot instance))
	278
579597e3	279	(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
	280	((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
	281	(current :accessor current :initform 0)
	282	(len :accessor len )
	283	(instances :accessor instances))
579597e3	284	(:type-name has-very-many))
	285
	286	(defmethod list-next ((slot has-very-many-slot-presentation))
	287	(setf (current slot) (incf (current slot) (number-to-display slot)))
	288	(when (< (len slot) (current slot))
	289	(setf (current slot) (- (number-to-display slot) (len slot)))))
	290
	291	(defmethod list-prev ((slot has-very-many-slot-presentation))
	292	(setf (current slot) (decf (current slot) (number-to-display slot)))
	293	(when (> 0 (current slot))
	294	;;what to do here is open to debate
	295	(setf (current slot) (- (len slot)(number-to-display slot) ))))
	296
	297
	298	(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
	299	;;(<:as-html "isance: " instance)
38a016c7	300	(if (slot-boundp slot 'ucw::place)
f1ce8b6e DC	301	(progn
f1ce8b6e DC	302	(<ucw:a :action (list-prev slot) (<:as-html "<<"))
38a016c7	303	(let ((self (ucw::parent slot)))
f1ce8b6e DC	304	(<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
	305	(<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
	306	(<ucw:a :action (list-next slot) (<:as-html ">>"))
	307	(call-next-method)
	308	(<:as-html "total :" (len slot)))
	309	(call-next-method)))
579597e3	310
	311	(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
	312	(let ((f (call-next-method)))
	313	(setf (len slot) (length f))
	314	(setf (instances slot) f)
	315	(loop for cons on (nthcdr (current slot) f)
	316	for i from 0 upto (number-to-display slot)
	317	collect (car cons))))
	318
63c06c54 DC	319
	320	;;;; * Has-a
	321	(defslot-presentation has-a-slot-presentation (mewa-relation-slot-presentation)
	322	((allow-nil-p :accessor allow-nil-p :initarg :allow-nil-p :initform t)
	323	(attributes :accessor attributes :initarg :attributes :initform nil))
579597e3	324	(:type-name has-a))
579597e3	325
63c06c54 DC	326	(defmethod find-foreign-slot-value ((slot has-a-slot-presentation) (object t))
	327	(multiple-value-bind (c s)
	328	(meta-model:explode-foreign-key (instance (ucw::parent slot)) (slot-name slot))
	329	(slot-value object s)))
	330
	331	(defmethod get-foreign-instances ((slot mewa-relation-slot-presentation) instance)
	332	(clsql:select (class-name (class-of
	333	(meta-model:explode-foreign-key instance (slot-name slot))))
	334	:flatp t))
579597e3	335
579597e3	336	(defmethod present-slot ((slot has-a-slot-presentation) instance)
63c06c54	337	; (<:as-html (presentation-slot-value slot instance))
579597e3	338	(if (editablep slot)
63c06c54	339	(progn (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
579597e3	340	(when (allow-nil-p slot)
63c06c54 DC	341	(<ucw:option :value nil (<:as-html "none")))
	342	(dolist (option (get-foreign-instances slot instance))
	343	(<ucw:option :value (find-foreign-slot-value slot option)
	344	(lol:present
	345	(lol:make-presentation option
	346	:type :as-string
	347	:initargs
	348	`(:attributes ,(attributes slot)))
	349	))))
	350	(<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
579597e3	351	(if (presentation-slot-value slot instance)
579597e3	352	(progn
63c06c54 DC	353	(lol:present
	354	(lol:make-presentation (meta-model:explode-foreign-key instance (slot-name slot))
	355	:type :one-line
	356	:initargs
	357	`(:attributes ,(attributes slot)))
	358	))
85281029	359	(<:as-html "--"))))
5f0b37e7	360
5dea194e DC	361	(defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
	362	((list-view :accessor list-view :initarg :list-view :initform :one-line)
	363	(action-view :accessor action-view :initarg :action-view :initform :viewer)
fce59b36 DC	364	(create-view :initform :creator)
fce59b36 DC	365	(select-view :initform :as-string :accessor select-view))
5dea194e DC	366	(:type-name many-to-many)
5dea194e DC	367	(:default-initargs :label "many to many"))
5f0b37e7	368
fce59b36 DC	369	(defun %delete-item (item)
	370	(clsql:with-default-database (clsql:default-database)
	371	(ignore-errors
	372	(clsql:delete-instance-records item))))
	373
	374	(defaction delete-item ((self component) instance)
	375	(multiple-value-bind (res err) (%delete-item instance)
	376	(if (not err)
	377	(call 'info-message :message "Removed Instance")
	378	(call 'info-message :message (format nil "Could not remove item. Try removing associated items first. ~A" instance)))))
	379
	380	(defaction delete-relationship ((slot many-to-many-slot-presentation) rel instance)
	381	(delete-item (ucw::parent self) rel)
	382	(sync-instance instance)
	383	(answer-component (ucw::parent self) t))
	384
	385
	386	(defun find-many-to-many-join-class (slot instance)
	387	(let* ((imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
	388	:db-info))
	389	(jc (make-instance (getf imd :join-class)))
	390	(jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
	391	:db-info)))
	392	(getf jcmd :join-class)))
	393
fce59b36 DC	394	(defmethod find-all-instances ((slot many-to-many-slot-presentation) instance)
	395	(clsql:select (find-many-to-many-join-class slot instance) :flatp t))
	396
	397	(defmethod present-slot ((slot many-to-many-slot-presentation) instance)
	398	(let ((instances (slot-value instance (slot-name slot)))
	399	new-instance)
5dea194e	400	(<:ul
c1869452 DC	401	(<:li (<ucw:button :action (add-to-many-to-many slot instance)
c1869452 DC	402	(<:as-html "Add New")))
fce59b36 DC	403	(<:li (<ucw:button :action (add-to-many-to-many slot instance new-instance)
	404	(<:as-html "Add:"))
	405	(<ucw:select :accessor new-instance
	406	(arnesi:dolist* (i (find-all-instances slot instance))
	407	(<ucw:option
	408	:value i
	409	(lol:present-view (i (select-view slot) slot))))))
5dea194e DC	410	(dolist* (i instances)
5dea194e DC	411	(<:li
fce59b36	412	(<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
5dea194e	413	(<:as-html "(view) "))
fce59b36	414	(<ucw:a :action (delete-relationship slot (second i) instance)
5dea194e	415	(<:as-html "(remove) "))
fce59b36	416	(present-view ((car i) (list-view slot) (ucw::parent slot)))) ))))
5dea194e	417
fce59b36	418	(defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)
a4232a83 DC	419	;;;; First things first, we sync.
a4232a83 DC	420	(sync-instance instance)
5dea194e DC	421	(let* (new
	422	(imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
	423	:db-info))
	424	(jc (make-instance (getf imd :join-class)))
	425	(jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
	426	:db-info))
	427	(fc (make-instance (getf jcmd :join-class)))
fce59b36 DC	428	(c (if
	429	foreign-instance
	430	foreign-instance
	431	(call-view (fc :creator (ucw::parent slot))))))
5dea194e DC	432	(when c
5dea194e DC	433	(sync-instance c)
fce59b36	434	; (error "~A ~A ~A" (getf imd :foreign-key) (getf jcmd :foreign-key) (getf imd :home-key))
5dea194e DC	435	(setf (slot-value jc (getf imd :foreign-key))
	436	(slot-value instance (getf imd :home-key)))
	437	(setf (slot-value jc (getf jcmd :home-key))
	438	(slot-value c (getf jcmd :foreign-key)))
	439	(sync-instance jc)
fce59b36	440
5dea194e DC	441	(sync-instance instance)
	442	c)))
	443
	444
	445
5f0b37e7	446
2cb4247d DC	447
	448
	449
	450