From wchunye at common-lisp.net Mon Aug 9 12:11:11 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:11:11 -0400 Subject: [ginseng-cvs] CVS ginseng Message-ID: Update of /project/ginseng/cvsroot/ginseng In directory cl-net:/tmp/cvs-serv25167 Log Message: initial version Status: Vendor Tag: start Release Tags: wchunye No conflicts created by this import From wchunye at common-lisp.net Mon Aug 9 12:21:26 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:21:26 -0400 Subject: [ginseng-cvs] CVS ginseng/doc Message-ID: Update of /project/ginseng/cvsroot/ginseng/doc In directory cl-net:/tmp/cvs-serv29129/doc Log Message: Directory /project/ginseng/cvsroot/ginseng/doc added to the repository From wchunye at common-lisp.net Mon Aug 9 12:22:22 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:22:22 -0400 Subject: [ginseng-cvs] CVS ginseng/examples Message-ID: Update of /project/ginseng/cvsroot/ginseng/examples In directory cl-net:/tmp/cvs-serv29199/examples Log Message: Directory /project/ginseng/cvsroot/ginseng/examples added to the repository From wchunye at common-lisp.net Mon Aug 9 12:26:15 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:26:15 -0400 Subject: [ginseng-cvs] CVS ginseng/src Message-ID: Update of /project/ginseng/cvsroot/ginseng/src In directory cl-net:/tmp/cvs-serv29466/src Log Message: Directory /project/ginseng/cvsroot/ginseng/src added to the repository From wchunye at common-lisp.net Mon Aug 9 12:27:25 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:27:25 -0400 Subject: [ginseng-cvs] CVS ginseng Message-ID: Update of /project/ginseng/cvsroot/ginseng In directory cl-net:/tmp/cvs-serv29557 Added Files: .cvsignore COPYRIGHT ginseng-examples.asd ginseng.asd Log Message: initial version. --- /project/ginseng/cvsroot/ginseng/.cvsignore 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/.cvsignore 2010/08/09 12:27:25 1.1 *.*fsl *.fasl *_[0-9][0-9][0-9][0-9]_[0-9][0-9]_[0-9][0-9].[0-9][0-9].[0-9][0-9].[0-9][0-9].* .git .gitignore --- /project/ginseng/cvsroot/ginseng/COPYRIGHT 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/COPYRIGHT 2010/08/09 12:27:25 1.1 Copyright (c) 2010, Wang ChunYe All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the Nokia Siemens Network Co.,Ltd. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--- /project/ginseng/cvsroot/ginseng/ginseng-examples.asd 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/ginseng-examples.asd 2010/08/09 12:27:25 1.1 (defpackage ginseng-examples-system (:use :common-lisp :asdf)) (in-package :ginseng-examples-system) (defsystem "ginseng-examples" :description "ginseng: examples for ginseng." :version "0.1" :author "See the file AUTHORS" :licence "See the file LICENSE" :depends-on (:ginseng) :components ((:module examples :serial t :components ((:file "package") (:file "hello-world" :depends-on ("package")) (:file "sum-of" :depends-on ("package")) (:file "index" :depends-on ("package")) (:file "app-inc-counter" :depends-on ("package")) )))) --- /project/ginseng/cvsroot/ginseng/ginseng.asd 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/ginseng.asd 2010/08/09 12:27:25 1.1 (defpackage ginseng-system (:use :common-lisp :asdf)) (in-package :ginseng-system) (defsystem "ginseng" :description "ginseng: my web framework." :version "0.1" :author "See the file AUTHORS" :licence "See the file LICENSE" :depends-on (:hunchentoot :iterate :split-sequence :yaclml) :components ((:module src :serial t :components ((:file "package") (:file "my-utils" :depends-on ("package")) (:file "dispatcher" :depends-on ("my-utils")) (:file "application" :depends-on ("my-utils")) )))) From wchunye at common-lisp.net Mon Aug 9 12:27:25 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:27:25 -0400 Subject: [ginseng-cvs] CVS ginseng/examples Message-ID: Update of /project/ginseng/cvsroot/ginseng/examples In directory cl-net:/tmp/cvs-serv29557/examples Added Files: .cvsignore app-inc-counter.lisp hello-world.lisp index.lisp package.lisp sum-of.lisp Log Message: initial version. --- /project/ginseng/cvsroot/ginseng/examples/.cvsignore 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/examples/.cvsignore 2010/08/09 12:27:25 1.1 *.wx32fsl *.fasl--- /project/ginseng/cvsroot/ginseng/examples/app-inc-counter.lisp 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/examples/app-inc-counter.lisp 2010/08/09 12:27:25 1.1 (in-package :ginseng-examples) (defun http-inc-counter(&optional (next-action nil)) (invoke-next-action next-action #'(lambda () (inc-counter-main 0)))) (defun inc-counter-main (counter) (yaclml:with-yaclml-output-to-string (<:html (<:head (<:title "Hello World")) (<:body (<:h1 "Hello" ) (<:form :action (dynamic-url (inc-counter-main (1+ counter))) (<:p (<:as-html counter)) (<:input :type "submit" :value "OK")) ;; (iter (for (k v) in-hashtable *k*) ;; (<:p (<:as-html k))) )))) (defun http-counter(&optional (next-action nil)) (invoke-next-action next-action #'(lambda () (counter-main 0)))) (defun counter-main (counter) (yaclml:with-yaclml-output-to-string (<:html (<:head (<:title "Hello World")) (<:body (<:h1 "Hello" ) (<:p (<:as-html counter)) (<:br) (<:a :href (dynamic-url (counter-main (1+ counter))) "++") (<:as-html " ") (<:a :href (dynamic-url (counter-main (1- counter))) "--") )))) (defun http-add-two-numbers (&optional (next-action nil)) (invoke-next-action next-action #'(lambda () (add-two-numbers-main)))) (defun add-two-numbers-main () (yaclml:with-yaclml-output-to-string (<:html (<:head (<:title "Add two number")) (<:body (<:h1 "Please input the first number:") (let ((cf (make-callback-factory)) (first-number 0)) (<:form :action (dynamic-url (apply-callbacks cf) (input-next-number first-number)) (<:input :type :text :name (create-callback cf #'(lambda (v) (setq first-number v)) :type 'integer)) )))))) (defun input-next-number(first-number) (yaclml:with-yaclml-output-to-string (<:html (<:head (<:title "Add two number")) (<:body (<:h1 (<:as-html "Add to " first-number "." " Please input the second number:")) (let ((cf (make-callback-factory)) (second-number 0)) (<:form :action (dynamic-url (apply-callbacks cf) (add-the-two-numbers first-number second-number)) (<:input :type :text :name (create-callback cf #'(lambda (v) (setq second-number v)) :type 'integer)) )))))) (defun add-the-two-numbers ( a b ) (yaclml:with-yaclml-output-to-string (<:html (<:head (<:title "Add two number")) (<:body (<:as-html a "+" b "=" (+ a b) ) (<:br) (<:a :href (relative-url-to-app) "try again") ))))--- /project/ginseng/cvsroot/ginseng/examples/hello-world.lisp 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/examples/hello-world.lisp 2010/08/09 12:27:25 1.1 (in-package :ginseng-examples) ;; this is the first example of using Ginseng. To create a simple ;; dynamic web page, it is nothing more than a function. ;; ;; for example, if you access ;; http://localhost:4242/cgi-bin/ginseng-examples/hello-world/arg1/arg2 ;; ;; the function "http-hello-world" in package "ginseng-examples" is ;; invoked with arguments, "arg1" and "arg2", etc. The function must ;; return a string as an HTML page. ;; ;; "/cgi-bin" is the ginseng prefix, you can change ;; ginseng::*ginseng-prefix* to change the prefix. (defun http-hello-world(&rest args) (with-yaclml-output-to-string (<:html (<:head (<:title "Hello World")) (<:body (<:h1 "Hello World") (<:p "input arguments are:" (<:ol (dolist (arg args) (<:li (<:as-html arg))) )))))) --- /project/ginseng/cvsroot/ginseng/examples/index.lisp 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/examples/index.lisp 2010/08/09 12:27:25 1.1 (in-package :ginseng-examples) (defun http-index (&rest args) (declare (ignore args)) (let* ((packages (list-all-packages)) list-of-functions) (iter (for package in packages) (iter (for s in-package package) (if (and (fboundp s) (eq (symbol-package s) package) (equal 0 (search "HTTP-" (symbol-name s)))) (push (cons package s) list-of-functions)))) (with-yaclml-output-to-string (<:html (<:head (<:title "list of apps")) (<:body (<:h1 "list of apps") (<:ol (iter (for (package . func) in list-of-functions) (let ((s (subseq (symbol-name func) (length "HTTP-")))) (<:li (<:a :href (concatenate 'string ginseng::*ginseng-prefix* "/" (package-name package) "/" s) (<:as-html (concatenate 'string (package-name package) "/" s)))))))))))) --- /project/ginseng/cvsroot/ginseng/examples/package.lisp 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/examples/package.lisp 2010/08/09 12:27:25 1.1 (in-package :cl-user) (defpackage :ginseng-examples (:use :cl :hunchentoot :iterate :yaclml :ginseng)) --- /project/ginseng/cvsroot/ginseng/examples/sum-of.lisp 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/examples/sum-of.lisp 2010/08/09 12:27:25 1.1 (in-package :ginseng-examples) (defun http-sum-of(&rest args) (with-yaclml-output-to-string (<:html (<:head (<:title "Sum of numbers")) (<:body (<:h1 "Sum of numbers") (<:p (<:as-html (format nil "~{~A~^+~}" args) "=" (apply #'+ (mapcar #'(lambda (x) (or (parse-integer x :junk-allowed t) 0)) args)))))))) From wchunye at common-lisp.net Mon Aug 9 12:27:25 2010 From: wchunye at common-lisp.net (wchunye) Date: Mon, 09 Aug 2010 08:27:25 -0400 Subject: [ginseng-cvs] CVS ginseng/src Message-ID: Update of /project/ginseng/cvsroot/ginseng/src In directory cl-net:/tmp/cvs-serv29557/src Added Files: .cvsignore application.lisp dispatcher.lisp my-utils.lisp package.lisp pattern-match.lisp Log Message: initial version. --- /project/ginseng/cvsroot/ginseng/src/.cvsignore 2010/08/09 12:27:25 NONE +++ /project/ginseng/cvsroot/ginseng/src/.cvsignore 2010/08/09 12:27:25 1.1 *.wx32fsl *.fasl--- /project/ginseng/cvsroot/ginseng/src/application.lisp 2010/08/09 12:27:26 NONE +++ /project/ginseng/cvsroot/ginseng/src/application.lisp 2010/08/09 12:27:26 1.1 (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))))) (defun relative-url-to-app (&key (prefix *ginseng-prefix*) (package (package-name *package*)) (app *ginseng-app-name*) (args)) (format nil "~{~A~^/~}" (append (list prefix package app) args))) (defun invoke-next-action (next-action &optional (main #'identity)) (let ((*k* (or (session-value 'k) (make-hash-table :test #'equal)))) (setf (session-value 'k) *k*) (funcall (gethash next-action *k* main)))) (defun get-parameter (id type &optional (method :both)) (hunchentoot::compute-parameter id type method)) (defstruct callback-factory callbacks) (defun create-callback (cf func &key (type 'string) (call-when-parameter-not-exists nil)) (let ((id (make-unique-id))) (push (if call-when-parameter-not-exists #'(lambda () (funcall func (get-parameter id type))) #'(lambda () (let ((v (get-parameter id type))) (if v (funcall func v))))) (callback-factory-callbacks cf)) id)) (defun apply-callbacks(cf) (dolist (f (callback-factory-callbacks cf)) (funcall f)))--- /project/ginseng/cvsroot/ginseng/src/dispatcher.lisp 2010/08/09 12:27:26 NONE +++ /project/ginseng/cvsroot/ginseng/src/dispatcher.lisp 2010/08/09 12:27:26 1.1 (in-package :ginseng) (defvar *last-request* nil "the last REQUEST object. it is used for debuging and testing") (defvar *ginseng-acceptor* nil "the ACCEPT object") (defvar *ginseng-prefix* "/cgi-bin" "default prefix for the framework.") (defvar *ginseng-app-name* nil) (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*))) , at body)) (defun ginseng-dispacher () (setq *last-request* *request*) (let ((script-name (script-name*)) ) (when (search *ginseng-prefix* script-name) (aprogn (subseq script-name (length *ginseng-prefix*)) (split-sequence:split-sequence #\/ it) ; split via "/" (delete "" it :test #'string=) ; delete the empty string. (let* ((list it) (package-name (nth 0 it)) (app-name (nth 1 it)) (args (nthcdr 2 list)) (package (find-package (string-upcase package-name))) (function-symbol (and package (find-symbol (string-upcase (concatenate 'string "http-" app-name)) package))) (*package* (or package *package*)) (*ginseng-app-name* app-name) ) (my-debug "access ~A" script-name) (if (fboundp function-symbol) (apply function-symbol args) (progn (my-debug "APP NOT FIND:~A" (list package-name app-name package function-symbol)) nil)) ))))) (let (prefix-dispatcher-func) (defun start-server(&key (port 4242)) (setq *ginseng-acceptor* (make-instance 'acceptor :port port)) (setq hunchentoot:*show-lisp-errors-p* t) (push (setf prefix-dispatcher-func (create-prefix-dispatcher *ginseng-prefix* 'ginseng-dispacher)) *dispatch-table*) (start *ginseng-acceptor*)) (defun stop-server() (stop *ginseng-acceptor*) (setq *dispatch-table* (remove prefix-dispatcher-func *dispatch-table*)) (setq *ginseng-acceptor* nil))) --- /project/ginseng/cvsroot/ginseng/src/my-utils.lisp 2010/08/09 12:27:26 NONE +++ /project/ginseng/cvsroot/ginseng/src/my-utils.lisp 2010/08/09 12:27:26 1.1 (in-package :ginseng) (defvar it nil) (defmacro aprogn (&rest body) `(let ((it (and (boundp 'it) it))) ,@(mapcar #'(lambda (s) `(setq it ,s)) body) it)) (defmacro awhen (test &rest body) `(let ((it (and (boundp 'it) it))) (when (setq it ,test) ,@(mapcar #'(lambda (s) `(setq it ,s)) body) it))) (let ((output *standard-output*)) (defun my-debug (&rest args) (format output "~&WCY-DEBUG:") (apply #'format output args))) (defun make-unique-id () (hunchentoot::md5-hex (hunchentoot::create-random-string 10 36)))--- /project/ginseng/cvsroot/ginseng/src/package.lisp 2010/08/09 12:27:26 NONE +++ /project/ginseng/cvsroot/ginseng/src/package.lisp 2010/08/09 12:27:26 1.1 (in-package :cl-user) (defpackage :ginseng (:use :cl :iterate) (:export :my-debug :aprogn :it :start-server :stop-server :dynamic-url :relative-url-to-app :invoke-next-action :make-callback-factory :create-callback :apply-callbacks ) (:import-from :hunchentoot :*dispatch-table* :create-prefix-dispatcher :start :stop :acceptor :script-name* :*request* :session-value :get-parameters* :post-parameters* )) --- /project/ginseng/cvsroot/ginseng/src/pattern-match.lisp 2010/08/09 12:27:26 NONE +++ /project/ginseng/cvsroot/ginseng/src/pattern-match.lisp 2010/08/09 12:27:26 1.1 (in-package :ginseng) (defun generate-code (pattern in body) (cond ((null pattern) `(if (null ,in) ,body)) ((consp pattern) (let ((next-car (gensym)) (next-cdr (gensym))) `(if (consp ,in) (let ((,next-car (car ,in)) (,next-cdr (cdr ,in))) (declare (ignorable ,next-car ,next-cdr)) ,(generate-code (car pattern) next-car (generate-code (cdr pattern) next-cdr body)))))) ((symbolp pattern) `(let ((,pattern ,in)) (declare (ignorable ,pattern)) ,body) ))) (defmacro p(pattern) (let ((input (gensym))) `#'(lambda (,input) ,(generate-code pattern input t)))) (defun match-helper (expr test-body) (if (null test-body) nil (let ((ok (gensym)) (v (gensym)) (tmp-args (gensym))) `(multiple-value-bind (,ok ,v) (funcall #'(lambda (,tmp-args) ,(generate-code (caar test-body) tmp-args (append (list 'values t) (cdar test-body)))) ,expr) (if ,ok ,v ,(match-helper expr (cdr test-body))))))) (defmacro match (expr test-body) (let ((expr-v (gensym))) `(let ((,expr-v ,expr)) ,(match-helper expr-v test-body)))) From wchunye at common-lisp.net Wed Aug 11 12:02:31 2010 From: wchunye at common-lisp.net (wchunye) Date: Wed, 11 Aug 2010 08:02:31 -0400 Subject: [ginseng-cvs] CVS ginseng Message-ID: Update of /project/ginseng/cvsroot/ginseng In directory cl-net:/tmp/cvs-serv8814 Modified Files: ginseng.asd Log Message: support env-var. --- /project/ginseng/cvsroot/ginseng/ginseng.asd 2010/08/09 12:27:25 1.1 +++ /project/ginseng/cvsroot/ginseng/ginseng.asd 2010/08/11 12:02:30 1.2 @@ -9,7 +9,9 @@ :depends-on (:hunchentoot :iterate :split-sequence - :yaclml) + :yaclml + :alexandria ;; copy-hash-table + ) :components ((:module src :serial t From wchunye at common-lisp.net Wed Aug 11 12:02:36 2010 From: wchunye at common-lisp.net (wchunye) Date: Wed, 11 Aug 2010 08:02:36 -0400 Subject: [ginseng-cvs] CVS ginseng/examples Message-ID: Update of /project/ginseng/cvsroot/ginseng/examples In directory cl-net:/tmp/cvs-serv8814/examples Modified Files: app-inc-counter.lisp hello-world.lisp Log Message: support env-var. --- /project/ginseng/cvsroot/ginseng/examples/app-inc-counter.lisp 2010/08/09 12:27:25 1.1 +++ /project/ginseng/cvsroot/ginseng/examples/app-inc-counter.lisp 2010/08/11 12:02:36 1.2 @@ -1,6 +1,6 @@ (in-package :ginseng-examples) (defun http-inc-counter(&optional (next-action nil)) - (invoke-next-action next-action #'(lambda () (inc-counter-main 0)))) + (invoke-next-action next-action :main #'(lambda () (inc-counter-main 0)))) (defun inc-counter-main (counter) (yaclml:with-yaclml-output-to-string (<:html @@ -16,7 +16,7 @@ )))) (defun http-counter(&optional (next-action nil)) - (invoke-next-action next-action #'(lambda () (counter-main 0)))) + (invoke-next-action next-action :main #'(lambda () (counter-main 0)))) (defun counter-main (counter) (yaclml:with-yaclml-output-to-string (<:html @@ -33,7 +33,7 @@ (defun http-add-two-numbers (&optional (next-action nil)) - (invoke-next-action next-action #'(lambda () (add-two-numbers-main)))) + (invoke-next-action next-action :main #'(lambda () (add-two-numbers-main)))) (defun add-two-numbers-main () (yaclml:with-yaclml-output-to-string (<:html --- /project/ginseng/cvsroot/ginseng/examples/hello-world.lisp 2010/08/09 12:27:25 1.1 +++ /project/ginseng/cvsroot/ginseng/examples/hello-world.lisp 2010/08/11 12:02:36 1.2 @@ -14,15 +14,22 @@ ;; ginseng::*ginseng-prefix* to change the prefix. (defun http-hello-world(&rest args) + (declare (ignore args)) (with-yaclml-output-to-string (<:html (<:head (<:title "Hello World")) (<:body - (<:h1 "Hello World") + (<:h1 "Hello World"))))) +(defun http-show-args(&rest args) + (with-yaclml-output-to-string + (<:html + (<:head + (<:title "Your input arguments")) + (<:body + (<:h1 "Your input arguments:") (<:p - "input arguments are:" (<:ol (dolist (arg args) (<:li (<:as-html arg))) - )))))) + )))))) \ No newline at end of file From wchunye at common-lisp.net Wed Aug 11 12:02:41 2010 From: wchunye at common-lisp.net (wchunye) Date: Wed, 11 Aug 2010 08:02:41 -0400 Subject: [ginseng-cvs] CVS ginseng/src Message-ID: 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*