30 May '08
Author: achiumenti
Date: Fri May 30 06:03:00 2008
New Revision: 49
Modified:
trunk/main/claw-core/src/components.lisp
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/src/translators.lisp
trunk/main/claw-core/src/validators.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
a lot of bug fixes, plus adding of checkbox and radio components
Modified: trunk/main/claw-core/src/components.lisp
==============================================================================
--- trunk/main/claw-core/src/components.lisp (original)
+++ trunk/main/claw-core/src/components.lisp Fri May 30 06:03:00 2008
@@ -41,9 +41,33 @@
(defgeneric translator-encode (translator wcomponent)
(:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))
+(defgeneric translator-type-to-string (translator wcomponent)
+ (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-encode"))
+
(defgeneric translator-decode (translator wcomponent)
(:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))
+(defgeneric translator-string-to-type (translator wcomponent)
+ (:documentation "Decodes the input component value after a form submit (Decodes from string to type). It's a wrapper for translator-decode"))
+
+(defgeneric translator-value-encode (translator value)
+ (:documentation "Encodes the value, used when rendering the component (Encodes from type to string)."))
+
+(defgeneric translator-value-type-to-string (translator value)
+ (:documentation "Encodes the value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-value-encode"))
+
+(defgeneric translator-value-decode (translator value &optional client-id label)
+ (:documentation "Decodes value after a form submit (Decodes from string to type)."))
+
+(defgeneric translator-value-string-to-type (translator value &optional client-id label)
+ (:documentation "Decodes value after a form submit (Decodes from string to type). It's a wrapper for translator-value-decode"))
+
+(defgeneric label (cinput)
+ (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled"))
+
+(defgeneric name-attr (cinput)
+ (:documentation "Returns the name of the input component"))
+
(defclass translator ()
()
(:documentation "a translator object encodes and decodes values passed to a html input component"))
@@ -55,10 +79,12 @@
(defun component-validation-errors (component &optional (request *request*))
"Resurns possible validation errors occurred during form rewinding bound to a specific component"
(let ((client-id (htcomponent-client-id component)))
- (getf (validation-errors request) (make-symbol client-id))))
+ (getf (validation-errors request) (intern client-id))))
;--------------------------------------------------------------------------------
+
+
(defclass cform (wcomponent)
((action :initarg :action
:accessor action
@@ -94,7 +120,6 @@
(setf class "error")
(setf class (format nil "~a error" class))))
(form> :static-id client-id
- :name client-id
:class class
(wcomponent-informal-parameters cform)
(input> :name *rewind-parameter*
@@ -154,8 +179,7 @@
(accessor :initarg :accessor
:reader cinput-accessor
:documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters")
- (label :initarg :label
- :reader label
+ (label :initarg :label
:documentation "The label is the description of the component. It's also be used when component validation fails.")
(translator :initarg :translator
:reader translator
@@ -173,6 +197,15 @@
:label nil :translator *simple-translator* :validator nil :visit-object nil)
(:documentation "Class inherited from both CINPUT and CSELECT"))
+(defmethod label ((cinput base-cinput))
+ (let ((label (slot-value cinput 'label)))
+ (if (functionp label)
+ (funcall label)
+ label)))
+
+(defmethod name-attr ((cinput base-cinput))
+ (htcomponent-client-id cinput))
+
(defclass cinput (base-cinput)
((input-type :initarg :type
:reader input-type
@@ -204,7 +237,7 @@
(setf value (translator-encode translator cinput))
(input> :static-id client-id
:type type
- :name client-id
+ :name (name-attr cinput)
:class class
:value value
(wcomponent-informal-parameters cinput))))
@@ -233,7 +266,7 @@
(setf value
(cond
(from-request-p (page-req-parameter (htcomponent-page cinput)
- client-id
+ (name-attr cinput)
result-as-list-p))
((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
(t (funcall (fdefinition reader) visit-object))))
@@ -260,12 +293,15 @@
(describe-html-attributes-from-class-slot-initargs class)
(describe-component-behaviour class))))
+(defmethod name-attr ((csubmit csubmit))
+ (htcomponent-client-id csubmit))
+
(defmethod wcomponent-template ((obj csubmit))
(let ((client-id (htcomponent-client-id obj))
(value (csubmit-value obj)))
(input> :static-id client-id
:type "submit"
- :name client-id
+ :name (name-attr obj)
:value value
(wcomponent-informal-parameters obj))))
@@ -300,7 +336,7 @@
(input> :static-id submit-id
:style "display:none;"
:type "submit"
- :name id
+ :name (name-attr obj)
:value "-")
(a> :static-id id
:href (format nil "javascript:document.getElementById('~a').click();" submit-id)
@@ -332,12 +368,135 @@
(setf class "error")
(setf class (format nil "~a error" class))))
(select> :static-id client-id
- :name client-id
+ :name (name-attr obj)
:class class
:multiple (cinput-result-as-list-p obj)
(wcomponent-informal-parameters obj)
(htcomponent-body obj))))
+;--------------------------------------------------------------------------------------------
+(defclass ccheckbox (cinput)
+ ((test :initarg :test
+ :accessor ccheckbox-test)
+ (value :initarg :value
+ :accessor ccheckbox-value))
+ (:metaclass metacomponent)
+ (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal)
+ (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+(let ((class (find-class 'ccheckbox)))
+ (closer-mop:ensure-finalized class)
+ (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+ (format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a"
+ "Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"."
+ *id-and-static-id-description*
+ (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+ (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
+ (describe-html-attributes-from-class-slot-initargs class)
+ (describe-component-behaviour class))))
+(defmethod wcomponent-template ((cinput ccheckbox))
+ (let* ((client-id (htcomponent-client-id cinput))
+ (translator (translator cinput))
+ (type (input-type cinput))
+ (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
+ (current-value (translator-type-to-string translator cinput))
+ (class (css-class cinput)))
+ (when (component-validation-errors cinput)
+ (if (or (null class) (string= class ""))
+ (setf class "error")
+ (setf class (format nil "~a error" class))))
+ (input> :static-id client-id
+ :type type
+ :name (name-attr cinput)
+ :class class
+ :value value
+ :checked (when (and current-value (equal value current-value)) "checked")
+ (wcomponent-informal-parameters cinput))))
+
+(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page))
+ (let* ((visit-object (or (cinput-visit-object cinput) page))
+ (client-id (htcomponent-client-id cinput))
+ (translator (translator cinput))
+ (accessor (cinput-accessor cinput))
+ (writer (cinput-writer cinput))
+ (validator (validator cinput))
+ (result-as-list-p (cinput-result-as-list-p cinput))
+ (new-value (page-req-parameter page
+ client-id
+ result-as-list-p)))
+ (when new-value
+ (setf new-value (translator-string-to-type translator cinput)))
+ (unless (component-validation-errors cinput)
+ (when validator
+ (funcall validator (or new-value "")))
+ (unless (component-validation-errors cinput)
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+ (funcall (fdefinition writer) new-value visit-object))))))
+
+;-------------------------------------------------------------------------------------
+(defclass cradio (ccheckbox)
+ ()
+ (:metaclass metacomponent)
+ (:default-initargs :type "radio")
+ (:documentation "Request cycle aware component the renders as an INPUT tag class"))
+
+(let ((class (find-class 'cradio)))
+ (closer-mop:ensure-finalized class)
+ (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
+ (format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a"
+ "Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"."
+ *id-and-static-id-description*
+ (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput))
+ (describe-html-attributes-from-class-slot-initargs (find-class 'cinput))
+ (describe-html-attributes-from-class-slot-initargs (find-class 'ccheckbox))
+ (describe-html-attributes-from-class-slot-initargs class)
+ (describe-component-behaviour class))))
+
+(defmethod name-attr ((ccheckbox ccheckbox))
+ (htcomponent-real-id ccheckbox))
+
+(defmethod wcomponent-after-rewind ((cinput cradio) (page page))
+ (let* ((visit-object (or (cinput-visit-object cinput) page))
+ (translator (translator cinput))
+ (accessor (cinput-accessor cinput))
+ (writer (cinput-writer cinput))
+ (validator (validator cinput))
+ (ccheckbox-test (ccheckbox-test cinput))
+ (result-as-list-p (cinput-result-as-list-p cinput))
+ (value (translator-value-string-to-type translator (ccheckbox-value cinput)))
+ (new-value (page-req-parameter page
+ (name-attr cinput)
+ result-as-list-p))
+ (checked))
+ (when new-value
+ (setf new-value (translator-string-to-type translator cinput)
+ checked (funcall ccheckbox-test value new-value)))
+ (when (and checked (null (component-validation-errors cinput)))
+ (when validator
+ (funcall validator (or new-value "")))
+ (when (null (component-validation-errors cinput))
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) new-value visit-object)
+ (funcall (fdefinition writer) new-value visit-object))))))
+
+(defmethod wcomponent-template ((cinput cradio))
+ (let* ((client-id (htcomponent-client-id cinput))
+ (translator (translator cinput))
+ (type (input-type cinput))
+ (value (translator-value-type-to-string translator (ccheckbox-value cinput)))
+ (current-value (translator-type-to-string translator cinput))
+ (class (css-class cinput)))
+ (when (component-validation-errors cinput)
+ (if (or (null class) (string= class ""))
+ (setf class "error")
+ (setf class (format nil "~a error" class))))
+ (input> :static-id client-id
+ :type type
+ :name (name-attr cinput)
+ :class class
+ :value value
+ :checked (when (and current-value (equal value current-value)) "checked")
+ (wcomponent-informal-parameters cinput))))
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Fri May 30 06:03:00 2008
@@ -49,7 +49,7 @@
- :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
- :LOGIN-PAGE-P Marks the function as a login page"))
-(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p)
+(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p encoding)
(:documentation "Registers a page into a lisplet for dispatching.
parameters:
- LISPLET the lisplet that will dispatch the page
@@ -57,15 +57,17 @@
- LOCATION The url location where the page will be registered (relative to the lisplet base path)
keys:
- :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location
-- :LOGIN-PAGE-P Marks the page as a login page"))
+- :LOGIN-PAGE-P Marks the page as a login page
+- :ENCODING The charset encoding used to render the resource"))
-(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type)
+(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type encoding)
(:documentation "Registers a resource (file or directory) into a lisplet for dispatching.
parameters:
- LISPLET the lisplet that will dispatch the page
- RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching
- LOCATION The url location where the resource will be registered (relative to the lisplet base path)
-- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type"))
+- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type
+- ENCODING The charset encoding used to render the resource"))
(defgeneric lisplet-dispatch-method (lisplet)
(:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST
@@ -106,7 +108,7 @@
(if handler
(funcall handler)
(let ((error-page (make-instance 'error-page
- :title (format nil "Server error: ~a" error-code)
+ :title (format nil "Server error: ~a" error-code)
:error-code error-code)))
(with-output-to-string (*standard-output*) (page-render error-page)))))))
@@ -120,6 +122,9 @@
(login-page :initarg :login-page
:accessor lisplet-login-page
:documentation "url location for the welcome page")
+ (encoding :initarg :encoding
+ :accessor lisplet-encoding
+ :documentation "The default charset external format for resources provided by this lisplet.")
(realm :initarg :realm
:reader lisplet-realm
:documentation "realm for requests that pass through this lisplet and session opened into this lisplet")
@@ -137,6 +142,7 @@
:documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
(:default-initargs :welcome-page nil
:login-page nil
+ :encoding :utf-8
:realm "claw"
:redirect-protected-resources-p nil)
(:documentation "A lisplet is a container for resources provided trhough the clawserver.
@@ -170,7 +176,7 @@
:basic))
(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
- (let ((pages (lisplet-pages lisplet)))
+ (let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
(sort-by-location (pushnew-location (cons location function) pages)))
(when welcome-page-p
@@ -178,16 +184,18 @@
(when login-page-p
(setf (lisplet-login-page lisplet) location))))
-(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p)
- (lisplet-register-function-location lisplet
- #'(lambda () (with-output-to-string (*standard-output*)
- (page-render (make-instance page-class :lisplet lisplet :url location))))
- location
- :welcome-page-p welcome-page-p
- :login-page-p login-page-p))
-
-(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
- (let ((pages (lisplet-pages lisplet)))
+(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p encoding)
+ (let ((charset-encoding (or encoding (lisplet-encoding lisplet))))
+ (lisplet-register-function-location lisplet
+ #'(lambda () (with-output-to-string (*standard-output*)
+ (page-render (make-instance page-class :lisplet lisplet :url location :encoding charset-encoding))))
+ location
+ :welcome-page-p welcome-page-p
+ :login-page-p login-page-p)))
+
+(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type (encoding :utf-8))
+ (let ((pages (lisplet-pages lisplet))
+ (external-format (flexi-streams:make-external-format (or encoding (lisplet-encoding lisplet)) :eol-style :lf)))
(setf (lisplet-pages lisplet)
(sort-by-location (pushnew-location
(cons location
@@ -199,11 +207,7 @@
(length (lisplet-base-path lisplet))
(length location) 1)))
resource-path)))
- (log-message :info "--------------------------------------------- ~%
-script-name: \"~a\"~%
-resource-path: \"~a\"~%
-resource-full-path :\"~a\"~%
---------------------------------------------" (script-name) resource-path resource-full-path)
+ (setf (reply-external-format) external-format)
(handle-static-file resource-full-path content-type)))
#'(lambda () (handle-static-file resource-path content-type))))
pages)))))
@@ -214,9 +218,7 @@
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
- do (progn
- (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url))
- (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))
+ do (when (starts-with-subseq rel-script-name url) (return (funcall action))))))
(defmethod lisplet-dispatch-method ((lisplet lisplet))
(let ((base-path (build-lisplet-location lisplet))
@@ -266,8 +268,6 @@
for match = (format nil "~a/~a" base-path (car protected-resource))
for allowed-roles = (cdr protected-resource)
do (when (or (starts-with-subseq match uri) (string= login-page-url uri))
- ;(when (lisplet-redirect-protected-resources-p lisplet)
- ;(redirect-to-https server request))
(cond
((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
(setf (return-code) +http-forbidden+)
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Fri May 30 06:03:00 2008
@@ -289,7 +289,7 @@
(format nil "~{:~a ~}" (eval reserved-parameters))
"NONE"))))
-(defun register-library-resource (location resource-path &optional content-type)
+(defun register-library-resource (location resource-path &optional content-type (encoding :utf-8))
"Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION."
(setf *claw-libraries-resources*
(sort-by-location (pushnew-location
@@ -300,9 +300,13 @@
(uri-to-pathname (subseq (script-name)
(+ (length (clawserver-base-path (current-server)))
(length location))))
- resource-path)))
+ resource-path))
+ (charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf)))
+ (setf (reply-external-format) charset-encoding)
(handle-static-file resource-full-path content-type)))
- #'(lambda () (handle-static-file resource-path content-type))))
+ #'(lambda () (let ((charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf)))
+ (setf (reply-external-format) charset-encoding)
+ (handle-static-file resource-path content-type)))))
*claw-libraries-resources*))))
(defun uri-to-pathname (uri &optional (relative t))
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Fri May 30 06:03:00 2008
@@ -53,6 +53,7 @@
:empty-string-p
:build-tagf
:page
+ :page-encoding
:page-url
:page-lisplet
:page-current-form
@@ -68,6 +69,7 @@
:htcomponent-body
:htcomponent-empty
:htcomponent-client-id
+ :htcomponent-real-id
:htcomponent-script-files
:htcomponent-stylesheet-files
:htcomponent-class-initscripts
@@ -188,14 +190,18 @@
:wcomponent-before-prerender
:wcomponent-after-prerender
:wcomponent-before-render
- :wcomponent-after-render
+ :wcomponent-after-render
:cform
:cform>
:action
:action-link
- :action-link>
+ :action-link>
:cinput
:cinput>
+ :ccheckbox
+ :ccheckbox>
+ :cradio
+ :cradio>
:cselect
:cselect>
:csubmit
@@ -203,7 +209,12 @@
:csubmit-value
:submit-link
:submit-link>
+ :input-type
+ :ccheckbox-value
+ :css-class
+ :name-attr
:lisplet
+ :lisplet-encoding
:lisplet-pages
:lisplet-register-page-location
:lisplet-register-function-location
@@ -269,10 +280,18 @@
:translator
:translator-integer
:translator-number
+ :translator-boolean
:translator-date
:translator-encode
:translator-decode
+ :translator-string-to-type
+ :translator-type-to-string
+ :translator-value-decode
+ :translator-value-encode
+ :translator-value-string-to-type
+ :translator-value-type-to-string
:*simple-translator*
+ :*boolean-translator*
:*locales*
:validate
:validation-errors
Modified: trunk/main/claw-core/src/server.lisp
==============================================================================
--- trunk/main/claw-core/src/server.lisp (original)
+++ trunk/main/claw-core/src/server.lisp Fri May 30 06:03:00 2008
@@ -104,6 +104,7 @@
(error-code :initarg :error-code
:reader page-error-code
:documentation "The error code to display"))
+ (:default-initargs :encoding :utf-8)
(:documentation "This is the page class used to render
the http error messages."))
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Fri May 30 06:03:00 2008
@@ -226,9 +226,6 @@
(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">"
"Page doctype as XHTML 4.01 FRAMESET")
-(defvar *default-encoding* "UTF-8"
- "Page default encoding (if no changes 'UTF-8')")
-
(defvar *rewind-parameter* "rewindobject"
"The request parameter for the object asking for a rewind action")
@@ -292,19 +289,20 @@
(id-table-map (request-id-table-map))
(id (getf (first fbody) :id))
(static-id (getf (first fbody) :static-id))
+ (real-id (or static-id id))
(instance))
(when static-id
(remf (first fbody) :id)
(setf id nil))
(setf instance (make-instance parent
:empty emptyp
+ :real-id real-id
:name (string-downcase tag-name)
:attributes (first fbody)
:body (second fbody)))
(if (null static-id)
(when (and id-table-map id)
- (setf (htcomponent-client-id instance)
- (generate-id id)))
+ (setf (htcomponent-client-id instance) (generate-id id)))
(setf (htcomponent-client-id instance) static-id))
instance))
@@ -378,9 +376,12 @@
(components-stack :initform nil
:accessor page-components-stack
:documentation "A stack of components enetered into rendering process.")
- (content-type :initarg :content-type
- :accessor page-content-type
- :documentation "Define the content type of the page when rendered")
+ (mime-type :initarg :mime-type
+ :accessor page-mime-type
+ :documentation "Define the mime type of the page when rendered")
+ (encoding :initarg :encoding
+ :accessor page-encoding
+ :documentation "The charset external format. When not provided the lisplet one is used")
(url :initarg :url
:accessor page-url :documentation "The URL provided with this page instance"))
(:default-initargs :writer t
@@ -394,7 +395,7 @@
:xmloutput nil
:doc-type *html-4.01-strict*
:request-parameters nil
- :content-type hunchentoot:*default-content-type*
+ :mime-type "text/html"
:url nil)
(:documentation "A page object holds claw components to be rendered") )
@@ -408,6 +409,8 @@
:accessor htcomponent-body :documentation "The tag body")
(client-id :initarg :client-id
:accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function")
+ (real-id :initarg :real-id
+ :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID")
(attributes :initarg :attributes
:accessor htcomponent-attributes :documentation "The tag attributes")
(empty :initarg :empty
@@ -424,6 +427,7 @@
:body nil
:json-render-on-validation-errors-p nil
:client-id nil
+ :real-id nil
:attributes nil
:empty nil
:script-files nil
@@ -578,17 +582,15 @@
(setf (page-tabulator page) 0)))
(defmethod page-render-headings ((page page))
- (let* ((writer (page-writer page))
- (jsonp (page-json-id-list page))
- (encoding (handler-case (format nil "~a" (stream-external-format writer))
- (error () (format nil "~a" *default-encoding*))))
+ (let* ((jsonp (page-json-id-list page))
+ (encoding (page-encoding page))
(xml-p (page-xmloutput page))
- (content-type (page-doc-type page)))
+ (doc-type (page-doc-type page)))
(when (null jsonp)
(when xml-p
- (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
- (when content-type
- (page-format-raw page "~a~%" content-type)))))
+ (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
+ (when doc-type
+ (page-format-raw page "~a~%" doc-type)))))
(defun json-validation-errors ()
"Composes the error part for the json reply"
@@ -609,7 +611,8 @@
(defmethod page-render ((page page))
(let ((body (page-content page))
(jsonp (page-json-id-list page)))
- (setf (hunchentoot:content-type) (page-content-type page))
+ (setf (reply-external-format)
+ (flexi-streams:make-external-format (page-encoding page) :eol-style :lf))
(if (null body)
(format nil "null body for page ~a~%" (type-of page))
(progn
@@ -874,7 +877,11 @@
(let ((body-list (htcomponent-body hthead))
(injections (page-init-injections page)))
(tag-render-starttag hthead page)
- (htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) page)
+ (htcomponent-render (meta> :http-equiv "Content-Type"
+ :content (format nil "~a;charset=~a"
+ (page-mime-type page)
+ (page-encoding page)))
+ page)
(dolist (child-tag body-list)
(when child-tag
(cond
@@ -1072,8 +1079,11 @@
(defun make-component (name parameters content)
"This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the
initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content."
- (let ((instance (make-instance name))
- (static-id (getf parameters :static-id)))
+ (let* ((instance (make-instance name))
+ (id (getf parameters :id))
+ (static-id (getf parameters :static-id))
+ (real-id (or static-id id)))
+ (setf (htcomponent-real-id instance) real-id)
(when static-id
(remf parameters :id))
(loop for (initarg value) on parameters by #'cddr
Modified: trunk/main/claw-core/src/translators.lisp
==============================================================================
--- trunk/main/claw-core/src/translators.lisp (original)
+++ trunk/main/claw-core/src/translators.lisp Fri May 30 06:03:00 2008
@@ -29,28 +29,45 @@
(in-package :claw)
+(defmethod translator-value-encode ((translator translator) value)
+ (format nil "~a" value))
+
+(defmethod translator-value-type-to-string ((translator translator) value)
+ (translator-value-encode translator value))
+
(defmethod translator-encode ((translator translator) (wcomponent cinput))
- (let ((page (htcomponent-page wcomponent))
- (visit-object (cinput-visit-object wcomponent))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent)))
- (format nil "~a" (if (component-validation-errors wcomponent)
- (page-req-parameter page (htcomponent-client-id wcomponent) nil)
- (progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
- (if (and (null reader) accessor)
- (funcall (fdefinition accessor) visit-object)
- (funcall (fdefinition reader) visit-object)))))))
+ (let* ((page (htcomponent-page wcomponent))
+ (visit-object (or (cinput-visit-object wcomponent) page))
+ (accessor (cinput-accessor wcomponent))
+ (reader (cinput-reader wcomponent))
+ (value (page-req-parameter page (name-attr wcomponent) nil)))
+ (if (component-validation-errors wcomponent)
+ value
+ (progn
+ (setf value (cond
+ ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+ (t (funcall (fdefinition reader) visit-object))))
+ (translator-value-encode translator value)))))
+
+(defmethod translator-type-to-string ((translator translator) (wcomponent cinput))
+ (translator-encode translator wcomponent))
+
+(defmethod translator-value-decode ((translator translator) value &optional client-id label)
+ (declare (ignore client-id label))
+ value)
+
+(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label)
+ (translator-value-decode translator value client-id label))
(defmethod translator-decode ((translator translator) (wcomponent wcomponent))
- (multiple-value-bind (client-id new-value)
+ (multiple-value-bind (client-id value)
(component-id-and-value wcomponent)
- (declare (ignore client-id))
- new-value))
+ (translator-value-decode translator value client-id (label wcomponent))))
-(setf *simple-translator* (make-instance 'translator))
+(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent))
+ (translator-decode translator wcomponent))
+(setf *simple-translator* (make-instance 'translator))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -58,56 +75,43 @@
(defclass translator-integer (translator)
((thousand-separator :initarg :thousand-separator
- :reader translator-thousand-separator
- :documentation "If specified (as character), it is the thousands separator. Despite of
+ :reader translator-thousand-separator
+ :documentation "If specified (as character), it is the thousands separator. Despite of
its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator")
(always-show-signum :initarg :always-show-signum
- :reader translator-always-show-signum
- :documentation "When true the signum is used also for displaying positive numbers.")
+ :reader translator-always-show-signum
+ :documentation "When true the signum is used also for displaying positive numbers.")
(grouping-size :initarg :grouping-size
- :reader translator-grouping-size
- :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3"))
+ :reader translator-grouping-size
+ :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3"))
(:default-initargs :thousand-separator nil
:grouping-size 3
:always-show-signum nil)
(:documentation "A translator object encodes and decodes integer values passed to a html input component"))
-(defmethod translator-encode ((translator translator-integer) (wcomponent cinput))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (or (cinput-visit-object wcomponent) page))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent))
- (grouping-size (translator-grouping-size translator))
- (thousand-separator (translator-thousand-separator translator))
- (signum-directive (if (translator-always-show-signum translator)
- "@"
- ""))
- (control-string (if thousand-separator
- (format nil "~~~d,',v:~aD" grouping-size signum-directive)
- (format nil "~~~ad" signum-directive)))
-
- (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
- (if (component-validation-errors wcomponent)
- value
- (progn
- (setf value (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (if thousand-separator
- (string-trim " " (format nil control-string thousand-separator value))
- (format nil control-string value))))))
+(defmethod translator-value-encode ((translator translator-integer) value)
+ (let* ((grouping-size (translator-grouping-size translator))
+ (thousand-separator (translator-thousand-separator translator))
+ (signum-directive (if (translator-always-show-signum translator)
+ "@"
+ ""))
+ (control-string (if thousand-separator
+ (format nil "~~~d,',v:~aD" grouping-size signum-directive)
+ (format nil "~~~ad" signum-directive))))
+ (if thousand-separator
+ (string-trim " " (format nil control-string thousand-separator value))
+ (format nil control-string value))))
-(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent))
+(defmethod translator-value-decode ((translator translator-integer) value &optional client-id label)
(let ((thousand-separator (translator-thousand-separator translator)))
- (multiple-value-bind (client-id value)
- (component-id-and-value wcomponent)
- (handler-case
- (if thousand-separator
- (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
- (parse-integer value))
- (error () (progn
- (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label wcomponent)))
- value))))))
+ (handler-case
+ (if thousand-separator
+ (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
+ (parse-integer value))
+ (error () (progn
+ (when label
+ (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") label)))
+ value)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
@@ -115,79 +119,67 @@
(defclass translator-number (translator-integer)
((decimals-separator :initarg :decimals-separator
- :reader translator-decimals-separator
- :documentation "The decimal separator of the rendered number. Default to #\.")
+ :reader translator-decimals-separator
+ :documentation "The decimal separator of the rendered number. Default to #\.")
(decimal-digits :initarg :decimal-digits
- :reader translator-decimal-digits
- :documentation "force the rendering of the value to a fixed number of decimal digits")
+ :reader translator-decimal-digits
+ :documentation "force the rendering of the value to a fixed number of decimal digits")
(coerce :initarg :coerce
- :accessor translator-coerce
- :documentation "Coerces the decoded input value to the given value type"))
+ :accessor translator-coerce
+ :documentation "Coerces the decoded input value to the given value type"))
(:default-initargs :decimals-separator #\.
- ;:integer-digits nil
- :decimal-digits nil
- :coerce 'ratio)
+ ;:integer-digits nil
+ :decimal-digits nil
+ :coerce 'ratio)
(:documentation "a translator object encodes and decodes integer values passed to a html input component"))
-(defmethod translator-encode ((translator translator-number) (wcomponent cinput))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (or (cinput-visit-object wcomponent) page))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent))
- (thousand-separator (translator-thousand-separator translator))
- (grouping-size (translator-grouping-size translator))
- (decimal-digits (translator-decimal-digits translator))
- (decimals-separator (translator-decimals-separator translator))
- (signum-directive (if (translator-always-show-signum translator) "@" ""))
- (integer-control-string (if thousand-separator
- (format nil "~~~d,',v:~aD" grouping-size signum-directive)
- (format nil "~~~ad" signum-directive)))
- (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
- (if (component-validation-errors wcomponent)
- value
- (multiple-value-bind (int-value dec-value)
- (floor (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (setf dec-value (coerce dec-value 'float))
- (format nil "~a~a"
- (if thousand-separator
- (string-trim " " (format nil integer-control-string thousand-separator int-value))
- (format nil integer-control-string int-value))
- (cond
- ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
- (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
- (decimal-digits
- (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
- (if (> (length frac-part) decimal-digits)
- (setf frac-part (subseq frac-part 0 decimal-digits))
- (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
- (format nil "~a~a" decimals-separator frac-part)))
- (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2)))))))))
-
+(defmethod translator-value-encode ((translator translator-number) value)
+ (let* ((thousand-separator (translator-thousand-separator translator))
+ (grouping-size (translator-grouping-size translator))
+ (decimal-digits (translator-decimal-digits translator))
+ (decimals-separator (translator-decimals-separator translator))
+ (signum-directive (if (translator-always-show-signum translator) "@" ""))
+ (integer-control-string (if thousand-separator
+ (format nil "~~~d,',v:~aD" grouping-size signum-directive)
+ (format nil "~~~ad" signum-directive))))
+ (multiple-value-bind (int-value dec-value)
+ (floor value)
+ (setf dec-value (coerce dec-value 'float))
+ (format nil "~a~a"
+ (if thousand-separator
+ (string-trim " " (format nil integer-control-string thousand-separator int-value))
+ (format nil integer-control-string int-value))
+ (cond
+ ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
+ (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
+ (decimal-digits
+ (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
+ (if (> (length frac-part) decimal-digits)
+ (setf frac-part (subseq frac-part 0 decimal-digits))
+ (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
+ (format nil "~a~a" decimals-separator frac-part)))
+ (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))
-(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent))
+(defmethod translator-value-decode ((translator translator-number) value &optional client-id label)
(let ((thousand-separator (translator-thousand-separator translator))
- (type (translator-coerce translator))
- (new-value))
- (multiple-value-bind (client-id value)
- (component-id-and-value wcomponent)
- (if thousand-separator
- (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
- (setf new-value value))
- (handler-case
- (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
- (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string))))
- (dec-value (expt 10 (length (second decomposed-string))))
- (result (/ int-value dec-value)))
- (if (integerp result)
- result
- (coerce result type)))
- (error () (progn
- (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label wcomponent)))
- value))))))
-
+ (type (translator-coerce translator))
+ (new-value))
+ (if thousand-separator
+ (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
+ (setf new-value value))
+ (handler-case
+ (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
+ (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string))))
+ (dec-value (expt 10 (length (second decomposed-string))))
+ (result (/ int-value dec-value)))
+ (if (integerp result)
+ result
+ (coerce result type)))
+ (error () (progn
+ (when label
+ (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") label)))
+ value)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -195,8 +187,8 @@
(defclass translator-date (translator)
((local-time-format :initarg :local-time-format
- :reader translator-local-time-format
- :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
+ :reader translator-local-time-format
+ :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)"))
(:default-initargs :local-time-format '(:month "/" :date "/" :year))
(:documentation "A translator object encodes and decodes local-date object value passed to a html input component.
@@ -206,76 +198,74 @@
-(defmethod translator-encode ((translator translator-date) (wcomponent cinput))
- (let* ((page (htcomponent-page wcomponent))
- (visit-object (or (cinput-visit-object wcomponent) page))
- (accessor (cinput-accessor wcomponent))
- (reader (cinput-reader wcomponent))
- (local-time-format (translator-local-time-format translator))
- (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
- (if (component-validation-errors wcomponent)
- value
- (progn
- (setf value (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (if (and value (not (stringp value)))
- (local-time-to-string value local-time-format)
- value)))))
+(defmethod translator-value-encode ((translator translator-date) value)
+ (let* ((local-time-format (translator-local-time-format translator)))
+ (if (and value (not (stringp value)))
+ (local-time-to-string value local-time-format)
+ value)))
-(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent))
+(defmethod translator-value-decode ((translator translator-date) value &optional client-id label)
(let ((date-format (translator-local-time-format translator))
- (sec 0)
- (min 0)
- (hour 0)
- (day 0)
- (month 0)
- (year 0)
- (old-value))
- (multiple-value-bind (client-id new-value)
- (component-id-and-value wcomponent)
- (declare (ignore client-id))
- (when (and new-value (string-not-equal new-value ""))
- (setf old-value new-value)
- (loop for element in date-format
- do (if (stringp element)
- (setf new-value (subseq new-value (length element)))
- (ccase element
- (:second (multiple-value-bind (value size)
- (parse-integer new-value :junk-allowed t)
- (setf new-value (subseq new-value size))
- (setf sec value)))
- (:minute (multiple-value-bind (value size)
- (parse-integer new-value :junk-allowed t)
- (setf new-value (subseq new-value size))
- (setf min value)))
- (:hour (multiple-value-bind (value size)
- (parse-integer new-value :junk-allowed t)
- (setf new-value (subseq new-value size))
- (setf hour value)))
- (:date (multiple-value-bind (value size)
- (parse-integer new-value :junk-allowed t)
- (setf new-value (subseq new-value size))
- (setf day value)))
- (:month (multiple-value-bind (value size)
- (parse-integer new-value :junk-allowed t)
- (setf new-value (subseq new-value size))
- (setf month value)))
- (:year (multiple-value-bind (value size)
- (parse-integer new-value :junk-allowed t)
- (setf new-value (subseq new-value size))
- (setf year value))))))
- (validate (and (string-equal new-value "")
- (>= sec 0)
- (>= min 0)
- (>= hour 0)
- (and (> month 0) (<= month 12))
- (and (> day 0) (<= day (days-in-month month year))))
- :component wcomponent
- :message (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a")
- (label wcomponent)
- old-value))
- (if (component-validation-errors wcomponent)
- old-value
- (encode-local-time 0 sec min hour day month year))))))
+ (sec 0)
+ (min 0)
+ (hour 0)
+ (day 0)
+ (month 0)
+ (year 0)
+ (old-value))
+ (when (and value (string-not-equal value ""))
+ (setf old-value value)
+ (loop for element in date-format
+ do (if (stringp element)
+ (setf value (subseq value (length element)))
+ (ccase element
+ (:second (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf sec curr-value)))
+ (:minute (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf min curr-value)))
+ (:hour (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf hour curr-value)))
+ (:date (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf day curr-value)))
+ (:month (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf month curr-value)))
+ (:year (multiple-value-bind (curr-value size)
+ (parse-integer value :junk-allowed t)
+ (setf value (subseq value size))
+ (setf year curr-value))))))
+ (if (and (string-equal value "")
+ (>= sec 0)
+ (>= min 0)
+ (>= hour 0)
+ (and (> month 0) (<= month 12))
+ (and (> day 0) (<= day (days-in-month month year))))
+ (encode-local-time 0 sec min hour day month year)
+ (progn
+ (when label
+ (add-exception client-id (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") label old-value)))
+ value)))))
+
+
+(defclass translator-boolean (translator)
+ ()
+ (:documentation "a translator object encodes and decodes boolean values passed to a html input component"))
+
+(defmethod translator-value-encode ((translator translator-boolean) value)
+ (format nil "~a" value))
+
+(defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label)
+ (if (string-equal value "NIL")
+ nil
+ t))
+(defvar *boolean-translator* (make-instance 'translator-boolean))
\ No newline at end of file
Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp (original)
+++ trunk/main/claw-core/src/validators.lisp Fri May 30 06:03:00 2008
@@ -53,14 +53,14 @@
(defun add-exception (id reason)
"Adds an exception for the given input component identified by its ID with the message expressed by REASON"
(let* ((validation-errors (validation-errors))
- (symbol-id (make-symbol id))
+ (symbol-id (intern id))
(errors (getf validation-errors symbol-id)))
(setf (getf validation-errors symbol-id) (nconc errors (list reason))
(validation-errors *request*) validation-errors)))
(defun component-exceptions (id)
"Returns a list of exception connectd to the given component"
- (let ((symbol-id (make-symbol id)))
+ (let ((symbol-id (intern id)))
(getf (validation-errors) symbol-id)))
(defun validate (test &key component message)
@@ -70,15 +70,15 @@
(add-validation-compliance client-id)
(add-exception client-id message))))
-(defun validate-required (component value)
+(defun validate-required (component value &key message)
"Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\".
The argument for the message will be the :label attribute of the COMPONENT."
(when (stringp value)
(validate (and value (string-not-equal value ""))
:component component
- :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component)))))
+ :message (or message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component))))))
-(defun validate-size (component value &key min-size max-size)
+(defun validate-size (component value &key min-size max-size message-low message-hi)
"Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value.
@@ -92,17 +92,17 @@
(when min-size
(validate (>= value-len min-size)
:component component
- :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
- (label component)
- min-size)))
+ :message (or message-low (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
+ (label component)
+ min-size))))
(when max-size
(validate (<= value-len max-size)
:component component
- :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
+ :message (or message-hi (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
(label component)
- max-size)))))))
+ max-size))))))))
-(defun validate-range (component value &key min max)
+(defun validate-range (component value &key min max message-low message-hi)
"Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX.
If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the :MIN value.
@@ -112,21 +112,21 @@
(and (when min
(validate (>= value min)
:component component
- :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
- (label component)
- (if (typep min 'ratio)
- (coerce min 'float)
- min))))
+ :message (or message-low (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
+ (label component)
+ (if (typep min 'ratio)
+ (coerce min 'float)
+ min)))))
(when max
(validate (<= value max)
:component component
- :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
- (label component)
- (if (typep max 'ratio)
- (coerce max 'float)
- max)))))))
+ :message (or message-hi (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
+ (label component)
+ (if (typep max 'ratio)
+ (coerce max 'float)
+ max))))))))
-(defun validate-number (component value &key min max)
+(defun validate-number (component value &key min max message-nan message-low message-hi)
"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\".
The argument for the message will be the :label attribute of the COMPONENT."
@@ -134,10 +134,10 @@
(let ((test (numberp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))
- (validate-range component value :min min :max max)))))
+ :message (or message-nan (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))))
+ (validate-range component value :min min :max max :message-low message-low :message-hi message-hi)))))
-(defun validate-integer (component value &key min max)
+(defun validate-integer (component value &key min max message-nan message-low message-hi)
"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\".
The argument for the message will be the :label attribute of the COMPONENT."
@@ -145,11 +145,11 @@
(let ((test (integerp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))
- (validate-range component value :min min :max max)))))
+ :message (or message-nan (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))))
+ (validate-range component value :min min :max max :message-low message-low :message-hi message-hi)))))
-(defun validate-date-range (component value &key min max (use-date-p t) use-time-p)
+(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi)
"Checks if the input field VALUE is a date between min and max.
If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time.
If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time.
@@ -183,15 +183,15 @@
(and (when min
(validate (local-time> new-value min)
:component component
- :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
- (label component)
- (local-time-to-string min local-time-format))))
+ :message (or message-low (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
+ (label component)
+ (local-time-to-string min local-time-format)))))
(when max
(validate (local-time< new-value max)
:component component
- :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
- (label component)
- (local-time-to-string max local-time-format))))))))
+ :message (or message-hi (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
+ (label component)
+ (local-time-to-string max local-time-format)))))))))
@@ -213,16 +213,16 @@
(defmethod wcomponent-template ((exception-monitor exception-monitor))
(let ((client-id (htcomponent-client-id exception-monitor))
(validation-errors (validation-errors))
- (body (htcomponent-body exception-monitor)))
+ (body (htcomponent-body exception-monitor)))
(div> :static-id client-id
(wcomponent-informal-parameters exception-monitor)
(when validation-errors
(if body
body
- (ul>
- (loop for component-exceptions in (rest validation-errors) by #'cddr
- do (loop for message in component-exceptions
- collect (li> message)))))))))
+ (ul> :id "errors"
+ (loop for (client-id component-exceptions) on validation-errors by #'cddr
+ collect (loop for message in component-exceptions
+ collect (li> message)))))))))
;;-------------------------------------------------------------------------------------------
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Fri May 30 06:03:00 2008
@@ -46,10 +46,15 @@
(simple-message-dispatcher-add-message *lisplet-messages* "en" "NAME" "Name")
(simple-message-dispatcher-add-message *lisplet-messages* "en" "SURNAME" "Surname")
(simple-message-dispatcher-add-message *lisplet-messages* "en" "WELCOME" "Welcome")
+(simple-message-dispatcher-add-message *lisplet-messages* "en" "AGREE" "Agree")
+(simple-message-dispatcher-add-message *lisplet-messages* "en" "SURE" "Are you sure?")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "YES" "sì")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "NAME" "Nome")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE" "Sei sicuro?")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE-ERROR-MESSAGE" "Devi essere sicuro")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!")
@@ -120,7 +125,7 @@
(title>
(title o))
(style> :type "text/css"
- "input.error {
+ "input.error, div.error {
background-color: #FF9999;
}
"))
@@ -331,9 +336,13 @@
:accessor user-gender)
(age :initarg :age
:accessor user-age)
+ (agree :initarg :agree
+ :accessor user-agree)
+ (sure :initarg :sure
+ :accessor user-sure)
(capital :initarg :capital
:accessor user-capital))
- (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0))
+ (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree ""))
(defgeneric form-page-update-user (form-page))
@@ -351,11 +360,14 @@
:accessor form-page-user)
(age :initarg :age
:accessor form-page-age)
+ (agree :initarg :agree
+ :accessor form-page-agree)
+ (sure :initarg :sure
+ :accessor form-page-sure)
(capital :initarg :capital
:accessor form-page-capital)
(birthday :initarg :birthday
- :accessor form-page-birthday))
-
+ :accessor form-page-birthday))
(:default-initargs :name "kiuma"
:surname "surnk"
:colors nil
@@ -364,6 +376,8 @@
:capital 500055/100
:birthday (now)
:message-dispatcher *lisplet-messages*
+ :agree t
+ :sure "yes"
:user (make-instance 'user)))
(defmethod form-page-update-user ((form-page form-page))
@@ -371,113 +385,149 @@
(name (form-page-name form-page))
(surname (form-page-surname form-page))
(gender (form-page-gender form-page))
- (age (form-page-age form-page)))
+ (age (form-page-age form-page))
+ (agree (form-page-agree form-page))
+ (sure (form-page-sure form-page)))
(setf (user-name user) name
(user-surname user) surname
(user-gender user) gender
- (user-age user) age)))
+ (user-age user) age
+ (user-agree user) agree
+ (user-sure user) sure)))
+
- ;(defmethod message-dispatch ((object form-page) key locale)
+(defun validate-agree (component value)
+ (declare (ignore value))
+ (validate nil
+ :component component
+ :message (do-message "SURE-ERROR-MESSAGE" "You must be sure")))
-(defmethod page-content ((o form-page))
- (site-template> :title "a page title"
- (cform> :id "testform" :method "post" :action #'form-page-update-user
- (table>
- (tr>
- (td> "Name")
- (td>
- (cinput> :id "name"
- :type "text"
- :label "Name"
- :validator #'(lambda (value)
- (validate-required (page-current-component o) value))
- :accessor 'form-page-name)"*"))
- (tr> :id "messaged"
- (td> (with-message "SURNAME" "SURNAME"))
- (td>
- (cinput> :id "surname"
- :type "text"
- :label "Surname"
- :validator #'(lambda (value)
- (validate-required (page-current-component o) value)
- (validate-size (page-current-component o) value :min-size 1 :max-size 20))
- :accessor 'form-page-surname)"*"))
- (tr>
- (td> "Gender")
- (td>
- (cselect> :id "gender"
- :accessor 'form-page-gender
- (loop for gender in (list "M" "F")
- collect (option> :value gender
- (when (string= gender (form-page-gender o))
- '(:selected "selected"))
- (if (string= gender "M")
- "Male"
- "Female"))))))
- (tr>
- (td> "Age")
- (td>
- (cinput> :id "age"
- :type "text"
- :label "Age"
- :translator (make-instance 'translator-integer :thousand-separator #\')
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-required component value)
- (validate-integer component value :min 1 :max 2000)))
- :accessor 'form-page-age)"*"))
- (tr>
- (td> "Birthday")
- (td>
- (cinput> :id "bday"
- :type "text"
- :label "Birthday"
- :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year))
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
- :accessor 'form-page-birthday)"(dd-mm-yyyy)"))
- (tr>
- (td> "Capital")
- (td>
- (cinput> :id "capital"
- :type "text"
- :label "Capital"
- :translator (make-instance 'translator-number
- :decimal-digits 2
- :thousand-separator #\')
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-required component value)
- (validate-number component value :min 1000.01 :max 500099/100)))
- :accessor 'form-page-capital)"*"))
- (tr>
- (td> "Colors")
- (td>
- (cselect> :id "colors"
- :multiple "true"
- :style "width:80px;height:120px;"
- :accessor 'form-page-colors
- (loop for color in (list "R" "G" "B")
- collect (option> :value color
- (when (find color (form-page-colors o) :test #'string=)
- '(:selected "selected"))
- (cond
- ((string= color "R") "red")
- ((string= color "G") "green")
- (t "blue")))))))
- (tr>
- (td> :colspan "2"
- (csubmit> :id "submit" :value "OK")))))
- (p>
- (exception-monitor>)
- (hr>)
- (h2> "From result:")
- (div> (format nil "Name: ~a" (user-name (form-page-user o))))
- (div> (format nil "Surname: ~a" (user-surname (form-page-user o))))
- (div> (format nil "Gender: ~a" (user-gender (form-page-user o))))
- (div> (format nil "Age: ~a" (user-age (form-page-user o)))))))
+(defmethod page-content ((o form-page))
+ (let ((user (form-page-user o)))
+ (site-template> :title "a page title"
+ (cform> :id "testform" :method "post" :action #'form-page-update-user
+ (table>
+ (tr>
+ (td> "Name")
+ (td>
+ (cinput> :id "name"
+ :type "text"
+ :label "Name"
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value))
+ :accessor 'form-page-name)"*"))
+ (tr> :id "messaged"
+ (td> (with-message "SURNAME" "SURNAME"))
+ (td>
+ (cinput> :id "surname"
+ :type "text"
+ :label "Surname"
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value)
+ (validate-size (page-current-component o) value :min-size 1 :max-size 20))
+ :accessor 'form-page-surname)"*"))
+ (tr> :id "agree"
+ (td> (with-message "AGREE" "AGREE"))
+ (td>
+ (ccheckbox> :id "agree"
+ :label (with-message "AGREE" "AGREE")
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value))
+ :accessor 'form-page-agree
+ :value t)"*"))
+ (tr> :id "sure"
+ (td> (with-message "SURE" "SURE"))
+ (td>
+ (cradio> :id "sure"
+ :label (with-message "SURE" "SURE")
+ :accessor 'form-page-sure
+ :value "yes")
+ (span> :style "margin-right:1.5em;" (with-message "YES" "yes"))
+ (cradio> :id "sure"
+ :label (with-message "SURE" "SURE")
+ :validator #'(lambda (value)
+ (validate-agree (page-current-component o) value))
+ :accessor 'form-page-sure
+ :value "no")
+ (span> :style "margin-right:1.5em;" (with-message "NO" "no"))))
+ (tr>
+ (td> "Gender")
+ (td>
+ (cselect> :id "gender"
+ :accessor 'form-page-gender
+ (loop for gender in (list "M" "F")
+ collect (option> :value gender
+ (when (string= gender (form-page-gender o))
+ '(:selected "selected"))
+ (if (string= gender "M")
+ "Male"
+ "Female"))))))
+ (tr>
+ (td> "Age")
+ (td>
+ (cinput> :id "age"
+ :type "text"
+ :label "Age"
+ :translator (make-instance 'translator-integer :thousand-separator #\')
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-required component value)
+ (validate-integer component value :min 1 :max 2000)))
+ :accessor 'form-page-age)"*"))
+ (tr>
+ (td> "Birthday")
+ (td>
+ (cinput> :id "bday"
+ :type "text"
+ :label "Birthday"
+ :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year))
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
+ :accessor 'form-page-birthday)"(dd-mm-yyyy)"))
+ (tr>
+ (td> "Capital")
+ (td>
+ (cinput> :id "capital"
+ :type "text"
+ :label "Capital"
+ :translator (make-instance 'translator-number
+ :decimal-digits 2
+ :thousand-separator #\')
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-required component value)
+ (validate-number component value :min 1000.01 :max 500099/100)))
+ :accessor 'form-page-capital)"*"))
+ (tr>
+ (td> "Colors")
+ (td>
+ (cselect> :id "colors"
+ :multiple "true"
+ :style "width:80px;height:120px;"
+ :accessor 'form-page-colors
+ (loop for color in (list "R" "G" "B")
+ collect (option> :value color
+ (when (find color (form-page-colors o) :test #'string=)
+ '(:selected "selected"))
+ (cond
+ ((string= color "R") "red")
+ ((string= color "G") "green")
+ (t "blue")))))))
+ (tr>
+ (td> :colspan "2"
+ (csubmit> :id "submit" :value "OK")))))
+ (p>
+ (exception-monitor> :class "error")
+ (hr>)
+ (h2> "From result:")
+ (div> (format nil "Name: ~a" (user-name user)))
+ (div> (format nil "Surname: ~a" (user-surname user)))
+ (div> (format nil "Gender: ~a" (user-gender user)))
+ (div> (format nil "Age: ~a" (user-age user)))
+ (div> (format nil "Agree: ~a" (user-agree user)))
+ (div> (format nil "Sure: ~a" (user-sure user)))))))
(lisplet-register-page-location *test-lisplet* 'form-page "form.html")
1
0
Author: achiumenti
Date: Sat May 24 13:18:39 2008
New Revision: 48
Modified:
trunk/main/claw-core/claw.asd
trunk/main/claw-core/src/components.lisp
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/src/validators.lisp
Log:
a lot of bug fixes
Modified: trunk/main/claw-core/claw.asd
==============================================================================
--- trunk/main/claw-core/claw.asd (original)
+++ trunk/main/claw-core/claw.asd Sat May 24 13:18:39 2008
@@ -31,7 +31,7 @@
:name "claw"
:author "Andrea Chiumenti"
:description "Common Lisp Active Web.A famework to write web applications"
- :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence)
+ :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :parenscript)
:components ((:module src
:components ((:file "packages")
(:file "misc" :depends-on ("packages"))
Modified: trunk/main/claw-core/src/components.lisp
==============================================================================
--- trunk/main/claw-core/src/components.lisp (original)
+++ trunk/main/claw-core/src/components.lisp Sat May 24 13:18:39 2008
@@ -55,7 +55,8 @@
(defun component-validation-errors (component &optional (request *request*))
"Resurns possible validation errors occurred during form rewinding bound to a specific component"
(let ((client-id (htcomponent-client-id component)))
- (assoc client-id (validation-errors request) :test #'equal)))
+ (getf (validation-errors request) (make-symbol client-id))))
+
;--------------------------------------------------------------------------------
(defclass cform (wcomponent)
@@ -87,7 +88,7 @@
(defmethod wcomponent-template((cform cform))
(let ((client-id (htcomponent-client-id cform))
(class (css-class cform))
- (validation-errors (aux-request-value :validation-errors)))
+ (validation-errors (validation-errors)))
(when validation-errors
(if (or (null class) (string= class ""))
(setf class "error")
@@ -105,7 +106,7 @@
(setf (page-current-form pobj) obj))
(defmethod wcomponent-after-rewind ((obj cform) (pobj page))
- (let ((validation-errors (aux-request-value :validation-errors))
+ (let ((validation-errors (validation-errors))
(action (action obj)))
(unless validation-errors
(when (or action (cform-rewinding-p obj pobj))
@@ -177,7 +178,7 @@
:reader input-type
:documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function."))
(:metaclass metacomponent)
- (:default-initargs :reserved-parameters (list :value :name) :empty t)
+ (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text")
(:documentation "Request cycle aware component the renders as an INPUT tag class"))
(let ((class (find-class 'cinput)))
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Sat May 24 13:18:39 2008
@@ -196,8 +196,14 @@
(let ((resource-full-path (merge-pathnames
(uri-to-pathname (subseq (script-name)
(+ (length (clawserver-base-path (current-server)))
- (length (lisplet-base-path (lisplet-base-path lisplet))))))
+ (length (lisplet-base-path lisplet))
+ (length location) 1)))
resource-path)))
+ (log-message :info "--------------------------------------------- ~%
+script-name: \"~a\"~%
+resource-path: \"~a\"~%
+resource-full-path :\"~a\"~%
+--------------------------------------------" (script-name) resource-path resource-full-path)
(handle-static-file resource-full-path content-type)))
#'(lambda () (handle-static-file resource-path content-type))))
pages)))))
@@ -208,10 +214,9 @@
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
- do (cond
- ((and (string< url rel-script-name)
- (null (starts-with-subseq rel-script-name url))) (return nil))
- ((starts-with-subseq rel-script-name url) (return (funcall action)))))))
+ do (progn
+ (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url))
+ (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))
(defmethod lisplet-dispatch-method ((lisplet lisplet))
(let ((base-path (build-lisplet-location lisplet))
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Sat May 24 13:18:39 2008
@@ -217,6 +217,22 @@
"Resurns possible validation errors occurred during form rewinding"
(aux-request-value :validation-errors request))
+(defun (setf validation-errors) (value &optional (request *request*))
+ "Sets possible validation errors occurred during form rewinding"
+ (setf (aux-request-value :validation-errors request) value))
+
+(defun validation-compliances (&optional (request *request*))
+ "Resurns the list of components that pass validation during form rewinding"
+ (aux-request-value :validation-compliances request))
+
+(defun (setf validation-compliances) (value &optional (request *request*))
+ "Sets the list of components that pass validation during form rewinding"
+ (setf (aux-request-value :validation-compliances request) value))
+
+(defun add-validation-compliance (id &optional (request *request*))
+ "Adds a component id to the list of components that pass validation during form rewinding"
+ (setf (validation-compliances request) (nconc (validation-compliances request) (list id))))
+
(defclass metacomponent (standard-class)
()
(:documentation "This is the meta class the must be set for every WCOMPONENT.
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Sat May 24 13:18:39 2008
@@ -211,6 +211,7 @@
:lisplet-protect
:lisplet-authentication-type
:claw-start-session
+ :build-lisplet-location
;; clawserver
:clawserver
:clawserver-base-path
@@ -234,6 +235,8 @@
#-:hunchentoot-no-ssl :clawserver-ssl-certificate-file
#-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file
#-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password
+ :add-exception
+ :component-exceptions
:msie-p
:*id-and-static-id-description*
:describe-component-behaviour
@@ -273,6 +276,8 @@
:*locales*
:validate
:validation-errors
+ :validation-compliances
+ :add-validation-compliance
:component-validation-errors
:validate-required
:validate-size
Modified: trunk/main/claw-core/src/server.lisp
==============================================================================
--- trunk/main/claw-core/src/server.lisp (original)
+++ trunk/main/claw-core/src/server.lisp Sat May 24 13:18:39 2008
@@ -385,21 +385,15 @@
(when (starts-with-subseq script-name base-path)
(setf rel-script-name (subseq script-name (length base-path))
rel-script-name-libs (subseq script-name (1+ (length base-path))))
- (or
+ (or
(loop for dispatcher in *claw-libraries-resources*
for url = (car dispatcher)
for action = (cdr dispatcher)
- do (cond
- ((and (string< url rel-script-name-libs)
- (null (starts-with-subseq rel-script-name-libs url))) (return nil))
- ((starts-with-subseq rel-script-name-libs url) (return (funcall action)))))
+ do (when (starts-with-subseq rel-script-name-libs url) (funcall action)))
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
- do (cond
- ((and (string< url rel-script-name)
- (null (starts-with-subseq rel-script-name url))) (return nil))
- ((starts-with-subseq rel-script-name url) (return (funcall action)))))))))
+ do (when (starts-with-subseq rel-script-name url) (return (funcall action))))))))
(defmethod clawserver-dispatch-method ((clawserver clawserver))
(let ((result (clawserver-dispatch-request clawserver)))
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Sat May 24 13:18:39 2008
@@ -15,7 +15,7 @@
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
-;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSEDse
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; 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 AUTHOR BE LIABLE FOR ANY
@@ -105,9 +105,10 @@
This internal method is called to render these scripts.
- PAGE is the page instance that must be given"))
-(defgeneric htbody-init-scripts-tag (page)
+(defgeneric htbody-init-scripts-tag (page &optional on-load)
(:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component
-See PAGE-BODY-INIT-SCRIPTS form more info.
+See PAGE-BODY-INIT-SCRIPTS form more info. If the ON-LOAD parameter it not nil, then the script will be executed
+on the onload document event.
- PAGE is the page instance that must be given"))
(defgeneric page-current-component (page)
@@ -370,6 +371,8 @@
:accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering")
(json-component-count :initarg :json-component-count
:accessor page-json-component-count :documentation "Need to render the json object after an xhr call.")
+ (json-component-id-list :initform ()
+ :accessor page-json-component-id-list :documentation "The current component that will ber rendered into json reply object in an xhr call.")
(request-parameters :initarg :request-parameters
:documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.")
(components-stack :initform nil
@@ -398,6 +401,9 @@
(defclass htcomponent (i18n-aware)
((page :initarg :page
:reader htcomponent-page :documentation "The owner page")
+ (json-render-on-validation-errors-p :initarg :json-render-on-validation-errors-p
+ :reader htcomponent-json-render-on-validation-errors-p
+ :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.")
(body :initarg :body
:accessor htcomponent-body :documentation "The tag body")
(client-id :initarg :client-id
@@ -416,6 +422,7 @@
:accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives"))
(:default-initargs :page nil
:body nil
+ :json-render-on-validation-errors-p nil
:client-id nil
:attributes nil
:empty nil
@@ -585,14 +592,19 @@
(defun json-validation-errors ()
"Composes the error part for the json reply"
- (let ((validation-errors (aux-request-value :validation-errors)))
+ (let ((validation-errors (validation-errors)))
(if validation-errors
- (strings-to-jsarray
- (loop for component-exceptions in validation-errors
- collect (format "{~a:~a}"(car component-exceptions)
- (strings-to-jsarray (loop for message in (cdr component-exceptions)
- collect (prin1-to-string message))))))
+ (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr
+ collect (symbol-name component-id)
+ collect (push 'array messages)))
+ (js-struct (ps:ps* `(create ,@errors))))
+ (subseq js-struct 0 (1- (length js-struct))))
"null")))
+
+(defun json-validation-compliances ()
+ "Composes the compliances part to form validation for the json reply"
+ (let ((js-array (ps:ps* `(array ,@(validation-compliances)))))
+ (subseq js-array 0 (1- (length js-array)))))
(defmethod page-render ((page page))
(let ((body (page-content page))
@@ -624,6 +636,8 @@
(htcomponent-render init-scripts page)))
(page-format-raw page "\",errors:")
(page-format-raw page (json-validation-errors))
+ (page-format-raw page ",valid:")
+ (page-format-raw page (json-validation-compliances))
(page-format-raw page "}"))))))
(defmethod page-body-init-scripts ((page page))
@@ -687,26 +701,39 @@
(let* ((id (htcomponent-client-id htcomponent))
(page (htcomponent-page htcomponent))
(print-status (page-can-print page))
- (render-p (member id (page-json-id-list page) :test #'string=)))
- (or print-status render-p)))
+ (validation-errors (validation-errors))
+ (json-render-on-validation-errors-p (htcomponent-json-render-on-validation-errors-p htcomponent))
+ (render-p (or (and (member id (page-json-id-list page) :test #'string=)
+ (null validation-errors))
+ print-status)))
+ #|json-render-on-validation-errors-p|#
+ (or json-render-on-validation-errors-p print-status render-p)))
(defmethod htcomponent-json-print-start-component ((htcomponent htcomponent))
(let* ((page (htcomponent-page htcomponent))
(jsonp (page-json-id-list page))
- (id (htcomponent-client-id htcomponent)))
+ (id (htcomponent-client-id htcomponent))
+ (validation-errors (validation-errors)))
(when (and jsonp
- (member id jsonp :test #'string-equal))
+ (or (and (null validation-errors)
+ (member id jsonp :test #'string-equal))
+ (htcomponent-json-render-on-validation-errors-p htcomponent)))
(when (> (page-json-component-count page) 0)
(page-format page ","))
(page-format-raw page "~a:\"" id)
+ (push id (page-json-component-id-list page))
(incf (page-json-component-count page)))))
(defmethod htcomponent-json-print-end-component ((htcomponent htcomponent))
(let* ((page (htcomponent-page htcomponent))
(jsonp (page-json-id-list page))
- (id (htcomponent-client-id htcomponent)))
+ (id (htcomponent-client-id htcomponent))
+ (validation-errors (validation-errors)))
(when (and jsonp
- (member id jsonp :test #'string-equal))
+ (or (and (null validation-errors)
+ (member id jsonp :test #'string-equal))
+ (htcomponent-json-render-on-validation-errors-p htcomponent)))
+ (pop (page-json-component-id-list page))
(page-format-raw page "\""))))
(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page))
@@ -776,7 +803,7 @@
(page-format page " ~a=\"~a\""
(string-downcase (if (eq k :static-id)
"id"
- (symbol-name k)))
+ (parenscript::symbol-to-js k)))
(let ((s (if (eq k :id)
(prin1-to-string (htcomponent-client-id tag))
(prin1-to-string v)))) ;escapes double quotes
@@ -784,26 +811,32 @@
(defmethod tag-render-starttag ((tag tag) (page page))
(let ((tagname (tag-name tag))
+ (id (htcomponent-client-id tag))
+ (jsonp (page-json-id-list page))
(emptyp (htcomponent-empty tag))
(xml-p (page-xmloutput page)))
(setf (page-lasttag page) tagname)
- (page-newline page)
- (page-print-tabulation page)
- (page-format page "<~a" tagname)
- (tag-render-attributes tag page)
- (if (null emptyp)
- (progn
- (page-format page ">")
- (incf (page-tabulator page)))
- (if (null xml-p)
+ (unless (and jsonp (string= id (first (page-json-component-id-list page))))
+ (page-newline page)
+ (page-print-tabulation page)
+ (page-format page "<~a" tagname)
+ (tag-render-attributes tag page)
+ (if (null emptyp)
+ (progn
(page-format page ">")
- (page-format page "/>")))))
+ (incf (page-tabulator page)))
+ (if (null xml-p)
+ (page-format page ">")
+ (page-format page "/>"))))))
(defmethod tag-render-endtag ((tag tag) (page page))
(let ((tagname (tag-name tag))
+ (id (htcomponent-client-id tag))
+ (jsonp (page-json-id-list page))
(previous-tagname (page-lasttag page))
(emptyp (htcomponent-empty tag)))
- (when (null emptyp)
+ (when (and (null emptyp) (not (and jsonp
+ (string= id (first (page-json-component-id-list page))))))
(progn
(decf (page-tabulator page))
(if (string= tagname previous-tagname)
@@ -906,8 +939,8 @@
(dolist (element body)
(when element
(cond
- ((stringp element) (htcomponent-render ($> element) page))
- ((functionp element) (htcomponent-render ($> (funcall element)) page))
+ ((stringp element) (htcomponent-render ($raw> element) page))
+ ((functionp element) (htcomponent-render ($raw> (funcall element)) page))
(t (htcomponent-render element page)))))
(if (null xml-p)
(page-format page "~%//-->")
@@ -952,20 +985,22 @@
((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
(t (htcomponent-render child-tag page)))))
(when (page-can-print page)
- (htcomponent-render (htbody-init-scripts-tag page) page)
+ (htcomponent-render (htbody-init-scripts-tag page t) page)
(tag-render-endtag htbody page))
(when (or (page-can-print page) previous-print-status)
(setf (page-can-print page) nil)
(htcomponent-json-print-end-component htbody))))
-(defmethod htbody-init-scripts-tag ((page page))
+(defmethod htbody-init-scripts-tag ((page page) &optional on-load)
(let ((js (script> :type "text/javascript"))
- (js-start-directive (if (msie-p)
- "window.attachEvent\('onload', function\(e) {"
- "document.addEventListener\('DOMContentLoaded', function\(e) {"))
- (js-end-directive (if (msie-p)
- "});"
- "}, false);"))
+ (js-start-directive (if on-load (if (msie-p)
+ "window.attachEvent\('onload', function\(e) {"
+ "document.addEventListener\('DOMContentLoaded', function\(e) {")
+ ""))
+ (js-end-directive (if on-load (if (msie-p)
+ "});"
+ "}, false);")
+ ""))
(page-body-init-scripts (page-body-init-scripts page)))
(setf (htcomponent-page js) page
(htcomponent-body js) (when page-body-init-scripts
@@ -982,6 +1017,9 @@
:accessor wcomponent-reserved-parameters
:type cons
:documentation "Parameters that may not be used in the constructor function")
+ (json-error-monitor-p :initarg :json-error-monitor-p
+ :accessor htcomponent-json-error-monitor-p
+ :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.")
(informal-parameters :initform ()
:accessor wcomponent-informal-parameters
:type cons
Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp (original)
+++ trunk/main/claw-core/src/validators.lisp Sat May 24 13:18:39 2008
@@ -39,44 +39,47 @@
(decode-local-time local-time)
(declare (ignore nsec))
(loop for result = "" then (concatenate 'string result (if (stringp element)
- element
- (ccase element
- (:second (format nil "~2,'0D" sec))
- (:minute (format nil "~2,'0D" min))
- (:hour (format nil "~2,'0D" hour))
- (:date (format nil "~2,'0D" day))
- (:month (format nil "~2,'0D" month))
- (:year (format nil "~4,'0D" year)))))
+ element
+ (ccase element
+ (:second (format nil "~2,'0D" sec))
+ (:minute (format nil "~2,'0D" min))
+ (:hour (format nil "~2,'0D" hour))
+ (:date (format nil "~2,'0D" day))
+ (:month (format nil "~2,'0D" month))
+ (:year (format nil "~4,'0D" year)))))
for element in format
finally (return result))))
(defun add-exception (id reason)
-"Adds an exception for the given input component identified by its ID with the message expressed by REASON"
- (let* ((validation-errors (aux-request-value :validation-errors))
- (component-exceptions (assoc id validation-errors :test #'equal)))
- (if component-exceptions
- (setf (cdr component-exceptions) (append (cdr component-exceptions) (list reason)))
- (if validation-errors
- (setf (aux-request-value :validation-errors) (append validation-errors (list (cons id (list reason)))))
- (setf (aux-request-value :validation-errors) (list (cons id (list reason))))))))
-
+ "Adds an exception for the given input component identified by its ID with the message expressed by REASON"
+ (let* ((validation-errors (validation-errors))
+ (symbol-id (make-symbol id))
+ (errors (getf validation-errors symbol-id)))
+ (setf (getf validation-errors symbol-id) (nconc errors (list reason))
+ (validation-errors *request*) validation-errors)))
+
+(defun component-exceptions (id)
+ "Returns a list of exception connectd to the given component"
+ (let ((symbol-id (make-symbol id)))
+ (getf (validation-errors) symbol-id)))
(defun validate (test &key component message)
-"When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..."
+ "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..."
(let ((client-id (htcomponent-client-id component)))
- (unless test
- (add-exception client-id message))))
+ (if test
+ (add-validation-compliance client-id)
+ (add-exception client-id message))))
(defun validate-required (component value)
- "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATE-REQUIRED\".
+ "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\".
The argument for the message will be the :label attribute of the COMPONENT."
(when (stringp value)
(validate (and value (string-not-equal value ""))
- :component component
- :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be null.") (label component)))))
+ :component component
+ :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component)))))
(defun validate-size (component value &key min-size max-size)
-"Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
+ "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value.
If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\".
@@ -86,64 +89,64 @@
(setf value (format nil "~a" value))
(setf value-len (length value))
(and (= value-len 0)
- (when min-size
- (validate (>= value-len min-size)
- :component component
- :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
- (label component)
- min-size)))
- (when max-size
- (validate (<= value-len max-size)
- :component component
- :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
- (label component)
- max-size)))))))
+ (when min-size
+ (validate (>= value-len min-size)
+ :component component
+ :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
+ (label component)
+ min-size)))
+ (when max-size
+ (validate (<= value-len max-size)
+ :component component
+ :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
+ (label component)
+ max-size)))))))
(defun validate-range (component value &key min max)
-"Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX.
+ "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX.
If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the :MIN value.
If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\".
The argument for the message will be the :label attribute of the COMPONENT and the :MAX value."
(when value
(and (when min
- (validate (>= value min)
- :component component
- :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
- (label component)
- (if (typep min 'ratio)
- (coerce min 'float)
- min))))
- (when max
- (validate (<= value max)
- :component component
- :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
- (label component)
- (if (typep max 'ratio)
- (coerce max 'float)
- max)))))))
+ (validate (>= value min)
+ :component component
+ :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
+ (label component)
+ (if (typep min 'ratio)
+ (coerce min 'float)
+ min))))
+ (when max
+ (validate (<= value max)
+ :component component
+ :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
+ (label component)
+ (if (typep max 'ratio)
+ (coerce max 'float)
+ max)))))))
(defun validate-number (component value &key min max)
-"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
+ "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\".
The argument for the message will be the :label attribute of the COMPONENT."
(when value
(let ((test (numberp value)))
(and (validate test
- :component component
- :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))
- (validate-range component value :min min :max max)))))
+ :component component
+ :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))
+ (validate-range component value :min min :max max)))))
(defun validate-integer (component value &key min max)
-"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
+ "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\".
The argument for the message will be the :label attribute of the COMPONENT."
(when value
(let ((test (integerp value)))
(and (validate test
- :component component
- :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))
- (validate-range component value :min min :max max)))))
+ :component component
+ :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))
+ (validate-range component value :min min :max max)))))
(defun validate-date-range (component value &key min max (use-date-p t) use-time-p)
@@ -157,64 +160,69 @@
The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword."
(unless (component-validation-errors component)
(let ((local-time-format '(:date "-" :month "-" :year))
- (new-value (make-instance 'local-time
- :nsec (nsec-of value)
- :sec (sec-of value)
- :day (day-of value)
- :timezone (timezone-of value))))
+ (new-value (make-instance 'local-time
+ :nsec (nsec-of value)
+ :sec (sec-of value)
+ :day (day-of value)
+ :timezone (timezone-of value))))
(when (and use-date-p (not use-time-p))
- (setf (local-time:nsec-of new-value) 0
- (local-time:sec-of new-value) 0)
- (when min
- (setf (local-time:nsec-of min) 0
- (local-time:sec-of min) 0))
- (when max
- (setf (local-time:nsec-of max) 0
- (local-time:sec-of max) 0)))
+ (setf (local-time:nsec-of new-value) 0
+ (local-time:sec-of new-value) 0)
+ (when min
+ (setf (local-time:nsec-of min) 0
+ (local-time:sec-of min) 0))
+ (when max
+ (setf (local-time:nsec-of max) 0
+ (local-time:sec-of max) 0)))
(when (and (not use-date-p) use-time-p)
- (setf (local-time:day-of new-value) 0)
- (when min
- (setf (local-time:day-of min) 0))
- (when max
- (setf (local-time:day-of max) 0)))
+ (setf (local-time:day-of new-value) 0)
+ (when min
+ (setf (local-time:day-of min) 0))
+ (when max
+ (setf (local-time:day-of max) 0)))
(and (when min
- (validate (local-time> new-value min)
- :component component
- :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
- (label component)
- (local-time-to-string min local-time-format))))
- (when max
- (validate (local-time< new-value max)
- :component component
- :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
- (label component)
- (local-time-to-string max local-time-format))))))))
-
+ (validate (local-time> new-value min)
+ :component component
+ :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
+ (label component)
+ (local-time-to-string min local-time-format))))
+ (when max
+ (validate (local-time< new-value max)
+ :component component
+ :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
+ (label component)
+ (local-time-to-string max local-time-format))))))))
+
;; ------------------------------------------------------------------------------------
(defclass exception-monitor (wcomponent) ()
(:metaclass metacomponent)
- (:default-initargs :empty t)
+ (:default-initargs :json-render-on-validation-errors-p t)
(:documentation "If from submission contains exceptions. It displays exception messages"))
(let ((class (find-class 'exception-monitor)))
(closer-mop:ensure-finalized class)
(setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function)
- (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a"
- "If from submission contains exceptions. It displays exception messages with a <ul> list"
- *id-and-static-id-description*
- (describe-html-attributes-from-class-slot-initargs class)
- (describe-component-behaviour class))))
+ (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a"
+ "If from submission contains exceptions. It displays exception messages with a <ul> list"
+ *id-and-static-id-description*
+ (describe-html-attributes-from-class-slot-initargs class)
+ (describe-component-behaviour class))))
(defmethod wcomponent-template ((exception-monitor exception-monitor))
(let ((client-id (htcomponent-client-id exception-monitor))
- (validation-errors (aux-request-value :validation-errors)))
- (when validation-errors
- (ul> :static-id client-id
- (wcomponent-informal-parameters exception-monitor)
- (loop for component-exceptions in validation-errors
- collect (loop for message in (cdr component-exceptions)
- collect (li> message)))))))
+ (validation-errors (validation-errors))
+ (body (htcomponent-body exception-monitor)))
+ (div> :static-id client-id
+ (wcomponent-informal-parameters exception-monitor)
+ (when validation-errors
+ (if body
+ body
+ (ul>
+ (loop for component-exceptions in (rest validation-errors) by #'cddr
+ do (loop for message in component-exceptions
+ collect (li> message)))))))))
+
;;-------------------------------------------------------------------------------------------
1
0
Author: achiumenti
Date: Tue May 13 11:23:32 2008
New Revision: 47
Modified:
trunk/main/claw-core/src/lisplet.lisp
Log:
corrected authorization logic
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Tue May 13 11:23:32 2008
@@ -264,16 +264,16 @@
;(when (lisplet-redirect-protected-resources-p lisplet)
;(redirect-to-https server request))
(cond
+ ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
+ (setf (return-code) +http-forbidden+)
+ (throw 'handler-done nil))
((and (null princp) auth-basicp)
(setf (return-code) +http-authorization-required+
(header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))))
(throw 'handler-done nil))
((and (null princp) (null auth-basicp) (not (string= login-page-url uri)))
(redirect-to-https server request login-page-url)
- (throw 'handler-done nil))
- ((and (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
- (setf (return-code) +http-forbidden+)
- (throw 'handler-done nil))
+ (throw 'handler-done nil))
#-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*)))
(redirect-to-https server request)
(throw 'handler-done nil))))))))
1
0
13 May '08
Author: achiumenti
Date: Tue May 13 09:32:43 2008
New Revision: 46
Modified:
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
corrected authorization logic
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Tue May 13 09:32:43 2008
@@ -99,42 +99,42 @@
(setf *http-error-handler*
;;overrides the default hunchentoot error handling
#'(lambda (error-code)
- (let* ((error-handlers (if (current-lisplet)
- (lisplet-error-handlers (current-lisplet))
- (make-hash-table)))
- (handler (gethash error-code error-handlers)))
- (if handler
- (funcall handler)
- (let ((error-page (make-instance 'error-page
- :title (format nil "Server error: ~a" error-code)
- :error-code error-code)))
- (with-output-to-string (*standard-output*) (page-render error-page)))))))
+ (let* ((error-handlers (if (current-lisplet)
+ (lisplet-error-handlers (current-lisplet))
+ (make-hash-table)))
+ (handler (gethash error-code error-handlers)))
+ (if handler
+ (funcall handler)
+ (let ((error-page (make-instance 'error-page
+ :title (format nil "Server error: ~a" error-code)
+ :error-code error-code)))
+ (with-output-to-string (*standard-output*) (page-render error-page)))))))
(defclass lisplet (i18n-aware)
((base-path :initarg :base-path
- :reader lisplet-base-path
- :documentation "common base path all resources registered into this lisplet")
+ :reader lisplet-base-path
+ :documentation "common base path all resources registered into this lisplet")
(welcome-page :initarg :welcome-page
- :accessor lisplet-welcome-page
- :documentation "url location for the welcome page")
+ :accessor lisplet-welcome-page
+ :documentation "url location for the welcome page")
(login-page :initarg :login-page
- :accessor lisplet-login-page
- :documentation "url location for the welcome page")
+ :accessor lisplet-login-page
+ :documentation "url location for the welcome page")
(realm :initarg :realm
- :reader lisplet-realm
- :documentation "realm for requests that pass through this lisplet and session opened into this lisplet")
+ :reader lisplet-realm
+ :documentation "realm for requests that pass through this lisplet and session opened into this lisplet")
(pages :initform nil
- :accessor lisplet-pages
- :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher")
+ :accessor lisplet-pages
+ :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher")
(error-handlers :initform (make-hash-table)
- :accessor lisplet-error-handlers
- :documentation "An hash table where keys are http error codes and values are functions with no parameters")
+ :accessor lisplet-error-handlers
+ :documentation "An hash table where keys are http error codes and values are functions with no parameters")
(protected-resources :initform nil
- :accessor lisplet-protected-resources
- :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location")
+ :accessor lisplet-protected-resources
+ :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location")
(redirect-protected-resources-p :initarg :redirect-protected-resources-p
- :accessor lisplet-redirect-protected-resources-p
- :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
+ :accessor lisplet-redirect-protected-resources-p
+ :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used"))
(:default-initargs :welcome-page nil
:login-page nil
:realm "claw"
@@ -144,19 +144,19 @@
(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet))
(let ((dispatchers (clawserver-dispatchers clawserver))
- (location (lisplet-base-path lisplet)))
+ (location (lisplet-base-path lisplet)))
(setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location
- (cons location
- #'(lambda ()
- (progn
- (setf (current-realm *request*) (lisplet-realm lisplet)
- (current-lisplet) lisplet)
- (lisplet-dispatch-method lisplet))))
- dispatchers)))))
+ (cons location
+ #'(lambda ()
+ (progn
+ (setf (current-realm *request*) (lisplet-realm lisplet)
+ (current-lisplet) lisplet)
+ (lisplet-dispatch-method lisplet))))
+ dispatchers)))))
(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
(let ((dispatchers (clawserver-dispatchers clawserver))
- (location (lisplet-base-path lisplet)))
+ (location (lisplet-base-path lisplet)))
(remove-by-location location dispatchers)))
@@ -172,7 +172,7 @@
(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
(let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
- (sort-by-location (pushnew-location (cons location function) pages)))
+ (sort-by-location (pushnew-location (cons location function) pages)))
(when welcome-page-p
(setf (lisplet-welcome-page lisplet) location))
(when login-page-p
@@ -180,102 +180,100 @@
(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p)
(lisplet-register-function-location lisplet
- #'(lambda () (with-output-to-string (*standard-output*)
- (page-render (make-instance page-class :lisplet lisplet :url location))))
- location
- :welcome-page-p welcome-page-p
- :login-page-p login-page-p))
+ #'(lambda () (with-output-to-string (*standard-output*)
+ (page-render (make-instance page-class :lisplet lisplet :url location))))
+ location
+ :welcome-page-p welcome-page-p
+ :login-page-p login-page-p))
(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
(let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
- (sort-by-location (pushnew-location
- (cons location
- (if (directory-pathname-p resource-path)
- #'(lambda ()
- (let ((resource-full-path (merge-pathnames
- (uri-to-pathname (subseq (script-name)
- (+ (length (clawserver-base-path (current-server)))
- (length (lisplet-base-path (lisplet-base-path lisplet))))))
- resource-path)))
- (handle-static-file resource-full-path content-type)))
- #'(lambda () (handle-static-file resource-path content-type))))
- pages)))))
+ (sort-by-location (pushnew-location
+ (cons location
+ (if (directory-pathname-p resource-path)
+ #'(lambda ()
+ (let ((resource-full-path (merge-pathnames
+ (uri-to-pathname (subseq (script-name)
+ (+ (length (clawserver-base-path (current-server)))
+ (length (lisplet-base-path (lisplet-base-path lisplet))))))
+ resource-path)))
+ (handle-static-file resource-full-path content-type)))
+ #'(lambda () (handle-static-file resource-path content-type))))
+ pages)))))
(defmethod lisplet-dispatch-request ((lisplet lisplet))
(let ((dispatchers (lisplet-pages lisplet))
- (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet))))))
+ (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet))))))
(loop for dispatcher in dispatchers
- for url = (car dispatcher)
- for action = (cdr dispatcher)
- do (cond
- ((and (string< url rel-script-name)
- (null (starts-with-subseq rel-script-name url))) (return nil))
- ((starts-with-subseq rel-script-name url) (return (funcall action)))))))
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (cond
+ ((and (string< url rel-script-name)
+ (null (starts-with-subseq rel-script-name url))) (return nil))
+ ((starts-with-subseq rel-script-name url) (return (funcall action)))))))
(defmethod lisplet-dispatch-method ((lisplet lisplet))
(let ((base-path (build-lisplet-location lisplet))
- (uri (script-name))
- (welcome-page (lisplet-welcome-page lisplet)))
+ (uri (script-name))
+ (welcome-page (lisplet-welcome-page lisplet)))
(lisplet-check-authorization lisplet)
- (when (= (return-code) +http-ok+)
- (if (and welcome-page (string= uri base-path))
- (page-render (lisplet-welcome-page lisplet))
- (lisplet-dispatch-request lisplet)))))
+ (when (= (return-code) +http-ok+)
+ (if (and welcome-page (string= uri base-path))
+ (page-render (lisplet-welcome-page lisplet))
+ (lisplet-dispatch-request lisplet)))))
(defmethod lisplet-protect ((lisplet lisplet) location roles)
(let ((protected-resources (lisplet-protected-resources lisplet)))
(setf (lisplet-protected-resources lisplet)
- (sort-protected-resources (pushnew-location
- (cons location roles)
- protected-resources)))))
-
-(defun redirect-to-https (server request)
- "Redirects a request sent through http using https"
- (cond
- ((= (server-port request) (clawserver-port server))
- (progn
- (redirect (request-uri request)
- :port (clawserver-sslport server)
- :protocol :HTTPS)
- (throw 'handler-done nil)))
- ((= (server-port request) *apache-http-port*)
- (progn
- (redirect (request-uri request)
- :port *apache-https-port*
- :protocol :HTTPS)
- (throw 'handler-done nil)))))
+ (sort-protected-resources (pushnew-location
+ (cons location roles)
+ protected-resources)))))
+
+(defun redirect-to-https (server request &optional uri)
+ "Redirects a request sent through http using https"
+ (let ((path (or uri (request-uri request)))
+ (port (server-port request))
+ (protocol :http))
+ #-:hunchentoot-no-ssl (when (or (clawserver-mod-lisp-p server)
+ (clawserver-ssl-certificate-file server))
+ (setf protocol :https
+ port (if (clawserver-mod-lisp-p server)
+ *apache-https-port*
+ (clawserver-sslport server))))
+ (redirect path :port port :protocol protocol)))
(defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*))
- (let ((uri (script-name request))
- (base-path (build-lisplet-location lisplet))
- (protected-resources (lisplet-protected-resources lisplet))
- (princp (current-principal))
- (login-config (current-config))
- (login-page (lisplet-login-page lisplet))
- (server (current-server request))
- (auth-basicp (eq (lisplet-authentication-type lisplet) :basic)))
+ (let* ((uri (script-name request))
+ (base-path (build-lisplet-location lisplet))
+ (protected-resources (lisplet-protected-resources lisplet))
+ (princp (current-principal))
+ (login-config (current-config))
+ (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet)))
+ (server (current-server request))
+ (auth-basicp (eq (lisplet-authentication-type lisplet) :basic)))
(setf (return-code) +http-ok+)
(when login-config
(when (and auth-basicp (null princp))
- (configuration-login login-config))
+ (configuration-login login-config))
(setf princp (current-principal))
- (when (and login-page
- (cl-ppcre:all-matches login-page uri))
- (redirect-to-https server request))
(loop for protected-resource in protected-resources
- for match = (format nil "~a~a" base-path (car protected-resource))
- for allowed-roles = (cdr protected-resource)
- do (when (starts-with-subseq match uri)
- (when (lisplet-redirect-protected-resources-p lisplet)
- (redirect-to-https server request))
- (if (null princp)
- (progn
- (when auth-basicp
- (setf (header-out "WWW-Authenticate")
- (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))))
- (setf (return-code) +http-authorization-required+)
- (throw 'handler-done nil))
- (unless (user-in-role-p allowed-roles)
- (setf (return-code) +http-forbidden+)
- (throw 'handler-done nil))))))))
+ for match = (format nil "~a/~a" base-path (car protected-resource))
+ for allowed-roles = (cdr protected-resource)
+ do (when (or (starts-with-subseq match uri) (string= login-page-url uri))
+ ;(when (lisplet-redirect-protected-resources-p lisplet)
+ ;(redirect-to-https server request))
+ (cond
+ ((and (null princp) auth-basicp)
+ (setf (return-code) +http-authorization-required+
+ (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))))
+ (throw 'handler-done nil))
+ ((and (null princp) (null auth-basicp) (not (string= login-page-url uri)))
+ (redirect-to-https server request login-page-url)
+ (throw 'handler-done nil))
+ ((and (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri)))
+ (setf (return-code) +http-forbidden+)
+ (throw 'handler-done nil))
+ #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*)))
+ (redirect-to-https server request)
+ (throw 'handler-done nil))))))))
Modified: trunk/main/claw-core/src/server.lisp
==============================================================================
--- trunk/main/claw-core/src/server.lisp (original)
+++ trunk/main/claw-core/src/server.lisp Tue May 13 09:32:43 2008
@@ -379,18 +379,20 @@
(let ((base-path (clawserver-base-path clawserver))
(dispatchers (clawserver-dispatchers clawserver))
(script-name (script-name))
- (rel-script-name))
+ (rel-script-name)
+ (rel-script-name-libs))
(setf (current-server) clawserver)
(when (starts-with-subseq script-name base-path)
- (setf rel-script-name (subseq script-name (length base-path)))
+ (setf rel-script-name (subseq script-name (length base-path))
+ rel-script-name-libs (subseq script-name (1+ (length base-path))))
(or
(loop for dispatcher in *claw-libraries-resources*
for url = (car dispatcher)
for action = (cdr dispatcher)
do (cond
- ((and (string< url rel-script-name)
- (null (starts-with-subseq rel-script-name url))) (return nil))
- ((starts-with-subseq rel-script-name url) (return (funcall action)))))
+ ((and (string< url rel-script-name-libs)
+ (null (starts-with-subseq rel-script-name-libs url))) (return nil))
+ ((starts-with-subseq rel-script-name-libs url) (return (funcall action)))))
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Tue May 13 09:32:43 2008
@@ -37,8 +37,8 @@
(or #.*compile-file-pathname* *load-pathname*)))
-(register-library-resource "/libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img"))))
-(register-library-resource "/libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
+(register-library-resource "libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img"))))
+(register-library-resource "libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
(defvar *lisplet-messages*
(make-instance 'simple-message-dispatcher))
@@ -55,23 +55,23 @@
(defvar *test-lisplet*)
(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test"
- :redirect-protected-resources-p t))
+ :redirect-protected-resources-p t))
(defvar *test-lisplet2*)
(setf *test-lisplet2* (make-instance 'lisplet :realm "test2"
- :base-path "/test2"))
+ :base-path "/test2"))
;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw"))
(defvar *clawserver* (make-instance 'clawserver
- :port 4242
- :sslport 4445
- :base-path "/claw"
- :mod-lisp-p nil
- :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem"
- :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem"))
+ :port 4242
+ :sslport 4445
+ :base-path "/claw"
+ :mod-lisp-p nil
+ :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem"
+ :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem"))
-;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t)
+ ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t)
(clawserver-register-lisplet *clawserver* *test-lisplet*)
(clawserver-register-lisplet *clawserver* *test-lisplet2*)
@@ -80,7 +80,7 @@
(declare (ignore request))
(let ((session *session*))
(when (and (string-equal user "kiuma")
- (string-equal password "password"))
+ (string-equal password "password"))
(setf (current-principal session) (make-instance 'principal :name user :roles '("user"))))))
@@ -90,14 +90,14 @@
(defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*))
(let ((lisplet (current-lisplet request)))
(multiple-value-bind (user password)
- (if (eq (lisplet-authentication-type lisplet) :basic)
- (authorization)
- (values (aux-request-value 'user request)
- (aux-request-value 'password request)))
+ (if (eq (lisplet-authentication-type lisplet) :basic)
+ (authorization)
+ (values (aux-request-value 'user request)
+ (aux-request-value 'password request)))
(test-configuration-do-login request user password))))
(clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration))
-
+
(defun claw-tst-start ()
@@ -111,7 +111,7 @@
(defclass site-template (wcomponent)
((title :initarg :title
- :reader title))
+ :reader title))
(:metaclass metacomponent))
(defmethod wcomponent-template ((o site-template))
@@ -120,7 +120,7 @@
(title>
(title o))
(style> :type "text/css"
-"input.error {
+ "input.error {
background-color: #FF9999;
}
"))
@@ -136,37 +136,41 @@
(defclass auth-page (page) ())
(defmethod page-content ((page auth-page))
(site-template> :title "Unauth test page"
- (p> "protected content")))
-(lisplet-register-page-location *test-lisplet* 'auth-page "/unauth.html")
-(lisplet-register-page-location *test-lisplet* 'auth-page "/auth.html")
-(lisplet-protect *test-lisplet* "/auth.html" '("admin" "user"))
-(lisplet-protect *test-lisplet* "/unauth.html" '("nobody"))
+ (p> "protected content")))
+(lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html")
+(lisplet-register-page-location *test-lisplet* 'auth-page "auth.html")
+(lisplet-protect *test-lisplet* "auth.html" '("admin" "user"))
+(lisplet-protect *test-lisplet* "unauth.html" '("nobody"))
(defclass index-page (page) ())
-(defmethod page-content ((o index-page))
- (site-template> :title "Home test page"
- (p> :id "p"
- (ul>
- (li> (a> :href "login.html"
- "Do login"))
- (li> (a> :href "info.html"
- "Headers info"))
- (li> (a> :href (format nil "~a/libs/images/matrix.jpg" (clawserver-base-path (current-server)))
- "show static file provided by CLAW-TESTS package"))
- (li> (a> :href "images/matrix.jpg"
- "show static file"))
- (li> (a> :href "images/matrix2.jpg"
- "show file by function"))
- (li> (a> :href "../test/realm.html" :target "clwo1"
- "realm on lisplet 'test'"))
- (li> (a> :href "../test2/realm.html" :target "clwo2"
- "realm on lisplet 'test2'"))
- (li> (a> :href "id-tests.html" "id generation test"))
- (li> (a> :href "form.html" "form components test"))
- (li> (a> :href "auth.html" "authorized page"))
- (li> (a> :href "unauth.html" "unauthorized page"))))))
-(lisplet-register-page-location *test-lisplet* 'index-page "/index.html" :welcome-page-p t)
+(defmethod page-content ((o index-page))
+ (let ((clawserver-base-path (clawserver-base-path (current-server))))
+ (site-template> :title "Home test page"
+ (p> :id "p"
+ (ul>
+ (li> (a> :href "login.html"
+ "Do login"))
+ (li> (a> :href "info.html"
+ "Headers info"))
+ (li> (a> :href (format nil "~a/libs/images/matrix.jpg" clawserver-base-path)
+ "show static file provided by CLAW-TESTS package by folder"))
+ (li> (a> :href (format nil "~a/libs/img.jpg" clawserver-base-path)
+ "show static file provided by CLAW-TESTS package by file"))
+ (li> (a> :href "images/matrix.jpg"
+ "show static file"))
+ (li> (a> :href "images/matrix2.jpg"
+ "show file by function"))
+ (li> (a> :href "../test/realm.html" :target "clwo1"
+ "realm on lisplet 'test'"))
+ (li> (a> :href "../test2/realm.html" :target "clwo2"
+ "realm on lisplet 'test2'"))
+ (li> (a> :href "id-tests.html" "id generation test"))
+ (li> (a> :href "form.html" "form components test"))
+ (li> (a> :href "auth.html" "authorized page"))
+ (li> (a> :href "unauth.html" "unauthorized page")))))))
+
+(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t)
(defclass msie-p (wcomponent)
()
@@ -179,43 +183,43 @@
(defmethod htcomponent-instance-initscript ((msie-p msie-p))
(let ((id (htcomponent-client-id msie-p)))
(format nil "document.getElementById('~a').innerHTML = '~a';"
- id
- (if (msie-p)
- "The browser is MSIE"
- "The browser is not MSIE"))))
+ id
+ (if (msie-p)
+ "The browser is MSIE"
+ "The browser is not MSIE"))))
(defclass info-page (page) ())
(defmethod page-content ((o info-page))
(let ((header-props (headers-in)))
(site-template> :title "Header info page"
- (p> :id "p"
- (table>
- (tr> (td> :colspan "2" "Header info"))
- (loop for key-val in header-props
- collect (tr>
- (td> (format nil "~a" (car key-val))
- (td> (format nil "~a" (cdr key-val))))))))
- (msie-p> :id "msie"))))
+ (p> :id "p"
+ (table>
+ (tr> (td> :colspan "2" "Header info"))
+ (loop for key-val in header-props
+ collect (tr>
+ (td> (format nil "~a" (car key-val))
+ (td> (format nil "~a" (cdr key-val))))))))
+ (msie-p> :id "msie"))))
-(lisplet-register-page-location *test-lisplet* 'info-page "/info.html")
+(lisplet-register-page-location *test-lisplet* 'info-page "info.html")
(defun test-image-file ()
(make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
-(lisplet-register-resource-location *test-lisplet* (test-image-file) "/images/matrix.jpg" "image/jpeg")
+(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg")
(lisplet-register-function-location *test-lisplet*
- (lambda ()
- (let ((path (test-image-file)))
- (setf (hunchentoot:content-type) (hunchentoot:mime-type path))
- (with-open-file (in path :element-type 'flex:octet)
- (let ((image-data (make-array (file-length in)
- :element-type 'flex:octet)))
- (read-sequence image-data in)
- image-data))))
- "/images/matrix2.jpg" )
+ (lambda ()
+ (let ((path (test-image-file)))
+ (setf (hunchentoot:content-type) (hunchentoot:mime-type path))
+ (with-open-file (in path :element-type 'flex:octet)
+ (let ((image-data (make-array (file-length in)
+ :element-type 'flex:octet)))
+ (read-sequence image-data in)
+ image-data))))
+ "images/matrix2.jpg" )
;;;--------------------realm test page--------------------------------
(defclass realm-page (page) ())
@@ -224,54 +228,54 @@
(claw-start-session))
(unless (session-value 'RND-NUMBER)
(setf (session-value 'RND-NUMBER) (random 1000)))
- (site-template> :title "Realm test page"
- (p>
- "session"
- (ul>
- (li> (a> :href "http://www.gentoo.org" :target "gentoo"
- "gentoo"))
- (li> (a> :href "../test/realm.html" :target "clwo1"
- "realm on lisplet 'test'"))
- (li> (a> :href "../test2/realm.html" :target "clwo2"
- "realm on lisplet 'test2'"))
- (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER)))
- (li> "Remote Addr: " (session-remote-addr *session*))
- (li> "User agent: " (session-user-agent *session*))
- (li> "Lisplet Realm: " (current-realm))
- (li> "Session Realm: " (session-realm *session*))
- (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*)))
- (li> "Request Realm: " (hunchentoot::realm *request*))))))
+ (site-template> :title "Realm test page"
+ (p>
+ "session"
+ (ul>
+ (li> (a> :href "http://www.gentoo.org" :target "gentoo"
+ "gentoo"))
+ (li> (a> :href "../test/realm.html" :target "clwo1"
+ "realm on lisplet 'test'"))
+ (li> (a> :href "../test2/realm.html" :target "clwo2"
+ "realm on lisplet 'test2'"))
+ (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER)))
+ (li> "Remote Addr: " (session-remote-addr *session*))
+ (li> "User agent: " (session-user-agent *session*))
+ (li> "Lisplet Realm: " (current-realm))
+ (li> "Session Realm: " (session-realm *session*))
+ (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*)))
+ (li> "Request Realm: " (hunchentoot::realm *request*))))))
-(lisplet-register-page-location *test-lisplet* 'realm-page "/realm.html")
-(lisplet-register-page-location *test-lisplet2* 'realm-page "/realm.html")
+(lisplet-register-page-location *test-lisplet* 'realm-page "realm.html")
+(lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html")
;;;--------------------id testing page--------------------------------
(defclass id-tests-page (page) ())
(defmethod page-content ((o id-tests-page))
(let ((uid (generate-id "uid"))
- (uid2 (generate-id "uid")))
+ (uid2 (generate-id "uid")))
(site-template> :title "a page title"
- "\"<escaping>test\""
- (hr>)
- (div> :id "foo" :class "goo"
- :onclick "this.innerHTML = this.id"
- :style "cursor: pointer;"
- "passed id: 'foo'[click me, to see generated id]")
- (div> :id "foo"
- :onclick "this.innerHTML = this.id"
- :style "cursor: pointer;"
- "passed id: 'foo'[click me, to see generated id]")
- (div> :static-id uid
- :onclick "this.innerHTML = this.id"
- :style "cursor: pointer;"
- "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")
- (div> :static-id uid2
- :onclick "this.innerHTML = this.id"
- :style "cursor: pointer;"
- "passed id: 'uid' (generated with generate-id)[click me, to see generated id]"))))
+ "\"<escaping>test\""
+ (hr>)
+ (div> :id "foo" :class "goo"
+ :onclick "this.innerHTML = this.id"
+ :style "cursor: pointer;"
+ "passed id: 'foo'[click me, to see generated id]")
+ (div> :id "foo"
+ :onclick "this.innerHTML = this.id"
+ :style "cursor: pointer;"
+ "passed id: 'foo'[click me, to see generated id]")
+ (div> :static-id uid
+ :onclick "this.innerHTML = this.id"
+ :style "cursor: pointer;"
+ "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")
+ (div> :static-id uid2
+ :onclick "this.innerHTML = this.id"
+ :style "cursor: pointer;"
+ "passed id: 'uid' (generated with generate-id)[click me, to see generated id]"))))
-(lisplet-register-page-location *test-lisplet* 'id-tests-page "/id-tests.html")
+(lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html")
;;;--------------------from components testing page--------------------------------
@@ -280,77 +284,77 @@
(defclass login-page (page)
((username :initform ""
- :accessor login-page-username)
+ :accessor login-page-username)
(passowrd :initform ""
- :accessor login-page-password))
+ :accessor login-page-password))
(:default-initargs :message-dispatcher *lisplet-messages*))
(defmethod page-content ((login-page login-page))
(let ((princp (current-principal)))
(site-template> :title "a page title"
- (if (null princp)
- (cform> :id "loginform" :method "post" :action #'login-page-login
- (table>
- (tr>
- (td> "Username")
- (td>
- (cinput> :id "username"
- :type "text"
- :accessor 'login-page-username)))
- (tr>
- (td> "Password")
- (td>
- (cinput> :id "passowrd"
- :type "password"
- :accessor 'login-page-password)))
- (tr>
- (td> :colspan "2"
- (csubmit> :id "submit" :value "Login")))))
- (p>
- (with-message "WELCOME" "WELCOME") " "
- (principal-name princp)
- (a> :href "index.html" "home"))))))
+ (if (null princp)
+ (cform> :id "loginform" :method "post" :action #'login-page-login
+ (table>
+ (tr>
+ (td> "Username")
+ (td>
+ (cinput> :id "username"
+ :type "text"
+ :accessor 'login-page-username)))
+ (tr>
+ (td> "Password")
+ (td>
+ (cinput> :id "passowrd"
+ :type "password"
+ :accessor 'login-page-password)))
+ (tr>
+ (td> :colspan "2"
+ (csubmit> :id "submit" :value "Login")))))
+ (p>
+ (with-message "WELCOME" "WELCOME") " "
+ (principal-name princp)
+ (a> :href "index.html" "home"))))))
(defmethod login-page-login ((login-page login-page))
(setf (aux-request-value 'user) (login-page-username login-page)
- (aux-request-value 'password) (login-page-password login-page))
+ (aux-request-value 'password) (login-page-password login-page))
(login))
-(lisplet-register-page-location *test-lisplet* 'login-page "/login.html" :login-page-p t)
+(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t)
(defclass user ()
((name :initarg :name
- :accessor user-name)
+ :accessor user-name)
(surname :initarg :surname
- :accessor user-surname)
- (gender :initarg :gender
- :accessor user-gender)
+ :accessor user-surname)
+ (gender :initarg :gender
+ :accessor user-gender)
(age :initarg :age
- :accessor user-age)
+ :accessor user-age)
(capital :initarg :capital
- :accessor user-capital))
+ :accessor user-capital))
(:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0))
(defgeneric form-page-update-user (form-page))
(defclass form-page (page user)
((name :initarg :name
- :accessor form-page-name)
+ :accessor form-page-name)
(surname :initarg :surname
- :accessor form-page-surname)
+ :accessor form-page-surname)
(colors :initarg :colors
- :accessor form-page-colors)
+ :accessor form-page-colors)
(gender :initarg :gender
- :writer setf-gender
- :accessor form-page-gender)
+ :writer setf-gender
+ :accessor form-page-gender)
(user :initarg :user
- :accessor form-page-user)
+ :accessor form-page-user)
(age :initarg :age
- :accessor form-page-age)
+ :accessor form-page-age)
(capital :initarg :capital
- :accessor form-page-capital)
+ :accessor form-page-capital)
(birthday :initarg :birthday
- :accessor form-page-birthday))
+ :accessor form-page-birthday))
(:default-initargs :name "kiuma"
:surname "surnk"
@@ -364,118 +368,118 @@
(defmethod form-page-update-user ((form-page form-page))
(let ((user (form-page-user form-page))
- (name (form-page-name form-page))
- (surname (form-page-surname form-page))
- (gender (form-page-gender form-page))
- (age (form-page-age form-page)))
+ (name (form-page-name form-page))
+ (surname (form-page-surname form-page))
+ (gender (form-page-gender form-page))
+ (age (form-page-age form-page)))
(setf (user-name user) name
- (user-surname user) surname
- (user-gender user) gender
- (user-age user) age)))
+ (user-surname user) surname
+ (user-gender user) gender
+ (user-age user) age)))
-;(defmethod message-dispatch ((object form-page) key locale)
+ ;(defmethod message-dispatch ((object form-page) key locale)
(defmethod page-content ((o form-page))
(site-template> :title "a page title"
- (cform> :id "testform" :method "post" :action #'form-page-update-user
- (table>
- (tr>
- (td> "Name")
- (td>
- (cinput> :id "name"
- :type "text"
- :label "Name"
- :validator #'(lambda (value)
- (validate-required (page-current-component o) value))
- :accessor 'form-page-name)"*"))
- (tr> :id "messaged"
- (td> (with-message "SURNAME" "SURNAME"))
- (td>
- (cinput> :id "surname"
- :type "text"
- :label "Surname"
- :validator #'(lambda (value)
- (validate-required (page-current-component o) value)
- (validate-size (page-current-component o) value :min-size 1 :max-size 20))
- :accessor 'form-page-surname)"*"))
- (tr>
- (td> "Gender")
- (td>
- (cselect> :id "gender"
- :accessor 'form-page-gender
- (loop for gender in (list "M" "F")
- collect (option> :value gender
- (when (string= gender (form-page-gender o))
- '(:selected "selected"))
- (if (string= gender "M")
- "Male"
- "Female"))))))
- (tr>
- (td> "Age")
- (td>
- (cinput> :id "age"
- :type "text"
- :label "Age"
- :translator (make-instance 'translator-integer :thousand-separator #\')
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-required component value)
- (validate-integer component value :min 1 :max 2000)))
- :accessor 'form-page-age)"*"))
- (tr>
- (td> "Birthday")
- (td>
- (cinput> :id "bday"
- :type "text"
- :label "Birthday"
- :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year))
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
- :accessor 'form-page-birthday)"(dd-mm-yyyy)"))
- (tr>
- (td> "Capital")
- (td>
- (cinput> :id "capital"
- :type "text"
- :label "Capital"
- :translator (make-instance 'translator-number
- :decimal-digits 2
- :thousand-separator #\')
- :validator #'(lambda (value)
- (let ((component (page-current-component o)))
- (validate-required component value)
- (validate-number component value :min 1000.01 :max 500099/100)))
- :accessor 'form-page-capital)"*"))
- (tr>
- (td> "Colors")
- (td>
- (cselect> :id "colors"
- :multiple "true"
- :style "width:80px;height:120px;"
- :accessor 'form-page-colors
- (loop for color in (list "R" "G" "B")
- collect (option> :value color
- (when (find color (form-page-colors o) :test #'string=)
- '(:selected "selected"))
- (cond
- ((string= color "R") "red")
- ((string= color "G") "green")
- (t "blue")))))))
- (tr>
- (td> :colspan "2"
- (csubmit> :id "submit" :value "OK")))))
- (p>
- (exception-monitor>)
- (hr>)
- (h2> "From result:")
- (div> (format nil "Name: ~a" (user-name (form-page-user o))))
- (div> (format nil "Surname: ~a" (user-surname (form-page-user o))))
- (div> (format nil "Gender: ~a" (user-gender (form-page-user o))))
- (div> (format nil "Age: ~a" (user-age (form-page-user o)))))))
+ (cform> :id "testform" :method "post" :action #'form-page-update-user
+ (table>
+ (tr>
+ (td> "Name")
+ (td>
+ (cinput> :id "name"
+ :type "text"
+ :label "Name"
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value))
+ :accessor 'form-page-name)"*"))
+ (tr> :id "messaged"
+ (td> (with-message "SURNAME" "SURNAME"))
+ (td>
+ (cinput> :id "surname"
+ :type "text"
+ :label "Surname"
+ :validator #'(lambda (value)
+ (validate-required (page-current-component o) value)
+ (validate-size (page-current-component o) value :min-size 1 :max-size 20))
+ :accessor 'form-page-surname)"*"))
+ (tr>
+ (td> "Gender")
+ (td>
+ (cselect> :id "gender"
+ :accessor 'form-page-gender
+ (loop for gender in (list "M" "F")
+ collect (option> :value gender
+ (when (string= gender (form-page-gender o))
+ '(:selected "selected"))
+ (if (string= gender "M")
+ "Male"
+ "Female"))))))
+ (tr>
+ (td> "Age")
+ (td>
+ (cinput> :id "age"
+ :type "text"
+ :label "Age"
+ :translator (make-instance 'translator-integer :thousand-separator #\')
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-required component value)
+ (validate-integer component value :min 1 :max 2000)))
+ :accessor 'form-page-age)"*"))
+ (tr>
+ (td> "Birthday")
+ (td>
+ (cinput> :id "bday"
+ :type "text"
+ :label "Birthday"
+ :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year))
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
+ :accessor 'form-page-birthday)"(dd-mm-yyyy)"))
+ (tr>
+ (td> "Capital")
+ (td>
+ (cinput> :id "capital"
+ :type "text"
+ :label "Capital"
+ :translator (make-instance 'translator-number
+ :decimal-digits 2
+ :thousand-separator #\')
+ :validator #'(lambda (value)
+ (let ((component (page-current-component o)))
+ (validate-required component value)
+ (validate-number component value :min 1000.01 :max 500099/100)))
+ :accessor 'form-page-capital)"*"))
+ (tr>
+ (td> "Colors")
+ (td>
+ (cselect> :id "colors"
+ :multiple "true"
+ :style "width:80px;height:120px;"
+ :accessor 'form-page-colors
+ (loop for color in (list "R" "G" "B")
+ collect (option> :value color
+ (when (find color (form-page-colors o) :test #'string=)
+ '(:selected "selected"))
+ (cond
+ ((string= color "R") "red")
+ ((string= color "G") "green")
+ (t "blue")))))))
+ (tr>
+ (td> :colspan "2"
+ (csubmit> :id "submit" :value "OK")))))
+ (p>
+ (exception-monitor>)
+ (hr>)
+ (h2> "From result:")
+ (div> (format nil "Name: ~a" (user-name (form-page-user o))))
+ (div> (format nil "Surname: ~a" (user-surname (form-page-user o))))
+ (div> (format nil "Gender: ~a" (user-gender (form-page-user o))))
+ (div> (format nil "Age: ~a" (user-age (form-page-user o)))))))
-(lisplet-register-page-location *test-lisplet* 'form-page "/form.html")
+(lisplet-register-page-location *test-lisplet* 'form-page "form.html")
1
0
Author: achiumenti
Date: Mon May 12 03:10:02 2008
New Revision: 45
Modified:
trunk/main/claw-core/claw.asd
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/tags.lisp
Log:
some indentaion corrected, informal parameters rendering corrected
Modified: trunk/main/claw-core/claw.asd
==============================================================================
--- trunk/main/claw-core/claw.asd (original)
+++ trunk/main/claw-core/claw.asd Mon May 12 03:10:02 2008
@@ -33,14 +33,14 @@
:description "Common Lisp Active Web.A famework to write web applications"
:depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence)
:components ((:module src
- :components ((:file "packages")
- (:file "misc" :depends-on ("packages"))
- (:file "i18n" :depends-on ("packages"))
- (:file "locales" :depends-on ("i18n"))
- (:file "hunchentoot-overrides" :depends-on ("packages"))
- (:file "tags" :depends-on ("misc"))
- (:file "components" :depends-on ("tags"))
- (:file "validators" :depends-on ("components"))
- (:file "translators" :depends-on ("validators"))
- (:file "server" :depends-on ("components"))
- (:file "lisplet" :depends-on ("server"))))))
+ :components ((:file "packages")
+ (:file "misc" :depends-on ("packages"))
+ (:file "i18n" :depends-on ("packages"))
+ (:file "locales" :depends-on ("i18n"))
+ (:file "hunchentoot-overrides" :depends-on ("packages"))
+ (:file "tags" :depends-on ("misc"))
+ (:file "components" :depends-on ("tags"))
+ (:file "validators" :depends-on ("components"))
+ (:file "translators" :depends-on ("validators"))
+ (:file "server" :depends-on ("components"))
+ (:file "lisplet" :depends-on ("server"))))))
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Mon May 12 03:10:02 2008
@@ -204,7 +204,7 @@
(defmethod lisplet-dispatch-request ((lisplet lisplet))
(let ((dispatchers (lisplet-pages lisplet))
- (rel-script-name (subseq (script-name) (length (build-lisplet-location lisplet)))))
+ (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet))))))
(loop for dispatcher in dispatchers
for url = (car dispatcher)
for action = (cdr dispatcher)
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Mon May 12 03:10:02 2008
@@ -40,27 +40,27 @@
(defun strings-to-jsarray (strings)
"Transforms a list of strings into a javascript array."
(let ((st-size (length strings))
- (items ""))
+ (items ""))
(cond ((= st-size 0) "[]")
- ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings))))
- (t (format nil (format nil "[~a~a]"
- (prin1-to-string (first strings))
- (progn
- (dolist (str (rest strings))
- (setf items (format nil "~a,~a"
- items (prin1-to-string str))))
- items)))))))
-
+ ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings))))
+ (t (format nil (format nil "[~a~a]"
+ (prin1-to-string (first strings))
+ (progn
+ (dolist (str (rest strings))
+ (setf items (format nil "~a,~a"
+ items (prin1-to-string str))))
+ items)))))))
+
(defun sort-by-location (location-list)
"Sorts a list of location items by their first element (the location itself)."
(sort location-list #'(lambda (item1 item2)
- (string-not-lessp (first item1) (first item2)))))
+ (string-not-lessp (first item1) (first item2)))))
(defun sort-protected-resources (protected-resources)
"Sorts a list of protected resources. A protected resource is a cons where the car is the url
of the resource and the cdr is a list of roles allowhed to access that resource."
(sort protected-resources #'(lambda (item1 item2)
- (string-lessp (car item1) (car item2)))))
+ (string-lessp (car item1) (car item2)))))
(defun remove-by-location (location location-list)
"Removes an item from LOCATION-LIST checking its first element
@@ -140,54 +140,54 @@
(let ((result result-list))
(loop for element in tree
do (cond
- ((consp element) (setf result (append (nreverse (flatten element result-list)) result)))
- (t (push element result))))
+ ((consp element) (setf result (append (nreverse (flatten element result-list)) result)))
+ (t (push element result))))
(nreverse result)))
(defun msie-p (&optional (request *request*))
"Returns nil when the calling browser is not the evil of MSIE"
(let* ((header-props (headers-in request))
- (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value))))))
- (when user-agent
- (all-matches "MSIE" (string-upcase (cdr user-agent))))))
+ (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value))))))
+ (when user-agent
+ (all-matches "MSIE" (string-upcase (cdr user-agent))))))
(defmacro with-message (key &optional (default "") locale)
-"Returns a lambda function that can localize a message by its key.
+ "Returns a lambda function that can localize a message by its key.
The first message dispatching is made by the lisplet, then, if the message is not already vlorized the
computation is left to the current rendering page, then to the current rendering web component.
If the message is null after these passages the default value is used."
(let ((current-lisplet (gensym))
- (current-page (gensym))
- (current-component (gensym))
- (result (gensym))
- (key-val key)
- (locale-val (gensym))
- (default-val default))
+ (current-page (gensym))
+ (current-component (gensym))
+ (result (gensym))
+ (key-val key)
+ (locale-val (gensym))
+ (default-val default))
`#'(lambda ()
- (let ((,current-lisplet (current-lisplet))
- (,current-page (current-page))
- (,current-component (current-component))
- (,locale-val ,locale)
- (,result))
- (unless ,locale-val
- (setf ,locale-val (user-locale)))
- (when ,current-lisplet
- (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
- (when (and (null ,result) ,current-page)
- (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
- (when (and (null ,result) ,current-component)
- (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))
- (when (null ,result)
- (setf ,locale-val "")
- (when ,current-lisplet
- (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
- (when (and (null ,result) ,current-page)
- (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
- (when (and (null ,result) ,current-component)
- (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))))
- (if ,result
- ,result
- ,default-val)))))
+ (let ((,current-lisplet (current-lisplet))
+ (,current-page (current-page))
+ (,current-component (current-component))
+ (,locale-val ,locale)
+ (,result))
+ (unless ,locale-val
+ (setf ,locale-val (user-locale)))
+ (when ,current-lisplet
+ (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-page)
+ (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-component)
+ (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))
+ (when (null ,result)
+ (setf ,locale-val "")
+ (when ,current-lisplet
+ (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-page)
+ (setf ,result (message-dispatch ,current-page ,key-val ,locale-val)))
+ (when (and (null ,result) ,current-component)
+ (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))))
+ (if ,result
+ ,result
+ ,default-val)))))
(defun do-message (key &optional (default "") locale)
"This function calls the lambda function returned by the WITH-MESSAGE macro."
@@ -196,14 +196,14 @@
(defun user-locale (&optional (request *request*) (session *session*))
"This function returns the user locale. If no locale was directly set, the browser default locale is used."
(let ((locale (when session
- (session-value 'locale session))))
+ (session-value 'locale session))))
(unless locale
(setf locale (first (loop for str in (all-matches-as-strings
- "[A-Z|a-z|_]+"
- (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_"))
- collect (if (> (length str) 2)
- (string-upcase str :start 2)
- str)))))
+ "[A-Z|a-z|_]+"
+ (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_"))
+ collect (if (> (length str) 2)
+ (string-upcase str :start 2)
+ str)))))
locale))
(defun (setf user-locale) (locale &optional (session *session*))
@@ -231,12 +231,12 @@
"Returns the first class default init arg value matching matching the given INITARG"
(loop for current-initarg in initargs
do (when (eq (first current-initarg) initarg)
- (return (second current-initarg)))))
+ (return (second current-initarg)))))
(defmethod initialize-instance :after ((class metacomponent) &key)
(let* ((name (class-name class))
- (builder-function (format nil "~a>" name))
- (symbolf (find-symbol builder-function)))
+ (builder-function (format nil "~a>" name))
+ (symbolf (find-symbol builder-function)))
(unless symbolf
(setf symbolf (intern builder-function)))
(setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest)))))
@@ -245,15 +245,15 @@
"Helper function that generates documentation for wcomponent init functions"
(let* ((class-slots (closer-mop:class-direct-slots class)))
(format nil "~{~%~a~}"
- (remove-if #'null
- (reverse (loop for slot in class-slots
- collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot))))
- (when slot-initarg
- (format nil
- "- :~a ~a"
- slot-initarg
- (documentation slot 't))))))))))
-
+ (remove-if #'null
+ (reverse (loop for slot in class-slots
+ collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot))))
+ (when slot-initarg
+ (format nil
+ "- :~a ~a"
+ slot-initarg
+ (documentation slot 't))))))))))
+
(defvar *id-and-static-id-description* "- :ID The htcomponent-client-id value. CLAW can transform its value to make it univocal
- :STATIC-ID Like the :ID parameter, it sets the htcomponent-client-id instance property, but CLAW will not manage its value to manage its univocity." "Description used for describing :ID and :STATIC-ID used in claw component init functions documentation
")
@@ -261,43 +261,45 @@
(defun describe-component-behaviour (class)
"Returns the behaviour descrioption of a WCOMPONENT init function. If it allows informal parameters, body and the reserved parameters"
(let* ((initargs (closer-mop:class-default-initargs class))
- (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters)))
+ (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters)))
(format nil "Allows informal parameters: ~a~%Allows body: ~a~%Reserved parameters: ~a"
- (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters)
- "Yes"
- "No")
- (if (find-first-classdefault-initarg-value initargs :empty)
- "No"
- "Yes")
- (if reserved-parameters
- (format nil "~{:~a ~}" (eval reserved-parameters))
- "NONE"))))
+ (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters)
+ "Yes"
+ "No")
+ (if (find-first-classdefault-initarg-value initargs :empty)
+ "No"
+ "Yes")
+ (if reserved-parameters
+ (format nil "~{:~a ~}" (eval reserved-parameters))
+ "NONE"))))
(defun register-library-resource (location resource-path &optional content-type)
"Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION."
(setf *claw-libraries-resources*
- (sort-by-location (pushnew-location
- (cons location
- (if (directory-pathname-p resource-path)
- #'(lambda ()
- (let ((resource-full-path (merge-pathnames
- (uri-to-pathname (subseq (script-name)
- (+ (length (clawserver-base-path (current-server)))
- (length location))))
- resource-path)))
- (handle-static-file resource-full-path content-type)))
- #'(lambda () (handle-static-file resource-path content-type))))
- *claw-libraries-resources*))))
+ (sort-by-location (pushnew-location
+ (cons location
+ (if (directory-pathname-p resource-path)
+ #'(lambda ()
+ (let ((resource-full-path (merge-pathnames
+ (uri-to-pathname (subseq (script-name)
+ (+ (length (clawserver-base-path (current-server)))
+ (length location))))
+ resource-path)))
+ (handle-static-file resource-full-path content-type)))
+ #'(lambda () (handle-static-file resource-path content-type))))
+ *claw-libraries-resources*))))
-(defun uri-to-pathname (uri)
+(defun uri-to-pathname (uri &optional (relative t))
"Convert an URI to a pathname"
(let* ((splitted-uri (split-sequence #\/ uri))
- (directory-list (butlast splitted-uri))
- (file (first (last splitted-uri)))
- (pos (position #\. file :from-end t))
- (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) ""))
- (list (subseq file 0 pos)(subseq file (1+ pos)))
- (list file))))
- (make-pathname :directory directory-list
- :name (first file-name-and-type)
- :type (second file-name-and-type))))
+ (directory-list (butlast splitted-uri))
+ (file (first (last splitted-uri)))
+ (pos (position #\. file :from-end t))
+ (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) ""))
+ (list (subseq file 0 pos)(subseq file (1+ pos)))
+ (list file))))
+ (make-pathname :directory (if relative
+ (cons :relative directory-list)
+ (cons :absolute directory-list))
+ :name (first file-name-and-type)
+ :type (second file-name-and-type))))
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Mon May 12 03:10:02 2008
@@ -37,245 +37,248 @@
(:shadow :flatten)
(:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
(:export :*html-4.01-strict*
- :*html-4.01-transitional*
- :*html-4.01-frameset*
- :*xhtml-1.0-strict*
- :*xhtml-1.0-transitional*
- :*xhtml-1.0-frameset*
- :*default-encoding*
- :*rewind-parameter*
- :*clawserver-base-path*
- :*apache-http-port*
- :*apache-https-port*
- :*empty-tags*
- :tag-emptyp
- :strings-to-jsarray
- :empty-string-p
- :build-tagf
- :page
- :message-dispatch
- :page-lisplet
- :page-current-form
- :page-req-parameter
- :page-script-files
- :page-stylesheet-files
- :page-class-initscripts
- :page-instance-initscripts
- :page-current-component
- :htcomponent
- :htcomponent-page
- :htcomponent-body
- :htcomponent-empty
- :htcomponent-client-id
- :htcomponent-script-files
- :htcomponent-stylesheet-files
- :htcomponent-class-initscripts
- :htcomponent-instance-initscript
- :tag
- :tag-name
- :tag-attributes
- :htbody
- :htscript
- :htlink
- :hthead
- :htstring
- :$>
- :$raw>
- ;empty tags definition
- :area>
- :base>
- :basefont>
- :br>
- :col>
- :frame>
- :hr>
- :img>
- :input>
- :isindex>
- :link>
- :meta>
- :param>
- ;standard tags
- :a>
- :abbr>
- :acronym>
- :address>
- :applet>
- :b>
- :bdo>
- :big>
- :blockquote>
- :body>
- :button>
- :caption>
- :center>
- :cite>
- :code>
- :colgroup>
- :dd>
- :del>
- :dfn>
- :dir>
- :div>
- :dl>
- :dt>
- :em>
- :fieldset>
- :font>
- :form>
- :frameset>
- :h1>
- :h2>
- :h3>
- :h4>
- :h5>
- :h6>
- :head>
- :html>
- :i>
- :iframe>
- :ins>
- :kbd>
- :label>
- :legend>
- :li>
- :map>
- :menu>
- :noframes>
- :noscript>
- :object>
- :ol>
- :optgroup>
- :option>
- :p>
- :pre>
- :q>
- :s>
- :samp>
- :script>
- :select>
- :small>
- :span>
- :strike>
- :strong>
- :style>
- :sub>
- :sup>
- :table>
- :tbody>
- :td>
- :textarea>
- :tfoot>
- :th>
- :thead>
- :title>
- :tr>
- :tt>
- :u>
- :ul>
- :var>
- ;; class modifiers
- :page-content
- :generate-id
- :metacomponent
- :wcomponent
- :wcomponent-informal-parameters
- :wcomponent-allow-informal-parametersp
- :wcomponent-template
- :wcomponent-before-rewind
- :wcomponent-after-rewind
- :wcomponent-before-prerender
- :wcomponent-after-prerender
- :wcomponent-before-render
- :wcomponent-after-render
- :cform
- :cform>
- :action-link
- :action-link>
- :cinput
- :cinput>
- :cselect
- :cselect>
- :csubmit
- :csubmit>
- :submit-link
- :submit-link>
- :lisplet
- :lisplet-pages
- :lisplet-register-page-location
- :lisplet-register-function-location
- :lisplet-register-resource-location
- :lisplet-protect
- :lisplet-authentication-type
- :claw-start-session
- ;; clawserver
- :clawserver
- :clawserver-base-path
- :clawserver-register-lisplet
- :clawserver-unregister-lisplet
- :clawserver-start
- :clawserver-stop
- :clawserver-port
- :clawserver-sslport
- :clawserver-address
- :clawserver-name
- :clawserver-sslname
- :clawserver-mod-lisp-p
- :clawserver-use-apache-log-p
- :clawserver-input-chunking-p
- :clawserver-read-timeout
- :clawserver-write-timeout
- :clawserver-login-config
- #+(and :unix (not :win32)) :clawserver-setuid
- #+(and :unix (not :win32)) :clawserver-setgid
- #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file
- #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file
- #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password
- :msie-p
- :*id-and-static-id-description*
- :describe-component-behaviour
- :describe-html-attributes-from-class-slot-initargs
- :clawserver-register-configuration
- :configuration
- :configuration-login
- :principal
- :current-principal
- :principal-name
- :principal-roles
- :current-lisplet
- :current-server
- :current-realm
- :current-page
- :current-component
- :user-locale
- :page-current-component
- :user-in-role-p
- :login
- :register-library-resource
- ;;i18n
- :message-dispatcher
- :message-dispatch
- :simple-message-dispatcher
- :simple-message-dispatcher-add-message
- :with-message
- :do-message
- ;;validation
- :translator
- :translator-integer
- :translator-number
- :translator-date
- :translator-encode
- :translator-decode
- :*simple-translator*
- :*locales*
- :validate
- :validation-errors
- :component-validation-errors
- :validate-required
- :validate-size
- :validate-range
- :validate-number
- :validate-integer
- :validate-date-range
- :exception-monitor
- :exception-monitor>))
\ No newline at end of file
+ :*html-4.01-transitional*
+ :*html-4.01-frameset*
+ :*xhtml-1.0-strict*
+ :*xhtml-1.0-transitional*
+ :*xhtml-1.0-frameset*
+ :*default-encoding*
+ :*rewind-parameter*
+ :*clawserver-base-path*
+ :*apache-http-port*
+ :*apache-https-port*
+ :*empty-tags*
+ :tag-emptyp
+ :strings-to-jsarray
+ :empty-string-p
+ :build-tagf
+ :page
+ :page-url
+ :page-lisplet
+ :page-current-form
+ :page-req-parameter
+ :page-script-files
+ :page-stylesheet-files
+ :page-class-initscripts
+ :page-instance-initscripts
+ :page-current-component
+ :page-body-init-scripts
+ :htcomponent
+ :htcomponent-page
+ :htcomponent-body
+ :htcomponent-empty
+ :htcomponent-client-id
+ :htcomponent-script-files
+ :htcomponent-stylesheet-files
+ :htcomponent-class-initscripts
+ :htcomponent-instance-initscript
+ :tag
+ :tag-name
+ :tag-attributes
+ :htbody
+ :htscript
+ :htlink
+ :hthead
+ :htstring
+ :$>
+ :$raw>
+ ;empty tags definition
+ :area>
+ :base>
+ :basefont>
+ :br>
+ :col>
+ :frame>
+ :hr>
+ :img>
+ :input>
+ :isindex>
+ :link>
+ :meta>
+ :param>
+ ;standard tags
+ :a>
+ :abbr>
+ :acronym>
+ :address>
+ :applet>
+ :b>
+ :bdo>
+ :big>
+ :blockquote>
+ :body>
+ :button>
+ :caption>
+ :center>
+ :cite>
+ :code>
+ :colgroup>
+ :dd>
+ :del>
+ :dfn>
+ :dir>
+ :div>
+ :dl>
+ :dt>
+ :em>
+ :fieldset>
+ :font>
+ :form>
+ :frameset>
+ :h1>
+ :h2>
+ :h3>
+ :h4>
+ :h5>
+ :h6>
+ :head>
+ :html>
+ :i>
+ :iframe>
+ :ins>
+ :kbd>
+ :label>
+ :legend>
+ :li>
+ :map>
+ :menu>
+ :noframes>
+ :noscript>
+ :object>
+ :ol>
+ :optgroup>
+ :option>
+ :p>
+ :pre>
+ :q>
+ :s>
+ :samp>
+ :script>
+ :select>
+ :small>
+ :span>
+ :strike>
+ :strong>
+ :style>
+ :sub>
+ :sup>
+ :table>
+ :tbody>
+ :td>
+ :textarea>
+ :tfoot>
+ :th>
+ :thead>
+ :title>
+ :tr>
+ :tt>
+ :u>
+ :ul>
+ :var>
+ ;; class modifiers
+ :page-content
+ :generate-id
+ :metacomponent
+ :wcomponent
+ :wcomponent-informal-parameters
+ :wcomponent-allow-informal-parametersp
+ :wcomponent-template
+ :wcomponent-before-rewind
+ :wcomponent-after-rewind
+ :wcomponent-before-prerender
+ :wcomponent-after-prerender
+ :wcomponent-before-render
+ :wcomponent-after-render
+ :cform
+ :cform>
+ :action
+ :action-link
+ :action-link>
+ :cinput
+ :cinput>
+ :cselect
+ :cselect>
+ :csubmit
+ :csubmit>
+ :csubmit-value
+ :submit-link
+ :submit-link>
+ :lisplet
+ :lisplet-pages
+ :lisplet-register-page-location
+ :lisplet-register-function-location
+ :lisplet-register-resource-location
+ :lisplet-protect
+ :lisplet-authentication-type
+ :claw-start-session
+ ;; clawserver
+ :clawserver
+ :clawserver-base-path
+ :clawserver-register-lisplet
+ :clawserver-unregister-lisplet
+ :clawserver-start
+ :clawserver-stop
+ :clawserver-port
+ :clawserver-sslport
+ :clawserver-address
+ :clawserver-name
+ :clawserver-sslname
+ :clawserver-mod-lisp-p
+ :clawserver-use-apache-log-p
+ :clawserver-input-chunking-p
+ :clawserver-read-timeout
+ :clawserver-write-timeout
+ :clawserver-login-config
+ #+(and :unix (not :win32)) :clawserver-setuid
+ #+(and :unix (not :win32)) :clawserver-setgid
+ #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file
+ #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file
+ #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password
+ :msie-p
+ :*id-and-static-id-description*
+ :describe-component-behaviour
+ :describe-html-attributes-from-class-slot-initargs
+ :clawserver-register-configuration
+ :configuration
+ :configuration-login
+ :principal
+ :current-principal
+ :principal-name
+ :principal-roles
+ :current-lisplet
+ :current-server
+ :current-realm
+ :current-page
+ :current-component
+ :user-locale
+ :page-current-component
+ :user-in-role-p
+ :login
+ :register-library-resource
+ ;;i18n
+ :message-dispatcher
+ :message-dispatch
+ :simple-message-dispatcher
+ :simple-message-dispatcher-add-message
+ :with-message
+ :do-message
+ ;;validation
+ :translator
+ :translator-integer
+ :translator-number
+ :translator-date
+ :translator-encode
+ :translator-decode
+ :*simple-translator*
+ :*locales*
+ :validate
+ :validation-errors
+ :component-validation-errors
+ :validate-required
+ :validate-size
+ :validate-range
+ :validate-number
+ :validate-integer
+ :validate-date-range
+ :exception-monitor
+ :exception-monitor>))
\ No newline at end of file
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Mon May 12 03:10:02 2008
@@ -142,7 +142,7 @@
- HTCOMPONENT is the htcomponent instance"))
(defgeneric htcomponent-json-print-end-component (htcomponent)
- (:documentation "Internal method called to render the json reply during the render cycle phase
+ (:documentation "Internal method called to render the json reply during the render cycle phase
on component end.
- HTCOMPONENT is the htcomponent instance"))
@@ -173,11 +173,6 @@
(defgeneric (setf slot-initialization) (value wcomponent slot-initarg)
(:documentation "Sets a slot by its :INITARG. It's used just after instance creation"))
-(defgeneric wcomponent-informal-parameters(wcomponent)
- (:documentation "This method returns class informal parameters as an alist (informal parameters are the ones not expected by the component,
-usually rendered as tag attributes withot any kind of evaluation)
- - WCOMPONENT is the wcomponent instance"))
-
(defgeneric wcomponent-before-rewind (wcomponent page)
(:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes.
- WCOMPONENT is the tag instance
@@ -238,8 +233,8 @@
(defvar *empty-tags*
(list "area" "base" "basefont" "br" "col" "frame"
- "hr" "img" "input" "isindex" "meta"
- "param" "link")
+ "hr" "img" "input" "isindex" "meta"
+ "param" "link")
"List of html empty tags")
(defun request-id-table-map ()
@@ -249,9 +244,9 @@
(when (boundp '*request*)
(let ((id-table-map (aux-request-value :id-table-map)))
(if (null id-table-map)
- (progn
- (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))
- id-table-map))))
+ (progn
+ (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))
+ id-table-map))))
(defun reset-request-id-table-map ()
"This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness.
@@ -262,15 +257,15 @@
(defun parse-htcomponent-function (function-body)
"This function parses attributes passed to a htcomponent creation function"
(let ((attributes)
- (body))
- (loop for last-elem = nil then elem
- for elem in function-body
- do (if (and (null body)
- (or (keywordp elem)
- (keywordp last-elem)))
- (push elem attributes)
- (when elem
- (push elem body))))
+ (body))
+ (loop for last-elem = nil then elem
+ for elem in function-body
+ do (if (and (null body)
+ (or (keywordp elem)
+ (keywordp last-elem)))
+ (push elem attributes)
+ (when elem
+ (push elem body))))
(list (reverse attributes) (reverse body))))
@@ -278,38 +273,38 @@
"This function is very useful when having references to components id inside component body.
When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute."
(let* ((id-ht (request-id-table-map))
- (client-id-index (gethash id id-ht 0))
- (result))
+ (client-id-index (gethash id id-ht 0))
+ (result))
(if (= 0 client-id-index)
- (setf result id)
- (setf result (format nil "~a_~d" id client-id-index)))
+ (setf result id)
+ (setf result (format nil "~a_~d" id client-id-index)))
(setf (gethash id id-ht) (1+ client-id-index))
result))
(defun build-tagf (tag-name parent emptyp &rest rest)
"This function is used to create a tag object instance
- TAG-NAME the a string tag name to create, for example \"span\"
-- PARENT the parent class. usually 'TAG
+- PARENT the parent class. usually TAG
- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase.
- REST a list of attribute/value pairs and the component body"
(let* ((fbody (parse-htcomponent-function (flatten rest)))
- (id-table-map (request-id-table-map))
- (id (getf (first fbody) :id))
- (static-id (getf (first fbody) :static-id))
- (instance))
+ (id-table-map (request-id-table-map))
+ (id (getf (first fbody) :id))
+ (static-id (getf (first fbody) :static-id))
+ (instance))
(when static-id
(remf (first fbody) :id)
(setf id nil))
(setf instance (make-instance parent
- :empty emptyp
- :name (string-downcase tag-name)
- :attributes (first fbody)
- :body (second fbody)))
+ :empty emptyp
+ :name (string-downcase tag-name)
+ :attributes (first fbody)
+ :body (second fbody)))
(if (null static-id)
- (when (and id-table-map id)
- (setf (htcomponent-client-id instance)
- (generate-id id)))
- (setf (htcomponent-client-id instance) static-id))
+ (when (and id-table-map id)
+ (setf (htcomponent-client-id instance)
+ (generate-id id)))
+ (setf (htcomponent-client-id instance) static-id))
instance))
(defun generate-tagf (tag-name emptyp)
@@ -318,12 +313,12 @@
- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase."
(let ((fsymbol (intern (format nil "~a>" (string-upcase tag-name)))))
(setf (fdefinition fsymbol)
- #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest)))
+ #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest)))
(setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag"
- (if emptyp
- "empty "
- "")
- tag-name))))
+ (if emptyp
+ "empty "
+ "")
+ tag-name))))
;;;----------------------------------------------------------------
@@ -333,58 +328,58 @@
(defclass simple-message-dispatcher (message-dispatcher)
((locales :initform (make-hash-table :test #'equal)
- :accessor simple-message-dispatcher-locales
- :documentation "Hash table of locales strings and KEY/VALUE message pairs"))
+ :accessor simple-message-dispatcher-locales
+ :documentation "Hash table of locales strings and KEY/VALUE message pairs"))
(:documentation "A message disptcher that leave data unchanged during encoding and decoding phases."))
(defclass i18n-aware (message-dispatcher)
((message-dispatcher :initarg :message-dispatcher
- :accessor message-dispatcher
- :documentation "Reference to a MESSAGE-DISPATCHER instance"))
+ :accessor message-dispatcher
+ :documentation "Reference to a MESSAGE-DISPATCHER instance"))
(:default-initargs :message-dispatcher nil)
(:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE"))
(defclass page(i18n-aware)
((writer :initarg :writer
- :accessor page-writer :documentation "The output stream for this page instance")
+ :accessor page-writer :documentation "The output stream for this page instance")
(lisplet :initarg :lisplet
- :reader page-lisplet :documentation "The lisplet that owns this page instance")
+ :reader page-lisplet :documentation "The lisplet that owns this page instance")
(can-print :initform nil
- :accessor page-can-print
- :documentation "Controls the printing process when a json request is dispatched.
+ :accessor page-can-print
+ :documentation "Controls the printing process when a json request is dispatched.
Only components with a matching id and their contents can be printed")
(script-files :initarg :script-files
- :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle")
+ :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle")
(stylesheet-files :initarg :stylesheet-files
- :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle")
+ :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle")
(class-initscripts :initarg :class-initscripts
- :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle")
+ :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle")
(instancee-initscripts :initarg :instance-initscripts
- :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle")
+ :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle")
(indent :initarg :indent
- :accessor page-indent :documentation "Determine if the output must be indented or not")
+ :accessor page-indent :documentation "Determine if the output must be indented or not")
(tabulator :initarg :tabulator
- :accessor page-tabulator :documentation "Holds the indentation level")
+ :accessor page-tabulator :documentation "Holds the indentation level")
(xmloutput :initarg :xmloutput
- :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML")
+ :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML")
(current-form :initform :nil
- :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired")
+ :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired")
(doc-type :initarg :doc-type
- :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)")
+ :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)")
(lasttag :initform nil
- :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering")
+ :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering")
(json-component-count :initarg :json-component-count
- :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.")
+ :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.")
(request-parameters :initarg :request-parameters
- :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.")
+ :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.")
(components-stack :initform nil
- :accessor page-components-stack
- :documentation "A stack of components enetered into rendering process.")
+ :accessor page-components-stack
+ :documentation "A stack of components enetered into rendering process.")
(content-type :initarg :content-type
- :accessor page-content-type
- :documentation "Define the content type of the page when rendered")
+ :accessor page-content-type
+ :documentation "Define the content type of the page when rendered")
(url :initarg :url
- :accessor page-url :documentation "The URL provided with this page instance"))
+ :accessor page-url :documentation "The URL provided with this page instance"))
(:default-initargs :writer t
:script-files nil
:json-component-count 0
@@ -402,23 +397,23 @@
(defclass htcomponent (i18n-aware)
((page :initarg :page
- :reader htcomponent-page :documentation "The owner page")
+ :reader htcomponent-page :documentation "The owner page")
(body :initarg :body
- :accessor htcomponent-body :documentation "The tag body")
+ :accessor htcomponent-body :documentation "The tag body")
(client-id :initarg :client-id
- :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function")
+ :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function")
(attributes :initarg :attributes
- :accessor htcomponent-attributes :documentation "The tag attributes")
+ :accessor htcomponent-attributes :documentation "The tag attributes")
(empty :initarg :empty
- :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag")
+ :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag")
(script-files :initarg :script-files
- :accessor htcomponent-script-files :documentation "Page injectable script files")
+ :accessor htcomponent-script-files :documentation "Page injectable script files")
(stylesheet-files :initarg :stylesheet-files
- :accessor htcomponent-stylesheet-files :documentation "Page injectable css files")
+ :accessor htcomponent-stylesheet-files :documentation "Page injectable css files")
(class-initscripts :initarg :class-initscripts
- :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives")
+ :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives")
(instance-initscript :initarg :instance-initscript
- :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives"))
+ :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives"))
(:default-initargs :page nil
:body nil
:client-id nil
@@ -432,13 +427,13 @@
(defclass tag (htcomponent)
((name :initarg :name
- :reader tag-name :documentation "The tag name to be rendered"))
+ :reader tag-name :documentation "The tag name to be rendered"))
(:default-initargs :name nil)
(:documentation "This class is used to render the most part of html tags"))
(defclass htstring (htcomponent)
((raw :initarg :raw
- :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not"))
+ :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not"))
(:default-initargs :raw nil)
(:documentation "Component needed to render strings"))
@@ -446,9 +441,9 @@
(defmethod initialize-instance :after ((inst tag) &rest keys)
(let ((emptyp (getf keys :empty))
- (body (getf keys :body)))
+ (body (getf keys :body)))
(when (and (not (null emptyp))
- (not (null body)))
+ (not (null body)))
(error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body)))))
(defun $> (value)
@@ -488,29 +483,29 @@
(build-tagf "head" 'hthead nil rest))
(mapcar #'(lambda (tag-name) (generate-tagf tag-name t))
- ;;Creates empty tag initialization functions. But the ones directly defined
- *empty-tags*)
+ ;;Creates empty tag initialization functions. But the ones directly defined
+ *empty-tags*)
(mapcar #'(lambda (tag-name) (generate-tagf tag-name nil))
- ;;Creates non empty tag initialization functions. But the ones directly defined
- '("a" "abbr" "acronym" "address" "applet"
- "b" "bdo" "big" "blockquote" "button"
- "caption" "center" "cite" "code" "colgroup"
- "dd" "del" "dfn" "dir" "div" "dl" "dt"
- "em"
- "fieldset" "font" "form" "frameset"
- "h1" "h2" "h3" "h4" "h5" "h6" "html"
- "i" "iframe" "ins"
- "kbd"
- "label" "legend" "li"
- "map" "menu"
- "noframes" "noscript"
- "object" "ol" "optgroup" "option"
- "p" "pre"
- "q"
- "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup"
- "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt"
- "u" "ul" "var"))
+ ;;Creates non empty tag initialization functions. But the ones directly defined
+ '("a" "abbr" "acronym" "address" "applet"
+ "b" "bdo" "big" "blockquote" "button"
+ "caption" "center" "cite" "code" "colgroup"
+ "dd" "del" "dfn" "dir" "div" "dl" "dt"
+ "em"
+ "fieldset" "font" "form" "frameset"
+ "h1" "h2" "h3" "h4" "h5" "h6" "html"
+ "i" "iframe" "ins"
+ "kbd"
+ "label" "legend" "li"
+ "map" "menu"
+ "noframes" "noscript"
+ "object" "ol" "optgroup" "option"
+ "p" "pre"
+ "q"
+ "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup"
+ "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt"
+ "u" "ul" "var"))
(defun tag-emptyp (tag-name)
"Returns if a tag defined by the string TAG-NAME is empty"
@@ -519,47 +514,47 @@
;;;--------------------METHODS implementation----------------------------------------------
(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent))
(let ((id (getf (htcomponent-attributes htcomponent) :id))
- (static-id (getf (htcomponent-attributes htcomponent) :static-id))
- (client-id (htcomponent-client-id htcomponent)))
+ (static-id (getf (htcomponent-attributes htcomponent) :static-id))
+ (client-id (htcomponent-client-id htcomponent)))
(setf (slot-value htcomponent 'page) page)
(unless client-id
(if static-id
- (setf (htcomponent-client-id htcomponent) static-id)
- (setf (htcomponent-client-id htcomponent) (generate-id id))))))
+ (setf (htcomponent-client-id htcomponent) static-id)
+ (setf (htcomponent-client-id htcomponent) (generate-id id))))))
(defmethod page-request-parameters ((page page))
(if (and (boundp '*request*) (null (slot-value page 'request-parameters)))
- (let ((parameters (append (post-parameters) (get-parameters)))
- (pparameters (make-hash-table :test 'equal)))
- (loop for kv in parameters
- do (setf (gethash (string-upcase (car kv)) pparameters)
- (append (gethash (string-upcase (car kv)) pparameters)
- (list (cdr kv)))))
- (setf (slot-value page 'request-parameters) pparameters))
- (slot-value page 'request-parameters)))
+ (let ((parameters (append (post-parameters) (get-parameters)))
+ (pparameters (make-hash-table :test 'equal)))
+ (loop for kv in parameters
+ do (setf (gethash (string-upcase (car kv)) pparameters)
+ (append (gethash (string-upcase (car kv)) pparameters)
+ (list (cdr kv)))))
+ (setf (slot-value page 'request-parameters) pparameters))
+ (slot-value page 'request-parameters)))
(defmethod page-req-parameter ((page page) name &optional as-list)
(let ((parameters (page-request-parameters page))
- (retval))
+ (retval))
(when parameters
(setf retval (gethash (string-upcase name) parameters))
(if (or (null retval) as-list)
- retval
- (first retval)))))
+ retval
+ (first retval)))))
(defmethod page-format ((page page) str &rest rest)
(let ((jsonp (page-json-id-list page))
- (writer (page-writer page)))
+ (writer (page-writer page)))
(if (null jsonp)
- (apply #'format writer str rest)
- (apply #'format writer (list
- (regex-replace-all "\""
- (regex-replace-all "\\\\\""
- (regex-replace-all "\\n"
- (apply #'format nil str rest)
- "\\n")
- "\\\\\\\"")
- "\\\""))))))
+ (apply #'format writer str rest)
+ (apply #'format writer (list
+ (regex-replace-all "\""
+ (regex-replace-all "\\\\\""
+ (regex-replace-all "\\n"
+ (apply #'format nil str rest)
+ "\\n")
+ "\\\\\\\"")
+ "\\\""))))))
(defmethod page-format-raw ((page page) str &rest rest)
(let ((writer (page-writer page)))
@@ -577,107 +572,107 @@
(defmethod page-render-headings ((page page))
(let* ((writer (page-writer page))
- (jsonp (page-json-id-list page))
- (encoding (handler-case (format nil "~a" (stream-external-format writer))
- (error () (format nil "~a" *default-encoding*))))
- (xml-p (page-xmloutput page))
- (content-type (page-doc-type page)))
+ (jsonp (page-json-id-list page))
+ (encoding (handler-case (format nil "~a" (stream-external-format writer))
+ (error () (format nil "~a" *default-encoding*))))
+ (xml-p (page-xmloutput page))
+ (content-type (page-doc-type page)))
(when (null jsonp)
(when xml-p
- (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
+ (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding))
(when content-type
- (page-format-raw page "~a~%" content-type)))))
+ (page-format-raw page "~a~%" content-type)))))
(defun json-validation-errors ()
"Composes the error part for the json reply"
(let ((validation-errors (aux-request-value :validation-errors)))
(if validation-errors
- (strings-to-jsarray
- (loop for component-exceptions in validation-errors
- collect (format "{~a:~a}"(car component-exceptions)
- (strings-to-jsarray (loop for message in (cdr component-exceptions)
- collect (prin1-to-string message))))))
- "null")))
+ (strings-to-jsarray
+ (loop for component-exceptions in validation-errors
+ collect (format "{~a:~a}"(car component-exceptions)
+ (strings-to-jsarray (loop for message in (cdr component-exceptions)
+ collect (prin1-to-string message))))))
+ "null")))
(defmethod page-render ((page page))
(let ((body (page-content page))
- (jsonp (page-json-id-list page)))
+ (jsonp (page-json-id-list page)))
(setf (hunchentoot:content-type) (page-content-type page))
(if (null body)
- (format nil "null body for page ~a~%" (type-of page))
- (progn
- (setf (current-page) page)
- (page-init page)
- (when (page-req-parameter page *rewind-parameter*)
- (htcomponent-rewind body page))
- (page-init page)
- (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!!
- (page-render-headings page)
- (page-init page)
- (when jsonp
- (page-format-raw page "{components:{"))
- (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!!
- (when jsonp
- (page-format-raw page "},classInjections:\"")
- (setf (page-can-print page) t)
- (dolist (injection (page-init-injections page))
- (when injection
- (htcomponent-render injection page)))
- (page-format-raw page "\",instanceInjections:\"")
- (let ((init-scripts (htbody-init-scripts-tag page)))
- (when init-scripts
- (htcomponent-render init-scripts page)))
- (page-format-raw page "\",errors:")
- (page-format-raw page (json-validation-errors))
- (page-format-raw page "}"))))))
+ (format nil "null body for page ~a~%" (type-of page))
+ (progn
+ (setf (current-page) page)
+ (page-init page)
+ (when (page-req-parameter page *rewind-parameter*)
+ (htcomponent-rewind body page))
+ (page-init page)
+ (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!!
+ (page-render-headings page)
+ (page-init page)
+ (when jsonp
+ (page-format-raw page "{components:{"))
+ (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!!
+ (when jsonp
+ (page-format-raw page "},classInjections:\"")
+ (setf (page-can-print page) t)
+ (dolist (injection (page-init-injections page))
+ (when injection
+ (htcomponent-render injection page)))
+ (page-format-raw page "\",instanceInjections:\"")
+ (let ((init-scripts (htbody-init-scripts-tag page)))
+ (when init-scripts
+ (htcomponent-render init-scripts page)))
+ (page-format-raw page "\",errors:")
+ (page-format-raw page (json-validation-errors))
+ (page-format-raw page "}"))))))
(defmethod page-body-init-scripts ((page page))
(let ((js-body ""))
(dolist (current-js (reverse (page-instance-initscripts page)))
(setf js-body (format nil "~a~%~a~%" js-body current-js)))
(if (string= "" js-body)
- js-body
- (format nil "~a" js-body))))
+ js-body
+ (format nil "~a" js-body))))
(defmethod page-print-tabulation ((page page))
(let ((jsonp (page-json-id-list page))
- (tabulator (page-tabulator page))
- (indent-p (page-indent page)))
+ (tabulator (page-tabulator page))
+ (indent-p (page-indent page)))
(when (and (<= 0 tabulator) indent-p (null jsonp))
(page-format-raw page "~a"
- (make-string tabulator :initial-element #\tab)))))
+ (make-string tabulator :initial-element #\tab)))))
(defmethod page-newline ((page page))
(let ((jsonp (page-json-id-list page))
- (indent-p (page-indent page)))
+ (indent-p (page-indent page)))
(when (and indent-p (null jsonp))
(page-format-raw page "~%"))))
(defmethod page-init-injections ((page page))
- (let ((tag-list)
- (class-init-scripts ""))
- (dolist (script (reverse (page-class-initscripts page)))
- (setf class-init-scripts (format nil "~a~%~a"
- class-init-scripts
- script)))
- (unless (string= "" class-init-scripts)
- (let ((current-js (script> :type "text/javascript")))
- (setf (htcomponent-body current-js) class-init-scripts)
- (push current-js tag-list)))
- (dolist (js-file (page-script-files page))
- (if (typep js-file 'htcomponent)
- (push js-file tag-list)
- (let ((current-js (script> :type "text/javascript" :src "")))
- (setf (getf (htcomponent-attributes current-js) :src) js-file)
- (push current-js tag-list))))
- (dolist (css-file (page-stylesheet-files page))
- (if (typep css-file 'htcomponent)
- (push css-file tag-list)
- (let ((current-css (link> :rel "stylesheet" :type "text/css" :href "")))
- (setf (getf (htcomponent-attributes current-css) :href) css-file)
- (push current-css tag-list))))
+ (let ((tag-list)
+ (class-init-scripts ""))
+ (dolist (script (reverse (page-class-initscripts page)))
+ (setf class-init-scripts (format nil "~a~%~a"
+ class-init-scripts
+ script)))
+ (unless (string= "" class-init-scripts)
+ (let ((current-js (script> :type "text/javascript")))
+ (setf (htcomponent-body current-js) class-init-scripts)
+ (push current-js tag-list)))
+ (dolist (js-file (page-script-files page))
+ (if (typep js-file 'htcomponent)
+ (push js-file tag-list)
+ (let ((current-js (script> :type "text/javascript" :src "")))
+ (setf (getf (htcomponent-attributes current-js) :src) js-file)
+ (push current-js tag-list))))
+ (dolist (css-file (page-stylesheet-files page))
+ (if (typep css-file 'htcomponent)
+ (push css-file tag-list)
+ (let ((current-css (link> :rel "stylesheet" :type "text/css" :href "")))
+ (setf (getf (htcomponent-attributes current-css) :href) css-file)
+ (push current-css tag-list))))
- tag-list))
+ tag-list))
(defmethod page-current-component ((page page))
(car (page-components-stack page)))
@@ -690,28 +685,28 @@
;;;========= HTCOMPONENT ============================
(defmethod htcomponent-can-print ((htcomponent htcomponent))
(let* ((id (htcomponent-client-id htcomponent))
- (page (htcomponent-page htcomponent))
- (print-status (page-can-print page))
- (render-p (member id (page-json-id-list page) :test #'string=)))
+ (page (htcomponent-page htcomponent))
+ (print-status (page-can-print page))
+ (render-p (member id (page-json-id-list page) :test #'string=)))
(or print-status render-p)))
(defmethod htcomponent-json-print-start-component ((htcomponent htcomponent))
(let* ((page (htcomponent-page htcomponent))
- (jsonp (page-json-id-list page))
- (id (htcomponent-client-id htcomponent)))
+ (jsonp (page-json-id-list page))
+ (id (htcomponent-client-id htcomponent)))
(when (and jsonp
- (member id jsonp :test #'string-equal))
+ (member id jsonp :test #'string-equal))
(when (> (page-json-component-count page) 0)
- (page-format page ","))
+ (page-format page ","))
(page-format-raw page "~a:\"" id)
(incf (page-json-component-count page)))))
(defmethod htcomponent-json-print-end-component ((htcomponent htcomponent))
(let* ((page (htcomponent-page htcomponent))
- (jsonp (page-json-id-list page))
- (id (htcomponent-client-id htcomponent)))
+ (jsonp (page-json-id-list page))
+ (id (htcomponent-client-id htcomponent)))
(when (and jsonp
- (member id jsonp :test #'string-equal))
+ (member id jsonp :test #'string-equal))
(page-format-raw page "\""))))
(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page))
@@ -746,22 +741,22 @@
(setf (page-can-print page) (htcomponent-can-print htcomponent)))
(dolist (tag (htcomponent-body htcomponent))
(when (subtypep (type-of tag) 'htcomponent)
- (htcomponent-prerender tag page)))
+ (htcomponent-prerender tag page)))
(when (null previous-print-status)
(setf (page-can-print page) nil))))
(defmethod htcomponent-render ((htcomponent htcomponent) (page page))
(let ((body-list (htcomponent-body htcomponent))
- (previous-print-status (page-can-print page)))
+ (previous-print-status (page-can-print page)))
(when (null previous-print-status)
(setf (page-can-print page) (htcomponent-can-print htcomponent))
(htcomponent-json-print-start-component htcomponent))
(dolist (child-tag body-list)
(when child-tag
- (cond
- ((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
- (t (htcomponent-render child-tag page)))))
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+ (t (htcomponent-render child-tag page)))))
(when (null previous-print-status)
(setf (page-can-print page) nil)
(htcomponent-json-print-end-component htcomponent))))
@@ -774,66 +769,66 @@
(when (htcomponent-attributes tag)
(loop for (k v) on (htcomponent-attributes tag) by #'cddr
do (progn
- (assert (keywordp k))
- (when (functionp v)
- (setf v (funcall v)))
- (when (and v (string-not-equal v ""))
- (page-format page " ~a=\"~a\""
- (string-downcase (if (eq k :static-id)
- "id"
- (symbol-name k)))
- (let ((s (if (eq k :id)
- (prin1-to-string (htcomponent-client-id tag))
- (prin1-to-string v)))) ;escapes double quotes
- (subseq s 1 (1- (length s))))))))))
+ (assert (keywordp k))
+ (when (functionp v)
+ (setf v (funcall v)))
+ (when (and v (string-not-equal v ""))
+ (page-format page " ~a=\"~a\""
+ (string-downcase (if (eq k :static-id)
+ "id"
+ (symbol-name k)))
+ (let ((s (if (eq k :id)
+ (prin1-to-string (htcomponent-client-id tag))
+ (prin1-to-string v)))) ;escapes double quotes
+ (subseq s 1 (1- (length s))))))))))
(defmethod tag-render-starttag ((tag tag) (page page))
(let ((tagname (tag-name tag))
- (emptyp (htcomponent-empty tag))
- (xml-p (page-xmloutput page)))
+ (emptyp (htcomponent-empty tag))
+ (xml-p (page-xmloutput page)))
(setf (page-lasttag page) tagname)
(page-newline page)
(page-print-tabulation page)
(page-format page "<~a" tagname)
(tag-render-attributes tag page)
(if (null emptyp)
- (progn
- (page-format page ">")
- (incf (page-tabulator page)))
- (if (null xml-p)
- (page-format page ">")
- (page-format page "/>")))))
+ (progn
+ (page-format page ">")
+ (incf (page-tabulator page)))
+ (if (null xml-p)
+ (page-format page ">")
+ (page-format page "/>")))))
(defmethod tag-render-endtag ((tag tag) (page page))
(let ((tagname (tag-name tag))
- (previous-tagname (page-lasttag page))
- (emptyp (htcomponent-empty tag)))
+ (previous-tagname (page-lasttag page))
+ (emptyp (htcomponent-empty tag)))
(when (null emptyp)
- (progn
- (decf (page-tabulator page))
- (if (string= tagname previous-tagname)
- (progn
- (page-format page "</~a>" tagname))
- (progn
- (page-newline page)
- (page-print-tabulation page)
- (page-format page "</~a>" tagname)))))
+ (progn
+ (decf (page-tabulator page))
+ (if (string= tagname previous-tagname)
+ (progn
+ (page-format page "</~a>" tagname))
+ (progn
+ (page-newline page)
+ (page-print-tabulation page)
+ (page-format page "</~a>" tagname)))))
(setf (page-lasttag page) nil)))
(defmethod htcomponent-render ((tag tag) (page page))
(let ((body-list (htcomponent-body tag))
- (previous-print-status (page-can-print page)))
+ (previous-print-status (page-can-print page)))
(when (null previous-print-status)
(setf (page-can-print page) (htcomponent-can-print tag))
(htcomponent-json-print-start-component tag))
(when (or (page-can-print page) previous-print-status)
(tag-render-starttag tag page))
(dolist (child-tag body-list)
- (when child-tag
- (cond
- ((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
- (t (htcomponent-render child-tag page)))))
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+ (t (htcomponent-render child-tag page)))))
(when (or (page-can-print page) previous-print-status)
(tag-render-endtag tag page))
(unless previous-print-status
@@ -844,18 +839,18 @@
(defmethod htcomponent-render ((hthead hthead) (page page))
(when (null (page-json-id-list page))
(let ((body-list (htcomponent-body hthead))
- (injections (page-init-injections page)))
+ (injections (page-init-injections page)))
(tag-render-starttag hthead page)
(htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) page)
- (dolist (child-tag body-list)
- (when child-tag
- (cond
- ((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
- (t (htcomponent-render child-tag page)))))
+ (dolist (child-tag body-list)
+ (when child-tag
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+ (t (htcomponent-render child-tag page)))))
(dolist (injection injections)
- (when injection
- (htcomponent-render injection page)))
+ (when injection
+ (htcomponent-render injection page)))
(tag-render-endtag hthead page))))
;;;========= HTSTRING ===================================
@@ -865,35 +860,35 @@
(defmethod htcomponent-render ((htstring htstring) (page page))
(let ((body (htcomponent-body htstring))
- (jsonp (not (null (page-json-id-list page))))
- (print-p (page-can-print page)))
+ (jsonp (not (null (page-json-id-list page))))
+ (print-p (page-can-print page)))
(when (and print-p body)
(when (functionp body)
- (setf body (funcall body)))
+ (setf body (funcall body)))
(when jsonp
- (setf body (regex-replace-all "\""
- (regex-replace-all "\\\\\""
- (regex-replace-all "\\n"
- body
- "\\n")
- "\\\\\\\"")
- "\\\"")))
+ (setf body (regex-replace-all "\""
+ (regex-replace-all "\\\\\""
+ (regex-replace-all "\\n"
+ body
+ "\\n")
+ "\\\\\\\"")
+ "\\\"")))
(if (htstring-raw htstring)
- (page-format-raw page body)
- (loop for ch across body
- do (case ch
- ((#\<) (page-format-raw page "<"))
- ((#\>) (page-format-raw page ">"))
- ((#\&) (page-format-raw page "&"))
- (t (page-format-raw page "~a" ch))))))))
+ (page-format-raw page body)
+ (loop for ch across body
+ do (case ch
+ ((#\<) (page-format-raw page "<"))
+ ((#\>) (page-format-raw page ">"))
+ ((#\&) (page-format-raw page "&"))
+ (t (page-format-raw page "~a" ch))))))))
;;;========= HTSCRIPT ===================================
(defmethod htcomponent-prerender((htscript htscript) (page page)))
(defmethod htcomponent-render ((htscript htscript) (page page))
(let ((xml-p (page-xmloutput page))
- (body (htcomponent-body htscript))
- (previous-print-status (page-can-print page)))
+ (body (htcomponent-body htscript))
+ (previous-print-status (page-can-print page)))
(when (null previous-print-status)
(setf (page-can-print page) (htcomponent-can-print htscript))
(htcomponent-json-print-start-component htscript))
@@ -902,21 +897,21 @@
(when (page-can-print page)
(tag-render-starttag htscript page)
(when (and (null (getf (htcomponent-attributes htscript) :src))
- (not (null (htcomponent-body htscript))))
- (if (null xml-p)
- (page-format page "~%//<!--~%")
- (page-format page "~%//<[CDATA[~%"))
- (unless (listp body)
- (setf body (list body)))
- (dolist (element body)
- (when element
- (cond
- ((stringp element) (htcomponent-render ($> element) page))
- ((functionp element) (htcomponent-render ($> (funcall element)) page))
- (t (htcomponent-render element page)))))
- (if (null xml-p)
- (page-format page "~%//-->")
- (page-format page "~%//]]>")))
+ (not (null (htcomponent-body htscript))))
+ (if (null xml-p)
+ (page-format page "~%//<!--~%")
+ (page-format page "~%//<[CDATA[~%"))
+ (unless (listp body)
+ (setf body (list body)))
+ (dolist (element body)
+ (when element
+ (cond
+ ((stringp element) (htcomponent-render ($> element) page))
+ ((functionp element) (htcomponent-render ($> (funcall element)) page))
+ (t (htcomponent-render element page)))))
+ (if (null xml-p)
+ (page-format page "~%//-->")
+ (page-format page "~%//]]>")))
(setf (page-lasttag page) nil)
(tag-render-endtag htscript page))
(when (null previous-print-status)
@@ -932,9 +927,9 @@
(htcomponent-json-print-start-component htlink))
(when (page-can-print page)
(unless (getf (htcomponent-attributes htlink) :type)
- (append '(:type "text/css") (htcomponent-attributes htlink)))
+ (append '(:type "text/css") (htcomponent-attributes htlink)))
(unless (getf (htcomponent-attributes htlink) :rel)
- (append '(:rel "styleshhet") (htcomponent-attributes htlink)))
+ (append '(:rel "styleshhet") (htcomponent-attributes htlink)))
(tag-render-starttag htlink page)
(tag-render-endtag htlink page))
(when (null previous-print-status)
@@ -944,109 +939,105 @@
;;;========= HTBODY ===================================
(defmethod htcomponent-render ((htbody htbody) (page page))
(let ((body-list (htcomponent-body htbody))
- (previous-print-status (page-can-print page)))
- (when (or (page-can-print page) previous-print-status)
+ (previous-print-status (page-can-print page)))
+ (when (or (page-can-print page) previous-print-status)
(setf (page-can-print page) (htcomponent-can-print htbody))
(htcomponent-json-print-start-component htbody))
(when (page-can-print page)
(tag-render-starttag htbody page))
(dolist (child-tag body-list)
(when child-tag
- (cond
- ((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
- (t (htcomponent-render child-tag page)))))
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+ (t (htcomponent-render child-tag page)))))
(when (page-can-print page)
(htcomponent-render (htbody-init-scripts-tag page) page)
(tag-render-endtag htbody page))
(when (or (page-can-print page) previous-print-status)
(setf (page-can-print page) nil)
(htcomponent-json-print-end-component htbody))))
-
+
(defmethod htbody-init-scripts-tag ((page page))
(let ((js (script> :type "text/javascript"))
- (js-start-directive (if (msie-p)
- "window.attachEvent\('onload', function\(e) {"
- "document.addEventListener\('DOMContentLoaded', function\(e) {"))
- (js-end-directive (if (msie-p)
- "});"
- "}, false);"))
- (page-body-init-scripts (page-body-init-scripts page)))
+ (js-start-directive (if (msie-p)
+ "window.attachEvent\('onload', function\(e) {"
+ "document.addEventListener\('DOMContentLoaded', function\(e) {"))
+ (js-end-directive (if (msie-p)
+ "});"
+ "}, false);"))
+ (page-body-init-scripts (page-body-init-scripts page)))
(setf (htcomponent-page js) page
- (htcomponent-body js) (when page-body-init-scripts
- (if (listp page-body-init-scripts)
- (append (list js-start-directive)
- page-body-init-scripts
- (list js-end-directive))
- (list js-start-directive page-body-init-scripts js-end-directive))))
+ (htcomponent-body js) (when page-body-init-scripts
+ (if (listp page-body-init-scripts)
+ (append (list js-start-directive)
+ page-body-init-scripts
+ (list js-end-directive))
+ (list js-start-directive page-body-init-scripts js-end-directive))))
js))
;;;========= WCOMPONENT ===================================
(defclass wcomponent (htcomponent)
((reserved-parameters :initarg :reserved-parameters
- :accessor wcomponent-reserved-parameters
- :type cons
- :documentation "Parameters that may not be used in the constructor function")
- (informal-parameters :initarg :informal-parameters
- :accessor wcomponent-informal-parameters
- :type cons
- :documentation "Informal parameters are parameters optional for the component")
+ :accessor wcomponent-reserved-parameters
+ :type cons
+ :documentation "Parameters that may not be used in the constructor function")
+ (informal-parameters :initform ()
+ :accessor wcomponent-informal-parameters
+ :type cons
+ :documentation "Informal parameters are parameters optional for the component")
(allow-informal-parameters :initarg :allow-informal-parameters
- :reader wcomponent-allow-informal-parametersp
- :allocation :class
- :documentation "Determines if the component accepts informal parameters"))
- (:default-initargs :informal-parameters nil
- :reserved-parameters nil
+ :reader wcomponent-allow-informal-parametersp
+ :allocation :class
+ :documentation "Determines if the component accepts informal parameters"))
+ (:default-initargs :reserved-parameters nil
:allow-informal-parameters t)
(:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own."))
-(defmethod wcomponent-informal-parameters ((wcomponent wcomponent)))
-
(defun slot-initarg-p (initarg class-precedence-list)
"Returns nil if a slot with that initarg isn't found into the list of classes passed"
(loop for class in class-precedence-list
- do (let* ((direct-slots (closer-mop:class-direct-slots class))
- (result (loop for slot in direct-slots
- do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg)
- (return initarg)))))
- (when result
- (return result)))))
+ do (let* ((direct-slots (closer-mop:class-direct-slots class))
+ (result (loop for slot in direct-slots
+ do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg)
+ (return initarg)))))
+ (when result
+ (return result)))))
(defmethod initialize-instance :after ((instance wcomponent) &rest rest)
(let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance)))
- (informal-parameters (loop for (k v) on rest by #'cddr
- for result = ()
- do (unless (slot-initarg-p k class-precedence-list)
- (push v result)
- (push k result))
- finally (return result))))
+ (informal-parameters (loop for (k v) on rest by #'cddr
+ for result = ()
+ do (unless (slot-initarg-p k class-precedence-list)
+ (push v result)
+ (push k result))
+ finally (return result))))
(setf (slot-value instance 'informal-parameters) informal-parameters)))
(defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg)
(let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg))
- (new-value (if (eq slot-initarg :id) (generate-id value) value))
- (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent))
- do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg)
- (return (closer-mop:slot-definition-name slot-definition))))))
+ (new-value (if (eq slot-initarg :id) (generate-id value) value))
+ (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent))
+ do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg)
+ (return (closer-mop:slot-definition-name slot-definition))))))
(if (find initarg (wcomponent-reserved-parameters wcomponent))
- (error (format nil "Parameter ~a is reserved" initarg))
- (if slot-name
- (setf (slot-value wcomponent slot-name) new-value)
- (if (null (wcomponent-allow-informal-parametersp wcomponent))
- (error (format nil
- "Component ~a doesn't accept informal parameters"
- slot-initarg))
- (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
-
-
+ (error (format nil "Parameter ~a is reserved" initarg))
+ (if slot-name
+ (setf (slot-value wcomponent slot-name) new-value)
+ (if (null (wcomponent-allow-informal-parametersp wcomponent))
+ (error (format nil
+ "Component ~a doesn't accept informal parameters"
+ slot-initarg))
+ (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value))))))
+
(defun make-component (name parameters content)
"This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the
initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content."
(let ((instance (make-instance name))
- (static-id (getf parameters :static-id)))
+ (static-id (getf parameters :static-id)))
(when static-id
- (remf parameters :id))
+ (remf parameters :id))
(loop for (initarg value) on parameters by #'cddr
do (setf (slot-initialization instance initarg) value))
(setf (htcomponent-body instance) content)
@@ -1063,9 +1054,9 @@
(let ((template (wcomponent-template wcomponent)))
(wcomponent-before-rewind wcomponent page)
(if (listp template)
- (dolist (tag template)
- (htcomponent-rewind tag page))
- (htcomponent-rewind template page))
+ (dolist (tag template)
+ (htcomponent-rewind tag page))
+ (htcomponent-rewind template page))
(wcomponent-after-rewind wcomponent page)))
(defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page)))
@@ -1074,23 +1065,23 @@
(defmethod htcomponent-prerender ((wcomponent wcomponent) (page page))
(wcomponent-before-prerender wcomponent page)
(let ((previous-print-status (page-can-print page))
- (template (wcomponent-template wcomponent)))
+ (template (wcomponent-template wcomponent)))
(when (null previous-print-status)
(setf (page-can-print page) (htcomponent-can-print wcomponent)))
(when (page-can-print page)
(dolist (script (htcomponent-script-files wcomponent))
- (pushnew script (page-script-files page) :test #'equal))
+ (pushnew script (page-script-files page) :test #'equal))
(dolist (css (htcomponent-stylesheet-files wcomponent))
- (pushnew css (page-stylesheet-files page) :test #'equal))
+ (pushnew css (page-stylesheet-files page) :test #'equal))
(dolist (js (htcomponent-class-initscripts wcomponent))
- (pushnew js (page-class-initscripts page) :test #'equal))
+ (pushnew js (page-class-initscripts page) :test #'equal))
(when (htcomponent-instance-initscript wcomponent)
- (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal)))
+ (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal)))
(if (listp template)
- (dolist (tag template)
- (when (subtypep (type-of tag) 'htcomponent)
- (htcomponent-prerender tag page)))
- (htcomponent-prerender template page))
+ (dolist (tag template)
+ (when (subtypep (type-of tag) 'htcomponent)
+ (htcomponent-prerender tag page)))
+ (htcomponent-prerender template page))
(when (null previous-print-status)
(setf (page-can-print page) nil)))
(wcomponent-after-prerender wcomponent page))
@@ -1100,19 +1091,19 @@
(defmethod htcomponent-render ((wcomponent wcomponent) (page page))
(let ((template (wcomponent-template wcomponent))
- (previous-print-status (page-can-print page)))
+ (previous-print-status (page-can-print page)))
(when (null previous-print-status)
(setf (page-can-print page) (htcomponent-can-print wcomponent))
(htcomponent-json-print-start-component wcomponent))
(wcomponent-before-render wcomponent page)
(unless (listp template)
(setf template (list template)))
- (dolist (child-tag template)
+ (dolist (child-tag template)
(when child-tag
- (cond
- ((stringp child-tag) (htcomponent-render ($> child-tag) page))
- ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
- (t (htcomponent-render child-tag page)))))
+ (cond
+ ((stringp child-tag) (htcomponent-render ($> child-tag) page))
+ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page))
+ (t (htcomponent-render child-tag page)))))
(wcomponent-after-render wcomponent page)
(when (null previous-print-status)
(setf (page-can-print page) nil)
@@ -1127,12 +1118,12 @@
(defmethod message-dispatch ((i18n-aware i18n-aware) key locale)
(let ((dispatcher (message-dispatcher i18n-aware))
- (result))
+ (result))
(when dispatcher
(progn
- (setf result (message-dispatch dispatcher key locale))
- (when (and (null result) (> (length locale) 2))
- (setf result (message-dispatch dispatcher key (subseq locale 0 2))))))
+ (setf result (message-dispatch dispatcher key locale))
+ (when (and (null result) (> (length locale) 2))
+ (setf result (message-dispatch dispatcher key (subseq locale 0 2))))))
result))
(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value)
1
0
06 May '08
Author: achiumenti
Date: Tue May 6 09:39:11 2008
New Revision: 44
Modified:
trunk/main/claw-core/claw.asd
trunk/main/claw-core/src/components.lisp
trunk/main/claw-core/src/lisplet.lisp
trunk/main/claw-core/src/misc.lisp
trunk/main/claw-core/src/packages.lisp
trunk/main/claw-core/src/server.lisp
trunk/main/claw-core/src/tags.lisp
trunk/main/claw-core/src/translators.lisp
trunk/main/claw-core/src/validators.lisp
trunk/main/claw-core/tests/packages.lisp
trunk/main/claw-core/tests/some-page.lisp
trunk/main/claw-core/tests/test1.lisp
Log:
refactoring finished
Modified: trunk/main/claw-core/claw.asd
==============================================================================
--- trunk/main/claw-core/claw.asd (original)
+++ trunk/main/claw-core/claw.asd Tue May 6 09:39:11 2008
@@ -31,7 +31,7 @@
:name "claw"
:author "Andrea Chiumenti"
:description "Common Lisp Active Web.A famework to write web applications"
- :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time)
+ :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence)
:components ((:module src
:components ((:file "packages")
(:file "misc" :depends-on ("packages"))
@@ -42,5 +42,5 @@
(:file "components" :depends-on ("tags"))
(:file "validators" :depends-on ("components"))
(:file "translators" :depends-on ("validators"))
- (:file "lisplet" :depends-on ("components"))
- (:file "server" :depends-on ("lisplet"))))))
+ (:file "server" :depends-on ("components"))
+ (:file "lisplet" :depends-on ("server"))))))
Modified: trunk/main/claw-core/src/components.lisp
==============================================================================
--- trunk/main/claw-core/src/components.lisp (original)
+++ trunk/main/claw-core/src/components.lisp Tue May 6 09:39:11 2008
@@ -209,43 +209,33 @@
(wcomponent-informal-parameters cinput))))
(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page))
- (let ((visit-object (cinput-visit-object cinput))
+ (let ((visit-object (or (cinput-visit-object cinput) page))
(accessor (cinput-accessor cinput))
(writer (cinput-writer cinput))
- (validator (validator cinput))
- (translator (translator cinput))
- (value ""))
- (multiple-value-bind (client-id request-value)
- (component-id-and-value cinput)
- (declare (ignore client-id))
- (setf value
- (handler-case
- (translator-decode translator cinput)
- (error () request-value)))
- (unless (null value)
+ (validator (validator cinput))
+ (value (translator-decode (translator cinput) cinput)))
+ (unless (or (null value) (component-validation-errors cinput))
(when validator
(funcall validator value))
(unless (component-validation-errors cinput)
- (when (null visit-object)
- (setf visit-object page))
- (if (and (null writer) accessor)
- (funcall (fdefinition `(setf ,accessor)) value visit-object)
- (funcall (fdefinition writer) value visit-object)))))))
+ (if (and (null writer) accessor)
+ (funcall (fdefinition `(setf ,accessor)) value visit-object)
+ (funcall (fdefinition writer) value visit-object))))))
(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t))
(let ((client-id (htcomponent-client-id cinput))
- (page (htcomponent-page cinput))
- (visit-object (cinput-visit-object cinput))
+ (visit-object (or (cinput-visit-object cinput) (htcomponent-page cinput)))
(accessor (cinput-accessor cinput))
(reader (cinput-reader cinput))
(result-as-list-p (cinput-result-as-list-p cinput))
(value ""))
- (when (null visit-object)
- (setf visit-object (htcomponent-page cinput)))
- (cond
- (from-request-p (setf value (page-req-parameter page client-id result-as-list-p)))
- ((and (null reader) accessor) (setf value (funcall (fdefinition accessor) visit-object)))
- (t (setf value (funcall (fdefinition reader) visit-object))))
+ (setf value
+ (cond
+ (from-request-p (page-req-parameter (htcomponent-page cinput)
+ client-id
+ result-as-list-p))
+ ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+ (t (funcall (fdefinition reader) visit-object))))
(values client-id value)))
Modified: trunk/main/claw-core/src/lisplet.lisp
==============================================================================
--- trunk/main/claw-core/src/lisplet.lisp (original)
+++ trunk/main/claw-core/src/lisplet.lisp Tue May 6 09:39:11 2008
@@ -29,6 +29,16 @@
(in-package :claw)
+(defgeneric clawserver-register-lisplet (clawserver lisplet)
+ (:documentation "This method registers a lisplet for request dispatching
+- CLAWSERVER the CLAWSERVER instance
+- LISPLET the LISPLET instance"))
+
+(defgeneric clawserver-unregister-lisplet (clawserver lisplet)
+ (:documentation "This method unregisters a lisplet from request dispatching
+- CLAWSERVER the CLAWSERVER instance
+- LISPLET the LISPLET instance"))
+
(defgeneric lisplet-register-function-location (lisplet function location &key welcome-page-p login-page-p)
(:documentation "Registers a function into a lisplet for dispatching.
parameters:
@@ -83,10 +93,15 @@
parameters:
- LISPLET the lisplet object."))
+(defgeneric build-lisplet-location (lisplet)
+ (:documentation "Constructs a full path prepending the lisplet base path to the given location"))
+
(setf *http-error-handler*
;;overrides the default hunchentoot error handling
#'(lambda (error-code)
- (let* ((error-handlers (lisplet-error-handlers (current-lisplet)))
+ (let* ((error-handlers (if (current-lisplet)
+ (lisplet-error-handlers (current-lisplet))
+ (make-hash-table)))
(handler (gethash error-code error-handlers)))
(if handler
(funcall handler)
@@ -127,16 +142,27 @@
(:documentation "A lisplet is a container for resources provided trhough the clawserver.
It is similar, for purposes, to a JAVA servlet"))
-(defun build-lisplet-location (lisplet location)
+(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet))
+ (let ((dispatchers (clawserver-dispatchers clawserver))
+ (location (lisplet-base-path lisplet)))
+ (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location
+ (cons location
+ #'(lambda ()
+ (progn
+ (setf (current-realm *request*) (lisplet-realm lisplet)
+ (current-lisplet) lisplet)
+ (lisplet-dispatch-method lisplet))))
+ dispatchers)))))
+
+(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
+ (let ((dispatchers (clawserver-dispatchers clawserver))
+ (location (lisplet-base-path lisplet)))
+ (remove-by-location location dispatchers)))
+
+
+(defmethod build-lisplet-location ((lisplet lisplet))
"Constructs a full path prepending the lisplet base path to the given location"
- (let ((server-base-path *clawserver-base-path*)
- (base-path (lisplet-base-path lisplet)))
- (if location
- (setf location (format nil "~a/~a" base-path location))
- (setf location base-path))
- (unless (null server-base-path)
- (setf location (format nil "~a~a" server-base-path location)))
- location))
+ (format nil "~a~a" (clawserver-base-path (current-server)) (lisplet-base-path lisplet)))
(defmethod lisplet-authentication-type ((lisplet lisplet))
(if (lisplet-login-page lisplet)
@@ -144,74 +170,64 @@
:basic))
(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p)
- (let ((pages (lisplet-pages lisplet))
- (new-location (build-lisplet-location lisplet location)))
+ (let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
- (sort-dispatchers (push-location-cons
- (cons new-location
- (create-prefix-dispatcher new-location
- function
- (lisplet-realm lisplet)))
- pages)))
+ (sort-by-location (pushnew-location (cons location function) pages)))
(when welcome-page-p
- (setf (lisplet-welcome-page lisplet) new-location))
+ (setf (lisplet-welcome-page lisplet) location))
(when login-page-p
- (setf (lisplet-login-page lisplet) new-location))))
+ (setf (lisplet-login-page lisplet) location))))
(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p)
- (let ((new-location (build-lisplet-location lisplet location)))
- (lisplet-register-function-location lisplet
- #'(lambda ()
- (with-output-to-string
- (*standard-output*)
- (page-render (make-instance page-class :lisplet lisplet :url new-location))))
- location
- :welcome-page-p welcome-page-p
- :login-page-p login-page-p)))
+ (lisplet-register-function-location lisplet
+ #'(lambda () (with-output-to-string (*standard-output*)
+ (page-render (make-instance page-class :lisplet lisplet :url location))))
+ location
+ :welcome-page-p welcome-page-p
+ :login-page-p login-page-p))
(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type)
- (let ((pages (lisplet-pages lisplet))
- (new-location (build-lisplet-location lisplet location)))
+ (let ((pages (lisplet-pages lisplet)))
(setf (lisplet-pages lisplet)
- (sort-dispatchers (push-location-cons
- (cons new-location
- (if (directory-pathname-p resource-path)
- (create-folder-dispatcher-and-handler new-location resource-path)
- (create-static-file-dispatcher-and-handler new-location resource-path content-type)))
+ (sort-by-location (pushnew-location
+ (cons location
+ (if (directory-pathname-p resource-path)
+ #'(lambda ()
+ (let ((resource-full-path (merge-pathnames
+ (uri-to-pathname (subseq (script-name)
+ (+ (length (clawserver-base-path (current-server)))
+ (length (lisplet-base-path (lisplet-base-path lisplet))))))
+ resource-path)))
+ (handle-static-file resource-full-path content-type)))
+ #'(lambda () (handle-static-file resource-path content-type))))
pages)))))
(defmethod lisplet-dispatch-request ((lisplet lisplet))
- (let ((pages (lisplet-pages lisplet)))
- (loop for dispatcher in pages
- for action = (funcall (cdr dispatcher) *request*)
- when action return (funcall action))))
+ (let ((dispatchers (lisplet-pages lisplet))
+ (rel-script-name (subseq (script-name) (length (build-lisplet-location lisplet)))))
+ (loop for dispatcher in dispatchers
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (cond
+ ((and (string< url rel-script-name)
+ (null (starts-with-subseq rel-script-name url))) (return nil))
+ ((starts-with-subseq rel-script-name url) (return (funcall action)))))))
(defmethod lisplet-dispatch-method ((lisplet lisplet))
- (let ((result nil)
- (base-path (build-lisplet-location lisplet nil))
- (uri (request-uri))
+ (let ((base-path (build-lisplet-location lisplet))
+ (uri (script-name))
(welcome-page (lisplet-welcome-page lisplet)))
- (progn
- (setf (current-lisplet) lisplet)
- (setf (current-realm) (lisplet-realm lisplet))
- (lisplet-check-authorization lisplet)
- (when (= (return-code) +http-ok+)
- (if (and welcome-page (string= uri base-path))
- (progn
- (redirect (lisplet-welcome-page lisplet))
- t)
- (progn
- (setf result (lisplet-dispatch-request lisplet))
- (when (null result)
- (setf (return-code) +http-not-found+))
- result))))))
+ (lisplet-check-authorization lisplet)
+ (when (= (return-code) +http-ok+)
+ (if (and welcome-page (string= uri base-path))
+ (page-render (lisplet-welcome-page lisplet))
+ (lisplet-dispatch-request lisplet)))))
(defmethod lisplet-protect ((lisplet lisplet) location roles)
- (let ((protected-resources (lisplet-protected-resources lisplet))
- (new-location (build-lisplet-location lisplet location)))
+ (let ((protected-resources (lisplet-protected-resources lisplet)))
(setf (lisplet-protected-resources lisplet)
- (sort-protected-resources (push-location-cons
- (cons new-location roles)
+ (sort-protected-resources (pushnew-location
+ (cons location roles)
protected-resources)))))
(defun redirect-to-https (server request)
@@ -231,7 +247,8 @@
(throw 'handler-done nil)))))
(defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*))
- (let ((uri (request-uri request))
+ (let ((uri (script-name request))
+ (base-path (build-lisplet-location lisplet))
(protected-resources (lisplet-protected-resources lisplet))
(princp (current-principal))
(login-config (current-config))
@@ -247,9 +264,9 @@
(cl-ppcre:all-matches login-page uri))
(redirect-to-https server request))
(loop for protected-resource in protected-resources
- for match = (format nil "^~a" (car protected-resource))
+ for match = (format nil "~a~a" base-path (car protected-resource))
for allowed-roles = (cdr protected-resource)
- do (when (cl-ppcre:all-matches match uri)
+ do (when (starts-with-subseq match uri)
(when (lisplet-redirect-protected-resources-p lisplet)
(redirect-to-https server request))
(if (null princp)
Modified: trunk/main/claw-core/src/misc.lisp
==============================================================================
--- trunk/main/claw-core/src/misc.lisp (original)
+++ trunk/main/claw-core/src/misc.lisp Tue May 6 09:39:11 2008
@@ -29,14 +29,14 @@
(in-package :claw)
-(defvar *clawserver-base-path* nil
- "This global variable is used to keep all lisplets \(claw web applications) under a common URL")
-
(defvar *apache-http-port* 80
"Default apache http port when claw is running in mod_lisp mode")
(defvar *apache-https-port* 443
"Default apache https port when claw is running in mod_lisp mode")
+(defvar *claw-libraries-resources* ()
+ "Global variable to hold exposed web resources")
+
(defun strings-to-jsarray (strings)
"Transforms a list of strings into a javascript array."
(let ((st-size (length strings))
@@ -51,11 +51,10 @@
items (prin1-to-string str))))
items)))))))
-(defun sort-dispatchers (dispatchers)
- "Sorts a list of dispatcher. A dispatcher is a cons where the car is the url
-where the dispatcher method(the cdr) will be called."
- (sort dispatchers #'(lambda (item1 item2)
- (string-not-lessp (car item1) (car item2)))))
+(defun sort-by-location (location-list)
+ "Sorts a list of location items by their first element (the location itself)."
+ (sort location-list #'(lambda (item1 item2)
+ (string-not-lessp (first item1) (first item2)))))
(defun sort-protected-resources (protected-resources)
"Sorts a list of protected resources. A protected resource is a cons where the car is the url
@@ -63,20 +62,20 @@
(sort protected-resources #'(lambda (item1 item2)
(string-lessp (car item1) (car item2)))))
-(defun remove-by-location (location cons-list)
- "Removes a cons checking its car
-against the location parameter"
- (delete-if #'(lambda (item) (string= (car item) location)) cons-list))
-
-(defun push-location-cons (location-cons cons-list)
- "Isert a new cons into a list of cons, or replace the one that has the same location
-registered (its car)."
- (let ((result (remove-by-location (car location-cons) cons-list)))
- (setf result (push location-cons result))))
+(defun remove-by-location (location location-list)
+ "Removes an item from LOCATION-LIST checking its first element
+against the LOCATION parameter"
+ (delete-if #'(lambda (item) (string= (first item) location)) location-list))
+
+(defun pushnew-location (location-items location-list)
+ "Isert a new location info items into a list, or replace the one that has the same location
+registered (its first element)."
+ (let ((result (remove-by-location (first location-items) location-list)))
+ (setf result (push location-items result))))
-(defun start-session ()
+(defun claw-start-session ()
"Starts a session bound to the current lisplet base path"
- (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet)))))
+ (start-session (format nil "~a/" (build-lisplet-location (current-lisplet)))))
(defun current-page (&optional (request *request*))
@@ -119,7 +118,7 @@
(defun (setf current-principal) (principal &optional (session *session*))
"Setf the principal(user) that logged into the application"
(unless session
- (setf session (start-session)))
+ (setf session (claw-start-session)))
(setf (session-value 'principal session) principal))
(defun user-in-role-p (roles &optional (session *session*))
@@ -211,7 +210,7 @@
"This function forces the locale for the current user, binding it to the user session,
that is created if no session exists."
(unless session
- (setf session (start-session)))
+ (setf session (claw-start-session)))
(setf (session-value 'locale session) locale))
(defun validation-errors (&optional (request *request*))
@@ -272,4 +271,33 @@
"Yes")
(if reserved-parameters
(format nil "~{:~a ~}" (eval reserved-parameters))
- "NONE"))))
\ No newline at end of file
+ "NONE"))))
+
+(defun register-library-resource (location resource-path &optional content-type)
+ "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION."
+ (setf *claw-libraries-resources*
+ (sort-by-location (pushnew-location
+ (cons location
+ (if (directory-pathname-p resource-path)
+ #'(lambda ()
+ (let ((resource-full-path (merge-pathnames
+ (uri-to-pathname (subseq (script-name)
+ (+ (length (clawserver-base-path (current-server)))
+ (length location))))
+ resource-path)))
+ (handle-static-file resource-full-path content-type)))
+ #'(lambda () (handle-static-file resource-path content-type))))
+ *claw-libraries-resources*))))
+
+(defun uri-to-pathname (uri)
+ "Convert an URI to a pathname"
+ (let* ((splitted-uri (split-sequence #\/ uri))
+ (directory-list (butlast splitted-uri))
+ (file (first (last splitted-uri)))
+ (pos (position #\. file :from-end t))
+ (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) ""))
+ (list (subseq file 0 pos)(subseq file (1+ pos)))
+ (list file))))
+ (make-pathname :directory directory-list
+ :name (first file-name-and-type)
+ :type (second file-name-and-type))))
Modified: trunk/main/claw-core/src/packages.lisp
==============================================================================
--- trunk/main/claw-core/src/packages.lisp (original)
+++ trunk/main/claw-core/src/packages.lisp Tue May 6 09:39:11 2008
@@ -33,8 +33,8 @@
(export 'HUNCHENTOOT::SESSION-REALM 'HUNCHENTOOT)
(defpackage :claw
- (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time)
- (:shadow :flatten :start-session)
+ (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence)
+ (:shadow :flatten)
(:documentation "A comprehensive web application framework and server for the Common Lisp programming language")
(:export :*html-4.01-strict*
:*html-4.01-transitional*
@@ -206,9 +206,11 @@
:lisplet-register-function-location
:lisplet-register-resource-location
:lisplet-protect
- :start-session
+ :lisplet-authentication-type
+ :claw-start-session
;; clawserver
- :clawserver
+ :clawserver
+ :clawserver-base-path
:clawserver-register-lisplet
:clawserver-unregister-lisplet
:clawserver-start
@@ -249,6 +251,7 @@
:page-current-component
:user-in-role-p
:login
+ :register-library-resource
;;i18n
:message-dispatcher
:message-dispatch
@@ -268,11 +271,11 @@
:validate
:validation-errors
:component-validation-errors
- :validator-required
- :validator-size
- :validator-range
- :validator-number
- :validator-integer
- :validator-date-range
+ :validate-required
+ :validate-size
+ :validate-range
+ :validate-number
+ :validate-integer
+ :validate-date-range
:exception-monitor
:exception-monitor>))
\ No newline at end of file
Modified: trunk/main/claw-core/src/server.lisp
==============================================================================
--- trunk/main/claw-core/src/server.lisp (original)
+++ trunk/main/claw-core/src/server.lisp Tue May 6 09:39:11 2008
@@ -1,4 +1,4 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/server.lisp $
;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.
@@ -29,18 +29,8 @@
(in-package :claw)
-(defgeneric clawserver-register-lisplet (clawserver lisplet)
- (:documentation "This method registers a lisplet for request dispatching
-- CLAWSERVER the CLAWSERVER instance
-- LISPLET the LISPLET instance"))
-
-(defgeneric clawserver-unregister-lisplet (clawserver lisplet)
- (:documentation "This method unregisters a lisplet from request dispatching
-- CLAWSERVER the CLAWSERVER instance
-- LISPLET the LISPLET instance"))
-
(defgeneric clawserver-dispatch-request (clawserver)
- (:documentation "Dispatches http requests through registered lisplets"))
+ (:documentation "Dispatches http requests through registered dispatchers"))
(defgeneric clawserver-dispatch-method (clawserver)
(:documentation "Uses CLAWSERVER-DISPATCH-REQUEST to perform dispatching"))
@@ -193,7 +183,10 @@
(format nil "The requested resource (~a) is not available." (request-uri *request*))))
(defclass clawserver ()
- ((port :initarg :port
+ ((base-path :initarg :base-path
+ :accessor clawserver-base-path
+ :documentation "This slot is used to keep all server resources under a common URL")
+ (port :initarg :port
:reader clawserver-port
:documentation "Returns the claw server http port")
(sslport :initarg :sslport
@@ -252,10 +245,12 @@
(sslserver :initform nil
:accessor clawserver-sslserver
:documentation "The hunchentoot server dispatching https requests.")
- (lisplets :initform nil
- :accessor clawserver-lisplets
+ (dispatchers :initform nil
+ :accessor clawserver-dispatchers
:documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet"))
- (:default-initargs :address nil
+ (:default-initargs :base-path ""
+ :use-apache-log-p nil
+ :address nil
:name (gensym)
:sslname (gensym)
:port 80
@@ -295,31 +290,7 @@
(when (eq use-apache-log-p :undefined)
(setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p)))
#-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined)
- (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file)))))
-
-(defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet))
- (let ((lisplets (clawserver-lisplets clawserver))
- (server-base-path *clawserver-base-path*)
- (location (lisplet-base-path lisplet)))
- (unless (null server-base-path)
- (setf location (format nil "~@[~a~]~a" server-base-path location)))
- (setf (clawserver-lisplets clawserver) (sort-dispatchers (push-location-cons
- (cons location
- (create-prefix-dispatcher
- location
- #'(lambda ()
- (lisplet-dispatch-method lisplet))
- (lisplet-realm lisplet)))
- lisplets)))))
-
-(defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet))
- (let ((lisplets (clawserver-lisplets clawserver))
- (server-base-path *clawserver-base-path*)
- (location (lisplet-base-path lisplet)))
- (unless (null server-base-path)
- (setf location (format nil "~@[~a~]~a" server-base-path location)))
- (remove-by-location location lisplets)))
-
+ (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file)))))
;;;-------------------------- WRITERS ----------------------------------------
@@ -399,33 +370,49 @@
(setf (slot-value clawserver 'ssl-privatekey-password) ssl-privatekey-password))
;;;-------------------------- METHODS ----------------------------------------
+
(defmethod clawserver-register-configuration ((clawserver clawserver) realm (configuration configuration))
(setf (gethash realm (clawserver-login-config clawserver)) configuration))
-(defmethod clawserver-dispatch-request ((clawserver clawserver))
- (let ((lisplets (clawserver-lisplets clawserver)))
- (loop for dispatcher in lisplets
- for action = (funcall (cdr dispatcher) *request*)
- when action return (funcall action))))
+(defmethod clawserver-dispatch-request ((clawserver clawserver))
+ (let ((base-path (clawserver-base-path clawserver))
+ (dispatchers (clawserver-dispatchers clawserver))
+ (script-name (script-name))
+ (rel-script-name))
+ (setf (current-server) clawserver)
+ (when (starts-with-subseq script-name base-path)
+ (setf rel-script-name (subseq script-name (length base-path)))
+ (or
+ (loop for dispatcher in *claw-libraries-resources*
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (cond
+ ((and (string< url rel-script-name)
+ (null (starts-with-subseq rel-script-name url))) (return nil))
+ ((starts-with-subseq rel-script-name url) (return (funcall action)))))
+ (loop for dispatcher in dispatchers
+ for url = (car dispatcher)
+ for action = (cdr dispatcher)
+ do (cond
+ ((and (string< url rel-script-name)
+ (null (starts-with-subseq rel-script-name url))) (return nil))
+ ((starts-with-subseq rel-script-name url) (return (funcall action)))))))))
+
(defmethod clawserver-dispatch-method ((clawserver clawserver))
- (let ((result nil))
- (progn
- ;(setf (aux-request-value 'clawserver) clawserver)
- (setf (current-server) clawserver)
- (setf result (clawserver-dispatch-request clawserver))
- (if (null result)
+ (let ((result (clawserver-dispatch-request clawserver)))
+ (if (null result)
#'(lambda () (when (= (return-code) +http-ok+)
- (setf (return-code *reply*) +http-not-found+)))
- #'(lambda () result)))))
+ (setf (return-code *reply*) +http-not-found+)))
+ #'(lambda () result))))
(defmethod clawserver-start ((clawserver clawserver))
(let ((port (clawserver-port clawserver))
(sslport (clawserver-sslport clawserver))
(address (clawserver-address clawserver))
(dispatch-table (list #'(lambda (request)
- (declare (ignorable request))
- (clawserver-dispatch-method clawserver))))
+ (declare (ignorable request))
+ (clawserver-dispatch-method clawserver))))
(name (clawserver-name clawserver))
(sslname (clawserver-sslname clawserver))
(mod-lisp-p (clawserver-mod-lisp-p clawserver))
@@ -476,8 +463,8 @@
;;;----------------------------------------------------------------------------
(defun login (&optional (request *request*))
"Perform user authentication for the reaml where the request has been created"
- (let* ((server (current-server request));(aux-request-value 'clawserver))
- (realm (current-realm request));(aux-request-value 'realm))
+ (let* ((server (current-server request))
+ (realm (current-realm request))
(login-config (gethash realm (clawserver-login-config server))))
(configuration-login login-config request)))
Modified: trunk/main/claw-core/src/tags.lisp
==============================================================================
--- trunk/main/claw-core/src/tags.lisp (original)
+++ trunk/main/claw-core/src/tags.lisp Tue May 6 09:39:11 2008
@@ -997,7 +997,6 @@
:documentation "Determines if the component accepts informal parameters"))
(:default-initargs :informal-parameters nil
:reserved-parameters nil
- :parameters nil
:allow-informal-parameters t)
(:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own."))
Modified: trunk/main/claw-core/src/translators.lisp
==============================================================================
--- trunk/main/claw-core/src/translators.lisp (original)
+++ trunk/main/claw-core/src/translators.lisp Tue May 6 09:39:11 2008
@@ -74,7 +74,7 @@
(defmethod translator-encode ((translator translator-integer) (wcomponent cinput))
(let* ((page (htcomponent-page wcomponent))
- (visit-object (cinput-visit-object wcomponent))
+ (visit-object (or (cinput-visit-object wcomponent) page))
(accessor (cinput-accessor wcomponent))
(reader (cinput-reader wcomponent))
(grouping-size (translator-grouping-size translator))
@@ -90,8 +90,6 @@
(if (component-validation-errors wcomponent)
value
(progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
(setf value (cond
((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
(t (funcall (fdefinition reader) visit-object))))
@@ -100,13 +98,16 @@
(format nil control-string value))))))
(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent))
- (let* ((thousand-separator (translator-thousand-separator translator)))
- (multiple-value-bind (client-id new-value)
+ (let ((thousand-separator (translator-thousand-separator translator)))
+ (multiple-value-bind (client-id value)
(component-id-and-value wcomponent)
- (declare (ignore client-id))
- (if thousand-separator
- (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value ""))
- (parse-integer new-value)))))
+ (handler-case
+ (if thousand-separator
+ (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
+ (parse-integer value))
+ (error () (progn
+ (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label wcomponent)))
+ value))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
@@ -131,65 +132,61 @@
(defmethod translator-encode ((translator translator-number) (wcomponent cinput))
(let* ((page (htcomponent-page wcomponent))
- (visit-object (cinput-visit-object wcomponent))
+ (visit-object (or (cinput-visit-object wcomponent) page))
(accessor (cinput-accessor wcomponent))
(reader (cinput-reader wcomponent))
(thousand-separator (translator-thousand-separator translator))
(grouping-size (translator-grouping-size translator))
(decimal-digits (translator-decimal-digits translator))
(decimals-separator (translator-decimals-separator translator))
- (signum-directive (if (translator-always-show-signum translator)
- "@"
- ""))
+ (signum-directive (if (translator-always-show-signum translator) "@" ""))
(integer-control-string (if thousand-separator
- (format nil "~~~d,',v:~aD" grouping-size signum-directive)
- (format nil "~~~ad" signum-directive)))
-
+ (format nil "~~~d,',v:~aD" grouping-size signum-directive)
+ (format nil "~~~ad" signum-directive)))
(value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))
(if (component-validation-errors wcomponent)
value
- (progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
- (multiple-value-bind (int-value dec-value)
- (floor (cond
- ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
- (t (funcall (fdefinition reader) visit-object))))
- (progn
- (setf dec-value (coerce dec-value 'float))
- (format nil "~a~a" (if thousand-separator
- (string-trim " " (format nil integer-control-string thousand-separator int-value))
- (format nil integer-control-string int-value))
- (cond
- ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
- (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
- (decimal-digits
- (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
- (if (> (length frac-part) decimal-digits)
- (setf frac-part (subseq frac-part 0 decimal-digits))
- (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
- (format nil "~a~a" decimals-separator frac-part)))
- (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2)))))))))))
+ (multiple-value-bind (int-value dec-value)
+ (floor (cond
+ ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+ (t (funcall (fdefinition reader) visit-object))))
+ (setf dec-value (coerce dec-value 'float))
+ (format nil "~a~a"
+ (if thousand-separator
+ (string-trim " " (format nil integer-control-string thousand-separator int-value))
+ (format nil integer-control-string int-value))
+ (cond
+ ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
+ (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
+ (decimal-digits
+ (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
+ (if (> (length frac-part) decimal-digits)
+ (setf frac-part (subseq frac-part 0 decimal-digits))
+ (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
+ (format nil "~a~a" decimals-separator frac-part)))
+ (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2)))))))))
(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent))
- (let* ((thousand-separator (translator-thousand-separator translator))
- (type (translator-coerce translator))
- (int-value)
- (dec-value))
- (multiple-value-bind (client-id new-value)
- (component-id-and-value wcomponent)
- (declare (ignore client-id))
- (when thousand-separator
- (setf new-value (regex-replace-all (format nil "~a" thousand-separator) new-value "")))
- (let ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
- (result))
- (setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))
- dec-value (expt 10 (length (second decomposed-string)))
- result (/ int-value dec-value))
- (if (integerp result)
- result
- (coerce result type))))))
+ (let ((thousand-separator (translator-thousand-separator translator))
+ (type (translator-coerce translator))
+ (new-value))
+ (multiple-value-bind (client-id value)
+ (component-id-and-value wcomponent)
+ (if thousand-separator
+ (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
+ (setf new-value value))
+ (handler-case
+ (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
+ (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string))))
+ (dec-value (expt 10 (length (second decomposed-string))))
+ (result (/ int-value dec-value)))
+ (if (integerp result)
+ result
+ (coerce result type)))
+ (error () (progn
+ (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label wcomponent)))
+ value))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -204,14 +201,14 @@
(:default-initargs :local-time-format '(:month "/" :date "/" :year))
(:documentation "A translator object encodes and decodes local-date object value passed to a html input component.
When decoding the input compoenent value string to a local-time instance
-if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATOR-DATE\".
+if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATE-DATE\".
The argument for the message will be the :label attribute of the COMPONENT and the input component string value."))
(defmethod translator-encode ((translator translator-date) (wcomponent cinput))
(let* ((page (htcomponent-page wcomponent))
- (visit-object (cinput-visit-object wcomponent))
+ (visit-object (or (cinput-visit-object wcomponent) page))
(accessor (cinput-accessor wcomponent))
(reader (cinput-reader wcomponent))
(local-time-format (translator-local-time-format translator))
@@ -219,15 +216,11 @@
(if (component-validation-errors wcomponent)
value
(progn
- (when (null visit-object)
- (setf visit-object (htcomponent-page wcomponent)))
(setf value (cond
((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
(t (funcall (fdefinition reader) visit-object))))
(if (and value (not (stringp value)))
- (progn
- (local-time-to-string value
- local-time-format))
+ (local-time-to-string value local-time-format)
value)))))
(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent))
@@ -279,7 +272,7 @@
(and (> month 0) (<= month 12))
(and (> day 0) (<= day (days-in-month month year))))
:component wcomponent
- :message (format nil (do-message "VALIDATOR-DATE" "Field ~a is not a valid date or wrong format: ~a")
+ :message (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a")
(label wcomponent)
old-value))
(if (component-validation-errors wcomponent)
Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp (original)
+++ trunk/main/claw-core/src/validators.lisp Tue May 6 09:39:11 2008
@@ -67,19 +67,19 @@
(unless test
(add-exception client-id message))))
-(defun validator-required (component value)
- "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATOR-REQUIRED\".
+(defun validate-required (component value)
+ "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATE-REQUIRED\".
The argument for the message will be the :label attribute of the COMPONENT."
(when (stringp value)
(validate (and value (string-not-equal value ""))
:component component
- :message (format nil (do-message "VALIDATOR-REQUIRED" "Field ~a may not be null.") (label component)))))
+ :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be null.") (label component)))))
-(defun validator-size (component value &key min-size max-size)
+(defun validate-size (component value &key min-size max-size)
"Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE.
-If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATOR-SIZE-MIN\".
+If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value.
-If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATOR-SIZE-MAX\".
+If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\".
The argument for the message will be the :label attribute of the COMPONENT and the :MAX-ZIZE value."
(let ((value-len 0))
(when value
@@ -89,27 +89,27 @@
(when min-size
(validate (>= value-len min-size)
:component component
- :message (format nil (do-message "VALIDATOR-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
+ :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." )
(label component)
min-size)))
(when max-size
(validate (<= value-len max-size)
:component component
- :message (format nil (do-message "VALIDATOR-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
+ :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." )
(label component)
max-size)))))))
-(defun validator-range (component value &key min max)
+(defun validate-range (component value &key min max)
"Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX.
-If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATOR-RANGE-MIN\".
+If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the :MIN value.
-If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATOR-RANGE-MAX\".
+If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\".
The argument for the message will be the :label attribute of the COMPONENT and the :MAX value."
(when value
(and (when min
(validate (>= value min)
:component component
- :message (format nil (do-message "VALIDATOR-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
+ :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d")
(label component)
(if (typep min 'ratio)
(coerce min 'float)
@@ -117,43 +117,43 @@
(when max
(validate (<= value max)
:component component
- :message (format nil (do-message "VALIDATOR-RANGE-MAX" "Field ~a is not less then or equal to ~d")
+ :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d")
(label component)
(if (typep max 'ratio)
(coerce max 'float)
max)))))))
-(defun validator-number (component value &key min max)
+(defun validate-number (component value &key min max)
"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
-If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATOR-NUMBER\".
+If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\".
The argument for the message will be the :label attribute of the COMPONENT."
(when value
(let ((test (numberp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (label component)))
- (validator-range component value :min min :max max)))))
+ :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))
+ (validate-range component value :min min :max max)))))
-(defun validator-integer (component value &key min max)
+(defun validate-integer (component value &key min max)
"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE.
-If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATOR-INTEGER\".
+If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\".
The argument for the message will be the :label attribute of the COMPONENT."
(when value
(let ((test (integerp value)))
(and (validate test
:component component
- :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (label component)))
- (validator-range component value :min min :max max)))))
+ :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))
+ (validate-range component value :min min :max max)))))
-(defun validator-date-range (component value &key min max (use-date-p t) use-time-p)
+(defun validate-date-range (component value &key min max (use-date-p t) use-time-p)
"Checks if the input field VALUE is a date between min and max.
If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time.
If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time.
If :USE-DATE-P and :USE-TIME-P are both not nil or nil, validation is made considering the date and time part of local-time.
-If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATOR-DATE-RANGE-MIN\".
+If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MIN\".
The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MIN parsed with the :LOCAL-TIME-FORMAT keyword.
-If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATOR-DATE-RANGE-MAX\".
+If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MAX\".
The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword."
(unless (component-validation-errors component)
(let ((local-time-format '(:date "-" :month "-" :year))
@@ -180,13 +180,13 @@
(and (when min
(validate (local-time> new-value min)
:component component
- :message (format nil (do-message "VALIDATOR-DATE-RANGE-MIN" "Field ~a is less then ~a.")
+ :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.")
(label component)
(local-time-to-string min local-time-format))))
(when max
(validate (local-time< new-value max)
:component component
- :message (format nil (do-message "VALIDATOR-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
+ :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.")
(label component)
(local-time-to-string max local-time-format))))))))
@@ -212,7 +212,7 @@
(validation-errors (aux-request-value :validation-errors)))
(when validation-errors
(ul> :static-id client-id
- (wcomponent-informal-parameters cform)
+ (wcomponent-informal-parameters exception-monitor)
(loop for component-exceptions in validation-errors
collect (loop for message in (cdr component-exceptions)
collect (li> message)))))))
Modified: trunk/main/claw-core/tests/packages.lisp
==============================================================================
--- trunk/main/claw-core/tests/packages.lisp (original)
+++ trunk/main/claw-core/tests/packages.lisp Tue May 6 09:39:11 2008
@@ -30,6 +30,6 @@
(in-package :cl-user)
(defpackage :claw-tests
- (:use :cl :claw :hunchentoot :local-time)
+ (:use :cl :hunchentoot :claw :local-time)
(:export :claw-tst-start
:claw-tst-stop))
\ No newline at end of file
Modified: trunk/main/claw-core/tests/some-page.lisp
==============================================================================
--- trunk/main/claw-core/tests/some-page.lisp (original)
+++ trunk/main/claw-core/tests/some-page.lisp Tue May 6 09:39:11 2008
@@ -29,9 +29,10 @@
(in-package :claw-tests)
-(defcomponent inspector ()
+(defclass inspector (wcomponent)
((ref-id :initarg :ref-id
- :reader ref-id)))
+ :reader ref-id))
+ (:metaclass metacomponent))
(defmethod wcomponent-template ((inspector inspector))
(div> :static-id (htcomponent-client-id inspector)
@@ -54,4 +55,4 @@
(div> :static-id hidden-component-id :style "display: none;" rnd-value)
(inspector> :id "inspector" :ref-id hidden-component-id "Show value")))))
-(lisplet-register-page-location *test-lisplet* 'some-page "some-page.html")
+(lisplet-register-page-location *test-lisplet* 'some-page "/some-page.html")
Modified: trunk/main/claw-core/tests/test1.lisp
==============================================================================
--- trunk/main/claw-core/tests/test1.lisp (original)
+++ trunk/main/claw-core/tests/test1.lisp Tue May 6 09:39:11 2008
@@ -29,13 +29,16 @@
(in-package :claw-tests)
-(setf *default-content-type* "text/html; charset=UTF-8")
+(setf hunchentoot:*default-content-type* "text/html; charset=UTF-8")
+
+(setf hunchentoot:*rewrite-for-session-urls* nil)
-(setf *rewrite-for-session-urls* nil)
(defvar *this-file* (load-time-value
(or #.*compile-file-pathname* *load-pathname*)))
-(setf *clawserver-base-path* "/claw")
+
+(register-library-resource "/libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img"))))
+(register-library-resource "/libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
(defvar *lisplet-messages*
(make-instance 'simple-message-dispatcher))
@@ -48,29 +51,33 @@
(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome")
(simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto")
-(simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATOR-REQUIRED" "Il campo ~a non può essere vuoto!")
+(simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!")
(defvar *test-lisplet*)
(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test"
- ));:message-dispatcher *lisplet-messages*))
+ :redirect-protected-resources-p t))
(defvar *test-lisplet2*)
(setf *test-lisplet2* (make-instance 'lisplet :realm "test2"
:base-path "/test2"))
-;;(defparameter *clawserver* (make-instance 'clawserver :port 4242))
+;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw"))
-(defvar *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445
- :mod-lisp-p nil
- :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem"
- :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem"))
+(defvar *clawserver* (make-instance 'clawserver
+ :port 4242
+ :sslport 4445
+ :base-path "/claw"
+ :mod-lisp-p nil
+ :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem"
+ :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem"))
-(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t)
+;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t)
(clawserver-register-lisplet *clawserver* *test-lisplet*)
(clawserver-register-lisplet *clawserver* *test-lisplet2*)
(defun test-configuration-do-login (request user password)
+ (declare (ignore request))
(let ((session *session*))
(when (and (string-equal user "kiuma")
(string-equal password "password"))
@@ -130,10 +137,10 @@
(defmethod page-content ((page auth-page))
(site-template> :title "Unauth test page"
(p> "protected content")))
-(lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html")
-(lisplet-register-page-location *test-lisplet* 'auth-page "auth.html")
-(lisplet-protect *test-lisplet* "auth.html" '("admin" "user"))
-(lisplet-protect *test-lisplet* "unauth.html" '("nobody"))
+(lisplet-register-page-location *test-lisplet* 'auth-page "/unauth.html")
+(lisplet-register-page-location *test-lisplet* 'auth-page "/auth.html")
+(lisplet-protect *test-lisplet* "/auth.html" '("admin" "user"))
+(lisplet-protect *test-lisplet* "/unauth.html" '("nobody"))
(defclass index-page (page) ())
@@ -145,6 +152,8 @@
"Do login"))
(li> (a> :href "info.html"
"Headers info"))
+ (li> (a> :href (format nil "~a/libs/images/matrix.jpg" (clawserver-base-path (current-server)))
+ "show static file provided by CLAW-TESTS package"))
(li> (a> :href "images/matrix.jpg"
"show static file"))
(li> (a> :href "images/matrix2.jpg"
@@ -157,7 +166,7 @@
(li> (a> :href "form.html" "form components test"))
(li> (a> :href "auth.html" "authorized page"))
(li> (a> :href "unauth.html" "unauthorized page"))))))
-(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t)
+(lisplet-register-page-location *test-lisplet* 'index-page "/index.html" :welcome-page-p t)
(defclass msie-p (wcomponent)
()
@@ -189,30 +198,30 @@
(td> (format nil "~a" (cdr key-val))))))))
(msie-p> :id "msie"))))
-(lisplet-register-page-location *test-lisplet* 'info-page "info.html")
+(lisplet-register-page-location *test-lisplet* 'info-page "/info.html")
(defun test-image-file ()
(make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg"))
-(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg")
+(lisplet-register-resource-location *test-lisplet* (test-image-file) "/images/matrix.jpg" "image/jpeg")
(lisplet-register-function-location *test-lisplet*
- #'(lambda ()
+ (lambda ()
(let ((path (test-image-file)))
- (setf (content-type) (mime-type path))
+ (setf (hunchentoot:content-type) (hunchentoot:mime-type path))
(with-open-file (in path :element-type 'flex:octet)
(let ((image-data (make-array (file-length in)
:element-type 'flex:octet)))
(read-sequence image-data in)
image-data))))
- "images/matrix2.jpg" )
+ "/images/matrix2.jpg" )
;;;--------------------realm test page--------------------------------
(defclass realm-page (page) ())
(defmethod page-content ((o realm-page))
- (when (null *session*)
- (start-session))
+ (when (null hunchentoot:*session*)
+ (claw-start-session))
(unless (session-value 'RND-NUMBER)
(setf (session-value 'RND-NUMBER) (random 1000)))
(site-template> :title "Realm test page"
@@ -228,13 +237,13 @@
(li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER)))
(li> "Remote Addr: " (session-remote-addr *session*))
(li> "User agent: " (session-user-agent *session*))
- (li> "Lisplet Realm: " (lisplet-realm (page-lisplet o)))
+ (li> "Lisplet Realm: " (current-realm))
(li> "Session Realm: " (session-realm *session*))
(li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*)))
(li> "Request Realm: " (hunchentoot::realm *request*))))))
-(lisplet-register-page-location *test-lisplet* 'realm-page "realm.html")
-(lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html")
+(lisplet-register-page-location *test-lisplet* 'realm-page "/realm.html")
+(lisplet-register-page-location *test-lisplet2* 'realm-page "/realm.html")
;;;--------------------id testing page--------------------------------
(defclass id-tests-page (page) ())
@@ -262,7 +271,7 @@
:style "cursor: pointer;"
"passed id: 'uid' (generated with generate-id)[click me, to see generated id]"))))
-(lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html")
+(lisplet-register-page-location *test-lisplet* 'id-tests-page "/id-tests.html")
;;;--------------------from components testing page--------------------------------
@@ -307,7 +316,7 @@
(aux-request-value 'password) (login-page-password login-page))
(login))
-(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t)
+(lisplet-register-page-location *test-lisplet* 'login-page "/login.html" :login-page-p t)
(defclass user ()
((name :initarg :name
@@ -378,7 +387,7 @@
:type "text"
:label "Name"
:validator #'(lambda (value)
- (validator-required (page-current-component o) value))
+ (validate-required (page-current-component o) value))
:accessor 'form-page-name)"*"))
(tr> :id "messaged"
(td> (with-message "SURNAME" "SURNAME"))
@@ -387,8 +396,8 @@
:type "text"
:label "Surname"
:validator #'(lambda (value)
- (validator-required (page-current-component o) value)
- (validator-size (page-current-component o) value :min-size 1 :max-size 20))
+ (validate-required (page-current-component o) value)
+ (validate-size (page-current-component o) value :min-size 1 :max-size 20))
:accessor 'form-page-surname)"*"))
(tr>
(td> "Gender")
@@ -411,11 +420,11 @@
:translator (make-instance 'translator-integer :thousand-separator #\')
:validator #'(lambda (value)
(let ((component (page-current-component o)))
- (validator-required component value)
- (validator-integer component value :min 1 :max 2000)))
+ (validate-required component value)
+ (validate-integer component value :min 1 :max 2000)))
:accessor 'form-page-age)"*"))
(tr>
- (td> "Bithday")
+ (td> "Birthday")
(td>
(cinput> :id "bday"
:type "text"
@@ -423,7 +432,7 @@
:translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year))
:validator #'(lambda (value)
(let ((component (page-current-component o)))
- (validator-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
+ (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900))))
:accessor 'form-page-birthday)"(dd-mm-yyyy)"))
(tr>
(td> "Capital")
@@ -436,8 +445,8 @@
:thousand-separator #\')
:validator #'(lambda (value)
(let ((component (page-current-component o)))
- (validator-required component value)
- (validator-number component value :min 1000.01 :max 500099/100)))
+ (validate-required component value)
+ (validate-number component value :min 1000.01 :max 500099/100)))
:accessor 'form-page-capital)"*"))
(tr>
(td> "Colors")
@@ -466,7 +475,7 @@
(div> (format nil "Gender: ~a" (user-gender (form-page-user o))))
(div> (format nil "Age: ~a" (user-age (form-page-user o)))))))
-(lisplet-register-page-location *test-lisplet* 'form-page "form.html")
+(lisplet-register-page-location *test-lisplet* 'form-page "/form.html")
1
0