| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | ;;;; LoL CLOS Tests |
| 4 | ;;;; |
| 5 | (defclass lol-test-class () |
| 6 | ((test-slot-value :initform "slot-value") |
| 7 | (test-string :initform "Test String")) |
| 8 | (:documentation "foo")) |
| 9 | |
| 10 | (defvar *foo* nil) |
| 11 | |
| 12 | (defvar *standard-layers* '(viewer editor creator one-line as-string)) |
| 13 | |
| 14 | (define-attributes (lol-test-class) |
| 15 | (test-getter t |
| 16 | :label "Getter" |
| 17 | :getter (constantly "Hello World")) |
| 18 | (test-getter/setter t |
| 19 | :label "Getter/Setter:" |
| 20 | :getter (lambda () |
| 21 | *foo*) |
| 22 | :setter #'(lambda (value) |
| 23 | (setf *foo* value))) |
| 24 | (test-slot-value t) |
| 25 | (test-string string :label "String" :documentation)) |
| 26 | |
| 27 | (defcomponent test-component () |
| 28 | (current-layer :accessor current-type :initform 'viewer) |
| 29 | (layer-spec :accessor layer-spec :initform nil) |
| 30 | (instance :accessor instance :initform (make-instance 'test-class)))) |
| 31 | |
| 32 | (defmethod render ((self test-component)) |
| 33 | (let ((test (instance self))) |
| 34 | (<:h1 (<:as-html "Lisp on Lines Test Component")) |
| 35 | (with-component (self) |
| 36 | (<ucw:form |
| 37 | :action (refresh-component self) |
| 38 | (<ucw:select :accessor (current-layer self) |
| 39 | (dolist* (type (display-types self)) |
| 40 | (<ucw:option :value type (<:as-html type)))) |
| 41 | (<:input :type "Submit" :value "update") |
| 42 | (<:fieldset |
| 43 | (<:legend (<:as-html (current-type self))) |
| 44 | (display test :type (current-type self))))))) |
| 45 | |
| 46 | |
| 47 | (defcomponent standard-display-component () |
| 48 | ((display-function :accessor display-function :initarg :display))) |
| 49 | |
| 50 | (defmethod render ((self standard-display-component)) |
| 51 | (funcall (display-function self) self)) |