Added AJAX support
[clinton/lisp-on-lines.git] / src / mewa / slot-presentations.lisp
index 4a746d3..1454c53 100644 (file)
                     (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))
@@ -93,7 +113,7 @@ When T, only the default value for primary keys and the joins are updated."))
       (meta-model:explode-foreign-key instance (slot-name slot))
     (let ((new-instance
             (call-component 
-             (parent slot) 
+             (parent slot)
              (make-instance (or (cadr (mewa:find-attribute finstance :presentation-search))
                                 'mewa::mewa-presentation-search)
                             :search-presentation
@@ -181,12 +201,73 @@ 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"))
   (: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)
@@ -285,3 +366,10 @@ When T, only the default value for primary keys and the joins are updated."))
            (setf (instance (presentation slot)) (presentation-slot-value slot instance))
            (present (presentation slot)))
          (<:as-html "--"))))
+
+
+
+
+
+
+