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