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
)
86 (defattribute select-attribute
(display-attribute)
89 :test
'meta-model
::generic-equal
90 :options-getter
(constantly nil
))
93 (defdisplay ((attribute select-attribute
) object
)
95 :accessor
(attribute-value object attribute
)
97 :test
(test attribute
)
98 (dolist* (obj (funcall (options-getter attribute
) object
))
101 (apply #'display
* obj
(display-arguments attribute
))))))
105 (defattribute base-attribute
()
110 (defdisplay ((base base-attribute
) object
)
111 (<:as-html
(attribute-value object base
)))
113 (defattribute base-attribute
()
119 :default-value-predicate
#'null
120 :dom-id
(js:gen-js-name-string
:prefix
"_ucw_")
123 (define-layered-function display-value
(attribute value
)
124 (:method
(attribute value
)
125 (if (funcall (default-value-predicate attribute
) value
)
126 (default-value attribute
)
130 :in-layer editor
((field base-attribute
) object
)
131 (LET ((value (attribute-value (object field
) field
)))
135 :VALUE
(escape-as-html (strcat (display-value field value
)))
141 (INPUT-SIZE FIELD
))))
144 :in-layer editor
:around
((string base-attribute
) object
)
145 (dletf (((callback string
)
146 (or (callback string
)
147 (ucw::make-new-callback
149 (setf (attribute-value object string
) val
)))))
150 ((object string
) object
))
155 (defattribute string-attribute
(base-attribute)
164 (defdisplay :in-layer omit-nil-attributes
165 :around
((attribute string-attribute
) object
)
166 (when (< 0 (length (attribute-value object attribute
)))
170 (defdisplay :in-layer viewer
171 ((string string-attribute
) object
)
172 (if (escape-html-p string
)
173 (<:as-html
(attribute-value object string
))
174 (<:as-is
(attribute-value object string
))))
178 (defattribute string-attribute
(base-attribute)
185 (defattribute string-search-attribute
(string-attribute)
188 ;; the func that find search results
190 :search-action
#'(lambda ()
193 ;; when chosing from a list of results, this function selects one.
194 :select-function
(constantly t
))
195 (:type-name string-search
))
198 :in-layer editor
:after
((search string-search-attribute
) object
)
205 (IT.BESE.UCW
::SET-ACTION-PARAMETER
206 ,(IT.BESE.UCW
::MAKE-NEW-ACTION
207 (IT.BESE.UCW
::CONTEXT.CURRENT-FRAME
*CONTEXT
*)
208 (search-action search
)))
213 (defattribute text-attribute
(string-attribute)
217 (defdisplay :in-layer editor
((string text-attribute
) object
)
220 :name
(callback string
)
221 (or (attribute-value object string
) "")))
227 (defattribute wall-time-attribute
(string-attribute)
229 (:type-name clsql-sys
:wall-time
))
231 (define-layered-method attribute-value
(object (attribute wall-time-attribute
))
232 (let ((date (call-next-method)))
233 (when date
(multiple-value-bind (y m d
) (clsql:time-ymd date
)
234 (format nil
"~a/~a/~a" m d y
)))))
237 ((time wall-time-attribute
) object
)
238 (<:as-html
(attribute-value object time
)))
242 (defattribute image
()
245 :css-class
"lol-image"
248 (defdisplay ((buttons (eql 'image-editor-buttons
)) object
)
249 (<ucw
:a
:action
(ok component object
)
250 (<:as-html
"select this image")))
252 (defdisplay ((image image
) object
)
254 :class
(or (css-class image
) "lol-image")
256 (or (prefix image
) "images/")
258 (attribute-value object image
)))))
261 :in-layer editor
((image image
) object
)
264 :class
"lol-image-thumbnails"
265 (<:as-html
"imagie")))