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

[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

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 14:01:54 2008 New Revision: 35 Modified: trunk/doc/claw.texinfo Log: updating user manual Modified: trunk/doc/claw.texinfo ============================================================================== --- trunk/doc/claw.texinfo (original) +++ trunk/doc/claw.texinfo Wed Apr 9 14:01:54 2008 @@ -46,6 +46,16 @@ @menu * Introduction:: * Server:: +* Lisplets:: +* Pages:: +* Getting Started:: +* i18n:: +* forms:: +* validation:: +* writing components:: +* advanced components:: +* login access:: +* Advanced techniques:: * Function index:: @c * Starting and Stopping:: @c * Compiler:: @@ -59,6 +69,16 @@ @include chapters/intro.texinfo @include chapters/server.texinfo +@include chapters/lisplets.texinfo +@include chapters/pages.texinfo +@include chapters/getting-started.texinfo +@include chapters/i18n.texinfo +@include chapters/forms.texinfo +@include chapters/validation.texinfo +@include chapters/writing-components.texinfo +@include chapters/advanced-components.texinfo +@include chapters/access.texinfo +@include chapters/advanced-techniques.texinfo @node Function index @unnumbered Function index

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 13:59:58 2008 New Revision: 34 Modified: trunk/doc/chapters/getting-started.texinfo trunk/doc/chapters/intro.texinfo trunk/doc/chapters/lisplets.texinfo trunk/doc/chapters/pages.texinfo trunk/doc/chapters/server.texinfo Log: updating user manual Modified: trunk/doc/chapters/getting-started.texinfo ============================================================================== --- trunk/doc/chapters/getting-started.texinfo (original) +++ trunk/doc/chapters/getting-started.texinfo Wed Apr 9 13:59:58 2008 @@ -1,3 +1,41 @@ @node Getting Started @comment node-name, next, previous, up @chapter Getting started with @value{claw} + +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)) + (style> :type "text/css" +"input.error { + background-color: #FF9999; +} +")) + (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). Modified: trunk/doc/chapters/intro.texinfo ============================================================================== --- trunk/doc/chapters/intro.texinfo (original) +++ trunk/doc/chapters/intro.texinfo Wed Apr 9 13:59:58 2008 @@ -10,13 +10,13 @@ @value{claw} is based on components, highly reusable building blocks the make easy and fast the creation of a web application. By using and creating new components, the developer can create robust and consistent web application with the minimal effort. -Each component may inject into a page ist own set of stylesheet and javasctipt files, and may come with its own class or instance javascript +Each component may inject into a page its own set of stylesheet and javascript files, and may come with its own class or instance javascript directives (a class directive is inserted only once into the page, while this is not true for an instance script). This leads to the creation of very sophisticated components with a very little effort. -@value{claw} comes with its own authentication systme that lets you create both basic and form based authentication systems. +@value{claw} comes with its own authentication system that lets you create both basic and form based authentication systems. -@value{claw} has the capability to force the page renderinig throught the protocol https of pages managing sensible data, using simple +@value{claw} has the capability to force the page rendering through the HTTPS protocol of pages managing sensible data, using simple directives. @value{claw} comes with its own extensible localization and validation system. @@ -34,13 +34,13 @@ When a user asks for a page the request is sent to the @code{CLAWSERVER} that dispatches the request to the registered lisplets. -Lisplets are web resource containers that hold web pages and other resource files, such as javascript, image, css, etc. files, or even funcions, under a common path. +Lisplets are web resource containers that hold web pages and other resource files, such as javascript, image, css, etc. files, or even functions, under a common path. When a matching lisplet is then found, it dispatches the request to a registered resource that can be a page or a file or even a function. If the request is sent for a file, this is then sent back to the browser if found. -If the request is sent for a page, usually mapped to a html url, the dispatcher calls the page rendering function to display the page as an html resource. +If the request is sent for a page, usually mapped to a html URL, the dispatcher calls the page rendering function to display the page as an html resource. If no resource is found a 404 message page, is sent to the user as feedback. Modified: trunk/doc/chapters/lisplets.texinfo ============================================================================== --- trunk/doc/chapters/lisplets.texinfo (original) +++ trunk/doc/chapters/lisplets.texinfo Wed Apr 9 13:59:58 2008 @@ -32,7 +32,7 @@ At this point you have defined a web application registered to the URL ``http://localhost:4242/test'' that @value{claw} will be able to serve. -All sessions and the authentication and authourization logic will be under the default realm ``claw'', +All sessions and the authentication and authorization logic will be under the default realm ``claw'', so if you register another lisplet into the server with the instruction: @cartouche @lisp @@ -71,7 +71,7 @@ @subsection Adding files and folders to a @code{LISPLET} -Suppose now you want to provide, thought your web application, a file present on jour hard disk, for example: +Suppose now you want to provide, thought your web application, a file present on your hard disk, for example: ``/opt/webresources/images/matrix.jpg''. This is made very simple with the following instructions @@ -84,9 +84,9 @@ @end cartouche The jpeg file will now be available when accessing ``http://localhost:4242/test/images/matrix.jpg''. -The last rgument specifies the mime-type, but it's optional. +The last argument specifies the mime-type, but it's optional. -If you want to regiter an entire folder, the process is very similar +If you want to register an entire folder, the process is very similar @cartouche @lisp (lisplet-register-resource-location *test-lisplet* @@ -100,10 +100,10 @@ @subsection Adding functions to a @code{LISPLET} -Registering a function gives you more flexybility then registering a static resource as a file or a directory but the complexity +Registering a function gives you more flexibility then registering a static resource as a file or a directory but the complexity relies into the function that you want to register. -For example, if you want to provide the same ``matrix.jpg'' file throught a function, you'll have to do something of the kind: +For example, if you want to provide the same ``matrix.jpg'' file through a function, you'll have to do something of the kind: @cartouche @lisp (lisplet-register-function-location *test-lisplet* @@ -118,7 +118,7 @@ "images/matrix2.jpg" ) @end lisp @end cartouche -Now the image will be availbe at the URL ``http://localhost:4242/test/images/matrix2.jpg''. +Now the image will be available at the URL ``http://localhost:4242/test/images/matrix2.jpg''. The method @code{lisplet-register-function-location} accepts two optional keys: @itemize @minus @@ -139,10 +139,22 @@ @cartouche @lisp (defclass empty-page (page) ()) -(lisplet-register-page-location *test-lisplet* 'empty-page "index.html" :welcome-page-p t) +(lisplet-register-page-location *test-lisplet* 'empty-page "index.html" + :welcome-page-p t) @end lisp @end cartouche This will provide an empty page at the URL ``http://localhost:4242/test/index.html'' and, since it is defined as a welcome page when you'll access the URL ``http://localhost:4242/test'' you will redirected to it. + +@section Sessions + +Sessions are common place where you sore stateful user data. Session handling is slightly different from the original one +implemented by @code{Hunchentoot}, so, to instantiate a session you have to use the method +@cartouche +@lisp +(lisplet-start-session) +@end lisp +@end cartouche +inside your code. Modified: trunk/doc/chapters/pages.texinfo ============================================================================== --- trunk/doc/chapters/pages.texinfo (original) +++ trunk/doc/chapters/pages.texinfo Wed Apr 9 13:59:58 2008 @@ -1,3 +1,158 @@ @node Pages @comment node-name, next, previous, up @chapter Web application pages + +@value{claw} applications are usually made of pages. + +A @code{PAGE} is a @code{CLOS} class that contains the rendering logic and is called +by the @code{LISPLET} when the URL matches the page resource mapping. + +@section Writing your first @value{claw} page + +You already know how to register a @code{PAGE} into a @code{LISPLET}, if not, visit the previous chapter; what +you miss, is how to put content into a page. + +@value{claw} comes with the full set of html tags plus some custom components that we'll see in the next sections. + +All html tag are rendered with functions whose names are the tag name plus the character >. Tag attributes are pairs +of symbols for attribute names and strings for their values. + +For example the function that render a DIV tag with class attribute ``foo'' is: +@cartouche +@lisp +(div> :class "foo") +@end lisp +@end cartouche + +Given this short intro we are now ready to write our first @value{claw} page: +@cartouche +@lisp +(defclass index-page (page) ()) +(defmethod page-content ((index-page index-page)) + (html> + (head> + (title> "First sample page")) + (body> + (h1> "Hello world")))) +(lisplet-register-page-location *test-lisplet* 'index-page "index.html" + :welcome-page-p t) +@end lisp +@end cartouche + +So, overriding the method @code{PAGE-CONTENT} for your new defined page gives you the possibility +to insert its content. As you can see the method definition is very similar to an HTML file, thought +more concise. + +@subsection The special tag attribute: @code{:ID} and @code{:STATIC-ID} + +@value{claw} pages try to keep ``ID'' tag attributes unique among the page. This is particularly useful +when you have to render tags that expose their id inside a loop. +To see what happens when this situation occurs see the following example: +@cartouche +@lisp +(defmethod page-content ((sample-page sample-page)) + (html> + (head> + (title> "First sample page")) + (body> + (loop for letter in (list "A" "B" "C" "D") + collect (div> :id "item" letter))))) +@end lisp +@end cartouche + +will produce the following HTML code +@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>First sample page</title> + </head> + <body> + <div id="item">A</div> + <div id="item_1">B</div> + <div id="item_2">C</div> + <div id="item_3">D</div> + <script type="text/javascript"> +// + </script> + </body> +</html> +@end format +@end example +@end cartouche + +When you want to prevent the default behaviour on id generation you have to provide the tag with the +attribute @code{:STATIC-ID}, that will render into HTML as the attribute @code{:ID}, but without the id +unique logic generation. + +An important method that is present in all tags and component is the @code{GENERATE-ID} that you +may use to obtain a unique id and put into components or tags with @code{:STATIC-ID}. + +Look at the following to see how it can work: +@cartouche +@lisp +(defmethod page-content ((sample-page sample-page)) + (html> + (head> + (title> "First sample page")) + (body> + (loop for letter in (list "A" "B" "C" "D") + for id = (generate-id "item") then (generate-id "item") + collect (div> (span> :static-id id letter) + (span> :onclick + (format nil "alert(document.getElementById('~a').innerHTML);" + id) + "click me")))))) +@end lisp +@end cartouche +that will produce the following HTML code: +@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>First sample page</title> + </head> + <body> + <div> + <span id="item">A</span> + <span onclick="alert(document.getElementById('item').innerHTML);"> + click me</span> + </div> + <div> + <span id="item_1">B</span> + <span onclick="alert(document.getElementById('item_1').innerHTML);"> + click me</span> + </div> + <div> + <span id="item_2">C</span> + <span onclick="alert(document.getElementById('item_2').innerHTML);"> + click me</span> + </div> + <div> + <span id="item_3">D</span> + <span onclick="alert(document.getElementById('item_3').innerHTML);"> + click me</span> + </div> + <script type="text/javascript"> +// + </script> + </body> +</html> +@end format +@end example +@end cartouche + +So, the outside tag generated id, is used in the onclick method of the span tags to reference the +previous tag. Modified: trunk/doc/chapters/server.texinfo ============================================================================== --- trunk/doc/chapters/server.texinfo (original) +++ trunk/doc/chapters/server.texinfo Wed Apr 9 13:59:58 2008 @@ -431,7 +431,8 @@ @cartouche @lisp -(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4443 +(defparameter *clawserver* (make-instance 'clawserver :port 4242 + :sslport 4443 :ssl-certificate-file #P"/path/to/certificate/cacert.pem" :ssl-privatekey-file #P"/path/to/certificate/privkey.pem"))) (clawserver-start *clawserver*)

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 13:59:03 2008 New Revision: 33 Modified: trunk/main/claw-core/tests/test1.lisp Log: clutter removing Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Wed Apr 9 13:59:03 2008 @@ -115,7 +115,7 @@ (html> (head> (title> - (wcomponent-parameter-value o ':title)) + (wcomponent-parameter-value o :title)) (style> :type "text/css" "input.error { background-color: #FF9999;

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 09:17:57 2008 New Revision: 32 Modified: trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/tests/test1.lisp Log: updating user manual Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Wed Apr 9 09:17:57 2008 @@ -1014,7 +1014,7 @@ (when (eq k :id) (setf id v)) (when (eq k :static-id) - (setf static-id v)))) + (setf static-id v)))) (when (and (eq id :required) (null static-id)) (error (format nil "Parameter id of class ~a is required" Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Wed Apr 9 09:17:57 2008 @@ -55,12 +55,12 @@ ));:message-dispatcher *lisplet-messages*)) (defvar *test-lisplet2*) -(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2" - ));:message-dispatcher *lisplet-messages*)) +(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 :sslport 4445 +(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")) @@ -205,14 +205,12 @@ (lisplet-register-function-location *test-lisplet* #'(lambda () (let ((path (test-image-file))) - (progn - (setf (content-type) (mime-type path)) - (load-time-value - (with-open-file (in (test-image-file) :element-type 'flex:octet) - (let ((image-data (make-array (file-length in) - :element-type 'flex:octet))) - (read-sequence image-data in) - image-data)))))) + (setf (content-type) (mime-type path)) + (with-open-file (in path :element-type 'flex:octet) + (let ((image-data (make-array (file-length in) + :element-type 'flex:octet))) + (read-sequence image-data in) + image-data)))) "images/matrix2.jpg" ) ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ())

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 09:17:29 2008 New Revision: 31 Modified: trunk/doc/chapters/intro.texinfo Log: updating user manual Modified: trunk/doc/chapters/intro.texinfo ============================================================================== --- trunk/doc/chapters/intro.texinfo (original) +++ trunk/doc/chapters/intro.texinfo Wed Apr 9 09:17:29 2008 @@ -10,6 +10,17 @@ @value{claw} is based on components, highly reusable building blocks the make easy and fast the creation of a web application. By using and creating new components, the developer can create robust and consistent web application with the minimal effort. +Each component may inject into a page ist own set of stylesheet and javasctipt files, and may come with its own class or instance javascript +directives (a class directive is inserted only once into the page, while this is not true for an instance script). This leads to +the creation of very sophisticated components with a very little effort. + +@value{claw} comes with its own authentication systme that lets you create both basic and form based authentication systems. + +@value{claw} has the capability to force the page renderinig throught the protocol https of pages managing sensible data, using simple +directives. + +@value{claw} comes with its own extensible localization and validation system. + The main aim of @value{claw} is @cite{`divide et impera'}, that means that dividing problems into small problems let programmers work on different part of an application, creating ad hoc components for both generic and specific tasks. @@ -21,9 +32,9 @@ @subsection The request cycle -When a user asks for a page the request is sent to the woserver that dispatches the request to the registered lisplets. +When a user asks for a page the request is sent to the @code{CLAWSERVER} that dispatches the request to the registered lisplets. -Lisplets are web resource containers that hold web pages and other resource files, such as javascript, image, css, etc. files, under a common path. +Lisplets are web resource containers that hold web pages and other resource files, such as javascript, image, css, etc. files, or even funcions, under a common path. When a matching lisplet is then found, it dispatches the request to a registered resource that can be a page or a file or even a function.

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 09:17:03 2008 New Revision: 30 Modified: trunk/doc/chapters/server.texinfo Log: updating user manual Modified: trunk/doc/chapters/server.texinfo ============================================================================== --- trunk/doc/chapters/server.texinfo (original) +++ trunk/doc/chapters/server.texinfo Wed Apr 9 09:17:03 2008 @@ -440,3 +440,15 @@ @value{claw} is now up and you can browse it with your browser using address http://www.yourcompany.com:4242 and http://www.yourcompany.com:4443. Of course you will have only a 404 response page! + +@subsection Making all applications to work under a common path + +You have the possibility to define a common path to mapp all @value{claw} applications registered into the server, +defining the global variable @code{*CLAWSERVER-BASE-PATH*}. This way, if you have two applcations mapped for example to +``/applicationA'' and ``/applicationB'', setting that variable to the common path ``/yourcompany'' with the instruction +@cartouche +@lisp +(setf *clawserver-base-path* "/yourcompany") +@end lisp +@end cartouche +you will have the two applications now mapped to ``/yourcompany/applicationA'' and ``/yourcompany/applicationB''.

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 09:16:31 2008 New Revision: 29 Added: trunk/doc/chapters/access.texinfo trunk/doc/chapters/advanced-components.texinfo trunk/doc/chapters/advanced-techniques.texinfo trunk/doc/chapters/forms.texinfo trunk/doc/chapters/getting-started.texinfo trunk/doc/chapters/i18n.texinfo trunk/doc/chapters/lisplets.texinfo trunk/doc/chapters/pages.texinfo trunk/doc/chapters/validation.texinfo trunk/doc/chapters/writing-components.texinfo Log: updating user manual Added: trunk/doc/chapters/access.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/access.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node login access +@comment node-name, next, previous, up +@chapter Access validation and authorization Added: trunk/doc/chapters/advanced-components.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/advanced-components.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node advanced components +@comment node-name, next, previous, up +@chapter Writing advanced components Added: trunk/doc/chapters/advanced-techniques.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/advanced-techniques.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node Advanced techniques +@comment node-name, next, previous, up +@chapter Advanced techniques Added: trunk/doc/chapters/forms.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/forms.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node forms +@comment node-name, next, previous, up +@chapter @value{claw} forms and form components Added: trunk/doc/chapters/getting-started.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/getting-started.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node Getting Started +@comment node-name, next, previous, up +@chapter Getting started with @value{claw} Added: trunk/doc/chapters/i18n.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/i18n.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node i18n +@comment node-name, next, previous, up +@chapter Internationalization of our application Added: trunk/doc/chapters/lisplets.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/lisplets.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,148 @@ +@node Lisplets +@comment node-name, next, previous, up +@chapter Lisplets + +Lisplets are @code{CLOS} objects that extend the functionalities of @code{CLAWSERVER}, dispatching requests that +come from this last one. + +Lisplets are so, the place where you put your web applications developed with @value{claw}. + +Lisplets return to the requesting user, pages, functions and resources mapped into them. + +Each Lisplet contains its own dispatch table and realm so that applications are not mixed together. + +@section Registering a lisplet into the server, crating a web application + +To create a web application you have to instantiate a @code{LISPLET} and then register it into the server. +@cartouche +@lisp +(defvar *clawserver* (make-instance 'clawserver :port 4242)) + +(defvar *test-lisplet* (make-instance 'lisplet :base-path "/test")) +(clawserver-register-lisplet *clawserver* *test-lisplet*) + +;;; you can now start the server +;;; with: +;;; (clawserver-start *clawserver*) +;;; and +;;; (clawserver-stop *clawserver*) +@end lisp +@end cartouche + +At this point you have defined a web application registered to the URL ``http://localhost:4242/test'' that +@value{claw} will be able to serve. + +All sessions and the authentication and authourization logic will be under the default realm ``claw'', +so if you register another lisplet into the server with the instruction: +@cartouche +@lisp +(defvar *test-lisplet2* (make-instance 'lisplet :base-path "/test2")) +(clawserver-register-lisplet *clawserver* *test-lisplet2*) +@end lisp +@end cartouche +any user session will be shared among @code{*test-lisplet*} and @code{*test-lisplet2*} and if a user is logged into +``/test'' application, he will be logged into ``/test2'' application too. + +To avoid this behaviour, you need to define a different realm for each of the two lisplet as the following example does: +@cartouche +@lisp +(defvar *clawserver* (make-instance 'clawserver :port 4242)) + +(defvar *test-lisplet* (make-instance 'lisplet :realm "test" + :base-path "/test")) +(clawserver-register-lisplet *clawserver* *test-lisplet*) + +(defvar *test-lisplet2* (make-instance 'lisplet :realm "test2" + :base-path "/test2")) +(clawserver-register-lisplet *clawserver* *test-lisplet2*) +@end lisp +@end cartouche + +The two lisplets will now have different realms, so a user session in @code{*test-lisplet*} will be +different from the one in @code{*test-lisplet2*}. So for the authentication and authorization module. +The same is for a user logged into the first application, he will not be automatically logged into the +other now. + +@section Adding resources into a @code{LISPLET} + +Lisplets alone don't do anything more then providing some error pages when something goes wrong. +To make a @code{LISPLET} a web application, you have to fill it with some application resource, and this +may be done in several ways. + +@subsection Adding files and folders to a @code{LISPLET} + +Suppose now you want to provide, thought your web application, a file present on jour hard disk, for example: +``/opt/webresources/images/matrix.jpg''. + +This is made very simple with the following instructions +@cartouche +@lisp +(lisplet-register-resource-location *test-lisplet* + #P"/opt/webresources/images/matrix.jpg" + "images/matrix.jpg" "image/jpeg") +@end lisp +@end cartouche + +The jpeg file will now be available when accessing ``http://localhost:4242/test/images/matrix.jpg''. +The last rgument specifies the mime-type, but it's optional. + +If you want to regiter an entire folder, the process is very similar +@cartouche +@lisp +(lisplet-register-resource-location *test-lisplet* + #P"/opt/webresources/images/" + "images2/") +@end lisp +@end cartouche + +Now you'll be able to access the same resource following the URL +``http://localhost:4242/test/images2/matrix.jpg'', easy, isn't it? + +@subsection Adding functions to a @code{LISPLET} + +Registering a function gives you more flexybility then registering a static resource as a file or a directory but the complexity +relies into the function that you want to register. + +For example, if you want to provide the same ``matrix.jpg'' file throught a function, you'll have to do something of the kind: +@cartouche +@lisp +(lisplet-register-function-location *test-lisplet* + #'(lambda () + (let ((path #P"/opt/webresources/images/matrix.jpg")) + (setf (content-type) (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" ) +@end lisp +@end cartouche +Now the image will be availbe at the URL ``http://localhost:4242/test/images/matrix2.jpg''. + +The method @code{lisplet-register-function-location} accepts two optional keys: +@itemize @minus +@item +@code{:WELCOME-PAGE-P} that +will redirect you to the registered location when you'll access your application with the URL +``http://localhost:4242/test'' +@item +@code{:LOGIN-PAGE-P} that will redirect an unregistered user to the resource when he tries to access +a protected resource to perform the login with a form based authentication. +@end itemize + +@subsection Adding pages to a @code{LISPLET} + +Pages are one of the key objects of @value{claw}, since they are sophisticated collectors of web components. +Pages are described in the next chapter, meanwhile to register a page that is a @code{CLOS} object, the procedure +is very similar to when you register a function. +@cartouche +@lisp +(defclass empty-page (page) ()) +(lisplet-register-page-location *test-lisplet* 'empty-page "index.html" :welcome-page-p t) +@end lisp +@end cartouche + +This will provide an empty page at the URL ``http://localhost:4242/test/index.html'' and, since it +is defined as a welcome page when you'll access the URL ``http://localhost:4242/test'' you will redirected +to it. Added: trunk/doc/chapters/pages.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/pages.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node Pages +@comment node-name, next, previous, up +@chapter Web application pages Added: trunk/doc/chapters/validation.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/validation.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node validation +@comment node-name, next, previous, up +@chapter Input validation and field translations Added: trunk/doc/chapters/writing-components.texinfo ============================================================================== --- (empty file) +++ trunk/doc/chapters/writing-components.texinfo Wed Apr 9 09:16:31 2008 @@ -0,0 +1,3 @@ +@node writing components +@comment node-name, next, previous, up +@chapter Creating a web application by writing reusable components

1 0

[claw-cvs] r28 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 09 Apr '08

09 Apr '08

Author: achiumenti Date: Wed Apr 9 08:24:28 2008 New Revision: 28 Modified: trunk/main/claw-core/src/misc.lisp Log: Corrected the registering lisplet function Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Wed Apr 9 08:24:28 2008 @@ -71,7 +71,7 @@ "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 cons-list)))) + (setf result (push location-cons result)))) (defun lisplet-start-session () "Starts a session boud to the current lisplet base path"

1 0

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

09 Apr '08

Author: achiumenti Date: Wed Apr 9 05:26:01 2008 New Revision: 27 Modified: 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/tests/test1.lisp Log: corrected json requests and init script injection that will be evaluate on document load Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Wed Apr 9 05:26:01 2008 @@ -144,6 +144,13 @@ (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)))))) + (defmacro with-message (key &optional (default "") locale) (let ((current-lisplet (gensym)) (current-page (gensym)) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Wed Apr 9 05:26:01 2008 @@ -46,6 +46,7 @@ :*clawserver-base-path* :*apache-http-port* :*apache-https-port* + :*empty-tags* ;:request-realm :request-id-table-map ;:dyna-id @@ -260,6 +261,7 @@ #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password + :msie-p :clawserver-register-configuration :claw-require-authorization :configuration Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Wed Apr 9 05:26:01 2008 @@ -585,6 +585,16 @@ (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) (when content-type (page-format-raw page "~a~%" content-type))))) + +(defun json-validation-errors () + (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"))) (defmethod page-render ((page page)) (let ((body (page-content page)) @@ -603,7 +613,7 @@ (page-init page) (when jsonp (page-format-raw page "{components:{")) - (setf (page-can-print page) t) + ;;(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:\"") @@ -615,7 +625,9 @@ (let ((init-scripts (htbody-init-scripts-tag page))) (when init-scripts (htcomponent-render init-scripts page))) - (page-format-raw 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 "")) @@ -651,14 +663,17 @@ (setf (htcomponent-body current-js) class-init-scripts) (push current-js tag-list))) (dolist (js-file (page-script-files page)) - (let ((current-js (script> :type "text/javascript" :src ""))) - (setf (getf (htcomponent-attributes current-js) :src) js-file) - (push current-js tag-list))) - + (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)) - (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) - (setf (getf (htcomponent-attributes current-css) :href) css-file) - (push current-css tag-list))) + (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)) @@ -681,7 +696,7 @@ (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) (id (htcomponent-client-id htcomponent))) - (when (or jsonp + (when (and jsonp (member id jsonp :test #'string-equal)) (when (> (page-json-component-count page) 0) (page-format page ",")) @@ -692,7 +707,7 @@ (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) (id (htcomponent-client-id htcomponent))) - (when (or jsonp + (when (and jsonp (member id jsonp :test #'string-equal)) (page-format-raw page "\"")))) @@ -943,9 +958,21 @@ (htcomponent-json-print-end-component htbody)))) (defmethod htbody-init-scripts-tag ((page page)) - (let ((js (script> :type "text/javascript"))) - (setf (htcomponent-page js) page) - (setf (htcomponent-body js) (page-body-init-scripts 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))) + (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)))) js)) ;;;========= WCOMPONENT =================================== Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Wed Apr 9 05:26:01 2008 @@ -163,6 +163,23 @@ (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)) + +(defmethod wcomponent-template ((msie-p msie-p)) + (let ((id (htcomponent-client-id msie-p))) + (p> :static-id id))) + +(defmethod htcomponent-instance-initscript ((msie-p msie-p)) + (let ((id (htcomponent-client-id msie-p))) + (format nil "document.getElementById('~a').innerHTML = '~a';" + id + (if (msie-p) + "The browser is MSIE" + "The browser is not MSIE")))) + (defclass info-page (page) ()) (defmethod page-content ((o info-page)) @@ -174,7 +191,8 @@ (loop for key-val in header-props collect (tr> (td> (format nil "~a" (car key-val)) - (td> (format nil "~a" (cdr key-val))))))))))) + (td> (format nil "~a" (cdr key-val)))))))) + (msie-p> :id "msie")))) (lisplet-register-page-location *test-lisplet* 'info-page "info.html")

1 0

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

02 Apr '08

Author: achiumenti Date: Wed Apr 2 02:15:27 2008 New Revision: 26 Modified: trunk/doc/chapters/intro.texinfo Log: documentation update Modified: trunk/doc/chapters/intro.texinfo ============================================================================== --- trunk/doc/chapters/intro.texinfo (original) +++ trunk/doc/chapters/intro.texinfo Wed Apr 2 02:15:27 2008 @@ -25,9 +25,9 @@ Lisplets are web resource containers that hold web pages and other resource files, such as javascript, image, css, etc. files, under a common path. -When a matching lisplet is then found, it dispatches the request to a registered resource that can be a page or a file. +When a matching lisplet is then found, it dispatches the request to a registered resource that can be a page or a file or even a function. -If the request is sent for a file, this is then sent pack to the browser if found. +If the request is sent for a file, this is then sent back to the browser if found. If the request is sent for a page, usually mapped to a html url, the dispatcher calls the page rendering function to display the page as an html resource.

1 0

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

01 Apr '08

Author: achiumenti Date: Tue Apr 1 11:11:57 2008 New Revision: 25 Added: trunk/main/claw-core/src/translators.lisp Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/validators.lisp trunk/main/claw-core/tests/packages.lisp trunk/main/claw-core/tests/test1.lisp Log: added local-time integration with validator and translator Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Tue Apr 1 11:11:57 2008 @@ -39,7 +39,8 @@ (:file "locales" :depends-on ("i18n")) (:file "hunchentoot-overrides" :depends-on ("packages")) (:file "tags" :depends-on ("misc")) - (:file "validators" :depends-on ("tags")) + (:file "validators" :depends-on ("tags")) + (: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/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Tue Apr 1 11:11:57 2008 @@ -288,6 +288,7 @@ :translator :translator-integer :translator-number + :translator-date :translator-encode :translator-decode :*simple-translator* @@ -299,6 +300,7 @@ :validator-size :validator-range :validator-number - :validator-integer + :validator-integer + :validator-date-range :exception-monitor :exception-monitor>)) Added: trunk/main/claw-core/src/translators.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/translators.lisp Tue Apr 1 11:11:57 2008 @@ -0,0 +1,300 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/components.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) + +(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)) + (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))) + (format nil "~a" (if (component-validation-errors wcomponent) + (page-req-parameter page (htcomponent-client-id wcomponent) nil) + (progn + (when (null visit-object) + (setf visit-object (htcomponent-page wcomponent))) + (if (and (null reader) accessor) + (funcall (fdefinition accessor) visit-object) + (funcall (fdefinition reader) visit-object))))))) + +(defmethod translator-decode ((translator translator) (wcomponent wcomponent)) + (multiple-value-bind (client-id new-value) + (component-id-and-value wcomponent) + (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") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-integer (translator) + ((thousand-separator :initarg :thousand-separator + :reader translator-thousand-separator + :documentation "If specified (as character), it is the thousands separator. Despite of +its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator") + (always-show-signum :initarg :always-show-signum + :reader translator-always-show-signum + :documentation "When true the signum is used also for displaying positive numbers.") + (grouping-size :initarg :grouping-size + :reader translator-grouping-size + :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) + (:default-initargs :thousand-separator nil + :grouping-size 3 + :always-show-signum nil) + (:documentation "A translator object encodes and decodes integer values passed to a html input component")) + +(defmethod translator-encode ((translator translator-integer) (wcomponent wcomponent)) + (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)) + (grouping-size (translator-grouping-size translator)) + (thousand-separator (translator-thousand-separator translator)) + (signum-directive (if (translator-always-show-signum translator) + "@" + "")) + (control-string (if thousand-separator + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive))) + + (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (progn + (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 thousand-separator + (string-trim " " (format nil control-string thousand-separator value)) + (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) + (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))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-number (translator-integer) + ((decimals-separator :initarg :decimals-separator + :reader translator-decimals-separator + :documentation "The decimal separator of the rendered number. Default to #\.") + (decimal-digits :initarg :decimal-digits + :reader translator-decimal-digits + :documentation "force the rendering of the value to a fixed number of decimal digits") + (coerce :initarg :coerce + :accessor translator-coerce + :documentation "Coerces the decoded input value to the given value type")) + (:default-initargs :decimals-separator #\. + ;:integer-digits nil + :decimal-digits nil + :coerce 'ratio) + (:documentation "a translator object encodes and decodes integer values passed to a html input component")) + + +(defmethod translator-encode ((translator translator-number) (wcomponent wcomponent)) + (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)) + (thousand-separator (translator-thousand-separator translator)) + (grouping-size (translator-grouping-size translator)) + (decimal-digits (translator-decimal-digits translator)) + (decimals-separator (translator-decimals-separator translator)) + (signum-directive (if (translator-always-show-signum translator) + "@" + "")) + (integer-control-string (if thousand-separator + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive))) + + (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (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))))))))))) + + +(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)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-date (translator) + ((local-time-format :initarg :local-time-format + :reader translator-local-time-format + :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are +expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)")) + (:default-initargs :local-time-format '(:month "/" :date "/" :year)) + (:documentation "A translator object encodes and decodes local-date object value passed to a html input component. +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\". +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 wcomponent)) + (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)) + (local-time-format (translator-local-time-format translator)) + (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (progn + (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)) + value))))) + +(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent)) + (let ((date-format (translator-local-time-format translator)) + (sec 0) + (min 0) + (hour 0) + (day 0) + (month 0) + (year 0) + (old-value)) + (multiple-value-bind (client-id new-value) + (component-id-and-value wcomponent) + (declare (ignore client-id)) + (when (and new-value (string-not-equal new-value "")) + (setf old-value new-value) + (loop for element in date-format + do (if (stringp element) + (setf new-value (subseq new-value (length element))) + (ccase element + (:second (multiple-value-bind (value size) + (parse-integer new-value :junk-allowed t) + (setf new-value (subseq new-value size)) + (setf sec value))) + (:minute (multiple-value-bind (value size) + (parse-integer new-value :junk-allowed t) + (setf new-value (subseq new-value size)) + (setf min value))) + (:hour (multiple-value-bind (value size) + (parse-integer new-value :junk-allowed t) + (setf new-value (subseq new-value size)) + (setf hour value))) + (:date (multiple-value-bind (value size) + (parse-integer new-value :junk-allowed t) + (setf new-value (subseq new-value size)) + (setf day value))) + (:month (multiple-value-bind (value size) + (parse-integer new-value :junk-allowed t) + (setf new-value (subseq new-value size)) + (setf month value))) + (:year (multiple-value-bind (value size) + (parse-integer new-value :junk-allowed t) + (setf new-value (subseq new-value size)) + (setf year value)))))) + (validate (and (string-equal new-value "") + (>= sec 0) + (>= min 0) + (>= hour 0) + (and (> month 0) (<= month 12)) + (and (> day 0) (<= day (days-in-month month year)))) + :component wcomponent + :message (format nil (do-message "VALIDATOR-DATE" "Field ~a is not a valid date or wrong format: ~a") + (wcomponent-parameter-value wcomponent :label) + old-value)) + (if (component-validation-errors wcomponent) + old-value + (encode-local-time 0 sec min hour day month year)))))) + Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Tue Apr 1 11:11:57 2008 @@ -29,259 +29,27 @@ (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 local-time-to-string (local-time format) + (:documentation "Writes a local-time instance the FORMAT list where element are joined together and :SECOND :MINUTE :HOUR :DATE :MONTH and :YEAR are +expanded into seconds for :SECOND, minutes for :MINUTE, hour of the day for :HOUR, day of the month for :DATE, month number for :MONTH and the year for :YEAR. +A format list may be for example '(:month \"/\" :date \"/\" :year)")) + +(defmethod local-time-to-string ((local-time local-time) format) + (multiple-value-bind (nsec sec min hour day month year) + (decode-local-time local-time) + (declare (ignore nsec)) + (loop for result = "" then (concatenate 'string result (if (stringp element) + element + (ccase element + (:second (format nil "~2,'0D" sec)) + (:minute (format nil "~2,'0D" min)) + (:hour (format nil "~2,'0D" hour)) + (:date (format nil "~2,'0D" day)) + (:month (format nil "~2,'0D" month)) + (:year (format nil "~4,'0D" year))))) + for element in format + finally (return result)))) -(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)) - (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))) - (format nil "~a" (if (component-validation-errors wcomponent) - (page-req-parameter page (htcomponent-client-id wcomponent) nil) - (progn - (when (null visit-object) - (setf visit-object (htcomponent-page wcomponent))) - (if (and (null reader) accessor) - (funcall (fdefinition accessor) visit-object) - (funcall (fdefinition reader) visit-object))))))) - -(defmethod translator-decode ((translator translator) (wcomponent wcomponent)) - (multiple-value-bind (client-id new-value) - (component-id-and-value wcomponent) - (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") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass translator-integer (translator) - ((thousand-separator :initarg :thousand-separator - :reader translator-thousand-separator - :documentation "If specified (as character), it is the thousands separator. Despite of -its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator") - (always-show-signum :initarg :always-show-signum - :reader translator-always-show-signum - :documentation "When true the signum is used also for displaying positive numbers.") - (grouping-size :initarg :grouping-size - :reader translator-grouping-size - :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) - (:default-initargs :thousand-separator nil - :grouping-size 3 - :always-show-signum nil) - (:documentation "A translator object encodes and decodes integer values passed to a html input component")) - -(defmethod translator-encode ((translator translator-integer) (wcomponent wcomponent)) - (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)) - (grouping-size (translator-grouping-size translator)) - (thousand-separator (translator-thousand-separator translator)) - (signum-directive (if (translator-always-show-signum translator) - "@" - "")) - (control-string (if thousand-separator - (format nil "~~~d,' ,v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (progn - (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 thousand-separator - (string-trim " " (format nil control-string thousand-separator value)) - (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) - (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))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass translator-number (translator-integer) - ((decimals-separator :initarg :decimals-separator - :reader translator-decimals-separator - :documentation "The decimal separator of the rendered number. Default to #\.") - (decimal-digits :initarg :decimal-digits - :reader translator-decimal-digits - :documentation "force the rendering of the value to a fixed number of decimal digits") - (coerce :initarg :coerce - :accessor translator-coerce - :documentation "Coerces the decoded input value to the given value type")) - (:default-initargs :decimals-separator #\. - ;:integer-digits nil - :decimal-digits nil - :coerce 'ratio) - (:documentation "a translator object encodes and decodes integer values passed to a html input component")) - - -(defmethod translator-encode ((translator translator-number) (wcomponent wcomponent)) - (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)) - (thousand-separator (translator-thousand-separator translator)) - (grouping-size (translator-grouping-size translator)) - (decimal-digits (translator-decimal-digits translator)) - (decimals-separator (translator-decimals-separator translator)) - (signum-directive (if (translator-always-show-signum translator) - "@" - "")) - (integer-control-string (if thousand-separator - (format nil "~~~d,' ,v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (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))))))))))) - - -(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)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defclass translator-date (translator) - ((date-format :initarg :date-format - :reader translator-date-fromat - :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are -expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)")) - (:default-initargs :date-format '(:month "/" :date "/" :year)) - (:documentation "A translator object encodes and decodes local-date object value passed to a html input component")) - - -#| -(defmethod translator-encode ((translator translator-number) (wcomponent wcomponent)) - (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)) - (thousand-separator (translator-thousand-separator translator)) - (grouping-size (translator-grouping-size translator)) - (decimal-digits (translator-decimal-digits translator)) - (decimals-separator (translator-decimals-separator translator)) - (signum-directive (if (translator-always-show-signum translator) - "@" - "")) - (integer-control-string (if thousand-separator - (format nil "~~~d,' ,v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (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))))))))))) - - -(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)))))) -|# -;;---------------------------------------------------------------------------------------- (defun add-exception (id reason) "Adds an exception for the given input component identified by its ID with the message expressed by REASON" (let* ((validation-errors (aux-request-value :validation-errors)) @@ -326,7 +94,7 @@ (when value (setf value (format nil "~a" value)) (setf value-len (length value)) - (or (= value-len 0) + (and (= value-len 0) (when min-size (validate (>= value-len min-size) :component component @@ -347,7 +115,7 @@ If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATOR-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX value." (when value - (or (when min + (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") @@ -370,7 +138,7 @@ The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (numberp value))) - (or (validate test + (and (validate test :component component :message (format nil (do-message "VALIDATOR-NUMBER" "Field ~a is not a valid number.") (wcomponent-parameter-value component :label))) (validator-range component value :min min :max max))))) @@ -381,12 +149,58 @@ The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (integerp value))) - (or (validate test + (and (validate test :component component :message (format nil (do-message "VALIDATOR-INTEGER" "Field ~a is not a valid integer.") (wcomponent-parameter-value component :label))) (validator-range component value :min min :max max))))) +(defun validator-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\". +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\". +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))) + (new-value (make-instance 'local-time + :nsec (nsec-of value) + :sec (sec-of value) + :day (day-of value) + :timezone (timezone-of value)))) + (when (and use-date-p (not use-time-p)) + (setf (local-time:nsec-of new-value) 0 + (local-time:sec-of new-value) 0) + (when min + (setf (local-time:nsec-of min) 0 + (local-time:sec-of min) 0)) + (when max + (setf (local-time:nsec-of max) 0 + (local-time:sec-of max) 0))) + (when (and (not use-date-p) use-time-p) + (setf (local-time:day-of new-value) 0) + (when min + (setf (local-time:day-of min) 0)) + (when max + (setf (local-time:day-of max) 0))) + (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.") + (wcomponent-parameter-value component :label) + (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) + (local-time-to-string max local-time-format)))))))) + + + ;; ------------------------------------------------------------------------------------ (defcomponent exception-monitor () () (:documentation "If from submission contains exceptions. It displays exception messages")) Modified: trunk/main/claw-core/tests/packages.lisp ============================================================================== --- trunk/main/claw-core/tests/packages.lisp (original) +++ trunk/main/claw-core/tests/packages.lisp Tue Apr 1 11:11:57 2008 @@ -30,6 +30,6 @@ (in-package :cl-user) (defpackage :claw-tests - (:use :cl :claw :hunchentoot) + (:use :cl :claw :hunchentoot :local-time) (:export :claw-tst-start :claw-tst-stop)) \ No newline at end of file Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Tue Apr 1 11:11:57 2008 @@ -328,13 +328,17 @@ (age :initarg :age :accessor form-page-age) (capital :initarg :capital - :accessor form-page-capital)) + :accessor form-page-capital) + (birthday :initarg :birthday + :accessor form-page-birthday)) + (:default-initargs :name "kiuma" :surname "surnk" :colors nil :gender '("M") :age 1800 :capital 500055/100 + :birthday (now) :message-dispatcher *lisplet-messages* :user (make-instance 'user))) @@ -400,6 +404,17 @@ (validator-integer component value :min 1 :max 2000))) :accessor 'form-page-age)"*")) (tr> + (td> "Bithday") + (td> + (cinput> :id "bday" + :type "text" + :label "Birthday" + :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validator-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) + :accessor 'form-page-birthday)"(dd-mm-yyyy)")) + (tr> (td> "Capital") (td> (cinput> :id "capital"

1 0