| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | (defaction read-instance ((self component) instance) |
| 4 | "View an existing instance" |
| 5 | (call 'crud-viewer :instance instance)) |
| 6 | |
| 7 | (defaction update-instance ((self component) instance) |
| 8 | "Edit an instance, possibly a newly created one" |
| 9 | (call 'crud-editor :instance instance)) |
| 10 | |
| 11 | (defaction create-instance ((self component) class &rest initargs) |
| 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 | |
| 28 | (defaction 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) |
| 35 | (answer t) |
| 36 | (progn |
| 37 | (call 'info-message :message delete-failed) |
| 38 | (answer t)))))) |
| 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" |
| 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)))))))))) |
| 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 |
| 141 | (string (attribute.name attribute)))) |
| 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 | |
| 211 | (defaction ensure-instance ((self crud-editor)) |
| 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 | |
| 291 | (defaction call-crud-summary ((self component) class) |
| 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))) |