[claw-cvs] r42 - in trunk/main/claw-core: . src tests
achiumenti at common-lisp.net
achiumenti at common-lisp.net
Sat Apr 26 15:05:45 UTC 2008
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>
More information about the Claw-cvs
mailing list