- claw-cvs@common-lisp.net - mailman3.common-lisp.net

[claw-cvs] r45 - in trunk/main/claw-core: . src
by achiumenti＠common-lisp.net 12 May '08

12 May '08

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 "~%//]]>"))) + (not (null (htcomponent-body htscript)))) + (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

[claw-cvs] r44 - in trunk/main/claw-core: . src tests
by achiumenti＠common-lisp.net 06 May '08

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

[claw-cvs] r43 - in trunk/main/claw-core: src tests
by achiumenti＠common-lisp.net 27 Apr '08

27 Apr '08

Author: achiumenti Date: Sun Apr 27 12:15:22 2008 New Revision: 43 Modified: 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 trunk/main/claw-core/src/translators.lisp trunk/main/claw-core/src/validators.lisp trunk/main/claw-core/tests/test1.lisp Log: API cleanup Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sun Apr 27 12:15:22 2008 @@ -86,7 +86,7 @@ (setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) - (let* ((error-handlers (lisplet-error-hadlers (current-lisplet))) + (let* ((error-handlers (lisplet-error-handlers (current-lisplet))) (handler (gethash error-code error-handlers))) (if handler (funcall handler) @@ -112,7 +112,7 @@ :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-hadlers + :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 @@ -192,9 +192,7 @@ (uri (request-uri)) (welcome-page (lisplet-welcome-page lisplet))) (progn - ;;(setf (aux-request-value 'lisplet) lisplet) (setf (current-lisplet) lisplet) - ;;(setf (aux-request-value 'realm) (lisplet-realm lisplet)) (setf (current-realm) (lisplet-realm lisplet)) (lisplet-check-authorization lisplet) (when (= (return-code) +http-ok+) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sun Apr 27 12:15:22 2008 @@ -74,7 +74,7 @@ (let ((result (remove-by-location (car location-cons) cons-list))) (setf result (push location-cons result)))) -(defun lisplet-start-session () +(defun 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))))) @@ -119,7 +119,7 @@ (defun (setf current-principal) (principal &optional (session *session*)) "Setf the principal(user) that logged into the application" (unless session - (setf session (lisplet-start-session))) + (setf session (start-session))) (setf (session-value 'principal session) principal)) (defun user-in-role-p (roles &optional (session *session*)) @@ -191,7 +191,7 @@ ,default-val))))) (defun do-message (key &optional (default "") locale) - "This function call the lambda function returned by the WITH-MESSAGE macro." + "This function calls the lambda function returned by the WITH-MESSAGE macro." (funcall (with-message key default locale))) (defun user-locale (&optional (request *request*) (session *session*)) @@ -211,7 +211,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 (lisplet-start-session))) + (setf session (start-session))) (setf (session-value 'locale session) locale)) (defun validation-errors (&optional (request *request*)) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sun Apr 27 12:15:22 2008 @@ -34,7 +34,7 @@ (defpackage :claw (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) - (:shadow :flatten) + (:shadow :flatten :start-session) (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") (:export :*html-4.01-strict* :*html-4.01-transitional* @@ -52,46 +52,29 @@ :strings-to-jsarray :empty-string-p :build-tagf - :parse-htcomponent-function - :page ;page classes hadle the whole rendering cycle - :message-dispatch - :page-writer - :page-can-print - :page-url + :page + :message-dispatch :page-lisplet :page-current-form - :page-req-parameter - :page-json-id-list - :page-format - :page-format-raw + :page-req-parameter :page-script-files :page-stylesheet-files :page-class-initscripts :page-instance-initscripts - :page-indent - :page-xmloutput - :page-doc-type - :page-current-component - :page-content-type - :htclass-body + :page-current-component :htcomponent :htcomponent-page :htcomponent-body -; :setf-htcomponent-page - :htcomponent-attributes - :htcomponent-can-print :htcomponent-empty :htcomponent-client-id :htcomponent-script-files :htcomponent-stylesheet-files :htcomponent-class-initscripts :htcomponent-instance-initscript - :tag ;class for tags that accept body + :tag :tag-name - :tag-render-starttag - :tag-render-endtag + :tag-attributes :htbody - :page-body-init-scripts :htscript :htlink :hthead @@ -193,32 +176,23 @@ :var> ;; class modifiers :page-content - :page-render :generate-id :metacomponent :wcomponent - :wcomponent-parameters :wcomponent-informal-parameters :wcomponent-allow-informal-parametersp :wcomponent-template - :wcomponent-parameter-value :wcomponent-before-rewind :wcomponent-after-rewind :wcomponent-before-prerender :wcomponent-after-prerender :wcomponent-before-render :wcomponent-after-render - :make-component :cform :cform> :action-link :action-link> - :base-cinput :cinput - :cinput-reader - :cinput-writer - :cinput-accessor - :cinput-visit-object :cinput> :cselect :cselect> @@ -227,18 +201,12 @@ :submit-link :submit-link> :lisplet - :lisplet-realm :lisplet-pages - :lisplet-base-path - :lisplet-dispatch-method :lisplet-register-page-location :lisplet-register-function-location :lisplet-register-resource-location - :lisplet-protect - :lisplet-authentication-type - :lisplet-start-session - :lisplet-error-handlers - :lisplet-redirect-protected-resources-p + :lisplet-protect + :start-session ;; clawserver :clawserver :clawserver-register-lisplet @@ -255,8 +223,7 @@ :clawserver-input-chunking-p :clawserver-read-timeout :clawserver-write-timeout - :clawserver-login-config - :login + :clawserver-login-config #+(and :unix (not :win32)) :clawserver-setuid #+(and :unix (not :win32)) :clawserver-setgid #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file @@ -266,8 +233,7 @@ :*id-and-static-id-description* :describe-component-behaviour :describe-html-attributes-from-class-slot-initargs - :clawserver-register-configuration - :claw-require-authorization + :clawserver-register-configuration :configuration :configuration-login :principal Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sun Apr 27 12:15:22 2008 @@ -161,6 +161,9 @@ - TAG is the tag instance - PAGE the page instance")) +(defgeneric tag-attributes (tag) + (:documentation "Returns an alist of tag attributes")) + (defgeneric (setf htcomponent-page) (page htcomponent) (:documentation "Internal method to set the component owner page and to assign an unique id attribute when provided. @@ -170,20 +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-parameter-value (wcomponent key) - (:documentation "Returns the value of a parameter passed to the wcomponent initialization -function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed. - - WCOMPONENT is the wcomponent instance - - KEY the parameter key to query")) - -(defgeneric wcomponent-check-parameters(wcomponent) - (:documentation "This internal method check if all :REQUIRED parameters are provided - - WCOMPONENT is the wcomponent instance")) - -(defgeneric wcomponent-parameters(wcomponent) - (:documentation "This method returns class formal parameters as an alist (formal parameters are the ones expected by the component) - - WCOMPONENT is the wcomponent instance")) - (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) @@ -528,7 +517,6 @@ (member tag-name *empty-tags* :test #'string-equal)) ;;;--------------------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)) @@ -779,6 +767,9 @@ (htcomponent-json-print-end-component htcomponent)))) ;;;========= TAG ===================================== +(defmethod tag-attributes ((tag tag)) + (htcomponent-attributes tag)) + (defmethod tag-render-attributes ((tag tag) (page page)) (when (htcomponent-attributes tag) (loop for (k v) on (htcomponent-attributes tag) by #'cddr @@ -992,11 +983,7 @@ ;;;========= WCOMPONENT =================================== (defclass wcomponent (htcomponent) - ((parameters :initarg :parameters - :accessor wcomponent-parameters - :type cons - :documentation "must be a plist or nil") - (reserved-parameters :initarg :reserved-parameters + ((reserved-parameters :initarg :reserved-parameters :accessor wcomponent-reserved-parameters :type cons :documentation "Parameters that may not be used in the constructor function") @@ -1036,8 +1023,6 @@ finally (return result)))) (setf (slot-value instance 'informal-parameters) informal-parameters))) -(defmethod wcomponent-check-parameters((comp wcomponent))) - (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)) @@ -1065,7 +1050,6 @@ (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr do (setf (slot-initialization instance initarg) value)) - (wcomponent-check-parameters instance) (setf (htcomponent-body instance) content) instance)) @@ -1076,13 +1060,6 @@ (let ((fbody (parse-htcomponent-function (flatten rest)))) (make-component component-name (first fbody) (second fbody)))) - -(defmethod wcomponent-parameter-value ((c wcomponent) key) - (let ((result (getf (htcomponent-attributes c) key :undefined))) - (if (eq result :undefined) - (getf (wcomponent-parameters c) key) - result))) - (defmethod htcomponent-rewind ((wcomponent wcomponent) (page page)) (let ((template (wcomponent-template wcomponent))) (wcomponent-before-rewind wcomponent page) Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Sun Apr 27 12:15:22 2008 @@ -280,7 +280,7 @@ (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") - (wcomponent-parameter-value wcomponent :label) + (label wcomponent) old-value)) (if (component-validation-errors wcomponent) old-value Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Sun Apr 27 12:15:22 2008 @@ -73,7 +73,7 @@ (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.") (wcomponent-parameter-value component :label))))) + :message (format nil (do-message "VALIDATOR-REQUIRED" "Field ~a may not be null.") (label component))))) (defun validator-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. @@ -90,13 +90,13 @@ (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." ) - (wcomponent-parameter-value component :label) + (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." ) - (wcomponent-parameter-value component :label) + (label component) max-size))))))) (defun validator-range (component value &key min max) @@ -110,7 +110,7 @@ (validate (>= value min) :component component :message (format nil (do-message "VALIDATOR-RANGE-MIN" "Field ~a is not greater then or equal to ~d") - (wcomponent-parameter-value component :label) + (label component) (if (typep min 'ratio) (coerce min 'float) min)))) @@ -118,7 +118,7 @@ (validate (<= value max) :component component :message (format nil (do-message "VALIDATOR-RANGE-MAX" "Field ~a is not less then or equal to ~d") - (wcomponent-parameter-value component :label) + (label component) (if (typep max 'ratio) (coerce max 'float) max))))))) @@ -131,7 +131,7 @@ (let ((test (numberp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (wcomponent-parameter-value component :label))) + :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (label component))) (validator-range component value :min min :max max))))) (defun validator-integer (component value &key min max) @@ -142,7 +142,7 @@ (let ((test (integerp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (wcomponent-parameter-value component :label))) + :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (label component))) (validator-range component value :min min :max max))))) @@ -156,7 +156,7 @@ 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\". 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));(translator-local-time-format (wcomponent-parameter-value component :translator))) + (let ((local-time-format '(:date "-" :month "-" :year)) (new-value (make-instance 'local-time :nsec (nsec-of value) :sec (sec-of value) @@ -181,13 +181,13 @@ (validate (local-time> new-value min) :component component :message (format nil (do-message "VALIDATOR-DATE-RANGE-MIN" "Field ~a is less then ~a.") - (wcomponent-parameter-value component :label) + (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.") - (wcomponent-parameter-value component :label) + (label component) (local-time-to-string max local-time-format)))))))) @@ -207,10 +207,6 @@ (describe-html-attributes-from-class-slot-initargs class) (describe-component-behaviour class)))) -(defmethod wcomponent-parameters ((exception-monitor exception-monitor)) - (declare (ignore exception-monitor)) - (list :class nil)) - (defmethod wcomponent-template ((exception-monitor exception-monitor)) (let ((client-id (htcomponent-client-id exception-monitor)) (validation-errors (aux-request-value :validation-errors))) Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Sun Apr 27 12:15:22 2008 @@ -73,12 +73,8 @@ (defun test-configuration-do-login (request user password) (let ((session *session*)) (when (and (string-equal user "kiuma") - (string-equal password "password")) - (progn - ;;(unless session - ;; (setf session (lisplet-start-session))) - ;;(setf (session-value 'principal session) (make-instance 'principal :name user :roles '("user"))))))) - (setf (current-principal session) (make-instance 'principal :name user :roles '("user"))))))) + (string-equal password "password")) + (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) @@ -216,7 +212,7 @@ (defmethod page-content ((o realm-page)) (when (null *session*) - (lisplet-start-session)) + (start-session)) (unless (session-value 'RND-NUMBER) (setf (session-value 'RND-NUMBER) (random 1000))) (site-template> :title "Realm test page"

1 0

[claw-cvs] r42 - in trunk/main/claw-core: . src tests
by achiumenti＠common-lisp.net 26 Apr '08

26 Apr '08

Author: achiumenti Date: Sat Apr 26 11:05:43 2008 New Revision: 42 Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/i18n.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/some-page.lisp trunk/main/claw-core/tests/test1.lisp Log: changed component initfunctions generation with MOP system instead of using macro. Finished API documentation Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Sat Apr 26 11:05:43 2008 @@ -31,16 +31,16 @@ :name "claw" :author "Andrea Chiumenti" :description "Common Lisp Active Web.A famework to write web applications" - :depends-on (:hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) + :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) :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 "validators" :depends-on ("tags")) + (:file "tags" :depends-on ("misc")) + (:file "components" :depends-on ("tags")) + (:file "validators" :depends-on ("components")) (:file "translators" :depends-on ("validators")) - (:file "components" :depends-on ("tags" "validators")) (:file "lisplet" :depends-on ("components")) (:file "server" :depends-on ("lisplet")))))) Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Sat Apr 26 11:05:43 2008 @@ -34,26 +34,66 @@ - OBJ the wcomponent instance - PAGE-OBJ the wcomponent owner page")) +(defgeneric component-id-and-value (cinput &key from-request-p) + (:documentation "Returns the form component \(such as <input> and <select>) client-id and the associated value. +When FROM-REQUEST-P is not null, the value is retrived from the http request by its name, from the associated reader or accessor when nil")) + +(defgeneric translator-encode (translator wcomponent) + (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string).")) + +(defgeneric translator-decode (translator wcomponent) + (:documentation "Decodes the input component value after a form submit (Decodes from string to type).")) + +(defclass translator () + () + (:documentation "a translator object encodes and decodes values passed to a html input component")) + +(defvar *simple-translator* nil + "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component. +Its encoder and decoder methods pass values unchanged") + +(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))) ;-------------------------------------------------------------------------------- -(defcomponent cform () () - (:documentation "This component render as a FORM tag class, but it is aware of +(defclass cform (wcomponent) + ((action :initarg :action + :accessor action + :documentation "Function performed after user submission") + (css-class :initarg :class + :reader css-class + :documentation "The html CLASS attribute")) + (:default-initargs :action nil :class nil) + (:metaclass metacomponent) + (:documentation "This component render as a FORM tag class, but it is aware of the request cycle and is able to fire an action on rewind")) +(let ((class (find-class 'cform))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" + "Function that instantiates a CFORM component and renders a html <form> tag." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + + (defmethod cform-rewinding-p ((cform cform) (page page)) (string= (htcomponent-client-id cform) (page-req-parameter page *rewind-parameter*))) -(defmethod wcomponent-parameters ((cform cform)) - (list :id :required - :class nil - :action nil)) - (defmethod wcomponent-template((cform cform)) (let ((client-id (htcomponent-client-id cform)) - (class (wcomponent-parameter-value cform :class))) + (class (css-class cform)) + (validation-errors (aux-request-value :validation-errors))) + (when validation-errors + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) (form> :static-id client-id - :name client-id + :name client-id :class class (wcomponent-informal-parameters cform) (input> :name *rewind-parameter* @@ -66,20 +106,29 @@ (defmethod wcomponent-after-rewind ((obj cform) (pobj page)) (let ((validation-errors (aux-request-value :validation-errors)) - (action (wcomponent-parameter-value obj :action))) + (action (action obj))) (unless validation-errors (when (or action (cform-rewinding-p obj pobj)) - (funcall (fdefinition action) pobj)) + (funcall action pobj)) (setf (page-current-form pobj) nil)))) ;-------------------------------------------------------------------------------- -(defcomponent action-link (cform) () - (:documentation "This component behaves like a CFORM, firing it's associated action once clicked. +(defclass action-link (cform) () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :href)) + (:documentation "This component behaves like a CFORM, firing it's associated action once clicked. It renders as a normal link.")) -(defmethod wcomponent-reserved-parameters ((o action-link)) - '(:href)) +(let ((class (find-class 'action-link))) + (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" + "Instantiates an ACTION-LINK that renders an <a> link that cals a page method." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'cform)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template((o action-link)) (let ((client-id (htcomponent-client-id o))) @@ -91,35 +140,62 @@ (htcomponent-body o)))) ;--------------------------------------------------------------------------------------- - -(defcomponent cinput () - ((result-as-list :initarg :result-as-list - :accessor cinput-result-as-list)) - (:default-initargs :result-as-list nil) +(defclass base-cinput (wcomponent) + ((result-as-list-p :initarg :multiple + :accessor cinput-result-as-list-p + :documentation "When not nil the associated request parameter will ba a list") + (writer :initarg :writer + :reader cinput-writer + :documentation "Visit object slot writer symbol, used to write the input value to the visit object") + (reader :initarg :reader + :reader cinput-reader + :documentation "Visit object slot reader symbol, used to get the corresponding value from the visit object") + (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 + :documentation "The label is the description of the component. It's also be used when component validation fails.") + (translator :initarg :translator + :reader translator + :documentation "A validator instance that encodes and decodes input values to and from the visit object mapped property") + (validator :initarg :validator + :reader validator + :documentation "A function that accept the passed component value during submission and performs the validation logic calling the validator functions.") + (visit-object :initarg :visit-object + :reader cinput-visit-object + :documentation "The object hoding the property mapped to the current input html component. When nil the owner page is used.") + (css-class :initarg :class + :reader css-class + :documentation "the html component class attribute")) + (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil + :label nil :translator *simple-translator* :validator nil :visit-object nil) + (:documentation "Class inherited from both CINPUT and CSELECT")) + +(defclass cinput (base-cinput) + ((input-type :initarg :type + :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) (:documentation "Request cycle aware component the renders as an INPUT tag class")) -(defmethod wcomponent-parameters ((cinput cinput)) - (list :id :required - :reader nil - :writer nil - :visit-object nil - :accessor nil - :validator-handler nil - :class nil - :label nil - :translator *simple-translator* - :validator nil - :type :required)) +(let ((class (find-class 'cinput))) + (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" + "Function that instantiates a CINPUT component and renders a html <input> tag." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) -(defmethod wcomponent-reserved-parameters ((cinput cinput)) - '(:value :name)) - -(defmethod wcomponent-template ((cinput cinput)) +(defmethod wcomponent-template ((cinput cinput)) (let ((client-id (htcomponent-client-id cinput)) - (type (wcomponent-parameter-value cinput :type)) - (class (wcomponent-parameter-value cinput :class)) - (translator (wcomponent-parameter-value cinput :translator)) - (value "")) + (type (input-type cinput)) + (translator (translator cinput)) + (value "") + (class (css-class cinput))) (when (component-validation-errors cinput) (if (or (null class) (string= class "")) (setf class "error") @@ -132,19 +208,20 @@ :value value (wcomponent-informal-parameters cinput)))) -(defmethod wcomponent-after-rewind ((cinput cinput) (page page)) - (let ((visit-object (wcomponent-parameter-value cinput :visit-object)) - (accessor (wcomponent-parameter-value cinput :accessor)) - (writer (wcomponent-parameter-value cinput :writer)) - (validator (wcomponent-parameter-value cinput :validator)) - (translator (wcomponent-parameter-value cinput :translator)) - (value)) +(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page)) + (let ((visit-object (cinput-visit-object cinput)) + (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))) + (error () request-value))) (unless (null value) (when validator (funcall validator value)) @@ -155,20 +232,46 @@ (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)) + (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)))) + (values client-id value))) + + ;--------------------------------------------------------------------------------------- -(defcomponent csubmit () () - (:documentation "This component render as an INPUT tag class ot type submit, but +(defclass csubmit (cform) + ((value :initarg :value + :reader csubmit-value + :documentation "The html VALUE attribute")) + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :type :name) :empty t :action nil) + (:documentation "This component render as an INPUT tag class ot type submit, but can override the default CFORM action, using its own associated action")) -(defmethod wcomponent-parameters ((o csubmit)) - (list :id :required :value :required :action nil)) - -(defmethod wcomponent-reserved-parameters ((o csubmit)) - '(:type :name)) +(let ((class (find-class 'csubmit))) + (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" + "Function that instantiates a CSUBMIT component and renders a html <input> tag of submit type." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'cform)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template ((obj csubmit)) (let ((client-id (htcomponent-client-id obj)) - (value (wcomponent-parameter-value obj :value))) + (value (csubmit-value obj))) (input> :static-id client-id :type "submit" :name client-id @@ -176,18 +279,28 @@ (wcomponent-informal-parameters obj)))) (defmethod wcomponent-after-rewind ((obj csubmit) (pobj page)) - (let ((action (wcomponent-parameter-value obj :action)) + (let ((action (action obj)) (current-form (page-current-form pobj)) (submitted-p (page-req-parameter pobj (htcomponent-client-id obj)))) (unless (or (null current-form) (null submitted-p) (null action)) - (setf (getf (wcomponent-parameters current-form) :action) action)))) + (setf (action current-form) action)))) ;----------------------------------------------------------------------------- -(defcomponent submit-link (csubmit) () - (:documentation "This component renders as a normal link, but behaves like a CSUBMIT, +(defclass submit-link (csubmit) + () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :href) :empty nil) + (:documentation "This component renders as a normal link, but behaves like a CSUBMIT, so it can be used instead of CSUBMIT when needed")) -(defmethod wcomponent-reserved-parameters ((o submit-link)) - '(:href)) +(let ((class (find-class 'submit-link))) + (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" + "Function that instantiates a SUBMIT-LINK component and renders a html <a> tag that can submit the form where it is contained." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'cform)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template ((obj submit-link)) (let* ((id (htcomponent-client-id obj)) @@ -204,27 +317,33 @@ (htcomponent-body obj))))) ;-------------------------------------------------------------------------- - -(defcomponent cselect (cinput) () - (:default-initargs :result-as-list t) - (:documentation "This component renders as a normal SELECT tag class, +(defclass cselect (base-cinput) () + (:default-initargs :reserved-parameters (list :type :name) :empty nil) + (:metaclass metacomponent) + (:documentation "This component renders as a normal SELECT tag class, but it is request cycle aware.")) -(defmethod wcomponent-parameters :around ((obj cselect)) - (declare (ignore obj)) - (let ((params (call-next-method))) - (remf params :reader) - (remf params :type) - params)) - -(defmethod wcomponent-reserved-parameters ((obj cselect)) - (declare (ignore obj)) - '(:type :name)) +(let ((class (find-class 'cselect))) + (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" + "Function that instantiates a CSELECT component and renders a html <select> tag." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template ((obj cselect)) - (let ((client-id (htcomponent-client-id obj))) + (let ((client-id (htcomponent-client-id obj)) + (class (css-class obj))) + (when (component-validation-errors obj) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) (select> :static-id client-id :name client-id + :class class + :multiple (cinput-result-as-list-p obj) (wcomponent-informal-parameters obj) (htcomponent-body obj)))) Modified: trunk/main/claw-core/src/i18n.lisp ============================================================================== --- trunk/main/claw-core/src/i18n.lisp (original) +++ trunk/main/claw-core/src/i18n.lisp Sat Apr 26 11:05:43 2008 @@ -43,42 +43,55 @@ And other FIELD value will produce an error condition.")) -(defvar *locales* (make-hash-table :test 'equal)) +(defvar *locales* (make-hash-table :test 'equal) + "A hash table of locale key strings and lists of locale directives. +You should use locale access functions to get its internal values.") (defun number-format-grouping-separator (&optional (locale (user-locale))) + "Returns the character used as thousands grouping separator for numbers" (getf (getf (gethash locale *locales*) :number-format) :grouping-separator)) (defun number-format-decimal-separator (&optional (locale (user-locale))) + "Returns the character used as decimals separator for numbers" (getf (getf (gethash locale *locales*) :number-format) :decimal-separator)) (defun ampm (&optional (locale (user-locale))) + "Returns a list with the localized version of AM and PM for time" (getf (gethash locale *locales*) :ampm)) (defun months (&optional (locale (user-locale))) + "Returns a localized list of monthes in long form" (getf (gethash locale *locales*) :months)) (defun short-months (&optional (locale (user-locale))) + "Returns a localized list of monthes in short form" (getf (gethash locale *locales*) :short-months)) (defun first-day-of-the-week (&optional (locale (user-locale))) - (getf (gethash locale *locales*) :first-day-of-the-week)) + "Returns the first day position of the week for the given locale, being sunday on position 0 and saturday on position 6" + (1- (getf (gethash locale *locales*) :first-day-of-the-week))) (defun weekdays (&optional (locale (user-locale))) + "Returns a localized list of days of the week in long form" (getf (gethash locale *locales*) :weekdays)) (defun short-weekdays (&optional (locale (user-locale))) + "Returns a localized list of days of the week in short form" (getf (gethash locale *locales*) :short-weekdays)) (defun eras (&optional (locale (user-locale))) + "Returns a list with the localized version of BC and AD eras" (getf (gethash locale *locales*) :eras)) (defun local-time-add-year (local-time value) + "Add or remove years, expressed by the value parameter, to a local-time instance" (multiple-value-bind (ns ss mm hh day month year) (decode-local-time local-time) (encode-local-time ns ss mm hh day month (+ year value)))) (defun local-time-add-month (local-time value) + "Add or remove monthes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed" (multiple-value-bind (d-month d-year) (floor (abs value) 12) (when (< value 0) @@ -91,6 +104,7 @@ (encode-local-time ns ss mm hh day month year)))))) (defun local-time-add-day (local-time value) + "Add or remove days, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed" (let* ((curr-day (day-of local-time)) (local-time-result (make-instance 'local-time :day curr-day @@ -101,6 +115,7 @@ local-time-result)) (defun local-time-add-hour (local-time value) + "Add or remove hours, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed" (multiple-value-bind (ns ss mm hh day month year) (decode-local-time local-time) (multiple-value-bind (d-hour d-day) @@ -114,6 +129,7 @@ (encode-local-time ns2 ss2 mm2 (+ hh d-hour) day2 month2 year2)))))) (defun local-time-add-min (local-time value) + "Add or remove minutes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed" (multiple-value-bind (ns ss mm hh day month year) (decode-local-time local-time) (multiple-value-bind (d-min d-hour) @@ -127,6 +143,7 @@ (encode-local-time ns2 ss2 (+ mm d-min) hh2 day2 month2 year2)))))) (defun local-time-add-sec (local-time value) + "Add or remove seconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed" (multiple-value-bind (ns ss mm hh day month year) (decode-local-time local-time) (multiple-value-bind (d-sec d-min) @@ -140,6 +157,7 @@ (encode-local-time ns2 (+ ss d-sec) mm2 hh2 day2 month2 year2)))))) (defun local-time-add-nsec (local-time value) + "Add or remove nanoseconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed" (multiple-value-bind (ns ss mm hh day month year) (decode-local-time local-time) (multiple-value-bind (d-nsec d-sec) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sat Apr 26 11:05:43 2008 @@ -29,7 +29,8 @@ (in-package :claw) -(defvar *clawserver-base-path* nil) +(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") @@ -74,7 +75,7 @@ (setf result (push location-cons result)))) (defun lisplet-start-session () - "Starts a session boud to the current lisplet base path" + "Starts a session bound to the current lisplet base path" (start-session (format nil "~@[~a~]~a/" *clawserver-base-path* (lisplet-base-path (current-lisplet))))) @@ -132,7 +133,7 @@ (gethash (current-realm request) (clawserver-login-config (current-server request)))) (defun login (&optional (request *request*)) - "Perfoms a login action using the configuration object given for the request realm" + "Perfoms a login action using the configuration object given for the request realm (see CURRENT-REALM)" (configuration-login (current-config request))) (defun flatten (tree &optional result-list) @@ -152,6 +153,10 @@ (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. +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)) @@ -186,9 +191,11 @@ ,default-val))))) (defun do-message (key &optional (default "") locale) + "This function call the lambda function returned by the WITH-MESSAGE macro." (funcall (with-message key default locale))) (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)))) (unless locale @@ -201,8 +208,68 @@ locale)) (defun (setf user-locale) (locale &optional (session *session*)) + "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 (lisplet-start-session))) (setf (session-value 'locale session) locale)) - - + +(defun validation-errors (&optional (request *request*)) + "Resurns possible validation errors occurred during form rewinding" + (aux-request-value :validation-errors request)) + +(defclass metacomponent (standard-class) + () + (:documentation "This is the meta class the must be set for every WCOMPONENT. +It creates a function whose name is the WCOMPONENT class name plus the character '>'. +The function may then be called as any other claw tag function.")) + +(defmethod closer-mop:validate-superclass ((class metacomponent)(super standard-class)) + t) + + +(defun find-first-classdefault-initarg-value (initargs initarg) + "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))))) + +(defmethod initialize-instance :after ((class metacomponent) &key) + (let* ((name (class-name class)) + (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))))) + +(defun describe-html-attributes-from-class-slot-initargs (class) + "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)))))))))) + +(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 +") + +(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))) + (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")))) \ No newline at end of file Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sat Apr 26 11:05:43 2008 @@ -33,8 +33,9 @@ (export 'HUNCHENTOOT::SESSION-REALM 'HUNCHENTOOT) (defpackage :claw - (:use :cl :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) + (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time) (: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* @@ -47,12 +48,7 @@ :*apache-http-port* :*apache-https-port* :*empty-tags* - ;:request-realm - :request-id-table-map - ;:dyna-id - :flatten :tag-emptyp - :tag-symbol-class :strings-to-jsarray :empty-string-p :build-tagf @@ -199,6 +195,7 @@ :page-content :page-render :generate-id + :metacomponent :wcomponent :wcomponent-parameters :wcomponent-informal-parameters @@ -212,12 +209,16 @@ :wcomponent-before-render :wcomponent-after-render :make-component - :defcomponent :cform :cform> :action-link :action-link> + :base-cinput :cinput + :cinput-reader + :cinput-writer + :cinput-accessor + :cinput-visit-object :cinput> :cselect :cselect> @@ -262,6 +263,9 @@ #-: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 :claw-require-authorization :configuration @@ -305,4 +309,4 @@ :validator-integer :validator-date-range :exception-monitor - :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 Sat Apr 26 11:05:43 2008 @@ -117,13 +117,17 @@ (:documentation "This is the page class used to render the http error messages.")) -(defcomponent error-page-template () - () - (:documentation "The template for the error-page")) - -(defmethod wcomponent-parameters ((error-page-template error-page-template)) - (list :title :required :error-code :required :style - " +(defclass error-page-template (wcomponent) + ((title :initarg :title + :reader title + :documentation "The page title") + (error-code :initarg :error-code + :reader error-code + :documentation "The http error code. For details consult http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html") + (style :initarg :style + :reader style + :documentation "The CSS <style> element, used to beautify the error page.")) + (:default-initargs :style " body { font-family: arial, elvetica; font-size: 7pt; @@ -142,12 +146,22 @@ margin: 0; margin-bottom: .5em; } -p.h2 {font-size: 1.5em;}")) +p.h2 {font-size: 1.5em;}" :empty t :allow-informal-parameters nil) + (:metaclass metacomponent) + (:documentation "The template for the error-page")) + +(let ((class (find-class 'error-page-template))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~%~%~a" + "Function that instantiates an ERROR-PAGE-TEMPLATE component and renders a html tenplate for CLAW generic error pages." + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template ((error-page-template error-page-template)) - (let ((error-code (wcomponent-parameter-value error-page-template ':error-code)) - (title (wcomponent-parameter-value error-page-template ':title)) - (style (wcomponent-parameter-value error-page-template ':style))) + (let ((error-code (error-code error-page-template)) + (title (title error-page-template)) + (style (style error-page-template))) (html> (head> (title> title) @@ -169,7 +183,6 @@ (span> :class "blue" "description") (gethash error-code hunchentoot::*http-reason-phrase-map*) - ;(htcomponent-body error-page-template) (hr> :noshade "noshade")) (p> :class "h2" "claw server")))))) @@ -467,36 +480,4 @@ (realm (current-realm request));(aux-request-value 'realm)) (login-config (gethash realm (clawserver-login-config server)))) (configuration-login login-config request))) - - -(defun start-clawserver (clawserver - &key (port 80) - address - (name (gensym)) - (mod-lisp-p nil) - (use-apache-log-p mod-lisp-p) - (input-chunking-p t) - (read-timeout *default-read-timeout*) - (write-timeout *default-write-timeout*) - #+(and :unix (not :win32)) setuid - #+(and :unix (not :win32)) setgid - #-:hunchentoot-no-ssl ssl-certificate-file - #-:hunchentoot-no-ssl (ssl-privatekey-file ssl-certificate-file) - #-:hunchentoot-no-ssl ssl-privatekey-password) - (start-server :port port - :address address - :dispatch-table (list #'(lambda (request) - (declare (ignorable request)) - (clawserver-dispatch-method clawserver))) - :name name - :mod-lisp-p mod-lisp-p - :use-apache-log-p use-apache-log-p - :input-chunking-p input-chunking-p - :read-timeout read-timeout - :write-timeout write-timeout - #+(and :unix (not :win32)) :setuid setuid - #+(and :unix (not :win32)) :setgid setgid - #-:hunchentoot-no-ssl :ssl-certificate-file ssl-certificate-file - #-:hunchentoot-no-ssl :ssl-privatekey-file ssl-privatekey-file - #-:hunchentoot-no-ssl :ssl-privatekey-password ssl-privatekey-password)) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sat Apr 26 11:05:43 2008 @@ -69,8 +69,8 @@ - PAGE is the page instance that must be given")) (defgeneric page-request-parameters (page) - (:documentation "This internal method builds the get and post parameters into an hash table. - - PAGE is the page instance that must be given")) + (:documentation "This internal method builds the get and post parameters into an hash table. +Parameters are collected as lists so that this method can collect parameters that appear moter then once.")) (defgeneric page-print-tabulation (page) (:documentation "This internal method is called during the rendering phase if tabulation is enabled. It writes the right amount @@ -167,6 +167,9 @@ - HTCOMPONENT is the tag instance - PAGE the page instance")) +(defgeneric (setf slot-initialization) (value wcomponent slot-initarg) + (:documentation "Sets a slot by its :INITARG. It's used just after instance creation")) + (defgeneric wcomponent-parameter-value (wcomponent key) (:documentation "Returns the value of a parameter passed to the wcomponent initialization function (the one generated with DEFCOMPONENT) or :UNDEFINED if not passed. @@ -214,6 +217,9 @@ - WCOMPONENT is the tag instance - PAGE the page instance")) +(defgeneric wcomponent-template (wcomponent) + (:documentation "The component template. What gives to each wcomponent its unique aspect and features")) + (defgeneric simple-message-dispatcher-add-message (simple-message-dispatcher locale key value) (:documentation "Adds a key value pair to a given locale for message translation")) @@ -321,17 +327,26 @@ "Internal function that generates an htcomponent creation function from the component class name - TAG-NAME the symbol class name of the component - EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase." - (setf (fdefinition (intern (format nil "~a>" (string-upcase tag-name)))) - #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest)))) + (let ((fsymbol (intern (format nil "~a>" (string-upcase tag-name))))) + (setf (fdefinition fsymbol) + #'(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)))) ;;;---------------------------------------------------------------- (defclass message-dispatcher () - ()) + () + (:documentation "This is and interface for message dispatchers")) (defclass simple-message-dispatcher (message-dispatcher) ((locales :initform (make-hash-table :test #'equal) - :accessor simple-message-dispatcher-locales))) + :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 @@ -346,7 +361,9 @@ (lisplet :initarg :lisplet :reader page-lisplet :documentation "The lisplet that owns this page instance") (can-print :initform nil - :accessor page-can-print) + :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") (stylesheet-files :initarg :stylesheet-files @@ -369,7 +386,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.") - (request-parameters :initarg :request-parameters) + (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 :accessor page-components-stack :documentation "A stack of components enetered into rendering process.") @@ -456,24 +474,28 @@ (:documentation "Creates a component for rendering a <script> tag")) (defun script> (&rest rest) + "This function generates the <script> html tag" (build-tagf "script" 'htscript nil rest)) (defclass htlink (tag) () (:documentation "Creates a component for rendering a <link> tag")) (defun link> (&rest rest) + "This function generates the <link> html tag" (build-tagf "link" 'htlink t rest)) (defclass htbody (tag) () (:documentation "Creates a component for rendering a <body> tag")) (defun body> (&rest rest) + "This function generates the <body> html tag" (build-tagf "body" 'htbody nil rest)) (defclass hthead (tag) () (:documentation "Creates a component for rendering a <head> tag")) (defun head> (&rest rest) + "Renders a <head> tag" (build-tagf "head" 'hthead nil rest)) (mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) @@ -505,14 +527,6 @@ "Returns if a tag defined by the string TAG-NAME is empty" (member tag-name *empty-tags* :test #'string-equal)) -(defun tag-symbol-class (tag-name) - "Returns the symbol class for a given TAG-NAME" - (let ((name (string-downcase tag-name))) - (cond ((string= name "script") 'htscript) - ((string= name "link") 'htlink) - ((string= name "body") 'htbody) - ((string= name "head") 'hthead) - (t 'tag)))) ;;;--------------------METHODS implementation---------------------------------------------- (defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) @@ -587,6 +601,7 @@ (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 @@ -613,7 +628,6 @@ (page-init page) (when jsonp (page-format-raw page "{components:{")) - ;;(setf (page-can-print page) (null jsonp)) (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! (when jsonp (page-format-raw page "},classInjections:\"") @@ -680,8 +694,9 @@ (defmethod page-current-component ((page page)) (car (page-components-stack page))) -(defmethod current-component () - (let ((page (current-page))) +(defun current-component (&optional (request *request*)) + "Returns the component that is currently rendering" + (let ((page (current-page request))) (when page (car (page-components-stack page))))) ;;;========= HTCOMPONENT ============================ @@ -939,7 +954,7 @@ (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) + (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) @@ -960,8 +975,8 @@ (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) {")) + "window.attachEvent\('onload', function\(e) {" + "document.addEventListener\('DOMContentLoaded', function\(e) {")) (js-end-directive (if (msie-p) "});" "}, false);")) @@ -992,69 +1007,72 @@ (allow-informal-parameters :initarg :allow-informal-parameters :reader wcomponent-allow-informal-parametersp :allocation :class - :documentation "Determines if the component accepts informal parameters") - (template :initform nil - :accessor wcomponent-template - :type htcomponent - :documentation "The component template. What gives to each wcomponent its unique aspect and features")) + :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.")) -(defmethod wcomponent-check-parameters((comp wcomponent)) - (let ((id nil) - (static-id nil)) - (loop for (k v) on (htcomponent-attributes comp) by #'cddr - do (progn (when (and (eql v ':required) (not (eq k :id))) - (error (format nil - "Parameter ~a of class ~a is required" - k (class-name (class-of comp))))) - (when (eq k :id) - (setf id v)) - (when (eq k :static-id) - (setf static-id v)))) - (when (and (eq id :required) (null static-id)) - (error (format nil - "Parameter id of class ~a is required" - (class-name (class-of comp))))))) +(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))))) + +(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)))) + (setf (slot-value instance 'informal-parameters) informal-parameters))) + +(defmethod wcomponent-check-parameters((comp wcomponent))) +(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)))))) + (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)))))) + + (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))) (when static-id (remf parameters :id)) - (loop for (k v) on parameters by #'cddr - do (let ((keyword k)) - (when (eq keyword :static-id) - (setf keyword :id)) - (multiple-value-bind (inst-k inst-v inst-p) - (get-properties (wcomponent-parameters instance) (list keyword)) - (declare (ignore inst-v)) - (when (find inst-k (wcomponent-reserved-parameters instance)) - (error (format nil "Parameter ~a is reserved" inst-k))) - (if (null inst-p) - (if (null (wcomponent-allow-informal-parametersp instance)) - (error (format nil - "Component ~a doesn't accept informal parameters" - name)) - (setf (getf (wcomponent-informal-parameters instance) keyword) v)) - (progn - (when (and (eq keyword :id) (not (null static-id))) - (setf keyword :static-id)) - (setf (getf (htcomponent-attributes instance) keyword) v)))))) + (loop for (initarg value) on parameters by #'cddr + do (setf (slot-initialization instance initarg) value)) (wcomponent-check-parameters instance) - (let ((id (wcomponent-parameter-value instance :id)) - (static-id (wcomponent-parameter-value instance :static-id))) - (if (and (null static-id) id) - (setf (htcomponent-client-id instance) (generate-id id)) - (setf (htcomponent-client-id instance) static-id))) (setf (htcomponent-body instance) content) instance)) (defun build-component (component-name &rest rest) + "This function is the one that WCOMPONENT init functions call to intantiate their relative components. +The REST parameter is flattened and divided into a pair, where the first element is the alist of the component parameters, +while the second is the component body." (let ((fbody (parse-htcomponent-function (flatten rest)))) (make-component component-name (first fbody) (second fbody)))) @@ -1065,26 +1083,6 @@ (getf (wcomponent-parameters c) key) result))) -(defmacro defcomponent (name superclass-name slot-specifier &body class-option) - (let ((symbolf (intern (format nil "~a>" name)))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ,name - ,@(if (null superclass-name) - (list '(wcomponent)) - (list - (let ((result)) - (dolist (parent superclass-name) - (when (subtypep parent 'wcomponent) - (setf result t))) - (if result - superclass-name - (append '(wcomponent) superclass-name))))) - ,@(if (null class-option) - (list slot-specifier) - (push slot-specifier class-option))) - (setf (fdefinition `,',symbolf) #'(lambda(&rest rest) (build-component ',name rest)))))) - - (defmethod htcomponent-rewind ((wcomponent wcomponent) (page page)) (let ((template (wcomponent-template wcomponent))) (wcomponent-before-rewind wcomponent page) @@ -1147,24 +1145,6 @@ (defmethod wcomponent-before-render ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-render ((wcomponent wcomponent) (page page))) -(defun component-id-and-value (component &key (from-request-p t) value-as-list-p) - (let ((client-id (htcomponent-client-id component)) - (page (htcomponent-page component)) - (visit-object (wcomponent-parameter-value component :visit-object)) - (accessor (wcomponent-parameter-value component :accessor)) - (reader (wcomponent-parameter-value component :reader)) - (result-as-list (cinput-result-as-list component)) - (value "")) - (when (null visit-object) - (setf visit-object (htcomponent-page component))) - (cond - (from-request-p (setf value (page-req-parameter page client-id value-as-list-p))) - ((and (null reader) accessor) (setf value (funcall (fdefinition accessor) visit-object))) - (t (setf value (funcall (fdefinition reader) visit-object)))) - (values client-id - (if result-as-list - (list value) - value)))) (defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Sat Apr 26 11:05:43 2008 @@ -29,21 +29,11 @@ (in-package :claw) -(defgeneric translator-encode (translator wcomponent) - (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string).")) - -(defgeneric translator-decode (translator wcomponent) - (:documentation "Decodes the input component value after a form submit (Decodes from string to type).")) - -(defclass translator () - () - (:documentation "a translator object encodes and decodes values passed to a html input component")) - -(defmethod translator-encode ((translator translator) (wcomponent wcomponent)) +(defmethod translator-encode ((translator translator) (wcomponent cinput)) (let ((page (htcomponent-page wcomponent)) - (visit-object (wcomponent-parameter-value wcomponent :visit-object)) - (accessor (wcomponent-parameter-value wcomponent :accessor)) - (reader (wcomponent-parameter-value wcomponent :reader))) + (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 @@ -59,9 +49,7 @@ (declare (ignore client-id)) new-value)) -(defvar *simple-translator* (make-instance 'translator) - "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component. -Its encoder and decoder methods pass values unchanged") +(setf *simple-translator* (make-instance 'translator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -84,11 +72,11 @@ :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 wcomponent)) +(defmethod translator-encode ((translator translator-integer) (wcomponent cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (wcomponent-parameter-value wcomponent :visit-object)) - (accessor (wcomponent-parameter-value wcomponent :accessor)) - (reader (wcomponent-parameter-value wcomponent :reader)) + (visit-object (cinput-visit-object wcomponent)) + (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) @@ -141,11 +129,11 @@ (:documentation "a translator object encodes and decodes integer values passed to a html input component")) -(defmethod translator-encode ((translator translator-number) (wcomponent wcomponent)) +(defmethod translator-encode ((translator translator-number) (wcomponent cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (wcomponent-parameter-value wcomponent :visit-object)) - (accessor (wcomponent-parameter-value wcomponent :accessor)) - (reader (wcomponent-parameter-value wcomponent :reader)) + (visit-object (cinput-visit-object wcomponent)) + (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)) @@ -221,11 +209,11 @@ -(defmethod translator-encode ((translator translator-date) (wcomponent wcomponent)) +(defmethod translator-encode ((translator translator-date) (wcomponent cinput)) (let* ((page (htcomponent-page wcomponent)) - (visit-object (wcomponent-parameter-value wcomponent :visit-object)) - (accessor (wcomponent-parameter-value wcomponent :accessor)) - (reader (wcomponent-parameter-value wcomponent :reader)) + (visit-object (cinput-visit-object wcomponent)) + (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) Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Sat Apr 26 11:05:43 2008 @@ -67,15 +67,6 @@ (unless test (add-exception client-id message)))) -(defun validation-errors (&optional (request *request*)) - "Resurns possible validation errors occurred during form rewinding" - (aux-request-value :validation-errors request)) - -(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))) - (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\". The argument for the message will be the :label attribute of the COMPONENT." @@ -202,9 +193,20 @@ ;; ------------------------------------------------------------------------------------ -(defcomponent exception-monitor () () +(defclass exception-monitor (wcomponent) () + (:metaclass metacomponent) + (:default-initargs :empty 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)))) + (defmethod wcomponent-parameters ((exception-monitor exception-monitor)) (declare (ignore exception-monitor)) (list :class nil)) @@ -213,9 +215,10 @@ (let ((client-id (htcomponent-client-id exception-monitor)) (validation-errors (aux-request-value :validation-errors))) (when validation-errors - (ul> :static-id client-id - (loop for component-exceptions in validation-errors - collect (loop for message in (cdr component-exceptions) - collect (li> message))))))) + (ul> :static-id client-id + (wcomponent-informal-parameters cform) + (loop for component-exceptions in validation-errors + collect (loop for message in (cdr component-exceptions) + collect (li> message))))))) ;;------------------------------------------------------------------------------------------- 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 Sat Apr 26 11:05:43 2008 @@ -29,10 +29,9 @@ (in-package :claw-tests) -(defcomponent inspector () ()) - -(defmethod wcomponent-parameters ((inspector inspector)) - (list :id :required :ref-id :required)) +(defcomponent inspector () + ((ref-id :initarg :ref-id + :reader ref-id))) (defmethod wcomponent-template ((inspector inspector)) (div> :static-id (htcomponent-client-id inspector) @@ -42,7 +41,7 @@ (format nil "document.getElementById\('~a').onclick = function \() {alert\(document.getElementById\('~a').innerHTML);};" (htcomponent-client-id inspector) - (wcomponent-parameter-value inspector :ref-id))) + (ref-id inspector))) (defclass some-page (page) ()) Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Sat Apr 26 11:05:43 2008 @@ -106,16 +106,16 @@ ;;;--------------------template-------------------------------- -(defcomponent site-template () ()) - -(defmethod wcomponent-parameters ((o site-template)) - (list :title :required)) +(defclass site-template (wcomponent) + ((title :initarg :title + :reader title)) + (:metaclass metacomponent)) (defmethod wcomponent-template ((o site-template)) (html> (head> (title> - (wcomponent-parameter-value o :title)) + (title o)) (style> :type "text/css" "input.error { background-color: #FF9999; @@ -163,10 +163,9 @@ (li> (a> :href "unauth.html" "unauthorized page")))))) (lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) -(defcomponent msie-p ()()) - -(defmethod wcomponent-parameters ((msie-p msie-p)) - (list :id :required)) +(defclass msie-p (wcomponent) + () + (:metaclass metacomponent)) (defmethod wcomponent-template ((msie-p msie-p)) (let ((id (htcomponent-client-id msie-p))) @@ -285,7 +284,7 @@ (let ((princp (current-principal))) (site-template> :title "a page title" (if (null princp) - (cform> :id "loginform" :method "post" :action 'login-page-login + (cform> :id "loginform" :method "post" :action #'login-page-login (table> (tr> (td> "Username") @@ -351,7 +350,7 @@ (:default-initargs :name "kiuma" :surname "surnk" :colors nil - :gender '("M") + :gender "M" :age 1800 :capital 500055/100 :birthday (now) @@ -362,7 +361,7 @@ (let ((user (form-page-user form-page)) (name (form-page-name form-page)) (surname (form-page-surname form-page)) - (gender (first (form-page-gender form-page))) + (gender (form-page-gender form-page)) (age (form-page-age form-page))) (setf (user-name user) name (user-surname user) surname @@ -374,7 +373,7 @@ (defmethod page-content ((o form-page)) (site-template> :title "a page title" - (cform> :id "testform" :method "post" :action 'form-page-update-user + (cform> :id "testform" :method "post" :action #'form-page-update-user (table> (tr> (td> "Name") @@ -399,10 +398,10 @@ (td> "Gender") (td> (cselect> :id "gender" - :writer 'setf-gender + :accessor 'form-page-gender (loop for gender in (list "M" "F") collect (option> :value gender - (when (string= gender (first (form-page-gender o))) + (when (string= gender (form-page-gender o)) '(:selected "selected")) (if (string= gender "M") "Male" @@ -437,7 +436,7 @@ :type "text" :label "Capital" :translator (make-instance 'translator-number - :decimal-digits 4 + :decimal-digits 2 :thousand-separator #\') :validator #'(lambda (value) (let ((component (page-current-component o))) @@ -450,13 +449,13 @@ (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 (member color (form-page-colors o) :test #'string=) - '(:selected "selected")) - (cond - ((string= color "R") "red") + :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>

1 0

[claw-cvs] r41 - trunk/main/claw-core/tests
by achiumenti＠common-lisp.net 15 Apr '08

15 Apr '08

Author: achiumenti Date: Tue Apr 15 13:49:16 2008 New Revision: 41 Added: trunk/main/claw-core/tests/some-page.lisp Log: writing tests for manual Added: trunk/main/claw-core/tests/some-page.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/tests/some-page.lisp Tue Apr 15 13:49:16 2008 @@ -0,0 +1,58 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: tests/test1.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; 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 +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-tests) + +(defcomponent inspector () ()) + +(defmethod wcomponent-parameters ((inspector inspector)) + (list :id :required :ref-id :required)) + +(defmethod wcomponent-template ((inspector inspector)) + (div> :static-id (htcomponent-client-id inspector) + (htcomponent-body inspector))) + +(defmethod htcomponent-instance-initscript ((inspector inspector)) + (format nil "document.getElementById\('~a').onclick = + function \() {alert\(document.getElementById\('~a').innerHTML);};" + (htcomponent-client-id inspector) + (wcomponent-parameter-value inspector :ref-id))) + +(defclass some-page (page) ()) + +(defmethod page-content ((some-page some-page)) + (let ((hidden-component-id (generate-id "hiddenComp")) + (rnd-value (prin1-to-string (random 10000)))) + (site-template> :title "this is the page title" + :class "foo" + (p> + (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")

1 0

[claw-cvs] r40 - trunk/main/claw-core
by achiumenti＠common-lisp.net 15 Apr '08

15 Apr '08

Author: achiumenti Date: Tue Apr 15 13:48:56 2008 New Revision: 40 Modified: trunk/main/claw-core/claw-tests.asd Log: writing tests for manual Modified: trunk/main/claw-core/claw-tests.asd ============================================================================== --- trunk/main/claw-core/claw-tests.asd (original) +++ trunk/main/claw-core/claw-tests.asd Tue Apr 15 13:48:56 2008 @@ -34,5 +34,6 @@ :depends-on (:claw) :components ((:module tests :components ((:file "packages") - (:file "test1" :depends-on ("packages")))))) + (:file "test1" :depends-on ("packages")) + (:file "some-page" :depends-on ("packages"))))))

1 0

[claw-cvs] r39 - trunk/doc/chapters
by achiumenti＠common-lisp.net 15 Apr '08

15 Apr '08

Author: achiumenti Date: Tue Apr 15 13:48:02 2008 New Revision: 39 Modified: trunk/doc/chapters/writing-components.texinfo Log: updating user manual Modified: trunk/doc/chapters/writing-components.texinfo ============================================================================== --- trunk/doc/chapters/writing-components.texinfo (original) +++ trunk/doc/chapters/writing-components.texinfo Tue Apr 15 13:48:02 2008 @@ -44,8 +44,8 @@ object, and is meant to be used just like any other standard function tag. The overriding of the method @code{wocomponent-parameters} must return an associative list where, if the key value is @code{:REQUIRED}, -it means that is is mandatory for the constructor function. In our case study a call to @code{SITE-TEMPLATE>} must contains also the -keyword @code{:TITLE} followed by its value. If the @code{:TITLE} is not provided an error will be signaled during the component +it means that it is mandatory for the constructor function. In our case study, a call to @code{SITE-TEMPLATE>} must contains also the +keyword @code{:TITLE} followed by its value. If the @code{:TITLE} is not provided, an error is signaled during the component instantiation. The overriding of the method @code{wocomponent-template} is in charge for the graphic aspect of the component, as you can imagine. @@ -55,12 +55,12 @@ @code{wcomponent-parameter-value} is used to retrieve a parameter passed to the constructor function. @item @code{wcomponent-informal-parameters} renders as an associative list of all the parameters not directly declared with the method -@code{wocomponent-parameters}, but that are present in the constructor function. +@code{wocomponent-parameters}, but are present in the constructor function, such as may be a @code{:CLASS} attribute. @item -@code{htcomponent-body} renders the body of the component +@code{htcomponent-body} renders the content body of the component @end itemize -So a call to the constructor function of our new fresh component might have this shape: +So, a call to the constructor function of our new fresh component, might have this shape: @cartouche @lisp (site-template> :title "this is the page title" @@ -94,12 +94,13 @@ Ouch, this is nearly what we expected, but it seems there are two extraneous tags, do you see them? -They are the meta and the script tags. +They are the <meta> and the <script> tags. -The meta tag is inserted by the @code{HTHEAD} component, that we have instantiated with @code{HEAD>}. -The value of the content attribute, is taken from the @code{PAGE-CONTENT-TYPE} slot method, whose default is @code{HUNCHENTOOT:*DEFAULT-CONTENT-TYPE*}. +The <meta> tag is inserted by the @code{HTHEAD} component, that we have instantiated with @code{HEAD>}. +The value of the @code{content} attribute is taken from the @code{PAGE-CONTENT-TYPE} slot method of the @code{PAGE} class, whose default is @code{HUNCHENTOOT:*DEFAULT-CONTENT-TYPE*}. +It is recomended to have ti value set to @code{"text/html; charset=UTF-8"}. -The script tag is used when @value{claw} components want to inject their instance javascripts. +The <script> tag is used when @value{claw} components want to inject their instance javascripts. So, for example, we could create a component that, when clicked, it shows a js alert containing the html component of another component: @@ -111,12 +112,14 @@ (list :id :required :ref-id :required)) (defmethod wcomponent-template ((inspector inspector)) - (div> :static-id (htcomponent-client-id inspactor) - (htcomponent-body o))) + (div> :static-id (htcomponent-client-id inspector) + (htcomponent-body inspector))) (defmethod htcomponent-instance-initscript ((inspector inspector)) - (format nil "document.getElementById('~a').onclick = - function () @{alert(document.getElementById('~a').innerHTML);@};" + (format nil "document.getElementById\('~a').onclick = + function \() @{ + alert\(document.getElementById\('~a').innerHTML); + @};" (htcomponent-client-id inspector) (wcomponent-parameter-value inspector :ref-id))) @@ -129,11 +132,45 @@ @lisp (defmethod page-content ((some-page some-page)) (let ((hidden-component-id (generate-id "hidden")) - (rnd-value (prin1-to-string (random 10000))) + (rnd-value (prin1-to-string (random 10000)))) (site-template> :title "this is the page title" :class "foo" (p> - (div> :static-id hidden-component-id rnd-value) - (inspector> :id "inspector" "Show value")))))) + (div> :static-id hidden-component-id + :style "display: none;" rnd-value) + (inspector> :id "inspector" + :ref-id hidden-component-id "Show value"))))) @end lisp @end cartouche + +and will render as: +@cartouche +@example +@format +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" + "http://www.w3.org/TR/html4/strict.dtd"> +<html> + <head> + <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> + <title>this is the page title</title> + </head> + <body class="foo"> + <p> + <div id="hiddenComp" style="display: none;">2351</div> + <div id="inspector">Show value</div> + </p> + <script type="text/javascript"> +// + </script> + </body> +</html> +@end format +@end example +@end cartouche

