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>