| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | ;;;; for when there is nothing left to display. |
| 4 | (defcomponent empty-page (window-component) |
| 5 | ()) |
| 6 | |
| 7 | (defmethod render-on ((res response) (self empty-page)) |
| 8 | "didnt find a thing") |
| 9 | |
| 10 | (defcomponent auto-complete () |
| 11 | ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)) |
| 12 | (output-id :accessor output-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)) |
| 13 | (client-value |
| 14 | :accessor client-value |
| 15 | :initform "" |
| 16 | :documentation "The string the user has, so far, insterted.") |
| 17 | (index |
| 18 | :accessor index |
| 19 | :initform nil |
| 20 | :documentation "The index (for use with NTH) in list-of-values of the item selected via Ajax") |
| 21 | (list-of-values |
| 22 | :accessor list-of-values |
| 23 | :initform '() |
| 24 | :documentation "The list generated by values-generator") |
| 25 | (values-generator :accessor values-generator :initarg :values-generator |
| 26 | :documentation "Function which, when passed the auto-complete component, returns a list of objects.") |
| 27 | (value |
| 28 | :accessor value |
| 29 | :initform nil |
| 30 | :documentation "The lisp value of the object selecting in the drop down") |
| 31 | (as-value :accessor as-value :initarg :as-value |
| 32 | :documentation "Function which, when passed a value, returns the string to put in the text box.") |
| 33 | (render-it :accessor render-it :initarg :render |
| 34 | :documentation "Function which, when passed the component and one of the values render it (the value).") |
| 35 | (input-size :accessor input-size :initarg :input-size :initform 20) |
| 36 | (submit-on-select-p |
| 37 | :accessor submit-on-select-p |
| 38 | :initarg :submit-on-select-p |
| 39 | :initform t) |
| 40 | (output-component-name :accessor output-component-name :initarg :output-comonent-name :initform 'auto-complete-output))) |
| 41 | |
| 42 | (defmethod js-on-complete ((l auto-complete)) |
| 43 | `(lambda (transport) |
| 44 | (setf (slot-value (document.get-element-by-id ,(output-id l)) |
| 45 | 'inner-h-t-m-l) |
| 46 | transport.response-text))) |
| 47 | |
| 48 | (defmacro make-action-url (component action) |
| 49 | " |
| 50 | There has got to be something like this buried in UCW somewhere, |
| 51 | but here's what i use." |
| 52 | `(ucw::print-uri-to-string |
| 53 | (compute-url ,component |
| 54 | :action-id (ucw::make-new-action (ucw::context.current-frame *context*) |
| 55 | (lambda () |
| 56 | (arnesi:with-call/cc |
| 57 | ,action)))))) |
| 58 | |
| 59 | (defun generate-ajax-request (js-url &optional js-options) |
| 60 | `(new |
| 61 | (*Ajax.*Request |
| 62 | ,js-url |
| 63 | ,js-options))) |
| 64 | |
| 65 | (defmacro with-ajax-request (js-url &rest js-options) |
| 66 | `(generate-ajax-request-for-url |
| 67 | ,js-url |
| 68 | ,@js-options)) |
| 69 | |
| 70 | (defmacro with-ajax-action ((component) &body action) |
| 71 | `(generate-ajax-request |
| 72 | (make-action-url ,component (progn ,@action)))) |
| 73 | |
| 74 | |
| 75 | (defun make-auto-complete-url (input-id) |
| 76 | "creates a url that calls the auto-complete entry-point for INPUT-ID." |
| 77 | (format nil "auto-complete.ucw?&auto-complete-id=~A&~A=~A" |
| 78 | input-id "session" |
| 79 | (ucw::session.id (ucw::context.session ucw::*context*)))) |
| 80 | |
| 81 | (defaction on-submit ((l auto-complete)) |
| 82 | ()) |
| 83 | |
| 84 | (defmethod js-on-select ((l auto-complete)) |
| 85 | "the javascript that is called when an item is selected" |
| 86 | (when (submit-on-select-p l) |
| 87 | `(progn |
| 88 | (set-action-parameter ,(register-action |
| 89 | (lambda () |
| 90 | (arnesi:with-call/cc |
| 91 | (on-submit l))))) |
| 92 | (submit-form)))) |
| 93 | |
| 94 | |
| 95 | (defmethod render ( (l auto-complete)) |
| 96 | ;; session-values are stored in an eql hash table. |
| 97 | (let ((input-key (intern (input-id l)))) |
| 98 | ;; We are storing the input components in the session, |
| 99 | ;; keyed on the string that we also use as the id for |
| 100 | ;; the input field. |
| 101 | |
| 102 | (unless (get-session-value input-key) |
| 103 | (setf (get-session-value input-key) l)) |
| 104 | |
| 105 | ;; A hidden field to hold the index number selected via javascript |
| 106 | (<ucw:text :accessor (client-value l) |
| 107 | :id (input-id l) :size (input-size l)) |
| 108 | (<:div :id (output-id l) :class "auto-complete" (<:as-html " "))) |
| 109 | (let* ((a (make-symbol (format nil "~A-autocompleter" (input-id l)))) |
| 110 | (f (make-symbol (format nil "~A.select-entry-function"a)))) |
| 111 | (<ucw:script |
| 112 | `(setf ,a |
| 113 | (new |
| 114 | (*Ajax.*Autocompleter |
| 115 | ,(input-id l) ,(output-id l) |
| 116 | ,(make-auto-complete-url (input-id l)) |
| 117 | (create |
| 118 | :param-name "value")))) |
| 119 | `(setf ,f (slot-value ,a 'select-entry)) |
| 120 | `(setf (slot-value ,a 'select-entry) |
| 121 | (lambda () |
| 122 | (,f) |
| 123 | ,(generate-ajax-request |
| 124 | (make-auto-complete-url (input-id l)) |
| 125 | `(create |
| 126 | :parameters (+ "&index=" (slot-value ,a 'index)) |
| 127 | :method "post" |
| 128 | :on-complete (lambda (res) |
| 129 | ,(js-on-select l))))))))) |
| 130 | |
| 131 | |
| 132 | ;;;; * auto-complete-ouput |
| 133 | |
| 134 | |
| 135 | (defcomponent auto-complete-output (window-component) |
| 136 | ((auto-complete :initarg :auto-complete :accessor auto-complete))) |
| 137 | |
| 138 | (defmethod render ((output auto-complete-output)) |
| 139 | (let ((auto-complete (auto-complete output))) |
| 140 | (setf (list-of-values auto-complete) |
| 141 | (funcall (values-generator auto-complete) (client-value auto-complete))) |
| 142 | (<:ul |
| 143 | :class "auto-complete-list" |
| 144 | (arnesi:dolist* (value (list-of-values auto-complete)) |
| 145 | (<:li |
| 146 | :class "auto-complete-list-item" |
| 147 | (funcall (render-it auto-complete) value)))) |
| 148 | (answer-component output t))) |
| 149 | |
| 150 | (defcomponent fkey-auto-complete (auto-complete) |
| 151 | ()) |
| 152 | |
| 153 | (defmethod js-on-select ((self fkey-auto-complete)) |
| 154 | (with-ajax-action (self) |
| 155 | (mewa::sync-foreign-instance (ucw::parent self) (value self)))) |
| 156 | |
| 157 | (defslot-presentation ajax-foreign-key-slot-presentation (mewa::foreign-key-slot-presentation) |
| 158 | ((original-value :accessor original-value :initform nil) |
| 159 | (search-slots :accessor search-slots :initarg :search-slots :initform nil) |
| 160 | (live-search |
| 161 | :accessor live-search |
| 162 | :component fkey-auto-complete)) |
| 163 | (:type-name ajax-foreign-key)) |
| 164 | |
| 165 | |
| 166 | (defmethod shared-initialize :after ((slot ajax-foreign-key-slot-presentation) slots &rest args) |
| 167 | (let* ((l (live-search slot)) |
| 168 | (slot-name (slot-name slot)) |
| 169 | (instance (instance (ucw::parent slot))) |
| 170 | (foreign-instance (explode-foreign-key instance slot-name)) |
| 171 | (class-name (class-name |
| 172 | (class-of foreign-instance)))) |
| 173 | ;; If no search-slots than use the any slots of type string |
| 174 | (unless (search-slots slot) |
| 175 | (setf (search-slots slot) (find-slots-of-type foreign-instance))) |
| 176 | |
| 177 | (setf (lisp-on-lines::values-generator l) |
| 178 | (lambda (input) |
| 179 | (word-search class-name |
| 180 | (search-slots slot) input))) |
| 181 | |
| 182 | (setf (lisp-on-lines::render-it l) |
| 183 | (lambda (val) |
| 184 | (<ucw:render-component |
| 185 | :component (make-presentation val :type :one-line)))))) |
| 186 | |
| 187 | (defaction revert-foreign-slot ((slot ajax-foreign-key-slot-presentation)) |
| 188 | (setf (lol::value (live-search slot)) nil) |
| 189 | (when (original-value slot) |
| 190 | (mewa::sync-foreign-instance slot (original-value slot)))) |
| 191 | |
| 192 | (defmethod present-slot :around ((slot ajax-foreign-key-slot-presentation) instance) |
| 193 | |
| 194 | (let ((foreign-instance |
| 195 | (if (lol::value (live-search slot)) |
| 196 | (lol::value (live-search slot)) |
| 197 | (setf (original-value slot) |
| 198 | (when (presentation-slot-value slot instance) |
| 199 | (meta-model:explode-foreign-key instance (slot-name slot))))))) |
| 200 | |
| 201 | (flet ((render-s () (when foreign-instance (call-next-method)))) |
| 202 | (if (slot-boundp slot 'ucw::place) |
| 203 | (cond |
| 204 | ((editablep slot) |
| 205 | (when foreign-instance |
| 206 | (setf (client-value (live-search slot)) |
| 207 | (with-output-to-string (s) |
| 208 | (yaclml:with-yaclml-stream s |
| 209 | (present (make-presentation foreign-instance |
| 210 | :type :one-line)))))) |
| 211 | |
| 212 | (<ucw:render-component :component (live-search slot)) |
| 213 | #+ (or) (<ucw:submit :action (revert-foreign-slot slot) |
| 214 | :value "Undo") |
| 215 | (<ucw:submit :action (mewa::search-records slot instance) :value "find" :style "display:inline")) |
| 216 | ((mewa::linkedp slot) |
| 217 | (<ucw:a :action (mewa::view-instance slot foreign-instance) |
| 218 | (render-s))) |
| 219 | (t |
| 220 | (render-s))) |
| 221 | ;; presentation is used only for rendering |
| 222 | (render-s))))) |