src/ucw/contextl-components.lisp

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