X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/5f0b37e7a9a8e95dd5a846bfa7896af5875b91f7..d25124264c5fc11612eee640a7ef568ed08d7db6:/src/mewa/slot-presentations.lisp

diff --git a/src/mewa/slot-presentations.lisp b/src/mewa/slot-presentations.lisp
index cbd2525..1454c53 100644
--- a/src/mewa/slot-presentations.lisp
+++ b/src/mewa/slot-presentations.lisp
@@ -10,6 +10,26 @@
 		     (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 
@@ -20,7 +40,8 @@
 		     :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."))
+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
@@ -46,7 +67,6 @@ When T, only the default value for primary keys and the joins are updated."))
   integer
   currency)
 
-
 (defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
        ()
        (:type-name clsql-sys:wall-time))
@@ -82,8 +102,6 @@ When T, only the default value for primary keys and the joins are updated."))
         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)
@@ -183,6 +201,68 @@ When T, only the default value for primary keys and the joins are updated."))
 	;; presentation is used only for rendering
         (render))))
 
+
+;;;; * AJAX stuff 
+
+;;;; TODO: This search stuff should probably me refactored elsewhere
+
+(defmethod find-slots-of-type (model &key (type 'string)
+			      (types '((string)) types-supplied-p))
+  "returns a list of slots matching TYPE, or matching any of TYPES"
+  (let (ty)
+    (if types-supplied-p 
+	(setf ty types)
+	(setf ty (list type)))
+    (remove nil (mapcar #'(lambda (st) (when (member (second st) ty)
+					 (first st)))
+	     (lisp-on-lines::list-slot-types model)))))
+
+(defslot-presentation ajax-foreign-key-slot-presentation (foreign-key-slot-presentation)
+  ((search-slots :accessor search-slots :initarg :search-slots :initform nil)
+   (live-search 
+     :accessor live-search
+     :component (lisp-on-lines:auto-complete
+		 :values-generator
+		 (lambda (value)
+		   (when (< 0 (length value))
+		     (limited-word-search 'person '(first-name last-name company-name) (list value))))
+
+		 :render (lambda (x)
+			   (<:as-html (if (> (length (last-name x)) 0)
+					 (strcat (last-name x) ", ")
+				      " ")
+				      (first-name x)" " (company-name x)))
+		 :as-value (lambda (x) x)
+		 :submit-on-click-p nil)))
+  (:type-name ajax-foreign-key))
+
+
+(defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args)
+  ;; If no search-slots than use the any slots of type string
+  (unless (search-slots slot)
+    (setf (search-slots slot) t)
+  (let ((l (live-search slot)))
+    (setf (lisp-on-lines::values-generator l) t))))
+	  
+
+(defmethod  present-slot :around ((slot ajax-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)
+	   
+           (<ucw:submit :action  (search-records slot instance) :value "find" :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"))
@@ -287,15 +367,9 @@ When T, only the default value for primary keys and the joins are updated."))
 	    (present (presentation slot)))
 	  (<:as-html "--"))))
 
-(defslot-presentation inline-slot-presentation (mewa-relation-slot-presentation)
-  ()
-  (:type-name inline))
 
-(defmethod present-slot ((slot inline-slot-presentation) instance)
-  (<:fieldset 
-   (<:legend (<:as-html (label slot)))
-  (<ucw:render-component :component (mewa:make-presentation (meta-model::explode-foreign-key instance (slot-name slot)) :type :editor))))
 
-(defmethod mewa::present-slot-as-row ((self mewa::mewa-object-presentation) (slot inline-slot-presentation))
-  (<:td :colspan 2
-	(present-slot slot (instance self))))
\ No newline at end of file
+
+
+
+