src/slot-presentations.lisp

;; i know this is horrible, but it works wonders.
(declaim (optimize (speed 0) (space 3) (safety 0)))


(in-package :lisp-on-lines)


;;;; I dont think i'm using these anymore.
(defun multiple-value-funcall->list (function &rest args)
  "The function to be called by m-v-bf"
		   (multiple-value-call #'list (apply function args)))

(defmacro multiple-value-bindf (vars form &body body)
  "Like M-V-B, only it works in actions. form must be a function call"
		   `(destructuring-bind ,vars
		     (multiple-value-funcall->list #',(car form) ,@(cdr form))
		     ,@body))


;;;; ** Textarea Slot Presentation

(defslot-presentation text-slot-presentation ()
  ((rows :initarg :rows :accessor rows :initform 5)
   (columns :initarg :columns :accessor columns :initform 40)
   (escape-html-p :initarg :escape-html-p :accessor escape-html-p :initform nil)
   (convert-newlines-p :initarg :convert-newlines-p :accessor convert-newlines-p :initform nil))
  (:type-name text))

(defmethod present-slot ((slot text-slot-presentation) instance)
  (flet ((maybe-convert-newline-and-escape-html-then-print ()
	   (let ((string (if (convert-newlines-p slot)
			     (with-output-to-string (new-string)
			       (with-input-from-string
				   (s (presentation-slot-value slot instance))
				 (loop for line = (read-line s nil)
				       while line
				       do (format new-string "~A~A" line "<br/>"))))
			     (presentation-slot-value slot instance))))
	     (if (escape-html-p slot)
		 (<:as-html string)
		 (<:as-is string)))))

    (if (editablep slot)
	(<ucw:textarea
	 :accessor (presentation-slot-value slot instance)
	 :reader (or (presentation-slot-value slot instance)
		 "")
	 :rows (rows slot)
	 :cols (columns slot))
	(when (presentation-slot-value slot instance)
	  (maybe-convert-newline-and-escape-html-then-print)))))


(defcomponent mewa-slot-presentation ()
  ((validate-functions :accessor validate-functions :initform (list (constantly t)))
   (slot-name :accessor slot-name
	      :initarg :slot-name
	      :documentation
	      "The name of the slot being accessed")
   (fill-gaps-only-p :accessor fill-gaps-only-p
		     :initarg :fill-gaps-only-p
		     :initform nil
		     :documentation
		     "When nil, the instance is syncronised with the database.
When T, only the default value for primary keys and the joins are updated.")
   (show-label-p :accessor show-label-p :initarg :show-label-p :initform t)
   (creatablep :accessor creatablep :initarg :creatablep :initform t))
  (:documentation "The superclass of all Mewa slot presentations"))


;;;; this has to be in the eval when i would think
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun generate-slot-presentation-definition-for-type (type)
    (let* ((u-name (intern (format nil "~A-SLOT-PRESENTATION" type)))
	   (sp-name (intern (format nil "MEWA-~A" u-name)))
	   (t-name (intern (format nil "MEWA-~A" type))))
      `(defslot-presentation ,sp-name (,u-name mewa-slot-presentation)
	()
	(:type-name ,t-name)))))

