add contextl component using new dynamic environment stuff
[clinton/lisp-on-lines.git] / src / ucw / contextl-components.lisp
CommitLineData
eaf8cd9c 1(in-package :lisp-on-lines-ucw)
2
6963098f 3(defclass contextl-application (standard-application)
4 ()
5 (:default-initargs
6
7 :action-class 'contextl-action))
8
9(defclass contextl-action (ucw-standard:standard-action)
10 ((dynamic-environment :accessor action-dynamic-environment
11 :initform nil
12 :initarg :dynamic-environment))
13 (:metaclass closer-mop:funcallable-standard-class))
14
15(defmethod shared-initialize :after ((action contextl-action) slots &rest args)
16 (declare (ignore slots args))
17 (setf (action-dynamic-environment action) (capture-dynamic-environment)))
18
19(defmethod ucw-core:handle-action :wrap-around ((action contextl-action) application session frame)
20 (call-next-method))
21
22(defmethod ucw-core:call-action :around ((action contextl-action) application session frame)
23 (with-dynamic-environment ((action-dynamic-environment action))
24 (call-next-method)))
25
26(defmethod ucw-core:call-callbacks ((action contextl-action) frame request)
27 (with-dynamic-environment ((action-dynamic-environment action))
28 (call-next-method)))
29
30(defclass contextl-component (standard-component)
31 ((component-dynamic-environment :accessor component-dynamic-environment
32 :initform nil))
33 (:metaclass standard-component-class))
34
35(defmethod render :wrap-around ((component contextl-component))
36 (if (component-dynamic-environment component)
37 (with-dynamic-environment ((component-dynamic-environment component))
38 (call-next-method))
39 (progn (setf (component-dynamic-environment component) (capture-dynamic-environment))
40 (call-next-method))))
41
42(defmethod/cc call-component :before ((from t) (to contextl-component))
43 (setf (component-dynamic-environment to) (capture-dynamic-environment)))
44
45
46
47
48#+LOL-TEST(progn
49 (defclass contextl-test-application (contextl-application)
50 ()
51 (:default-initargs :url-prefix "/contextl/"))
52
53 (defparameter *context-test-application* (make-instance 'contextl-test-application))
54
55 (register-application ucw-user:*example-server* *context-test-application*)
56
57 (defentry-point "test.ucw" (:application *context-test-application*) ()
58 (call 'contextl-test-component))
59
60 (defdynamic foo 1)
61
62(defclass contextl-test-component (contextl-component) ()
63 (:metaclass standard-component-class))
64
65(defmethod render ((component contextl-test-component))
66 (<:As-html (dynamic foo))
67 (dlet ((foo (1+ (dynamic foo))))
68 (<:as-html (dynamic foo))
69 (<:br)
70 (with-described-object (T nil)
71 (let ((a (find-attribute *description* 'identity)))
72 (<ucw:a :action (call 'contextl-test-component)
73 "Call")))
74 (<:br)
75 (when (component.calling-component component)
76 (<ucw:a :action (answer)
77 "Answer")))
78))
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
eaf8cd9c 95#+nil (defclass contextl-session-frame (ucw-core::standard-session-frame)
96 ())
97
98#+nil(defmethod ucw-core::register-callback-in-frame ((frame contextl-session-frame) callback &key &allow-other-keys)
99 (let ((lambda (ucw::callback-lambda callback)))
100 (let ((context (contextl:current-layer-context)))
101 (setf (ucw::callback-lambda callback)
102 (lambda (arg)
103 (contextl:funcall-with-layer-context context lambda arg)))
104 (call-next-method))))
105
106#+nil(setf ucw-core::*session-frame-class* 'contextl-session-frame)
107
108