1 0

[claw-cvs] r38 - in trunk: doc/chapters main/claw-core/src
by achiumenti＠common-lisp.net 15 Apr '08

15 Apr '08

Author: achiumenti Date: Tue Apr 15 01:02:25 2008 New Revision: 38 Modified: trunk/doc/chapters/writing-components.texinfo trunk/main/claw-core/src/hunchentoot-overrides.lisp Log: user manual update Modified: trunk/doc/chapters/writing-components.texinfo ============================================================================== --- trunk/doc/chapters/writing-components.texinfo (original) +++ trunk/doc/chapters/writing-components.texinfo Tue Apr 15 01:02:25 2008 @@ -63,7 +63,8 @@ So a call to the constructor function of our new fresh component might have this shape: @cartouche @lisp -(site-template> :title "this is the page title" :class "foo" +(site-template> :title "this is the page title" + :class "foo" (p> Hello world)) @end lisp @@ -94,4 +95,45 @@ Ouch, this is nearly what we expected, but it seems there are two extraneous tags, do you see them? They are the meta and the script tags. -...continue... + +The meta tag is inserted by the @code{HTHEAD} component, that we have instantiated with @code{HEAD>}. +The value of the content attribute, is taken from the @code{PAGE-CONTENT-TYPE} slot method, whose default is @code{HUNCHENTOOT:*DEFAULT-CONTENT-TYPE*}. + +The script tag is used when @value{claw} components want to inject their instance javascripts. +So, for example, we could create a component that, when clicked, it shows a js alert containing the html +component of another component: + +@cartouche +@lisp +(defcomponent inspector () ()) + +(defmethod wcomponent-parameters ((inspector inspector)) + (list :id :required :ref-id :required)) + +(defmethod wcomponent-template ((inspector inspector)) + (div> :static-id (htcomponent-client-id inspactor) + (htcomponent-body o))) + +(defmethod htcomponent-instance-initscript ((inspector inspector)) + (format nil "document.getElementById('~a').onclick = + function () @{alert(document.getElementById('~a').innerHTML);@};" + (htcomponent-client-id inspector) + (wcomponent-parameter-value inspector :ref-id))) + +@end lisp +@end cartouche + +Ok, now we can use our new inspector component inside our page: + +@cartouche +@lisp +(defmethod page-content ((some-page some-page)) + (let ((hidden-component-id (generate-id "hidden")) + (rnd-value (prin1-to-string (random 10000))) + (site-template> :title "this is the page title" + :class "foo" + (p> + (div> :static-id hidden-component-id rnd-value) + (inspector> :id "inspector" "Show value")))))) +@end lisp +@end cartouche Modified: trunk/main/claw-core/src/hunchentoot-overrides.lisp ============================================================================== --- trunk/main/claw-core/src/hunchentoot-overrides.lisp (original) +++ trunk/main/claw-core/src/hunchentoot-overrides.lisp Tue Apr 15 01:02:25 2008 @@ -171,10 +171,10 @@ realm))) (when *reply* (cond ((null session) - (log-message :notice "No session for session identifier '~A' (User-Agent: '~A', IP: '~A', REALM: '~A')" + (log-message :notice "No session for session identifier '~A' \(User-Agent: '~A', IP: '~A', REALM: '~A')" session-identifier user-agent remote-addr realm)) (t - (log-message :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A', REALM: '~A')" + (log-message :warning "Fake session identifier '~A' \(User-Agent: '~A', IP: '~A', REALM: '~A')" session-identifier user-agent remote-addr realm)))) (when session (remove-session session))

1 0

[claw-cvs] r37 - in trunk/doc: . chapters
by achiumenti＠common-lisp.net 10 Apr '08

10 Apr '08

Author: achiumenti Date: Thu Apr 10 02:08:57 2008 New Revision: 37 Modified: trunk/doc/chapters/getting-started.texinfo trunk/doc/chapters/writing-components.texinfo trunk/doc/claw.texinfo Log: user manual update Modified: trunk/doc/chapters/getting-started.texinfo ============================================================================== --- trunk/doc/chapters/getting-started.texinfo (original) +++ trunk/doc/chapters/getting-started.texinfo Thu Apr 10 02:08:57 2008 @@ -1,97 +1,4 @@ @node Getting Started @comment node-name, next, previous, up -@chapter Getting started with @value{claw} +@chapter Getting started with @value{claw}, your first application -Now that you know how to write pages in @value{claw}, lets move to a further step: writing components. - -A real @value{claw} web application is made of a lisplet, several pages and resources, and, of course, many reusable -components that go into pages. - -Using reusable components, may dramatically improve your productivity. You can then create custom components libraries -that will give to your web application a crystal clear style, and speed up the creation of repetitive piece -of HTML code, as page templates for instance. - -So said, let's create our first @value{claw} component, a site template. -@cartouche -@lisp -(defcomponent site-template () ()) - -(defmethod wcomponent-parameters ((o site-template)) - (list :title :required :home-page "/claw/test/index.html")) - -(defmethod wcomponent-template ((o site-template)) - (html> - (head> - (title> - (wcomponent-parameter-value o :title))) - (body> - (wcomponent-informal-parameters o) - (div> - :style "background-color: #DBDFE0;padding: 3px;" - (a> :href (wcomponent-parameter-value o :home-page) "home")) - (htcomponent-body o)))) -@end lisp -@end cartouche - -Thought this is not the best template you can do, it's a nice starting point to explain how components are created -(and used). - -First let's analyze the @code{defcomponent} instruction: this macro has the same signature of the @code{defclass} macro, -except that it creates a class that is always a @code{WOCOMPONENT} subclass. - -@code{defcomponent} also creates a function whose symbol is -the name of the component plus the character '>', @code{SITE-TEMPLATE>} in the specific case, that instantiate the corresponding -object, and is meant to be used just like any other standard function tag. - -The overriding of the method @code{wocomponent-parameters} must return an associative list where, if the key value is @code{:REQUIRED}, -it means that is is mandatory for the constructor function. In our case study a call to @code{SITE-TEMPLATE>} must contains also the -keyword @code{:TITLE} followed by its value. If the @code{:TITLE} is not provided an error will be signaled during the component -instantiation. - -The overriding of the method @code{wocomponent-template} is in charge for the graphic aspect of the component, as you can imagine. -Inside this method we have used calls to other three very important component methods: -@itemize @minus -@item -@code{wcomponent-parameter-value} is used to retrieve a parameter passed to the constructor function. -@item -@code{wcomponent-informal-parameters} renders as an associative list of all the parameters not directly declared with the method -@code{wocomponent-parameters}, but that are present in the constructor function. -@item -@code{htcomponent-body} renders the body of the component -@end itemize - -So a call to the constructor function of our new fresh component might have this shape: -@cartouche -@lisp -(site-template> :title "this is the page title" :class "foo" - (p> - Hello world)) -@end lisp -@end cartouche - -and will render as -@cartouche -@example -@format -<html> - <head> - <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> - <title>this is the page title</title> - </head> - <body class="foo"> - <p>Hello world</p> - <script type="text/javascript"> -// - </script> - </body> -</html> -@end format -@end example -@end cartouche - -Ouch, this is nearly what we expected, but it seems there are two extraneous tags, do you see them? - -They are the meta and the script tags. -...continue... Modified: trunk/doc/chapters/writing-components.texinfo ============================================================================== --- trunk/doc/chapters/writing-components.texinfo (original) +++ trunk/doc/chapters/writing-components.texinfo Thu Apr 10 02:08:57 2008 @@ -1,3 +1,97 @@ @node writing components @comment node-name, next, previous, up @chapter Creating a web application by writing reusable components + +Now that you know how to write pages in @value{claw}, lets move to a further step: writing components. + +A real @value{claw} web application is made of a lisplet, several pages and resources, and, of course, many reusable +components that go into pages. + +Using reusable components, may dramatically improve your productivity. You can then create custom components libraries +that will give to your web application a crystal clear style, and speed up the creation of repetitive piece +of HTML code, as page templates for instance. + +So said, let's create our first @value{claw} component, a site template. +@cartouche +@lisp +(defcomponent site-template () ()) + +(defmethod wcomponent-parameters ((o site-template)) + (list :title :required :home-page "/claw/test/index.html")) + +(defmethod wcomponent-template ((o site-template)) + (html> + (head> + (title> + (wcomponent-parameter-value o :title))) + (body> + (wcomponent-informal-parameters o) + (div> + :style "background-color: #DBDFE0;padding: 3px;" + (a> :href (wcomponent-parameter-value o :home-page) "home")) + (htcomponent-body o)))) +@end lisp +@end cartouche + +Thought this is not the best template you can do, it's a nice starting point to explain how components are created +(and used). + +First let's analyze the @code{defcomponent} instruction: this macro has the same signature of the @code{defclass} macro, +except that it creates a class that is always a @code{WOCOMPONENT} subclass. + +@code{defcomponent} also creates a function whose symbol is +the name of the component plus the character '>', @code{SITE-TEMPLATE>} in the specific case, that instantiate the corresponding +object, and is meant to be used just like any other standard function tag. + +The overriding of the method @code{wocomponent-parameters} must return an associative list where, if the key value is @code{:REQUIRED}, +it means that is is mandatory for the constructor function. In our case study a call to @code{SITE-TEMPLATE>} must contains also the +keyword @code{:TITLE} followed by its value. If the @code{:TITLE} is not provided an error will be signaled during the component +instantiation. + +The overriding of the method @code{wocomponent-template} is in charge for the graphic aspect of the component, as you can imagine. +Inside this method we have used calls to other three very important component methods: +@itemize @minus +@item +@code{wcomponent-parameter-value} is used to retrieve a parameter passed to the constructor function. +@item +@code{wcomponent-informal-parameters} renders as an associative list of all the parameters not directly declared with the method +@code{wocomponent-parameters}, but that are present in the constructor function. +@item +@code{htcomponent-body} renders the body of the component +@end itemize + +So a call to the constructor function of our new fresh component might have this shape: +@cartouche +@lisp +(site-template> :title "this is the page title" :class "foo" + (p> + Hello world)) +@end lisp +@end cartouche + +and will render as +@cartouche +@example +@format +<html> + <head> + <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> + <title>this is the page title</title> + </head> + <body class="foo"> + <p>Hello world</p> + <script type="text/javascript"> +// + </script> + </body> +</html> +@end format +@end example +@end cartouche + +Ouch, this is nearly what we expected, but it seems there are two extraneous tags, do you see them? + +They are the meta and the script tags. +...continue... Modified: trunk/doc/claw.texinfo ============================================================================== --- trunk/doc/claw.texinfo (original) +++ trunk/doc/claw.texinfo Thu Apr 10 02:08:57 2008 @@ -48,13 +48,12 @@ * Server:: * Lisplets:: * Pages:: -* Getting Started:: -* i18n:: +* writing components:: * forms:: * validation:: -* writing components:: -* advanced components:: +* i18n:: * login access:: +* Getting Started:: * Advanced techniques:: * Function index:: @c * Starting and Stopping:: @@ -71,13 +70,12 @@ @include chapters/server.texinfo @include chapters/lisplets.texinfo @include chapters/pages.texinfo -@include chapters/getting-started.texinfo -@include chapters/i18n.texinfo +@include chapters/writing-components.texinfo @include chapters/forms.texinfo @include chapters/validation.texinfo -@include chapters/writing-components.texinfo -@include chapters/advanced-components.texinfo +@include chapters/i18n.texinfo @include chapters/access.texinfo +@include chapters/getting-started.texinfo @include chapters/advanced-techniques.texinfo @node Function index

1 0

[claw-cvs] r36 - trunk/doc/chapters
by achiumenti＠common-lisp.net 09 Apr '08

09 Apr '08

Author: achiumenti Date: Wed Apr 9 17:13:20 2008 New Revision: 36 Modified: trunk/doc/chapters/getting-started.texinfo Log: user manual update Modified: trunk/doc/chapters/getting-started.texinfo ============================================================================== --- trunk/doc/chapters/getting-started.texinfo (original) +++ trunk/doc/chapters/getting-started.texinfo Wed Apr 9 17:13:20 2008 @@ -23,12 +23,7 @@ (html> (head> (title> - (wcomponent-parameter-value o :title)) - (style> :type "text/css" -"input.error { - background-color: #FF9999; -} -")) + (wcomponent-parameter-value o :title))) (body> (wcomponent-informal-parameters o) (div> @@ -37,5 +32,66 @@ (htcomponent-body o)))) @end lisp @end cartouche + Thought this is not the best template you can do, it's a nice starting point to explain how components are created (and used). + +First let's analyze the @code{defcomponent} instruction: this macro has the same signature of the @code{defclass} macro, +except that it creates a class that is always a @code{WOCOMPONENT} subclass. + +@code{defcomponent} also creates a function whose symbol is +the name of the component plus the character '>', @code{SITE-TEMPLATE>} in the specific case, that instantiate the corresponding +object, and is meant to be used just like any other standard function tag. + +The overriding of the method @code{wocomponent-parameters} must return an associative list where, if the key value is @code{:REQUIRED}, +it means that is is mandatory for the constructor function. In our case study a call to @code{SITE-TEMPLATE>} must contains also the +keyword @code{:TITLE} followed by its value. If the @code{:TITLE} is not provided an error will be signaled during the component +instantiation. + +The overriding of the method @code{wocomponent-template} is in charge for the graphic aspect of the component, as you can imagine. +Inside this method we have used calls to other three very important component methods: +@itemize @minus +@item +@code{wcomponent-parameter-value} is used to retrieve a parameter passed to the constructor function. +@item +@code{wcomponent-informal-parameters} renders as an associative list of all the parameters not directly declared with the method +@code{wocomponent-parameters}, but that are present in the constructor function. +@item +@code{htcomponent-body} renders the body of the component +@end itemize + +So a call to the constructor function of our new fresh component might have this shape: +@cartouche +@lisp +(site-template> :title "this is the page title" :class "foo" + (p> + Hello world)) +@end lisp +@end cartouche + +and will render as +@cartouche +@example +@format +<html> + <head> + <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> + <title>this is the page title</title> + </head> + <body class="foo"> + <p>Hello world</p> + <script type="text/javascript"> +// + </script> + </body> +</html> +@end format +@end example +@end cartouche + +Ouch, this is nearly what we expected, but it seems there are two extraneous tags, do you see them? + +They are the meta and the script tags. +...continue...

1 0