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
)
19 (<:as-html
(or (label attribute
) (attribute.name attribute
)) " "))
21 :class
"lol-attribute"
24 (deflayer use-pretty-labels
)
26 (define-layered-method label
27 :in-layer use-pretty-labels
28 :around
(standard-attribute)
29 (let ((label (call-next-method)))
32 (substitute #\Space
#\- label
)))))
34 (defattribute display
()
36 (:documentation
"Apply the display function to this object"))
38 (defdisplay ((attribute display
) object
)
39 (apply #'display self
(attribute-value object attribute
)
40 (description.properties attribute
)))
44 (defattribute base-attribute
()
47 (defdisplay ((base base-attribute
) object
)
48 (<:as-html
(attribute-value object base
)))
50 (defattribute base-attribute
(ucw::string-field
)
56 (defmethod ucw:client-value
((self base-attribute
))
57 (attribute-value (object self
) self
))
59 (defmethod (setf ucw
:client-value
) (value (attribute base-attribute
))
60 (setf (attribute-value (object attribute
) attribute
) value
))
63 (defmethod render ((field base-attribute
))
64 "this can only be used within a display-using-description call in the editor context,
65 it is a hack to integrate lol with ucw's new form stuff"
69 (LET ((value (attribute-value (object field
) field
)))
70 (<:as-html
"asd" value
)
74 :VALUE
(escape-as-html value
)
80 (ucw::INPUT-SIZE FIELD
)))
85 :in-layer editor
((string base-attribute
) object
)
90 :in-layer editor
:around
((string base-attribute
) object
)
91 (dletf (((callback string
) (ucw::make-new-callback
93 (setf (attribute-value object string
) val
))))
94 ((object string
) object
))
99 (defattribute string-attribute
(base-attribute)
107 (defdisplay :in-layer omit-nil-attributes
108 :around
((attribute string-attribute
) object
)
109 (when (< 0 (length (attribute-value object attribute
)))
113 (defdisplay :in-layer viewer
114 ((string string-attribute
) object
)
115 (if (escape-html-p string
)
116 (<:as-html
(attribute-value object string
))
117 (<:as-is
(attribute-value object string
))))
121 (defattribute string-attribute
(base-attribute)
128 (defattribute string-search-attribute
(string-attribute)
131 ;; the func that find search results
133 :search-action
#'(lambda ()
136 ;; when chosing from a list of results, this function selects one.
137 :select-function
(constantly t
))
138 (:type-name string-search
))
141 :in-layer editor
:after
((search string-search-attribute
) object
)
148 (IT.BESE.UCW
::SET-ACTION-PARAMETER
149 ,(IT.BESE.UCW
::MAKE-NEW-ACTION
150 (IT.BESE.UCW
::CONTEXT.CURRENT-FRAME
*CONTEXT
*)
151 (search-action search
)))
156 (defattribute text-attribute
(string-attribute)
160 (defdisplay :in-layer editor
((string text-attribute
) object
)
163 :name
(callback string
)
164 (or (attribute-value object string
) "")))
170 (defattribute wall-time-attribute
(string-attribute)
172 (:type-name clsql-sys
:wall-time
))
174 (define-layered-method attribute-value
(object (attribute wall-time-attribute
))
175 (let ((date (call-next-method)))
176 (when date
(multiple-value-bind (y m d
) (clsql:time-ymd date
)
177 (format nil
"~a/~a/~a" m d y
)))))
180 ((time wall-time-attribute
) object
)
181 (<:as-html
(attribute-value object time
)))
185 (defattribute image
()
188 :css-class
"lol-image"
191 (defdisplay ((buttons (eql 'image-editor-buttons
)) object
)
192 (<ucw
:a
:action
(ok component object
)
193 (<:as-html
"select this image")))
195 (defdisplay ((image image
) object
)
197 :class
(or (css-class image
) "lol-image")
199 (or (prefix image
) "images/")
201 (attribute-value object image
)))))
204 :in-layer editor
((image image
) object
)
207 :class
"lol-image-thumbnails"
208 (<:as-html
"imagie")))