src/standard-attributes.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (deflayer omit-nil-attributes)
   4
   5 (defdisplay :in-layer omit-nil-attributes
   6             :around ((attribute standard-attribute) object)
   7  (when (attribute-value object attribute)
   8    (call-next-method)))
   9
  10 (deflayer label-attributes)
  11
  12 (defdisplay :in-layer label-attributes
  13             :around ((attribute standard-attribute) object)
  14
  15     (<:span
  16      :class "lol-label"
  17      (<:as-html (or (label attribute) (attribute.name attribute))))
  18     (<:span
  19      :class "lol-attribute"
  20      (call-next-method)))
  21
  22 ;;;; * Base Types
  23
  24 (defattribute base-attribute ()
  25   ())
  26
  27 (defdisplay ((base base-attribute) object)
  28  (<:as-html (attribute-value object base)))
  29
  30
  31 (defattribute base-attribute ()
  32   ()
  33   (:in-layer editor)
  34   (:default-properties
  35       :callback nil))
  36
  37 (defdisplay
  38     :in-layer editor :around ((string base-attribute) object)
  39     (dletf (((callback string) (ucw::make-new-callback
  40                                 #'(lambda (val)
  41                                     (setf (attribute-value object string) val)))))
  42       (call-next-method)))
  43
  44 ;;;; Strings
  45
  46 (defattribute string-attribute ()
  47   ()
  48   (:type-name string)
  49   (:default-properties
  50       :escape-html-p t
  51     :size nil
  52     :max-length nil))
  53
  54 (defdisplay
  55     :in-layer editor ((string base-attribute) object)
  56  (<:input
  57   :type "text"
  58   :id (id string)
  59   :name (callback string)
  60   :value (or (attribute-value object string) "")))
  61
  62
  63 (defdisplay :in-layer omit-nil-attributes
  64             :around ((attribute string-attribute) object)
  65  (when (< 0 (length  (attribute-value object attribute)))
  66    (call-next-method)))
  67
  68 ;;;; default
  69 (defdisplay :in-layer viewer
  70             ((string string-attribute) object)
  71   (if (escape-html-p string)
  72       (<:as-html (attribute-value object string))
  73       (<:as-is (attribute-value object string))))
  74
  75
  76 ;;;; editor
  77 (defattribute string-attribute (base-attribute)
  78   ()
  79   (:in-layer editor)
  80   (:default-properties
  81       :callback nil))
  82
  83
  84 (defattribute string-search-attribute (string-attribute)
  85   ()
  86   (:default-properties
  87       ;; the func that find search results
  88
  89       :search-action #'(lambda ()
  90                          (with-call/cc
  91                            nil))
  92     ;; when chosing from a list of results, this function selects one.
  93     :select-function (constantly t))
  94   (:type-name string-search))
  95
  96 (defdisplay
  97    :in-layer editor :after ((search string-search-attribute) object)
  98    (<:input
  99     :TYPE "submit"
 100     :VALUE "search"
 101     :ONCLICK
 102     (JS:JS-INLINE*
 103      `(PROGN
 104        (IT.BESE.UCW::SET-ACTION-PARAMETER
 105         ,(IT.BESE.UCW::MAKE-NEW-ACTION
 106           (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
 107           (search-action search)))
 108        (RETURN T)))))
 109
 110 ;;;; textarea
 111
 112 (defattribute text-attribute (string-attribute)
 113       ()
 114       (:type-name text))
 115
 116 (defdisplay :in-layer editor ((string text-attribute) object)
 117  (<:textarea
 118   :id (id string)
 119   :name (callback string)
 120   (or (attribute-value object string) "")))
 121
 122
 123
 124 ;;;; WALL-TIME
 125
 126 (defattribute wall-time-attribute (string-attribute)
 127   ()
 128   (:type-name clsql-sys:wall-time))
 129
 130 (define-layered-method attribute-value (object (attribute wall-time-attribute))
 131  (let ((date (call-next-method)))
 132    (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
 133                 (format nil "~a/~a/~a" m d y)))))
 134
 135 (defdisplay
 136   ((time wall-time-attribute) object)
 137   (<:as-html (attribute-value object time)))
 138
 139
 140
 141 (defattribute image ()
 142   ()
 143   (:default-properties
 144       :css-class "lol-image"
 145     :prefix "images/"))
 146
 147 (defdisplay ((buttons (eql 'image-editor-buttons)) object)
 148   (<ucw:a :action (ok component object)
 149           (<:as-html "select this image")))
 150
 151 (defdisplay ((image image) object)
 152   (<:img
 153    :class (or (css-class image) "lol-image")
 154    :src (arnesi:strcat
 155          (or (prefix image) "images/")
 156          (escape-as-uri
 157           (attribute-value object image)))))
 158
 159 (defdisplay
 160     :in-layer editor ((image image)  object)
 161
 162     (<:div
 163      :class "lol-image-thumbnails"
 164      (<:as-html "imagie")))
 165
 166
 167
 168
 169
 170