From 6963098fa7926e13ce221b8c0a3886f9f9984ac1 Mon Sep 17 00:00:00 2001
From: drewc <drewc@tech.coop>
Date: Fri, 24 Jul 2009 10:08:25 -0700
Subject: [PATCH] add contextl component using new dynamic environment stuff

darcs-hash:20090724170825-39164-5167dc5a28fa6e0fc101e5b6766017eb65d82d37.gz
---
 src/ucw/contextl-components.lisp | 92 ++++++++++++++++++++++++++++++++
 src/ucw/packages.lisp            |  6 +--
 src/ucw/standard-components.lisp | 68 ++++++++++++++---------
 3 files changed, 138 insertions(+), 28 deletions(-)

diff --git a/src/ucw/contextl-components.lisp b/src/ucw/contextl-components.lisp
index 80431c3..0f4465e 100644
--- a/src/ucw/contextl-components.lisp
+++ b/src/ucw/contextl-components.lisp
@@ -1,5 +1,97 @@
 (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)
   ())
 
diff --git a/src/ucw/packages.lisp b/src/ucw/packages.lisp
index 4d97207..5649f6c 100644
--- a/src/ucw/packages.lisp
+++ b/src/ucw/packages.lisp
@@ -2,7 +2,7 @@
 (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)  
@@ -14,9 +14,7 @@
 
 		
   (:export 
-
-   ;;; First, LOL-UCW exports. The rest are from UCW.
-   #:lol-component
    
+   #:lol-component   
    #:described-component-class))
 
diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
index 8ffe33d..3509a8a 100644
--- a/src/ucw/standard-components.lisp
+++ b/src/ucw/standard-components.lisp
@@ -1,26 +1,54 @@
 (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)))
@@ -36,17 +64,9 @@
        (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)
 
-   )
 
 
 
-- 
2.20.1