(defmacro define-base-mewa-presentations (&body types)
  "Define the mewa-slot-presentations by subclassing the base UCW ones"
    `(progn ,@(mapcar #'generate-slot-presentation-definition-for-type
		      types)))

;;;then actually define the base presentations :
(define-base-mewa-presentations
  boolean
  string
  number
  integer
  currency)

(defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
       ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
	(trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
	(default-to-now-p :accessor default-to-now-p :initarg :default-to-now-p :initform nil))
       (:type-name clsql-sys:wall-time))

(defmethod lol::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 lol::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 lol::present-slot ((slot clsql-wall-time-slot-presentation) instance)
  (let ((date (lol::presentation-slot-value slot instance)))
    ;; Default values
    (when (and (not date) (default-to-now-p slot))
      (setf (lol::presentation-slot-value slot instance) (clsql:get-time)))
    ;;simple viewer
    (if (and date (not (editablep slot)))
	(<:as-html date))
    ;; editor
    (when (editablep slot)
      (<ucw:input :accessor (lol::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 (lol::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))))
		:order-by (car (list-keys (instance slot)))))


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

(defaction add-to-has-many ((slot has-many-slot-presentation) instance)
  ;; if the instance is not stored we must make sure to mark it stored now!
  (unless (meta-model::persistentp instance)
    (setf (mewa::modifiedp (ucw::parent self)) t))
  ;; sync up the instance
  ;;(mewa:ensure-instance-sync (parent slot))
  (meta-model:sync-instance (instance (ucw::parent slot)))

  (multiple-value-bindf (class home foreign)
      (meta-model:explode-has-many instance (slot-name slot))
    (let ((new (make-instance class)))
      (setf (slot-value new foreign) (slot-value instance home))
      (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
      (call-component (ucw::parent slot)  (mewa:make-presentation new :type (creator slot)))
      (meta-model:sync-instance instance))))

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

		   (present-slot p s))))))))))))


(defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
  (sort (slot-value instance (slot-name slot)) #'<
	:key #'(lambda (x) (funcall (car (list-keys x)) x))))

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

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

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

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


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

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


;;;; * Has-a
(defslot-presentation has-a-slot-presentation (mewa-relation-slot-presentation)
  ((allow-nil-p :accessor allow-nil-p :initarg :allow-nil-p :initform t)
   (attributes :accessor attributes :initarg :attributes :initform nil))
  (:type-name has-a))

(defmethod find-foreign-slot-value ((slot has-a-slot-presentation) (object t))
  (multiple-value-bind (c s)
      (meta-model:explode-foreign-key (instance (ucw::parent slot)) (slot-name slot))
    (slot-value object s)))

(defmethod get-foreign-instances ((slot mewa-relation-slot-presentation) instance)
  (clsql:select (class-name (class-of
			     (meta-model:explode-foreign-key instance (slot-name slot))))
		:flatp t))

(defmethod present-slot ((slot has-a-slot-presentation) instance)
;      (<:as-html (lol::presentation-slot-value slot instance))
  (if (editablep slot)
      (progn (<ucw:select :accessor (lol::presentation-slot-value slot instance) :test #'equalp
        (when (allow-nil-p slot)
	  (<ucw:option :value nil (<:as-html "none")))
	(dolist (option (get-foreign-instances slot instance))
	  (<ucw:option :value (find-foreign-slot-value slot option)
		       (lol::present
			(lol::make-presentation option
			   :type :as-string
			   :initargs
			   `(:attributes ,(attributes slot)))
			))))
	     (when (creatablep slot)
	       (<ucw:submit :action  (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline")))
      (if (lol::presentation-slot-value slot instance)
	  (progn
	   (lol::present
	    (lol:make-presentation (meta-model:explode-foreign-key instance (slot-name slot))
			   :type :one-line
			   :initargs
			   `(:attributes ,(attributes slot)))
			   ))
	   (<:as-html "--"))))

(defslot-presentation many-to-many-slot-presentation (mewa-relation-slot-presentation)
  ((list-view :accessor list-view :initarg :list-view :initform :one-line)
   (action-view :accessor action-view :initarg :action-view :initform :viewer)
   (create-view :initform :creator)
   (select-view :initform :as-string :accessor select-view))
  (:type-name many-to-many)
  (:default-initargs :label "many to many"))

(defun %delete-item (item)
  (clsql:with-default-database (clsql:*default-database*)
    (ignore-errors
    (clsql:delete-instance-records item))))

(defaction delete-item ((self component) instance)
  (multiple-value-bind (res err) (%delete-item instance)
  (if (not err)
      (call 'info-message :message "Removed Instance")
      (call 'info-message :message (format nil "Could not remove item. Try removing associated items first. ~A" instance)))))

(defaction delete-relationship ((slot many-to-many-slot-presentation) rel instance)
  (delete-item (ucw::parent self) rel)
  (sync-instance instance)
  (answer-component (ucw::parent self)   t))


(defun find-many-to-many-join-class (slot instance)
  (let* ((imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
		    :db-info))
	 (jc (make-instance (getf imd :join-class)))
	 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
		     :db-info)))
    (getf jcmd :join-class)))

(defmethod find-all-instances ((slot many-to-many-slot-presentation) instance)
  (clsql:select (find-many-to-many-join-class slot instance) :flatp t))

(defmethod present-slot ((slot many-to-many-slot-presentation) instance)
  (let ((instances (slot-value instance (slot-name slot)))
	new-instance)
    (<:ul
     (<:li (<ucw:button :action (add-to-many-to-many slot instance)
			 (<:as-html "Add New")))
     (<:li  (<ucw:button :action (add-to-many-to-many slot instance new-instance)
			 (<:as-html "Add:"))
	    (<ucw:select :accessor new-instance
			 (arnesi:dolist* (i (find-all-instances slot instance))
			   (<ucw:option
			    :value i
			    (lol:present-view (i (select-view slot) slot))))))
     (dolist* (i instances)
       (<:li
	(<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
		(<:as-html "(view) "))
	(<ucw:a :action (delete-relationship slot (second i) instance)
		(<:as-html "(remove) "))
	(present-view ((car i) (list-view slot) (ucw::parent slot))))))))


(defaction add-to-many-to-many ((slot many-to-many-slot-presentation) instance &optional foreign-instance)
  ;;;; First things first, we sync.
  (sync-instance instance)
  (let* (new
	 (imd (getf (meta-model::find-slot-metadata instance (slot-name slot))
		    :db-info))
	 (jc (make-instance (getf imd :join-class)))
	 (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
		     :db-info))
	 (fc (make-instance (getf jcmd :join-class)))
	 (c (if
	     foreign-instance
	     foreign-instance
	     (call-view (fc :creator (ucw::parent slot))))))
    (when c
      (sync-instance c)
;      (error "~A ~A ~A" (getf imd :foreign-key) (getf jcmd :foreign-key) (getf imd :home-key))
      (setf (slot-value jc (getf imd :foreign-key))
	    (slot-value instance (getf imd :home-key)))
      (setf (slot-value jc (getf jcmd :home-key))
	    (slot-value c (getf jcmd :foreign-key)))
      (sync-instance jc)

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