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

(defslot-presentation has-a-slot-presentation (foreign-key-slot-presentation)
  ()
  (:type-name has-a))

(defmethod present-slot ((slot has-a-slot-presentation) instance)
  t)

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

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

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

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

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

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

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

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


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

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

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

(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))
  (:type-name many-to-many)
  (:default-initargs :label "many to many"))

(defmethod present-slot ((slot many-to-many-slot-presentation) instance)
  
  (let ((instances (slot-value instance (slot-name slot))))
    (<:ul
     (<:li (<ucw:a :action (add-on-many-to-many slot instance)
		   (<:as-html "Add New")))
     (dolist* (i instances)
       (<:li
	(<ucw:a :action (call-view ((car i) (action-view slot) slot))
		(<:as-html "(view) "))
	(<ucw:a :action (delete-item (ucw::parent slot) (second i))
		(<:as-html "(remove) "))
	(present-view ((car i)  (list-view slot) (ucw::parent slot)))) ))))

(defaction add-on-many-to-many ((slot many-to-many-slot-presentation) 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 (call-view (fc :creator (ucw::parent slot)))))

    (when c
      (sync-instance c)
      (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 ()
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)
5dea194e	197	(render)
f1ce8b6e	198	(<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
569ad9e6	199	(<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
f1ce8b6e DC	200	((linkedp slot)
	201	(<ucw:a :action (view-instance slot (foreign-instance slot))
	202	(render)))
	203	(t
	204	(render)))
	205	;; presentation is used only for rendering
	206	(render))))
579597e3	207
d2512426	208
5dea194e DC	209	(defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
5dea194e DC	210	(clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))))
38a016c7	211
5dea194e DC	212	(defslot-presentation has-a-slot-presentation (foreign-key-slot-presentation)
	213	()
	214	(:type-name has-a))
	215
	216	(defmethod present-slot ((slot has-a-slot-presentation) instance)
	217	t)
