(in-package :lisp-on-lines-ucw)
+(defclass contextl-application (standard-application)
+ ()
+ (:default-initargs
+
+ :action-class 'contextl-action))
+
+(defclass contextl-action (ucw-standard:standard-action)
+ ((dynamic-environment :accessor action-dynamic-environment
+ :initform nil
+ :initarg :dynamic-environment))
+ (:metaclass closer-mop:funcallable-standard-class))
+
+(defmethod shared-initialize :after ((action contextl-action) slots &rest args)
+ (declare (ignore slots args))
+ (setf (action-dynamic-environment action) (capture-dynamic-environment)))
+
+(defmethod ucw-core:handle-action :wrap-around ((action contextl-action) application session frame)
+ (call-next-method))
+
+(defmethod ucw-core:call-action :around ((action contextl-action) application session frame)
+ (with-dynamic-environment ((action-dynamic-environment action))
+ (call-next-method)))
+
+(defmethod ucw-core:call-callbacks ((action contextl-action) frame request)
+ (with-dynamic-environment ((action-dynamic-environment action))
+ (call-next-method)))
+
+(defclass contextl-component (standard-component)
+ ((component-dynamic-environment :accessor component-dynamic-environment
+ :initform nil))
+ (:metaclass standard-component-class))
+
+(defmethod render :wrap-around ((component contextl-component))
+ (if (component-dynamic-environment component)
+ (with-dynamic-environment ((component-dynamic-environment component))
+ (call-next-method))
+ (progn (setf (component-dynamic-environment component) (capture-dynamic-environment))
+ (call-next-method))))
+
+(defmethod/cc call-component :before ((from t) (to contextl-component))
+ (setf (component-dynamic-environment to) (capture-dynamic-environment)))
+
+
+
+
+#+LOL-TEST(progn
+ (defclass contextl-test-application (contextl-application)
+ ()
+ (:default-initargs :url-prefix "/contextl/"))
+
+ (defparameter *context-test-application* (make-instance 'contextl-test-application))
+
+ (register-application ucw-user:*example-server* *context-test-application*)
+
+ (defentry-point "test.ucw" (:application *context-test-application*) ()
+ (call 'contextl-test-component))
+
+ (defdynamic foo 1)
+
+(defclass contextl-test-component (contextl-component) ()
+ (:metaclass standard-component-class))
+
+(defmethod render ((component contextl-test-component))
+ (<:As-html (dynamic foo))
+ (dlet ((foo (1+ (dynamic foo))))
+ (<:as-html (dynamic foo))
+ (<:br)
+ (with-described-object (T nil)
+ (let ((a (find-attribute *description* 'identity)))
+ (<ucw:a :action (call 'contextl-test-component)
+ "Call")))
+ (<:br)
+ (when (component.calling-component component)
+ (<ucw:a :action (answer)
+ "Answer")))
+))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
#+nil (defclass contextl-session-frame (ucw-core::standard-session-frame)
())
(defpackage lisp-on-lines-ucw
(:documentation "An LoL Layer over ucw.basic")
(:nicknames #:lol-ucw)
- (:use #:lisp-on-lines #:ucw :ucw-core :common-lisp :arnesi)
+ (:use #:lisp-on-lines #:ucw :ucw-core :common-lisp :arnesi :contextl)
(:shadowing-import-from :js
#:new)
(:export
-
- ;;; First, LOL-UCW exports. The rest are from UCW.
- #:lol-component
+ #:lol-component
#:described-component-class))
(in-package :lisp-on-lines-ucw)
-(defclass lisp-on-lines-action (ucw-standard::standard-action)
- ((layer-context :accessor action-layer-context
- :initform nil
- :initarg :layer-context))
+(defclass lisp-on-lines-application (contextl-application)
+ ()
+ (:default-initargs :action-class 'lisp-on-lines-action))
+
+(defclass lisp-on-lines-action (contextl-action)
+ ()
(:metaclass closer-mop:funcallable-standard-class))
+(defclass lisp-on-lines-component (contextl-component)
+ ()
+ (:metaclass standard-component-class))
+
+(defclass lisp-on-lines-component-class (standard-component-class)
+ ())
+
+
+(defmethod initialize-instance :around ((class lisp-on-lines-component-class)
+ &rest initargs &key (direct-superclasses '()))
+ (declare (dynamic-extent initargs))
+ (if (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component)))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (find-class 'lisp-on-lines-component)))
+ initargs)))
+
+
+(defmethod reinitialize-instance :around ((class lisp-on-lines-component-class)
+ &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+ (declare (dynamic-extent initargs))
+ (if (or (not direct-superclasses-p)
+ (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component))))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (find-class 'lisp-on-lines-component)))
+ initargs)))
+
+(defclass described-component-class (described-class standard-component-class )
+ ())
-(setf ucw-core::*default-action-class* 'lisp-on-lines-action)
-(defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
- (let ((next-method (lambda ()
- (layered-call-action
- action application session frame
- (lambda ()
- (call-next-method))))))
- (let ((layer-context (action-layer-context action)))
- (if layer-context
- (contextl:funcall-with-layer-context layer-context next-method)
- (funcall next-method)))
- ))
(defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)
(let ((lol::*invalid-objects* (make-hash-table)))
(call-next-method))))
-(contextl:define-layered-function layered-call-action (action application session frame next-method)
- (:method (action application session frame next-method)
- (funcall next-method)))
-(contextl:define-layered-method layered-call-action
- :in-layer #.(lol::defining-description 'lol::validate)
- :around ((action lisp-on-lines-action) application session frame next-method)
- (call-next-method)
- )