removed the poorly named and poorly located INSTANCE-IS-STORED-P
[clinton/lisp-on-lines.git] / src / slot-presentations.lisp
1 (in-package :lisp-on-lines)
2
3 (defun multiple-value-funcall->list (function &rest args)
4 "The function to be called by m-v-bf"
5 (multiple-value-call #'list (apply function args)))
6
7 (defmacro multiple-value-bindf (vars form &body body)
8 "Like M-V-B, only it works in actions. form must be a function call"
9 `(destructuring-bind ,vars
10 (multiple-value-funcall->list #',(car form) ,@(cdr form))
11 ,@body))
12
13
14 ;;;; ** Textarea Slot Presentation
15
16 (defslot-presentation text-slot-presentation ()
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))
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)
28 (<:as-html (presentation-slot-value slot instance))
29 (<:as-is (presentation-slot-value slot instance)))))
30
31
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.
42 When T, only the default value for primary keys and the joins are updated.")
43 (show-label-p :accessor show-label-p :initarg :show-label-p :initform t))
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)
68
69 (defslot-presentation clsql-wall-time-slot-presentation (mewa-relation-slot-presentation)
70 ((input-id :accessor input-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+))
71 (trigger-id :accessor trigger-id :initform (arnesi:random-string 10 arnesi:+ascii-alphabet+)))
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)
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)
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 ))))
87
88 (defmethod label :around ((slot clsql-wall-time-slot-presentation))
89 (concatenate 'string (call-next-method) " (m/d/y)"))
90
91 (defmethod present-slot ((slot clsql-wall-time-slot-presentation) instance)
92 (let ((date (presentation-slot-value slot instance)))
93 (if (and date (not (editablep slot)))
94 (<:as-html date))
95 (when (editablep slot)
96 (<ucw:input :accessor (presentation-slot-value slot instance) :id (input-id slot) :style "display:inline")
97 (<:button :id (trigger-id slot) (<:as-html "[...]"))
98 (<:script :type "text/javascript"
99 (<:as-is (format nil "
100
101 Calendar.setup({
102 inputField : \"~a\",
103 button : \"~a\",
104 ifFormat : \"%m/%d/%Y\" });" (input-id slot) (trigger-id slot)))))))
105
106 (defslot-presentation mewa-relation-slot-presentation (mewa-slot-presentation slot-presentation)
107 ((foreign-instance :accessor foreign-instance)
108 (linkedp :accessor linkedp :initarg :linkedp :initform t)
109 (creator :accessor creator :initarg :creator :initform :editor)
110 (new-instance :accessor new-instance :initform nil))
111 (:type-name relation))
112
113 (defaction search-records ((slot mewa-relation-slot-presentation) instance)
114 (multiple-value-bindf (finstance foreign-slot-name)
115 (meta-model:explode-foreign-key instance (slot-name slot))
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
139 (defaction create-record-on-foreign-key ((slot mewa-relation-slot-presentation) instance)
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
144 (ucw::parent slot)
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)
158 (setf (slot-value instance (slot-name slot)) (slot-value new-instance foreign-slot-name))
159 (meta-model:sync-instance instance :fill-gaps-only-p (fill-gaps-only-p self)))))
160
161
162 (defmethod present-relation ((slot mewa-relation-slot-presentation) instance)
163 ;;;;(<:as-html (slot-name slot) "=> " (foreign-instance slot) " from " instance )
164 (let* ((i (foreign-instance slot))
165 (pres (mewa::make-presentation
166 i
167 :type :one-line
168 :initargs (list
169 :global-properties
170 (list :editablep nil :linkedp nil)))))
171 (when (and (ucw::parent slot) (slot-boundp slot 'ucw::place))
172 (setf (component.place pres) (component.place (ucw::parent slot))))
173 (when i (<ucw:render-component :component pres))))
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)
184 (call-component (ucw::parent self) (apply #'mewa:make-presentation instance initargs))
185 ;; the viewed instance could have been changed/deleted, so we sync this instance
186 (meta-model:sync-instance (instance (ucw::parent self))))
187
188
189 (defmethod present-slot :around ((slot foreign-key-slot-presentation) instance)
190 (setf (foreign-instance slot)
191 (when (presentation-slot-value slot instance)
192 (meta-model:explode-foreign-key instance (slot-name slot))))
193 (flet ((render () (when (foreign-instance slot)(call-next-method))))
194 (if (slot-boundp slot 'ucw::place)
195 (cond
196 ((editablep slot)
197 (render)
198 (<ucw:submit :action (search-records slot instance) :value "Search" :style "display:inline")
199 (<ucw:submit :action (create-record-on-foreign-key slot instance) :value "Add New" :style "display:inline"))
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))))
207
208
209 (defmethod find-foreign-instances ((slot foreign-key-slot-presentation))
210 (clsql:select (class-name (class-of (meta-model:explode-foreign-key (instance slot) (slot-name slot))))))
211
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)
218
219 ;;;; HAS MANY
220 (defslot-presentation has-many-slot-presentation (mewa-relation-slot-presentation)
221 ((add-new-label :accessor add-new-label :initarg :add-new-label :initform "Add New"))
222 (:type-name has-many))
223
224 (defaction add-to-has-many ((slot has-many-slot-presentation) instance)
225 ;; if the instance is not stored we must make sure to mark it stored now!
226 (unless (meta-model::persistentp instance)
227 (setf (mewa::modifiedp (ucw::parent self)) t))
228 ;; sync up the instance
229 ;;(mewa:ensure-instance-sync (parent slot))
230 (meta-model:sync-instance (instance (ucw::parent slot)))
231
232 (multiple-value-bindf (class home foreign)
233 (meta-model:explode-has-many instance (slot-name slot))
234 (let ((new (make-instance class)))
235 (setf (slot-value new foreign) (slot-value instance home))
236 (meta-model:sync-instance new :fill-gaps-only-p (fill-gaps-only-p self))
237 (call-component (ucw::parent slot) (mewa:make-presentation new :type (creator slot)))
238 (meta-model:sync-instance instance))))
239
240 (defmethod present-slot ((slot has-many-slot-presentation) instance)
241 (when (slot-boundp slot 'ucw::place)
242 (<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label slot)))
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
274
275 (defmethod get-foreign-instances ((slot has-many-slot-presentation) instance)
276 (slot-value instance (slot-name slot)))
277
278 (defmethod presentation-slot-value ((slot has-many-slot-presentation) instance)
279 (get-foreign-instances slot instance))
280
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))
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)
302 (if (slot-boundp slot 'ucw::place)
303 (progn
304 (<ucw:a :action (list-prev slot) (<:as-html "<<"))
305 (let ((self (ucw::parent slot)))
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)))
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)))
341 (<:as-html "--"))))
342
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"))
349
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
386
387
388
389
390