301f28fd |
1 | (in-package :lisp-on-lines) |
2 | |
88670bec |
3 | (defmethod/cc read-instance ((self component) instance) |
301f28fd |
4 | "View an existing instance" |
5 | (call 'crud-viewer :instance instance)) |
6 | |
88670bec |
7 | (defmethod/cc update-instance ((self component) instance) |
301f28fd |
8 | "Edit an instance, possibly a newly created one" |
9 | (call 'crud-editor :instance instance)) |
10 | |
88670bec |
11 | (defmethod/cc create-instance ((self component) class &rest initargs) |
301f28fd |
12 | "Create a new instance and edit it." |
13 | (update-instance self (apply #'make-instance class initargs))) |
14 | |
15 | (defun %delete-instance-and-return-nil (instance) |
16 | "returns nil on success" |
17 | (handler-case (clsql:delete-instance-records instance) |
18 | (error (x) |
19 | (return-from %delete-instance-and-return-nil x))) |
20 | nil) |
21 | |
22 | (defun display-as-string (instance) |
23 | (with-output-to-string (s) |
24 | (yaclml:with-yaclml-stream s |
25 | (display (make-instance 'component) instance |
26 | :layers '(+ as-string))))) |
27 | |
88670bec |
28 | (defmethod/cc delete-instance ((self component) instance) |
907c9983 |
29 | (when (call 'option-dialog |
30 | :message (format nil "Really Delete ~A" (display-as-string instance)) |
31 | :options '((t "Yes, really delete it,") |
32 | (nil "No, i'll hold on to this one."))) |
33 | (let ((delete-failed (%delete-instance-and-return-nil instance))) |
34 | (if (not delete-failed) |
35 | (answer t) |
36 | (progn |
37 | (call 'info-message :message delete-failed) |
38 | (answer t)))))) |
301f28fd |
39 | |
40 | |
41 | (defmethod breadcrumb-name (component) |
42 | (string-downcase (string (class-name (class-of component))))) |
43 | |
44 | (defun render-breadcrumb (self) |
45 | (<:p :class "breadcrumb" |
907c9983 |
46 | (let ((count 0) |
47 | (trail-length 3)) |
48 | (labels ((find-call-stack-for-crumbs (component list-of-parents) |
49 | (cond ((and (not (null component)) |
50 | (> trail-length count)) |
51 | (incf count) |
52 | (find-call-stack-for-crumbs |
53 | (when (slot-boundp component 'ucw::calling-component) |
54 | (slot-value component 'ucw::calling-component)) |
55 | (cons component list-of-parents))) |
56 | (t |
57 | list-of-parents)))) |
58 | (loop |
59 | :for c |
60 | :on (find-call-stack-for-crumbs self nil) |
61 | :do (let ((c c)) |
62 | (<:as-html " / ") |
63 | (if (cdr c) |
64 | (<ucw:a |
65 | :action (answer-component (second c) nil) |
66 | (<:as-html (breadcrumb-name (first c)))) |
67 | (<:as-html (breadcrumb-name (first c)))))))))) |
301f28fd |
68 | |
69 | (defcomponent crud () |
70 | ((instance :accessor instance :initarg :instance :initform nil)) |
71 | (:documentation "The base class for all standard crud components")) |
72 | |
73 | (defmethod render ((self crud)) |
74 | "Just to show off more of LOL, we'll use its display mechanism for UCW components. |
75 | |
76 | DISPLAY takes two required arguments, |
77 | COMPONENT : The component to display FROM (not neccesarily 'in') |
78 | OBJECT : The 'thing' we want to display... in this case it's the component, |
79 | |
80 | DISPLAY also takes keyword arguments that modify the DESCRIPTION at run time. |
81 | |
82 | By default, the display method iterates through the ATTRIBUTES |
83 | of the DESCRIPTION of the OBJECT. This will hopfully become clear. |
84 | |
85 | In this case, we are displaying the component from itself. |
86 | " |
87 | |
88 | (display self self)) |
89 | |
90 | (defun class-name-of (instance) |
91 | (class-name (class-of instance))) |
92 | |
93 | ;;;; We'll use this in a string attribute to display the title. |
94 | (defgeneric find-title (crud) |
95 | (:method (crud) |
96 | (if (instance crud) |
97 | (format nil "An instance of ~A" (class-name-of (instance crud))) |
98 | "Welcome to Crud 1.0"))) |
99 | |
100 | ;;;; ** We define an attribute for the menu |
101 | ;;;; DEFATTRIBUTE is like defclass for attributes. |
102 | (defattribute crud-menu () |
103 | () |
104 | (:default-properties |
105 | :show-back-p t) |
106 | (:documentation |
107 | "A Custom menu attribute")) |
108 | |
109 | (defdisplay :wrapping ((menu crud-menu) object (component component)) |
110 | "Set up the menu with an optional back button |
111 | |
112 | In a DEFDISPLAY form, the variable SELF is bound to the component we are displaying. |
113 | This allows it to work with UCW's CALL and ANSWER, and saves some typing as well. |
114 | One can also provide a name (or a specializer) for the component as the third parameter |
115 | in the defdisplay argument list, (as i did above) but this is optional. |
116 | |
117 | DEFDISPLAY is really just a few macros around DISPLAY-USING-DESCRIPTION, |
118 | which does the real work. Macroexpand if you're interested." |
119 | (<:ul |
120 | (when (show-back-p menu) |
121 | (<:li (<ucw:a :action (answer nil) |
122 | (<:as-html "Go Back")))) |
123 | (call-next-method))) |
124 | |
125 | (defdisplay ((menu crud-menu) object) |
126 | "Do nothing beyond the defalt for our standard menu |
127 | |
128 | note the omitted COMPONENT argument. sugar is all." |
129 | t) |
130 | |
131 | ;;;; create a new layer for some customisations. |
132 | (deflayer crud) |
133 | |
134 | ;;;; we don't really _have_ to do this in our own layer, |
135 | ;;;; but it does give us the ability to turn the behaviour off. |
136 | (defdisplay :in-layer crud |
137 | :wrap-around ((attribute standard-attribute) (object crud)) |
138 | "Around every attribute of a CRUD instance, i'd like to wrap a div." |
139 | (<:div |
140 | :class (format nil "crud-~A" (string-downcase |
1cc831d4 |
141 | (string (attribute-name attribute)))) |
301f28fd |
142 | (call-next-method))) |
143 | |
144 | ;;;; A description contains attributes. |
145 | ;;;; ATTRIBUTES are the various pieces that come together to make a display |
146 | ;;;; In this case, we define parts of the 'page'. |
147 | |
148 | (defdescription crud () |
149 | (;; use a generic function for the title attribute |
150 | (title |
151 | ;; attributes have types. |
152 | ;; inspect LOL::FIND-ATTRIBUTE-CLASS-FOR-TYPE for a list. |
153 | :type 'string |
154 | ;; almost all attributes have a getter and/or setter function |
155 | ;; which is passed the object being displayed. |
156 | ;; You can also use :SLOT-NAME |
157 | ;; see ATTRIBUTE-VALUE for details. |
158 | :getter #'find-title) |
159 | |
160 | ;; our breadcrumb function renders itself, |
161 | ;; and does not return a value. |
162 | (breadcrumb |
163 | ;; the FUNCTION type calls a function |
164 | ;; again, passing the object. |
165 | :type 'function |
166 | :function #'render-breadcrumb |
167 | ;; We need to specify IDENTITY here, |
168 | ;; as the default :GETTER calls |
169 | ;; SLOT-VALUE on the name of the attribute. |
170 | :getter #'identity) |
171 | ;; So we don't need a getter in INSTANCE. |
172 | (instance |
173 | ;; the DISPLAY type calls DISPLAY |
174 | ;; passing the component and the object |
175 | ;; along with any arguments specified using the |
176 | ;; :DISPLAY property |
177 | :type 'display |
178 | :display '(:layers (+ show-attribute-labels))) |
179 | ;; this is our menu, a custom attribute |
180 | (menu |
181 | :type 'crud-menu)) |
182 | (;; now we create a LINE in the default layer. |
183 | ;; LINES describe how an object is displayed |
184 | ;; when that layer is active. |
185 | :in-layer |
186 | t |
187 | :attributes '(breadcrumb title menu instance) |
188 | :layers '(- show-attribute-labels + crud))) |
189 | |
190 | |
191 | ;;;; That's the basic outline of our app, now we fill in the blanks. |
192 | |
193 | ;;;; ** Viewer |
194 | (defcomponent crud-viewer (crud) |
195 | () |
196 | (:documentation "A component for viewing objects")) |
197 | |
198 | (defdisplay ((menu crud-menu) (crud crud-viewer)) |
199 | "Allow the user to edit and delete the object" |
200 | (<:li (<ucw:a :action (delete-instance crud (instance crud)) |
201 | (<:as-html "DELETE this object."))) |
202 | (<:li (<ucw:a :action (update-instance crud (instance crud)) |
203 | (<:as-html "EDIT this object.")))) |
204 | |
205 | ;;;; ** Editor |
206 | ;;;; (use the same component for creating and editing, |
207 | ;;;; with a little magic to make it all work. |
208 | (defcomponent crud-editor (crud validation-mixin) |
209 | ()) |
210 | |
88670bec |
211 | (defmethod/cc ensure-instance ((self crud-editor)) |
301f28fd |
212 | "This one does a little magic, see SYNC-INSTANCE" |
213 | (meta-model::sync-instance (instance self))) |
214 | |
215 | (defmethod find-title ((crud crud-editor)) |
216 | (<:as-html "Editing a " |
217 | (class-name (class-of (instance crud))) |
218 | " ") |
219 | (unless (meta-model:persistentp (instance crud)) |
220 | (<:as-html "(new)"))) |
221 | |
222 | (defattribute crud-editor-attribute (display-attribute) |
223 | () |
224 | (:type-name crud-editor)) |
225 | |
226 | (defdisplay :around ((ed crud-editor-attribute) object) |
227 | (with-active-layers (editor show-attribute-labels wrap-form) |
228 | (call-next-method))) |
229 | |
230 | |
231 | (defdescription crud-editor () |
232 | ((instance :type 'crud-editor)) |
233 | (:in-layer |
234 | t |
235 | :default-attributes |
236 | `((instance |
237 | :display |
238 | (:form-buttons |
239 | ((:value ,(if (meta-model:persistentp (instance self)) |
240 | "Save" |
241 | "Create") |
242 | :action ,(action (self object) |
243 | (ensure-instance self) |
244 | (answer (instance self)))) |
245 | (:value |
246 | "Cancel" |
247 | :action |
248 | ,(action (self object) |
249 | (setf (instance self) nil) |
250 | (answer nil))))))))) |
251 | |
252 | ;;;; ** Summary |
253 | (defcomponent crud-summary (crud) |
254 | ((class :accessor db-class :initarg :class) |
255 | (limit :accessor row-limit :initform 25) |
256 | (offset :accessor row-offset :initform 0))) |
257 | |
258 | (defmethod find-title ((crud crud-summary)) |
259 | (format nil "Viewing Summary of ~A" (db-class crud))) |
260 | |
261 | (defun find-some (class limit offset) |
262 | (clsql:select class :limit limit :offset offset :flatp t)) |
263 | |
264 | (defmethod find-summary ((crud crud-summary)) |
265 | (find-some (db-class crud) |
266 | (row-limit crud) |
267 | (row-offset crud))) |
268 | |
269 | (defdescription crud-summary () |
270 | () |
271 | (:in-layer t |
272 | ;;; here we show :default-attributes |
273 | ;;; the attributes themselves can vary by layer |
274 | ;;; the same syntax is supported in an :ATTRIBUTES form |
275 | ;;; but that also specifies which attributes to display |
276 | :default-attributes |
277 | `((instance |
278 | :getter ,#'find-summary |
279 | :display |
280 | (:layers (+ one-line) |
281 | :list-item |
282 | (:layers (+ lol::wrap-link + lol::show-attribute-labels) |
283 | :link-action ,(action (self obj) |
284 | (call 'crud-viewer :instance obj)))))))) |
285 | |
286 | (defdisplay ((menu crud-menu) (object crud-summary)) |
287 | (<:li (<ucw:a |
288 | :action (create-instance object (db-class object)) |
289 | (<:as-html "(Create New " (db-class object) ")")))) |
290 | |
88670bec |
291 | (defmethod/cc call-crud-summary ((self component) class) |
301f28fd |
292 | (call 'crud-summary :class class)) |
293 | |
294 | |
295 | (defcomponent crud-database (crud) |
296 | ()) |
297 | |
298 | (defdescription crud-database () |
299 | ((instructions |
300 | :type 'string |
301 | :getter (constantly "View Object Summary: ")) |
302 | (instance |
303 | :type 'display |
304 | :getter #'(lambda (obj) |
305 | (declare (ignore obj)) |
306 | (meta-model::list-base-classes :clsql)) |
307 | :display `(:layers (+ one-line) |
308 | :list-item |
309 | (:layers (+ lol::wrap-link ) |
310 | :link-action ,(action (self class) |
311 | (call-crud-summary self class)))))) |
312 | (:in-layer |
313 | t |
314 | :attributes '(title menu instructions instance))) |