[ginseng-cvs] CVS ginseng/src

[wchunye]

Update of /project/ginseng/cvsroot/ginseng/src
In directory cl-net:/tmp/cvs-serv8814/src

Modified Files:
	application.lisp dispatcher.lisp package.lisp 
Log Message:
support env-var.


--- /project/ginseng/cvsroot/ginseng/src/application.lisp	2010/08/09 12:27:25	1.1
+++ /project/ginseng/cvsroot/ginseng/src/application.lisp	2010/08/11 12:02:40	1.2
@@ -1,13 +1,8 @@
 (in-package :ginseng)
 (defparameter *k* nil)
-(defmacro dynamic-url (&body body)
-  (hunchentoot::with-unique-names
-      (next)
-    `(let ((,next (make-unique-id)))
-       (setf (gethash ,next *k*)
-             #'(lambda ()
-                 , at body))
-       (relative-url-to-app :args (list ,next)))))
+(defparameter *environment* nil)
+(defvar *last-k* nil) ;for debug
+(defvar *last-environment* nil)
 (defun relative-url-to-app (&key 
                             (prefix *ginseng-prefix*)
                             (package (package-name *package*))
@@ -15,17 +10,58 @@
                             (args))
   (format nil "~{~A~^/~}" 
           (append (list prefix package app) args)))
-
-(defun invoke-next-action (next-action &optional (main #'identity))
+(defmacro dynamic-url (&body body)
+  (hunchentoot::with-unique-names
+      (next env)
+    `(let ((,next (make-unique-id)))
+       (setf (gethash ,next *k*)
+             (list
+              #'(lambda ()
+                  , at body)
+              *environment*))
+       (relative-url-to-app :args (list ,next)))))
+(defun default-main()
+  (with-yaclml-output-to-string
+    (<:html
+     (<:head
+      (<:title "GINSENG DEFAULT ACTION FOR DEBUG."))
+     (<:body 
+      (<:h1 "DEFAULT ACTION IS NOT DEFINED.")
+      (<:p 
+       (<:table
+        (<:tr (<:td "ENVIRONMENT-VARIABLE: ") (<:td " "))
+        (maphash 
+         #'(lambda (k v)
+             (<:tr
+              (<:td (<:as-html k))
+              (<:td (<:as-html v))))
+         *environment*)
+        ;; (<:tr (<:td "ARGS: ") (<:td " "))            
+        ;; (loop for arg in args
+        ;;    for i upfrom 0
+        ;;       (<:td (<:as-html i))
+        ;;      (<:td (<:as-html arg))
+        ;;   )))))
+        ))))))
+(defun invoke-next-action (next-action 
+                           &key
+                           (main #'default-main)
+                           (init-env-var nil)
+                           )
   (let ((*k* (or (session-value 'k) (make-hash-table :test #'equal))))
     (setf (session-value 'k) *k*)
-    (funcall (gethash next-action *k* 
-                      main))))
-
-
+    (setq *last-k* *k*)
+    (destructuring-bind (f e1) 
+        (gethash next-action *k* 
+                 (list main (let ((r (make-hash-table :test #'eq)))
+                              (dolist (pair init-env-var)
+                                (setf (gethash (car pair) r) (cdr pair)))
+                              r)))
+      (let ((*environment* (alexandria:copy-hash-table e1)))
+        (setq *last-environment* *environment*)
+        (funcall f)))))
 (defun get-parameter (id type &optional (method :both))
   (hunchentoot::compute-parameter id type method))
-
 (defstruct callback-factory callbacks)
 (defun create-callback (cf func
                         &key
@@ -43,4 +79,13 @@
      id))
 (defun apply-callbacks(cf)
   (dolist (f (callback-factory-callbacks cf))
-    (funcall f)))
\ No newline at end of file
+    (funcall f)))
+
+(defmacro with-rebinds(vars &body body)
+  `(let (,@(loop for var in vars
+              collect `(,var ,var)))
+     , at body))
+(defun (setf env-var) (new-value symbol)
+  (setf (gethash symbol *environment*) new-value))
+(defun env-var (symbol &optional default)
+  (gethash symbol *environment* default))
\ No newline at end of file
--- /project/ginseng/cvsroot/ginseng/src/dispatcher.lisp	2010/08/09 12:27:25	1.1
+++ /project/ginseng/cvsroot/ginseng/src/dispatcher.lisp	2010/08/11 12:02:40	1.2
@@ -10,8 +10,10 @@
 (defmacro with-last-environment (&body body)
   `(let* ((ginseng::*last-request* ginseng::*last-request*)
           (hunchentoot::*request* ginseng::*last-request*)
-         (hunchentoot::*acceptor* (hunchentoot:request-acceptor ginseng::*last-request*))
-          (hunchentoot::*session* (hunchentoot:session-verify ginseng::*last-request*)))
+          (hunchentoot::*acceptor* (hunchentoot:request-acceptor ginseng::*last-request*))
+          (hunchentoot::*session* (hunchentoot:session-verify ginseng::*last-request*))
+          (*environment* *last-environment*)
+          (*k* *last-k*))
      , at body))
 (defun ginseng-dispacher ()
   (setq *last-request* *request*)
--- /project/ginseng/cvsroot/ginseng/src/package.lisp	2010/08/09 12:27:25	1.1
+++ /project/ginseng/cvsroot/ginseng/src/package.lisp	2010/08/11 12:02:40	1.2
@@ -1,6 +1,6 @@
 (in-package :cl-user)
 (defpackage :ginseng
-  (:use :cl :iterate)
+  (:use :cl :iterate :yaclml)
   (:export :my-debug :aprogn :it :start-server :stop-server
            :dynamic-url
            :relative-url-to-app
@@ -8,6 +8,8 @@
            :make-callback-factory
            :create-callback
            :apply-callbacks
+           :env-var
+           :with-rebinds
            )
   (:import-from :hunchentoot 
                 :*dispatch-table*