Add NULL description
[clinton/lisp-on-lines.git] / src / ucw / standard-components.lisp
1 (in-package :lisp-on-lines-ucw)
2
3 (defparameter *source-component* nil)
4
5 (defclass standard-basic-action (basic-action)
6 ((source-component :accessor action-source-component))
7 (:metaclass mopp:funcallable-standard-class))
8
9 (defmethod shared-initialize :before ((action standard-basic-action) slots &rest args)
10 (declare (ignore slots args))
11 (setf (action-source-component action) *source-component*))
12
13 (defmethod handle-action :around ((action standard-basic-action) a s f)
14 (let ((*source-component* (action-source-component action)))
15 (call-next-method)))
16
17 (defmethod render :around (component)
18 (let ((*source-component* component))
19 (call-next-method)))
20
21
22 (defun/cc call (name &rest args)
23 (call-component *source-component*
24 (apply #'make-instance name args)))
25
26 (defun/cc answer (&optional val)
27 (let ((child *source-component*))
28 (setf *source-component* (ucw::component.calling-component child))
29 (answer-component child val)))
30
31 (defclass described-component-class (described-class standard-component-class )
32 ())
33
34 (defmacro defaction (&rest args-and-body)
35 `(arnesi:defmethod/cc ,@args-and-body))
36
37 (defparameter *default-action-class* 'standard-basic-action)
38
39 (defun make-action (lambda &rest initargs &key (class *default-action-class*) &allow-other-keys)
40 "Makes a new unregistered action."
41 (remf-keywords initargs :class)
42 (apply #'make-instance class :lambda lambda initargs))
43
44
45 (defclass standard-application (ucw:basic-application)
46 ())
47
48 (defclass standard-request-context (ucw::standard-request-context)
49 ())
50
51 (defmethod ucw:request-context-class list ((application standard-application))
52 'standard-request-context)
53
54 (defvar +action-compound-name-delimiter+ #\|)
55
56 (defmethod ucw::find-action-id :around ((context standard-request-context))
57 (or
58 (loop
59 :for (k . v) in (ucw::parameters
60 (context.request context))
61 :do(destructuring-bind (param-name &optional action-id)
62 (split-sequence:split-sequence
63 +action-compound-name-delimiter+ k)
64 (when (and action-id
65 (string=
66 ucw::+action-parameter-name+ param-name))
67 (return action-id))))
68 (call-next-method)))
69
70
71
72
73
74 (defcomponent standard-window-component
75 (ucw::basic-window-component)
76 ((body
77 :initform nil
78 :accessor window-body
79 :component t
80 :initarg :body)))
81
82 (defmethod render-html-head ((window standard-window-component))
83 (let* ((app (context.application *context*))
84 (url-prefix (application.url-prefix app)))
85 (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
86 (awhen (window-component.title window)
87 (<:title (if (functionp it)
88 (funcall it window)
89 (<:as-html it))))
90 (awhen (window-component.icon window)
91 (<:link :rel "icon"
92 :type "image/x-icon"
93 :href (concatenate 'string url-prefix it)))
94 (dolist (stylesheet (effective-window-stylesheets window))
95 (<:link :rel "stylesheet"
96 :href stylesheet
97 :type "text/css"))))
98
99 (defmethod render-html-body ((window standard-window-component))
100 (ucw:render (window-body window)))
101
102 (defcomponent info-message ()
103 ((message :accessor message :initarg :message)))
104
105 (defmethod render ((m info-message))
106 (<:div
107 :class "info-mssage"
108 (<:as-html (message m)))
109 (<lol:a :action (answer-component m nil) "Ok"))
110
111