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

(in-package :it.bese.ucw)

(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
;;;;  This should really be in UCW.

(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) "  (mm/dd/yyyy)"))

(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))
  (: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
            (call-component 
             (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)))))
      (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)))))

(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
            (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 (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 (parent self))))


(defmethod present-slot :before ((slot foreign-key-slot-presentation) instance)
  ())


(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 '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))))

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