Misc Cleanups.
[clinton/lisp-on-lines.git] / src / ucw / standard-components.lisp
CommitLineData
4358148e 1(in-package :lisp-on-lines-ucw)
2
e8fd1a9a 3(defclass lisp-on-lines-action (ucw-standard::standard-action)
4 ((layer-context :accessor action-layer-context
5 :initform nil
6 :initarg :layer-context))
7 (:metaclass closer-mop:funcallable-standard-class))
b7657b86 8
b7657b86 9
e8fd1a9a 10(setf ucw-standard::*default-action-class* 'lisp-on-lines-action)
b7657b86 11
b7657b86 12
b7657b86 13
e8fd1a9a 14(defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
15 (let ((next-method (lambda ()
16 (layered-call-action
17 action application session frame
18 (lambda ()
19 (call-next-method))))))
20 (let ((layer-context (action-layer-context action)))
21 (if layer-context
22 (funcall-with-layer-context layer-context next-method)
23 (funcall next-method)))
24 ))
b7657b86 25
e8fd1a9a 26(defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
27 (let ((lol::*invalid-objects* (make-hash-table)))
28 (handler-bind ((lol::validation-condition
29 (lambda (c)
30 (let ((object (lol::validation-condition-object c))
31 (attribute (lol::validation-condition-attribute c)))
b7657b86 32
b7657b86 33
e8fd1a9a 34 (setf (gethash object lol::*invalid-objects*)
35 (cons (cons attribute c)
36 (gethash object lol::*invalid-objects*)))))))
37 (call-next-method))))
b7657b86 38
4358148e 39
e8fd1a9a 40(define-layered-function layered-call-action (action application session frame next-method)
41 (:method (action application session frame next-method)
42 (funcall next-method)))
4358148e 43
4358148e 44
e8fd1a9a 45(contextl:define-layered-method layered-call-action
46 :in-layer #.(lol::defining-description 'lol::validate)
47 :around ((action lisp-on-lines-action) application session frame next-method)
48 (call-next-method)
4358148e 49
e8fd1a9a 50 )
4358148e 51
4358148e 52
2548f054 53
e8fd1a9a 54(defclass described-component-class (described-class standard-component-class )
55 ())
2548f054 56
57
58
4358148e 59(defcomponent standard-window-component
e8fd1a9a 60 (ucw-standard::basic-window-component)
4358148e 61 ((body
62 :initform nil
63 :accessor window-body
64 :component t
65 :initarg :body)))
66
b1c8f43b 67(defmethod render-html-head ((window standard-window-component))
68 (let* ((app (context.application *context*))
69 (url-prefix (application.url-prefix app)))
70 (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
71 (awhen (window-component.title window)
72 (<:title (if (functionp it)
73 (funcall it window)
74 (<:as-html it))))
75 (awhen (window-component.icon window)
76 (<:link :rel "icon"
77 :type "image/x-icon"
78 :href (concatenate 'string url-prefix it)))
79 (dolist (stylesheet (effective-window-stylesheets window))
80 (<:link :rel "stylesheet"
81 :href stylesheet
82 :type "text/css"))))
83
6de8d300 84(defmethod render-html-body ((window standard-window-component))
e8fd1a9a 85 (render (window-body window)))
b7657b86 86
87(defcomponent info-message ()
88 ((message :accessor message :initarg :message)))
89
90(defmethod render ((m info-message))
91 (<:div
92 :class "info-mssage"
93 (<:as-html (message m)))
94 (<lol:a :action (answer-component m nil) "Ok"))
95
96