d2512426	218
579597e3	219	;;;; HAS MANY
579597e3	220	(defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
12dcf3d4	221	((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
579597e3	222	(:type-name has-many))
579597e3	223
498061f6	224	(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
8e6e6b56	225	;; if the instance is not stored we must make sure to mark it stored now!
5dea194e	226	(unless (meta-model::persistentp instance)
38a016c7	227	(setf (mewa::modifiedp (ucw::parent self)) t))
8e6e6b56	228	;; sync up the instance
ec044146	229	;;(mewa:ensure-instance-sync (parent slot))
38a016c7	230	(meta-model:sync-instance (instance (ucw::parent slot)))
ec044146	231
85281029 DC	232	(multiple-value-bindf (class home foreign)
85281029 DC	233	(meta-model:explode-has-many instance (slot-name slot))
498061f6	234	(let ((new (make-instance class)))
498061f6	235	(setf (slot-value new foreign) (slot-value instance home))
e9454185	236	(meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
38a016c7	237	(call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
e9454185	238	(meta-model:sync-instance instance))))
498061f6	239
579597e3	240	(defmethod present-slot ((slot has-many-slot-presentation) instance)
38a016c7	241	(when (slot-boundp slot 'ucw::place)
f1ce8b6e	242	(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
d5e996b3 DC	243	(let* ((i (get-foreign-instances slot instance))
	244	(presentation (and i (make-presentation (car i) :type :one-line))))
	245	(when i
	246	(flet ((linker (i string)
	247	(<ucw:a
	248	:action (view-instance slot i
	249	:initargs
	250	`(:global-properties ,
	251	(list
	252	:linkedp t
	253	:editablep nil)))
	254	(<:as-html string))))
	255	(<:table
	256	(<:tr
	257	(<:th) ;empty col for (view) link
	258	(dolist (s (slots presentation))
	259	(<:th (<:as-html (label s)))))
	260	(dolist (s i)
	261	(let ((s s))
	262	(setf (foreign-instance slot) s)
	263	(when (slot-boundp slot 'ucw::place)
	264	(<:tr
	265	(<:td (linker s " (view) "))
	266	(dolist (p (slots (make-presentation s :type :one-line
	267	:initargs
	268	'(:global-properties
	269	(:editablep nil)))))
	270	(<:td
	271
	272	(present-slot p s))))))))))))
	273
579597e3	274
	275	(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
	276	(slot-value instance (slot-name slot)))
	277
ec4f5786	278	(defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
	279	(get-foreign-instances slot instance))
	280
579597e3	281	(defslot-presentation has-very-many-slot-presentation (has-many-slot-presentation)
	282	((number-to-display :accessor number-to-display :initarg :number-to-display :initform 10)
	283	(current :accessor current :initform 0)
	284	(len :accessor len )
	285	(instances :accessor instances))
579597e3	286	(:type-name has-very-many))
	287
	288	(defmethod list-next ((slot has-very-many-slot-presentation))
	289	(setf (current slot) (incf (current slot) (number-to-display slot)))
	290	(when (< (len slot) (current slot))
	291	(setf (current slot) (- (number-to-display slot) (len slot)))))
	292
	293	(defmethod list-prev ((slot has-very-many-slot-presentation))
	294	(setf (current slot) (decf (current slot) (number-to-display slot)))
	295	(when (> 0 (current slot))
	296	;;what to do here is open to debate
	297	(setf (current slot) (- (len slot)(number-to-display slot) ))))
	298
	299
	300	(defmethod present-slot ((slot has-very-many-slot-presentation) instance)
	301	;;(<:as-html "isance: " instance)
38a016c7	302	(if (slot-boundp slot 'ucw::place)
f1ce8b6e DC	303	(progn
f1ce8b6e DC	304	(<ucw:a :action (list-prev slot) (<:as-html "<<"))
38a016c7	305	(let ((self (ucw::parent slot)))
f1ce8b6e DC	306	(<ucw:a :action (call-component self (mewa:make-presentation (car (slot-value instance (slot-name slot))) :type :listing :initargs (list :instances (instances slot))))
	307	(<:as-html (label slot) (format nil " ~a-~a " (current slot) (+ (current slot) (number-to-display slot))))))
	308	(<ucw:a :action (list-next slot) (<:as-html ">>"))
	309	(call-next-method)
	310	(<:as-html "total :" (len slot)))
	311	(call-next-method)))
579597e3	312
	313	(defmethod get-foreign-instances :around ((slot has-very-many-slot-presentation) instance)
	314	(let ((f (call-next-method)))
	315	(setf (len slot) (length f))
	316	(setf (instances slot) f)
	317	(loop for cons on (nthcdr (current slot) f)
	318	for i from 0 upto (number-to-display slot)
	319	collect (car cons))))
	320
	321	(defslot-presentation has-a-slot-presentation (one-of-presentation)
	322	((key :initarg :key :accessor key))
	323	(:type-name has-a))
	324
	325	(defmethod get-foreign-slot-value ((slot has-a-slot-presentation) (object t) (slot-name t))
	326	(slot-value object slot-name))
	327
	328	(defmethod present-slot ((slot has-a-slot-presentation) instance)
	329	(<:as-html (presentation-slot-value slot instance))
	330	(if (editablep slot)
	331	(<ucw:select :accessor (presentation-slot-value slot instance) :test #'equalp
	332	(when (allow-nil-p slot)
	333	(<ucw:option :value nil (<:as-html (none-label slot))))
	334	(dolist (option (get-foreign-instances (presentation slot) instance))
	335	(setf (instance (presentation slot)) option)
	336	(<ucw:option :value (get-foreign-slot-value slot option (key slot)) (present (presentation slot)))))
	337	(if (presentation-slot-value slot instance)
	338	(progn
	339	(setf (instance (presentation slot)) (presentation-slot-value slot instance))
	340	(present (presentation slot)))
85281029	341	(<:as-html "--"))))
5f0b37e7	342
5dea194e DC	343	(defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
	344	((list-view :accessor list-view :initarg :list-view :initform :one-line)
	345	(action-view :accessor action-view :initarg :action-view :initform :viewer)
	346	(create-view :initform :creator))
	347	(:type-name many-to-many)
	348	(:default-initargs :label "many to many"))
5f0b37e7	349
5dea194e DC	350	(defmethod present-slot ((slot many-to-many-slot-presentation) instance)
	351
	352	(let ((instances (slot-value instance (slot-name slot))))
	353	(<:ul
	354	(<:li (<ucw:a :action (add-on-many-to-many slot instance)
	355	(<:as-html "Add New")))
	356	(dolist* (i instances)
	357	(<:li
	358	(<ucw:a :action (call-view ((car i) (action-view slot) slot))
	359	(<:as-html "(view) "))
	360	(<ucw:a :action (delete-item (ucw::parent slot) (second i))
	361	(<:as-html "(remove) "))
	362	(present-view ((car i) (list-view slot) (ucw::parent slot)))) ))))
	363
	364	(defaction add-on-many-to-many ((slot many-to-many-slot-presentation) instance)
	365	(let* (new
	366	(imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
	367	:db-info))
	368	(jc (make-instance (getf imd :join-class)))
	369	(jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
	370	:db-info))
	371	(fc (make-instance (getf jcmd :join-class)))
	372	(c (call-view (fc :creator (ucw::parent slot)))))
	373
	374	(when c
	375	(sync-instance c)
	376	(setf (slot-value jc (getf imd :foreign-key))
	377	(slot-value instance (getf imd :home-key)))
	378	(setf (slot-value jc (getf jcmd :home-key))
	379	(slot-value c (getf jcmd :foreign-key)))
	380	(sync-instance jc)
	381	(sync-instance instance)
	382	c)))
	383
	384
	385
5f0b37e7	386
2cb4247d DC	387
	388
	389
	390