[clinton/lisp-on-lines.git] / src / mewa / 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 nil)
   (columns :initarg :columns :accessor columns :initform nil)
   (html-contentp :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-is (presentation-slot-value slot instance))
	  (<:as-html (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)
       ()
       (: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))
	(input-id (string (gensym))))
    (if (and date (not (editablep slot)))
	(<:span (<:as-html date)))
    (when (editablep slot)
      (<ucw:input :accessor (presentation-slot-value slot instance) :id input-id)
      (<:script :type "text/javascript" 
		(<:as-is (format nil " 
      Calendar.setup({
        inputField     :    \"~a\",
        ifFormat       :    \"%m/%d/%Y\",
      });" input-id))))))

(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)))
	
    (<:ul 
     (dolist (s i)
       (let ((s s))
	 (setf (foreign-instance slot) s)
         (when (slot-boundp slot 'ucw::place)
           (<ucw:a :action (view-instance slot s :initargs `(:global-properties ,(list :linkedp t :editablep nil)))
		 (<:li   (setf (linkedp slot) nil)
			 (present-relation slot instance)))))))))


(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
	16	(defslot-presentation text-slot-presentation ()
	17	((rows :initarg :rows :accessor rows :initform nil)
	18	(columns :initarg :columns :accessor columns :initform nil)
	19	(html-contentp :initarg :escape-html-p :accessor escape-html-p :initform nil))
	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)
	28	(<:as-is (presentation-slot-value slot instance))
	29	(<:as-html (presentation-slot-value slot instance)))))
	30
	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)
579597e3	70	()
	71	(:type-name clsql-sys:wall-time))
	72
	73	(defmethod presentation-slot-value ((slot clsql-wall-time-slot-presentation) instance)
	74	(let ((date (call-next-method)))
	75	(when date (multiple-value-bind (y m d) (clsql:time-ymd date)
	76	(format nil "~a/~a/~a" m d y)))))
	77
	78	(defmethod (setf presentation-slot-value) ((value string) (slot clsql-wall-time-slot-presentation) instance)
f4170204	79	(let ((new-time (clsql:parse-date-time (remove #\Space value)))
	80	(old-time (when (slot-boundp instance (slot-name slot))
	81	(slot-value instance (slot-name slot)))))
	82	(unless (or (eql old-time new-time)
ec4f5786	83	(when (and new-time old-time)
	84	(equal :equal (clsql:time-compare new-time old-time))))
	85	(setf (presentation-slot-value slot instance) new-time ))))
579597e3	86
19531fbd	87	(defmethod label :around ((slot clsql-wall-time-slot-presentation))
ec044146	88	(concatenate 'string (call-next-method) " (m/d/y)"))
19531fbd	89
579597e3	90	(defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
	91	(let ((date (presentation-slot-value slot instance))
	92	(input-id (string (gensym))))
	93	(if (and date (not (editablep slot)))
	94	(<:span (<:as-html date)))
	95	(when (editablep slot)
	96	(<ucw:input :accessor (presentation-slot-value slot instance) :id input-id)
	97	(<:script :type "text/javascript"
	98	(<:as-is (format nil "
	99	Calendar.setup({
	100	inputField : \"~a\",
	101	ifFormat : \"%m/%d/%Y\",
	102	});" input-id))))))
	103
e9454185 DC	104	(defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
e9454185 DC	105	((foreign-instance :accessor foreign-instance)
569ad9e6	106	(linkedp :accessor linkedp :initarg :linkedp :initform t)
38a016c7 DC	107	(creator :accessor creator :initarg :creator :initform :editor)
38a016c7 DC	108	(new-instance :accessor new-instance :initform nil))
579597e3	109	(:type-name relation))
579597e3	110
7d87c1d2	111	(defaction search-records ((slot mewa-relation-slot-presentation) instance)
e9454185 DC	112	(multiple-value-bindf (finstance foreign-slot-name)
e9454185 DC	113	(meta-model:explode-foreign-key instance (slot-name slot))
38a016c7 DC	114	(let ((new-instance (new-instance self)))
	115	(unless new-instance
	116	(setf (new-instance self)
	117	(call-component
	118	(ucw::parent slot)
	119	(make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
	120	'mewa::mewa-presentation-search)
	121	:search-presentation
	122	(mewa:make-presentation finstance
	123	:type :search-presentation)
	124	:list-presentation
	125	(mewa:make-presentation finstance
	126	:type :listing)))))
	127	(sync-foreign-instance slot new-instance))))
	128
	129	(defmethod sync-foreign-instance ((slot mewa-relation-slot-presentation) foreign-instance)
	130	(let ((instance (instance (ucw::parent slot))))
	131	(multiple-value-bind (foo f-slot-name)
	132	(meta-model:explode-foreign-key instance (slot-name slot))
	133	(setf (slot-value instance (slot-name slot)) (slot-value foreign-instance f-slot-name))
	134	(meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p slot)))))
	135
	136
569ad9e6	137	(defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
e9454185 DC	138	(multiple-value-bindf (finstance foreign-slot-name)
	139	(meta-model:explode-foreign-key instance (slot-name slot))
	140	(let ((new-instance
	141	(call-component
38a016c7	142	(ucw::parent slot)
569ad9e6 DC	143	(mewa:make-presentation finstance :type (creator self)))))
	144
	145	;;;; TODO: this next bit is due to a bad design decision.
	146	;;;; Components should always have (ok) return self, but somewhere
	147	;;;; i've made in return (instance self) sometimes, and this
	148	;;;; bahaviour is totatlly fucked.
	149
	150	(when (typep new-instance 'mewa::mewa)
	151	(setf new-instance (instance new-instance)))
	152
	153	;;;; sorry about that, and now back t our regular program.
	154
	155	(meta-model:sync-instance new-instance)
e9454185 DC	156	(setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
e9454185 DC	157	(meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
569ad9e6	158
e9454185	159
579597e3	160	(defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
579597e3	161	;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
19531fbd	162	(let* ((i (foreign-instance slot))
579597e3	163	(pres (mewa::make-presentation
	164	i
	165	:type :one-line
	166	:initargs (list
	167	:global-properties
19531fbd	168	(list :editablep nil :linkedp nil)))))
9d6c69fb	169	(when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
498061f6	170	(setf (component.place pres) (component.place (ucw::parent slot))))
498061f6	171	(when i (<ucw:render-component :component pres))))
579597e3	172
7d87c1d2	173
7d87c1d2	174
579597e3	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 DC	233	(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
	234	(let ((i (get-foreign-instances slot instance)))
	235
498061f6	236	(<:ul
	237	(dolist (s i)
	238	(let ((s s))
	239	(setf (foreign-instance slot) s)
38a016c7	240	(when (slot-boundp slot 'ucw::place)
e9454185	241	(<ucw:a :action (view-instance slot s :initargs `(:global-properties ,(list :linkedp t :editablep nil)))
498061f6	242	(<:li (setf (linkedp slot) nil)
e9454185	243	(present-relation slot instance)))))))))
579597e3	244
	245
	246	(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
	247	(slot-value instance (slot-name slot)))
	248
ec4f5786	249	(defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
	250	(get-foreign-instances slot instance))
	251
579597e3	252	(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
	253	((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
	254	(current :accessor current :initform 0)
	255	(len :accessor len )
	256	(instances :accessor instances))
579597e3	257	(:type-name has-very-many))
	258
	259	(defmethod list-next ((slot has-very-many-slot-presentation))
	260	(setf (current slot) (incf (current slot) (number-to-display slot)))
	261	(when (< (len slot) (current slot))
	262	(setf (current slot) (- (number-to-display slot) (len slot)))))
	263
	264	(defmethod list-prev ((slot has-very-many-slot-presentation))
	265	(setf (current slot) (decf (current slot) (number-to-display slot)))
	266	(when (> 0 (current slot))
	267	;;what to do here is open to debate
	268	(setf (current slot) (- (len slot)(number-to-display slot) ))))
	269
	270
	271	(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
	272	;;(<:as-html "isance: " instance)
38a016c7	273	(if (slot-boundp slot 'ucw::place)
f1ce8b6e DC	274	(progn
f1ce8b6e DC	275	(<ucw:a :action (list-prev slot) (<:as-html "<<"))
38a016c7	276	(let ((self (ucw::parent slot)))
f1ce8b6e DC	277	(<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
	278	(<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
	279	(<ucw:a :action (list-next slot) (<:as-html ">>"))
	280	(call-next-method)
	281	(<:as-html "total :" (len slot)))
	282	(call-next-method)))
579597e3	283
	284	(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
	285	(let ((f (call-next-method)))
	286	(setf (len slot) (length f))
	287	(setf (instances slot) f)
	288	(loop for cons on (nthcdr (current slot) f)
	289	for i from 0 upto (number-to-display slot)
	290	collect (car cons))))
	291
	292	(defslot-presentation has-a-slot-presentation (one-of-presentation)
	293	((key :initarg :key :accessor key))
	294	(:type-name has-a))
	295
	296	(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
	297	(slot-value object slot-name))
	298
	299	(defmethod present-slot ((slot has-a-slot-presentation) instance)
	300	(<:as-html (presentation-slot-value slot instance))
	301	(if (editablep slot)
	302	(<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
	303	(when (allow-nil-p slot)
	304	(<ucw:option :value nil (<:as-html (none-label slot))))
	305	(dolist (option (get-foreign-instances (presentation slot) instance))
	306	(setf (instance (presentation slot)) option)
	307	(<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
	308	(if (presentation-slot-value slot instance)
	309	(progn
	310	(setf (instance (presentation slot)) (presentation-slot-value slot instance))
	311	(present (presentation slot)))
85281029	312	(<:as-html "--"))))
5f0b37e7	313
5f0b37e7	314
5f0b37e7	315
2cb4247d DC	316
	317
	318
	319