src/attributes/standard-attributes.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; A few layers related to attributes
   4 (deflayer omit-nil-attributes)
   5
   6 (defdisplay :in-layer omit-nil-attributes
   7             :around ((attribute standard-attribute) object)
   8  (when (attribute-value object attribute)
   9    (call-next-method)))
  10
  11 (deflayer show-attribute-labels)
  12
  13 (defdisplay
  14     :in-layer show-attribute-labels
  15     :around ((attribute standard-attribute) object)
  16
  17   (<:span
  18    :class "lol-label"
  19    (<:as-html (or (label attribute) (attribute.name attribute)) " "))
  20   (<:span
  21    :class "lol-attribute"
  22    (call-next-method)))
  23
  24 (deflayer use-pretty-labels)
  25
  26 (define-layered-method label
  27    :in-layer use-pretty-labels
  28    :around (standard-attribute)
  29  (let ((label (call-next-method)))
  30    (when label
  31      (string-capitalize
  32       (substitute #\Space #\- label)))))
  33
  34 (defattribute display ()
  35   ()
  36   (:documentation "Apply the display function to this object"))
  37
  38 (defdisplay ((attribute display) object)
  39   (apply #'display self (attribute-value object attribute)
  40          (description.properties attribute)))
  41
  42 ;;;; * Base Types
  43
  44 (defattribute base-attribute ()
  45   ())
  46
  47 (defdisplay ((base base-attribute) object)
  48  (<:as-html (attribute-value object base)))
  49
  50 (defattribute base-attribute (ucw::string-field)
  51   ()
  52   (:in-layer editor)
  53   (:default-properties
  54       :callback nil))
  55
  56 (defmethod ucw:client-value ((self base-attribute))
  57   (attribute-value (object self) self))
  58
  59 (defmethod (setf ucw:client-value) (value (attribute base-attribute))
  60   (setf (attribute-value (object attribute) attribute) value))
  61
  62
  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"
  66   (call-next-method))
  67
  68   #+ (or)
  69 (LET ((value (attribute-value (object field) field)))
  70   (<:as-html "asd" value)
  71   (<:input
  72    :NAME
  73    (callback field)
  74    :VALUE (escape-as-html value)
  75    :TYPE
  76    "text"
  77    :ID
  78    (DOM-ID FIELD)
  79    :SIZE
  80    (ucw::INPUT-SIZE FIELD)))
  81
  82
  83
  84 (defdisplay
  85     :in-layer editor  ((string base-attribute) object)
  86  (render string))
  87
  88
  89 (defdisplay
  90     :in-layer editor :around ((string base-attribute) object)
  91     (dletf (((callback string) (ucw::make-new-callback
  92                                 #'(lambda (val)
  93                                     (setf (attribute-value object string) val))))
  94             ((object string) object))
  95       (call-next-method)))
  96
  97 ;;;; Strings
  98
  99 (defattribute string-attribute (base-attribute)
 100   ()
 101   (:type-name string)
 102   (:default-properties
 103       :escape-html-p t
 104     :size nil
 105     :max-length nil))
 106
 107 (defdisplay :in-layer omit-nil-attributes
 108             :around ((attribute string-attribute) object)
 109  (when (< 0 (length  (attribute-value object attribute)))
 110    (call-next-method)))
 111
 112 ;;;; default
 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))))
 118
 119
 120 ;;;; editor
 121 (defattribute string-attribute (base-attribute)
 122   ()
 123   (:in-layer editor)
 124   (:default-properties
 125       :callback nil))
 126
 127
 128 (defattribute string-search-attribute (string-attribute)
 129   ()
 130   (:default-properties
 131       ;; the func that find search results
 132
 133       :search-action #'(lambda ()
 134                          (with-call/cc
 135                            nil))
 136     ;; when chosing from a list of results, this function selects one.
 137     :select-function (constantly t))
 138   (:type-name string-search))
 139
 140 (defdisplay
 141    :in-layer editor :after ((search string-search-attribute) object)
 142    (<:input
 143     :TYPE "submit"
 144     :VALUE "search"
 145     :ONCLICK
 146     (JS:JS-INLINE*
 147      `(PROGN
 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)))
 152        (RETURN T)))))
 153
 154 ;;;; textarea
 155
 156 (defattribute text-attribute (string-attribute)
 157       ()
 158       (:type-name text))
 159
 160 (defdisplay :in-layer editor ((string text-attribute) object)
 161  (<:textarea
 162   :id (id string)
 163   :name (callback string)
 164   (or (attribute-value object string) "")))
 165
 166
 167
 168 ;;;; WALL-TIME
 169
 170 (defattribute wall-time-attribute (string-attribute)
 171   ()
 172   (:type-name clsql-sys:wall-time))
 173
 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)))))
 178
 179 (defdisplay
 180   ((time wall-time-attribute) object)
 181   (<:as-html (attribute-value object time)))
 182
 183
 184
 185 (defattribute image ()
 186   ()
 187   (:default-properties
 188       :css-class "lol-image"
 189     :prefix "images/"))
 190
 191 (defdisplay ((buttons (eql 'image-editor-buttons)) object)
 192   (<ucw:a :action (ok component object)
 193           (<:as-html "select this image")))
 194
 195 (defdisplay ((image image) object)
 196   (<:img
 197    :class (or (css-class image) "lol-image")
 198    :src (arnesi:strcat
 199          (or (prefix image) "images/")
 200          (escape-as-uri
 201           (attribute-value object image)))))
 202
 203 (defdisplay
 204     :in-layer editor ((image image)  object)
 205
 206     (<:div
 207      :class "lol-image-thumbnails"
 208      (<:as-html "imagie")))
 209
 210
 211
 212
 213
 214