1 (in-package :lisp-on-lines
)
3 (defmethod/cc read-instance
((self component
) instance
)
4 "View an existing instance"
5 (call 'crud-viewer
:instance instance
))
7 (defmethod/cc update-instance
((self component
) instance
)
8 "Edit an instance, possibly a newly created one"
9 (call 'crud-editor
:instance instance
))
11 (defmethod/cc create-instance
((self component
) class
&rest initargs
)
12 "Create a new instance and edit it."
13 (update-instance self
(apply #'make-instance class initargs
)))
15 (defun %delete-instance-and-return-nil
(instance)
16 "returns nil on success"
17 (handler-case (clsql:delete-instance-records instance
)
19 (return-from %delete-instance-and-return-nil x
)))
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
)))))
28 (defmethod/cc delete-instance
((self component
) instance
)
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
)
37 (call 'info-message
:message delete-failed
)
41 (defmethod breadcrumb-name (component)
42 (string-downcase (string (class-name (class-of component
)))))
44 (defun render-breadcrumb (self)
45 (<:p
:class
"breadcrumb"
48 (labels ((find-call-stack-for-crumbs (component list-of-parents
)
49 (cond ((and (not (null component
))
50 (> trail-length 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
)))
60 :on
(find-call-stack-for-crumbs self nil
)
65 :action
(answer-component (second c
) nil
)
66 (<:as-html
(breadcrumb-name (first c
))))
67 (<:as-html
(breadcrumb-name (first c
))))))))))
70 ((instance :accessor instance
:initarg
:instance
:initform nil
))
71 (:documentation
"The base class for all standard crud components"))
73 (defmethod render ((self crud
))
74 "Just to show off more of LOL, we'll use its display mechanism for UCW components.
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,
80 DISPLAY also takes keyword arguments that modify the DESCRIPTION at run time.
82 By default, the display method iterates through the ATTRIBUTES
83 of the DESCRIPTION of the OBJECT. This will hopfully become clear.
85 In this case, we are displaying the component from itself.
90 (defun class-name-of (instance)
91 (class-name (class-of instance
)))
93 ;;;; We'll use this in a string attribute to display the title.
94 (defgeneric find-title
(crud)
97 (format nil
"An instance of ~A" (class-name-of (instance crud
)))
98 "Welcome to Crud 1.0")))
100 ;;;; ** We define an attribute for the menu
101 ;;;; DEFATTRIBUTE is like defclass for attributes.
102 (defattribute crud-menu
()
107 "A Custom menu attribute"))
109 (defdisplay :wrapping
((menu crud-menu
) object
(component component
))
110 "Set up the menu with an optional back button
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.
117 DEFDISPLAY is really just a few macros around DISPLAY-USING-DESCRIPTION,
118 which does the real work. Macroexpand if you're interested."
120 (when (show-back-p menu
)
121 (<:li
(<ucw
:a
:action
(answer nil
)
122 (<:as-html
"Go Back"))))
125 (defdisplay ((menu crud-menu
) object
)
126 "Do nothing beyond the defalt for our standard menu
128 note the omitted COMPONENT argument. sugar is all."
131 ;;;; create a new layer for some customisations.
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."
140 :class
(format nil
"crud-~A" (string-downcase
141 (string (attribute-name attribute
))))
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'.
148 (defdescription crud
()
149 (;; use a generic function for the title attribute
151 ;; attributes have types.
152 ;; inspect LOL::FIND-ATTRIBUTE-CLASS-FOR-TYPE for a list.
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
)
160 ;; our breadcrumb function renders itself,
161 ;; and does not return a value.
163 ;; the FUNCTION type calls a function
164 ;; again, passing the object.
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.
171 ;; So we don't need a getter in INSTANCE.
173 ;; the DISPLAY type calls DISPLAY
174 ;; passing the component and the object
175 ;; along with any arguments specified using the
178 :display
'(:layers
(+ show-attribute-labels
)))
179 ;; this is our menu, a custom attribute
182 (;; now we create a LINE in the default layer.
183 ;; LINES describe how an object is displayed
184 ;; when that layer is active.
187 :attributes
'(breadcrumb title menu instance
)
188 :layers
'(- show-attribute-labels
+ crud
)))
191 ;;;; That's the basic outline of our app, now we fill in the blanks.
194 (defcomponent crud-viewer
(crud)
196 (:documentation
"A component for viewing objects"))
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."))))
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
)
211 (defmethod/cc ensure-instance
((self crud-editor
))
212 "This one does a little magic, see SYNC-INSTANCE"
213 (meta-model::sync-instance
(instance self
)))
215 (defmethod find-title ((crud crud-editor
))
216 (<:as-html
"Editing a "
217 (class-name (class-of (instance crud
)))
219 (unless (meta-model:persistentp
(instance crud
))
220 (<:as-html
"(new)")))
222 (defattribute crud-editor-attribute
(display-attribute)
224 (:type-name crud-editor
))
226 (defdisplay :around
((ed crud-editor-attribute
) object
)
227 (with-active-layers (editor show-attribute-labels wrap-form
)
231 (defdescription crud-editor
()
232 ((instance :type
'crud-editor
))
239 ((:value
,(if (meta-model:persistentp
(instance self
))
242 :action
,(action (self object
)
243 (ensure-instance self
)
244 (answer (instance self
))))
248 ,(action (self object
)
249 (setf (instance self
) nil
)
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)))
258 (defmethod find-title ((crud crud-summary
))
259 (format nil
"Viewing Summary of ~A" (db-class crud
)))
261 (defun find-some (class limit offset
)
262 (clsql:select class
:limit limit
:offset offset
:flatp t
))
264 (defmethod find-summary ((crud crud-summary
))
265 (find-some (db-class crud
)
269 (defdescription crud-summary
()
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
278 :getter
,#'find-summary
280 (:layers
(+ one-line
)
282 (:layers
(+ lol
::wrap-link
+ lol
::show-attribute-labels
)
283 :link-action
,(action (self obj
)
284 (call 'crud-viewer
:instance obj
))))))))
286 (defdisplay ((menu crud-menu
) (object crud-summary
))
288 :action
(create-instance object
(db-class object
))
289 (<:as-html
"(Create New " (db-class object
) ")"))))
291 (defmethod/cc call-crud-summary
((self component
) class
)
292 (call 'crud-summary
:class class
))
295 (defcomponent crud-database
(crud)
298 (defdescription crud-database
()
301 :getter
(constantly "View Object Summary: "))
304 :getter
#'(lambda (obj)
305 (declare (ignore obj
))
306 (meta-model::list-base-classes
:clsql
))
307 :display
`(:layers
(+ one-line
)
309 (:layers
(+ lol
::wrap-link
)
310 :link-action
,(action (self class
)
311 (call-crud-summary self class
))))))
314 :attributes
'(title menu instructions instance
)))