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 ;;;; Strings
  31
  32 (defattribute string-attribute (base-attribute)
  33   ()
  34
  35   (:type-name string)
  36   (:default-properties
  37       :escape-html-p t
  38     :size nil
  39     :max-length nil))
  40
  41 (defdisplay :in-layer omit-nil-attributes
  42             :around ((attribute string-attribute) object)
  43  (when (< 0 (length  (attribute-value object attribute)))
  44    (call-next-method)))
  45
  46
  47 ;;;; default
  48 (defdisplay ((string string-attribute) object)
  49   (if (escape-html-p string)
  50       (<:as-html (attribute-value object string))
  51       (<:as-is (attribute-value object string))))
  52
  53
  54 ;;;; editor
  55 (defattribute string-attribute (base-attribute)
  56   ()
  57   (:in-layer editor)
  58   (:default-properties
  59       :callback nil))
  60
  61 (defdisplay
  62    :in-layer editor :around ((string string-attribute) object)
  63  (dletf (((callback string) (ucw::make-new-callback
  64                              #'(lambda (val)
  65                                  (setf (attribute-value object string) val)))))
  66    (call-next-method)))
  67
  68 (defdisplay :in-layer editor ((string string-attribute) object)
  69  (<:input
  70   :type "text"
  71   :id (id string)
  72   :name (callback string)
  73   :value (or (attribute-value object string) "")))
  74
  75 (defattribute string-search-attribute (string-attribute)
  76   ()
  77   (:default-properties
  78       ;; the func that find search results
  79
  80       :search-action #'(lambda ()
  81                          (with-call/cc
  82                            nil))
  83     ;; when chosing from a list of results, this function selects one.
  84     :select-function (constantly t))
  85   (:type-name string-search))
  86
  87 (defdisplay
  88    :in-layer editor :after ((search string-search-attribute) object)
  89      (IT.BESE.YACLML.TAGS:INPUT
  90       :TYPE "submit"
  91       :VALUE "search"
  92       :ONCLICK
  93       (JS:JS-INLINE*
  94        `(PROGN
  95          (IT.BESE.UCW::SET-ACTION-PARAMETER
  96           ,(IT.BESE.UCW::MAKE-NEW-ACTION
  97             (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
  98             (search-action search)))
  99          (RETURN T)))))
 100
 101 ;;;; textarea
 102
 103 (defattribute text-attribute (string-attribute)
 104   ()
 105   (:type-name text))
 106
 107 (defdisplay :in-layer editor ((string text-attribute) object)
 108  (<:textarea
 109   :id (id string)
 110   :name (callback string)
 111  (or (attribute-value object string) "")))
 112
 113
 114
 115 ;;;; WALL-TIME
 116
 117 (defattribute wall-time-attribute (string-attribute)
 118   ()
 119   (:type-name clsql-sys:wall-time))
 120
 121 (define-layered-method attribute-value (object (attribute wall-time-attribute))
 122  (let ((date (call-next-method)))
 123    (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
 124                 (format nil "~a/~a/~a" m d y)))))
 125
 126 (defdisplay
 127   ((time wall-time-attribute) object)
 128   (<:as-html (attribute-value object time)))
 129
 130
 131
 132 (defattribute image ()
 133   ())
 134
 135 (defdisplay ((buttons (eql 'image-editor-buttons)) object)
 136   (<ucw:a :action (ok component object)
 137           (<:as-html "select this image")))
 138
 139 (defdisplay ((image image) object)
 140   (<:img
 141    :class (or (.get :css-class) "lol-image")
 142    :src (arnesi:strcat
 143          (or (.get :prefix) "images/")
 144          (escape-as-uri
 145           (attribute-value object image)))))
 146
 147 (defdisplay
 148     :in-layer editor ((image image)  object)
 149
 150     (<:div
 151      :class "lol-image-thumbnails"
 152
 153      (dolist* (i (or (.get :directory)
 154                      (cl-fad:list-directory (strcat *default-pathname-defaults* "wwwroot/images/"))))
 155        (<:div
 156         :style "border: 1px solid black;width:100px;"
 157         (<:img
 158          :width "90px"
 159          :src (strcat (or (.get :prefix) "images/")
 160                       (file-namestring i)))
 161         (display-using-description* 'image-editor-buttons (file-namestring i) (.properties)))
 162        (<:p :style "clear:both;"))))
 163
 164
 165
 166
 167
 168