[Bese-devel] "Memoized" One time actions.

[Drew Crampsie]

Attached (and inlined) is a patch that adds this behavior to UCW proper

"Memoized" has been renamed "isolated", and the magic words look like:

(defaction foo :isolate ((c component) ...)
  ...)

Patch output is in 'tla changes --diffs >isolate.diff' format, which i 
hope is what arch users do (i use darcs and i have a darcs achive that 
tracks UCW if anybody is interested).

drew



* looking for ucw-2004 at common-lisp.net/ucw--dev--0.3--patch-210 to 
compare with
* comparing to ucw-2004 at common-lisp.net/ucw--dev--0.3--patch-210
M  src/rerl/standard-action.lisp
M  src/rerl/standard-component/standard-component.lisp

* modified files

--- orig/src/rerl/standard-action.lisp
+++ mod/src/rerl/standard-action.lisp
@@ -98,7 +98,7 @@
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;; Defining actions and entry points

-(defmacro defaction (name ((self self-class) &rest other-args) &body body)
+(defmacro %defaction (name ((self self-class) &rest other-args) &body body)
    "Defines an action method named NAME."
    `(defmethod/cc ,name ((,self ,self-class) , at other-args)
       ;; extract declares and docstirngs from BODY and put them here
@@ -117,6 +117,21 @@
         (block ,name
           , at body))))

+(defmacro defaction (name &rest rest)
+  (if (equal (car rest) :isolate)
+      (destructuring-bind (args &body body) (cdr rest)
+	(let ((fun (concatenate 'string
+				(string name)
+				"-"
+				(string (gensym)))))
+	  `(progn
+	     (%defaction ,(intern fun) ,args
+	       , at body)
+	     (%defaction ,name ,args
+	       (run-isolated ,(caar args) #',(intern fun) ,(caar args) ,@(cdr 
args))))))
+
+      `(%defaction ,name , at rest)))
+
  (defun gen-entry-point-lambda (url request-lambda-list body)
    `(lambda ()
       (ucw.component.action.dribble


--- orig/src/rerl/standard-component/standard-component.lisp
+++ mod/src/rerl/standard-component/standard-component.lisp
@@ -23,6 +23,11 @@
     (transaction-stack :initarg :transaction-stack
                        :accessor component.transaction-stack
                        :initform nil)
+   (isolate-hash :initarg :isolate-hash
+		 :accessor component.isolate-hash
+		 :initform (make-hash-table :test #'equalp)
+		 :documentation
+"A hash table containing the values of actions declared with the 
:isolate property")
     (parent :initarg :parent :accessor parent :initform nil))
    (:documentation "Super class of all standard components."))

@@ -134,6 +139,18 @@
  (defmethod update-url ((comp standard-component) url)
    url)

+(defmethod run-isolated ((comp standard-component) fun &rest args)
+  "isolate an action so that repeated calls (ie by reloading the page) 
use a cached value"
+  (let* ((memo-id
+	  (concatenate 'string
+		       (ucw::find-session-id *context*)
+		       (ucw::find-frame-id *context*)
+		       (ucw::find-action-id *context*)))
+	 (memo (gethash memo-id (component.isolate-hash comp))))
+    (or memo
+	(setf (gethash memo-id (component.isolate-hash comp)) (apply fun args)))))
+
+
  (defmacro defcomponent (name supers slots &rest options)
    "Convience macro for defining a component class.


-------------- next part --------------
A non-text attachment was scrubbed...
Name: isolate.diff
Type: text/x-patch
Size: 2746 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/bese-devel/attachments/20050204/6a0ae154/attachment.bin>