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

(in-package :mewa)

(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 25)
   (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)
		     :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)
           (<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))))


;;;; 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 (mewa::instance-is-stored-p 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))))

(defslot-presentation has-a-slot-presentation (one-of-presentation)
  ((key :initarg :key :accessor key))
  (:type-name has-a))

(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
  (slot-value object slot-name))

(defmethod present-slot ((slot has-a-slot-presentation) instance)
      (<:as-html (presentation-slot-value slot instance))
  (if (editablep slot)
      (<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
        (when (allow-nil-p slot)
	  (<ucw:option :value nil (<:as-html (none-label slot))))
	(dolist (option (get-foreign-instances (presentation slot) instance))
	  (setf (instance (presentation slot)) option)
	  (<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
      (if (presentation-slot-value slot instance)
	  (progn
	    (setf (instance (presentation slot)) (presentation-slot-value slot instance))
	    (present (presentation slot)))
	  (<:as-html "--"))))
Commit	Line	Data
38a016c7	1	(in-package :mewa)
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 ()
d5e996b3 DC	17	((rows :initarg :rows :accessor rows :initform 25)
	18	(columns :initarg :columns :accessor columns :initform 40)
	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)
	23	(if (editablep slot)
	24	(<ucw:textarea :accessor (presentation-slot-value slot instance)
	25	:rows (rows slot)
	26	:cols (columns slot))
	27	(if (escape-html-p slot)
d5e996b3	28	(<:as-html (presentation-slot-value slot instance))
4b893987	29	(<:as-is (presentation-slot-value slot instance)))))
44108fd6 DC	30
44108fd6 DC	31
e9454185 DC	32	(defcomponent mewa-slot-presentation ()
	33	((slot-name :accessor slot-name
	34	:initarg :slot-name
	35	:documentation
	36	"The name of the slot being accessed")
	37	(fill-gaps-only-p :accessor fill-gaps-only-p
	38	:initarg :fill-gaps-only-p
	39	:initform nil
	40	:documentation
	41	"When nil, the instance is syncronised with the database.
68a53dce DC	42	When T, only the default value for primary keys and the joins are updated.")
68a53dce DC	43	(show-label-p :accessor show-label-p :initarg :show-label-p :initform t))
e9454185 DC	44	(:documentation "The superclass of all Mewa slot presentations"))
	45
	46	;;;; this has to be in the eval when i would think
	47	(eval-when (:compile-toplevel :load-toplevel :execute)
	48	(defun generate-slot-presentation-definition-for-type (type)
	49	(let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
	50	(sp-name (intern (format nil "MEWA-~A" u-name)))
	51	(t-name (intern (format nil "MEWA-~A" type))))
	52	`(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
	53	()
	54	(:type-name ,t-name)))))
	55
	56	(defmacro define-base-mewa-presentations (&body types)
	57	"Define the mewa-slot-presentations by subclassing the base UCW ones"
	58	`(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
	59	types)))
	60
	61	;;;then actually define the base presentations :
	62	(define-base-mewa-presentations
	63	boolean
	64	string
	65	number
	66	integer
	67	currency)
9d6c69fb	68
f4170204	69	(defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
d5e996b3 DC	70	((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
d5e996b3 DC	71	(trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)))
579597e3	72	(:type-name clsql-sys:wall-time))
	73
	74	(defmethod presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
	75	(let ((date (call-next-method)))
	76	(when date (multiple-value-bind (y m d) (clsql:time-ymd date)
	77	(format nil "~a/~a/~a" m d y)))))
	78
	79	(defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
f4170204	80	(let ((new-time (clsql:parse-date-time (remove #\Space value)))
	81	(old-time (when (slot-boundp instance (slot-name slot))
	82	(slot-value instance (slot-name slot)))))
	83	(unless (or (eql old-time new-time)
ec4f5786	84	(when (and new-time old-time)
	85	(equal :equal (clsql:time-compare new-time old-time))))
	86	(setf (presentation-slot-value slot instance) new-time ))))
579597e3	87
19531fbd	88	(defmethod label :around ((slot clsql-wall-time-slot-presentation))
ec044146	89	(concatenate 'string (call-next-method) " (m/d/y)"))
19531fbd	90
579597e3	91	(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
d5e996b3	92	(let ((date (presentation-slot-value slot instance)))
579597e3	93	(if (and date (not (editablep slot)))
d2dbe50f	94	(<:as-html date))
579597e3	95	(when (editablep slot)
d5e996b3 DC	96	(<ucw:input :accessor (presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
d5e996b3 DC	97	(<:button :id (trigger-id slot) (<:as-html "[...]"))
579597e3	98	(<:script :type "text/javascript"
579597e3	99	(<:as-is (format nil "
d5e996b3 DC	100
	101	Calendar.setup({
	102	inputField : \"~a\",
	103	button : \"~a\",
	104	ifFormat : \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))
579597e3	105
e9454185 DC	106	(defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
e9454185 DC	107	((foreign-instance :accessor foreign-instance)
569ad9e6	108	(linkedp :accessor linkedp :initarg :linkedp :initform t)
38a016c7 DC	109	(creator :accessor creator :initarg :creator :initform :editor)
38a016c7 DC	110	(new-instance :accessor new-instance :initform nil))
579597e3	111	(:type-name relation))
579597e3	112
7d87c1d2	113	(defaction search-records ((slot mewa-relation-slot-presentation) instance)
e9454185 DC	114	(multiple-value-bindf (finstance foreign-slot-name)
e9454185 DC	115	(meta-model:explode-foreign-key instance (slot-name slot))
38a016c7 DC	116	(let ((new-instance (new-instance self)))
	117	(unless new-instance
	118	(setf (new-instance self)
	119	(call-component
	120	(ucw::parent slot)
	121	(make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
	122	'mewa::mewa-presentation-search)
	123	:search-presentation
	124	(mewa:make-presentation finstance
	125	:type :search-presentation)
	126	:list-presentation
	127	(mewa:make-presentation finstance
	128	:type :listing)))))
	129	(sync-foreign-instance slot new-instance))))
	130
	131	(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
	132	(let ((instance (instance (ucw::parent slot))))
	133	(multiple-value-bind (foo f-slot-name)
	134	(meta-model:explode-foreign-key instance (slot-name slot))
	135	(setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
	136	(meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
	137
	138
569ad9e6	139	(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
e9454185 DC	140	(multiple-value-bindf (finstance foreign-slot-name)
	141	(meta-model:explode-foreign-key instance (slot-name slot))
	142	(let ((new-instance
	143	(call-component
38a016c7	144	(ucw::parent slot)
569ad9e6 DC	145	(mewa:make-presentation finstance :type (creator self)))))
	146
	147	;;;; TODO: this next bit is due to a bad design decision.
	148	;;;; Components should always have (ok) return self, but somewhere
	149	;;;; i've made in return (instance self) sometimes, and this
	150	;;;; bahaviour is totatlly fucked.
	151
	152	(when (typep new-instance 'mewa::mewa)
	153	(setf new-instance (instance new-instance)))
	154
	155	;;;; sorry about that, and now back t our regular program.
	156
	157	(meta-model:sync-instance new-instance)
e9454185 DC	158	(setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
e9454185 DC	159	(meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
569ad9e6	160
e9454185	161
579597e3	162	(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
579597e3	163	;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
19531fbd	164	(let* ((i (foreign-instance slot))
579597e3	165	(pres (mewa::make-presentation
	166	i
	167	:type :one-line
	168	:initargs (list
	169	:global-properties
19531fbd	170	(list :editablep nil :linkedp nil)))))
9d6c69fb	171	(when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
498061f6	172	(setf (component.place pres) (component.place (ucw::parent slot))))
498061f6	173	(when i (<ucw:render-component :component pres))))
579597e3	174
	175	(defmethod present-slot ((slot mewa-relation-slot-presentation) instance)
	176	(present-relation slot instance))
	177
	178	(defslot-presentation foreign-key-slot-presentation (mewa-relation-slot-presentation)
	179	()
	180	(:type-name foreign-key)
	181	(:default-initargs))
	182
	183	(defaction view-instance ((self component) instance &rest initargs)
38a016c7	184	(call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
12dcf3d4	185	;; the viewed instance could have been changed/deleted, so we sync this instance
38a016c7	186	(meta-model:sync-instance (instance (ucw::parent self))))
579597e3	187
498061f6	188
569ad9e6	189	(defmethod present-slot :around ((slot foreign-key-slot-presentation) instance)
f1ce8b6e DC	190	(setf (foreign-instance slot)
	191	(when (presentation-slot-value slot instance)
	192	(meta-model:explode-foreign-key instance (slot-name slot))))
f1ce8b6e	193	(flet ((render () (when (foreign-instance slot)(call-next-method))))
38a016c7	194	(if (slot-boundp slot 'ucw::place)
f1ce8b6e DC	195	(cond
f1ce8b6e DC	196	((editablep slot)
f1ce8b6e	197	(<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
569ad9e6	198	(<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
f1ce8b6e DC	199	((linkedp slot)
	200	(<ucw:a :action (view-instance slot (foreign-instance slot))
	201	(render)))
	202	(t
	203	(render)))
	204	;; presentation is used only for rendering
	205	(render))))
579597e3	206
d2512426	207
38a016c7	208
d2512426	209
579597e3	210	;;;; HAS MANY
579597e3	211	(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
12dcf3d4	212	((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
579597e3	213	(:type-name has-many))
579597e3	214
498061f6	215	(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
8e6e6b56 DC	216	;; if the instance is not stored we must make sure to mark it stored now!
8e6e6b56 DC	217	(unless (mewa::instance-is-stored-p instance)
38a016c7	218	(setf (mewa::modifiedp (ucw::parent self)) t))
8e6e6b56	219	;; sync up the instance
ec044146	220	;;(mewa:ensure-instance-sync (parent slot))
38a016c7	221	(meta-model:sync-instance (instance (ucw::parent slot)))
ec044146	222
85281029 DC	223	(multiple-value-bindf (class home foreign)
85281029 DC	224	(meta-model:explode-has-many instance (slot-name slot))
498061f6	225	(let ((new (make-instance class)))
498061f6	226	(setf (slot-value new foreign) (slot-value instance home))
e9454185	227	(meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
38a016c7	228	(call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
e9454185	229	(meta-model:sync-instance instance))))
498061f6	230
579597e3	231	(defmethod present-slot ((slot has-many-slot-presentation) instance)
38a016c7	232	(when (slot-boundp slot 'ucw::place)
f1ce8b6e	233	(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
d5e996b3 DC	234	(let* ((i (get-foreign-instances slot instance))
	235	(presentation (and i (make-presentation (car i) :type :one-line))))
	236	(when i
	237	(flet ((linker (i string)
	238	(<ucw:a
	239	:action (view-instance slot i
	240	:initargs
	241	`(:global-properties ,
	242	(list
	243	:linkedp t
	244	:editablep nil)))
	245	(<:as-html string))))
	246	(<:table
	247	(<:tr
	248	(<:th) ;empty col for (view) link
	249	(dolist (s (slots presentation))
	250	(<:th (<:as-html (label s)))))
	251	(dolist (s i)
	252	(let ((s s))
	253	(setf (foreign-instance slot) s)
	254	(when (slot-boundp slot 'ucw::place)
	255	(<:tr
	256	(<:td (linker s " (view) "))
	257	(dolist (p (slots (make-presentation s :type :one-line
	258	:initargs
	259	'(:global-properties
	260	(:editablep nil)))))
	261	(<:td
	262
	263	(present-slot p s))))))))))))
	264
579597e3	265
	266	(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
	267	(slot-value instance (slot-name slot)))
	268
ec4f5786	269	(defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
	270	(get-foreign-instances slot instance))
	271
579597e3	272	(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
	273	((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
	274	(current :accessor current :initform 0)
	275	(len :accessor len )
	276	(instances :accessor instances))
579597e3	277	(:type-name has-very-many))
	278
	279	(defmethod list-next ((slot has-very-many-slot-presentation))
	280	(setf (current slot) (incf (current slot) (number-to-display slot)))
	281	(when (< (len slot) (current slot))
	282	(setf (current slot) (- (number-to-display slot) (len slot)))))
	283
	284	(defmethod list-prev ((slot has-very-many-slot-presentation))
	285	(setf (current slot) (decf (current slot) (number-to-display slot)))
	286	(when (> 0 (current slot))
	287	;;what to do here is open to debate
	288	(setf (current slot) (- (len slot)(number-to-display slot) ))))
	289
	290
	291	(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
	292	;;(<:as-html "isance: " instance)
38a016c7	293	(if (slot-boundp slot 'ucw::place)
f1ce8b6e DC	294	(progn
f1ce8b6e DC	295	(<ucw:a :action (list-prev slot) (<:as-html "<<"))
38a016c7	296	(let ((self (ucw::parent slot)))
f1ce8b6e DC	297	(<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
	298	(<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
	299	(<ucw:a :action (list-next slot) (<:as-html ">>"))
	300	(call-next-method)
	301	(<:as-html "total :" (len slot)))
	302	(call-next-method)))
579597e3	303
	304	(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
	305	(let ((f (call-next-method)))
	306	(setf (len slot) (length f))
	307	(setf (instances slot) f)
	308	(loop for cons on (nthcdr (current slot) f)
	309	for i from 0 upto (number-to-display slot)
	310	collect (car cons))))
	311
	312	(defslot-presentation has-a-slot-presentation (one-of-presentation)
	313	((key :initarg :key :accessor key))
	314	(:type-name has-a))
	315
	316	(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
	317	(slot-value object slot-name))
	318
	319	(defmethod present-slot ((slot has-a-slot-presentation) instance)
	320	(<:as-html (presentation-slot-value slot instance))
	321	(if (editablep slot)
	322	(<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
	323	(when (allow-nil-p slot)
	324	(<ucw:option :value nil (<:as-html (none-label slot))))
	325	(dolist (option (get-foreign-instances (presentation slot) instance))
	326	(setf (instance (presentation slot)) option)
	327	(<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
	328	(if (presentation-slot-value slot instance)
	329	(progn
	330	(setf (instance (presentation slot)) (presentation-slot-value slot instance))
	331	(present (presentation slot)))
85281029	332	(<:as-html "--"))))
5f0b37e7	333
5f0b37e7	334
5f0b37e7	335
2cb4247d DC	336
	337
	338
	339