1 (in-package :lisp-on-lines
)
3 ;;;; A few layers related to attributes
4 (deflayer omit-nil-attributes
)
6 (defdisplay :in-layer omit-nil-attributes
7 :around
((attribute standard-attribute
) object
)
8 (when (attribute-value object attribute
)
11 (deflayer show-attribute-labels
)
14 :in-layer show-attribute-labels
15 :around
((attribute standard-attribute
) object
)
18 (<:as-html
(or (label attribute
) (attribute.name attribute
)) " "))
20 :class
"lol-attribute"
23 (deflayer use-pretty-labels
)
25 (define-layered-method label
26 :in-layer use-pretty-labels
27 :around
(standard-attribute)
28 (let ((label (call-next-method)))
31 (substitute #\Space
#\- label
)))))
33 (deflayer inspect-attributes
)
35 (defdisplay :in-layer inspect-attributes
36 :around
((attribute standard-attribute
) object
)
38 (<ucw
:a
:action
(ucw::call-inspector self attribute
)
41 (attribute.name attribute
) ":"
42 (description.type attribute
) ":"
46 ;;;; Functional attributes
47 (defattribute display-attribute
()
49 :accessor display-arguments
54 (:documentation
"Apply the display function to this object"))
56 (defdisplay ((attribute display-attribute
) object
)
57 (apply #'display self
(attribute-value object attribute
)
58 (display-arguments attribute
)))
60 (defattribute function-attribute
()
61 ((function :accessor function-of
68 (defdisplay ((function function-attribute
) object
)
69 (funcall (function-of function
)
70 (attribute-value object function
)))
73 ;;;; Attribute Grouping
74 (defattribute attribute-group
()
80 (defdisplay ((group attribute-group
) object
)
81 (apply #'display self object
82 :attributes
(attributes group
)
87 (defattribute base-attribute
()
92 (defdisplay ((base base-attribute
) object
)
93 (<:as-html
(attribute-value object base
)))
95 (defattribute base-attribute
(ucw::string-field
)
101 :default-value-predicate
#'null
))
103 (define-layered-function display-value
(attribute value
)
104 (:method
(attribute value
)
105 (if (funcall (default-value-predicate attribute
) value
)
106 (default-value attribute
)
110 :in-layer editor
((field base-attribute
) object
)
111 (LET ((value (attribute-value (object field
) field
)))
115 :VALUE
(escape-as-html (strcat (display-value field value
)))
121 (ucw::INPUT-SIZE FIELD
))))
124 :in-layer editor
:around
((string base-attribute
) object
)
125 (dletf (((callback string
)
126 (or (callback string
)
127 (ucw::make-new-callback
129 (setf (attribute-value object string
) val
)))))
130 ((object string
) object
))
135 (defattribute string-attribute
(base-attribute)
144 (defdisplay :in-layer omit-nil-attributes
145 :around
((attribute string-attribute
) object
)
146 (when (< 0 (length (attribute-value object attribute
)))
150 (defdisplay :in-layer viewer
151 ((string string-attribute
) object
)
152 (if (escape-html-p string
)
153 (<:as-html
(attribute-value object string
))
154 (<:as-is
(attribute-value object string
))))
158 (defattribute string-attribute
(base-attribute)
165 (defattribute string-search-attribute
(string-attribute)
168 ;; the func that find search results
170 :search-action
#'(lambda ()
173 ;; when chosing from a list of results, this function selects one.
174 :select-function
(constantly t
))
175 (:type-name string-search
))
178 :in-layer editor
:after
((search string-search-attribute
) object
)
185 (IT.BESE.UCW
::SET-ACTION-PARAMETER
186 ,(IT.BESE.UCW
::MAKE-NEW-ACTION
187 (IT.BESE.UCW
::CONTEXT.CURRENT-FRAME
*CONTEXT
*)
188 (search-action search
)))
193 (defattribute text-attribute
(string-attribute)
197 (defdisplay :in-layer editor
((string text-attribute
) object
)
200 :name
(callback string
)
201 (or (attribute-value object string
) "")))
207 (defattribute wall-time-attribute
(string-attribute)
209 (:type-name clsql-sys
:wall-time
))
211 (define-layered-method attribute-value
(object (attribute wall-time-attribute
))
212 (let ((date (call-next-method)))
213 (when date
(multiple-value-bind (y m d
) (clsql:time-ymd date
)
214 (format nil
"~a/~a/~a" m d y
)))))
217 ((time wall-time-attribute
) object
)
218 (<:as-html
(attribute-value object time
)))
222 (defattribute image
()
225 :css-class
"lol-image"
228 (defdisplay ((buttons (eql 'image-editor-buttons
)) object
)
229 (<ucw
:a
:action
(ok component object
)
230 (<:as-html
"select this image")))
232 (defdisplay ((image image
) object
)
234 :class
(or (css-class image
) "lol-image")
236 (or (prefix image
) "images/")
238 (attribute-value object image
)))))
241 :in-layer editor
((image image
) object
)
244 :class
"lol-image-thumbnails"
245 (<:as-html
"imagie")))