| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | ;;;; LoL CLOS Test Class |
| 4 | (defclass lol-test-class () |
| 5 | ((test-string :initform "test string")) |
| 6 | (:documentation "foo")) |
| 7 | |
| 8 | (set-default-attributes 'lol-test-class) |
| 9 | |
| 10 | (define-attributes (lol-test-class) |
| 11 | (test-string t :label "String :")) |
| 12 | |
| 13 | (defcomponent test-component () |
| 14 | ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string)) |
| 15 | (current-type :accessor current-type :initform 'viewer) |
| 16 | (instance :accessor instance :initform (make-instance 'test-class)))) |
| 17 | |
| 18 | (defmethod render ((self test-component)) |
| 19 | (let ((test (instance self))) |
| 20 | (<:h1 (<:as-html "Lisp on Lines Test Component")) |
| 21 | (with-component (self) |
| 22 | (<ucw:form |
| 23 | :action (refresh-component self) |
| 24 | (<ucw:select :accessor (current-type self) |
| 25 | (dolist* (type (display-types self)) |
| 26 | (<ucw:option :value type (<:as-html type)))) |
| 27 | (<:input :type "Submit" :value "update") |
| 28 | (<:fieldset |
| 29 | (<:legend (<:as-html (current-type self))) |
| 30 | (display test :type (current-type self))))) |
| 31 | |
| 32 | (<:div |
| 33 | (<:h2 |
| 34 | (<:as-html "UCW Presentation based displays (the old school")) |
| 35 | (dolist (type '(:viewer :editor :creator :one-line :as-string)) |
| 36 | (<:h3 (<:as-html type)) |
| 37 | (present-view (test type self)) |
| 38 | (<ucw:a :action (call-view (test type self)) |
| 39 | (<:as-html "Call to " type)))))) |
| 40 | |
| 41 | |
| 42 | (defcomponent standard-display-component () |
| 43 | ((display-function :accessor display-function :initarg :display))) |
| 44 | |
| 45 | (defmethod render ((self standard-display-component)) |
| 46 | (funcall (display-function self) self)) |