[ganelon-cvs] CVS update: ganelon/lisp/ganelon.asd ganelon/lisp/html.lisp ganelon/lisp/mvc.lisp ganelon/lisp/utils.lisp ganelon/lisp/compile.lisp
Tomek Lipski
tlipski at common-lisp.net
Mon Mar 8 23:21:47 UTC 2004
Update of /project/ganelon/cvsroot/ganelon/lisp
In directory common-lisp.net:/tmp/cvs-serv20334/lisp
Modified Files:
ganelon.asd html.lisp mvc.lisp utils.lisp
Removed Files:
compile.lisp
Log Message:
Bugfixes + formatting
Date: Mon Mar 8 18:21:46 2004
Author: tlipski
Index: ganelon/lisp/ganelon.asd
diff -u ganelon/lisp/ganelon.asd:1.1.1.1 ganelon/lisp/ganelon.asd:1.2
--- ganelon/lisp/ganelon.asd:1.1.1.1 Wed Mar 3 18:50:36 2004
+++ ganelon/lisp/ganelon.asd Mon Mar 8 18:21:46 2004
@@ -1,5 +1,17 @@
+;
+; $Id: ganelon.asd,v 1.2 2004/03/08 23:21:46 tlipski Exp $
+;
(asdf:defsystem "ganelon"
:version "0.1"
:components ((:file "utils")
(:file "mvc" :depends-on ("utils"))
(:file "html" :depends-on ("utils"))))
+
+
+;
+; $Log: ganelon.asd,v $
+; Revision 1.2 2004/03/08 23:21:46 tlipski
+;
+; Bugfixes + formatting
+;
+;
Index: ganelon/lisp/html.lisp
diff -u ganelon/lisp/html.lisp:1.1.1.1 ganelon/lisp/html.lisp:1.2
--- ganelon/lisp/html.lisp:1.1.1.1 Wed Mar 3 18:50:35 2004
+++ ganelon/lisp/html.lisp Mon Mar 8 18:21:46 2004
@@ -1,24 +1,27 @@
;;;;
;; package extending standard allegroserve html tags with support
;; for ganelon.mvc forms
+;
+; $Id: html.lisp,v 1.2 2004/03/08 23:21:46 tlipski Exp $
+;
;;;;
(defpackage "GANELON.HTML"
(:use
- #:COMMON-LISP
- #:NET.HTML.GENERATOR
- #:GANELON.UTILS
- )
+ #:COMMON-LISP
+ #:NET.HTML.GENERATOR
+ #:GANELON.UTILS
+ )
(:export
- #:mvc-bean
- #:mvc-bean-value
- #:mvc-form
- #:mvc-input
- #:mvc-select
- #:mvc-option
- #:mvc-radio
- #:mvc-checkbox
- #:mvc-textarea
- )
+ #:mvc-bean
+ #:mvc-bean-value
+ #:mvc-form
+ #:mvc-input
+ #:mvc-select
+ #:mvc-option
+ #:mvc-radio
+ #:mvc-checkbox
+ #:mvc-textarea
+ )
)
(in-package :GANELON.HTML)
@@ -27,130 +30,127 @@
;;form
(defmacro mvc-form (name action params &rest body)
"Generates and sets form (in variable named mvc-form, be careful!)
- for use by other controls."
+ for use by other controls."
`(let ((mvc-form (ganelon.mvc:get-form ,name
- ganelon.mvc:req
- ganelon.mvc:ent
- ganelon.mvc:context
- ganelon.mvc:session)))
- (make-tag "form"
- ,body
- ,params
- (cons "name" ,name)
- (cons "action" (ganelon.mvc:get-action-url
- ganelon.mvc:project ,action))))
+ ganelon.mvc:context
+ ganelon.mvc:session)))
+ (make-tag "form"
+ ,body
+ ,params
+ (cons "name" ,name)
+ (cons "action" (ganelon.mvc:get-action-url
+ ganelon.mvc:project ,action))))
)
;;input with value
-(defmacro mvc-input (name params
- &key (value nil))
-"HTML input of default type text"
+(defmacro mvc-input (name params &key (value nil))
+ "HTML input of default type text"
`(make-tag "input"
- nil
- ,params
- (cons "name" ,name)
- (cons "value"
- (control-value ,name ,value)))
+ nil
+ ,params
+ (cons "name" ,name)
+ (cons "value"
+ (control-value ,name ,value)))
)
(defmacro mvc-radio (name value &optional params)
`(make-tag "input"
- nil
- ,params
- (cons "name" ,name)
- (cons "value" ,value)
- (cons "type" "radio")
- (if (equal ,value (control-value ,name nil))
- (cons "checked" "1")))
-)
+ nil
+ ,params
+ (cons "name" ,name)
+ (cons "value" ,value)
+ (cons "type" "radio")
+ (if (equal ,value (control-value ,name nil))
+ (cons "checked" "1")))
+ )
(defmacro mvc-checkbox (name value &optional params)
`(make-tag "input"
- nil
- ,params
- (cons "name" ,name)
- (cons "value" ,value)
- (cons "type" "checkbox")
- (if (equal ,value (control-value ,name nil))
- (cons "checked" "1")))
+ nil
+ ,params
+ (cons "name" ,name)
+ (cons "value" ,value)
+ (cons "type" "checkbox")
+ (if (equal ,value (control-value ,name nil))
+ (cons "checked" "1")))
)
(defmacro mvc-select (name value params &rest body)
`(let ((select-value (control-value ,name ,value)))
- (make-tag "select"
- ,body
- ,params
- (cons "name" ,name)
- )
- )
-)
+ (make-tag "select"
+ ,body
+ ,params
+ (cons "name" ,name)
+ )
+ )
+ )
(defmacro mvc-option (value params &rest body)
`(make-tag "option"
- ,body
- ,params
- (cons "value" ,value)
- (if (equal ,value select-value)
- (cons "selected" "1")))
-
+ ,body
+ ,params
+ (cons "value" ,value)
+ (if (equal ,value select-value)
+ (cons "selected" "1")))
+
)
(defmacro mvc-textarea (name &optional value params)
`(make-tag "textarea"
- '(net.html.generator:html
- (:princ (control-value ,name ,value)))
- ,params)
-)
-
+ '(net.html.generator:html
+ (:princ (control-value ,name ,value)))
+ ,params)
+ )
+
(defmacro mvc-bean (property-path &optional context-type)
`(mvc-bean-value
- (case ,context-type
- (:session (ganelon.mvc:session-fields ganelon.mvc:session))
- (:context ganelon.mvc:context)
- (T (if (gethash (car ,property-path)
- (ganelon.mvc:session-fields ganelon.mvc:session))
- (ganelon.mvc:session-fields ganelon.mvc:session)
- ganelon.mvc:context)))
- ,property-path
- (ganelon.mvc::project-package ganelon.mvc:project))
-)
+ (case ,context-type
+ (:session (ganelon.mvc:session-fields ganelon.mvc:session))
+ (:context ganelon.mvc:context)
+ (T (if (gethash (car ,property-path)
+ (ganelon.mvc:session-fields ganelon.mvc:session))
+ (ganelon.mvc:session-fields ganelon.mvc:session)
+ ganelon.mvc:context)))
+ ,property-path
+ (ganelon.mvc::project-package ganelon.mvc:project))
+ )
(defun mvc-bean-value (bean property-path package)
;;find a form or hashtable in session/request context
(and bean (car property-path)
- (get-property bean (car property-path) package)
- (if (cdr property-path)
- (mvc-bean-value (get-property
- bean (car property-path) package)
- (cdr property-path)
- package)
- (get-property bean (car property-path) package)))
+ (get-property bean (car property-path) package)
+ (if (cdr property-path)
+ (mvc-bean-value (get-property
+ bean (car property-path) package)
+ (cdr property-path)
+ package)
+ (get-property bean (car property-path) package)))
)
(defun tag-params (params)
(if params
- (format nil "~A=\"~A\" ~A" (caar params) (cdar params)
- (tag-params (cdr params)))
- "")
+ (format nil "~A=\"~A\" ~A" (caar params) (cdar params)
+ (tag-params (cdr params)))
+ "")
)
(defmacro make-tag (name body params &rest addparams)
`(progn
- (net.html.generator:html
- (:princ
- (format nil
- "<~A ~A>" ,name
- (tag-params
- (nconc
- (list , at addparams)
- ,params))
- )))
- , at body
- (net.html.generator:html
- (:princ
- (format nil "</~A>" ,name)))
- )
+ (net.html.generator:html
+ (:princ
+ (format nil
+ "<~A ~A>" ,name
+ (tag-params
+ (nconc
+ (list , at addparams)
+ ,params))
+ )))
+ , at body
+ (net.html.generator:html
+ (:princ
+ (format nil "</~A>" ,name)))
+ )
)
-
+
(defmacro control-value (name &optional value)
`(if mvc-form
(or ,value
@@ -160,3 +160,11 @@
(or ,value ""))
)
+
+;
+; $Log: html.lisp,v $
+; Revision 1.2 2004/03/08 23:21:46 tlipski
+;
+; Bugfixes + formatting
+;
+;
Index: ganelon/lisp/mvc.lisp
diff -u ganelon/lisp/mvc.lisp:1.1.1.1 ganelon/lisp/mvc.lisp:1.2
--- ganelon/lisp/mvc.lisp:1.1.1.1 Wed Mar 3 18:50:35 2004
+++ ganelon/lisp/mvc.lisp Mon Mar 8 18:21:46 2004
@@ -1,46 +1,53 @@
;;;; Mvc library for web apps under PAserve
+;
+; $Id: mvc.lisp,v 1.2 2004/03/08 23:21:46 tlipski Exp $
+;
(defpackage "GANELON.MVC"
(:use
#:COMMON-LISP
- #:NET.ASERVE
- #:GANELON.UTILS
- )
+ #:NET.ASERVE
+ #:GANELON.UTILS
+ )
(:export
- #:action
- #:page
- #:form
- #:init-project
- #:add-project-entry
- #:remove-project-entry
- #:make-action
- #:make-form
- #:make-page
- #:get-action-url
- #:get-form
- #:ent
- #:context
- #:session
- #:project
- #:req
- #:session-fields
- #:project-package
- ))
+ #:action
+ #:page
+ #:form
+ #:init-project
+ #:add-project-entry
+ #:remove-project-entry
+ #:make-action
+ #:make-form
+ #:make-page
+ #:get-action-url
+ #:get-form
+ #:ent
+ #:context
+ #:session
+ #:project
+ #:req
+ #:session-fields
+ #:project-package
+ ))
(in-package :GANELON.MVC)
+(defvar *SESSSION-REAPER* nil)
+(defvar *ALL-SESSIONS* (make-hash-table))
+
(defstruct entry
name
path)
(defstruct (action
- (:include entry))
+ (:include entry))
function
form-struct)
(defstruct (page
- (:include entry))
- filepath)
+ (:include entry))
+ filepath
+ charset)
(defstruct session
fields
@@ -50,7 +57,7 @@
name
maker
(scope :context)) ;; :context or :session
-
+
(defstruct project
name
path
@@ -59,324 +66,344 @@
page-functions
sessions
mappings
- session-timeout)
+ session-timeout
+ path-prefix
+ lsp-default-charset)
;;;start a project
-(defun init-project (name path entries package &key (session-timeout 30))
+(defun init-project (name path entries package &key (session-timeout 30)
+ (path-prefix "") (lsp-default-charset))
(let ((proj (make-project :name name :path path :entries nil
- :page-functions (make-hash-table :test #'equal)
- :sessions (make-hash-table :test #'equal)
- :mappings (make-hash-table :test #'equal)
- :package package
- :session-timeout session-timeout)))
- (dolist (entry entries)
- (add-project-entry proj entry))
- (acl-compat.mp:process-run-function "Session reaper"
- nil
- 'session-reaper
- (project-sessions proj))
- proj)
- )
+ :page-functions (make-hash-table :test #'equal)
+ :sessions (make-hash-table :test #'equal)
+ :mappings (make-hash-table :test #'equal)
+ :package package
+ :session-timeout session-timeout
+ :path-prefix path-prefix
+ :lsp-default-charset lsp-default-charset)))
+ (dolist (entry entries)
+ (add-project-entry proj entry))
+ (add-sessions-to-rip (project-sessions proj)
+ name)
+ proj))
+
+(defun add-sessions-to-rip (sessions project-name)
+ "Add project's sessions container to ripping process"
+ (if (null *SESSSION-REAPER*)
+ (start-reaper))
+ (setf (gethash project-name *ALL-SESSIONS*)
+ sessions))
+
+(defun start-reaper ()
+ "Start the session reaper process"
+ (acl-compat.mp:process-run-function "Session reaper" 'session-reaper)
+ (setq *SESSSION-REAPER* T))
;;add new entry to project
(defun add-project-entry (proj entry)
+ (if (page-p entry)
+ (setf (page-filepath entry)
+ (concatenate 'string (project-path-prefix proj)
+ (page-filepath entry))))
(setf (project-entries proj)
- (cons entry (project-entries proj)))
- (setf (gethash (entry-name entry) (project-mappings proj))
- entry)
- (publish
- :path (concatenate 'string
- (project-path proj)
- "/"
- (entry-path entry))
- :function
- #'(lambda (req ent)
- (route-entry
- req
- ent
- (make-hash-table :test #'equal)
- proj
- (entry-name entry)
- (get-session req proj))))
- )
+ (cons entry (project-entries proj)))
+ (setf (gethash (entry-name entry) (project-mappings proj))
+ entry)
+ (publish
+ :path (concatenate 'string (project-path proj) "/" (entry-path entry))
+ :function #'(lambda (req ent)
+ (route-entry req ent (make-hash-table :test #'equal) proj
+ (entry-name entry)
+ (get-session req proj)))))
(defun remove-project-entry (project name)
(setf (project-entries project)
- (remove-if #'(lambda(x)
- (eq (entry-name x) name))
- (project-entries project)))
-)
+ (remove-if #'(lambda(x)
+ (eq (entry-name x) name))
+ (project-entries project)))
+ )
;;;route entries
(defun route-entry (req ent context project name session)
(let ((entry (gethash name (project-mappings project))))
- (if (not entry)
- (maphash #'(lambda (k v)
- (format t "~A: ~A~%" k v))
- (project-mappings project)))
- (if (action-p entry)
- (serve-action req ent context project entry session))
- (if (page-p entry)
- (serve-page req ent context project entry session)))
+ (if (not entry)
+ (maphash #'(lambda (k v)
+ (format t "~A: ~A~%" k v))
+ (project-mappings project)))
+ (if (action-p entry)
+ (serve-action req ent context project entry session))
+ (if (page-p entry)
+ (serve-page req ent context project entry session)))
)
;;;serve action, routing the chain to another action or page
(defun serve-action (req ent context project action session)
(route-entry req ent context project
- (funcall (action-function action)
- req
- ent
- context
- session
- (get-action-form
- action
- context
- session
- project
- req))
- session)
+ (funcall (action-function action)
+ req
+ ent
+ context
+ session
+ (get-action-form
+ action
+ context
+ session
+ project
+ req))
+ session)
)
;;;serve page, returning the output to client
(defun serve-page (req ent context project page session)
(with-http-response (req ent)
- (setf (reply-header-slot-value req :CONTENT-TYPE)
- "text/html; charset=iso-8859-2")
- (let ((page-func (gethash (page-filepath page)
- (project-page-functions project))))
- (funcall (car
- (if (and page-func
- (> (cdr page-func) (or (file-write-date
- (page-filepath page)) 0)))
- page-func
- (setf (gethash (page-filepath page)
- (project-page-functions project))
- (cons (page-function-from-file (page-filepath page)
- (project-package project))
- (get-universal-time)))))
- req ent context session project)
- )
- )
+ (if (or (page-charset page)
+ (project-lsp-default-charset project))
+ (setf (reply-header-slot-value req :CONTENT-TYPE)
+ (concatenate 'string
+ "text/html; charset="
+ (or (page-charset page)
+ (project-lsp-default-charset
+ project)))))
+ (let ((page-func (gethash (page-filepath page)
+ (project-page-functions project))))
+ (funcall (car
+ (if (and page-func
+ (> (cdr page-func)
+ (or (file-write-date (page-filepath page)) 0)))
+ page-func
+ (setf (gethash (page-filepath page)
+ (project-page-functions project))
+ (cons (page-function-from-file (page-filepath page)
+ (project-package project))
+ (get-universal-time)))))
+ req ent context session project)
+ )
+ )
)
(defun page-function-from-file (filename package)
- (format t "page-function-from-file ~A ~%" filename)
- (format t "package ~A~%" *package*)
(in-package (symb package))
- (format t "package ~A~%" *package*)
- (format t
- "(progn ~A)~%"
- (construct-page-func-string
- (contents-of-file filename)))
(compile nil
- `(lambda (req ent context session project)
- (net.aserve:with-http-body (req ent)
- ,(read-from-string
- (format nil
- "(progn ~A)"
- (construct-page-func-string
- (contents-of-file filename)))))))
+ `(lambda (req ent context session project)
+ (net.aserve:with-http-body (req ent)
+ ,(read-from-string
+ (format nil
+ "(progn ~A)"
+ (construct-page-func-string
+ (contents-of-file filename)))))))
)
(defun construct-page-func-string (str &optional (start 0))
"Text up until <% tag is translated into (net.html.generator:html 'text')
- Text inside <% %> is translated to code or expanded as a directive"
-
+ Text inside <% %> is translated to code or expanded as a directive"
+
(multiple-value-bind (tagpos scriptpos endpos type)
- (find-script str start)
- (if (not tagpos) ;;No scriplets, simply format to html macro
- (format nil "(net.html.generator:html ~S)"
- (subseq str start))
- ;;found a scriplet, decide on type
- (format nil (if (> tagpos start)
- "(net.html.generator:html ~S) ~A ~A"
- "~A ~A")
- (subseq str start tagpos)
- (tag-expand type (subseq str scriptpos endpos))
- (construct-page-func-string str (+ endpos 2)))))
-)
+ (find-script str start)
+ (if (not tagpos) ;;No scriplets, simply format to html macro
+ (format nil "(net.html.generator:html ~S)"
+ (subseq str start))
+ ;;found a scriplet, decide on type
+ (format nil (if (> tagpos start)
+ "(net.html.generator:html ~S) ~A ~A"
+ "~A ~A")
+ (subseq str start tagpos)
+ (tag-expand type (subseq str scriptpos endpos))
+ (construct-page-func-string str (+ endpos 2)))))
+ )
(defun tag-expand (type body)
(case type
- (:script (format nil "~A" body))
- (:expr (format nil "(net.html.generator:html (:princ ~A))" body))
- (:directive (expand-directive body)))
+ (:script (format nil "~A" body))
+ (:expr (format nil "(net.html.generator:html (:princ ~A))" body))
+ (:directive (expand-directive body)))
)
(defun expand-directive (body)
(format t "expand-directive~%")
(format t "~A~%" (construct-page-func-string
- (funcall (compile nil `(lambda ()
- ,(read-from-string
- (format nil "(progn ~A)~%" body)))))))
+ (funcall (compile nil `(lambda ()
+ ,(read-from-string
+ (format nil "(progn ~A)~%" body)))))))
(construct-page-func-string
- (funcall
- (compile nil `(lambda ()
- ,(read-from-string
- (format nil "(progn ~A)~%" body))))))
+ (funcall
+ (compile nil `(lambda ()
+ ,(read-from-string
+ (format nil "(progn ~A)~%" body))))))
)
(defun find-script (str start)
(let ((startpos (search "<%" str :start2 start)))
- (if startpos
- (let ((endpos (search "%>" str :start2 (+ start 2))))
- (if endpos
- (case (char str (+ startpos 2))
- (#\=
- (values startpos (+ startpos 3)
- endpos :expr))
- (#\@
- (values startpos (+ startpos 3)
- endpos :directive))
- (t
- (values startpos (+ startpos 2)
- endpos :script)))
- (error "EOF inside open '<%'.")
- )
- )
- (values nil nil nil nil)))
+ (if startpos
+ (let ((endpos (search "%>" str :start2 (+ start 2))))
+ (if endpos
+ (case (char str (+ startpos 2))
+ (#\=
+ (values startpos (+ startpos 3)
+ endpos :expr))
+ (#\@
+ (values startpos (+ startpos 3)
+ endpos :directive))
+ (t
+ (values startpos (+ startpos 2)
+ endpos :script)))
+ (error "EOF inside open '<%'.")
+ )
+ )
+ (values nil nil nil nil)))
)
;;;get session from request and session-container
;;;if session does not exist, it creates one (side-effect)
(defun get-session (req project)
(let* ((session-container (project-sessions project))
- (sessid
- (cdr (find-if #'(lambda(x)
- (if (equal (format nil "~A" (car x)) "SESSID")
- x ))
- (get-cookie-values req)))))
- (if (not sessid)
- (setq sessid (make-sessid session-container)))
- (let ((sess (gethash sessid session-container)))
- (if sess
- (if (<= (get-universal-time) (session-expires sess))
- (setf (session-expires sess)
- (+ (get-universal-time)
- (* 60 (project-session-timeout project))))
- (progn
- (setq sessid (make-sessid session-container))
- (setq sess nil))))
-
- (if (not sess)
- (progn
- (setq sess (make-session
- :fields (make-hash-table :test #'equal)
- :expires (+ (get-universal-time)
- (* 60 (project-session-timeout project)))))
- (setf (gethash sessid session-container) sess)))
- (set-cookie-header req
- :name "SESSID"
- :value sessid)
- sess))
- )
-
-(defun session-reaper (session-container)
- (let ((curr-time (get-universal-time)))
- (maphash #'(lambda (sessid sess)
- (if (> curr-time (session-expires sess))
- (remhash sessid (session-container))))
- session-container))
+ (sessid
+ (cdr (find-if #'(lambda(x)
+ (if (equal (format nil "~A" (car x)) "SESSID")
+ x ))
+ (get-cookie-values req)))))
+ (if (not sessid)
+ (setq sessid (make-sessid session-container)))
+ (let ((sess (gethash sessid session-container)))
+ (if sess
+ (if (<= (get-universal-time) (session-expires sess))
+ (setf (session-expires sess)
+ (+ (get-universal-time)
+ (* 60 (project-session-timeout project))))
+ (progn
+ (setq sessid (make-sessid session-container))
+ (setq sess nil))))
+
+ (if (not sess)
+ (progn
+ (setq sess (make-session
+ :fields (make-hash-table :test #'equal)
+ :expires (+ (get-universal-time)
+ (* 60 (project-session-timeout project)))))
+ (setf (gethash sessid session-container) sess)))
+ (set-cookie-header req
+ :name "SESSID"
+ :value sessid)
+ sess))
+ )
+
+(defun session-reaper ()
+ (maphash #'(lambda (k v)
+ (sessions-reap v))
+ *ALL-SESSIONS*)
(sleep 30)
+ (session-reaper))
- (sesseion-reaper project)
- )
+(defun sessions-reap (session-container)
+ (let ((curr-time (get-universal-time)))
+ (maphash #'(lambda (sessid sess)
+ (if (> curr-time (session-expires sess))
+ (remhash sessid session-container)))
+ session-container)))
;;;create unique session id
(defun make-sessid (session-container)
(format t "make-sessid~%")
(let ((sessid (format nil "~X" (random 999999999))))
- (if (gethash sessid session-container)
- (make-sessid session-container)
- sessid)
- )
-)
+ (if (gethash sessid session-container)
+ (make-sessid session-container)
+ sessid)
+ )
+ )
;;;fill structure from query data
(defun make-form-struct (query form project)
(format t "make-form-struct")
(let ((struct (funcall (form-maker form))))
- (format t "made-form-struct")
- (update-form-struct query struct project)
+ (format t "made-form-struct")
+ (update-form-struct query struct project)
+ )
)
-)
(defun update-form-struct (query struct project)
(format t "update-form-struct ~%")
(let ((pack (project-package project)))
-
- (dolist (param query)
- (format t "~A: ~A~%" (car param) (cdr param))
- (if (slot-exists-p struct (symb2 pack (car param)))
- (setf (slot-value struct (symb2 pack (car param))) (cdr param))
- (format t "Nie ma slotu ~A ~A~%" (car param) struct)))
- struct
- )
+
+ (dolist (param query)
+ (format t "~A: ~A~%" (car param) (cdr param))
+ (if (slot-exists-p struct (symb2 pack (car param)))
+ (setf (slot-value struct (symb2 pack (car param))) (cdr param))
+ (format t "Nie ma slotu ~A ~A~%" (car param) struct)))
+ struct
+ )
)
+
+(defmacro sess-value (session name)
+ `(gethash ,name (session-fields ,session))
+ )
+
;;;read form from request, context, session
(defun fetch-form (form cont sess req project)
(format t "fetch-form ~%")
(let* ((form-name (form-name form))
- (sess-form (sess-value sess form-name))
- (cont-form (gethash form-name cont)))
- (format t "~A ~A ~A ~%" form-name sess-form cont-form)
- (if cont-form
- cont-form
- (setf (gethash form-name cont)
- (if sess-form
- (update-form-struct (request-query req)
- sess-form
- project)
- (make-form-struct (request-query req)
- form
- project))))
- )
+ (sess-form (sess-value sess form-name))
+ (cont-form (gethash form-name cont)))
+ (format t "~A ~A ~A ~%" form-name sess-form cont-form)
+ (if cont-form
+ cont-form
+ (setf (gethash form-name cont)
+ (if sess-form
+ (update-form-struct (request-query req)
+ sess-form
+ project)
+ (make-form-struct (request-query req)
+ form
+ project))))
+ )
)
+
;;;update session forms
(defun update-session-form (form form-data session)
(format t "update-session-form ~A ~%" (form-scope form))
(if (equal (form-scope form) :session)
- (setf (sess-value session (form-name form))
- form-data))
+ (setf (sess-value session (form-name form))
+ form-data))
form-data
- )
+ )
(defun get-action-form (action cont sess project req)
(format t "get-action-form ~%")
(if (action-form-struct action)
- (update-session-form (action-form-struct action)
- (fetch-form (action-form-struct action)
- cont
- sess
- req
- project
- )
- sess)
- nil
- )
-)
+ (update-session-form (action-form-struct action)
+ (fetch-form (action-form-struct action)
+ cont
+ sess
+ req
+ project
+ )
+ sess)
+ nil
+ )
+ )
(defun get-action-url (project action-name)
(let ((action (gethash action-name (project-mappings project))))
- (if action
- (strconc (project-path project) "/" (action-path action))
- (strconc "#No action named: '" action-name "'!!!")
- ))
-)
+ (if action
+ (strconc (project-path project) "/" (action-path action))
+ (strconc "#No action named: '" action-name "'!!!")
+ ))
+ )
;;get form by name
-(defun get-form (form-name req ent cont session)
+(defun get-form (form-name cont session)
(let ((form (gethash form-name cont)))
- (if form
- form
- (sess-value session form-name)))
+ (if form form
+ (sess-value session form-name)))
)
-(defmacro sess-value (session name)
- `(gethash ,name (session-fields ,session))
- )
+;
+; $Log: mvc.lisp,v $
+; Revision 1.2 2004/03/08 23:21:46 tlipski
+;
+; Bugfixes + formatting
+;
+;
Index: ganelon/lisp/utils.lisp
diff -u ganelon/lisp/utils.lisp:1.1.1.1 ganelon/lisp/utils.lisp:1.2
--- ganelon/lisp/utils.lisp:1.1.1.1 Wed Mar 3 18:50:36 2004
+++ ganelon/lisp/utils.lisp Mon Mar 8 18:21:46 2004
@@ -1,3 +1,7 @@
+;
+; $Id: utils.lisp,v 1.2 2004/03/08 23:21:46 tlipski Exp $
+;
+
(defpackage "GANELON.UTILS"
(:export
#:get-struct-value
@@ -24,15 +28,14 @@
)
(in-package :GANELON.UTILS)
-(defun get-struct-value (form name)
- (slot-value form (symb name))
- )
-
;;;translate string into symbol
(defmacro symb (&rest args)
`(values (intern (string-upcase
(concatenate 'string , at args))))
)
+(defun get-struct-value (form name)
+ (slot-value form (symb name))
+ )
(defmacro symb2 (package &rest args)
`(values (intern (string-upcase
@@ -199,3 +202,11 @@
(setf (nth idx list)
(funcall fun (nth idx list)))
)
+
+;
+; $Log: utils.lisp,v $
+; Revision 1.2 2004/03/08 23:21:46 tlipski
+;
+; Bugfixes + formatting
+;
+;
More information about the Ganelon-cvs
mailing list