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

[claw-cvs] r55 - in trunk/main/claw-core: . src tests
by achiumenti＠common-lisp.net 17 Jul '08

17 Jul '08

Author: achiumenti Date: Thu Jul 17 09:11:41 2008 New Revision: 55 Added: trunk/main/claw-core/src/connector.lisp trunk/main/claw-core/src/logger.lisp trunk/main/claw-core/src/session-manager.lisp Modified: trunk/main/claw-core/claw-tests.asd 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/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/src/translators.lisp trunk/main/claw-core/src/validators.lisp trunk/main/claw-core/tests/packages.lisp trunk/main/claw-core/tests/test1.lisp Log: commit of version 0.1.0 Modified: trunk/main/claw-core/claw-tests.asd ============================================================================== --- trunk/main/claw-core/claw-tests.asd (original) +++ trunk/main/claw-core/claw-tests.asd Thu Jul 17 09:11:41 2008 @@ -31,7 +31,7 @@ :name "claw-tests" :author "Andrea Chiumenti" :description "Tests for cl-webobjects" - :depends-on (:claw) + :depends-on (:claw :hunchentoot-connector) :components ((:module tests :components ((:file "packages") (:file "test1" :depends-on ("packages")) Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Thu Jul 17 09:11:41 2008 @@ -31,16 +31,19 @@ :name "claw" :author "Andrea Chiumenti" :description "Common Lisp Active Web.A famework to write web applications" - :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :parenscript) - :components ((:module src + :depends-on (:closer-mop :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :parenscript :bordeaux-threads :flexi-streams :md5) + :components ((:module src :components ((:file "packages") - (:file "misc" :depends-on ("packages")) + (:file "mime-type" :depends-on ("packages")) + (:file "misc" :depends-on ("mime-type")) (:file "i18n" :depends-on ("packages")) (:file "locales" :depends-on ("i18n")) - (:file "hunchentoot-overrides" :depends-on ("packages")) - (:file "tags" :depends-on ("misc")) + (:file "connector" :depends-on ("misc")) + (:file "logger" :depends-on ("misc")) + (:file "session-manager" :depends-on ("misc")) + (:file "tags" :depends-on ("misc")) (:file "components" :depends-on ("tags")) (:file "validators" :depends-on ("components")) (:file "translators" :depends-on ("validators")) - (:file "server" :depends-on ("components")) + (:file "server" :depends-on ("components")) (:file "lisplet" :depends-on ("server")))))) Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Thu Jul 17 09:11:41 2008 @@ -79,10 +79,10 @@ (defvar *file-translator* nil "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".") -(defun component-validation-errors (component &optional (request *request*)) +(defun component-validation-errors (component) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) - (getf (validation-errors request) (intern client-id)))) + (getf (validation-errors) (intern client-id)))) ;-------------------------------------------------------------------------------- @@ -285,6 +285,7 @@ (writer (cinput-writer cinput)) (validator (validator cinput)) (value (translator-decode (translator cinput) cinput))) +; (log-message :info "********************* ~a : ~a" cinput value) (unless (or (null value) (component-validation-errors cinput)) (when validator (funcall validator value)) Added: trunk/main/claw-core/src/connector.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/connector.lisp Thu Jul 17 09:11:41 2008 @@ -0,0 +1,261 @@ +;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/connector.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw) + +(defgeneric connector-host (connector) + (:documentation " +Returns the value of the incoming Host http header. \(This corresponds to the environment variable HTTP_HOST in CGI scripts.)")) + +(defgeneric connector-request-method (connector) + (:documentation "Returns the request method as a keyword, i.e. something like :POST. \(This corresponds to the environment variable REQUEST_METHOD in CGI scripts.)")) + +(defgeneric connector-script-name (connector) + (:documentation "Returns the file name \(or path) component of the URI for request, i.e. the part of the string returned by REQUEST-URI in front of the first question mark \(if any). +\(This corresponds to the environment variable SCRIPT_NAME in CGI scripts.)")) + +(defgeneric connector-request-uri (connector) + (:documentation "Returns the URI for request. +Note that this not the full URI but only the part behind the scheme and authority components, so that if the user has typed http://user:password@www.domain.com/xxx/frob.html?foo=bar into his browser, this function will return \"/xxx/frob.html?foo=bar\". \(This corresponds to the environment variable REQUEST_URI in CGI scripts.")) + +(defgeneric connector-query-string (connector) + (:documentation "Returns the query component of the URI for request, i.e. the part of the string returned by REQUEST-URI behind the first question mark \(if any). +\(This corresponds to the environment variable QUERY_STRING in CGI scripts.) See also CONNECTOR-GET-PARAMETER and CONNECTOR-GET-PARAMETERS.")) + +(defgeneric connector-get-parameter (connector name) + (:documentation "Returns the value of the GET parameter \(as provided via the request URI) named by the string name as a string \(or NIL if there ain't no GET parameter with this name). +Note that only the first value will be returned if the client provided more than one GET parameter with the name name. See also CONNECTOR-GET-PARAMETERS")) + +(defgeneric connector-get-parameters (connector) + (:documentation "Returns an alist of all GET parameters \(as provided via the request URI). The car of each element of this list is the parameter's name while the cdr is its value \(as a string). +The elements of this list are in the same order as they were within the request URI. See also CONNECTOR-GET-PARAMETER.")) + +(defgeneric connector-post-parameter (connector name) + (:documentation "Returns the value of the POST parameter \(as provided in the request's body) named by the string name. +Note that only the first value will be returned if the client provided more than one POST parameter with the name name. +This value will usually be a string \(or NIL if there ain't no POST parameter with this name). +If, however, the browser sent a file through a multipart/form-data form, the value of this function is a three-element list + +\(path file-name content-type) + +where path is a pathname denoting the place were the uploaded file was stored, file-name \(a string) is the file name sent by the browser, and content-type \(also a string) is the content type sent by the browser. +The file denoted by path will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it.")) + +(defgeneric connector-post-parameters (connector) + (:documentation "Returns an alist of all POST parameters (as provided via the request's body). The car of each element of this list is the parameter's name while the cdr is its value. The elements of this list are in the same order as they were within the request's body. +See also CONNECTOR-POST-PARAMETER.")) + +(defgeneric connector-parameter (connector name) + (:documentation "Returns the value of the GET or POST parameter named by the string name as a string \(or NIL if there ain't no parameter with this name). +If both a GET and a POST parameter with the name name exist, the GET parameter will be returned. See also CONNECTOR-GET-PARAMETER and CONNECTOR-POST-PARAMETER.")) + +(defgeneric connector-header-in (connector name) + (:documentation "Returns the incoming header named by the keyword name as a string \(or NIL if there ain't no header with this name). +Note that this queries the headers sent to Hunchentoot by the client or by mod_lisp. +In the latter case this may not only include the incoming http headers but also some headers sent by mod_lisp. +For backwards compatibility, name can also be a string which is matched case-insensitively. See also CONNECTOR-HEADERS-IN.")) + +(defgeneric connector-headers-in (connector) + (:documentation "Returns an alist of all incoming headers. +The car of each element of this list is the headers's name \(a Lisp keyword) while the cdr is its value (as a string). +There's no guarantee about the order of this list. See also CONECTOR-HEADER-IN and the remark about incoming headers there.")) + +(defgeneric connector-authorization (connector) + (:documentation "Returns as two values the user and password \(if any) from the incoming Authorization http header. +Returns NIL if there is no such header.")) + +(defgeneric connector-remote-addr (connector) + (:documentation "Returns the IP address \(as a string) of the client which sent the request. \(This corresponds to the environment variable REMOTE_ADDR in CGI scripts.) See also CONNECTOR-REAL-REMOTE-ADDR.")) + +(defgeneric connector-remote-port (connector) + (:documentation "Returns the IP port (as a number) of the client which sent the request.")) + +(defgeneric connector-real-remote-addr (connector) + (:documentation "Returns the value of the incoming X-Forwarded-For http header as the second value in the form of a list of IP addresses and the first element of this list as the first value if this header exists. +Otherwise returns the value of CONNECTOR-REMOTE-ADDR as the only value.")) + +(defgeneric connector-server-addr (connector) + (:documentation "Returns the IP address \(as a string) where the request came in. +\(This corresponds to the environment variable SERVER_ADDR in CGI scripts.)")) + +(defgeneric connector-server-port (connector) + (:documentation "Returns the IP port \(as a number) where the request came in.")) + +(defgeneric connector-server-protocol (connector) + (:documentation "Returns the version of the http protocol which is used by the client as a Lisp keyword - this is usually either :HTTP/1.0 or :HTTP/1.1. +\(This corresponds to the environment variable SERVER_PROTOCOL in CGI scripts.")) + +(defgeneric connector-user-agent (connector) + (:documentation "Returns the value of the incoming User-Agent http header. +\(This corresponds to the environment variable HTTP_USER_AGENT in CGI scripts.)")) + + +(defgeneric connector-referer (connector) + (:documentation "Returns the value of the incoming Referer \(sic!) http header. \(This corresponds to the environment variable HTTP_REFERER in CGI scripts.)")) + +(defgeneric connector-cookie-in (connector name) + (:documentation "Returns the value of the incoming cookie named by the string name \(or NIL if there ain't no cookie with this name). +See also CONNECTOR-COOKIES-IN")) + +(defgeneric connector-cookies-in (connector) + (:documentation "Returns an alist of all incoming cookies. +The car of each element of this list is the cookie's name while the cdr is the cookie's value. See also CONNECTOR-COOKIE-IN")) + +(defgeneric connector-aux-request-value (connector symbol) + (:documentation "Returns values VALUE, PRESENTP. +This accessor associates arbitrary data with the the symbol symbol in the REQUEST object request. +PRESENTP is true if such data was found, otherwise NIL")) + +(defgeneric (setf connector-aux-request-value) (value connector symbol) + (:documentation "This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request.")) + +(defgeneric connector-delete-aux-request-value (connector symbol) + (:documentation "Completely removes any data associated with the symbol symbol from the REQUEST object request. Note that this is different from using AUX-REQUEST-VALUE to set the data to NIL")) + +;;--------------------------- + +(defgeneric connector-header-out (connector name) + (:documentation "Returns the outgoing http header named by the keyword name if there is one, otherwise NIL \(name parameter must be a symbol). +Note that the headers Set-Cookie, Content-Length, and Content-Type cannot be queried by HEADER-OUT. +See also CONNECTOR-HEADERS-OUT, CONNECTOR-CONTENT-TYPE, CONNECTOR-CONTENT-LENGTH, CONNECTOR-COOKIES-OUT, and CONNECTOR-COOKIE-OUT")) + +(defgeneric (setf connector-header-out) (value connector name) + (:documentation "SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol). +If no header named name exists it is created. +Note that the headers Set-Cookie, Content-Length, and Content-Type must not be set by SETF of HEADER-OUT. +Also, there are a couple of \"technical\" headers like Connection or Transfer-Encoding that you're not supposed to set yourself. +See also CONNECTOR-HEADERS-OUT, CONNECTOR-CONTENT-TYPE, CONNECTOR-CONTENT-LENGTH, CONNECTOR-COOKIES-OUT, and CONNECTOR-COOKIE-OUT")) + +(defgeneric connector-headers-out (connector) + (:documentation "Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type). +The car of each element of this list is the headers's name while the cdr is its value. +This alist should not be manipulated directly, use SETF of CONNECTOR-HEADER-OUT instead")) + +(defgeneric connector-cookie-out (connector name) + (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name). +See also CONNECTOR-COOKIES-OUT and the CLAW-COOKIE class definition.")) + +(defgeneric (setf connector-cookie-out) (cookie-instance connector name) + (:documentation "Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply. +If a cookie with the same name \(case-sensitive) already exists, it is replaced. + The default for value is the empty string.")) + +(defgeneric connector-cookies-out (connector) + (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name). +See also CONNECTOR-COOKIES-OUT and the CLAW-COOKIE class definition.")) + +(defgeneric connector-return-code (connector) + (:documentation "CONNECTOR-RETURN-CODE returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)")) + +(defgeneric (setf connector-return-code) (value connector) + (:documentation "Setf CONNECTOR-RETURN-CODE sets the http return code of the reply.")) + +(defgeneric connector-content-type (connector) + (:documentation "CONNECTOR-CONTENT-TYPE returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\").")) + +(defgeneric (setf connector-content-type) (value connector) + (:documentation "SETF CONNECTOR-CONTENT-TYPE sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\").")) + +(defgeneric connector-reply-external-format-encoding (connector) + (:documentation "CONNECTOR-REPLY-EXTERNAL-FORMAT-ENCODING returns the symbol of the reply charset encoding \(Such as UTF-8).")) + +(defgeneric (setf connector-reply-external-format-encoding) (value connector) + (:documentation "SETF CONNECTOR-REPLY-EXTERNAL-FORMAT-ENCODING sets the symbol of the reply charset encoding \(Such as UTF-8).")) + +(defgeneric connector-writer (connector) + (:documentation "Returns the output stream writer to generate replies. It's default to *standard-output*")) + +(defgeneric connector-redirect (connector target &key host port protocol add-session-id code) + (:documentation "Sends back appropriate headers to redirect the client to target \(a string). +If target is a full URL starting with a scheme, host, port, and protocol are ignored. +Otherwise, target should denote the path part of a URL, protocol must be one of the keywords :HTTP or :HTTPS, and the URL to redirect to will be constructed from host, port, protocol, and target. +If code is a 3xx redirection code, it will be sent as status code. +In case of NIL, a 302 status code will be sent to the client. If host is not provided, the current host \(see CONNECTOR-HOST) will be used. +If protocol is the keyword :HTTPS, the client will be redirected to a https URL, if it's :HTTP it'll be sent to a http URL. +If both host and protocol aren't provided, then the value of protocol will match the current request.")) + +(defgeneric connector-content-length (connector) + (:documentation "Returns the outgoing Content-Length http header")) + +(defgeneric (setf connector-content-length) (value connector) + (:documentation "Sets the outgoing Content-Length http header")) + +(defclass connector (claw-service) + ((behind-apache-p :initarg :behind-apache-p + :accessor connector-behind-apache-p + :documentation "Returns true if the connector is running behind apache.") + (port :initarg :port + :accessor connector-port + :documentation "The port under which normal http requests are handled") + (sslport :initarg :sslport + :accessor connector-sslport + :documentation "The port under which https requests are handled") + (address :initarg :address + :accessor connector-address + :documentation "The address under which https reqhests are handled")) + (:default-initargs :port 80 :sslport 443 + :address nil + :behind-apache-p nil :name 'connector) + (:documentation "CONNECTOR is an interface, so you cannot directly use it. +A Connector subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides. +To properly work a CLAWSERVER instance must be provided with a CONNECTOR implementation. +A CONNECTOR implementation to properly work, must implement all the CONNECTOR- methods.")) + +(defmethod connector-writer ((connector connector))) + +(defclass claw-cookie () + ((name :initarg :name + :reader claw-cookie-name + :type string + :documentation "The name of the claw-cookie - a string.") + (value :initarg :value + :accessor claw-cookie-value + :initform "" + :documentation "The value of the claw-cookie. Will be URL-encoded when sent to the browser.") + (expires :initarg :expires + :initform nil + :accessor claw-cookie-expires + :documentation "The time \(a universal time) when the claw-cookie expires \(or NIL).") + (path :initarg :path + :initform nil + :accessor claw-cookie-path + :documentation "The path this claw-cookie is valid for \(or NIL).") + (domain :initarg :domain + :initform nil + :accessor claw-cookie-domain + :documentation "The domain this claw-cookie is valid for \(or NIL).") + (secure :initarg :secure + :initform nil + :accessor claw-cookie-secure + :documentation "A generalized boolean denoting whether this is a secure claw-cookie.") + (http-only :initarg :http-only + :initform nil + :accessor claw-cookie-http-only + :documentation "A generalized boolean denoting whether this is a HttpOnly claw-cookie."))) + Modified: trunk/main/claw-core/src/i18n.lisp ============================================================================== --- trunk/main/claw-core/src/i18n.lisp (original) +++ trunk/main/claw-core/src/i18n.lisp Thu Jul 17 09:11:41 2008 @@ -31,7 +31,7 @@ (defgeneric local-time-add (local-time field value) (:documentation "Adds the specified amount of VALUE to the LOCAL_TIME. -FIELD may be any of: +FIELD may be any of: * 'NSEC nano-seconds * 'MSEC milli-seconds * 'SEC seconds @@ -43,18 +43,18 @@ And other FIELD value will produce an error condition.")) -(defvar *locales* (make-hash-table :test 'equal) - "A hash table of locale key strings and lists of locale directives. +(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)) @@ -90,88 +90,97 @@ (decode-local-time local-time) (encode-local-time ns ss mm hh day month (+ year value)))) -(defun local-time-add-month (local-time 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) (setf d-month (- d-month) - d-year (- d-year)) + d-year (- d-year)) (multiple-value-bind (ns ss mm hh day month year) - (decode-local-time local-time) - (multiple-value-bind (ns ss mm hh day month-ignore year) - (decode-local-time (encode-local-time ns ss mm hh day 1 (+ year d-year))) - (encode-local-time ns ss mm hh day month year)))))) + (decode-local-time local-time) + (multiple-value-bind (ns ss mm hh day month-ignore year) + (decode-local-time (encode-local-time ns ss mm hh day 1 (+ year d-year))) + (declare (ignore month-ignore)) + (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 - :sec (sec-of local-time) - :nsec (nsec-of local-time) - :time-zone (timezone-of local-time)))) + (local-time-result (make-instance 'local-time + :day curr-day + :sec (sec-of local-time) + :nsec (nsec-of local-time) + :time-zone (timezone-of local-time)))) (setf (day-of local-time-result) (+ curr-day value)) 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 (ns-ignore ss-ignore mm-ignore hh day-ignore month-ignore year-ignore) + (decode-local-time local-time) + (declare (ignore ns-ignore ss-ignore mm-ignore day-ignore month-ignore year-ignore)) (multiple-value-bind (d-hour d-day) - (floor (abs value) 24) + (floor (abs value) 24) (when (< value 0) - (setf d-hour (- d-hour) - d-day (- d-day))) + (setf d-hour (- d-hour) + d-day (- d-day))) (let ((local-time-result (local-time-add-day local-time d-day))) - (multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2) - (decode-local-time local-time-result) - (encode-local-time ns2 ss2 mm2 (+ hh d-hour) day2 month2 year2)))))) + (multiple-value-bind (ns2 ss2 mm2 hh-ignore day2 month2 year2) + (decode-local-time local-time-result) + (declare (ignore hh-ignore)) + (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 (ns-ignore ss-ignore mm hh-ignore day-ignore month-ignore year-ignore) + (decode-local-time local-time) + (declare (ignore ns-ignore ss-ignore hh-ignore day-ignore month-ignore year-ignore)) (multiple-value-bind (d-min d-hour) - (floor (abs value) 60) + (floor (abs value) 60) (when (< value 0) - (setf d-min (- d-min) - d-hour (- d-hour))) + (setf d-min (- d-min) + d-hour (- d-hour))) (let ((local-time-result (local-time-add-hour local-time d-hour))) - (multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2) - (decode-local-time local-time-result) - (encode-local-time ns2 ss2 (+ mm d-min) hh2 day2 month2 year2)))))) + (multiple-value-bind (ns2 ss2 mm-ignore hh2 day2 month2 year2) + (decode-local-time local-time-result) + (declare (ignore mm-ignore)) + (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 (ns-ignore ss mm-ignore hh-ignore day-ignore month-ignore year-ignore) + (decode-local-time local-time) + (declare (ignore ns-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore)) (multiple-value-bind (d-sec d-min) - (floor (abs value) 60) + (floor (abs value) 60) (when (< value 0) - (setf d-sec (- d-sec) - d-min (- d-min))) + (setf d-sec (- d-sec) + d-min (- d-min))) (let ((local-time-result (local-time-add-min local-time d-min))) - (multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2) - (decode-local-time local-time-result) - (encode-local-time ns2 (+ ss d-sec) mm2 hh2 day2 month2 year2)))))) + (multiple-value-bind (ns2 ss-ignore mm2 hh2 day2 month2 year2) + (decode-local-time local-time-result) + (declare (ignore ss-ignore)) + (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 (ns ss-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore) + (decode-local-time local-time) + (declare (ignore ss-ignore mm-ignore hh-ignore day-ignore month-ignore year-ignore)) (multiple-value-bind (d-nsec d-sec) - (floor (abs value) 10000000) + (floor (abs value) 10000000) (when (< value 0) - (setf d-nsec (- d-nsec) - d-sec (- d-sec))) + (setf d-nsec (- d-nsec) + d-sec (- d-sec))) (let ((local-time-result (local-time-add-sec local-time d-sec))) - (multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2) - (decode-local-time local-time-result) - (encode-local-time (+ ns d-nsec) ss2 mm2 hh2 day2 month2 year2)))))) - + (multiple-value-bind (ns-ignore ss2 mm2 hh2 day2 month2 year2) + (decode-local-time local-time-result) + (declare (ignore ns-ignore)) + (encode-local-time (+ ns d-nsec) ss2 mm2 hh2 day2 month2 year2)))))) + (defmethod local-time-add ((local-time local-time) field value) - (ccase field + (ccase field (NSEC (local-time-add-nsec local-time value)) (SEC (local-time-add-sec local-time value)) (MIN (local-time-add-min local-time value)) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Thu Jul 17 09:11:41 2008 @@ -49,7 +49,7 @@ - :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the function as a login page")) -(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p external-format) +(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p) (:documentation "Registers a page into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page @@ -57,23 +57,21 @@ - LOCATION The url location where the page will be registered (relative to the lisplet base path) keys: - :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location -- :LOGIN-PAGE-P Marks the page as a login page -- :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) +- :LOGIN-PAGE-P Marks the page as a login page")) -(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type external-format) +(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type) (:documentation "Registers a resource (file or directory) into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page - RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching - LOCATION The url location where the resource will be registered (relative to the lisplet base path) -- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type -- :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) +- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type")) (defgeneric lisplet-dispatch-method (lisplet) (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST - LISPLET the lisplet object")) -(defgeneric lisplet-dispatch-request (lisplet) +(defgeneric lisplet-dispatch-request (lisplet uri) (:documentation "Dispatches the http request. - LISPLET the lisplet object")) @@ -85,7 +83,7 @@ - LOCATION the location that must be protected. - ROLES a string list containing all the roles allowed to acces the given location.")) -(defgeneric lisplet-check-authorization (lisplet &optional request) +(defgeneric lisplet-check-authorization (lisplet) (:documentation "Performs authentication and authorization checking. Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login.")) @@ -98,33 +96,22 @@ (defgeneric build-lisplet-location (lisplet) (:documentation "Constructs a full path prepending the lisplet base path to the given location")) -(setf *http-error-handler* - ;;overrides the default hunchentoot error handling - #'(lambda (error-code) - (let* ((error-handlers (if (current-lisplet) - (lisplet-error-handlers (current-lisplet)) - (make-hash-table))) - (handler (gethash error-code error-handlers))) - (if handler - (funcall handler) - (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) - :error-code error-code))) - (with-output-to-string (*standard-output*) (page-render error-page))))))) - (defclass lisplet (i18n-aware) ((base-path :initarg :base-path :reader lisplet-base-path :documentation "common base path all resources registered into this lisplet") + (server-address :initarg :server-address + :accessor lisplet-server-address + :documentation "Server address used on redirections") (welcome-page :initarg :welcome-page :accessor lisplet-welcome-page :documentation "url location for the welcome page") (login-page :initarg :login-page :accessor lisplet-login-page :documentation "url location for the welcome page") - (external-format :initarg :external-format - :accessor lisplet-external-format - :documentation "The default charset external format for resources provided by this lisplet.") + (log-manager :initarg :log-manager + :accessor lisplet-log-manager + :documentation "Log meanager used to log lisplet application messages. When nil the server one is used.") (realm :initarg :realm :reader lisplet-realm :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") @@ -140,9 +127,10 @@ (redirect-protected-resources-p :initarg :redirect-protected-resources-p :accessor lisplet-redirect-protected-resources-p :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) - (:default-initargs :welcome-page nil + (:default-initargs :server-address *claw-default-server-address* + :welcome-page nil :login-page nil - :external-format nil + :log-manager nil :realm "claw" :redirect-protected-resources-p nil) (:documentation "A lisplet is a container for resources provided trhough the clawserver. @@ -154,10 +142,7 @@ (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location (cons location #'(lambda () - (progn - (setf (current-realm *request*) (lisplet-realm lisplet) - (current-lisplet) lisplet) - (lisplet-dispatch-method lisplet)))) + (lisplet-dispatch-method lisplet))) dispatchers))))) (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) @@ -168,7 +153,7 @@ (defmethod build-lisplet-location ((lisplet lisplet)) "Constructs a full path prepending the lisplet base path to the given location" - (format nil "~a~a" (clawserver-base-path (current-server)) (lisplet-base-path lisplet))) + (format nil "~a~a" (clawserver-base-path *clawserver*) (lisplet-base-path lisplet))) (defmethod lisplet-authentication-type ((lisplet lisplet)) (if (lisplet-login-page lisplet) @@ -184,54 +169,52 @@ (when login-page-p (setf (lisplet-login-page lisplet) location)))) -(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p external-format) - (let ((charset-external-format (or external-format (lisplet-external-format lisplet)))) - (lisplet-register-function-location lisplet - #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location :external-format charset-external-format)))) - location - :welcome-page-p welcome-page-p - :login-page-p login-page-p))) - -(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type external-format) - (let ((pages (lisplet-pages lisplet)) - (charset-external-format (or external-format (lisplet-external-format lisplet)))) +(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p) + (lisplet-register-function-location lisplet + #'(lambda () (with-output-to-string (*standard-output*) + (page-render (make-instance page-class)))) + location + :welcome-page-p welcome-page-p + :login-page-p login-page-p)) + +(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location (if (directory-pathname-p resource-path) #'(lambda () (let ((resource-full-path (merge-pathnames - (uri-to-pathname (subseq (script-name) - (+ (length (clawserver-base-path (current-server))) + (uri-to-pathname (subseq (claw-script-name) + (+ (length (clawserver-base-path *clawserver*)) (length (lisplet-base-path lisplet)) (length location) 1))) resource-path))) - (unless (or (null charset-external-format) - (eq (flexi-streams:external-format-name (reply-external-format)) - (flexi-streams:external-format-name charset-external-format))) - (setf (reply-external-format) charset-external-format)) - (handle-static-file resource-full-path content-type))) - #'(lambda () (handle-static-file resource-path content-type)))) + (claw-handle-static-file resource-full-path content-type))) + #'(lambda () (claw-handle-static-file resource-path content-type)))) pages))))) -(defmethod lisplet-dispatch-request ((lisplet lisplet)) + +(defmethod lisplet-dispatch-request ((lisplet lisplet) uri) (let ((dispatchers (lisplet-pages lisplet)) - (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) + (rel-script-name (subseq uri (1+ (length (build-lisplet-location lisplet)))))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) - (let ((base-path (build-lisplet-location lisplet)) - (uri (script-name)) - (welcome-page (lisplet-welcome-page lisplet))) + (let* ((*claw-current-realm* (lisplet-realm lisplet)) + (*claw-current-lisplet* lisplet) + (*claw-session* (default-session-manager-session-verify *session-manager*)) + (base-path (build-lisplet-location lisplet)) + (uri (claw-script-name)) + (welcome-page (lisplet-welcome-page lisplet))) (lisplet-check-authorization lisplet) - (when (= (return-code) +http-ok+) - (if (and welcome-page (string= uri base-path)) - (page-render (lisplet-welcome-page lisplet)) - (lisplet-dispatch-request lisplet))))) + (when (= (claw-return-code) +http-ok+) + (if (and welcome-page (or (string= uri base-path) (string= uri (concatenate 'string base-path "/")))) + (funcall (cdr (assoc welcome-page (lisplet-pages lisplet)))) + (lisplet-dispatch-request lisplet uri))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) (let ((protected-resources (lisplet-protected-resources lisplet))) @@ -240,29 +223,31 @@ (cons location roles) protected-resources))))) -(defun redirect-to-https (server request &optional uri) +(defun redirect-to-https (&optional uri) "Redirects a request sent through http using https" - (let ((path (or uri (request-uri request))) - (port (server-port request)) - (protocol :http)) - #-:hunchentoot-no-ssl (when (or (clawserver-mod-lisp-p server) - (clawserver-ssl-certificate-file server)) - (setf protocol :https - port (if (clawserver-mod-lisp-p server) - *apache-https-port* - (clawserver-sslport server)))) - (redirect path :port port :protocol protocol))) - -(defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*)) - (let* ((uri (script-name request)) + (let* ((connector (clawserver-connector *clawserver*)) + (path (or uri (claw-request-uri))) + (port (connector-port connector)) + (sslport (connector-sslport connector))) + (if (connector-behind-apache-p connector) + (claw-redirect path :port *apache-https-port* :protocol :https) + (claw-redirect path :port (or sslport port) :protocol (if sslport + :https + :http))))) + +(defmethod lisplet-check-authorization ((lisplet lisplet)) + (let* ((connector (clawserver-connector *clawserver*)) + (uri (claw-script-name)) (base-path (build-lisplet-location lisplet)) (protected-resources (lisplet-protected-resources lisplet)) (princp (current-principal)) (login-config (current-config)) (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet))) - (server (current-server request)) + (sslport (connector-sslport connector)) (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) - (setf (return-code) +http-ok+) + (when (or (string= uri base-path) (string= uri (concatenate 'string base-path "/"))) + (setf uri (format nil "~a/~a" base-path uri))) + (setf (claw-return-code) +http-ok+) (when login-config (when (and auth-basicp (null princp)) (configuration-login login-config)) @@ -273,15 +258,15 @@ do (when (or (starts-with-subseq match uri) (string= login-page-url uri)) (cond ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) - (setf (return-code) +http-forbidden+) + (setf (claw-return-code) +http-forbidden+) (throw 'handler-done nil)) ((and (null princp) auth-basicp) - (setf (return-code) +http-authorization-required+ - (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) + (setf (claw-return-code) +http-authorization-required+ + (claw-header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" *claw-current-realm*)) (throw 'handler-done nil)) ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) - (redirect-to-https server request login-page-url) + (redirect-to-https login-page-url) (throw 'handler-done nil)) - #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) - (redirect-to-https server request) + ((and sslport (not (= (claw-server-port) sslport))) + (redirect-to-https) (throw 'handler-done nil)))))))) Added: trunk/main/claw-core/src/logger.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/logger.lisp Thu Jul 17 09:11:41 2008 @@ -0,0 +1,43 @@ +;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/logger.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw) + +(defgeneric logger-log (logger level control-string &rest args) + (:documentation "Logs a message. +log-level should be one of the keywords :EMERG, :ALERT, :CRIT, :ERROR, :WARNING, :NOTICE, :INFO, or :DEBUG which correspond to the various Apache log levels. +Form the rest this method behaves like the FORMAT function.")) + +(defclass logger (claw-service) + () + (:documentation "The logger is a class that logs messages sent via LOGGER-LOG method. +LOGGER is an interface, so you cannot directly use it. +A LOGGER subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides. +To properly work a CLAWSERVER instance must be provided with a LOGGER implementation. +A LOG implementation to properly work, must implement all the LOGGER-LOG method.")) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Thu Jul 17 09:11:41 2008 @@ -29,29 +29,349 @@ (in-package :claw) -(setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) +(defconstant +buffer-length+ 8192 + "Length of buffers used for internal purposes.") -(defvar *apache-http-port* 80 - "Default apache http port when claw is running in mod_lisp mode") -(defvar *apache-https-port* 443 - "Default apache https port when claw is running in mod_lisp mode") - -(defvar *claw-libraries-resources* () - "Global variable to hold exposed web resources") - -(defun strings-to-jsarray (strings) - "Transforms a list of strings into a javascript array." - (let ((st-size (length strings)) - (items "")) - (cond ((= st-size 0) "[]") - ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) - (t (format nil (format nil "[~a~a]" - (prin1-to-string (first strings)) - (progn - (dolist (str (rest strings)) - (setf items (format nil "~a,~a" - items (prin1-to-string str)))) - items))))))) +(eval-when (:compile-toplevel :execute :load-toplevel) + + (defvar *clawserver* nil + "The current serving CLAWSERVER instance") + + (defvar *session-manager* nil + "The SESSION-MANAGER used by the *CLAWSERVER*") + + (defvar *apache-http-port* 80 + "Default apache http port when claw is running in mod_lisp mode, or behind mod_proxy") + (defvar *apache-https-port* 443 + "Default apache https port when claw is running in mod_lisp mode, or behind mod_proxy") + + (defvar *claw-default-server-address* nil + "Default host address given as default server address for lisplets used on redirections") + + (defvar *claw-libraries-resources* () + "Global variable to hold exposed web resources") + + (defvar *claw-current-page* nil + "The CLAW page currently rendering") + + (defvar *claw-current-realm* "CLAW" + "The realm under which the request has been sent. +A realm is used to group resources under a common 'place', and is used for registered web applications +to have different or common sessions for a give user.") + + (defvar *claw-current-lisplet* nil + "The liplet currently serving") + + (defvar *claw-session* nil + "The session bound to the current request") + + (defvar *http-reason-phrase-map* (make-hash-table) + "Used to map numerical return codes to reason phrases.") + + (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 +") + + (defvar *day-names* + '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") + "The three-character names of the seven days of the week - needed +for cookie date format.") + + (defvar *month-names* + '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + "The three-character names of the twelve months - needed for cookie +date format.") + + (defmacro def-http-return-code (name value reason-phrase) + "Shortcut to define constants for return codes. NAME is a +Lisp symbol, VALUE is the numerical value of the return code, and +REASON-PHRASE is the phrase \(a string) to be shown in the +server's status line." + `(eval-when (:compile-toplevel :execute :load-toplevel) + (defconstant ,name ,value ,(format nil "HTTP return code \(~A) for '~A'." + value reason-phrase)) + (setf (gethash ,value *http-reason-phrase-map*) ,reason-phrase))) + + (defvar *http-reason-phrase-map* (make-hash-table) + "Used to map numerical return codes to reason phrases.")) + +(def-http-return-code +http-continue+ 100 "Continue") +(def-http-return-code +http-switching-protocols+ 101 "Switching Protocols") +(def-http-return-code +http-ok+ 200 "OK") +(def-http-return-code +http-created+ 201 "Created") +(def-http-return-code +http-accepted+ 202 "Accepted") +(def-http-return-code +http-non-authoritative-information+ 203 "Non-Authoritative Information") +(def-http-return-code +http-no-content+ 204 "No Content") +(def-http-return-code +http-reset-content+ 205 "Reset Content") +(def-http-return-code +http-partial-content+ 206 "Partial Content") +(def-http-return-code +http-multi-status+ 207 "Multi-Status") +(def-http-return-code +http-multiple-choices+ 300 "Multiple Choices") +(def-http-return-code +http-moved-permanently+ 301 "Moved Permanently") +(def-http-return-code +http-moved-temporarily+ 302 "Moved Temporarily") +(def-http-return-code +http-see-other+ 303 "See Other") +(def-http-return-code +http-not-modified+ 304 "Not Modified") +(def-http-return-code +http-use-proxy+ 305 "Use Proxy") +(def-http-return-code +http-temporary-redirect+ 307 "Temporary Redirect") +(def-http-return-code +http-bad-request+ 400 "Bad Request") +(def-http-return-code +http-authorization-required+ 401 "Authorization Required") +(def-http-return-code +http-payment-required+ 402 "Payment Required") +(def-http-return-code +http-forbidden+ 403 "Forbidden") +(def-http-return-code +http-not-found+ 404 "Not Found") +(def-http-return-code +http-method-not-allowed+ 405 "Method Not Allowed") +(def-http-return-code +http-not-acceptable+ 406 "Not Acceptable") +(def-http-return-code +http-proxy-authentication-required+ 407 "Proxy Authentication Required") +(def-http-return-code +http-request-time-out+ 408 "Request Time-out") +(def-http-return-code +http-conflict+ 409 "Conflict") +(def-http-return-code +http-gone+ 410 "Gone") +(def-http-return-code +http-length-required+ 411 "Length Required") +(def-http-return-code +http-precondition-failed+ 412 "Precondition Failed") +(def-http-return-code +http-request-entity-too-large+ 413 "Request Entity Too Large") +(def-http-return-code +http-request-uri-too-large+ 414 "Request-URI Too Large") +(def-http-return-code +http-unsupported-media-type+ 415 "Unsupported Media Type") +(def-http-return-code +http-requested-range-not-satisfiable+ 416 "Requested range not satisfiable") +(def-http-return-code +http-expectation-failed+ 417 "Expectation Failed") +(def-http-return-code +http-failed-dependency+ 424 "Failed Dependency") +(def-http-return-code +http-internal-server-error+ 500 "Internal Server Error") +(def-http-return-code +http-not-implemented+ 501 "Not Implemented") +(def-http-return-code +http-bad-gateway+ 502 "Bad Gateway") +(def-http-return-code +http-service-unavailable+ 503 "Service Unavailable") +(def-http-return-code +http-gateway-time-out+ 504 "Gateway Time-out") +(def-http-return-code +http-version-not-supported+ 505 "Version not supported") + +(defvar *approved-return-codes* '(#.+http-ok+ #.+http-no-content+ + #.+http-multi-status+ + #.+http-not-modified+) + "A list of return codes the server should not treat as an error - +see *HANDLE-HTTP-ERRORS-P*.") + +;;-------------------------------------------------------------------------------------------- +;;---------------------------------------- WRAPPERS ----------------------------------------- +;;-------------------------------------------------------------------------------------------- + +(defun claw-request-method () + "Wrapper function around CONNECTOR-REQUEST-METHOD. +Returns :GET or POST. respectively." + (clawserver-request-method *clawserver*)) + +(defun claw-script-name () + "Wrapper function around CONNECTOR-SCRIPT-NAME. +Returns the file name \(or path) component of the URI for request \(before the question mark)," + (clawserver-script-name *clawserver*)) + +(defun claw-request-uri () + "Wrapper function around CONNECTOR-REQUEST-URI. +Returns the URI for request." + (clawserver-request-uri *clawserver*)) + +(defun claw-query-string () + "Wrapper function around CONNECTOR-QUERY-STRING. +Returns the query component of the URI for request \(the part behing the question mark)" + (clawserver-query-string *clawserver*)) + +(defun claw-get-parameter (name) + "Wrapper function around CONNECTOR-GET-PARAMETER. +Returns the value of the GET parameter as a string \(or nil), identified by NAME \(a string too)" + (clawserver-get-parameter *clawserver* name)) + +(defun claw-get-parameters () + "Wrapper function around CONNECTOR-GET-PARAMETERS. +Returns an alist of all GET parameters." + (clawserver-get-parameters *clawserver*)) + +(defun claw-post-parameter (name) + "Wrapper function around CONNECTOR-POST-PARAMETER. +Returns the value of the POST parameter as a string \(or nil), identified by NAME \(a string too)" + (clawserver-post-parameter *clawserver* name)) + +(defun claw-post-parameters () + "Wrapper function around CONNECTOR-POST-PARAMETERS. +Returns an alist of all POST parameters." + (clawserver-post-parameters *clawserver*)) + +(defun claw-parameter (name) + "Wrapper function around CONNECTOR-PARAMETER. +Returns the value of the GET or POST parameter as a string \(or nil), identified by NAME \(a string too)" + (clawserver-parameter *clawserver* name)) + +(defun claw-header-in (symbol) + "Wrapper function around CONNECTOR-HEADER-IN. +Returns the incoming header named by the keyword SYMBOL, as a string." + (clawserver-header-in *clawserver* symbol)) + +(defun claw-headers-in () + "Wrapper function around CONNECTOR-HEADERS-IN." + (clawserver-headers-in *clawserver*)) + +(defun claw-authorization () + "Wrapper function around CONNECTOR-AUTHORIZATION. +Returns as two values the user and password \(if any) from the incoming Authorization http header." + (clawserver-authorization *clawserver*)) + +(defun claw-remote-addr () + "Wrapper function around CONNECTOR-REMOTE-ADDR. +Returns the IP address \(as a string) of the client which sent the request." + (clawserver-remote-addr *clawserver*)) + +(defun claw-remote-port () + "Wrapper function around CONNECTOR-REMOTE-PORT. +Returns the IP port \(as a number) of the client which sent the request." + (clawserver-remote-port *clawserver*)) + +(defun claw-real-remote-addr () + "Wrapper function around CONNECTOR-REAL-REMOTE-ADDR see it for more info." + (clawserver-real-remote-addr *clawserver*)) + +(defun claw-server-addr () + "Wrapper function around CONNECTOR-SERVER-ADDR. +Returns the IP address \(as a string) where the request came in." + (clawserver-server-addr *clawserver*)) + +(defun claw-server-port () + "Wrapper function around CONNECTOR-SERVER-PORT. +Returns the IP port \(as a number) where the request came in." + (clawserver-server-addr *clawserver*)) + +(defun claw-user-agent () + "Wrapper function around CONNECTOR-USER-AGENT. +Returns the value of the incoming User-Agent http header." + (clawserver-user-agent *clawserver*)) + +(defun claw-referer () + "Wrapper function around CONNECTOR-REFERER see it for more info." + (clawserver-referer *clawserver*)) + +(defun claw-cookie-in (name) + "Wrapper function around CONNECTOR-COOKIE-IN. +Returns the value \(a CLAW-COOKIE instance or nil) of the incoming cookie named by the string NAME." + (clawserver-cookie-in *clawserver* name)) + +(defun claw-cookies-in () + "Wrapper function around CONNECTOR-COOKIES-IN. +Returns the value \(as CLAW-COOKIE instance) of the incoming cookies." + (clawserver-cookies-in *clawserver*)) + +(defun claw-aux-request-value (symbol) + "Wrapper function around CONNECTOR-AUX-REQUEST-VALUE. +Returns values VALUE, PRESENTP. +This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request. +present-p is true if such data was found, otherwise NIL" + (clawserver-aux-request-value *clawserver* symbol)) + +(defun (setf claw-aux-request-value) (value symbol) + "Wrapper function around (SETF CONNECTOR-AUX-REQUEST-VALUE). +This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request." + (setf (clawserver-aux-request-value *clawserver* symbol) value)) + +(defun claw-delete-aux-request-value (symbol) + "Wrapper function around CONNECTOR-DELETE-AUX-REQUEST-VALUE. +Completely removes any data associated with the symbol symbol from the REQUEST object request." + (clawserver-delete-aux-request-value *clawserver* symbol)) + +(defun claw-content-type () + "Returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")." + (clawserver-content-type *clawserver*)) + +(defun (setf claw-content-type) (value) + "Sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\")." + (setf (clawserver-content-type *clawserver*) value)) + +(defun claw-content-length () + "Returns the outgoing Content-Length http header" + (clawserver-content-length *clawserver*)) + +(defun (setf claw-content-length) (value) + "Sets the outgoing Content-Length http header" + (setf (clawserver-content-length *clawserver*) value)) + +;;--------------------------- + +(defun claw-header-out (symbol) + "Wrapper function around CONNECTOR-HEADER-OUT. +Returns the outgoing http header named by the keyword name if there is one, otherwise NIL." + (clawserver-header-out *clawserver* symbol)) + +(defun (setf claw-header-out) (value symbol) + "Wrapper function around \(SETF CONNECTOR-HEADER-OUT). +SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol). +If no header named name exists it is created." + (setf (clawserver-header-out *clawserver* symbol) value)) + +(defun claw-headers-out () + "Wrapper function around CONNECTOR-HEADERS-OUT. +Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type)." + (clawserver-headers-out *clawserver*)) + +(defun claw-cookie-out (name) + "Wrapper function around CONNECTOR-COOKIE-OUT. +Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name)." + (clawserver-cookie-out *clawserver* name)) + +(defun (setf claw-cookie-out) (cookie-instance name) + "Wrapper function around \(SETF CONNECTOR-COOKIE-OUT). +Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply." + (setf (clawserver-cookie-out *clawserver* name) cookie-instance)) + +(defun claw-cookies-out () + "Wrapper function around CONNECTOR-COOKIES-OUT. +Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name)." + (clawserver-cookies-out *clawserver*)) + +(defun claw-return-code () + "Wrapper function around CONNECTOR-COOKIES-OUT. +Returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)" + (clawserver-return-code *clawserver*)) + +(defun (setf claw-return-code) (value) + "Wrapper function around \(SETF CONNECTOR-COOKIES-OUT). +Sets the http return code of the reply." + (setf (clawserver-return-code *clawserver*) value)) + +(defun claw-reply-external-format-encoding () + "Wrapper function around CONNECTOR-REPLY-EXTERNAL-FORMAT-ENCODING. +Returns the symbol of the reply charset encoding \(Such as UTF-8)." + (clawserver-reply-external-format-encoding *clawserver*)) + +(defun (setf claw-reply-external-format-encoding) (value) + "Wrapper function around (SETF CONNECTOR-REPLY-EXTERNAL-FORMAT-ENCODING). +Sets the symbol of the reply charset encoding \(Such as UTF-8)." + (setf (clawserver-reply-external-format-encoding *clawserver*) value)) + +(defun claw-writer () + "Wrapper function around CONNECTOR-WRITER. +Returns the output stream writer to generate replies. It's default to *standard-output*" + (clawserver-writer *clawserver*)) + +(defun claw-redirect (target &key host port protocol add-session-id code) + "Wrapper function around CONNECTOR-REDIRECT. +Sends back appropriate headers to redirect the client to target \(a string)." + (clawserver-redirect *clawserver* target + :host (or host (lisplet-server-address *claw-current-lisplet*)) + :port port + :protocol protocol + :add-session-id add-session-id :code code)) + +(defun claw-session-value (symbol) + "Wrapper function around SESSION-MANAGER-SESSION-VALUE. +Returns the value identified by SYMBOL, bounded to the user session." + (session-manager-session-value (clawserver-session-manager *clawserver*) symbol)) + +(defun (setf claw-session-value) (value symbol) + "Wrapper function around (SETF SESSION-MANAGER-SESSION-VALUE). +Sets or modifies the value identified by SYMBOL, bounded to the user session" + (setf (session-manager-session-value (clawserver-session-manager *clawserver*) symbol) value)) + +(defun claw-delete-session-value (symbol) + "Wrapper function around SESSION-MANAGER-DELETE-SESSION-VALUE. +Deletes the value identified by SYMBOL, bounded to the user session. +This is different from setting the value to null." + (session-manager-delete-session-value (clawserver-session-manager *clawserver*) symbol)) +;;-------------------------------------------------------------------------------------------- +;;---------------------------------------- WRAPPERS --------------------------------------END +;;-------------------------------------------------------------------------------------------- + + +(defun duplicate-back-slashes (string) + (regex-replace-all "\\" string "\\\\\\\\")) (defun sort-by-location (location-list) "Sorts a list of location items by their first element (the location itself)." @@ -75,67 +395,41 @@ (let ((result (remove-by-location (first location-items) location-list))) (setf result (push location-items result)))) -(defun claw-start-session () +(defun claw-start-session (&key max-time domain) "Starts a session bound to the current lisplet base path" - (start-session (format nil "~a/" (build-lisplet-location (current-lisplet))))) + (session-manager-start-session (clawserver-session-manager *clawserver*) + :path (format nil "~a/" (build-lisplet-location *claw-current-lisplet*)) + :max-time max-time + :domain domain)) + +(defun claw-remove-session () + "Disposes user session if present" + (session-manager-remove-session (clawserver-session-manager *clawserver*))) - -(defun current-page (&optional (request *request*)) - "Returns the page that is rendering" - (aux-request-value 'page request)) - -(defun (setf current-page) (page &optional (request *request*)) - "Setf the page that is to be rendered" - (setf (aux-request-value 'page request) page)) - -(defun current-realm (&optional (request *request*)) - "Returns the realm under which the request has been sent" - (aux-request-value 'realm request)) - -(defun (setf current-realm) (realm &optional (request *request*)) - "Setf the realm under which the request has been sent" - (setf (aux-request-value 'realm request) realm)) - -(defun current-lisplet (&optional (request *request*)) - "Returns the lisplet instance from which the request comes from" - (aux-request-value 'lisplet request)) - -(defun (setf current-lisplet) (lisplet &optional (request *request*)) - "Sets the lisplet instance from which the request comes from" - (setf (aux-request-value 'lisplet request) lisplet)) - -(defun current-server (&optional (request *request*)) - "Returns the clawserver instance from which the request comes from" - (aux-request-value 'clawserver request)) - -(defun (setf current-server) (server &optional (request *request*)) - "Sets the clawserver instance from which the request comes from" - (setf (aux-request-value 'clawserver request) server)) - -(defun current-principal (&optional (session *session*)) +(defun current-principal () "Returns the principal(user) that logged into the application" - (when session - (session-value 'principal session))) + (when *claw-session* + (claw-session-value 'principal))) -(defun (setf current-principal) (principal &optional (session *session*)) +(defun (setf current-principal) (principal) "Setf the principal(user) that logged into the application" - (unless session - (setf session (claw-start-session))) - (setf (session-value 'principal session) principal)) + (unless *claw-session* + (setf *claw-session* (claw-start-session))) + (setf (claw-session-value 'principal) principal)) -(defun user-in-role-p (roles &optional (session *session*)) +(defun user-in-role-p (roles) "Detects if current principal belongs to any of the expressed roles" - (let ((principal (current-principal session))) + (let ((principal (current-principal))) (when principal (loop for el in (principal-roles principal) thereis (member el roles))))) -(defun current-config (&optional (request *request*)) +(defun current-config () "Returns the current configuration object for the realm of the request" - (gethash (current-realm request) (clawserver-login-config (current-server request)))) + (gethash *claw-current-realm* (clawserver-login-config *clawserver*))) -(defun login (&optional (request *request*)) +(defun login () "Perfoms a login action using the configuration object given for the request realm (see CURRENT-REALM)" - (configuration-login (current-config request))) + (configuration-login (current-config))) (defun flatten (tree &optional result-list) "Traverses the tree in order, collecting even non-null leaves into a list." @@ -146,9 +440,9 @@ (t (push element result)))) (nreverse result))) -(defun msie-p (&optional (request *request*)) +(defun msie-p () "Returns nil when the calling browser is not the evil of MSIE" - (let* ((header-props (headers-in request)) + (let* ((header-props (claw-headers-in)) (user-agent (find :USER-AGENT header-props :test #'(lambda (member value) (eq member (car value)))))) (when user-agent (all-matches "MSIE" (string-upcase (cdr user-agent)))))) @@ -158,33 +452,29 @@ 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)) + (let ((current-component (gensym)) (result (gensym)) (key-val key) (locale-val (gensym)) (default-val default)) `#'(lambda () - (let ((,current-lisplet (current-lisplet)) - (,current-page (current-page)) - (,current-component (current-component)) + (let ((,current-component (current-component)) (,locale-val ,locale) (,result)) (unless ,locale-val (setf ,locale-val (user-locale))) - (when ,current-lisplet - (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) - (when (and (null ,result) ,current-page) - (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when *claw-current-lisplet* + (setf ,result (message-dispatch *claw-current-lisplet* ,key-val ,locale-val))) + (when (and (null ,result) *claw-current-page*) + (setf ,result (message-dispatch *claw-current-page* ,key-val ,locale-val))) (when (and (null ,result) ,current-component) (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) (when (null ,result) (setf ,locale-val "") - (when ,current-lisplet - (setf ,result (message-dispatch ,current-lisplet ,key-val ,locale-val))) - (when (and (null ,result) ,current-page) - (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) + (when *claw-current-lisplet* + (setf ,result (message-dispatch *claw-current-lisplet* ,key-val ,locale-val))) + (when (and (null ,result) *claw-current-page*) + (setf ,result (message-dispatch *claw-current-page* ,key-val ,locale-val))) (when (and (null ,result) ,current-component) (setf ,result (message-dispatch ,current-component ,key-val ,locale-val)))) (if ,result @@ -195,45 +485,90 @@ "This function calls the lambda function returned by the WITH-MESSAGE macro." (funcall (with-message key default locale))) -(defun user-locale (&optional (request *request*) (session *session*)) +(defun user-locale () "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 - (setf locale (first (loop for str in (all-matches-as-strings - "[A-Z|a-z|_]+" - (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) - collect (if (> (length str) 2) - (string-upcase str :start 2) - str))))) - locale)) + (let ((locale (when *claw-session* (claw-session-value 'locale)))) + (or locale + (first (loop for str in (all-matches-as-strings + "[A-Z|a-z|_]+" + (regex-replace-all "-" (regex-replace-all ";.*" (claw-header-in 'ACCEPT-LANGUAGE) "") "_")) + collect (if (> (length str) 2) + (string-upcase str :start 2) + str)))))) -(defun (setf user-locale) (locale &optional (session *session*)) +(defun (setf user-locale) (locale) "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 (claw-start-session))) - (setf (session-value 'locale session) locale)) + (unless *claw-session* + (setf *claw-session* (claw-start-session))) + (setf (claw-session-value 'locale) locale)) -(defun validation-errors (&optional (request *request*)) +(defun validation-errors () "Resurns possible validation errors occurred during form rewinding" - (aux-request-value :validation-errors request)) + (claw-aux-request-value :validation-errors)) -(defun (setf validation-errors) (value &optional (request *request*)) +(defun (setf validation-errors) (value) "Sets possible validation errors occurred during form rewinding" - (setf (aux-request-value :validation-errors request) value)) + (setf (claw-aux-request-value :validation-errors) value)) -(defun validation-compliances (&optional (request *request*)) +(defun validation-compliances () "Resurns the list of components that pass validation during form rewinding" - (aux-request-value :validation-compliances request)) + (claw-aux-request-value :validation-compliances)) -(defun (setf validation-compliances) (value &optional (request *request*)) +(defun (setf validation-compliances) (value) "Sets the list of components that pass validation during form rewinding" - (setf (aux-request-value :validation-compliances request) value)) + (setf (claw-aux-request-value :validation-compliances) value)) -(defun add-validation-compliance (id &optional (request *request*)) +(defun add-validation-compliance (id) "Adds a component id to the list of components that pass validation during form rewinding" - (setf (validation-compliances request) (nconc (validation-compliances request) (list id)))) + (setf (validation-compliances) (nconc (validation-compliances) (list id)))) + +(defun claw-handle-static-file (path &optional content-type (server *clawserver*)) + "A function which acts like a Hunchentoot handler for the file +denoted by PATH. Send a content type header corresponding to +CONTENT-TYPE or \(if that is NIL) tries to determine the content +type via the file's suffix." + (unless (and (fad:file-exists-p path) + (not (fad:directory-exists-p path))) + ;; does not exist + (setf (claw-return-code) 404) + (throw 'handler-done nil)) + (let ((time (or (file-write-date path) (get-universal-time)))) + (setf (claw-content-type) (or content-type + (mime-type path) + "application/octet-stream")) + ;(handle-if-modified-since time) + (with-open-file (file path + :direction :input + :element-type 'octet + :if-does-not-exist nil) + (setf (claw-header-out "Last-Modified") (rfc-1123-date time) + (claw-content-length) (file-length file)) + (let ((out (clawserver-writer server))) + (loop with buf = (make-array +buffer-length+ :element-type 'octet) + for pos = (read-sequence buf file) + until (zerop pos) + do (write-sequence buf out :end pos) + (finish-output out)))))) + +(defun claw-write-response-string (content &key (content-type "text/html") last-modified) + (when content + (when last-modified + (setf (claw-header-out "Last-Modified") (rfc-1123-date last-modified))) + (setf (claw-content-length) (length content) + (claw-content-type) content-type) + (let ((out (clawserver-writer *clawserver*))) + (write-sequence content out) + (finish-output out)) + content)) + +(defun md5-hex (string) + "Calculates the md5 sum of the string STRING and returns it as a hex string." + (with-output-to-string (s) + (loop for code across (md5:md5sum-sequence string) + do (format s "~2,'0x" code)))) + + (defclass metacomponent (standard-class) () @@ -272,10 +607,6 @@ 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)) @@ -291,7 +622,7 @@ (format nil "~{:~a ~}" (eval reserved-parameters)) "NONE")))) -(defun register-library-resource (location resource-path &optional content-type external-format) +(defun register-library-resource (location resource-path &optional content-type) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (setf *claw-libraries-resources* (sort-by-location (pushnew-location @@ -299,21 +630,12 @@ (if (directory-pathname-p resource-path) #'(lambda () (let ((resource-full-path (merge-pathnames - (uri-to-pathname (subseq (script-name) - (+ (length (clawserver-base-path (current-server))) + (uri-to-pathname (subseq (claw-script-name) + (+ (length (clawserver-base-path *clawserver*)) (length location)))) resource-path))) - (unless (or (null external-format) - (eq (flexi-streams:external-format-name (reply-external-format)) - (flexi-streams:external-format-name external-format))) - (setf (reply-external-format) external-format)) - (handle-static-file resource-full-path content-type))) - #'(lambda () (progn - (unless (or (null external-format) - (eq (flexi-streams:external-format-name (reply-external-format)) - (flexi-streams:external-format-name external-format))) - (setf (reply-external-format) external-format)) - (handle-static-file resource-path content-type))))) + (claw-handle-static-file resource-full-path content-type))) + #'(lambda () (claw-handle-static-file resource-path content-type)))) *claw-libraries-resources*)))) (defun uri-to-pathname (uri &optional (relative t)) @@ -330,3 +652,29 @@ (cons :absolute directory-list)) :name (first file-name-and-type) :type (second file-name-and-type)))) + +(defun rfc-1123-date (&optional (time (get-universal-time))) + "Generates a time string according to RFC 1123. Default is current time." + (multiple-value-bind + (second minute hour date month year day-of-week) + (decode-universal-time time 0) + (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT" + (nth day-of-week *day-names*) + date + (nth (1- month) *month-names*) + year + hour + minute + second))) + +(defun log-message (level control-string &rest args) + "Logs a message. +log-level should be one of the keywords :EMERG, :ALERT, :CRIT, :ERROR, :WARNING, :NOTICE, :INFO, or :DEBUG which correspond to the various Apache log levels. +Form the rest this method behaves like the FORMAT function." + (apply #'logger-log (if *claw-current-lisplet* + (or (lisplet-log-manager *claw-current-lisplet*) + (clawserver-log-manager *clawserver*)) + (clawserver-log-manager *clawserver*)) + level + control-string + args)) \ 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 Thu Jul 17 09:11:41 2008 @@ -29,291 +29,434 @@ (in-package :cl-user) -(export 'HUNCHENTOOT::REQUEST-REALM 'HUNCHENTOOT) -(export 'HUNCHENTOOT::SESSION-REALM 'HUNCHENTOOT) (defpackage :claw - (:use :cl :closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) + (:use :cl :closer-mop :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :bordeaux-threads :flexi-streams) (:shadow :flatten) (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") - (:export :*html-4.01-strict* - :*html-4.01-transitional* - :*html-4.01-frameset* - :*xhtml-1.0-strict* - :*xhtml-1.0-transitional* - :*xhtml-1.0-frameset* - :*rewind-parameter* - :*clawserver-base-path* - :*apache-http-port* - :*apache-https-port* - :*empty-tags* - :tag-emptyp - :strings-to-jsarray - :empty-string-p - :build-tagf - :page - :page-external-format - :page-url - :page-lisplet - :page-current-form - :page-req-parameter - :page-script-files - :page-stylesheet-files - :page-class-initscripts - :page-instance-initscripts - :page-current-component - :page-body-init-scripts - :htcomponent - :htcomponent-page - :htcomponent-body - :htcomponent-empty - :htcomponent-client-id - :htcomponent-real-id - :htcomponent-script-files - :htcomponent-stylesheet-files - :htcomponent-class-initscripts - :htcomponent-instance-initscript - :tag - :tag-name - :tag-attributes - :htbody - :htscript - :htlink - :hthead - :htstring - :$> - :$raw> + (:export #:*html-4.01-strict* + #:*html-4.01-transitional* + #:*html-4.01-frameset* + #:*xhtml-1.0-strict* + #:*xhtml-1.0-transitional* + #:*xhtml-1.0-frameset* + #:*rewind-parameter* + #:*clawserver-base-path* + #:*apache-http-port* + #:*apache-https-port* + #:*claw-default-server-address* + #:*empty-tags* + #:*clawserver* + #:*session-manager* + #:*claw-current-page* + #:*claw-current-lisplet* + #:*claw-current-realm* + #:*claw-session* + #:+http-continue+ + #:+http-switching-protocols+ + #:+http-ok+ + #:+http-created+ + #:+http-accepted+ + #:+http-non-authoritative-information+ + #:+http-no-content+ + #:+http-reset-content+ + #:+http-partial-content+ + #:+http-multi-status+ + #:+http-multiple-choices+ + #:+http-moved-permanently+ + #:+http-moved-temporarily+ + #:+http-see-other+ + #:+http-not-modified+ + #:+http-use-proxy+ + #:+http-temporary-redirect+ + #:+http-bad-request+ + #:+http-authorization-required+ + #:+http-payment-required+ + #:+http-forbidden+ + #:+http-not-found+ + #:+http-method-not-allowed+ + #:+http-not-acceptable+ + #:+http-proxy-authentication-required+ + #:+http-request-time-out+ + #:+http-conflict+ + #:+http-gone+ + #:+http-length-required+ + #:+http-precondition-failed+ + #:+http-request-entity-too-large+ + #:+http-request-uri-too-large+ + #:+http-unsupported-media-type+ + #:+http-requested-range-not-satisfiable+ + #:+http-expectation-failed+ + #:+http-failed-dependency+ + #:+http-internal-server-error+ + #:+http-not-implemented+ + #:+http-bad-gateway+ + #:+http-service-unavailable+ + #:+http-gateway-time-out+ + #:+http-version-not-supported+ + + #:claw-request-method + #:claw-script-name + #:claw-request-uri + #:claw-query-string + #:claw-get-parameter + #:claw-get-parameters + #:claw-post-parameter + #:claw-post-parameters + #:claw-parameter + #:claw-header-in + #:claw-headers-in + #:claw-authorization + #:claw-remote-addr + #:claw-remote-port + #:claw-real-remote-addr + #:claw-server-addr + #:claw-server-port + #:claw-user-agent + #:claw-referer + #:claw-cookie-in + #:claw-cookies-in + #:claw-aux-request-value + #:claw-delete-aux-request-value + #:claw-content-type + #:claw-header-out + #:claw-headers-out + #:claw-cookie-out + #:claw-cookies-out + #:claw-return-code + #:claw-reply-external-format-encoding + #:claw-writer + #:claw-redirect + #:claw-session-value + #:claw-start-session + #:claw-remove-session + #:claw-delete-session-value + #:log-message + + #:claw-cookie + #:claw-cookie-name + #:claw-cookie-value + #:claw-cookie-expires + #:claw-cookie-path + #:claw-cookie-domain + #:claw-cookie-secure + #:claw-cookie-http-only + + #:connector + #:connector-behind-apache-p + #:connector-host + #:connector-request-method + #:connector-script-name + #:connector-request-uri + #:connector-query-string + #:connector-get-parameter + #:connector-get-parameters + #:connector-post-parameter + #:connector-post-parameters + #:connector-parameter + #:connector-header-in + #:connector-headers-in + #:connector-authorization + #:connector-remote-addr + #:connector-remote-port + #:connector-real-remote-addr + #:connector-server-addr + #:connector-server-port + #:connector-server-protocol + #:connector-user-agent + #:connector-referer + #:connector-cookie-in + #:connector-cookies-in + #:connector-aux-request-value + #:connector-delete-aux-request-value + #:connector-header-out + #:connector-headers-out + #:connector-cookie-out + #:connector-cookies-out + #:connector-return-code + #:connector-content-type + #:connector-reply-external-format-encoding + #:connector-writer + #:connector-redirect + #:connector-content-length + #:connector-port + #:connector-sslport + #:connector-address + + #:logger + #:logger-log + + #:session-manager + #:default-session-manager + + #:error-page + #:render-error-page + + #:mime-type + #:duplicate-back-slashes + #:build-tagf + #:page + #:page-render + #:page-current-form + #:page-req-parameter + #:page-script-files + #:page-stylesheet-files + #:page-class-initscripts + #:page-instance-initscripts + #:page-current-component + #:page-body-init-scripts + #:htcomponent + #:htcomponent-page + #:htcomponent-body + #:htcomponent-empty + #:htcomponent-client-id + #:htcomponent-real-id + #:htcomponent-script-files + #:htcomponent-stylesheet-files + #:htcomponent-class-initscripts + #:htcomponent-instance-initscript + #:tag + #:tag-name + #:tag-attributes + #:htbody + #:htscript + #:htlink + #:hthead + #:htstring + #:$> + #:$raw> ;empty tags definition - :area> - :base> - :basefont> - :br> - :col> - :frame> - :hr> - :img> - :input> - :isindex> - :link> - :meta> - :param> + #:area> + #:base> + #:basefont> + #:br> + #:col> + #:frame> + #:hr> + #:img> + #:input> + #:isindex> + #:link> + #:meta> + #:param> ;standard tags - :a> - :abbr> - :acronym> - :address> - :applet> - :b> - :bdo> - :big> - :blockquote> - :body> - :button> - :caption> - :center> - :cite> - :code> - :colgroup> - :dd> - :del> - :dfn> - :dir> - :div> - :dl> - :dt> - :em> - :fieldset> - :font> - :form> - :frameset> - :h1> - :h2> - :h3> - :h4> - :h5> - :h6> - :head> - :html> - :i> - :iframe> - :ins> - :kbd> - :label> - :legend> - :li> - :map> - :menu> - :noframes> - :noscript> - :object> - :ol> - :optgroup> - :option> - :p> - :pre> - :q> - :s> - :samp> - :script> - :select> - :small> - :span> - :strike> - :strong> - :style> - :sub> - :sup> - :table> - :tbody> - :td> - :textarea> - :tfoot> - :th> - :thead> - :title> - :tr> - :tt> - :u> - :ul> - :var> + #:a> + #:abbr> + #:acronym> + #:address> + #:applet> + #:b> + #:bdo> + #:big> + #:blockquote> + #:body> + #:button> + #:caption> + #:center> + #:cite> + #:code> + #:colgroup> + #:dd> + #:del> + #:dfn> + #:dir> + #:div> + #:dl> + #:dt> + #:em> + #:fieldset> + #:font> + #:form> + #:frameset> + #:h1> + #:h2> + #:h3> + #:h4> + #:h5> + #:h6> + #:head> + #:html> + #:i> + #:iframe> + #:ins> + #:kbd> + #:label> + #:legend> + #:li> + #:map> + #:menu> + #:noframes> + #:noscript> + #:object> + #:ol> + #:optgroup> + #:option> + #:p> + #:pre> + #:q> + #:s> + #:samp> + #:script> + #:select> + #:small> + #:span> + #:strike> + #:strong> + #:style> + #:sub> + #:sup> + #:table> + #:tbody> + #:td> + #:textarea> + #:tfoot> + #:th> + #:thead> + #:title> + #:tr> + #:tt> + #:u> + #:ul> + #:var> ;; class modifiers - :page-content - :generate-id - :metacomponent - :wcomponent - :wcomponent-informal-parameters - :wcomponent-allow-informal-parametersp - :wcomponent-template - :wcomponent-before-rewind - :wcomponent-after-rewind - :wcomponent-before-prerender - :wcomponent-after-prerender - :wcomponent-before-render - :wcomponent-after-render - :cform - :form-method - :cform> - :action - :action-link - :action-link> - :cinput - :cinput> - :ctextarea - :ctextarea> - :cinput-file - :cinput-file> - :cinput-result-as-list-p - :ccheckbox - :ccheckbox> - :cradio - :cradio> - :cselect - :cselect> - :csubmit - :csubmit> - :csubmit-value - :submit-link - :submit-link> - :input-type - :ccheckbox-value - :css-class - :name-attr - :lisplet - :lisplet-external-format - :lisplet-pages - :lisplet-register-page-location - :lisplet-register-function-location - :lisplet-register-resource-location - :lisplet-protect - :lisplet-authentication-type - :claw-start-session - :build-lisplet-location + #:page-content + #:generate-id + #:metacomponent + #:wcomponent + #:wcomponent-informal-parameters + #:wcomponent-allow-informal-parametersp + #:wcomponent-template + #:wcomponent-before-rewind + #:wcomponent-after-rewind + #:wcomponent-before-prerender + #:wcomponent-after-prerender + #:wcomponent-before-render + #:wcomponent-after-render + #:cform + #:form-method + #:cform> + #:action + #:action-link + #:action-link> + #:cinput + #:cinput> + #:ctextarea + #:ctextarea> + #:cinput-file + #:cinput-file> + #:cinput-result-as-list-p + #:ccheckbox + #:ccheckbox> + #:cradio + #:cradio> + #:cselect + #:cselect> + #:csubmit + #:csubmit> + #:csubmit-value + #:submit-link + #:submit-link> + #:input-type + #:ccheckbox-value + #:css-class + #:name-attr + #:lisplet + + #:lisplet-log-manager + #:lisplet-server-addrss + :lisplet-error-handlers + #:lisplet-pages + #:lisplet-register-page-location + #:lisplet-register-function-location + #:lisplet-register-resource-location + #:lisplet-protect + #:lisplet-authentication-type + + #:build-lisplet-location + ;; claw-service + #:claw-service + #:claw-service-name + #:claw-service-start + #:claw-service-stop + #:claw-service-running-p ;; clawserver :clawserver - :clawserver-base-path - :clawserver-register-lisplet - :clawserver-unregister-lisplet - :clawserver-start - :clawserver-stop - :clawserver-port - :clawserver-sslport - :clawserver-address - :clawserver-name - :clawserver-sslname - :clawserver-mod-lisp-p - :clawserver-use-apache-log-p - :clawserver-input-chunking-p - :clawserver-read-timeout - :clawserver-write-timeout - :clawserver-login-config - #+(and :unix (not :win32)) :clawserver-setuid - #+(and :unix (not :win32)) :clawserver-setgid - #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file - #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file - #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password - :add-exception - :component-exceptions - :msie-p - :*id-and-static-id-description* - :describe-component-behaviour - :describe-html-attributes-from-class-slot-initargs - :clawserver-register-configuration - :configuration - :configuration-login - :principal - :current-principal - :principal-name - :principal-roles - :current-lisplet - :current-server - :current-realm - :current-page - :current-component - :user-locale - :page-current-component - :user-in-role-p - :login - :register-library-resource + #:clawserver-dispatch-method + #:clawserver-log-manager + #:clawserver-add-service + #:clawserver-base-path + #:clawserver-register-lisplet + #:clawserver-unregister-lisplet + #:clawserver-start + #:clawserver-stop + #:clawserver-name + #:clawserver-sslname + #:clawserver-mod-lisp-p + #:clawserver-use-apache-log-p + #:clawserver-input-chunking-p + #:clawserver-read-timeout + #:clawserver-write-timeout + #:clawserver-login-config + + #:add-exception + #:component-exceptions + #:msie-p + #:*id-and-static-id-description* + #:describe-component-behaviour + #:describe-html-attributes-from-class-slot-initargs + #:clawserver-register-configuration + #:configuration + #:configuration-login + #:principal + #:current-principal + #:principal-name + #:principal-roles + #:current-component + #:user-locale + #:page-current-component + #:user-in-role-p + #:login + #:register-library-resource ;;i18n - :message-dispatcher - :message-dispatch - :simple-message-dispatcher - :simple-message-dispatcher-add-message - :with-message - :do-message + #:message-dispatcher + #:message-dispatch + #:simple-message-dispatcher + #:simple-message-dispatcher-add-message + #:with-message + #:do-message ;;validation - :translator - :translator-integer - :translator-number - :translator-boolean - :translator-date - :translator-file - :translator-encode - :translator-decode - :translator-string-to-type - :translator-type-to-string - :translator-value-decode - :translator-value-encode - :translator-value-string-to-type - :translator-value-type-to-string - :*simple-translator* - :*boolean-translator* - :*integer-translator* - :*number-translator* - :*date-translator-ymd* - :*date-translator-time* - :*file-translator* - :*locales* - :validate - :validation-errors - :validation-compliances - :add-validation-compliance - :component-validation-errors - :validate-required - :validate-size - :validate-range - :validate-number - :validate-integer - :validate-date-range - :exception-monitor - :exception-monitor>)) \ No newline at end of file + #:translator + #:translator-integer + #:translator-number + #:translator-boolean + #:translator-date + #:translator-file + #:translator-encode + #:translator-decode + #:translator-string-to-type + #:translator-type-to-string + #:translator-value-decode + #:translator-value-encode + #:translator-value-string-to-type + #:translator-value-type-to-string + #:*simple-translator* + #:*boolean-translator* + #:*integer-translator* + #:*number-translator* + #:*date-translator-ymd* + #:*date-translator-time* + #:*file-translator* + #:*locales* + #:validate + #:validation-errors + #:validation-compliances + #:add-validation-compliance + #:component-validation-errors + #:validate-required + #:validate-size + #:validate-range + #:validate-number + #:validate-integer + #:validate-date-range + #:exception-monitor + #:exception-monitor>)) \ No newline at end of file Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Thu Jul 17 09:11:41 2008 @@ -29,6 +29,184 @@ (in-package :claw) +;;------------------------------------------------------------------------------------------ + +(defgeneric render-error-page (clawserver &optional error-code) + (:documentation "Method called when need to display an error page.")) + +(defgeneric clawserver-host (clawserver) + (:documentation " +Returns the value of the incoming Host http header. \(This corresponds to the environment variable HTTP_HOST in CGI scripts.)")) + +(defgeneric clawserver-request-method (clawserver) + (:documentation "Returns the request method as a keyword, i.e. something like :POST. \(This corresponds to the environment variable REQUEST_METHOD in CGI scripts.)")) + +(defgeneric clawserver-request-uri (clawserver) + (:documentation "Returns the URI for request. +Note that this not the full URI but only the part behind the scheme and authority components, so that if the user has typed http://user:password@www.domain.com/xxx/frob.html?foo=bar into his browser, this function will return \"/xxx/frob.html?foo=bar\". \(This corresponds to the environment variable REQUEST_URI in CGI scripts.")) + +(defgeneric clawserver-script-name (connector) + (:documentation "Returns the file name \(or path) component of the URI for request, i.e. the part of the string returned by REQUEST-URI in front of the first question mark \(if any). +\(This corresponds to the environment variable SCRIPT_NAME in CGI scripts.)")) + +(defgeneric clawserver-query-string (clawserver) + (:documentation "Returns the query component of the URI for request, i.e. the part of the string returned by REQUEST-URI behind the first question mark \(if any). +\(This corresponds to the environment variable QUERY_STRING in CGI scripts.) See also CLAWSERVER-GET-PARAMETER and CLAWSERVER-GET-PARAMETERS.")) + +(defgeneric clawserver-get-parameter (clawserver name) + (:documentation "Returns the value of the GET parameter \(as provided via the request URI) named by the string name as a string \(or NIL if there ain't no GET parameter with this name). +Note that only the first value will be returned if the client provided more than one GET parameter with the name name. See also CLAWSERVER-GET-PARAMETERS")) + +(defgeneric clawserver-get-parameters (clawserver) + (:documentation "Returns an alist of all GET parameters \(as provided via the request URI). The car of each element of this list is the parameter's name while the cdr is its value \(as a string). +The elements of this list are in the same order as they were within the request URI. See also CLAWSERVER-GET-PARAMETER.")) + +(defgeneric clawserver-post-parameter (clawserver name) + (:documentation "Returns the value of the POST parameter \(as provided in the request's body) named by the string name. +Note that only the first value will be returned if the client provided more than one POST parameter with the name name. +This value will usually be a string \(or NIL if there ain't no POST parameter with this name). +If, however, the browser sent a file through a multipart/form-data form, the value of this function is a three-element list + +\(path file-name content-type) + +where path is a pathname denoting the place were the uploaded file was stored, file-name \(a string) is the file name sent by the browser, and content-type \(also a string) is the content type sent by the browser. +The file denoted by path will be deleted after the request has been handled - you have to move or copy it somewhere else if you want to keep it.")) + +(defgeneric clawserver-post-parameters (clawserver) + (:documentation "Returns an alist of all POST parameters (as provided via the request's body). The car of each element of this list is the parameter's name while the cdr is its value. The elements of this list are in the same order as they were within the request's body. +See also CLAWSERVER-POST-PARAMETER.")) + +(defgeneric clawserver-parameter (clawserver name) + (:documentation "Returns the value of the GET or POST parameter named by the string name as a string \(or NIL if there ain't no parameter with this name). +If both a GET and a POST parameter with the name name exist, the GET parameter will be returned. See also CLAWSERVER-GET-PARAMETER and CLAWSERVER-POST-PARAMETER.")) + +(defgeneric clawserver-header-in (clawserver name) + (:documentation "Returns the incoming header named by the keyword name as a string \(or NIL if there ain't no header with this name). +Note that this queries the headers sent to Hunchentoot by the client or by mod_lisp. In the latter case this may not only include the incoming http headers but also some headers sent by mod_lisp. +For backwards compatibility, name can also be a string which is matched case-insensitively. See also CLAWSERVER-HEADERS-IN.")) + +(defgeneric clawserver-headers-in (clawserver) + (:documentation "Returns an alist of all incoming headers. +The car of each element of this list is the headers's name \(a Lisp keyword) while the cdr is its value (as a string). +There's no guarantee about the order of this list. See also CLAWSERVER-HEADER-IN and the remark about incoming headers there.")) + +(defgeneric clawserver-authorization (clawserver) + (:documentation "Returns as two values the user and password \(if any) from the incoming Authorization http header. +Returns NIL if there is no such header.")) + +(defgeneric clawserver-remote-addr (clawserver) + (:documentation "Returns the IP address \(as a string) of the client which sent the request. \(This corresponds to the environment variable REMOTE_ADDR in CGI scripts.) See also CLAWSERVER-REAL-REMOTE-ADDR.")) + +(defgeneric clawserver-remote-port (clawserver) + (:documentation "Returns the IP port (as a number) of the client which sent the request.")) + +(defgeneric clawserver-real-remote-addr (clawserver) + (:documentation "Returns the value of the incoming X-Forwarded-For http header as the second value in the form of a list of IP addresses and the first element of this list as the first value if this header exists. +Otherwise returns the value of CLAWSERVER-REMOTE-ADDR as the only value.")) + +(defgeneric clawserver-server-addr (clawserver) + (:documentation "Returns the IP address \(as a string) where the request came in. +\(This corresponds to the environment variable SERVER_ADDR in CGI scripts.)")) + +(defgeneric clawserver-server-port (clawserver) + (:documentation "Returns the IP port \(as a number) where the request came in.")) + +(defgeneric clawserver-server-protocol (clawserver) + (:documentation "Returns the version of the http protocol which is used by the client as a Lisp keyword - this is usually either :HTTP/1.0 or :HTTP/1.1. +\(This corresponds to the environment variable SERVER_PROTOCOL in CGI scripts.")) + +(defgeneric clawserver-user-agent (clawserver) + (:documentation "Returns the value of the incoming User-Agent http header. +\(This corresponds to the environment variable HTTP_USER_AGENT in CGI scripts.)")) + + +(defgeneric clawserver-referer (clawserver) + (:documentation "Returns the value of the incoming Referer \(sic!) http header. \(This corresponds to the environment variable HTTP_REFERER in CGI scripts.)")) + +(defgeneric clawserver-cookie-in (clawserver name) + (:documentation "Returns the value of the incoming cookie named by the string name \(or NIL if there ain't no cookie with this name). +See also CLAWSERVER-COOKIES-IN")) + +(defgeneric clawserver-cookies-in (clawserver) + (:documentation "Returns an alist of all incoming cookies. +The car of each element of this list is the cookie's name while the cdr is the cookie's value. See also CLAWSERVER-COOKIE-IN")) + +(defgeneric clawserver-aux-request-value (clawserver symbol) + (:documentation "This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request. present-p is true if such data was found, otherwise NIL")) + +(defgeneric (setf clawserver-aux-request-value) (value clawserver symbol) + (:documentation "This accessor can be used to associate arbitrary data with the the symbol symbol in the REQUEST object request. present-p is true if such data was found, otherwise NIL")) + +(defgeneric clawserver-delete-aux-request-value (clawserver symbol) + (:documentation "Completely removes any data associated with the symbol symbol from the REQUEST object request. Note that this is different from using AUX-REQUEST-VALUE to set the data to NIL")) + +(defgeneric clawserver-header-out (clawserver name) + (:documentation "Returns the outgoing http header named by the keyword name if there is one, otherwise NIL \(name parameter must be a symbol). +Note that the headers Set-Cookie, Content-Length, and Content-Type cannot be queried by HEADER-OUT. +See also CLAWSERVER-HEADERS-OUT, CLAWSERVER-CONTENT-TYPE, CLAWSERVER-CONTENT-LENGTH, CLAWSERVER-COOKIES-OUT, and CLAWSERVER-COOKIE-OUT")) + +(defgeneric (setf clawserver-header-out) (value clawserver name) + (:documentation "SETF of HEADER-OUT changes the current value of the header named name \(name parameter must be a symbol). +If no header named name exists it is created. +Note that the headers Set-Cookie, Content-Length, and Content-Type must not be set by SETF of HEADER-OUT. +Also, there are a couple of \"technical\" headers like Connection or Transfer-Encoding that you're not supposed to set yourself. +See also CLAWSERVER-HEADERS-OUT, CLAWSERVER-CONTENT-TYPE, CLAWSERVER-CONTENT-LENGTH, CLAWSERVER-COOKIES-OUT, and CLAWSERVER-COOKIE-OUT")) + +(defgeneric clawserver-headers-out (clawserver) + (:documentation "Returns an alist of all outgoing http parameters \(except for Set-Cookie, Content-Length, and Content-Type). +The car of each element of this list is the headers's name while the cdr is its value. +This alist should not be manipulated directly, use SETF of CLAWSERVER-HEADER-OUT instead")) + +(defgeneric clawserver-cookie-out (clawserver name) + (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name). +See also CLAWSERVER-COOKIES-OUT and the CLAW-COOKIE class definition.")) + +(defgeneric (setf clawserver-cookie-out) (cookie-instance clawserver name) + (:documentation "Creates a CLAW-COOKIE object from the parameters provided to this function and adds it to the outgoing cookies of the REPLY object reply. +If a cookie with the same name \(case-sensitive) already exists, it is replaced. + The default for value is the empty string.")) + +(defgeneric clawserver-cookies-out (clawserver) + (:documentation "Returns the outgoing cookie named by the string name \(or NIL if there ain't no cookie with this name). +See also CLAWSERVER-COOKIES-OUT and the CLAW-COOKIE class definition.")) + +(defgeneric clawserver-return-code (clawserver) + (:documentation "CLAWSERVER-RETURN-CODE returns the http return code of the reply. The return code of each REPLY object is initially set to 200 \(OK)")) + +(defgeneric (setf clawserver-return-code) (value clawserver) + (:documentation "Setf CLAWSERVER-RETURN-CODE sets the http return code of the reply.")) + +(defgeneric clawserver-content-type (clawserver) + (:documentation "CLAWSERVER-CONTENT-TYPE returns the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\").")) + +(defgeneric (setf clawserver-content-type) (value clawserver) + (:documentation "SETF CLAWSERVER-CONTENT-TYPE sets the outgoing Content-Type http header \(such as: \"text/html; charset=utf-8\").")) + +(defgeneric clawserver-content-length (clawserver) + (:documentation "Returns the outgoing Content-Length http header")) + +(defgeneric (setf clawserver-content-length) (value clawserver) + (:documentation "Sets the outgoing Content-Length http header")) + +(defgeneric clawserver-reply-external-format-encoding (clawserver) + (:documentation "CLAWSERVER-REPLY-EXTERNAL-FORMAT-ENCODING returns the symbol of the reply charset encoding \(Such as UTF-8).")) + +(defgeneric (setf clawserver-reply-external-format-encoding) (value clawserver) + (:documentation "SETF CLAWSERVER-REPLY-EXTERNAL-FORMAT-ENCODING sets the symbol of the reply charset encoding \(Such as UTF-8).")) + +(defgeneric clawserver-writer (clawserver) + (:documentation "Returns the output stream writer to generate replies. It's default to *standard-output*")) + +(defgeneric clawserver-redirect (clawserver target &key host port protocol add-session-id code) + (:documentation "Sends back appropriate headers to redirect the client to target \(a string). +If target is a full URL starting with a scheme, host, port, and protocol are ignored. +Otherwise, target should denote the path part of a URL, protocol must be one of the keywords :HTTP or :HTTPS, and the URL to redirect to will be constructed from host, port, protocol, and target. +If code is a 3xx redirection code, it will be sent as status code. +In case of NIL, a 302 status code will be sent to the client. If host is not provided, the current host \(see CLAWSERVER-HOST) will be used. +If protocol is the keyword :HTTPS, the client will be redirected to a https URL, if it's :HTTP it'll be sent to a http URL. If both host and protocol aren't provided, then the value of protocol will match the current request.")) +;;------------------------------------------------------------------------------------------ + + (defgeneric clawserver-dispatch-request (clawserver) (:documentation "Dispatches http requests through registered dispatchers")) @@ -50,53 +228,52 @@ (defgeneric (setf clawserver-address) (address clawserver) (:documentation "Binds the claw server to a specific address. When server is started an error will be signaled.")) -(defgeneric (setf clawserver-name) (name clawserver) - (:documentation "Sets the name of the server that dispatches http requests.")) - -(defgeneric (setf clawserver-sslname) (sslname clawserver) - (:documentation "Sets the name of the server that dispatches https requests.")) - -(defgeneric (setf clawserver-mod-lisp-p) (mod-lisp-p clawserver) - (:documentation "When not null binds the claw server to apache using mod_lisp2. When server is started an error will be signaled.")) - -(defgeneric (setf clawserver-use-apache-log-p) (apache-log-p clawserver) - (:documentation "When boud to apache with mod_lisp2 if not nil, uses apache logging. When server is started an error will be signaled.")) - -(defgeneric (setf clawserver-input-chunking-p) (input-chunking-p clawserver) - (:documentation "Sets input-chunking-p, when true the server will accept request -bodies without a Content-Length header if the client uses chunked transfer encoding. -If you want to use this feature behind mod_lisp, you should make sure that your combination of -Apache and mod_lisp can cope with that. When server is started an error will be signaled.")) - +(defgeneric clawserver-behind-apache-p (clawserver) + (:documentation "Returns true if the server (or better, the connector) is running behind apache.")) +;;----------------------------------------------------------------------------------------------- (defgeneric (setf clawserver-read-timeout) (read-timeout clawserver) (:documentation "Sets the read timeout in seconds. When server is started an error will be signaled.")) (defgeneric (setf clawserver-write-timeout) (write-timeout clawserver) (:documentation "Sets the write timeout in seconds. When server is started an error will be signaled.")) -#+(and :unix (not :win32)) (defgeneric (setf clawserver-setuid) (setuid clawserver) - (:documentation "Sets the uid under which the server runs (Only for *NIX). When server is started an error will be signaled.")) - -#+(and :unix (not :win32)) (defgeneric (setf clawserver-setgid) (setgid clawserver) - (:documentation "Sets the gid under which the server runs (Only for *NIX). When server is started an error will be signaled.")) +(defgeneric clawserver-add-service (clawserver service) + (:documentation "Registers a service for the given CLAWSERVER object with the given SERVICE name. +A service may be added if the CLAWSERVER object is not running.")) -#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-certificate-file) (certificate-file clawserver) - (:documentation "The ssl certificate file for https connections. When server is started an error will be signaled.")) - -#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-file) (ssl-privatekey-file clawserver) - (:documentation "The ssl private key file for https connections. When server is started an error will be signaled.")) - -#-:hunchentoot-no-ssl (defgeneric (setf clawserver-ssl-privatekey-password) (ssl-privatekey-password clawserver) - (:documentation "The password for the ssl private key file. When server is started an error will be signaled.")) +;;------------------------------------------------------------ (defgeneric clawserver-register-configuration(clawserver realm configuration) (:documentation "Registers a configuration object for the given realm into the server. The configuration will perform the authentication logic.")) -(defgeneric configuration-login (configuration &optional request) +(defgeneric configuration-login (configuration) (:documentation "Authenticate a user creating a principal object that will be stored into the http session. If no session is present one will be created, if the authentication succeds the principal instance is returned")) +(defgeneric claw-service-start (claw-service) + (:documentation "Starts the service")) + +(defgeneric claw-service-stop (claw-service) + (:documentation "Stop the service")) + +(defclass claw-service () + ((running-p :initform nil + :accessor claw-service-running-p + :documentation "Returns if the server is running or not.") + (name :initarg :name + :type symbol + :reader claw-service-name + :documentation "Mandatory and unique service name that will be used inside the CLAWSERVER object.")) + (:documentation "Generic claw service, must implement claw-service-start and claw-service-stop. +A service injected into a CLAWSERVER oject via CLAWSERVER-ADD-SERVICE method is automatically started or stopped when the CLAWSERVER object is started or stopped")) + +(defmethod claw-service-start ((claw-service claw-service)) + (setf (claw-service-running-p claw-service) t)) + +(defmethod claw-service-stop ((claw-service claw-service)) + (setf (claw-service-running-p claw-service) nil)) + (defclass error-page (page) ((title :initarg :title :reader page-title @@ -151,7 +328,8 @@ (defmethod wcomponent-template ((error-page-template error-page-template)) (let ((error-code (error-code error-page-template)) (title (title error-page-template)) - (style (style error-page-template))) + (style (style error-page-template)) + (request-uri (connector-request-uri (clawserver-connector *clawserver*)))) (html> (head> (title> title) @@ -159,7 +337,7 @@ (body> (p> (p> :class "h1" - (format nil "HTTP Status ~a - ~a" error-code (request-uri *request*))) + (format nil "HTTP Status ~a - ~a" error-code request-uri)) (hr> :noshade "noshade") (p> (span> :class "blue" @@ -168,101 +346,47 @@ (p> (span> :class "blue" "url") - (request-uri *request*)) + request-uri) (p> (span> :class "blue" "description") - (gethash error-code hunchentoot::*http-reason-phrase-map*) + (gethash error-code *http-reason-phrase-map*) (hr> :noshade "noshade")) (p> :class "h2" "claw server")))))) (defmethod page-content ((error-page error-page)) - (error-page-template> :title (page-title error-page) - :error-code (page-error-code error-page) - (format nil "The requested resource (~a) is not available." (request-uri *request*)))) + (let ((connector (clawserver-connector *clawserver*))) + (error-page-template> :title (page-title error-page) + :error-code (page-error-code error-page) + (format nil "The requested resource (~a) is not available." (connector-request-uri connector))))) (defclass clawserver () ((base-path :initarg :base-path :accessor clawserver-base-path :documentation "This slot is used to keep all server resources under a common URL") - (port :initarg :port - :reader clawserver-port - :documentation "Returns the claw server http port") - (sslport :initarg :sslport - :reader clawserver-sslport - :documentation "Returns the claw server https port") - (address :initarg :address - :reader clawserver-address - :documentation "Returns the address where claw server is bound to.") - (name :initarg :name - :reader clawserver-name - :documentation "Returns the name of the server that dispatches http requests.") - (sslname :initarg :sslname - :reader clawserver-sslname - :documentation "Returns the name of the server that dispatches https requests.") - (mod-lisp-p :initarg :mod-lisp-p - :reader clawserver-mod-lisp-p - :documentation "Returns not nil when the server is bound to apache through mod_lisp") - (use-apache-log-p :initarg :use-apache-log-p - :reader clawserver-use-apache-log-p - :documentation "Returns not nil when the server uses apache logging") - (input-chunking-p :initarg :input-chunking-p - :reader clawserver-input-chunking-p - :documentation "When true the server will accept request -bodies without a Content-Length header if the client uses chunked transfer encoding. -If you want to use this feature behind mod_lisp, you should make sure that your combination of -Apache and mod_lisp can cope with that.") - (read-timeout :initarg :read-timeout - :reader clawserver-read-timeout - :documentation "Returns the server read timeout in seconds.") - (write-timeout :initarg :write-timeout - :reader clawserver-write-timeout - :documentation "Returns the server write timeout in seconds.") + (connector :initarg :connector + :accessor clawserver-connector + :documentation "Reads or sets the server connector that dispatches requests and processes replies from the remote host.") + (log-manager :initarg :log-manager + :accessor clawserver-log-manager + :documentation "Required log meanager used to log application messages when no lisplet one is provided") + (session-manager :initarg :session-manager + :accessor clawserver-session-manager + :documentation "Accessor for the session manager. See the definition of the SESSION-MANAGER class.") + (services :initarg :services + :accessor clawserver-services + :documentation "A hash map of services handled by the current server") (login-config :initform (make-hash-table :test 'equal) :accessor clawserver-login-config :documentation "An hash table holding a pair of realm, expressed as string, and a predicate. The predicate should take two arguments (login and password), and return a principal instance if the login call succeeds.") - #+(and :unix (not :win32)) (setuid :initarg :setuid - :reader clawserver-setuid - :documentation "Returns the uid under which the server runs.") - #+(and :unix (not :win32)) (setgid :initarg :setgid - :reader clawserver-setgid - :documentation "Returns the gid under which the server runs.") - #-:hunchentoot-no-ssl (ssl-certificate-file :initarg :ssl-certificate-file - :reader clawserver-ssl-certificate-file - :documentation "The ssl certificate file for https connections.") - #-:hunchentoot-no-ssl (ssl-privatekey-file :initarg :ssl-privatekey-file - :reader clawserver-ssl-privatekey-file - :documentation "The ssl private key file for https connections") - #-:hunchentoot-no-ssl (ssl-privatekey-password :initarg :ssl-privatekey-password - :reader clawserver-ssl-privatekey-password - :documentation "The password for the ssl private key file for https connections") - (server :initform nil - :accessor clawserver-server - :documentation "The hunchentoot server dispatching http requests.") - (sslserver :initform nil - :accessor clawserver-sslserver - :documentation "The hunchentoot server dispatching https requests.") (dispatchers :initform nil :accessor clawserver-dispatchers :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet")) (:default-initargs :base-path "" - :use-apache-log-p nil - :address nil - :name (gensym) - :sslname (gensym) - :port 80 - :sslport 443 - :mod-lisp-p nil - :input-chunking-p t - :read-timeout *default-read-timeout* - :write-timeout *default-write-timeout* - #+(and :unix (not :win32)) :setuid nil - #+(and :unix (not :win32)) :setgid nil - #-:hunchentoot-no-ssl :ssl-certificate-file nil - #-:hunchentoot-no-ssl :ssl-privatekey-password nil) + :services (make-hash-table)) (:documentation "CLAWSERVER is built around huncentoot and has the instructions for lisplet dispatching, so use this class to start and stop 3hunchentoot server.")) @@ -271,8 +395,8 @@ () (:documentation "A configuration class for CLAW server realm login configurations")) -(defmethod configuration-login ((configuration configuration) &optional (request *request*)) - (declare (ignore request))) +(defmethod configuration-login ((configuration configuration)) + nil) (defclass principal () ((name :initarg :name @@ -284,90 +408,12 @@ (:default-initargs :roles nil) (:documentation "An instance of PRINCIPAL is stored into session after a user successfully login into the application.")) -(defmethod initialize-instance :after ((clawserver clawserver) &rest keys) - (let ((use-apache-log-p (getf keys :use-apache-log-p :undefined)) - #-:hunchentoot-no-ssl (ssl-privatekey-file (getf keys :ssl-privatekey-file :undefined))) - (when (eq use-apache-log-p :undefined) - (setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p))) - #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined) - (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) ;;;-------------------------- WRITERS ---------------------------------------- -(defmethod (setf clawserver-port) (port (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change port when server is started")) - (setf (slot-value clawserver 'port) port)) - -(defmethod (setf clawserver-sslport) (sslport (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change SSL port when server is started")) - (setf (slot-value clawserver 'sslport) sslport)) - -(defmethod (setf clawserver-address) (address (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change binding address when server is started")) - (setf (slot-value clawserver 'address) address)) - -(defmethod (setf clawserver-name) (name (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (setf (server-name (clawserver-server clawserver)) name)) - (setf (slot-value clawserver 'name) name)) - -(defmethod (setf clawserver-sslname) (sslname (clawserver clawserver)) - (unless (null (clawserver-sslserver clawserver)) - (setf (server-name (clawserver-sslserver clawserver)) sslname)) - (setf (slot-value clawserver 'sslname) sslname)) - -(defmethod (setf clawserver-mod-lisp-p) (mod-lisp-p (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change mod-lisp property when server is started")) - (setf (slot-value clawserver 'mod-lisp-p) mod-lisp-p)) - -(defmethod (setf clawserver-use-apache-log-p) (use-apache-log-p (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change logging property when server is started")) - (setf (slot-value clawserver 'use-apache-log-p) use-apache-log-p)) - -(defmethod (setf clawserver-input-chunking-p) (input-chunking-p (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change chunking property when server is started")) - (setf (slot-value clawserver 'input-chunking-p) input-chunking-p)) - -(defmethod (setf clawserver-read-timeout) (read-timeout (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change read timeout property when server is started")) - (setf (slot-value clawserver 'read-timeout) read-timeout)) - -(defmethod (setf clawserver-write-timeout) (write-timeout (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change write timeout property when server is started")) - (setf (slot-value clawserver 'write-timeout) write-timeout)) - -#+(and :unix (not :win32)) (defmethod (setf clawserver-setuid) (setuid (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change uid property when server is started")) - (setf (slot-value clawserver 'setuid) setuid)) - -#+(and :unix (not :win32)) (defmethod (setf clawserver-setgid) (setgid (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change gid property when server is started")) - (setf (slot-value clawserver 'setgid) setgid)) - -#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-certificate-file) (ssl-certificate-file (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change ssl certificate file property when server is started")) - (setf (slot-value clawserver 'ssl-certificate-file) ssl-certificate-file)) - -#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-file) (ssl-privatekey-file (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change ssl privatekey file property when server is started")) - (setf (slot-value clawserver 'ssl-privatekey-file) ssl-privatekey-file)) - -#-:hunchentoot-no-ssl (defmethod (setf clawserver-ssl-privatekey-password) (ssl-privatekey-password (clawserver clawserver)) - (unless (null (clawserver-server clawserver)) - (error "Cannot change ssl privatekey password property when server is started")) - (setf (slot-value clawserver 'ssl-privatekey-password) ssl-privatekey-password)) +(defmethod clawserver-add-service ((server clawserver) (service claw-service)) + (setf (gethash (claw-service-name service) (clawserver-services server)) service)) + ;;;-------------------------- METHODS ---------------------------------------- @@ -375,92 +421,219 @@ (setf (gethash realm (clawserver-login-config clawserver)) configuration)) +(defmethod render-error-page ((clawserver clawserver) &optional (error-code +http-not-found+)) + (let ((connector (clawserver-connector clawserver))) + (setf (claw-return-code) +http-ok+) + (page-render (make-instance 'error-page + :title (format nil "Server error: ~a" error-code) + :writer (connector-writer connector) + :error-code error-code)))) + (defmethod clawserver-dispatch-request ((clawserver clawserver)) - (let ((base-path (clawserver-base-path clawserver)) - (dispatchers (clawserver-dispatchers clawserver)) - (script-name (script-name)) - (rel-script-name) - (rel-script-name-libs)) - (setf (current-server) clawserver) - (when (starts-with-subseq script-name base-path) - (setf rel-script-name (subseq script-name (length base-path)) - rel-script-name-libs (subseq script-name (1+ (length base-path)))) - (or - (loop for dispatcher in *claw-libraries-resources* - for url = (car dispatcher) - for action = (cdr dispatcher) - do (when (starts-with-subseq rel-script-name-libs url) (funcall action))) - (loop for dispatcher in dispatchers - for url = (car dispatcher) - for action = (cdr dispatcher) - do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))) + (let* ((*clawserver* clawserver) + (*session-manager* (clawserver-session-manager clawserver)) + (connector (clawserver-connector clawserver)) + (base-path (clawserver-base-path clawserver)) + (dispatchers (clawserver-dispatchers clawserver)) + (script-name (connector-script-name connector)) + (rel-script-name) + (rel-script-name-libs) + (http-result)) + (handler-bind ((error (lambda (cond) + ;(log-message :error "~a" cond) + (logger-log (clawserver-log-manager clawserver) :error "~a" cond) + (with-output-to-string (*standard-output*) + (render-error-page clawserver +http-internal-server-error+))))) + (unwind-protect + (catch 'handler-done + (if (starts-with-subseq script-name base-path) + (progn + (setf rel-script-name (subseq script-name (length base-path)) + rel-script-name-libs (subseq script-name (1+ (length base-path)))) + (setf http-result (or + (loop for dispatcher in *claw-libraries-resources* + for url = (car dispatcher) + for action = (cdr dispatcher) + do (when (starts-with-subseq rel-script-name-libs url) (funcall action))) + (loop for dispatcher in dispatchers + for url = (car dispatcher) + for action = (cdr dispatcher) + do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))))) + (or http-result + (with-output-to-string (*standard-output*) + (render-error-page clawserver (or + (let ((return-code (claw-return-code))) + (if (= return-code +http-ok+) + nil + return-code)) + +http-not-found+))))))) + (defmethod clawserver-dispatch-method ((clawserver clawserver)) - (let ((result (clawserver-dispatch-request clawserver))) + (let ((result (clawserver-dispatch-request clawserver)) + (connector (clawserver-connector clawserver))) (if (null result) - #'(lambda () (when (= (return-code) +http-ok+) - (setf (return-code *reply*) +http-not-found+))) + #'(lambda () (when (= (connector-return-code connector) 200) ;OK + (setf (connector-return-code connector) 404))) ; Not found #'(lambda () result)))) (defmethod clawserver-start ((clawserver clawserver)) - (let ((port (clawserver-port clawserver)) - (sslport (clawserver-sslport clawserver)) - (address (clawserver-address clawserver)) - (dispatch-table (list #'(lambda (request) - (declare (ignorable request)) - (clawserver-dispatch-method clawserver)))) - (name (clawserver-name clawserver)) - (sslname (clawserver-sslname clawserver)) - (mod-lisp-p (clawserver-mod-lisp-p clawserver)) - (use-apache-log-p (clawserver-use-apache-log-p clawserver)) - (input-chunking-p (clawserver-input-chunking-p clawserver)) - (read-timeout (clawserver-read-timeout clawserver)) - (write-timeout (clawserver-write-timeout clawserver)) - (uid (clawserver-setuid clawserver)) - (gid (clawserver-setgid clawserver)) - (ssl-certificate-file (clawserver-ssl-certificate-file clawserver)) - (ssl-privatekey-file (clawserver-ssl-privatekey-file clawserver)) - (ssl-privatekey-password (clawserver-ssl-privatekey-password clawserver))) - (progn - (setf (clawserver-server clawserver) - (start-server :port port - :address address - :dispatch-table dispatch-table - :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 uid - #+(and :unix (not :win32)) :setgid gid)) - #-:hunchentoot-no-ssl (when ssl-certificate-file - (setf (clawserver-sslserver clawserver) - (start-server :port sslport - :address address - :dispatch-table dispatch-table - :name sslname - :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 uid - #+(and :unix (not :win32)) :setgid gid - :ssl-certificate-file ssl-certificate-file - :ssl-privatekey-file ssl-privatekey-file - :ssl-privatekey-password ssl-privatekey-password)))))) + (let ((*clawserver* clawserver) + (log-manager (clawserver-log-manager clawserver)) + (connector (clawserver-connector clawserver)) + (sm (clawserver-session-manager clawserver))) + (unless (claw-service-running-p log-manager) + (claw-service-start log-manager)) + (unless (claw-service-running-p connector) + (claw-service-start connector)) + (claw-service-start sm))) (defmethod clawserver-stop ((clawserver clawserver)) - (progn - (setf (clawserver-server clawserver) (stop-server (clawserver-server clawserver))) - (when (clawserver-sslserver clawserver) - (setf (clawserver-sslserver clawserver) (stop-server (clawserver-sslserver clawserver)))))) -;;;---------------------------------------------------------------------------- -(defun login (&optional (request *request*)) + (let ((*clawserver* clawserver) + (log-manager (clawserver-log-manager clawserver)) + (connector (clawserver-connector clawserver)) + (sm (clawserver-session-manager clawserver))) + (when (claw-service-running-p connector) + (claw-service-stop connector)) + (when (claw-service-running-p log-manager) + (claw-service-stop log-manager)) + (claw-service-stop sm))) + +(defun login () "Perform user authentication for the reaml where the request has been created" - (let* ((server (current-server request)) - (realm (current-realm request)) - (login-config (gethash realm (clawserver-login-config server)))) - (configuration-login login-config request))) + (let* ((login-config (gethash *claw-current-realm* (clawserver-login-config *clawserver*)))) + (configuration-login login-config))) + + + + +;;------------------------------------------------------------------------------------------------------- + +(defmethod clawserver-host ((clawserver clawserver)) + (connector-host (clawserver-connector clawserver))) + +(defmethod clawserver-request-method ((clawserver clawserver)) + (connector-request-method (clawserver-connector clawserver))) + +(defmethod clawserver-request-uri ((clawserver clawserver)) + (connector-request-uri (clawserver-connector clawserver))) + +(defmethod clawserver-query-string ((clawserver clawserver)) + (connector-query-string (clawserver-connector clawserver))) + +(defmethod clawserver-get-parameter ((clawserver clawserver) name) + (connector-get-parameter (clawserver-connector clawserver) name)) + +(defmethod clawserver-get-parameters ((clawserver clawserver)) + (connector-get-parameters (clawserver-connector clawserver))) + +(defmethod clawserver-post-parameter ((clawserver clawserver) name) + (connector-post-parameter (clawserver-connector clawserver) name)) + +(defmethod clawserver-post-parameters ((clawserver clawserver)) + (connector-post-parameters (clawserver-connector clawserver))) + +(defmethod clawserver-parameter ((clawserver clawserver) name) + (connector-parameter (clawserver-connector clawserver) name)) + +(defmethod clawserver-header-in ((clawserver clawserver) name) + (connector-header-in (clawserver-connector clawserver) name)) + +(defmethod clawserver-headers-in ((clawserver clawserver)) + (connector-headers-in (clawserver-connector clawserver))) + +(defmethod clawserver-authorization ((clawserver clawserver)) + (connector-authorization (clawserver-connector clawserver))) + +(defmethod clawserver-remote-addr ((clawserver clawserver)) + (connector-remote-addr (clawserver-connector clawserver))) + +(defmethod clawserver-remote-port ((clawserver clawserver)) + (connector-remote-port (clawserver-connector clawserver))) + +(defmethod clawserver-real-remote-addr ((clawserver clawserver)) + (connector-real-remote-addr (clawserver-connector clawserver))) + +(defmethod clawserver-server-addr ((clawserver clawserver)) + (connector-server-addr (clawserver-connector clawserver))) + +(defmethod clawserver-server-port ((clawserver clawserver)) + (connector-server-port (clawserver-connector clawserver))) + +(defmethod clawserver-server-protocol ((clawserver clawserver)) + (connector-server-protocol (clawserver-connector clawserver))) + +(defmethod clawserver-user-agent ((clawserver clawserver)) + (connector-user-agent (clawserver-connector clawserver))) + +(defmethod clawserver-referer ((clawserver clawserver)) + (connector-referer (clawserver-connector clawserver))) + +(defmethod clawserver-cookie-in ((clawserver clawserver) name) + (connector-cookie-in (clawserver-connector clawserver) name)) + +(defmethod clawserver-cookies-in ((clawserver clawserver)) + (connector-cookies-in (clawserver-connector clawserver))) + +(defmethod clawserver-aux-request-value ((clawserver clawserver) symbol) + (connector-aux-request-value (clawserver-connector clawserver) symbol)) + +(defmethod (setf clawserver-aux-request-value) (value (clawserver clawserver) symbol) + (setf (connector-aux-request-value (clawserver-connector clawserver) symbol) value)) + +(defmethod clawserver-delete-aux-request-value ((clawserver clawserver) symbol) + (connector-delete-aux-request-value (clawserver-connector clawserver) symbol)) + +(defmethod clawserver-header-out ((clawserver clawserver) name) + (connector-header-out (clawserver-connector clawserver) name)) + +(defmethod (setf clawserver-header-out) (value (clawserver clawserver) name) + (setf (connector-header-out (clawserver-connector clawserver) name) value)) + +(defmethod clawserver-headers-out ((clawserver clawserver)) + (connector-headers-out (clawserver-connector clawserver))) + +(defmethod clawserver-cookie-out ((clawserver clawserver) name) + (connector-cookie-out (clawserver-connector clawserver) name)) + +(defmethod (setf clawserver-cookie-out) (cookie-instance (clawserver clawserver) name) + (setf (connector-cookie-out (clawserver-connector clawserver) name) cookie-instance)) + +(defmethod clawserver-cookies-out ((clawserver clawserver)) + (connector-cookies-out (clawserver-connector clawserver))) + +(defmethod clawserver-return-code ((clawserver clawserver)) + (connector-return-code (clawserver-connector clawserver))) + +(defmethod (setf clawserver-return-code) (value (clawserver clawserver)) + (setf (connector-return-code (clawserver-connector clawserver)) value)) + +(defmethod clawserver-content-type ((clawserver clawserver)) + (connector-content-type (clawserver-connector clawserver))) + +(defmethod (setf clawserver-content-type) (value (clawserver clawserver)) + (setf (connector-content-type (clawserver-connector clawserver)) value)) + +(defmethod clawserver-content-length ((clawserver clawserver)) + (connector-content-length (clawserver-connector clawserver))) + +(defmethod (setf clawserver-content-length) (value (clawserver clawserver)) + (setf (connector-content-length (clawserver-connector clawserver)) value)) + +(defmethod clawserver-reply-external-format-encoding ((clawserver clawserver)) + (connector-reply-external-format-encoding (clawserver-connector clawserver))) + +(defmethod (setf clawserver-reply-external-format-encoding) (value (clawserver clawserver)) + (setf (connector-reply-external-format-encoding (clawserver-connector clawserver)) value)) + +(defmethod clawserver-writer ((clawserver clawserver)) + (connector-writer (clawserver-connector clawserver))) + +(defmethod clawserver-redirect (clawserver target &key host port protocol add-session-id code) + (connector-redirect (clawserver-connector clawserver) target :host host :port port :protocol protocol :add-session-id add-session-id :code code)) + +(defmethod clawserver-behind-apache-p ((clawserver clawserver)) + (connector-behind-apache-p (clawserver-connector clawserver))) +(defmethod clawserver-script-name ((clawserver clawserver)) + (connector-script-name (clawserver-connector clawserver))) \ No newline at end of file Added: trunk/main/claw-core/src/session-manager.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-core/src/session-manager.lisp Thu Jul 17 09:11:41 2008 @@ -0,0 +1,374 @@ +;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/session-manager.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw) + + +(defgeneric session-manager-start-session (session-manager &key path max-time domain) + (:documentation "Creates a new session if none exists")) + +(defgeneric session-manager-session-value (session-manager symbol) + (:documentation "Returns the value bound to the given session symbol. +It returns nil if no symbol is defined for the current session.")) + +(defgeneric (setf session-manager-session-value) (value session-manager symbol) + (:documentation "Sets the session symbol with the given value.")) + +(defgeneric session-manager-delete-session-value (session-manager symbol) + (:documentation "Completely removes any data associated with the symbol symbol from the session. +Note that this is different from using SESSION-VALUE to set the data to NIL")) + +(defgeneric session-manager-remove-session (session-manager &optional session) (:documentation "Removes the user session.")) + +(defgeneric session-manager-reset-sessions (session-manager) + (:documentation "Invalidates and destroy all sessions")) + +(defgeneric session-manager-session-cookie-value (session-manager) + (:documentation "Returns a unique string that's associated with the user session")) + +(defgeneric session-manager-session-max-time (session-manager) + (:documentation "This gets or sets the maximum time (in seconds) the session should be valid before it's invalidated. +If a request associated with this session comes in and the last request for the same session was more than seconds seconds ago than the session is deleted and a new one is started for this client")) + +(defgeneric session-manager-session-remote-addr (session-manager) + (:documentation "Returns the 'real' remote address (see CONNECTOR-REAL-REMOTE-ADDR) of the client for which the session was initiated.")) + +(defgeneric session-manager-session-user-agent (session-manager) + (:documentation "Returns the 'User-Agent' http header (see USER-AGENT) of the client for which the session was initiated.")) + +(defgeneric session-manager-session-gc (session-manager) + (:documentation "Deletes sessions which are too old - see SESSION-MANAGER-SESSION-TOO-OLD-P. Usually, you don't call this function directly")) + +(defgeneric session-manager-session-too-old-p (session-manager) + (:documentation "Returns a true value if the session is too old and would be deleted during the next session GC.")) + +(defgeneric session-manager-start (session-manager) + (:documentation "Starts the session manager.")) + +(defgeneric session-manager-stop (session-manager) + (:documentation "Stops the session manager.")) + +(let ((session-id-counter 0)) + (defun get-next-session-id () + "Returns the next sequential session id." + (incf session-id-counter))) + +;;------------------------------------------------------------------------- +(defvar *session-default-max-time* (* 30 60) + "The default time \(in seconds) after which this +session expires if it's not used.") + +(defclass session () + ((session-id :initform (get-next-session-id) + :reader session-id + :type integer + :documentation "The unique ID \(an INTEGER) of the session.") + (realm :initarg :realm + :accessor session-realm + :documentation "The realm under which the request has been sent. +A realm is used to group resources under a common 'place', and is used for registered web applications +to have different or common sessions for a give user") + (session-string :accessor session-string + :documentation "The session strings encodes enough +data to safely retrieve this session. It is sent to the browser as a +cookie value or as a GET parameter.") + (user-agent :initform (connector-user-agent (clawserver-connector *clawserver*)) + :reader session-user-agent + :documentation "The incoming 'User-Agent' header that +was sent when this session was created.") + (remote-addr :initform (connector-real-remote-addr (clawserver-connector *clawserver*)) + :reader session-remote-addr + :documentation "The remote IP address of the client when +this sessions was started as returned by REAL-REMOTE-ADDR.") + (session-start :initform (get-universal-time) + :reader session-start + :documentation "The time this session was started.") + (last-click :initform (get-universal-time) + :reader session-last-click + :documentation "The last time this session was used.") + (session-data :initarg :session-data + :initform (make-hash-table) + :reader session-data + :documentation "Data associated with this session - +see SESSION-VALUE.") + (session-counter :initform 0 + :reader session-counter + :documentation "The number of times this session +has been used.") + (max-time :initarg :max-time + :initform *session-default-max-time* + :accessor session-max-time + :type fixnum + :documentation "The time \(in seconds) after which this +session expires if it's not used.")) + (:default-initargs :realm *claw-current-realm*) + (:documentation "SESSION objects are automatically maintained +by Hunchentoot. They should not be created explicitly with +MAKE-INSTANCE but implicitly with START-SESSION. Note that +SESSION objects can only be created when the special variable +*REQUEST* is bound to a REQUEST object.")) + +;;------------------------------------------------------------------------- +(defvar *session-manager* nil + "The session manager used during the request cycle.") + +(defclass session-manager (claw-service) + ((max-time :initarg :max-time + :accessor session-manager-max-time + :type fixnum + :documentation "The time \(in seconds) after which this session expires if it's not used.")) + (:default-initargs :name 'session-manager :max-time 1800) + (:documentation "SESSION-MANAGER is an interface, so you cannot directly use it. +A SESSION-MANAGER subclass is a class that helps to decouple CLAW from the web server on which CLAWSERVER resides. +To properly work a CLAWSERVER instance must be provided with a SESSION-MANAGER implementation. +A SESSION-MANAGER implementation to properly work, must implement all the CONNECTOR- methods. +As the name suggests this is a server that handles user sessions.")) + + +(defgeneric default-session-manager-session-verify (session-manager) + (:documentation "Tries to get a session identifier from the cookies \(oralternatively from the GET parameters) sent by the client. +This identifier is then checked for validity against the REQUEST. +On success the corresponding session object \(if not too old) is returned \(and updated). Otherwise NIL is returned.")) + +;;------------------------------------------------------------------------- +(defgeneric default-session-manager-session-too-old-p (default-session-manager session) + (:documentation "Returns true if the SESSION has not been active in the last \(SESSION-MANAGER-MAX-TIME SESSION-MANAGER) seconds.")) + +(defgeneric default-session-manager-encode-session-string (default-session-manager id user-agent remote-addr start realm) + (:documentation "Create a uniquely encoded session string based on the values ID, USER-AGENT, REMOTE-ADDR, START and REALM")) + +(defgeneric default-session-manager-current-session (default-session-manager) + (:documentation "Returns the session bouded to the current request")) + +(defclass default-session-manager (session-manager) + ((gc-timeout :initarg :gc-timeout + :accessor default-session-manager-gc-timeout + :documentation "The period the service waits before calling the session garbage collector") + (sessions :initform (make-hash-table) + :accessor default-session-manager-sessions + :documentation "A hash table containing all sessions identified by their id") + (service-lock :accessor default-session-manager-service-lock + :documentation "This is a thread lock that is used when adding or removing sessions, or when calling the session garbage collector.") + (session-cookie-name :initarg :session-cookie-name + :accessor default-session-manager-session-cookie-name + :documentation "The name of the cookie that stores the session id.") + (use-user-agent-for-sessions-p :initarg :use-user-agent-for-sessions-p + :reader use-user-agent-for-sessions-p + :documentation "") + (use-remote-addr-for-sessions-p :initarg :use-remote-addr-for-sessions-p + :reader use-remote-addr-for-sessions-p + :documentation "") + (session-secret :initarg :session-secret + :accessor default-session-manager-random-secret + :documentation "A random letter used to encode sessin into a string in a random way.")) + (:default-initargs :gc-timeout 1 :session-cookie-name "CLAWSID" + :use-user-agent-for-sessions-p t + :use-remote-addr-for-sessions-p t + :session-secret (format nil "~VR" 36 (random 36 (make-random-state t)))) + (:documentation "This is the CLAW default session manager.")) + +(defmethod initialize-instance :after ((session-manager default-session-manager) &rest keys) + (declare (ignore keys)) + (setf (default-session-manager-service-lock session-manager) + (bt:make-lock (symbol-name 'session-manager)))) + +(defmethod default-session-manager-current-session ((session-manager default-session-manager)) + (or *claw-session* + (let* ((connector (clawserver-connector *clawserver*)) + (cookie-name (default-session-manager-session-cookie-name session-manager)) + (sessions (default-session-manager-sessions session-manager)) + (session-identifier (or (connector-cookie-in connector cookie-name) + (connector-get-parameter connector cookie-name)))) + (when session-identifier + (destructuring-bind (id-string session-string) + (split ":" session-identifier :limit 2) + (declare (ignore session-string)) + (let ((id (and (scan "^\\d+$" id-string) + (parse-integer id-string :junk-allowed t)))) + (and id (gethash id sessions)))))))) + +(defmethod claw-service-start :after ((session-manager default-session-manager)) + (unless (claw-service-running-p session-manager) + (bt:make-thread #'(lambda () + (do ((continue (claw-service-running-p session-manager) (funcall #'claw-service-running-p session-manager))) + ((null continue)) + (session-manager-session-gc session-manager)))))) + +(defmethod default-session-manager-encode-session-string ((session-manager default-session-manager) id user-agent remote-addr start realm) + ;; *SESSION-SECRET* is used twice due to known theoretical + ;; vulnerabilities of MD5 encoding + (let ((session-secret (default-session-manager-random-secret session-manager))) + (md5-hex (concatenate 'string + session-secret + (md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A~@[~A~]" + session-secret + id + user-agent + remote-addr + start + realm)))))) + +(defmethod default-session-manager-session-verify ((session-manager default-session-manager)) + (let* ((connector (clawserver-connector *clawserver*)) + (sessions (default-session-manager-sessions session-manager)) + (cookie-name (default-session-manager-session-cookie-name session-manager)) + (session-identifier (or (connector-cookie-in connector cookie-name) + (connector-get-parameter connector cookie-name)))) + (unless (and session-identifier + (stringp session-identifier) + (plusp (length session-identifier))) + (return-from default-session-manager-session-verify nil)) + (destructuring-bind (id-string session-string) + (split ":" session-identifier :limit 2) + (let* ((id (and (scan "^\\d+$" id-string) + (parse-integer id-string + :junk-allowed t))) + (session (and id + (gethash id sessions))) + (user-agent (connector-user-agent connector)) + (remote-addr (connector-remote-addr connector)) + (realm (when session (session-realm session)))) + (unless (and session + session-string + (string= session-string + (session-string session)) + (string= session-string + (default-session-manager-encode-session-string session-manager + id + (and (use-user-agent-for-sessions-p session-manager) + user-agent) + (and (use-remote-addr-for-sessions-p session-manager) + remote-addr) + (session-start session) + realm))) + (cond ((null session) + (log-message :notice "No session for session identifier '~A' \(User-Agent: '~A', IP: '~A', REALM: '~A')" + session-identifier user-agent remote-addr realm)) + (t + (log-message :warning "Fake session identifier '~A' \(User-Agent: '~A', IP: '~A', REALM: '~A')" + session-identifier user-agent remote-addr realm))) + (when (and session-identifier *claw-current-lisplet*) + (let ((cookie (make-instance 'claw-cookie + :name cookie-name + :expires (get-universal-time) + :path (format nil "~a/" (build-lisplet-location *claw-current-lisplet*)) + :domain nil + :value ""))) + (setf (connector-cookie-out connector cookie-name) cookie))) + (when session + (session-manager-remove-session session-manager session)) + (setf *claw-session* nil) + (return-from default-session-manager-session-verify *claw-session*)) + (incf (slot-value session 'session-counter)) + (setf (slot-value session 'last-click) (get-universal-time) + *claw-session* session))))) + + +(defmethod default-session-manager-session-too-old-p ((session-manager default-session-manager) (session session)) + (< (+ (session-last-click session) (or (session-max-time session) (session-manager-max-time session-manager))) + (get-universal-time))) + +(defmethod session-manager-start-session ((session-manager default-session-manager) &key (path "/") max-time domain) + (let* ((connector (clawserver-connector *clawserver*)) + (sessions (default-session-manager-sessions session-manager)) + (cookie-name (default-session-manager-session-cookie-name session-manager)) + (session-identifier (or (connector-cookie-in connector cookie-name) + (connector-get-parameter connector cookie-name)))) + (if (and session-identifier (gethash (parse-integer session-identifier :junk-allowed t) sessions)) + (destructuring-bind (id-string session-string) + (split ":" session-identifier :limit 2) + (declare (ignore session-string)) + (let* ((id (and (scan "^\\d+$" id-string) + (parse-integer id-string :junk-allowed t))) + (session (and id (gethash id sessions)))) + (unless (and session (default-session-manager-session-too-old-p session-manager session)) + (return-from session-manager-start-session session)))) + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (let* ((session (make-instance 'session + :max-time (or max-time (session-manager-max-time session-manager)))) + (cookie-name (default-session-manager-session-cookie-name session-manager)) + (cookie)) + (setf (session-string session) (default-session-manager-encode-session-string session-manager + (session-id session) + (session-user-agent session) + (session-remote-addr session) + (session-start session) + (session-realm session)) + cookie (make-instance 'claw-cookie + :name cookie-name + :expires nil + :path path + :domain domain + :value (format nil "~a:~a" (session-id session) (session-string session)))) + (setf (connector-cookie-out connector cookie-name) cookie) + (setf (gethash (session-id session) (default-session-manager-sessions session-manager)) session + *claw-session* session)))))) + + +(defmethod session-manager-remove-session ((session-manager default-session-manager) &optional session) + (let ((current-session (or session (default-session-manager-current-session session-manager)))) + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (remhash (session-id current-session) (default-session-manager-sessions session-manager))))) + +(defmethod session-manager-session-value ((session-manager default-session-manager) symbol) + (let ((session (default-session-manager-current-session session-manager))) + (when session + (gethash symbol (session-data session))))) + +(defmethod (setf session-manager-session-value) (value (session-manager default-session-manager) symbol) + (let ((session (default-session-manager-current-session session-manager))) + (when session + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (setf (gethash symbol (session-data session)) value))))) + + +(defmethod session-manager-delete-session-value ((session-manager default-session-manager) symbol) + (let ((session (default-session-manager-current-session session-manager))) + (when session + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (remhash symbol (session-data session)))))) + +(defmethod session-manager-remove-session ((session-manager default-session-manager) &optional session) + (unless session + (setf session (default-session-manager-current-session session-manager))) + (when session + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (remhash (session-id session) (default-session-manager-sessions session-manager))))) + +(defmethod session-manager-reset-sessions ((session-manager default-session-manager)) + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (setf (default-session-manager-sessions session-manager) (make-hash-table)))) + +(defmethod session-manager-session-gc ((session-manager default-session-manager)) + (let ((sessions (default-session-manager-sessions session-manager))) + (loop for session-id being the hash-key of sessions using (hash-value session) + do (when (default-session-manager-session-too-old-p session-manager session) + (bt:with-lock-held ((default-session-manager-service-lock session-manager)) + (remhash session-id sessions)))))) + Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Thu Jul 17 09:11:41 2008 @@ -247,18 +247,16 @@ "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. So if you have a :id \"compId\" given to a previous component, the second time this id will be used, it will be rendered as \"compId1\", the third time will be \"compId2\" and so on" - (when (boundp '*request*) - (let ((id-table-map (aux-request-value :id-table-map))) - (if (null id-table-map) - (progn - (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) - id-table-map)))) + (let ((id-table-map (claw-aux-request-value :id-table-map))) + (if (null id-table-map) + (progn + (setf (claw-aux-request-value :id-table-map) (make-hash-table :test 'equal))) + id-table-map))) (defun reset-request-id-table-map () "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness. See REQUEST-ID-TABLE-MAP for more info." - (when (boundp '*request*) - (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))) + (setf (claw-aux-request-value :id-table-map) (make-hash-table :test 'equal))) (defun parse-htcomponent-function (function-body) "This function parses attributes passed to a htcomponent creation function" @@ -355,8 +353,6 @@ (defclass page(i18n-aware) ((writer :initarg :writer :accessor page-writer :documentation "The output stream for this page instance") - (lisplet :initarg :lisplet - :reader page-lisplet :documentation "The lisplet that owns this page instance") (can-print :initform nil :accessor page-can-print :documentation "Controls the printing process when a json request is dispatched. @@ -393,14 +389,9 @@ (mime-type :initarg :mime-type :accessor page-mime-type :documentation "Define the mime type of the page when rendered") - (external-format :initarg :external-format - :accessor page-external-format - :documentation "The charset external format. When not provided the lisplet one is used") (injection-writing-p :initform nil :accessor page-injection-writing-p - :documentation "Flag that becomes true when rendering page injections") - (url :initarg :url - :accessor page-url :documentation "The URL provided with this page instance")) + :documentation "Flag that becomes true when rendering page injections")) (:default-initargs :writer t :script-files nil :json-component-count 0 @@ -412,9 +403,7 @@ :xmloutput nil :doc-type *html-4.01-strict* :request-parameters nil - :mime-type "text/html" - :external-format nil - :url nil) + :mime-type "text/html") (:documentation "A page object holds claw components to be rendered") ) (defclass htcomponent (i18n-aware) @@ -539,10 +528,6 @@ "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" "u" "ul" "var")) -(defun tag-emptyp (tag-name) - "Returns if a tag defined by the string TAG-NAME is empty" - (member tag-name *empty-tags* :test #'string-equal)) - ;;;--------------------METHODS implementation---------------------------------------------- (defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) (setf (slot-value htcomponent 'page) page) @@ -556,8 +541,8 @@ (setf (htcomponent-client-id htcomponent) (generate-id id))))))) (defmethod page-request-parameters ((page page)) - (if (and (boundp '*request*) (null (slot-value page 'request-parameters))) - (let ((parameters (append (post-parameters) (get-parameters))) + (if (null (slot-value page 'request-parameters)) + (let ((parameters (append (claw-post-parameters) (claw-get-parameters))) (pparameters (make-hash-table :test 'equal))) (loop for kv in parameters do (setf (gethash (string-upcase (car kv)) pparameters) @@ -611,7 +596,7 @@ (defmethod page-render-headings ((page page)) (let* ((jsonp (page-json-id-list page)) - (encoding (flexi-streams:external-format-name (or (page-external-format page) (reply-external-format)))) + (encoding (claw-reply-external-format-encoding)) (xml-p (page-xmloutput page)) (doc-type (page-doc-type page))) (when (null jsonp) @@ -638,16 +623,11 @@ (defmethod page-render ((page page)) (let ((body (page-content page)) - (jsonp (page-json-id-list page)) - (external-format (page-external-format page))) - (unless (or (null external-format) - (eq (flexi-streams:external-format-name (reply-external-format)) - (flexi-streams:external-format-name external-format))) - (setf (reply-external-format) external-format)) + (jsonp (page-json-id-list page))) (if (null body) (format nil "null body for page ~a~%" (type-of page)) (progn - (setf (current-page) page) + (setf *claw-current-page* page) (page-init page) (when (page-req-parameter page *rewind-parameter*) (htcomponent-rewind body page)) @@ -728,11 +708,10 @@ (defmethod page-current-component ((page page)) (car (page-components-stack page))) -(defun current-component (&optional (request *request*)) +(defun current-component () "Returns the component that is currently rendering" - (let ((page (current-page request))) - (when page - (car (page-components-stack page))))) + (when *claw-current-page* + (car (page-components-stack *claw-current-page*)))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) (let* ((id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) @@ -938,7 +917,7 @@ (when (null (page-json-id-list page)) (let ((body-list (htcomponent-body hthead)) (injections (page-init-injections page)) - (encoding (flexi-streams:external-format-name (or (page-external-format page) (reply-external-format))))) + (encoding (claw-reply-external-format-encoding))) (tag-render-starttag hthead page) (htcomponent-render (meta> :http-equiv "Content-Type" :content (format nil "~a;charset=~a" @@ -1190,10 +1169,16 @@ (when (null previous-print-status) (setf (page-can-print page) (htcomponent-can-print wcomponent))) (when (page-can-print page) - (dolist (script (htcomponent-script-files wcomponent)) - (pushnew script (page-script-files page) :test #'equal)) - (dolist (css (htcomponent-stylesheet-files wcomponent)) - (pushnew css (page-stylesheet-files page) :test #'equal)) + (let ((script-files (htcomponent-script-files wcomponent))) + (dolist (script (if (listp script-files) + script-files + (list script-files))) + (pushnew script (page-script-files page) :test #'equal))) + (let ((css-files (htcomponent-stylesheet-files wcomponent))) + (dolist (css (if (listp css-files) + css-files + (list css-files))) + (pushnew css (page-stylesheet-files page) :test #'equal))) (dolist (js (htcomponent-class-initscripts wcomponent)) (pushnew js (page-class-initscripts page) :test #'equal)) (when (htcomponent-instance-initscript wcomponent) Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Thu Jul 17 09:11:41 2008 @@ -273,6 +273,7 @@ (format nil "~a" value)) (defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label) + (declare (ignore client-id label)) (if (string-equal value "NIL") nil t)) @@ -297,6 +298,7 @@ (t (second value)))) (defmethod translator-value-decode ((translator translator-file) value &optional client-id label) + (declare (ignore client-id label)) value) (setf *file-translator* (make-instance 'translator-file)) \ No newline at end of file Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Thu Jul 17 09:11:41 2008 @@ -31,11 +31,11 @@ (defgeneric local-time-to-string (local-time format) (:documentation "Writes a local-time instance the FORMAT list where element are joined together and :SECOND :MINUTE :HOUR :DATE :MONTH and :YEAR are -expanded into seconds for :SECOND, minutes for :MINUTE, hour of the day for :HOUR, day of the month for :DATE, month number for :MONTH and the year for :YEAR. +expanded into seconds for :SECOND, minutes for :MINUTE, hour of the day for :HOUR, day of the month for :DATE, month number for :MONTH and the year for :YEAR. A format list may be for example '(:month \"/\" :date \"/\" :year)")) (defmethod local-time-to-string ((local-time local-time) format) - (multiple-value-bind (nsec sec min hour day month year) + (multiple-value-bind (nsec sec min hour day month year) (decode-local-time local-time) (declare (ignore nsec)) (loop for result = "" then (concatenate 'string result (if (stringp element) @@ -50,13 +50,13 @@ for element in format finally (return result)))) -(defun add-exception (id reason) +(defun add-exception (id reason) "Adds an exception for the given input component identified by its ID with the message expressed by REASON" (let* ((validation-errors (validation-errors)) (symbol-id (intern id)) (errors (getf validation-errors symbol-id))) (setf (getf validation-errors symbol-id) (nconc errors (list reason)) - (validation-errors *request*) validation-errors))) + (validation-errors) validation-errors))) (defun component-exceptions (id) "Returns a list of exception connectd to the given component" @@ -66,7 +66,7 @@ (defun validate (test &key component message) "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..." (let ((client-id (htcomponent-client-id component))) - (if test + (if test (add-validation-compliance client-id) (add-exception client-id message)))) @@ -74,12 +74,12 @@ "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) - (validate (and value (string-not-equal value "")) - :component component + (validate (and value (string-not-equal value "")) + :component component :message (or message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component)))))) (defun validate-size (component value &key min-size max-size message-low message-hi) - "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. + "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\". @@ -88,40 +88,40 @@ (when value (setf value (format nil "~a" value)) (setf value-len (length value)) - (and (= value-len 0) - (when min-size + (and (= value-len 0) + (when min-size (validate (>= value-len min-size) - :component component + :component component :message (or message-low (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) - (label component) - min-size)))) - (when max-size + (label component) + min-size)))) + (when max-size (validate (<= value-len max-size) - :component component + :component component :message (or message-hi (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) - (label component) - max-size)))))))) + (label component) + max-size)))))))) (defun validate-range (component value &key min max message-low message-hi) - "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. + "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX value." - (when value + (when value (and (when min (validate (>= value min) - :component component + :component component :message (or message-low (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") - (label component) + (label component) (if (typep min 'ratio) (coerce min 'float) min))))) (when max (validate (<= value max) - :component component + :component component :message (or message-hi (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") - (label component) + (label component) (if (typep max 'ratio) (coerce max 'float) max)))))))) @@ -130,10 +130,10 @@ "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\". The argument for the message will be the :label attribute of the COMPONENT." - (when value + (when value (let ((test (numberp value))) (and (validate test - :component component + :component component :message (or message-nan (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))) (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) @@ -141,15 +141,15 @@ "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\". The argument for the message will be the :label attribute of the COMPONENT." - (when value + (when value (let ((test (integerp value))) (and (validate test - :component component + :component component :message (or message-nan (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))) (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) -(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi) +(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi) "Checks if the input field VALUE is a date between min and max. If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time. If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time. @@ -160,7 +160,7 @@ The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword." (unless (component-validation-errors component) (let ((local-time-format '(:date "-" :month "-" :year)) - (new-value (make-instance 'local-time + (new-value (make-instance 'local-time :nsec (nsec-of value) :sec (sec-of value) :day (day-of value) @@ -182,17 +182,17 @@ (setf (local-time:day-of max) 0))) (and (when min (validate (local-time> new-value min) - :component component - :message (or message-low (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") - (label component) + :component component + :message (or message-low (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") + (label component) (local-time-to-string min local-time-format))))) (when max (validate (local-time< new-value max) - :component component - :message (or message-hi (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") - (label component) + :component component + :message (or message-hi (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") + (label component) (local-time-to-string max local-time-format))))))))) - + ;; ------------------------------------------------------------------------------------ @@ -213,16 +213,16 @@ (defmethod wcomponent-template ((exception-monitor exception-monitor)) (let ((client-id (htcomponent-client-id exception-monitor)) (validation-errors (validation-errors)) - (body (htcomponent-body exception-monitor))) + (body (htcomponent-body exception-monitor))) (div> :static-id client-id - (wcomponent-informal-parameters exception-monitor) + (wcomponent-informal-parameters exception-monitor) (when validation-errors (if body body (ul> :id "errors" - (loop for (client-id component-exceptions) on validation-errors by #'cddr - collect (loop for message in component-exceptions - collect (li> message))))))))) + (loop for (client-id component-exceptions) on validation-errors by #'cddr + collect (loop for message in component-exceptions + collect (li> message))))))))) ;;------------------------------------------------------------------------------------------- Modified: trunk/main/claw-core/tests/packages.lisp ============================================================================== --- trunk/main/claw-core/tests/packages.lisp (original) +++ trunk/main/claw-core/tests/packages.lisp Thu Jul 17 09:11:41 2008 @@ -30,6 +30,6 @@ (in-package :cl-user) (defpackage :claw-tests - (:use :cl :hunchentoot :claw :local-time) + (:use :cl :claw :hunchentoot-connector :local-time) (:export :claw-tst-start :claw-tst-stop)) \ No newline at end of file Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Thu Jul 17 09:11:41 2008 @@ -29,9 +29,9 @@ (in-package :claw-tests) -(setf hunchentoot:*default-content-type* "text/html; charset=UTF-8") +;(setf hunchentoot:*default-content-type* "text/html; charset=UTF-8") -(setf hunchentoot:*rewrite-for-session-urls* nil) +;(setf hunchentoot:*rewrite-for-session-urls* nil) (defvar *this-file* (load-time-value (or #.*compile-file-pathname* *load-pathname*))) @@ -63,53 +63,60 @@ :redirect-protected-resources-p t)) (defvar *test-lisplet2*) -(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" +(setf *test-lisplet2* (make-instance 'lisplet + :realm "test2" :base-path "/test2")) -;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) - -(defvar *clawserver* (make-instance 'clawserver - :port 4242 - :sslport 4445 - :base-path "/claw" - :mod-lisp-p nil - :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" - :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) +;;(defparameter *test-server* (make-instance 'clawserver :port 4242 :base-path "/claw")) +(defvar *ht-connector* (make-instance 'hunchentoot-connector + :port 4242 + :sslport nil + :behind-apache-p t + :mod-lisp-p nil + :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" + :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) +(defvar *sm* (make-instance 'default-session-manager)) + +(defvar *ht-log-manager* (make-instance 'hunchentoot-logger)) + +(defvar *test-server* (make-instance 'clawserver + :connector *ht-connector* + :log-manager *ht-log-manager* + :session-manager *sm* + :base-path "/claw")) ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) -(clawserver-register-lisplet *clawserver* *test-lisplet*) -(clawserver-register-lisplet *clawserver* *test-lisplet2*) +(clawserver-register-lisplet *test-server* *test-lisplet*) +(clawserver-register-lisplet *test-server* *test-lisplet2*) -(defun test-configuration-do-login (request user password) - (declare (ignore request)) - (let ((session *session*)) - (when (and (string-equal user "kiuma") +(defun test-configuration-do-login (user password) + (when (and (string-equal user "kiuma") (string-equal password "password")) - (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) + (setf (current-principal) (make-instance 'principal :name user :roles '("user"))))) (defclass test-configuration (configuration) ()) -(defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*)) - (let ((lisplet (current-lisplet request))) - (multiple-value-bind (user password) - (if (eq (lisplet-authentication-type lisplet) :basic) - (authorization) - (values (aux-request-value 'user request) - (aux-request-value 'password request))) - (test-configuration-do-login request user password)))) +(defmethod configuration-login ((test-configuration test-configuration)) + (log-message :info "AUX athenticating: ~a" (claw-aux-request-value 'user)) + (multiple-value-bind (user password) + (if (eq (lisplet-authentication-type *claw-current-lisplet*) :basic) + (claw-authorization) + (values (claw-aux-request-value 'user) + (claw-aux-request-value 'password))) + (test-configuration-do-login user password))) -(clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration)) +(clawserver-register-configuration *test-server* "test1" (make-instance 'test-configuration)) (defun claw-tst-start () - (clawserver-start *clawserver*)) + (clawserver-start *test-server*)) (defun claw-tst-stop () - (clawserver-stop *clawserver*)) + (clawserver-stop *test-server*)) ;;;--------------------template-------------------------------- @@ -150,7 +157,7 @@ (defclass index-page (page) ()) (defmethod page-content ((o index-page)) - (let ((clawserver-base-path (clawserver-base-path (current-server)))) + (let ((clawserver-base-path (clawserver-base-path *clawserver*))) (site-template> :title "Home test page" (p> :id "p" (ul> @@ -196,7 +203,7 @@ (defclass info-page (page) ()) (defmethod page-content ((o info-page)) - (let ((header-props (headers-in))) + (let ((header-props (claw-headers-in))) (site-template> :title "Header info page" (p> :id "p" (table> @@ -218,7 +225,8 @@ (lisplet-register-function-location *test-lisplet* (lambda () (let ((path (test-image-file))) - (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) + (setf (claw-content-type) (or (mime-type path) + "application/octet-stream")) (with-open-file (in path :element-type 'flex:octet) (let ((image-data (make-array (file-length in) :element-type 'flex:octet))) @@ -226,16 +234,30 @@ image-data)))) "images/matrix2.jpg" ) ;;;--------------------realm test page-------------------------------- -(defclass realm-page (page) ()) +(defgeneric realm-page-session-dispose (page)) + +(defgeneric realm-page-generate-number (page)) + +(defclass realm-page (page) + ((rnd-number :initform nil + :accessor realm-page-rnd-numuber))) + +(defmethod realm-page-generate-number ((page realm-page)) + (claw-start-session) + (unless (claw-session-value 'RND-NUMBER) + (setf (claw-session-value 'RND-NUMBER) (random 1000))) + (setf (realm-page-rnd-numuber page) (claw-session-value 'RND-NUMBER))) + +(defmethod realm-page-session-dispose ((page realm-page)) + (claw-remove-session) + (realm-page-generate-number page)) (defmethod page-content ((o realm-page)) - (when (null hunchentoot:*session*) - (claw-start-session)) - (unless (session-value 'RND-NUMBER) - (setf (session-value 'RND-NUMBER) (random 1000))) + (realm-page-generate-number o) (site-template> :title "Realm test page" (p> - "session" + (cform> :id "sessionDispose" :action #'realm-page-session-dispose + (submit-link> :id "submit" "Session dispose")) (ul> (li> (a> :href "http://www.gentoo.org" :target "gentoo" "gentoo")) @@ -243,13 +265,7 @@ "realm on lisplet 'test'")) (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) - (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) - (li> "Remote Addr: " (session-remote-addr *session*)) - (li> "User agent: " (session-user-agent *session*)) - (li> "Lisplet Realm: " (current-realm)) - (li> "Session Realm: " (session-realm *session*)) - (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) - (li> "Request Realm: " (hunchentoot::realm *request*)))))) + (li> "Rnd number value: " #'(lambda () (format nil "~d" (realm-page-rnd-numuber o)))))))) (lisplet-register-page-location *test-lisplet* 'realm-page "realm.html") (lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html") @@ -298,7 +314,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 "get" :action #'login-page-login (table> (tr> (td> "Username") @@ -323,8 +339,9 @@ (a> :href "index.html" "home")))))) (defmethod login-page-login ((login-page login-page)) - (setf (aux-request-value 'user) (login-page-username login-page) - (aux-request-value 'password) (login-page-password login-page)) + (log-message :info "athenticating: ~a" (login-page-username login-page)) + (setf (claw-aux-request-value 'user) (login-page-username login-page) + (claw-aux-request-value 'password) (login-page-password login-page)) (login)) (lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t)

1 0

[claw-cvs] r54 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 17 Jul '08

17 Jul '08

Author: achiumenti Date: Thu Jul 17 07:21:21 2008 New Revision: 54 Removed: trunk/main/claw-core/src/hunchentoot-overrides.lisp Log: deleting binding to hunchentoot

1 0

[claw-cvs] r53 - branches/claw-0.0.1
by achiumenti＠common-lisp.net 16 Jul '08

16 Jul '08

Author: achiumenti Date: Wed Jul 16 13:49:19 2008 New Revision: 53 Added: branches/claw-0.0.1/ - copied from r52, trunk/ Log: making first branch

1 0

[claw-cvs] r52 - branches
by achiumenti＠common-lisp.net 16 Jul '08

16 Jul '08

Author: achiumenti Date: Wed Jul 16 13:15:48 2008 New Revision: 52 Added: branches/ Log: added branches

1 0

[claw-cvs] r51 - in trunk/main/dojo: . src src/js tests tests/docroot tests/docroot/css tests/docroot/img
by achiumenti＠common-lisp.net 14 Jun '08

14 Jun '08

Author: achiumenti Date: Sat Jun 14 02:00:26 2008 New Revision: 51 Added: trunk/main/dojo/ trunk/main/dojo/README trunk/main/dojo/claw-dojo-tests.asd trunk/main/dojo/claw-dojo.asd trunk/main/dojo/src/ trunk/main/dojo/src/dijit.lisp trunk/main/dojo/src/djbody.lisp trunk/main/dojo/src/djbutton.lisp trunk/main/dojo/src/djclaw.lisp trunk/main/dojo/src/djcolorpalette.lisp trunk/main/dojo/src/djcontainers.lisp trunk/main/dojo/src/djcontent-pane.lisp trunk/main/dojo/src/djdialog.lisp trunk/main/dojo/src/djform.lisp trunk/main/dojo/src/djlayout.lisp trunk/main/dojo/src/djlink.lisp trunk/main/dojo/src/djmenu.lisp trunk/main/dojo/src/djprogressbar.lisp trunk/main/dojo/src/djtitlepane.lisp trunk/main/dojo/src/djtoolbar.lisp trunk/main/dojo/src/djtooltip.lisp trunk/main/dojo/src/djtree.lisp trunk/main/dojo/src/djwidget.lisp trunk/main/dojo/src/js/ trunk/main/dojo/src/misc.lisp trunk/main/dojo/src/packages.lisp trunk/main/dojo/tests/ trunk/main/dojo/tests/ajax-test.lisp trunk/main/dojo/tests/common.lisp trunk/main/dojo/tests/djbutton-test.lisp trunk/main/dojo/tests/djcalendar-test.lisp trunk/main/dojo/tests/djcolorpalette-test.lisp trunk/main/dojo/tests/djdialog-test.lisp trunk/main/dojo/tests/djeditor-test.lisp trunk/main/dojo/tests/djmenu-test.lisp trunk/main/dojo/tests/djprogressbar-test.lisp trunk/main/dojo/tests/docroot/ trunk/main/dojo/tests/docroot/css/ trunk/main/dojo/tests/docroot/css/style.css trunk/main/dojo/tests/docroot/img/ trunk/main/dojo/tests/docroot/img/roundedbg.gif (contents, props changed) trunk/main/dojo/tests/docroot/img/roundedbg.png (contents, props changed) trunk/main/dojo/tests/docroot/img/spinner.gif (contents, props changed) trunk/main/dojo/tests/header-info-page.lisp trunk/main/dojo/tests/index.lisp trunk/main/dojo/tests/main.lisp trunk/main/dojo/tests/packages.lisp trunk/main/dojo/tests/realm.lisp trunk/main/dojo/tests/slider-test.lisp Log: claw dojo-integration, first commit Added: trunk/main/dojo/README ============================================================================== --- (empty file) +++ trunk/main/dojo/README Sat Jun 14 02:00:26 2008 @@ -0,0 +1,6 @@ +to use claw-dojo library download dojo at + +http://download.dojotoolkit.org/release-1.1.1/dojo-release-1.1.1.tar.gz + +Then unpack it into the src directory and rename the extacted directory +"dojo-release-1.1.1" from to "dojotoolkit" \ No newline at end of file Added: trunk/main/dojo/claw-dojo-tests.asd ============================================================================== --- (empty file) +++ trunk/main/dojo/claw-dojo-tests.asd Sat Jun 14 02:00:26 2008 @@ -0,0 +1,51 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/claw-dojo-tests.asd $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(asdf:defsystem :claw-dojo-tests + :name "claw-dojo-tests" + :author "Andrea Chiumenti" + :description "Tests for claw-dojo" + :depends-on (:claw :claw-dojo :parenscript) + :components ((:module tests + :components ((:file "packages") + (:file "common" :depends-on ("packages")) + (:file "main" :depends-on ("common")) + (:file "index" :depends-on ("main")) + (:file "realm" :depends-on ("main")) + (:file "header-info-page" :depends-on ("main")) + (:file "djbutton-test" :depends-on ("main")) + (:file "djdialog-test" :depends-on ("main")) + (:file "djcolorpalette-test" :depends-on ("main")) + (:file "djeditor-test" :depends-on ("main")) + (:file "ajax-test" :depends-on ("main")) + (:file "djcalendar-test" :depends-on ("main")) + (:file "slider-test" :depends-on ("main")) + (:file "djmenu-test" :depends-on ("main")))))) + + Added: trunk/main/dojo/claw-dojo.asd ============================================================================== --- (empty file) +++ trunk/main/dojo/claw-dojo.asd Sat Jun 14 02:00:26 2008 @@ -0,0 +1,53 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/claw-dojo.asd $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(asdf:defsystem :claw-dojo + :name "claw-dojo" + :author "Andrea Chiumenti" + :description "claw dojo-1.1.0 integration" + :depends-on (:claw :parenscript) + :components ((:module src + :components ((:file "packages") + (:file "misc" :depends-on ("packages")) + (:file "djlink" :depends-on ("misc")) + (:file "djwidget" :depends-on ("misc")) + (:file "djcontent-pane" :depends-on ("misc")) + (:file "djbody" :depends-on ("djcontent-pane")) + (:file "dijit" :depends-on ("djwidget")) + (:file "djclaw" :depends-on ("djwidget")) + (:file "djform" :depends-on ("djwidget")) + (:file "djbutton" :depends-on ("djwidget")) + (:file "djmenu" :depends-on ("djwidget")) + (:file "djdialog" :depends-on ("djwidget")) + (:file "djcolorpalette" :depends-on ("djwidget")) + (:file "djprogressbar" :depends-on ("djwidget")) + (:file "djtitlepane" :depends-on ("djwidget")) + (:file "djtree" :depends-on ("djwidget")) + (:file "djlayout" :depends-on ("djwidget")) + (:file "djtooltip" :depends-on ("djwidget")))))) Added: trunk/main/dojo/src/dijit.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/dijit.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,35 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/dijit.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djbackground-iframe (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.BackgroundIframe component. More info at http://api.dojotoolkit.org/")) Added: trunk/main/dojo/src/djbody.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djbody.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,121 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djbody.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defgeneric scripts-content-pane> (&rest rest)) + +(defclass djbody (wcomponent) + ((class :initarg :class + :reader djbody-class + :documentation "The css class of the <body> tag element") + (theme :initarg :theme + :reader djbody-theme + :documentation "The theme name. See http://dojotoolkit.org/book/dojo-book-0-9/part-2-dijit/themes-and-design for more details") + (themes-url :initarg :themes-url + :reader djbody-themes-url + :documentation "The url that contains dojo themes") + (parse-on-load-p :initarg :parse-on-load + :reader djbody-parse-on-load-p + :documentation "Shoul always be true") + (debugp :initarg :is-debug + :reader djbody-debugp + :documentation "Set to true if you want to debug dojo calls") + (load-dojo-js :initarg :load-dojo-js + :reader load-dojo-js + :documentation "When not nil it loads the dojo.js file with a <script> tag") + (djconfig :initarg :djconfig + :reader djbody-djconfig + :documentation "Additional dojo configurations")) + (:metaclass metacomponent) + (:default-initargs :class "" :theme "tundra" + :themes-url (format nil "~a/dojotoolkit/dijit/themes/" (clawserver-base-path (current-server))) + :parse-on-load "true" + :load-dojo-js t + :is-debug nil + :djconfig nil) + (:documentation "This class provide a <body> tag that is enabled for dojo.")) + +(let ((class (find-class 'djbody))) + (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 DJBODY component and renders a html <body> tag enabled for dojo." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod htcomponent-script-files ((o djbody)) + (let ((parse-on-load (djbody-parse-on-load-p o)) + (is-debug (djbody-debugp o)) + (djconfig (djbody-djconfig o))) + (when (load-dojo-js o) + (script> :type "text/javascript" + :src (format nil "~a/dojotoolkit/dojo/dojo.js" (clawserver-base-path (current-server))) + :djconfig (if (null djconfig) + (format nil + "parseOnLoad:~a,usePlainJson:true,isDebug:~a" + parse-on-load is-debug) + (format nil + "parseOnLoad:~a,usePlainJson:true,~a,isDebug:~a" + parse-on-load djconfig is-debug)))))) + + +(defmethod htcomponent-stylesheet-files ((o djbody)) + (let ((theme (djbody-theme o))) + (list + (format nil "~a/dojotoolkit/dojo/resources/dojo.css" (clawserver-base-path (current-server))) + (format nil "~a/dojotoolkit/dijit/themes/dijit.css" (clawserver-base-path (current-server))) + (format nil "~a~a/~a.css" (djbody-themes-url o) theme theme)))) + + +(defmethod djbody-cssclass ((o djbody)) + (format nil "~a ~a" (djbody-theme o) (djbody-class o))) + +(defmethod wcomponent-template ((obj djbody)) + (let ((id "scripts-content-pane") + (pobj (htcomponent-page obj)) + (attributes (append (list :class (djbody-cssclass obj)) + (wcomponent-informal-parameters obj)))) + (build-tagf "body" 'tag nil + attributes + (htcomponent-body obj) + (djxcontent-pane> :static-id id + (script> :type "text/javascript" + (page-body-init-scripts pobj)))))) + + +(defmethod wcomponent-after-prerender ((obj djbody) (pobj page)) + (let ((scripts (page-instance-initscripts pobj))) + ;;remember that scripts are in reverse order + (when scripts + (push "});" (page-instance-initscripts pobj)) + (nconc scripts (list "dojo.addOnLoad\(function\() {"))))) + + Added: trunk/main/dojo/src/djbutton.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djbutton.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,90 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djbutton.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djbutton (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.Button component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.Button")) + +(defclass djdrop-down-button (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.DropDownButton component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.DropDownButton" :dojo-require (list "dijit.form.Button"))) + + +(defclass djcombo-button (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.ComboButton component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.ComboButton" :dojo-require (list "dijit.form.Button"))) + + +(defclass djtoggle-button (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.ToggleButton component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.ToggleButton" :dojo-require (list "dijit.form.Button"))) + + +;;;-------------------------------------------------------- +(defclass djsubmit-button (csubmit) + ((form :initform nil + :accessor djsubmit-button-form)) + (:metaclass metacomponent) + (:documentation "This class is used to render dijit.form.Button that incorporates the logic to be included inside a CFORM component.")) + +(defmethod wcomponent-template ((obj djsubmit-button)) + (let* ((id (htcomponent-client-id obj)) + (value (csubmit-value obj))) + (djbutton> :static-id id + (wcomponent-informal-parameters obj) + value))) + +(defmethod wcomponent-before-prerender ((obj djsubmit-button) (page page)) + (hunchentoot:log-message :info "PRERENDER@@@@@@@@@@@@@@@~a" (page-current-form page)) + (setf (djsubmit-button-form obj) (page-current-form page))) + +(defmethod wcomponent-before-render ((obj djsubmit-button) (page page)) + (hunchentoot:log-message :info "RENDER@@@@@@@@@@@@@@@~a" (page-current-form page)) + (setf (djsubmit-button-form obj) (page-current-form page))) + +(defmethod htcomponent-instance-initscript ((obj djsubmit-button)) + (let ((id (htcomponent-client-id obj)) + (form-id (htcomponent-client-id (djsubmit-button-form obj)))) + (ps* + `(dojo.connect (dijit.by-id ,id) + "onClick" + (lambda (e) (let ((the-form (dijit.by-id ,form-id))) + (unless the-form + (setf the-form (dojo.by-id ,form-id))) + (.submit the-form))))))) Added: trunk/main/dojo/src/djclaw.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djclaw.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,61 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djclaw.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass _djfloating-content (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo claw.FloatingContent component.") + (:default-initargs :dojo-type "claw.FloatingContent")) + +(defclass djfloating-content (wcomponent) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.FloatingContent component.")) + +(defmethod wcomponent-template ((obj djfloating-content)) + (let ((id (htcomponent-client-id obj))) + (list + (djhard-link> :id id :ref-id id) + (_djfloating-content> :static-id id + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))) + +(defclass djhard-link (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo claw.HardLink component.") + (:default-initargs :dojo-type "claw.HardLink")) + +(defclass djrounded (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo claw.Rounded component. Provide bgImg and bgImgAlt \(for msie <= 6)") + (:default-initargs :dojo-type "claw.Rounded")) \ No newline at end of file Added: trunk/main/dojo/src/djcolorpalette.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djcolorpalette.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,37 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djcolorpalette.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djcolor-palette (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.ColorPalette. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.ColorPalette")) + Added: trunk/main/dojo/src/djcontainers.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djcontainers.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,46 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djcontainers.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djaccordion-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.AccordionContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.AccordionContainer")) + +(defclass djaccordion-pane (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.AccordionPane component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.AccordionPane":dojo-require (list "dijit.layout.AccordionContainer"))) + + + + Added: trunk/main/dojo/src/djcontent-pane.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djcontent-pane.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,59 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djcontent-plane.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djxcontent-pane (djwidget) + ((execute-scripts-p :initarg :execute-scripts-p + :reader djcontent-pane-execute-scripts-p + :documentation "When not nil permits to the content pane to evaluate javascript directives") + (render-styles-p :initarg :render-styles-p + :reader djcontent-pane-render-styles-p + :documentation "When not nil permits to the content pane to evaluate style sheet directives")) + (:metaclass metacomponent) + (:documentation "Class for dojo dojox.layout.ContentPane component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dojox.layout.ContentPane" :execute-scripts-p t + :render-styles-p t)) + + +(defmethod wcomponent-template ((obj djxcontent-pane)) + (let ((id (htcomponent-client-id obj)) + (dojo-type (djwidget-dojo-type obj)) + (execute-scripts (if (djcontent-pane-execute-scripts-p obj) + "true" + "false")) + (render-styles (if (djcontent-pane-render-styles-p obj) + "true" + "false"))) + (div> :dojoType dojo-type + :executeScripts execute-scripts + :renderStyles render-styles + :static-id id + (wcomponent-informal-parameters obj) + (htcomponent-body obj)))) Added: trunk/main/dojo/src/djdialog.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djdialog.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,86 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djdialog.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass _djdialog (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Dialog component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.Dialog")) + +(defclass djdialog (wcomponent) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Dialog component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there")) + +(defmethod wcomponent-template ((obj djdialog)) + (let ((id (htcomponent-client-id obj))) + (list + (_djdialog> :static-id id + (wcomponent-informal-parameters obj) + (htcomponent-body obj)) + (djhard-link> :id "hidden" :ref-id id)))) + +(defclass _djdialog-underlay (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.DialogUnderlay component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.DialogUnderlay" :dojo-require (list "dijit.Dialog"))) + +(defclass djdialog-underlay (wcomponent) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.DialogUnderlay component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there")) + +(defmethod wcomponent-template ((obj djdialog-underlay)) + (let ((id (htcomponent-client-id obj))) + (list + (djhard-link> :id id :ref-id id) + (_djdialog-underlay> :static-id id + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))) + + +(defclass _djtooltip-dialog (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.TooltipDialog component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.TooltipDialog" :dojo-require (list "dijit.Dialog"))) + +(defclass djtooltip-dialog (wcomponent) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.TooltipDialog component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there")) + +(defmethod wcomponent-template ((obj djtooltip-dialog)) + (let ((id (htcomponent-client-id obj))) + (_djtooltip-dialog> :static-id id + (wcomponent-informal-parameters obj) + (htcomponent-body obj)))) Added: trunk/main/dojo/src/djform.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djform.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,469 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djform.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djform (cform djwidget) + ((update-id :initarg :update-id + :reader update-id + :documentation "A list of the component id to update") + (ajax-form-p :initarg :ajax-form-p + :reader djform-ajax-form-p + :documentation "When not nil, requests are sent via XHR call.")) + (:metaclass metacomponent) + (:documentation "Class to generate a <form> element that is capable of XHR requests. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "claw.Form" :update-id () :ajax-form-p t)) + +(defmethod wcomponent-template((obj djform)) + (let ((id (htcomponent-client-id obj)) + (method (form-method obj)) + (dojo-type (djwidget-dojo-type obj)) + (update-id (update-id obj))) + (form> :static-id id + :xhr (djform-ajax-form-p obj) + :method method + :dojotype dojo-type + :update-id (when update-id + (let ((js-array (ps* `(array ,update-id)))) + (subseq js-array 0 (1- (length js-array))))) + (wcomponent-informal-parameters obj) + (input> :name *rewind-parameter* + :type "hidden" + :value id) + (htcomponent-body obj)))) + + +(defmethod htcomponent-instance-initscript ((obj djform)) + nil) + +(defclass djtext-box (cinput djwidget) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.TextBox") + (:default-initargs :dojo-type "dijit.form.TextBox" :type "text")) + +(defmethod wcomponent-template ((obj djtext-box)) + (let ((client-id (htcomponent-client-id obj)) + (type (claw::input-type obj)) + (dojo-type (djwidget-dojo-type obj)) + (translator (translator obj)) + (value "") + (class (claw::css-class obj))) + (when (component-validation-errors obj) + (if (or (null class) (string= class "")) + (setf class "dijitError") + (setf class (format nil "~a dijitError" class)))) + (setf value (translator-encode translator obj)) + (input> :static-id client-id + :type type + :dojoType dojo-type + :name client-id + :class class + :value value + (wcomponent-informal-parameters obj)))) + +(defclass djtextarea (ctextarea djwidget) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.Textarea") + (:default-initargs :dojo-type "dijit.form.Textarea" :tag-name "textarea")) + +(defmethod wcomponent-template ((obj djtextarea)) + (let ((client-id (htcomponent-client-id obj)) + (tag-name (djwidget-tag-name obj)) + (dojo-type (djwidget-dojo-type obj)) + (translator (translator obj)) + (value "") + (class (claw::css-class obj))) + (when (component-validation-errors obj) + (if (or (null class) (string= class "")) + (setf class "dijitError") + (setf class (format nil "~a dijitError" class)))) + (setf value (translator-encode translator obj)) + (if (string-equal tag-name "textarea") + (textarea> :static-id client-id + :dojoType dojo-type + :name (name-attr obj) + :class class + (wcomponent-informal-parameters obj) + (or (when value ($raw> value)) (htcomponent-body obj))) + (let ((tag-name (djwidget-tag-name obj)) + (parameters (nconc (list :static-id (htcomponent-client-id obj) + :dojo-type (djwidget-dojo-type obj) + :name (name-attr obj)) + (djwidget-formal-parameters obj)))) + (build-tagf tag-name + 'tag + (not (null (find tag-name *empty-tags*))) + (list + parameters + (wcomponent-informal-parameters obj) + (or (when value ($raw> value)) + (htcomponent-body obj)))))))) + + +(defclass djsimple-textarea (djtextarea) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.SimpleTextarea") + (:default-initargs :dojo-type "dijit.form.SimpleTextarea" :type "text")) + +(defclass djvalidation-text-box (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.ValidationTextBox") + (:default-initargs :dojo-type "dijit.form.ValidationTextBox" :type "text" + :dojo-require (list "dijit.form.ValidationTextBox"))) + +(defclass djmapped-text-box (djvalidation-text-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a DJVALIDATION-TEXT-BOX, but is used to render a dojo dijit.form.MappedTextBox") + (:default-initargs :dojo-type "dijit.form.MappedTextBox")) + +(defclass djrange-bound-text-box (djvalidation-text-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a DJVALIDATION-TEXT-BOX, but is used to render a dojo dijit.form.RangeBoundTextBox") + (:default-initargs :dojo-type "dijit.form.RangeBoundTextBox")) + +(defclass djnumber-text-box (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.NumberTextBox") + (:default-initargs :dojo-type "dijit.form.NumberTextBox" :type "text")) + +(defclass djnumber-spinner (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.NumberSpinner") + (:default-initargs :dojo-type "dijit.form.NumberSpinner" :type "text")) + +(defclass djcheck-box (ccheckbox djwidget) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CCHECKBOX, but is used to render a dojo dijit.form.CheckBox") + (:default-initargs :dojo-type "dijit.form.CheckBox")) + +(defmethod wcomponent-template ((cinput djcheck-box)) + (let* ((client-id (htcomponent-client-id cinput)) + (dojo-type (djwidget-dojo-type cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (current-value (translator-type-to-string translator cinput)) + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :dojoType dojo-type + :name (name-attr cinput) + :class class + :value value + :checked (when (and current-value (equal value current-value)) "checked") + (wcomponent-informal-parameters cinput)))) + +(defclass djradio-button (cradio djwidget) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CRADIO, but is used to render a dojo dijit.form.CheckBox") + (:default-initargs :dojo-type "dijit.form.RadioButton" :dojo-require (list "dijit.form.CheckBox"))) + +(defmethod wcomponent-template ((cinput djradio-button)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (dojo-type (djwidget-dojo-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (current-value (translator-type-to-string translator cinput)) + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :dojoType dojo-type + :name (name-attr cinput) + :class class + :value value + :checked (when (and current-value (equal value current-value)) "checked") + (wcomponent-informal-parameters cinput)))) + +(defclass djcombo-box (cinput djwidget) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CSELECT, but is used to render a dojo dijit.form.ComboBox") + (:default-initargs :dojo-type "dijit.form.ComboBox" :multiple nil)) + +(defmethod wcomponent-template ((obj djcombo-box)) + (let ((client-id (htcomponent-client-id obj)) + (dojo-type (djwidget-dojo-type obj)) + (translator (translator obj)) + (value "") + (class (claw::css-class obj))) + (when (component-validation-errors obj) + (if (or (null class) (string= class "")) + (setf class "dijitError") + (setf class (format nil "~a dijitError" class)))) + (setf value (translator-encode translator obj)) + (select> :static-id client-id + :dojoType dojo-type + :name client-id + :class class + :value value + :multiple (cinput-result-as-list-p obj) + (wcomponent-informal-parameters obj) + (htcomponent-body obj)))) + +(defclass djmulti-select (djcombo-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a DJVALIDATION-TEXT-BOX, but is used to render a dojo dijit.form.MultiSelect") + (:default-initargs :dojo-type "dijit.form.MultiSelect" :multiple t)) + +(defclass djfiltering-select (djcombo-box) + ((onchange :initarg :onchange)) + (:metaclass metacomponent) + (:documentation "This class inherits from a CSELECT, but is used to render a dojo dijit.form.FilteringSelect") + (:default-initargs :dojo-type "dijit.form.FilteringSelect")) + +(defclass djinline-edit-box (cinput djwidget) + ((autosavep :initarg :autosavep + :reader djinline-edit-box-autosavep + :documentation "Changing the value automatically saves it; don't have to push save button \(and save button isn't even displayed)") + (button-save :initarg :button-save + :reader djinline-edit-box-button-save + :documentation "Save button label") + (button-cancel :initarg :button-cancel + :reader djinline-edit-box-button-cancel + :documentation "Cancel button label") + (render-as-html :initarg :render-as-html + :accessor djinline-edit-box-render-as-html + :documentation "Set this to true if the specified Editor's value should be interpreted as HTML rather than plain text \(ie, dijit.Editor)") + (editor :initarg :editor + :reader djinline-edit-box-editor + :documentation "The widget used to edit the value")) + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.InLineEditBox. More info at http://api.dojotoolkit.org/") + (:default-initargs :empty t :dojo-type "dijit.InlineEditBox" + :tag-name "span" + :autosavep t + :button-save nil + :button-cancel nil + :render-as-html nil + :editor "dijit.form.TextBox")) + +(defmethod wcomponent-template ((obj djinline-edit-box)) + (let ((id (htcomponent-client-id obj)) + (tag-name (djwidget-tag-name obj)) + (auto-save (if (djinline-edit-box-autosavep obj) "true" "false")) + (button-save (djinline-edit-box-button-save obj)) + (button-cancel (djinline-edit-box-button-cancel obj)) + (render-as-html (if (djinline-edit-box-render-as-html obj) "true" "false")) + (editor (djinline-edit-box-editor obj)) + (value "")) + (build-tagf tag-name + 'tag nil + :static-id id + :value value + :autosave auto-save + :buttonsave button-save + :buttoncancel button-cancel + :renderashtml render-as-html + :editor editor + (wcomponent-informal-parameters obj)))) + +(defmethod htcomponent-instance-initscript((obj djinline-edit-box)) + (let ((id (htcomponent-client-id obj)) + (page-url (page-url (htcomponent-page obj)))) + (ps* `(dojo.connect (dijit.by-id ,id) + "onChange" + (lambda (e) (dojo.xhrPost (create :url ,page-url + :error (lambda (data) (console.error data)) + :timeout 2000 + :handle-as "json" + :content (create :json (array) + ,*rewind-parameter* ,id)))))))) + +(defclass djdate-text-box (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.DateTextBox") + (:default-initargs :dojo-type "dijit.form.DateTextBox" :type "text" + :translator *date-translator-ymd*)) + + +(defclass djtime-text-box (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.DateTextBox") + (:default-initargs :dojo-type "dijit.form.TimeTextBox" :type "text" + :translator *date-translator-time*)) + +(defclass djcalendar (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit._Calendar") + (:default-initargs :dojo-type "dijit._Calendar" :dojo-require (list "dijit._Calendar" "dojo.date.locale") + :type "text" + :translator *date-translator-ymd*)) + + +(defclass djcurrency-text-box (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT, but is used to render a dojo dijit.form.CurrencyTextBox") + (:default-initargs :dojo-type "dijit.form.CurrencyTextBox" :type "text")) + + +(defclass _djslider (djwidget) + () + (:metaclass metacomponent) + (:documentation "Base class to map dojo dijit.form.Slider. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-require (list "dijit.form.Slider"))) + +(defclass _djslider-slider (cinput _djslider) + () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :value :name) :translator *number-translator*) + (:documentation "Base class to map dojo dijit.form.HorizontalSlider and dijit.form.VerticalSlider. More info at http://api.dojotoolkit.org/")) + +(defmethod wcomponent-template ((_djslider-slider _djslider-slider)) + (let ((client-id (htcomponent-client-id _djslider-slider)) + (translator (translator _djslider-slider)) + (value "") + (class (css-class _djslider-slider))) + (when (component-validation-errors _djslider-slider) + (if (or (null class) (string= class "")) + (setf class "dijitError") + (setf class (format nil "~a dijitError" class)))) + (setf value (translator-encode translator _djslider-slider)) + (div> :static-id client-id + :dojoType (djwidget-dojo-type _djslider-slider) + :value value + :class class + :name (name-attr _djslider-slider) + (wcomponent-informal-parameters _djslider-slider) + (htcomponent-body _djslider-slider)))) + +(defclass djhorizontal-slider (_djslider-slider) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.HorizontalSlider. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.HorizontalSlider")) + +(defclass djhorizontal-rule (_djslider) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.HorizontalRule. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.HorizontalRule")) + +(defclass djhorizontal-rule-labels (_djslider) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.HorizontalRuleLabels. Renders like an <ol> tag element, so put +<li> tag elements inside. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.HorizontalRuleLabels" :tag-name "ol")) + +(defclass djvertical-slider (_djslider-slider) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.VerticalSlider. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.VerticalSlider")) + +(defclass djvertical-rule (_djslider) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.VerticalRule. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.VerticalRule")) + +(defclass djvertical-rule-labels (_djslider) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.form.VerticalRuleLabels. Renders like an <ol> tag element, so put +<li> tag elements inside. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.form.VerticalRuleLabels" :tag-name "ol")) + +(defclass djtext-box-file (djtext-box) + () + (:metaclass metacomponent) + (:documentation "This class inherits from a CINPUT of type \"file\", but is used to render a dojo dijit.form.DateTextBox") + (:default-initargs :dojo-type "dojox.widget.FileInput" :type nil + :translator *file-translator*)) + +(defmethod htcomponent-stylesheet-files((djtext-box-file djtext-box-file)) + (list (format nil "~a/dojotoolkit/dojox/widget/FileInput/FileInput.css" (clawserver-base-path (current-server))))) + +(defclass djeditor (djtextarea) + ((form :initform nil + :accessor djeditor-form)) + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "claw.Editor" :tag-name "div")) + +(defclass djeditor-plugins-always-show-toolbar (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit._editor.plugins.AlwaysShowToolbar" :tag-name nil)) + +(defclass djeditor-plugins-enter-key-handling (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit._editor.plugins.EnterKeyHandling" :tag-name nil)) + +(defclass djeditor-plugins-font-choice (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit._editor.plugins.FontChoice" :tag-name nil)) + +(defclass djeditor-plugins-link-dialog (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit._editor.plugins.LinkDialog" :tag-name nil)) + +(defclass djeditor-plugins-text-color (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit._editor.plugins.TextColor" :tag-name nil)) + +(defclass djeditor-plugins-toggle-dir (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Editor. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit._editor.plugins.ToggleDir" :tag-name nil)) + Added: trunk/main/dojo/src/djlayout.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djlayout.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,101 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djcontainers.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djaccordion-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.AccordionContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.AccordionContainer")) + +(defclass djaccordion-pane (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.AccordionPane component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.AccordionPane":dojo-require (list "dijit.layout.AccordionContainer"))) + +(defclass djborder-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.BorderContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.BorderContainer")) + +(defclass djcontent-pane (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.ContentPane component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.ContentPane")) + +(defclass djlayout-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.LayoutContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.LayoutContainer")) + +(defclass djlink-pane (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.LinkPane component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.LinkPane")) + +(defclass djsplit-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.SplitContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.SplitContainer")) + +(defclass djstack-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.StackContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.StackContainer")) + +(defclass djstack-controller (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.StackController component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.StackController" :dojo-require (list "dijit.layout.StackContainer"))) + +(defclass djtab-container (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.TabContainer component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.TabContainer")) + +(defclass djtab-controller (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.layout.TabController component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.layout.TabController" :dojo-require (list "dijit.layout.TabContainer"))) + + + + + Added: trunk/main/dojo/src/djlink.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djlink.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,63 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djlink.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djaction-link (action-link djwidget) + ((update-id :initarg :update-id + :reader update-id + :documentation "A list of the component id to update")) + (:metaclass metacomponent) + (:documentation "Class that extends ACTION-LINK to handle XHR requests.") + (:default-initargs :dojo-type "dijit.form.Form" :update-id ())) + +(defmethod wcomponent-template((o djaction-link)) + (let ((client-id (htcomponent-client-id o))) + (a> :static-id client-id + :href "#" + (wcomponent-informal-parameters o) + (htcomponent-body o)))) + + +(defmethod htcomponent-instance-initscript((obj djaction-link)) + (let ((id (htcomponent-client-id obj)) + (page-url (page-url (htcomponent-page obj))) + (update-id-list (update-id obj))) + (ps* + `(dojo.connect (dojo.by-id ,id) + "onclick" + (lambda (e) (progn + (e.prevent-default) + (dojo.xhr-post (create :url ,page-url + :load (lambda (data) (claw.update-and-eval data)) + :error (lambda (data) (console.error data)) + :timeout 2000 + :handle-as "json" + :content (create :json (array ,update-id-list) + ,*rewind-parameter* ,id))))))))) Added: trunk/main/dojo/src/djmenu.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djmenu.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,55 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djmenu.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + + +(defclass djmenu (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Menu. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.Menu")) + +(defclass djmenu-item (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.MenuItem. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.MenuItem" :dojo-require (list "dijit.Menu"))) + +(defclass djmenu-separator (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.MenuSeparator. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.MenuSeparator" :dojo-require (list "dijit.Menu"))) + +(defclass djpopup-menu-item (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.PopupMenuItem. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.PopupMenuItem" :dojo-require (list "dijit.Menu"))) Added: trunk/main/dojo/src/djprogressbar.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djprogressbar.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,39 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djprogressbar.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djprogress-bar (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.ProgressBar. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.ProgressBar")) + + + Added: trunk/main/dojo/src/djtitlepane.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djtitlepane.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,37 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djtitlepane.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djtitle-pane (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.TitlePane. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.TitlePane")) + Added: trunk/main/dojo/src/djtoolbar.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djtoolbar.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,43 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djtoolbar.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djtoolbar (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Toolbar. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.Toolbar")) + +(defclass djtoolbar-separator (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.ToolbarSeparator. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.ToolbarSeparator")) + Added: trunk/main/dojo/src/djtooltip.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djtooltip.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,49 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djtooltip.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass _djtooltip (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Tooltip component. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.Tooltip")) + +(defclass djtooltip (wcomponent) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Tooltip component. More info at http://api.dojotoolkit.org/. It adds a HardLink so that the Dialog, that is moved inside body, may be referenced where it war originally placed, and so can be deleted from there")) + +(defmethod wcomponent-template ((obj djtooltip)) + (let ((id (htcomponent-client-id obj))) + (list + (djhard-link> :ref-id id) + (_djtooltip> :static-id id + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))) Added: trunk/main/dojo/src/djtree.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djtree.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,39 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djtree.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defclass djtree (djwidget) + () + (:metaclass metacomponent) + (:documentation "Class for dojo dijit.Toolbar. More info at http://api.dojotoolkit.org/") + (:default-initargs :dojo-type "dijit.Tree")) + + + Added: trunk/main/dojo/src/djwidget.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/djwidget.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,81 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/djwidget.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defgeneric djwidget-formal-parameters (djwidget) + (:documentation "list of html attributes defined by widget slots")) + +(defclass djwidget (wcomponent) + ((tag-name :initarg :tag-name + :reader djwidget-tag-name + :documentation "The HTML tag element that will be rendered") + (dojo-type :initarg :dojo-type + :reader djwidget-dojo-type + :documentation "The type of the dojo element, it will be added as dojoType HTML custom tag attribute") + (dojo-rquire :initarg :dojo-require + :reader djwidget-dojo-require + :documentation "A list of addictional dojo reqirements")) + (:metaclass metacomponent) + (:default-initargs :tag-name "div" :dojo-require nil) + (:documentation "Base class to render dojo widgets")) + +(let ((class (find-class 'djwidget))) + (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 DJWIDGET component and renders a html tag enabled for dojo whose name is provided by the :TAG-NAME keyword and the dojo widget by :DOJO-TYPE." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod djwidget-formal-parameters ((djwidget djwidget))()) + +(defmethod htcomponent-class-initscripts ((obj djwidget)) + (let ((dojo-type (djwidget-dojo-type obj)) + (dojo-require (djwidget-dojo-require obj))) + (append + (list (ps* `(dojo.require "dojo.parser"))) + (unless dojo-require + (list (ps* `(dojo.require ,dojo-type)))) + (loop for require in dojo-require + collect (ps* `(dojo.require ,require)))))) + +(defmethod wcomponent-template ((obj djwidget)) + (let ((tag-name (djwidget-tag-name obj))) + (when tag-name + (let ((parameters (nconc (list :static-id (htcomponent-client-id obj) :dojo-type (djwidget-dojo-type obj)) + (djwidget-formal-parameters obj)))) + (build-tagf tag-name + 'tag + (not (null (find tag-name *empty-tags*))) + (list + parameters + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))))) Added: trunk/main/dojo/src/misc.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/misc.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,43 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/misc.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :dojo) + +(defvar *dojo-misc-file* (load-time-value + (or #.*compile-file-pathname* *load-pathname*))) + +(defun djuser-locale () + (substitute #\- #\_ (string-downcase (user-locale)))) + +(register-library-resource "dojotoolkit/" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("dojotoolkit")))) +(register-library-resource "dojotoolkit/claw/HardLink.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "HardLink" :type "js")) +(register-library-resource "dojotoolkit/claw/FloatingContent.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "FloatingContent" :type "js")) +(register-library-resource "dojotoolkit/claw/Rounded.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Rounded" :type "js")) +(register-library-resource "dojotoolkit/claw/Form.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Form" :type "js")) +(register-library-resource "dojotoolkit/claw/Editor.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "Editor" :type "js")) Added: trunk/main/dojo/src/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/src/packages.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,185 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/src/packages.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :claw-dojo + (:nicknames :dojo) + (:use :cl :claw :parenscript) + (:export :*dojo-directory-name* + :djuser-locale + :djwidget-dojo-type + :djwidget-dojo-require + :djwidget + :djwidget> + :djwidget-formal-parameters + :djxcontent-pane + :djxcontent-pane> + :djbody + :djbody> + ;;dijit namespace + :djbackground-iframe + :djbackground-iframe> + :djcolor-palette + :djcolor-palette> + :djdialog + :djdialog> + :djdialog-underlay + :djdialog-underlay> + :djeditor + :djeditor> + :djeditor-plugins-always-show-toolbar + :djeditor-plugins-always-show-toolbar> + :djeditor-plugins-enter-key-handling + :djeditor-plugins-enter-key-handling> + :djeditor-plugins-font-choice + :djeditor-plugins-font-choice> + :djeditor-plugins-link-dialog + :djeditor-plugins-link-dialog> + :djeditor-plugins-text-color + :djeditor-plugins-text-color> + :djeditor-plugins-toggle-dir + :djeditor-plugins-toggle-dir> + :djinline-edit-box + :djinline-edit-box> + :djmenu + :djmenu> + :djmenu-item + :djmenu-item> + :djmenu-separator + :djmenu-separator> + :djpopup-menu-item + :djpopup-menu-item> + :djprogress-bar + :djprogress-bar> + :djtitle-pane + :djtitle-pane> + :djtoolbar + :djtoolbar> + :djtoolbar-separator + :djtoolbar-separator> + :djtooltip + :djtooltip> + :djtooltip-dialog + :djtooltip-dialog> + :djtree + :djtree> + ;;dijit.form namespace + :djbutton + :djbutton> + :djsubmit-button + :djsubmit-button> + :djcheck-box + :djcheck-box> + :djcombo-box + :djcombo-box> + :djcombo-button + :djcombo-button> + :djcurrency-text-box + :djcurrency-text-box> + :djdate-text-box + :djdate-text-box> + :djcalendar + :djcalendar> + :djdrop-down-button + :djdrop-down-button> + :djfiltering-select + :djfiltering-select> + :djform + :djform> + :djhorizontal-rule + :djhorizontal-rule> + :djhorizontal-rule-labels + :djhorizontal-rule-labels> + :djhorizontal-slider + :djhorizontal-slider> + :djmapped-text-box + :djmapped-text-box> + :djmulti-select + :djmulti-select> + :djnumber-spinner + :djnumber-spinner> + :djnumber-text-box + :djnumber-text-box> + :djradio-button + :djradio-button> + :djrange-bound-text-box + :djrange-bound-text-box> + :djsimple-textarea + :djsimple-textarea> + :djtextarea + :djtextarea> + :djtext-box + :djtext-box> + :djtime-text-box + :djtime-text-box> + :djtoggle-button + :djtoggle-button> + :djvalidation-text-box + :djvalidation-text-box> + :djvertical-rule + :djvertical-rule> + :djvertical-rule-labels + :djvertical-rule-labels> + :djvertical-slider + :djvertical-slider> + :djaction-link + :djaction-link> + :djtext-box-file + :djtext-box-file> + ;;dijit.layout namespace + :djaccordion-container + :djaccordion-container> + :djaccordion-pane + :djaccordion-pane> + :djborder-container + :djborder-container> + :djcontent-pane + :djcontent-pane> + :djlayout-container + :djlayout-container> + :djlink-pane + :djlink-pane> + :djsplit-container + :djsplit-container> + :djstack-container + :djstack-container> + :djstack-controller + :djstack-controller> + :djtab-container + :djtab-container> + :djtab-controller + :djtab-controller> + ;;claw namespace + :djfloating-content + :djfloating-content> + :djhard-link + :djhard-link> + :djrounded + :djrounded>)) Added: trunk/main/dojo/tests/ajax-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/ajax-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,285 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/ajax-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + +(defgeneric display-btn (pobj)) +(defgeneric read-message (pobj)) +(defgeneric write-message (pobj value)) + + +(defclass ajax-page (page) + ((display-btn-p :initform nil + :accessor ajax-page-display-btn-p) + (name :initform "" + :accessor ajax-page-name) + (surname :initform "" + :accessor ajax-page-surname) + (combo-message :initform "" + :accessor ajax-page-country) + (cardinal-point :initform "NE" + :accessor ajax-page-cardinal-point) + (lisper :initform nil + :accessor ajax-page-lisper) + (color :initform "red" + :accessor ajax-page-color) + (date :initform (local-time:now) + :accessor ajax-page-date) + (time :initform (local-time:now) + :accessor ajax-page-time) + (wallet :initform 50.25 + :accessor ajax-page-wallet) + (year :initform 2000 + :accessor ajax-page-year) + (file :initform nil + :accessor ajax-page-inputfile))) + +(defclass simpledjbutton (djbutton) + () + (:metaclass metacomponent)) + +(defclass ajax-exception-monitor (exception-monitor) + () + (:metaclass metacomponent)) + +(defmethod wcomponent-template ((obj ajax-exception-monitor)) + (exception-monitor> :static-id (htcomponent-client-id obj) + (let ((errors (validation-errors)) + (dialog-id (format nil "~aDialog" (htcomponent-client-id obj)))) + (div> :render-condition #'(lambda() errors) + (list + (djbutton> :id "id" :onclick (ps* `(.show (dijit.by-id ,dialog-id))) + "Validation errors") + (style> (format nil "#~a .dijitError {border-color:#f3d118;background-color:#f9f7ba;color:red;}" dialog-id)) + (djdialog> :static-id dialog-id + ;:open "true" + :title "Validation errors" + (loop for (component-id reasons) on errors by #'cddr + collect (loop for reason in reasons + collect (p> reason))))))))) + +(defmethod htcomponent-instance-initscript ((obj ajax-exception-monitor)) + (let ((errors (validation-errors)) + (dialog-id (format nil "~aDialog" (htcomponent-client-id obj)))) + (when errors + (ps* `(let ((dialog (dijit.by-id ,dialog-id))) + (dojo.add-class (slot-value dialog 'container-node) "dijitError") + (.show dialog)))))) + + +(defmethod htcomponent-instance-initscript ((obj simpledjbutton)) + (let ((id (htcomponent-client-id obj)) + (pobj (htcomponent-page obj))) + (ps* `(dojo.connect (dijit.by-id ,id) + "onClick" + nil + (lambda () (alert (+ "Hello " + ,(ajax-page-name pobj) + " " + ,(ajax-page-surname pobj) + " from " + ,(ajax-page-country pobj) + "!\\nYour preferred color is " + ,(ajax-page-color pobj) + "\\nDirection taken --> " + ,(ajax-page-cardinal-point pobj)))))))) + +(defmethod display-btn ((pobj ajax-page)) + (setf (ajax-page-display-btn-p pobj) t)) + +(defvar *integet-translator* (make-instance 'translator-integer)) + +(defmethod page-content ((pobj ajax-page)) + (let ((dyna-content-id (generate-id "dynacontent")) + (spinner-id (generate-id "spinner")) + (djbutton-id (generate-id "djbutton")) + (path-file-mimetype (ajax-page-inputfile pobj))) + (site-template> :title "dojo ajax test page" + (style> "table td {text-align: right; vertical-align: top;} +td.left {text-align: left;} +td p {margin: 0.25em;} +.colorInput, .colorBox {float: left; position: relative; } +.colorBox {display: block; margin-right: 10px; height: 1em; width: 1em; border: 1px solid gray;}") + (p> + (div> :static-id dyna-content-id + (div> :render-condition #'(lambda () (ajax-page-display-btn-p pobj)) + (simpledjbutton> :id djbutton-id (span> "Show message")) + (div> :render-condition #'(lambda () path-file-mimetype) + :style "border: 1px solid gray;" + (third path-file-mimetype)))) + (div> + (action-link> :id "alink" + :action 'display-btn + "display") + "|" + (djaction-link> :id "djlink" + :action 'display-btn + :update-id (list dyna-content-id) + "ajax display") + (djform> :id "djform" + :enctype "multipart/form-data" + :ajax-form-p t + :method "post" + :action 'display-btn + :update-id (list dyna-content-id) + :on-before-submit (ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (ps* `(.hide (dijit.by-id ,spinner-id))) + (table> + (tr> + (td> "Name") + (td> :class "left" + (djvalidation-text-box> :id "name" + :label "Name" + :required "true" + :accessor 'ajax-page-name + :validator #'(lambda (value) + (validate-required (page-current-component pobj) value))))) + + (tr> + (td> "Surname") + (td> :class "left" + (djtext-box> :id "surname" + :label "Surname" + :accessor 'ajax-page-surname + :validator #'(lambda (value) + (validate-required (page-current-component pobj) value))))) + (tr> + (td> "Country") + (td> :class "left" + (djcombo-box> :id "country" + :accessor 'ajax-page-country + :label "Country" + :validator #'(lambda (value) + (validate-required (page-current-component pobj) value)) + (option> :value "FR" "France") + (option> :value "IT" "Italy") + (option> :value "US" "USA") + (option> :value "ES" "Spain")) + (p> + "djcombo-box allow to insert even non expected values.") + (p> :style "margin-bottom: .75em;" + "The passed parameter value is the one typed"))) + (tr> + (td> "Cardinal point") + (td> :class "left" + (djfiltering-select> :id "cardinal" + :accessor 'ajax-page-cardinal-point + :label "Cardinal point" + :validator #'(lambda (value) + (validate-required (page-current-component pobj) value)) + (option> :value "N" "North") + (option> :value "NE" "North-East") + (option> :value "E" "East") + (option> :value "SE" "South-East") + (option> :value "S" "South") + (option> :value "SW" "South-West") + (option> :value "W" "West") + (option> :value "NW" "North-West")) + (p> + "djfiltring-select doesn't allow to insert non expected values.") + (p> :style "margin-bottom: .75em;" + "The value submitted with the form is the hidden value (ex: NE), not the displayed value a.k.a. label (ex: North-East)"))) + (tr> + (td> "Year") + (td> :class "left" + (djnumber-spinner> :id "year" + :label "Year" + :pattern "####" + :constraints "{min:2000,max:2100}" + :translator *integet-translator* + :accessor 'ajax-page-year + :validator #'(lambda (value) + (validate-required (page-current-component pobj) value))))) + (tr> + (td> "Date") + (td> :class "left" + (djdate-text-box> :id "date" + :label "Date" + :accessor 'ajax-page-date))) + (tr> + (td> "Time") + (td> :class "left" + (djtime-text-box> :id "time" + :label "Time" + :accessor 'ajax-page-time))) + (tr> + (td> "Wallet") + (td> :class "left" + (djcurrency-text-box> :id "wallet" + :label "Wallet" + :currency "€" + :accessor 'ajax-page-wallet))) + (tr> + (td> "Lisper") + (td> :class "left" + (djcheck-box> :id "lisper" + :label "Lisper" + :translator *boolean-translator* + :accessor 'ajax-page-lisper + :value T + :validator #'(lambda (value) + (validate-required (page-current-component pobj) value :message "You must be a lisper to submit data!"))))) + (tr> + (td> "Preferred color") + (td> :class "left" + (djradio-button> :id "color" + :class "colorInput" + :label "Color" + :accessor 'ajax-page-color + :value "red") + (span> :style "background: red;" :class "colorBox") + (djradio-button> :id "color" + :class "colorInput" + :label "Color" + :accessor 'ajax-page-color + :value "green") + (span> :style "background: green;" :class "colorBox") + (djradio-button> :id "color" + :class "colorInput" + :label "Color" + :accessor 'ajax-page-color + :value "blue") + (span> :style "background: blue;" :class "colorBox"))) + (tr> + (td> "Text file") + (td> :class "left" + (djtext-box-file> :id "inputFile" + :label "File" + :accessor 'ajax-page-inputfile)))) + (submit-link> :id "slink" + :action 'display-btn + "update link") + (djsubmit-button> :id "submitButton" :value "Update") + (ajax-exception-monitor> :id "exceptionMonitor")) + (djfloating-content> :static-id spinner-id + (img> :alt "spinner" + :src (format nil "~a/docroot/img/spinner.gif" (build-lisplet-location (current-lisplet)))))))))) + + +(lisplet-register-page-location *dojo-test-lisplet* 'ajax-page "ajax.html") \ No newline at end of file Added: trunk/main/dojo/tests/common.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/common.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,56 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/common.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + +(defclass site-template (wcomponent) + ((title :initarg :title + :reader site-template-title) + (djconfig :initarg :djconfig + :reader site-template-djconfig)) + (:metaclass metacomponent) + (:default-initargs :djconfig nil)) + +(defmethod wcomponent-template ((o site-template)) + (html> + (head> + ;;(meta> :HTTP-EQUIV "expires" :CONTENT "Wed, 26 Feb 2100 08:21:57 GMT") + (title> (site-template-title o)) + (link> :href (format nil "~a/docroot/css/style.css" (build-lisplet-location (current-lisplet))) + :rel "stylesheet" + :type "text/css")) + (djbody> :is-debug "false" + :djconfig (site-template-djconfig o) + (p> + (a> :href "../test/index.html" "home") + (p> + " Current language \"" + (djuser-locale) "\"")) + (wcomponent-informal-parameters o) + (htcomponent-body o)))) Added: trunk/main/dojo/tests/djbutton-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djbutton-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,75 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djbutton-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass djbutton-page (page) ()) + +(defmethod page-content ((o djbutton-page)) + (site-template> :title "dojo buttons test page" + (p> + (djbutton> :id "djbutton" + (span> "djbutton")) + (djdrop-down-button> :id "djddbutton" + (span> "djdropdown-button") + (djmenu> :id "menu" + (djmenu-item> :id "menu" + :iconclass "dijitEditorIcon dijitEditorIconCopy" + "copy") + (djmenu-item> :id "menu" + :iconclass "dijitEditorIcon dijitEditorIconCut" + "cut") + (djmenu-item> :id "menu" + :iconclass "dijitEditorIcon dijitEditorIconPaste" + "paste"))) + (djcombo-button> :id "djComboButton" + :optionstitle "save options" + :iconclass "plusBlockIcon" + (span> "combo button") + (djmenu> :id "menu" + (djmenu-item> :id "menu" + :iconClass "dijitEditorIcon dijitEditorIconSave" + :onclick "alert('save')" + "save") + (djmenu-item> :id "menu" + :iconClass "dijitEditorIcon dijitEditorIconSave" + :onclick "alert('save as')" + "save as"))) + (djtoggle-button> :id "djToggleButtonCheck" + :iconclass "dijitCheckBoxIcon" + :onchange "console.log('toggled button checked='+arguments[0]);" + "Toggle me") + (djtoggle-button> :id "djToggleButtonRadio" + :iconclass "dijitRadioIcon" + :onchange "console.log('toggled button checked='+arguments[0]);" + "Toggle me")))) + + +(lisplet-register-page-location *dojo-test-lisplet* 'djbutton-page "djbutton.html") \ No newline at end of file Added: trunk/main/dojo/tests/djcalendar-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djcalendar-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,87 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djcalendar-tests.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + +(defgeneric djcalendar-page-null-action (page)) + +(defclass djcalendar-page (page) + ((cal1 :initarg :cal1 + :accessor djcalendar-page-cal1) + (cal2 :initarg :cal2 + :accessor djcalendar-page-cal2) + (cal3 :initarg :cal3 + :accessor djcalendar-page-cal3) + (cal4 :initarg :cal4 + :accessor djcalendar-page-cal4) + (cal-local :initarg :cal-local + :accessor djcalendar-page-cal-local)) + (:default-initargs :cal1 (local-time:now) :cal2 (local-time:now) + :cal3 (local-time:now) + :cal4 (local-time:now) + :cal-local (local-time:now))) + +(defmethod djcalendar-page-null-action ((o djcalendar-page))) + +(defmethod page-content ((o djcalendar-page)) + (let ((lang (djuser-locale)) + (dates-container-id (generate-id "datesContainer"))) + (site-template> :title "dojo calendar test page" + :djconfig (format nil "extraLocale:['en-us','es-es', 'ar-sy', 'zh-cn', '~a']" lang) + (djform> :id "theForm" :update-id (list dates-container-id) + (div> :static-id dates-container-id + (p> + (h1> "en-en" " encoding") + (djdate-text-box> :id "cal" :lang "en-us" + :accessor 'djcalendar-page-cal1) + (span> (translator-value-type-to-string *date-translator-ymd* (djcalendar-page-cal1 o)))) + (p> + (h1> "es-es" " encoding") + (djdate-text-box> :id "cal" :lang "es-es" + :accessor 'djcalendar-page-cal2) + (span> (translator-value-type-to-string *date-translator-ymd* (djcalendar-page-cal2 o)))) + (p> + (h1> "zh-cn" " encoding") + (djdate-text-box> :id "cal" :lang "zh-cn" + :accessor 'djcalendar-page-cal3) + (span> (translator-value-type-to-string *date-translator-ymd* (djcalendar-page-cal3 o)))) + (p> + (h1> "ar-sy" " encoding") + (djdate-text-box> :id "cal" :lang "ar-sy" + :accessor 'djcalendar-page-cal4) + (span> (translator-value-type-to-string *date-translator-ymd* (djcalendar-page-cal4 o)))) + (p> + (h1> "Local encoding") + (djdate-text-box> :id "cal" :lang lang + :accessor 'djcalendar-page-cal-local) + (span> (translator-value-type-to-string *date-translator-ymd* (djcalendar-page-cal-local o))))) + (p> + (djsubmit-button> :id "submitDates" :value "Submit dates")))))) + +(lisplet-register-page-location *dojo-test-lisplet* 'djcalendar-page "djcalendar.html") \ No newline at end of file Added: trunk/main/dojo/tests/djcolorpalette-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djcolorpalette-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,51 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djcolorpalette-tests.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass djcolorpalette-page (page) ()) + +(defmethod page-content ((o djcolorpalette-page)) + (let ((dialog (djdialog> :id "dialog" + :title "Color Palette!" + (djcolor-palette>)))) + (site-template> :title "dojo buttons test page" + (p> + (djbutton> :id "djbutton" + :onclick (format nil "dijit.byId('~a').show()" (htcomponent-client-id dialog)) + (span> "show color paette dialog")) + (djdropdown-button> + (span> "tooltip dialog") + (djtooltip-dialog> :id "dialog" + :title "HELLO!" + (djcolor-palette>))) + dialog)))) + +(lisplet-register-page-location *dojo-test-lisplet* 'djcolorpalette-page "djcolorpalette.html") \ No newline at end of file Added: trunk/main/dojo/tests/djdialog-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djdialog-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,67 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djdialog-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass djdialog-page (page) ()) + +(defmethod page-content ((o djdialog-page)) + (let ((dialog (djdialog> :id "dialog" + :title "HELLO!" + (span> ($> "hello world")))) + (no-title-dialog-id (generate-id "ntId")) + (lisplet-path (build-lisplet-location (current-lisplet)))) + (site-template> :title "dojo buttons test page" + (p> + (djbutton> :id "djbutton" + :onclick (format nil "dijit.byId('~a').show()" + (htcomponent-client-id dialog)) + (span> "show dialog")) + (djdrop-down-button> :id "ddButton" + (span> "tooltip dialog") + (djtooltip-dialog> :id "dialog" + :title "HELLO!" + (span> "hello world"))) + dialog) + (p> + (djrounded> :id "rounded" + :style "width: 130px;height: 1.5em" + :bg-img (format nil "~a/docroot/img/roundedbg.png" lisplet-path) + :bg-img-alt (format nil "~a/docroot/img/roundedbg.gif" lisplet-path) + (span> :style "font-weight: bold;" "Rounded box gg"))) + (p> + (djbutton> :id "djbutton" + :onclick (format nil "dijit.byId('~a').show()" no-title-dialog-id) + "No title dialog") + (djfloating-content> :static-id no-title-dialog-id + :style "background: transparent;" + (div> :style (format nil "height:60px;width:60px;background: url('~a/docroot/img/spinner.gif') 50% 50% no-repeat;" lisplet-path))))))) + +(lisplet-register-page-location *dojo-test-lisplet* 'djdialog-page "djdialog.html") \ No newline at end of file Added: trunk/main/dojo/tests/djeditor-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djeditor-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,135 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djeditor-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass djeditor-page (page) + ((text1 :initarg :text1 + :accessor djeditor-page-text1) + (text2 :initarg :text2 + :accessor djeditor-page-text2) + (text3 :initarg :text3 + :accessor djeditor-page-text3) + (text4 :initarg :text4 + :accessor djeditor-page-text4)) + (:default-initargs :text1 "" :text2 "" + :text3 "" :text4 "")) + +(defclass editor-dialog (djdialog) + () + (:metaclass metacomponent)) + +(defmethod htcomponent-instance-initscript ((editor-dialog editor-dialog)) + (parenscript:ps* `(.show (dijit.by-id ,(htcomponent-client-id editor-dialog))))) + +(defclass result-text (wcomponent) + ((dialog-content :initarg :dialog-content + :accessor dialog-content) + (style :initarg :style + :reader style)) + (:metaclass metacomponent) + (:default-initargs :style "display:inline;line-height:normal;vertical-align:middle;padding:0pt 0.3em;")) + + +(defmethod wcomponent-template ((obj result-text)) + (let* ((dialog-id (generate-id "resultDialog")) + (dialog-content (dialog-content obj)) + (render-content-function #'(lambda () (progn + (hunchentoot:log-message :info "~a::------->~a" (htcomponent-client-id obj) dialog-content) + (and dialog-content + (string-not-equal dialog-content "")))))) + (div> :static-id (htcomponent-client-id obj) + :style (style obj) + (wcomponent-informal-parameters obj) + (htcomponent-body obj) + (djbutton> :id "showDialog" + :render-condition render-content-function + :onclick (format nil "dijit.byId('~a').show()" dialog-id) + "show text") + (editor-dialog> :render-condition render-content-function + :static-id dialog-id + (div> :style "height:370px;width: 800px;overflow:auto;border: 1px solid gray;padding: 0 .5em;" + ($raw> dialog-content)) + (div> :style "text-align:center;margin-top: 1em;" + (djbutton> :id "close" + :onclick (format nil "dijit.byId('~a').hide()" dialog-id) + (span> "Close"))))))) + +(defmethod page-content ((o djeditor-page)) + (let ((result-text1 (generate-id "resultText")) + (result-text2 (generate-id "resultText")) + (result-text3 (generate-id "resultText")) + (result-text4 (generate-id "resultText")) + (text1 (djeditor-page-text1 o)) + (text2 (djeditor-page-text2 o)) + (text3 (djeditor-page-text3 o)) + (text4 (djeditor-page-text4 o))) + (site-template> :title "dojo editor test page" + (djeditor-plugins-always-show-toolbar>) + (djeditor-plugins-enter-key-handling>) + (djeditor-plugins-font-choice>) + (djeditor-plugins-link-dialog>) + (djeditor-plugins-text-color>) + (djeditor-plugins-toggle-dir>) + (djform> :id "theForm" + :ajax-form-p nil + :update-id (list result-text1) + (p> (djeditor> :id "editor" + :tag-name "div" :accessor 'djeditor-page-text1)) + (result-text> :static-id result-text1 + :dialog-content text1 + (djsubmit-button> :id "submitData" :value "Submit on normal form"))) + (djform> :id "theForm" + :update-id (list result-text2) + (p> (djeditor> :id "editor" + :extraPlugins "['dijit._editor.plugins.AlwaysShowToolbar']" + :accessor 'djeditor-page-text2)) + (result-text> :static-id result-text2 + :dialog-content text2 + (djsubmit-button> :id "submitData" + :value "Submit on claw.Form"))) + (djform> :id "theForm" + :update-id (list result-text3) + (p> (djeditor> :id "editor" + :plugins "['bold','italic','|','createLink','foreColor','hiliteColor',{name:'dijit._editor.plugins.FontChoice', command:'fontName', generic:true},'fontSize','formatBlock','insertImage']" + :accessor 'djeditor-page-text3)) + (result-text> :static-id result-text3 + :dialog-content text3 + (csubmit> :id "submitData" :value "Standard submit"))) + (djform> :id "theForm" + :update-id (list result-text4) + (p> (djeditor> :id "editor" + :plugins "['bold','italic','|',{name:'dijit._editor.plugins.EnterKeyHandling'},{name:'dijit._editor.plugins.FontChoice', command:'fontName', custom:['Verdana','Myriad','Garamond','Apple Chancery','Hiragino Mincho Pro']}, {name:'dijit._editor.plugins.FontChoice', command:'fontSize', custom:[3,4,5]}]" + :accessor 'djeditor-page-text4)) + (result-text> :static-id result-text4 + :dialog-content text4 + (djsubmit-button> :id "submitData" :value "Submit")))))) + +(lisplet-register-page-location *dojo-test-lisplet* 'djeditor-page "djeditor.html") \ No newline at end of file Added: trunk/main/dojo/tests/djmenu-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djmenu-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,272 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djmenu-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass djmenu-page (page) + ((top-left :initform "top-left" + :accessor top-left) + (top-right :initform "top-right" + :accessor top-right) + (bottom-left :initform "bottom-left" + :accessor bottom-left) + (bottom-right :initform "bottom-right" + :accessor bottom-right) + (text-area :initform "Hello there" + :accessor text-area) + (select-value :initform "1" + :accessor select-value))) + +(defclass djmenu-page-menu (wcomponent) + () + (:metaclass metacomponent) + (:default-initargs :empty t)) + +(defmethod wcomponent-template ((obj djmenu-page-menu)) + (let ((id (htcomponent-client-id obj))) + (djmenu> :static-id id + (wcomponent-informal-parameters obj) + (djmenu-item> :id "mi" + :onClick "alert\('Hello world');" + "Enabled Item") + (djmenu-item> :id "mi" + :disabled "true" + "Disabled Item") + (djmenu-separator> :id "ms") + (djmenu-item> :id "mi" + :icon-class "dijitEditorIcon dijitEditorIconCut" + :on-click "alert\('not actually cutting anything, just a test!')" + "Cut") + (djmenu-item> :id "mi" + :icon-class "dijitEditorIcon dijitEditorIconCopy" + :on-click "alert\('not actually copying anything, just a test!')" + "Copy") + (djmenu-item> :id "mi" + :icon-class "dijitEditorIcon dijitEditorIconPaste" + :on-click "alert\('not actually pasting anything, just a test!')" + "Paste") + (djmenu-separator> :id "ms") + (djpopup-menu-item> :id "mpi" + (span> "Enabled Submenu") + (djmenu> :id "submenu2" + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 1!')" + "Submenu Item One") + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 2!')" + "Submenu Item Two") + (djpopup-menu-item> :id "pmi" + (span> "Deeper Submenu") + (djmenu> :id "submenu4" + (djmenu-item> :id "mi" + :on-click "alert\('Sub-submenu 1!')" + "Sub-sub-menu Item One") + (djmenu-item> :id "mi" + :on-click "alert\('Sub-submenu 2!')" + "Sub-sub-menu Item Two"))))) + (djpopup-menu-item> :id "pmi" + :disabled "true" + (span> "Disabled Submenu") + (djmenu> :id "submenu3" :style "display: none;" + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 1!')" + "Submenu Item One") + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 2!')" + "Submenu Item Two"))) + (djpopup-menu-item> :id "pmi" + (span> "Different popup") + (djcolor-palette> :id "cp"))))) + + +(defmethod page-content ((o djmenu-page)) + (let ((input2-id (generate-id "input2"))) + (site-template> :title "dojo menu test page" + (script> :language "Javascript" :type "text/javascript" + "function createMenu\() { + // create a menu programmatically + function fClick\() {alert\('clicked!')}; + + pMenu = new dijit.Menu\({targetNodeIds:['prog_menu'], id:'progMenu'}); + pMenu.addChild\(new dijit.MenuItem\({label:'Programmatic Context Menu', disabled:true})); + pMenu.addChild\(new dijit.MenuSeparator\()); + pMenu.addChild\(new dijit.MenuItem\({label:'Simple menu item', onClick:fClick})); + pMenu.addChild\(new dijit.MenuItem\({label:'Another menu item', onClick:fClick})); + pMenu.addChild\(new dijit.MenuItem\({label:'With an icon', iconClass:'dijitEditorIcon dijitEditorIconCut', onClick:fClick})); + var mItem = new dijit.MenuItem\({label:'dojo.event clicking'}); + dojo.connect\(mItem, 'onClick', function\(){alert\('click! handler created via dojo.connect\()')}); + pMenu.addChild\(mItem); + + var pSubMenu = new dijit.Menu\({parentMenu:pMenu, id:'progSubMenu'}); + pSubMenu.addChild\(new dijit.MenuItem\({label:'Submenu item', onClick:fClick})); + pSubMenu.addChild\(new dijit.MenuItem\({label:'Submenu item', onClick:fClick})); + pMenu.addChild\(new dijit.PopupMenuItem\({label:'Submenu', popup:pSubMenu, id:'progPopupMenuItem'})); + + pMenu.startup\(); + + dojo.byId\('prog_menu').innerHTML=\"This div has a programmatic context menu on it that's different to the page menu.\"; + dojo.byId\('createButton').disabled = true; + dojo.byId\('destroyButton').disabled = false; + } + + function destroyMenu\(){ + pMenu.destroyRecursive\(); + dojo.byId\('prog_menu').innerHTML='No programmatic menu on this div, should get page level menu.'; + dojo.byId\('createButton').disabled = false; + dojo.byId\('destroyButton').disabled = true; + }") + (djmenu-page-menu> :id "submenu1" + :context-menu-for-window "true" + :style "display: none;") + (djmenu-page-menu> :id "leftClick" + :left-click-to-open "true" + :target-node-ids input2-id + :style "display: none;") + (div> :style "padding: 1em" + (h1> :class "testTitle" "Dijit Menu System Test") + (h3> "Form") + (cform> :id "theForm" + (cinput> :id "input1" :accessor 'top-left) + (p> :style "text-align:right" + "left click to open the menu for this input:" + (br>) + "Note: because of the window contextMenu, make sure you get" + (br>) + "the right menu by verifying the left" + (br>) + "click one starts with \"Left Click Menu\"" + (br>) + "at the very top." + (cinput> :static-id input2-id :accessor 'top-right)) + (ctextarea> :id "textarea" :accessor 'text-area) + (br>) + (cselect> :id "select" + :accessor 'select-value + (option> :value "1" + (when (string= "1" (select-value o)) + (list :selected "selected")) + "check if i") + (option> :value "2" + (when (string= "2" (select-value o)) + (list :selected "selected")) + "bleed through") + (option> :value "3" + (when (string= "3" (select-value o)) + (list :selected "selected")) + "on IE6")) + (button> :id "button" + "push me")) + (div> :id "prog_menu" + :style "border:1px solid blue; padding:10px; margin:20px 0;" + "Click button below to create special menu on this div.") + (button> :id "createButton" + :onclick "createMenu\();" + "create programmatic menu") + (button> :id "destroyButton" + :onclick "destroyMenu\();" + :disabled "disabled" + "destroy programmatic menu") + (div> :style "height:500px") + (p> "\(this space intentionally left blank to aid testing with controls + at the bottom of the browser window)") + (div> :style "height:500px") + (cform> :id "theForm" + (cinput> :id "input3" + :accessor 'bottom-left) + (p> :style "text-align:right" + (cinput> :id "input4" :accessor 'bottom-right)) + (p> "See also: " + (a> :href "djbutton.html" + "test Button") + "\(PopupMenu is used with DropDownButton and ComboButton)") + (h3> "Mouse opening tests") + (ul> + (li> "Right click on the client area of the page \(ctrl-click for Macintosh). Menu should open.") + (li> "Right click on each of the form controls above. Menu should open.") + (li> "Right click near the righthand window border. Menu should open to the left of the pointer.") + (li> "Right click near the bottom window border. Menu should open above the pointer.")) + (h3> "Mouse hover tests") + (ul> + (li> "Hover over the first item with the pointer. Item should highlight and get focus.") + (li> "Hover over the second \(disabled) item. Item should highlight and get focus.") + (li> "Seperator items should not highlight on hover - no items should highlight in this case.")) + (h3> "Mouse click tests") + (ul> + (li> "Click on the first menu item. Alert should open with the message \"Hello world\". The menu should dissapear.") + (li> "Click on the second menu item \(disabled). Should not do anything - focus should remain on the disabled item.") + (li> "Click anywhere outside the menu. Menu should close. Focus will be set by the browser based on where the user clicks.")) + (h3> "Mouse submenu tests") + (ul> + (li> "Hover over the \"Enabled Submenu\" item. Item should highlight and then pop open a submenu after a short \(500ms) delay.") + (li> "Hover over any of the other menu items. Submenu should close immediately and deselect the submenu parent item. The newly hovered item should become selected.") + (li> "Hover over the \"Disabled Submenu\" item. Item should highlight, but no submenu should appear.") + (li> "Clicking on the \"Enabled Submenu\" item before the submenu has opened \(you'll have to be quick!) should immediatley open the submenu.") + (li> "Clicking on the \"Enabled Submenu\" item " + (i> "after") + " the submenu has opened should have no effect - the item is still selected and the submenu still open.") + (li> "Hover over submenu item 1. Should select it - the parent menu item should stay selected also.") + (li> "Hover over submenu item 2. Should select it - the parent menu item should stay selected also.")) + (h3> "Keyboard opening tests") + (ul> + (li> "On Windows: press shift-f10 with focus on any of the form controls. Should open the menu.") + (li> "On Windows: press the context menu key \(located on the right of the space bar on North American keyboards) with focus on any of the form controls. Should open the menu.") + (li> "On Firefox on the Mac: press ctrl-space with focus on any of the form controls. Should open the menu.")) + (h3> "Keyboard closing tests") + (ul> + (li> "Open the menu.") + (li> "Press tab. Should close the menu and return focus to where it was before the menu was opened.") + (li> "Open the menu.") + (li> "Press escape. Should close the menu and return focus to where it was before the menu was opened.")) + (h3> "Keyboard navigation tests") + (ul> + (li> "Open the menu.") + (li> "Pressing up or down arrow should cycle focus through the items in that menu.") + (li> "Pressing enter or space should invoke the menu item.") + (li> "Disabled items receive focus but no action is taken upon pressing enter or space.")) + (h3> "Keyboard submenu tests") + (ul> + (li> "Open the menu.") + (li> "The first item should become selected.") + (li> "Press the right arrow key. Nothing should happen.") + (li> "Press the left arrow key. Nothing should happen.") + (li> "Press the down arrow until \"Enabled Submenu\" is selected. The submenu should not appear.") + (li> "Press enter. The submenu should appear with the first item selected.") + (li> "Press escape. The submenu should vanish - \"Enabled Submenu\" should remain selected.") + (li> "Press the right arrow key. The submenu should appear with the first item selected.") + (li> "Press the right arrow key. Nothing should happen.") + (li> "Press the left arrow key. The submenu should close - \"Enabled Submenu\" should remain selected.") + (li> "Press the left arrow key. The menu should " + (i> "not") + " close and \"Enabled Submenu\" should remain selected.") + (li> "Press escape. The menu should close and focus should be returned to where it was before the menu was opened."))))))) + + + +(lisplet-register-page-location *dojo-test-lisplet* 'djmenu-page "djmenu.html") \ No newline at end of file Added: trunk/main/dojo/tests/djprogressbar-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/djprogressbar-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,272 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/djprogressbar-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass djmenu-page (page) + ((top-left :initform "top-left" + :accessor top-left) + (top-right :initform "top-right" + :accessor top-right) + (bottom-left :initform "bottom-left" + :accessor bottom-left) + (bottom-right :initform "bottom-right" + :accessor bottom-right) + (text-area :initform "Hello there" + :accessor text-area) + (select-value :initform "1" + :accessor select-value))) + +(defclass djmenu-page-menu (wcomponent) + () + (:metaclass metacomponent) + (:default-initargs :empty t)) + +(defmethod wcomponent-template ((obj djmenu-page-menu)) + (let ((id (htcomponent-client-id obj))) + (djmenu> :static-id id + (wcomponent-informal-parameters obj) + (djmenu-item> :id "mi" + :onClick "alert\('Hello world');" + "Enabled Item") + (djmenu-item> :id "mi" + :disabled "true" + "Disabled Item") + (djmenu-separator> :id "ms") + (djmenu-item> :id "mi" + :icon-class "dijitEditorIcon dijitEditorIconCut" + :on-click "alert\('not actually cutting anything, just a test!')" + "Cut") + (djmenu-item> :id "mi" + :icon-class "dijitEditorIcon dijitEditorIconCopy" + :on-click "alert\('not actually copying anything, just a test!')" + "Copy") + (djmenu-item> :id "mi" + :icon-class "dijitEditorIcon dijitEditorIconPaste" + :on-click "alert\('not actually pasting anything, just a test!')" + "Paste") + (djmenu-separator> :id "ms") + (djpopup-menu-item> :id "mpi" + (span> "Enabled Submenu") + (djmenu> :id "submenu2" + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 1!')" + "Submenu Item One") + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 2!')" + "Submenu Item Two") + (djpopup-menu-item> :id "pmi" + (span> "Deeper Submenu") + (djmenu> :id "submenu4" + (djmenu-item> :id "mi" + :on-click "alert\('Sub-submenu 1!')" + "Sub-sub-menu Item One") + (djmenu-item> :id "mi" + :on-click "alert\('Sub-submenu 2!')" + "Sub-sub-menu Item Two"))))) + (djpopup-menu-item> :id "pmi" + :disabled "true" + (span> "Disabled Submenu") + (djmenu> :id "submenu3" :style "display: none;" + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 1!')" + "Submenu Item One") + (djmenu-item> :id "mi" + :on-click "alert\('Submenu 2!')" + "Submenu Item Two"))) + (djpopup-menu-item> :id "pmi" + (span> "Different popup") + (djcolor-palette> :id "cp"))))) + + +(defmethod page-content ((o djmenu-page)) + (let ((input2-id (generate-id "input2"))) + (site-template> :title "dojo menu test page" + (script> :language "Javascript" :type "text/javascript" + "function createMenu\() { + // create a menu programmatically + function fClick\() {alert\('clicked!')}; + + pMenu = new dijit.Menu\({targetNodeIds:['prog_menu'], id:'progMenu'}); + pMenu.addChild\(new dijit.MenuItem\({label:'Programmatic Context Menu', disabled:true})); + pMenu.addChild\(new dijit.MenuSeparator\()); + pMenu.addChild\(new dijit.MenuItem\({label:'Simple menu item', onClick:fClick})); + pMenu.addChild\(new dijit.MenuItem\({label:'Another menu item', onClick:fClick})); + pMenu.addChild\(new dijit.MenuItem\({label:'With an icon', iconClass:'dijitEditorIcon dijitEditorIconCut', onClick:fClick})); + var mItem = new dijit.MenuItem\({label:'dojo.event clicking'}); + dojo.connect\(mItem, 'onClick', function\(){alert\('click! handler created via dojo.connect\()')}); + pMenu.addChild\(mItem); + + var pSubMenu = new dijit.Menu\({parentMenu:pMenu, id:'progSubMenu'}); + pSubMenu.addChild\(new dijit.MenuItem\({label:'Submenu item', onClick:fClick})); + pSubMenu.addChild\(new dijit.MenuItem\({label:'Submenu item', onClick:fClick})); + pMenu.addChild\(new dijit.PopupMenuItem\({label:'Submenu', popup:pSubMenu, id:'progPopupMenuItem'})); + + pMenu.startup\(); + + dojo.byId\('prog_menu').innerHTML=\"This div has a programmatic context menu on it that's different to the page menu.\"; + dojo.byId\('createButton').disabled = true; + dojo.byId\('destroyButton').disabled = false; + } + + function destroyMenu\(){ + pMenu.destroyRecursive\(); + dojo.byId\('prog_menu').innerHTML='No programmatic menu on this div, should get page level menu.'; + dojo.byId\('createButton').disabled = false; + dojo.byId\('destroyButton').disabled = true; + }") + (djmenu-page-menu> :id "submenu1" + :context-menu-for-window "true" + :style "display: none;") + (djmenu-page-menu> :id "leftClick" + :left-click-to-open "true" + :target-node-ids input2-id + :style "display: none;") + (div> :style "padding: 1em" + (h1> :class "testTitle" "Dijit Menu System Test") + (h3> "Form") + (cform> :id "theForm" + (cinput> :id "input1" :accessor 'top-left) + (p> :style "text-align:right" + "left click to open the menu for this input:" + (br>) + "Note: because of the window contextMenu, make sure you get" + (br>) + "the right menu by verifying the left" + (br>) + "click one starts with \"Left Click Menu\"" + (br>) + "at the very top." + (cinput> :static-id input2-id :accessor 'top-right)) + (ctextarea> :id "textarea" :accessor 'text-area) + (br>) + (cselect> :id "select" + :accessor 'select-value + (option> :value "1" + (when (string= "1" (select-value o)) + (list :selected "selected")) + "check if i") + (option> :value "2" + (when (string= "2" (select-value o)) + (list :selected "selected")) + "bleed through") + (option> :value "3" + (when (string= "3" (select-value o)) + (list :selected "selected")) + "on IE6")) + (button> :id "button" + "push me")) + (div> :id "prog_menu" + :style "border:1px solid blue; padding:10px; margin:20px 0;" + "Click button below to create special menu on this div.") + (button> :id "createButton" + :onclick "createMenu\();" + "create programmatic menu") + (button> :id "destroyButton" + :onclick "destroyMenu\();" + :disabled "disabled" + "destroy programmatic menu") + (div> :style "height:500px") + (p> "\(this space intentionally left blank to aid testing with controls + at the bottom of the browser window)") + (div> :style "height:500px") + (cform> :id "theForm" + (cinput> :id "input3" + :accessor 'bottom-left) + (p> :style "text-align:right" + (cinput> :id "input4" :accessor 'bottom-right)) + (p> "See also: " + (a> :href "djbutton.html" + "test Button") + "\(PopupMenu is used with DropDownButton and ComboButton)") + (h3> "Mouse opening tests") + (ul> + (li> "Right click on the client area of the page \(ctrl-click for Macintosh). Menu should open.") + (li> "Right click on each of the form controls above. Menu should open.") + (li> "Right click near the righthand window border. Menu should open to the left of the pointer.") + (li> "Right click near the bottom window border. Menu should open above the pointer.")) + (h3> "Mouse hover tests") + (ul> + (li> "Hover over the first item with the pointer. Item should highlight and get focus.") + (li> "Hover over the second \(disabled) item. Item should highlight and get focus.") + (li> "Seperator items should not highlight on hover - no items should highlight in this case.")) + (h3> "Mouse click tests") + (ul> + (li> "Click on the first menu item. Alert should open with the message \"Hello world\". The menu should dissapear.") + (li> "Click on the second menu item \(disabled). Should not do anything - focus should remain on the disabled item.") + (li> "Click anywhere outside the menu. Menu should close. Focus will be set by the browser based on where the user clicks.")) + (h3> "Mouse submenu tests") + (ul> + (li> "Hover over the \"Enabled Submenu\" item. Item should highlight and then pop open a submenu after a short \(500ms) delay.") + (li> "Hover over any of the other menu items. Submenu should close immediately and deselect the submenu parent item. The newly hovered item should become selected.") + (li> "Hover over the \"Disabled Submenu\" item. Item should highlight, but no submenu should appear.") + (li> "Clicking on the \"Enabled Submenu\" item before the submenu has opened \(you'll have to be quick!) should immediatley open the submenu.") + (li> "Clicking on the \"Enabled Submenu\" item " + (i> "after") + " the submenu has opened should have no effect - the item is still selected and the submenu still open.") + (li> "Hover over submenu item 1. Should select it - the parent menu item should stay selected also.") + (li> "Hover over submenu item 2. Should select it - the parent menu item should stay selected also.")) + (h3> "Keyboard opening tests") + (ul> + (li> "On Windows: press shift-f10 with focus on any of the form controls. Should open the menu.") + (li> "On Windows: press the context menu key \(located on the right of the space bar on North American keyboards) with focus on any of the form controls. Should open the menu.") + (li> "On Firefox on the Mac: press ctrl-space with focus on any of the form controls. Should open the menu.")) + (h3> "Keyboard closing tests") + (ul> + (li> "Open the menu.") + (li> "Press tab. Should close the menu and return focus to where it was before the menu was opened.") + (li> "Open the menu.") + (li> "Press escape. Should close the menu and return focus to where it was before the menu was opened.")) + (h3> "Keyboard navigation tests") + (ul> + (li> "Open the menu.") + (li> "Pressing up or down arrow should cycle focus through the items in that menu.") + (li> "Pressing enter or space should invoke the menu item.") + (li> "Disabled items receive focus but no action is taken upon pressing enter or space.")) + (h3> "Keyboard submenu tests") + (ul> + (li> "Open the menu.") + (li> "The first item should become selected.") + (li> "Press the right arrow key. Nothing should happen.") + (li> "Press the left arrow key. Nothing should happen.") + (li> "Press the down arrow until \"Enabled Submenu\" is selected. The submenu should not appear.") + (li> "Press enter. The submenu should appear with the first item selected.") + (li> "Press escape. The submenu should vanish - \"Enabled Submenu\" should remain selected.") + (li> "Press the right arrow key. The submenu should appear with the first item selected.") + (li> "Press the right arrow key. Nothing should happen.") + (li> "Press the left arrow key. The submenu should close - \"Enabled Submenu\" should remain selected.") + (li> "Press the left arrow key. The menu should " + (i> "not") + " close and \"Enabled Submenu\" should remain selected.") + (li> "Press escape. The menu should close and focus should be returned to where it was before the menu was opened."))))))) + + + +(lisplet-register-page-location *dojo-test-lisplet* 'djmenu-page "djmenu.html") \ No newline at end of file Added: trunk/main/dojo/tests/docroot/css/style.css ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/docroot/css/style.css Sat Jun 14 02:00:26 2008 @@ -0,0 +1,61 @@ +.Rounded { + display: table-cell; + position:relative; + margin:0px auto; + min-width: 10px; + max-width:1000px; + z-index:1; + margin-left:5px; + margin-top: 3px; +} + +.Rounded .RoundedContent, +.Rounded .RoundedTop, +.Rounded .RoundedBottom, +.Rounded .RoundedBottom div { + background:transparent url('../img/roundedbg.png') no-repeat top right; + _background:transparent url('../img/roundedbg.gif') no-repeat top right; +} + +.Rounded .RoundedContent { + position:relative; + zoom:1; + _overflow-y:hidden; + padding:5px 10px 0px 5px; + margin: 0 0 0 0; +} + +.Rounded .RoundedTop { + position:absolute; + left:0px; + top:0px; + width:5px; + margin-left:-5px; + height:100%; + _height:1000px; + background-position:top left; +} + +.Rounded .RoundedBottom, +.Rounded .RoundedBottom div { + height:7px; + font-size:1px; +} + +.Rounded .RoundedBottom { + background-position:bottom right; + position:relative; + width:100%; + clear: both; + margin-left: 0px; + margin-right: 0px; + padding: 0; + display: table; +} + +.Rounded .RoundedBottom div { + position:relative; + width:5px; + margin-left:-5px; + background-position:bottom left; +} Added: trunk/main/dojo/tests/docroot/img/roundedbg.gif ============================================================================== Binary file. No diff available. Added: trunk/main/dojo/tests/docroot/img/roundedbg.png ============================================================================== Binary file. No diff available. Added: trunk/main/dojo/tests/docroot/img/spinner.gif ============================================================================== Binary file. No diff available. Added: trunk/main/dojo/tests/header-info-page.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/header-info-page.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,47 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/header-info-page.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass header-info-page (page) ()) + +(defmethod page-content ((o header-info-page)) + (let ((header-props (headers-in))) + (site-template> :title "Header info page" + (p> :id "p" + (table> + (tr> (td> :colspan "2" "Header info")) + (loop for key-val in header-props + collect (tr> + (td> (format nil "~a" (car key-val)) + (td> (format nil "~a" (cdr key-val))))))))))) + +(lisplet-register-page-location *dojo-test-lisplet* 'header-info-page "info.html") + Added: trunk/main/dojo/tests/index.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/index.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,52 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/index.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass index-page (page) ()) + +(defmethod page-content ((o index-page)) + (site-template> :title "Home test page" + (p> :id "p" + (ul> + (li> (a> :href "realm.html" "realm on test")) + (li> (a> :href "info.html" "HTTP Header info")) + (li> (a> :href "../test2/realm.html" "realm on test2")) + (li> (a> :href "djbutton.html" "dojo buttons integration test")) + (li> (a> :href "djdialog.html" "dojo dialog integration test")) + (li> (a> :href "djcolorpalette.html" "dojo color palette integration test")) + (li> (a> :href "djeditor.html" "dojo editor integration test")) + (li> (a> :href "djevent.html" "dojo event integration test")) + (li> (a> :href "ajax.html" "dojo ajax test")) + (li> (a> :href "djcalendar.html" "dojo calendar test")) + (li> (a> :href "slider.html" "dojo slider test")) + (li> (a> :href "djmenu.html" "dojo menu test")))))) + +(lisplet-register-page-location *dojo-test-lisplet* 'index-page "index.html" :welcome-page-p t) \ No newline at end of file Added: trunk/main/dojo/tests/main.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/main.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,87 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/main.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + +(setf hunchentoot:*default-content-type* "text/html; charset=UTF-8") + +(defvar *main-file* (load-time-value + (or #.*compile-file-pathname* *load-pathname*))) + +(defvar *dojo-test-lisplet*) +(defvar *dojo-test-lisplet2*) +(setf *dojo-test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test")) +(setf *dojo-test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2")) + +(defparameter *clawserver* (make-instance 'clawserver + :port 4242 + :mod-lisp-p nil + :base-path "/claw")) + +;;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :sslport 4445 :base-path "/claw" +;;; :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" +;;; :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) + +(clawserver-register-lisplet *clawserver* *dojo-test-lisplet*) +(clawserver-register-lisplet *clawserver* *dojo-test-lisplet2*) + +(defun test-image-file () + (make-pathname :directory (append (pathname-directory *main-file*) '("img")) :name "matrix" :type "jpg")) + +(let ((path (make-pathname :directory (append (pathname-directory *main-file*) '("docroot"))))) + (lisplet-register-resource-location *dojo-test-lisplet* + path + "docroot/") + (lisplet-register-resource-location *dojo-test-lisplet2* + path + "docroot/")) + +(defun djstart () + (clawserver-start *clawserver*) + *clawserver*) + +(defun djstop () + (clawserver-stop *clawserver*) + *clawserver*) + +(defun debug-mode () + (setf hunchentoot:*catch-errors-p* nil + hunchentoot::*log-lisp-backtraces-p* t + hunchentoot::*log-lisp-errors-p* t + hunchentoot::*log-lisp-warnings-p* t + hunchentoot::*show-lisp-errors-p* t + hunchentoot::*show-lisp-backtraces-p* t)) + +(defun production-mode () + (setf hunchentoot:*catch-errors-p* t + hunchentoot::*log-lisp-backtraces-p* nil + hunchentoot::*log-lisp-errors-p* t + hunchentoot::*log-lisp-warnings-p* t + hunchentoot::*show-lisp-errors-p* nil + hunchentoot::*show-lisp-backtraces-p* nil)) \ No newline at end of file Added: trunk/main/dojo/tests/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/packages.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,38 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/packages.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :claw-dojo-tests + (:nicknames :dojo-tests) + (:use :cl :hunchentoot :claw :dojo :parenscript) + (:export :djstart + :djstop + :debug-mode + :production-mode)) \ No newline at end of file Added: trunk/main/dojo/tests/realm.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/realm.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,59 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/realm.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + + +(defclass realm-page (page) ()) + +(defmethod page-content ((o realm-page)) + (when (null hunchentoot:*session*) + (claw-start-session)) + (unless (session-value 'RND-NUMBER) + (setf (session-value 'RND-NUMBER) (random 1000))) + (site-template> :title "Realm test page" + (p> + "session" + (ul> + (li> (a> :href "http://www.gentoo.org" :target "gentoo" + "gentoo")) + (li> (a> :href "../test/realm.html" :target "clwo1" + "realm on lisplet 'test'")) + (li> (a> :href "../test2/realm.html" :target "clwo2" + "realm on lisplet 'test2'")) + (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) + (li> "Remote Addr: " (session-remote-addr *session*)) + (li> "User agent: " (session-user-agent *session*)) + (li> "Lisplet Realm: " (current-realm)) + (li> "Session Realm: " (session-realm *session*)) + (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) + (li> "Request Realm: " (hunchentoot::realm *request*)))))) + +(lisplet-register-page-location *dojo-test-lisplet* 'realm-page "realm.html") +(lisplet-register-page-location *dojo-test-lisplet2* 'realm-page "realm.html") Added: trunk/main/dojo/tests/slider-test.lisp ============================================================================== --- (empty file) +++ trunk/main/dojo/tests/slider-test.lisp Sat Jun 14 02:00:26 2008 @@ -0,0 +1,129 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/slider-test.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-dojo-tests) + +(defgeneric slide-page-null-action (slider-page)) + +(defclass slider-page (page) + ((hval :initform 10 + :accessor slider-page-hval) + (vval :initform 50 + :accessor slider-page-vval) + (message-content :initform "" + :accessor slider-page-message-content))) + +(defmethod slide-page-null-action ((slider-page slider-page)) + (setf (slider-page-message-content slider-page) + (div> :style "border: 1px solid gray;" + (format nil "Sent djhorizontal-slider value: ~a" (slider-page-hval slider-page)) + (br>) + (format nil "Sent djvertical-slider value: ~a" (slider-page-vval slider-page))))) + +(defmethod page-content ((pobj slider-page)) + (let ((hs-content-id (generate-id "content")) + (vs-content-id (generate-id "content"))) + (site-template> :title "dojo slider test page" + (h1> :class "testTitle" "Slider") + "Also try using the arrow keys, buttons, or clicking on the progress bar to move the slider." + (br>) + (cform> :id "djform" + :action 'slide-page-null-action + (br>) + "initial value=10, min=0, max=100, pageIncrement=100, onChange event triggers span innerHTML change immediately" + (br>) + (djhorizontal-slider> :id "slider1" + :onChange (parenscript:ps* `(setf (slot-value (dojo.by-id ,hs-content-id) 'inner-H-T-M-L) + (dojo.number.format (/ (aref arguments 0) 100) + (create :places 1 + :pattern "#%")))) + :accessor 'slider-page-hval + :maximum 100 + :minimum 0 + :page-increment 100 + :show-buttons "false" + :intermediate-changes "true" + :style "width:50%; height: 20px;" + (djhorizontal-rule-labels> :container "topDecoration" + :style "height:1.2em;font-size:75%;color:gray;" + :count 6 + :numeric-margin 1) + (djhorizontal-rule> :container "topDecoration" + :style "height:5px;" + :count 6) + (djhorizontal-rule> :container "bottomDecoration" + :style "height:5px;" + :count 5) + (djhorizontal-rule-labels> :container "bottomDecoration" + :style "height:1em;font-size:75%;color:gray;" + (li> "lowest") + (li> "normal") + (li> "highest"))) + (p> + (span> :style="font-weight: bolder;" "djhorizontal-slider current value:")(span> :static-id hs-content-id "--")) + + (br>) + "initial value=10, min=0, max=100, pageIncrement=100, onChange event triggers span innerHTML change immediately" + (br>) + (djvertical-slider> :id "slider2" + :onChange (parenscript:ps* `(setf (slot-value (dojo.by-id ,vs-content-id) 'inner-H-T-M-L) + (dojo.number.format (/ (aref arguments 0) 100) + (create :places 1 + :pattern "#%")))) + :accessor 'slider-page-vval + :maximum 100 + :minimum 0 + :page-increment 100 + :discrete-values 11 + :style "height: 300px;" + (djvertical-rule-labels> :container "leftDecoration" + :style "width:2em;color:gray;" + (li> "0") + (li> "100")) + (djvertical-rule> :container "leftDecoration" + :style "width:5px;" + :count 11 + :rule-style "border-color:gray;") + (djvertical-rule> :container "rightDecoration" + :style "width:5px;" + :count 11 + :rule-style "border-color:gray;") + (djvertical-rule-labels> :container "rightDecoration" + :style "width:2em;color:gray;" + :count 6 + :numeric-margin 1 + :maximum 100 + :constraints "{pattern:'#'}")) + (p> + (span> :style="font-weight: bolder;" "djvertical-slider current value:")(span> :static-id vs-content-id "--")) + (djsubmit-button> :id "submit" :value "Submit")) + (slider-page-message-content pobj)))) + + +(lisplet-register-page-location *dojo-test-lisplet* 'slider-page "slider.html") \ No newline at end of file

1 0

[claw-cvs] r50 - in trunk/main/claw-core: src tests
by achiumenti＠common-lisp.net 14 Jun '08

14 Jun '08

Author: achiumenti Date: Sat Jun 14 01:16:01 2008 New Revision: 50 Modified: trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/src/translators.lisp trunk/main/claw-core/tests/test1.lisp Log: a lot of bug fixes. Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Sat Jun 14 01:16:01 2008 @@ -33,9 +33,9 @@ (:documentation "Internal method to determine, during the rewinding phase, if the COMP has been fired for calling its action. - 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. + (: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) @@ -68,15 +68,18 @@ (defgeneric name-attr (cinput) (:documentation "Returns the name of the input component")) -(defclass translator () +(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. + "*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*)) +(defvar *file-translator* nil + "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".") + +(defun component-validation-errors (component &optional (request *request*)) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) (getf (validation-errors request) (intern client-id)))) @@ -85,14 +88,35 @@ -(defclass cform (wcomponent) +(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) + :documentation "The html CLASS attribute") + (method :initarg :method + :reader form-method + :documentation "Form post method (may be \"get\" or \"post\")")) + (:default-initargs :action nil :class nil :method "post") + (:documentation "Internal use component")) + +(defmethod wcomponent-after-rewind ((obj _cform) (pobj page)) + (let ((validation-errors (validation-errors)) + (action (action obj))) + (when (and (null validation-errors) + action + (cform-rewinding-p obj pobj)) + (funcall action pobj)))) + +(defmethod cform-rewinding-p ((cform _cform) (page page)) + (string= (htcomponent-client-id cform) + (page-req-parameter page *rewind-parameter*))) + +(defclass cform (_cform) + ((execut-p :initform T + :accessor cform-execute-p + :documentation "When nil the form will never rewind an the CFORM-REWINDING-P will always be 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")) @@ -107,13 +131,10 @@ (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-template((cform cform)) (let ((client-id (htcomponent-client-id cform)) (class (css-class cform)) + (method (form-method cform)) (validation-errors (validation-errors))) (when validation-errors (if (or (null class) (string= class "")) @@ -121,26 +142,40 @@ (setf class (format nil "~a error" class)))) (form> :static-id client-id :class class + :method method (wcomponent-informal-parameters cform) (input> :name *rewind-parameter* - :type "hidden" + :type "hidden" :value client-id) (htcomponent-body cform)))) +(defmethod cform-rewinding-p ((cform cform) (page page)) + (and (cform-execute-p cform) + (string= (htcomponent-client-id cform) + (page-req-parameter page *rewind-parameter*)))) + (defmethod wcomponent-before-rewind ((obj cform) (pobj page)) + (let ((render-condition (htcomponent-render-condition obj))) + (setf (cform-execute-p obj) (not (and render-condition (null (funcall render-condition)))) + (page-current-form pobj) obj))) + +(defmethod wcomponent-after-rewind :after ((obj cform) (pobj page)) + (setf (page-current-form pobj) nil)) + +(defmethod wcomponent-before-prerender ((obj cform) (pobj page)) (setf (page-current-form pobj) obj)) -(defmethod wcomponent-after-rewind ((obj cform) (pobj page)) - (let ((validation-errors (validation-errors)) - (action (action obj))) - (unless validation-errors - (when (or action (cform-rewinding-p obj pobj)) - (funcall action pobj)) - (setf (page-current-form pobj) nil)))) +(defmethod wcomponent-after-prerender ((obj cform) (pobj page)) + (setf (page-current-form pobj) nil)) +(defmethod wcomponent-before-render ((obj cform) (pobj page)) + (setf (page-current-form pobj) obj)) + +(defmethod wcomponent-after-render ((obj cform) (pobj page)) + (setf (page-current-form pobj) nil)) ;-------------------------------------------------------------------------------- -(defclass action-link (cform) () +(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. @@ -165,11 +200,12 @@ (wcomponent-informal-parameters o) (htcomponent-body o)))) + ;--------------------------------------------------------------------------------------- (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") + :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") @@ -179,7 +215,7 @@ (accessor :initarg :accessor :reader cinput-accessor :documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters") - (label :initarg :label + (label :initarg :label :documentation "The label is the description of the component. It's also be used when component validation fails.") (translator :initarg :translator :reader translator @@ -209,7 +245,7 @@ (defclass cinput (base-cinput) ((input-type :initarg :type :reader input-type - :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) + :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) @@ -218,13 +254,13 @@ (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." + "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-template ((cinput cinput)) +(defmethod wcomponent-template ((cinput cinput)) (let ((client-id (htcomponent-client-id cinput)) (type (input-type cinput)) (translator (translator cinput)) @@ -243,20 +279,53 @@ (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput base-cinput) (page page)) - (let ((visit-object (or (cinput-visit-object cinput) page)) - (accessor (cinput-accessor cinput)) - (writer (cinput-writer cinput)) - (validator (validator cinput)) - (value (translator-decode (translator cinput) cinput))) + (when (cform-rewinding-p (page-current-form page) page) + (let ((visit-object (or (cinput-visit-object cinput) page)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (value (translator-decode (translator cinput) cinput))) (unless (or (null value) (component-validation-errors cinput)) (when validator (funcall validator value)) (unless (component-validation-errors cinput) (if (and (null writer) accessor) (funcall (fdefinition `(setf ,accessor)) value visit-object) - (funcall (fdefinition writer) value visit-object)))))) + (funcall (fdefinition writer) value visit-object))))))) -(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) +(defclass ctextarea (base-cinput) + () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :name) :empty nil) + (:documentation "Request cycle aware component the renders as an INPUT tag class")) + +(let ((class (find-class 'ctextarea))) + (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 CTEXTAREA component and renders a html <textarea> 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 ((ctextarea ctextarea)) + (let ((client-id (htcomponent-client-id ctextarea)) + (translator (translator ctextarea)) + (value "") + (class (css-class ctextarea))) + (when (component-validation-errors ctextarea) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (setf value (translator-encode translator ctextarea)) + (textarea> :static-id client-id + :name (name-attr ctextarea) + :class class + (wcomponent-informal-parameters ctextarea) + (or value "")))) + +(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) (let ((client-id (htcomponent-client-id cinput)) (visit-object (or (cinput-visit-object cinput) (htcomponent-page cinput))) (accessor (cinput-accessor cinput)) @@ -264,30 +333,47 @@ (result-as-list-p (cinput-result-as-list-p cinput)) (value "")) (setf value - (cond - (from-request-p (page-req-parameter (htcomponent-page cinput) + (cond + (from-request-p (page-req-parameter (htcomponent-page cinput) (name-attr cinput) result-as-list-p)) ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) - (values client-id value))) + (values client-id value))) + +;--------------------------------------------------------------------------------------- +(defclass cinput-file (cinput) + () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :value :name :type) :empty t :type "file" :translator *file-translator*) + (:documentation "Request cycle aware component the renders as an INPUT tag class of type file")) +(let ((class (find-class 'cinput-file))) + (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 a CINPUT component and renders a html <input> tag of type \"file\"." + (list + *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)))) ;--------------------------------------------------------------------------------------- -(defclass csubmit (cform) +(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 + (:documentation "This component render as an INPUT tag class ot type submit, but can override the default CFORM action, using its own associated action")) (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." + "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) @@ -306,13 +392,15 @@ (wcomponent-informal-parameters obj)))) (defmethod wcomponent-after-rewind ((obj csubmit) (pobj page)) - (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 (action current-form) action)))) + (when (cform-rewinding-p (page-current-form pobj) pobj) + (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 (action current-form) action))))) + ;----------------------------------------------------------------------------- -(defclass submit-link (csubmit) +(defclass submit-link (csubmit) () (:metaclass metacomponent) (:default-initargs :reserved-parameters (list :href) :empty nil) @@ -323,7 +411,7 @@ (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." + "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) @@ -332,7 +420,7 @@ (defmethod wcomponent-template ((obj submit-link)) (let* ((id (htcomponent-client-id obj)) (submit-id (generate-id id))) - (list + (list (input> :static-id submit-id :style "display:none;" :type "submit" @@ -347,14 +435,14 @@ (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, + (:documentation "This component renders as a normal SELECT tag class, but it is request cycle aware.")) (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." + "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) @@ -380,7 +468,7 @@ ((test :initarg :test :accessor ccheckbox-test) (value :initarg :value - :accessor ccheckbox-value)) + :accessor ccheckbox-value)) (:metaclass metacomponent) (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal) (:documentation "Request cycle aware component the renders as an INPUT tag class")) @@ -389,18 +477,18 @@ (closer-mop:ensure-finalized class) (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) (format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a" - "Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"." + "Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"." *id-and-static-id-description* (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) (describe-html-attributes-from-class-slot-initargs (find-class 'cinput)) (describe-html-attributes-from-class-slot-initargs class) (describe-component-behaviour class)))) -(defmethod wcomponent-template ((cinput ccheckbox)) +(defmethod wcomponent-template ((cinput ccheckbox)) (let* ((client-id (htcomponent-client-id cinput)) (translator (translator cinput)) (type (input-type cinput)) - (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) (current-value (translator-type-to-string translator cinput)) (class (css-class cinput))) (when (component-validation-errors cinput) @@ -416,25 +504,26 @@ (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) - (let* ((visit-object (or (cinput-visit-object cinput) page)) - (client-id (htcomponent-client-id cinput)) - (translator (translator cinput)) - (accessor (cinput-accessor cinput)) - (writer (cinput-writer cinput)) - (validator (validator cinput)) - (result-as-list-p (cinput-result-as-list-p cinput)) - (new-value (page-req-parameter page - client-id - result-as-list-p))) - (when new-value - (setf new-value (translator-string-to-type translator cinput))) - (unless (component-validation-errors cinput) - (when validator - (funcall validator (or new-value ""))) + (when (cform-rewinding-p (page-current-form page) page) + (let* ((visit-object (or (cinput-visit-object cinput) page)) + (client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (new-value (page-req-parameter page + client-id + result-as-list-p))) + (when new-value + (setf new-value (translator-string-to-type translator cinput))) (unless (component-validation-errors cinput) - (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object)))))) + (when validator + (funcall validator (or new-value ""))) + (unless (component-validation-errors cinput) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object))))))) ;------------------------------------------------------------------------------------- (defclass cradio (ccheckbox) @@ -447,7 +536,7 @@ (closer-mop:ensure-finalized class) (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) (format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a" - "Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"." + "Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"." *id-and-static-id-description* (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) (describe-html-attributes-from-class-slot-initargs (find-class 'cinput)) @@ -459,34 +548,35 @@ (htcomponent-real-id ccheckbox)) (defmethod wcomponent-after-rewind ((cinput cradio) (page page)) - (let* ((visit-object (or (cinput-visit-object cinput) page)) - (translator (translator cinput)) - (accessor (cinput-accessor cinput)) - (writer (cinput-writer cinput)) - (validator (validator cinput)) - (ccheckbox-test (ccheckbox-test cinput)) - (result-as-list-p (cinput-result-as-list-p cinput)) - (value (translator-value-string-to-type translator (ccheckbox-value cinput))) - (new-value (page-req-parameter page - (name-attr cinput) - result-as-list-p)) - (checked)) - (when new-value - (setf new-value (translator-string-to-type translator cinput) - checked (funcall ccheckbox-test value new-value))) - (when (and checked (null (component-validation-errors cinput))) - (when validator - (funcall validator (or new-value ""))) - (when (null (component-validation-errors cinput)) - (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object)))))) + (when (cform-rewinding-p (page-current-form page) page) + (let* ((visit-object (or (cinput-visit-object cinput) page)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (ccheckbox-test (ccheckbox-test cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (value (translator-value-string-to-type translator (ccheckbox-value cinput))) + (new-value (page-req-parameter page + (name-attr cinput) + result-as-list-p)) + (checked)) + (when new-value + (setf new-value (translator-string-to-type translator cinput) + checked (funcall ccheckbox-test value new-value))) + (when (and checked (null (component-validation-errors cinput))) + (when validator + (funcall validator (or new-value ""))) + (when (null (component-validation-errors cinput)) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object))))))) -(defmethod wcomponent-template ((cinput cradio)) - (let* ((client-id (htcomponent-client-id cinput)) +(defmethod wcomponent-template ((cinput cradio)) + (let* ((client-id (htcomponent-client-id cinput)) (translator (translator cinput)) (type (input-type cinput)) - (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) (current-value (translator-type-to-string translator cinput)) (class (css-class cinput))) (when (component-validation-errors cinput) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sat Jun 14 01:16:01 2008 @@ -49,7 +49,7 @@ - :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the function as a login page")) -(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p encoding) +(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p external-format) (:documentation "Registers a page into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page @@ -58,16 +58,16 @@ keys: - :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the page as a login page -- :ENCODING The charset encoding used to render the resource")) +- :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) -(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type encoding) +(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type external-format) (:documentation "Registers a resource (file or directory) into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page - RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching - LOCATION The url location where the resource will be registered (relative to the lisplet base path) - CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type -- ENCODING The charset encoding used to render the resource")) +- :EXTERNAL-FORMAT The FLEXI-STREAMS:EXTERNAL-FORMAT used to render the resource")) (defgeneric lisplet-dispatch-method (lisplet) (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST @@ -78,7 +78,7 @@ - LISPLET the lisplet object")) (defgeneric lisplet-protect (lisplet location roles) - (:documentation "protects all the resources that start with the given LOCATION, making them available only if the + (:documentation "protects all the resources that start with the given LOCATION, making them available only if the user is logged and belongs at least to one of the given roles. parameters: - LISPLET the lisplet object. @@ -86,7 +86,7 @@ - ROLES a string list containing all the roles allowed to acces the given location.")) (defgeneric lisplet-check-authorization (lisplet &optional request) - (:documentation "Performs authentication and authorization checking. + (:documentation "Performs authentication and authorization checking. Sets the return code of each REPLY, to +HTTP-OK+, +HTTP-FORBIDDEN+ or +HTTP-AUTHORIZATION-REQUIRED+. If the lisplet authentication type is :BASIC and the user isn't logged in, asks for a basic login.")) @@ -98,7 +98,7 @@ (defgeneric build-lisplet-location (lisplet) (:documentation "Constructs a full path prepending the lisplet base path to the given location")) -(setf *http-error-handler* +(setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) (let* ((error-handlers (if (current-lisplet) @@ -107,8 +107,8 @@ (handler (gethash error-code error-handlers))) (if handler (funcall handler) - (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) + (let ((error-page (make-instance 'error-page + :title (format nil "Server error: ~a" error-code) :error-code error-code))) (with-output-to-string (*standard-output*) (page-render error-page))))))) @@ -118,13 +118,13 @@ :documentation "common base path all resources registered into this lisplet") (welcome-page :initarg :welcome-page :accessor lisplet-welcome-page - :documentation "url location for the welcome page") + :documentation "url location for the welcome page") (login-page :initarg :login-page :accessor lisplet-login-page - :documentation "url location for the welcome page") - (encoding :initarg :encoding - :accessor lisplet-encoding - :documentation "The default charset external format for resources provided by this lisplet.") + :documentation "url location for the welcome page") + (external-format :initarg :external-format + :accessor lisplet-external-format + :documentation "The default charset external format for resources provided by this lisplet.") (realm :initarg :realm :reader lisplet-realm :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") @@ -139,10 +139,10 @@ :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location") (redirect-protected-resources-p :initarg :redirect-protected-resources-p :accessor lisplet-redirect-protected-resources-p - :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) - (:default-initargs :welcome-page nil + :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) + (:default-initargs :welcome-page nil :login-page nil - :encoding :utf-8 + :external-format nil :realm "claw" :redirect-protected-resources-p nil) (:documentation "A lisplet is a container for resources provided trhough the clawserver. @@ -150,11 +150,11 @@ (defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) - (location (lisplet-base-path lisplet))) + (location (lisplet-base-path lisplet))) (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location (cons location #'(lambda () - (progn + (progn (setf (current-realm *request*) (lisplet-realm lisplet) (current-lisplet) lisplet) (lisplet-dispatch-method lisplet)))) @@ -163,7 +163,7 @@ (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) (location (lisplet-base-path lisplet))) - (remove-by-location location dispatchers))) + (remove-by-location location dispatchers))) (defmethod build-lisplet-location ((lisplet lisplet)) @@ -175,8 +175,8 @@ :form :basic)) -(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) - (let ((pages (lisplet-pages lisplet))) +(defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p @@ -184,31 +184,34 @@ (when login-page-p (setf (lisplet-login-page lisplet) location)))) -(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p encoding) - (let ((charset-encoding (or encoding (lisplet-encoding lisplet)))) - (lisplet-register-function-location lisplet +(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p external-format) + (let ((charset-external-format (or external-format (lisplet-external-format lisplet)))) + (lisplet-register-function-location lisplet #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location :encoding charset-encoding)))) + (page-render (make-instance page-class :lisplet lisplet :url location :external-format charset-external-format)))) location :welcome-page-p welcome-page-p :login-page-p login-page-p))) -(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type (encoding :utf-8)) +(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type external-format) (let ((pages (lisplet-pages lisplet)) - (external-format (flexi-streams:make-external-format (or encoding (lisplet-encoding lisplet)) :eol-style :lf))) + (charset-external-format (or external-format (lisplet-external-format lisplet)))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) + (cons location + (if (directory-pathname-p resource-path) #'(lambda () - (let ((resource-full-path (merge-pathnames + (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length (lisplet-base-path lisplet)) (length location) 1))) resource-path))) - (setf (reply-external-format) external-format) - (handle-static-file resource-full-path content-type))) + (unless (or (null charset-external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name charset-external-format))) + (setf (reply-external-format) charset-external-format)) + (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -225,9 +228,9 @@ (uri (script-name)) (welcome-page (lisplet-welcome-page lisplet))) (lisplet-check-authorization lisplet) - (when (= (return-code) +http-ok+) - (if (and welcome-page (string= uri base-path)) - (page-render (lisplet-welcome-page lisplet)) + (when (= (return-code) +http-ok+) + (if (and welcome-page (string= uri base-path)) + (page-render (lisplet-welcome-page lisplet)) (lisplet-dispatch-request lisplet))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) @@ -238,7 +241,7 @@ protected-resources))))) (defun redirect-to-https (server request &optional uri) - "Redirects a request sent through http using https" + "Redirects a request sent through http using https" (let ((path (or uri (request-uri request))) (port (server-port request)) (protocol :http)) @@ -258,9 +261,9 @@ (login-config (current-config)) (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet))) (server (current-server request)) - (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) + (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) (setf (return-code) +http-ok+) - (when login-config + (when login-config (when (and auth-basicp (null princp)) (configuration-login login-config)) (setf princp (current-principal)) @@ -268,17 +271,17 @@ for match = (format nil "~a/~a" base-path (car protected-resource)) for allowed-roles = (cdr protected-resource) do (when (or (starts-with-subseq match uri) (string= login-page-url uri)) - (cond + (cond ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) (setf (return-code) +http-forbidden+) (throw 'handler-done nil)) ((and (null princp) auth-basicp) - (setf (return-code) +http-authorization-required+ + (setf (return-code) +http-authorization-required+ (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) (throw 'handler-done nil)) ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) (redirect-to-https server request login-page-url) - (throw 'handler-done nil)) + (throw 'handler-done nil)) #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) (redirect-to-https server request) (throw 'handler-done nil)))))))) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sat Jun 14 01:16:01 2008 @@ -29,10 +29,12 @@ (in-package :claw) -(defvar *apache-http-port* 80 +(setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) + +(defvar *apache-http-port* 80 "Default apache http port when claw is running in mod_lisp mode") (defvar *apache-https-port* 443 - "Default apache https port when claw is running in mod_lisp mode") + "Default apache https port when claw is running in mod_lisp mode") (defvar *claw-libraries-resources* () "Global variable to hold exposed web resources") @@ -43,27 +45,27 @@ (items "")) (cond ((= st-size 0) "[]") ((= st-size 1) (format nil "[~a]" (prin1-to-string (first strings)))) - (t (format nil (format nil "[~a~a]" + (t (format nil (format nil "[~a~a]" (prin1-to-string (first strings)) (progn (dolist (str (rest strings)) (setf items (format nil "~a,~a" items (prin1-to-string str)))) items))))))) - + (defun sort-by-location (location-list) "Sorts a list of location items by their first element (the location itself)." (sort location-list #'(lambda (item1 item2) (string-not-lessp (first item1) (first item2))))) (defun sort-protected-resources (protected-resources) - "Sorts a list of protected resources. A protected resource is a cons where the car is the url + "Sorts a list of protected resources. A protected resource is a cons where the car is the url of the resource and the cdr is a list of roles allowhed to access that resource." (sort protected-resources #'(lambda (item1 item2) (string-lessp (car item1) (car item2))))) (defun remove-by-location (location location-list) - "Removes an item from LOCATION-LIST checking its first element + "Removes an item from LOCATION-LIST checking its first element against the LOCATION parameter" (delete-if #'(lambda (item) (string= (first item) location)) location-list)) @@ -72,7 +74,7 @@ registered (its first element)." (let ((result (remove-by-location (first location-items) location-list))) (setf result (push location-items result)))) - + (defun claw-start-session () "Starts a session bound to the current lisplet base path" (start-session (format nil "~a/" (build-lisplet-location (current-lisplet))))) @@ -122,7 +124,7 @@ (setf (session-value 'principal session) principal)) (defun user-in-role-p (roles &optional (session *session*)) - "Detects if current principal belongs to any of the expressed roles" + "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal session))) (when principal (loop for el in (principal-roles principal) thereis (member el roles))))) @@ -138,8 +140,8 @@ (defun flatten (tree &optional result-list) "Traverses the tree in order, collecting even non-null leaves into a list." (let ((result result-list)) - (loop for element in tree - do (cond + (loop for element in tree + do (cond ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) (t (push element result)))) (nreverse result))) @@ -153,8 +155,8 @@ (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. +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)) @@ -163,12 +165,12 @@ (key-val key) (locale-val (gensym)) (default-val default)) - `#'(lambda () + `#'(lambda () (let ((,current-lisplet (current-lisplet)) (,current-page (current-page)) (,current-component (current-component)) (,locale-val ,locale) - (,result)) + (,result)) (unless ,locale-val (setf ,locale-val (user-locale))) (when ,current-lisplet @@ -176,7 +178,7 @@ (when (and (null ,result) ,current-page) (setf ,result (message-dispatch ,current-page ,key-val ,locale-val))) (when (and (null ,result) ,current-component) - (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) + (setf ,result (message-dispatch ,current-component ,key-val ,locale-val))) (when (null ,result) (setf ,locale-val "") (when ,current-lisplet @@ -192,14 +194,14 @@ (defun do-message (key &optional (default "") locale) "This function calls the lambda function returned by the WITH-MESSAGE macro." (funcall (with-message key default locale))) - + (defun user-locale (&optional (request *request*) (session *session*)) "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 - (setf locale (first (loop for str in (all-matches-as-strings - "[A-Z|a-z|_]+" + (setf locale (first (loop for str in (all-matches-as-strings + "[A-Z|a-z|_]+" (regex-replace-all "-" (regex-replace-all ";.*" (header-in "ACCEPT-LANGUAGE" request) "") "_")) collect (if (> (length str) 2) (string-upcase str :start 2) @@ -212,24 +214,24 @@ (unless session (setf session (claw-start-session))) (setf (session-value 'locale session) locale)) - -(defun validation-errors (&optional (request *request*)) + +(defun validation-errors (&optional (request *request*)) "Resurns possible validation errors occurred during form rewinding" (aux-request-value :validation-errors request)) -(defun (setf validation-errors) (value &optional (request *request*)) +(defun (setf validation-errors) (value &optional (request *request*)) "Sets possible validation errors occurred during form rewinding" (setf (aux-request-value :validation-errors request) value)) -(defun validation-compliances (&optional (request *request*)) +(defun validation-compliances (&optional (request *request*)) "Resurns the list of components that pass validation during form rewinding" (aux-request-value :validation-compliances request)) -(defun (setf validation-compliances) (value &optional (request *request*)) +(defun (setf validation-compliances) (value &optional (request *request*)) "Sets the list of components that pass validation during form rewinding" (setf (aux-request-value :validation-compliances request) value)) -(defun add-validation-compliance (id &optional (request *request*)) +(defun add-validation-compliance (id &optional (request *request*)) "Adds a component id to the list of components that pass validation during form rewinding" (setf (validation-compliances request) (nconc (validation-compliances request) (list id)))) @@ -252,7 +254,7 @@ (defmethod initialize-instance :after ((class metacomponent) &key) (let* ((name (class-name class)) (builder-function (format nil "~a>" name)) - (symbolf (find-symbol builder-function))) + (symbolf (find-symbol builder-function))) (unless symbolf (setf symbolf (intern builder-function))) (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest))))) @@ -261,15 +263,15 @@ "Helper function that generates documentation for wcomponent init functions" (let* ((class-slots (closer-mop:class-direct-slots class))) (format nil "~{~%~a~}" - (remove-if #'null + (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 + (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 ") @@ -284,41 +286,46 @@ "No") (if (find-first-classdefault-initarg-value initargs :empty) "No" - "Yes") + "Yes") (if reserved-parameters (format nil "~{:~a ~}" (eval reserved-parameters)) - "NONE")))) + "NONE")))) -(defun register-library-resource (location resource-path &optional content-type (encoding :utf-8)) +(defun register-library-resource (location resource-path &optional content-type external-format) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (setf *claw-libraries-resources* (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) + (cons location + (if (directory-pathname-p resource-path) #'(lambda () - (let ((resource-full-path (merge-pathnames + (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length location)))) - resource-path)) - (charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) - (setf (reply-external-format) charset-encoding) - (handle-static-file resource-full-path content-type))) - #'(lambda () (let ((charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) - (setf (reply-external-format) charset-encoding) + resource-path))) + (unless (or (null external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name external-format))) + (setf (reply-external-format) external-format)) + (handle-static-file resource-full-path content-type))) + #'(lambda () (progn + (unless (or (null external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name external-format))) + (setf (reply-external-format) external-format)) (handle-static-file resource-path content-type))))) *claw-libraries-resources*)))) (defun uri-to-pathname (uri &optional (relative t)) "Convert an URI to a pathname" (let* ((splitted-uri (split-sequence #\/ uri)) - (directory-list (butlast splitted-uri)) + (directory-list (butlast splitted-uri)) (file (first (last splitted-uri))) (pos (position #\. file :from-end t)) (file-name-and-type (if (and pos (> pos 0) (string-not-equal (subseq file (1+ pos)) "")) (list (subseq file 0 pos)(subseq file (1+ pos))) (list file)))) - (make-pathname :directory (if relative + (make-pathname :directory (if relative (cons :relative directory-list) (cons :absolute directory-list)) :name (first file-name-and-type) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sat Jun 14 01:16:01 2008 @@ -26,7 +26,7 @@ ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + (in-package :cl-user) (export 'HUNCHENTOOT::REQUEST-REALM 'HUNCHENTOOT) @@ -42,29 +42,28 @@ :*xhtml-1.0-strict* :*xhtml-1.0-transitional* :*xhtml-1.0-frameset* - :*default-encoding* - :*rewind-parameter* + :*rewind-parameter* :*clawserver-base-path* :*apache-http-port* :*apache-https-port* :*empty-tags* :tag-emptyp - :strings-to-jsarray + :strings-to-jsarray :empty-string-p :build-tagf - :page - :page-encoding + :page + :page-external-format :page-url :page-lisplet :page-current-form - :page-req-parameter + :page-req-parameter :page-script-files :page-stylesheet-files :page-class-initscripts :page-instance-initscripts - :page-current-component + :page-current-component :page-body-init-scripts - :htcomponent + :htcomponent :htcomponent-page :htcomponent-body :htcomponent-empty @@ -74,14 +73,14 @@ :htcomponent-stylesheet-files :htcomponent-class-initscripts :htcomponent-instance-initscript - :tag + :tag :tag-name :tag-attributes :htbody :htscript :htlink :hthead - :htstring + :htstring :$> :$raw> ;empty tags definition @@ -177,27 +176,33 @@ :u> :ul> :var> - ;; class modifiers + ;; class modifiers :page-content :generate-id :metacomponent :wcomponent :wcomponent-informal-parameters :wcomponent-allow-informal-parametersp - :wcomponent-template + :wcomponent-template :wcomponent-before-rewind :wcomponent-after-rewind :wcomponent-before-prerender :wcomponent-after-prerender :wcomponent-before-render - :wcomponent-after-render + :wcomponent-after-render :cform + :form-method :cform> :action :action-link - :action-link> + :action-link> :cinput :cinput> + :ctextarea + :ctextarea> + :cinput-file + :cinput-file> + :cinput-result-as-list-p :ccheckbox :ccheckbox> :cradio @@ -208,23 +213,23 @@ :csubmit> :csubmit-value :submit-link - :submit-link> + :submit-link> :input-type :ccheckbox-value :css-class :name-attr :lisplet - :lisplet-encoding + :lisplet-external-format :lisplet-pages :lisplet-register-page-location :lisplet-register-function-location :lisplet-register-resource-location - :lisplet-protect + :lisplet-protect :lisplet-authentication-type :claw-start-session :build-lisplet-location ;; clawserver - :clawserver + :clawserver :clawserver-base-path :clawserver-register-lisplet :clawserver-unregister-lisplet @@ -240,7 +245,7 @@ :clawserver-input-chunking-p :clawserver-read-timeout :clawserver-write-timeout - :clawserver-login-config + :clawserver-login-config #+(and :unix (not :win32)) :clawserver-setuid #+(and :unix (not :win32)) :clawserver-setgid #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file @@ -252,7 +257,7 @@ :*id-and-static-id-description* :describe-component-behaviour :describe-html-attributes-from-class-slot-initargs - :clawserver-register-configuration + :clawserver-register-configuration :configuration :configuration-login :principal @@ -273,7 +278,7 @@ :message-dispatcher :message-dispatch :simple-message-dispatcher - :simple-message-dispatcher-add-message + :simple-message-dispatcher-add-message :with-message :do-message ;;validation @@ -282,16 +287,22 @@ :translator-number :translator-boolean :translator-date + :translator-file :translator-encode :translator-decode :translator-string-to-type :translator-type-to-string :translator-value-decode - :translator-value-encode + :translator-value-encode :translator-value-string-to-type :translator-value-type-to-string :*simple-translator* :*boolean-translator* + :*integer-translator* + :*number-translator* + :*date-translator-ymd* + :*date-translator-time* + :*file-translator* :*locales* :validate :validation-errors Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Sat Jun 14 01:16:01 2008 @@ -63,9 +63,9 @@ (:documentation "When boud to apache with mod_lisp2 if not nil, uses apache logging. When server is started an error will be signaled.")) (defgeneric (setf clawserver-input-chunking-p) (input-chunking-p clawserver) - (:documentation "Sets input-chunking-p, when true the server will accept request -bodies without a Content-Length header if the client uses chunked transfer encoding. -If you want to use this feature behind mod_lisp, you should make sure that your combination of + (:documentation "Sets input-chunking-p, when true the server will accept request +bodies without a Content-Length header if the client uses chunked transfer encoding. +If you want to use this feature behind mod_lisp, you should make sure that your combination of Apache and mod_lisp can cope with that. When server is started an error will be signaled.")) (defgeneric (setf clawserver-read-timeout) (read-timeout clawserver) @@ -97,18 +97,17 @@ (:documentation "Authenticate a user creating a principal object that will be stored into the http session. If no session is present one will be created, if the authentication succeds the principal instance is returned")) -(defclass error-page (page) +(defclass error-page (page) ((title :initarg :title :reader page-title :documentation "The page title") (error-code :initarg :error-code :reader page-error-code :documentation "The error code to display")) - (:default-initargs :encoding :utf-8) - (:documentation "This is the page class used to render + (:documentation "This is the page class used to render the http error messages.")) -(defclass error-page-template (wcomponent) +(defclass error-page-template (wcomponent) ((title :initarg :title :reader title :documentation "The page title") @@ -126,7 +125,7 @@ span.blue { background-color: #525D76; color: white; - font-weight: bolder; + font-weight: bolder; margin-right: .25em; } p.h1, p.h2 { @@ -152,7 +151,7 @@ (defmethod wcomponent-template ((error-page-template error-page-template)) (let ((error-code (error-code error-page-template)) (title (title error-page-template)) - (style (style error-page-template))) + (style (style error-page-template))) (html> (head> (title> title) @@ -177,12 +176,12 @@ (hr> :noshade "noshade")) (p> :class "h2" "claw server")))))) - -(defmethod page-content ((error-page error-page)) - (error-page-template> :title (page-title error-page) + +(defmethod page-content ((error-page error-page)) + (error-page-template> :title (page-title error-page) :error-code (page-error-code error-page) - (format nil "The requested resource (~a) is not available." (request-uri *request*)))) - + (format nil "The requested resource (~a) is not available." (request-uri *request*)))) + (defclass clawserver () ((base-path :initarg :base-path :accessor clawserver-base-path @@ -204,15 +203,15 @@ :documentation "Returns the name of the server that dispatches https requests.") (mod-lisp-p :initarg :mod-lisp-p :reader clawserver-mod-lisp-p - :documentation "Returns not nil when the server is bound to apache through mod_lisp") + :documentation "Returns not nil when the server is bound to apache through mod_lisp") (use-apache-log-p :initarg :use-apache-log-p :reader clawserver-use-apache-log-p :documentation "Returns not nil when the server uses apache logging") (input-chunking-p :initarg :input-chunking-p :reader clawserver-input-chunking-p - :documentation "When true the server will accept request -bodies without a Content-Length header if the client uses chunked transfer encoding. -If you want to use this feature behind mod_lisp, you should make sure that your combination of + :documentation "When true the server will accept request +bodies without a Content-Length header if the client uses chunked transfer encoding. +If you want to use this feature behind mod_lisp, you should make sure that your combination of Apache and mod_lisp can cope with that.") (read-timeout :initarg :read-timeout :reader clawserver-read-timeout @@ -249,23 +248,23 @@ (dispatchers :initform nil :accessor clawserver-dispatchers :documentation "A collection of cons where the car is an url location where a lisplet is registered and the cdr is a dispatcher for that lisplet")) - (:default-initargs :base-path "" + (:default-initargs :base-path "" :use-apache-log-p nil - :address nil + :address nil :name (gensym) :sslname (gensym) - :port 80 + :port 80 :sslport 443 - :mod-lisp-p nil + :mod-lisp-p nil :input-chunking-p t - :read-timeout *default-read-timeout* + :read-timeout *default-read-timeout* :write-timeout *default-write-timeout* #+(and :unix (not :win32)) :setuid nil #+(and :unix (not :win32)) :setgid nil #-:hunchentoot-no-ssl :ssl-certificate-file nil #-:hunchentoot-no-ssl :ssl-privatekey-password nil) - (:documentation "CLAWSERVER is built around huncentoot and has the -instructions for lisplet dispatching, so use this class to start and stop + (:documentation "CLAWSERVER is built around huncentoot and has the +instructions for lisplet dispatching, so use this class to start and stop 3hunchentoot server.")) (defclass configuration () @@ -291,7 +290,7 @@ (when (eq use-apache-log-p :undefined) (setf (clawserver-use-apache-log-p clawserver) (getf keys :mod-lisp-p))) #-:hunchentoot-no-ssl (when (eq ssl-privatekey-file :undefined) - (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) + (setf (clawserver-ssl-privatekey-file clawserver) (getf keys :ssl-certificate-file))))) ;;;-------------------------- WRITERS ---------------------------------------- @@ -385,8 +384,8 @@ (setf (current-server) clawserver) (when (starts-with-subseq script-name base-path) (setf rel-script-name (subseq script-name (length base-path)) - rel-script-name-libs (subseq script-name (1+ (length base-path)))) - (or + rel-script-name-libs (subseq script-name (1+ (length base-path)))) + (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) @@ -395,11 +394,11 @@ for url = (car dispatcher) for action = (cdr dispatcher) do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))) - + (defmethod clawserver-dispatch-method ((clawserver clawserver)) - (let ((result (clawserver-dispatch-request clawserver))) + (let ((result (clawserver-dispatch-request clawserver))) (if (null result) - #'(lambda () (when (= (return-code) +http-ok+) + #'(lambda () (when (= (return-code) +http-ok+) (setf (return-code *reply*) +http-not-found+))) #'(lambda () result)))) @@ -407,7 +406,7 @@ (let ((port (clawserver-port clawserver)) (sslport (clawserver-sslport clawserver)) (address (clawserver-address clawserver)) - (dispatch-table (list #'(lambda (request) + (dispatch-table (list #'(lambda (request) (declare (ignorable request)) (clawserver-dispatch-method clawserver)))) (name (clawserver-name clawserver)) @@ -451,9 +450,9 @@ :ssl-certificate-file ssl-certificate-file :ssl-privatekey-file ssl-privatekey-file :ssl-privatekey-password ssl-privatekey-password)))))) - + (defmethod clawserver-stop ((clawserver clawserver)) - (progn + (progn (setf (clawserver-server clawserver) (stop-server (clawserver-server clawserver))) (when (clawserver-sslserver clawserver) (setf (clawserver-sslserver clawserver) (stop-server (clawserver-sslserver clawserver)))))) @@ -464,4 +463,4 @@ (realm (current-realm request)) (login-config (gethash realm (clawserver-login-config server)))) (configuration-login login-config request))) - + Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sat Jun 14 01:16:01 2008 @@ -33,25 +33,33 @@ (:documentation "Returns the KEY translation by the given LOCALE")) (defgeneric page-req-parameter (page name &optional as-list) - (:documentation "This method returns a request parameter given by NAME searching first + (:documentation "This method returns a request parameter given by NAME searching first into post parameters and, if no parameter found, into get prarmeters. The optional function parameter AS-LIST if true returns the result as list. -When AS-LIST is true, if the searched parameter is found more then once, a list with +When AS-LIST is true, if the searched parameter is found more then once, a list with all valuse given to param NAME is returned. - PAGE is the page instance that must be given. - NAME The parameter to search - AS-LIST If true the result is returned as list, if false as string. Default: false")) (defgeneric page-json-id-list (page) - (:documentation "This internal method is called to get a list of all the components by their id, that must be updated when + (:documentation "This internal method is called to get a list of all the components by their id, that must be updated when an xhr request is sent from the browser. - PAGE is the page instance that must be given")) -(defgeneric page-content (page) +(defgeneric page-json-prefix (page) + (:documentation "This internal method is called to get a prefix to prepend to a json reply when needed. + - PAGE is the page instance that must be given")) + +(defgeneric page-json-suffix (page) + (:documentation "This internal method is called to get a suffix to append to a json reply when needed. + - PAGE is the page instance that must be given")) + +(defgeneric page-content (page) (:documentation "This method returns the page content to be redered. - PAGE is the page instance that must be given")) -(defgeneric page-init (page) +(defgeneric page-init (page) (:documentation "Internal method for page initialization. - PAGE is the page instance that must be given")) @@ -60,7 +68,7 @@ - PAGE is the page instance that must be given")) (defgeneric page-init-injections (page) - (:documentation "This internal method is called during the request cycle phase to reset page slots that + (:documentation "This internal method is called during the request cycle phase to reset page slots that must be reinitialized during sub-phases (rewinding, pre-rendering, rendering). - PAGE is the page instance that must be given")) @@ -68,8 +76,8 @@ (:documentation "This internal method renders the html first lines that determine if the page is a html or a xhtml, along with the schema definition. - 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. +(defgeneric page-request-parameters (page) + (: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) @@ -83,8 +91,8 @@ (defgeneric page-format (page str &rest rest) (:documentation "This internal method is the replacement of the FORMAT function. It is aware -of an xhr request when the reply must be given as a json object. It also uses the default page output stream -to render the output. +of an xhr request when the reply must be given as a json object. It also uses the default page output stream +to render the output. - PAGE is the page instance that must be given - STR The format control - REST The format arguments @@ -92,8 +100,8 @@ (defgeneric page-format-raw (page str &rest rest) (:documentation "This internal method is the replacement of the FORMAT. -The difference with PAGE-FORMAT is that it prints out the result ignoring the json directive. -It also uses the default page output stream as PAGE-FORMAT does to render the output. +The difference with PAGE-FORMAT is that it prints out the result ignoring the json directive. +It also uses the default page output stream as PAGE-FORMAT does to render the output. - PAGE is the page instance that must be given - STR The format control - REST The format arguments @@ -101,9 +109,9 @@ (defgeneric page-body-init-scripts (page) (:documentation "During the render phase wcomponent instances inject their initialization scripts (javascript) -that will be evaluated when the page has been loaded. +that will be evaluated when the page has been loaded. This internal method is called to render these scripts. - - PAGE is the page instance that must be given")) + - PAGE is the page instance that must be given")) (defgeneric htbody-init-scripts-tag (page &optional on-load) (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component @@ -115,25 +123,25 @@ (:documentation "The component being processed into one of the rendering phases")) (defgeneric htcomponent-rewind (htcomponent page) - (:documentation "This internal method is the first called during the request cycle phase. + (:documentation "This internal method is the first called during the request cycle phase. It is evaluated when a form action or an action-link action is fired. It is used to update all visit objects slots. - HTCOMPONENT is the htcomponent instance that must be rewound - PAGE is the page instance that must be given")) (defgeneric htcomponent-prerender (htcomponent page) - (:documentation "This internal method is the second sub phase during the request cycle phase. + (:documentation "This internal method is the second sub phase during the request cycle phase. It is used to inject all wcomponent class scripts and stylesheets into the owner page. - HTCOMPONENT is the htcomponent instance that must be prerendered - PAGE is the page instance that must be given")) (defgeneric htcomponent-render (htcomponent page) - (:documentation "This internal method is the last called during the request cycle phase. + (:documentation "This internal method is the last called during the request cycle phase. It is used to effectively render the component into the page. - HTCOMPONENT is the htcomponent instance that must be rendered - PAGE is the page instance that must be given")) (defgeneric htcomponent-can-print (htcomponent) - (:documentation "This internal method is used in an xhr call to determine + (:documentation "This internal method is used in an xhr call to determine if a component may be rendered into the reply - HTCOMPONENT is the htcomponent instance")) @@ -147,7 +155,7 @@ on component end. - HTCOMPONENT is the htcomponent instance")) -(defgeneric tag-render-starttag (tag page) +(defgeneric tag-render-starttag (tag page) (:documentation "Internal method to print out the opening html tag during the render phase - TAG is the tag instance - PAGE the page instance")) @@ -166,7 +174,7 @@ (:documentation "Returns an alist of tag attributes")) (defgeneric (setf htcomponent-page) (page htcomponent) - (:documentation "Internal method to set the component owner page and to assign + (:documentation "Internal method to set the component owner page and to assign an unique id attribute when provided. - HTCOMPONENT is the tag instance - PAGE the page instance")) @@ -208,25 +216,25 @@ (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")) -(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" +(defvar *html-4.01-strict* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">" "Page doctype as HTML 4.01 STRICT") -(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" +(defvar *html-4.01-transitional* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">" "Page doctype as HTML 4.01 TRANSITIONAL") -(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" +(defvar *html-4.01-frameset* "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" "Page doctype as HTML 4.01 FRAMESET") -(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" +(defvar *xhtml-1.0-strict* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" "Page doctype as HTML 4.01 XHTML") -(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" +(defvar *xhtml-1.0-transitional* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">" "Page doctype as XHTML 4.01 TRANSITIONAL") -(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" +(defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET") -(defvar *rewind-parameter* "rewindobject" +(defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") (defvar *empty-tags* @@ -236,29 +244,29 @@ "List of html empty tags") (defun request-id-table-map () - "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. -So if you have a :id \"compId\" given to a previous component, the second + "Holds an hash table of used components/tags id as keys and the number of their occurrences as values. +So if you have a :id \"compId\" given to a previous component, the second time this id will be used, it will be rendered as \"compId1\", the third time will be \"compId2\" and so on" - (when (boundp '*request*) + (when (boundp '*request*) (let ((id-table-map (aux-request-value :id-table-map))) (if (null id-table-map) - (progn + (progn (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal))) id-table-map)))) - + (defun reset-request-id-table-map () "This function resets the ID-TABLE-MAP built during the request cycle to handle id uniqueness. See REQUEST-ID-TABLE-MAP for more info." - (when (boundp '*request*) + (when (boundp '*request*) (setf (aux-request-value :id-table-map) (make-hash-table :test 'equal)))) (defun parse-htcomponent-function (function-body) "This function parses attributes passed to a htcomponent creation function" (let ((attributes) (body)) - (loop for last-elem = nil then elem - for elem in function-body - do (if (and (null body) + (loop for last-elem = nil then elem + for elem in function-body + do (if (and (null body) (or (keywordp elem) (keywordp last-elem))) (push elem attributes) @@ -269,7 +277,7 @@ (defun generate-id (id) "This function is very useful when having references to components id inside component body. -When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." +When used with :STATIC-ID the generated id will be mantained as is, and rendered just like the :ID tag attribute." (let* ((id-ht (request-id-table-map)) (client-id-index (gethash id id-ht 0)) (result)) @@ -281,29 +289,35 @@ (defun build-tagf (tag-name parent emptyp &rest rest) "This function is used to create a tag object instance -- TAG-NAME the a string tag name to create, for example \"span\" +- TAG-NAME the a string tag name to create, for example \"span\" - PARENT the parent class. usually TAG - EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase. - REST a list of attribute/value pairs and the component body" (let* ((fbody (parse-htcomponent-function (flatten rest))) (id-table-map (request-id-table-map)) - (id (getf (first fbody) :id)) - (static-id (getf (first fbody) :static-id)) + (attributes (first fbody)) + (id (getf attributes :id)) + (static-id (getf attributes :static-id)) + (render-condition (getf attributes :render-condition)) (real-id (or static-id id)) (instance)) (when static-id - (remf (first fbody) :id) + (remf attributes :id) (setf id nil)) - (setf instance (make-instance parent + (when render-condition + (remf attributes :render-condition)) + (setf instance (make-instance parent :empty emptyp :real-id real-id :name (string-downcase tag-name) - :attributes (first fbody) + :render-condition render-condition + :attributes attributes :body (second fbody))) - (if (null static-id) - (when (and id-table-map id) - (setf (htcomponent-client-id instance) (generate-id id))) - (setf (htcomponent-client-id instance) static-id)) + (when real-id + (if (null static-id) + (when (and id-table-map id) + (setf (htcomponent-client-id instance) (generate-id id))) + (setf (htcomponent-client-id instance) static-id))) instance)) (defun generate-tagf (tag-name emptyp) @@ -313,7 +327,7 @@ (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" + (setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag" (if emptyp "empty " "") @@ -321,17 +335,17 @@ ;;;---------------------------------------------------------------- -(defclass message-dispatcher () +(defclass message-dispatcher () () (:documentation "This is and interface for message dispatchers")) -(defclass simple-message-dispatcher (message-dispatcher) +(defclass simple-message-dispatcher (message-dispatcher) ((locales :initform (make-hash-table :test #'equal) :accessor simple-message-dispatcher-locales :documentation "Hash table of locales strings and KEY/VALUE message pairs")) (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases.")) -(defclass i18n-aware (message-dispatcher) +(defclass i18n-aware (message-dispatcher) ((message-dispatcher :initarg :message-dispatcher :accessor message-dispatcher :documentation "Reference to a MESSAGE-DISPATCHER instance")) @@ -340,12 +354,12 @@ (defclass page(i18n-aware) ((writer :initarg :writer - :accessor page-writer :documentation "The output stream for this page instance") + :accessor page-writer :documentation "The output stream for this page instance") (lisplet :initarg :lisplet :reader page-lisplet :documentation "The lisplet that owns this page instance") (can-print :initform nil :accessor page-can-print - :documentation "Controls the printing process when a json request is dispatched. + :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") @@ -354,18 +368,18 @@ (class-initscripts :initarg :class-initscripts :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") (instancee-initscripts :initarg :instance-initscripts - :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") + :accessor page-instance-initscripts :documentation "Holds component instance javascript directives injected by components during the request cycle") (indent :initarg :indent :accessor page-indent :documentation "Determine if the output must be indented or not") (tabulator :initarg :tabulator :accessor page-tabulator :documentation "Holds the indentation level") (xmloutput :initarg :xmloutput :accessor page-xmloutput :documentation "Determine if the page must be rendered as an XML") - (current-form :initform :nil + (current-form :initform nil :accessor page-current-form :documentation "During the rewinding phase the form or the action-link whose action has been fired") (doc-type :initarg :doc-type :accessor page-doc-type :documentation "The DOCUMENT TYPE of the page (default to HTML 4.01 STRICT)") - (lasttag :initform nil + (lasttag :initform nil :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.") @@ -375,17 +389,20 @@ :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.") + :documentation "A stack of components enetered into rendering process.") (mime-type :initarg :mime-type - :accessor page-mime-type - :documentation "Define the mime type of the page when rendered") - (encoding :initarg :encoding - :accessor page-encoding - :documentation "The charset external format. When not provided the lisplet one is used") + :accessor page-mime-type + :documentation "Define the mime type of the page when rendered") + (external-format :initarg :external-format + :accessor page-external-format + :documentation "The charset external format. When not provided the lisplet one is used") + (injection-writing-p :initform nil + :accessor page-injection-writing-p + :documentation "Flag that becomes true when rendering page injections") (url :initarg :url :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t - :script-files nil + :script-files nil :json-component-count 0 :stylesheet-files nil :class-initscripts nil @@ -396,12 +413,13 @@ :doc-type *html-4.01-strict* :request-parameters nil :mime-type "text/html" + :external-format nil :url nil) (:documentation "A page object holds claw components to be rendered") ) - + (defclass htcomponent (i18n-aware) ((page :initarg :page - :reader htcomponent-page :documentation "The owner page") + :reader htcomponent-page :documentation "The owner page") (json-render-on-validation-errors-p :initarg :json-render-on-validation-errors-p :reader htcomponent-json-render-on-validation-errors-p :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.") @@ -410,11 +428,14 @@ (client-id :initarg :client-id :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") (real-id :initarg :real-id - :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID") + :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID") (attributes :initarg :attributes :accessor htcomponent-attributes :documentation "The tag attributes") (empty :initarg :empty :accessor htcomponent-empty :documentation "Determine if the tag has to be rendered as an empty tag") + (render-condition :initarg :render-condition + :accessor htcomponent-render-condition + :documentation "When not nil the component followr the pre-rendering and rendering phase only if the execution of this function isn't nil") (script-files :initarg :script-files :accessor htcomponent-script-files :documentation "Page injectable script files") (stylesheet-files :initarg :stylesheet-files @@ -423,13 +444,13 @@ :accessor htcomponent-class-initscripts :documentation "Page injectable javascript class derectives") (instance-initscript :initarg :instance-initscript :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) - (:default-initargs :page nil + (:default-initargs :page nil :body nil :json-render-on-validation-errors-p nil - :client-id nil :real-id nil - :attributes nil + :attributes nil :empty nil + :render-condition nil :script-files nil :stylesheet-files nil :class-initscripts nil @@ -471,19 +492,19 @@ (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" + "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" + "This function generates the <body> html tag" (build-tagf "body" 'htbody nil rest)) (defclass hthead (tag) () @@ -499,21 +520,21 @@ (mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) ;;Creates non empty tag initialization functions. But the ones directly defined - '("a" "abbr" "acronym" "address" "applet" - "b" "bdo" "big" "blockquote" "button" - "caption" "center" "cite" "code" "colgroup" - "dd" "del" "dfn" "dir" "div" "dl" "dt" - "em" + '("a" "abbr" "acronym" "address" "applet" + "b" "bdo" "big" "blockquote" "button" + "caption" "center" "cite" "code" "colgroup" + "dd" "del" "dfn" "dir" "div" "dl" "dt" + "em" "fieldset" "font" "form" "frameset" "h1" "h2" "h3" "h4" "h5" "h6" "html" "i" "iframe" "ins" "kbd" "label" "legend" "li" "map" "menu" - "noframes" "noscript" + "noframes" "noscript" "object" "ol" "optgroup" "option" - "p" "pre" - "q" + "p" "pre" + "q" "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" "u" "ul" "var")) @@ -523,15 +544,16 @@ (member tag-name *empty-tags* :test #'string-equal)) ;;;--------------------METHODS implementation---------------------------------------------- -(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) - (let ((id (getf (htcomponent-attributes htcomponent) :id)) - (static-id (getf (htcomponent-attributes htcomponent) :static-id)) - (client-id (htcomponent-client-id htcomponent))) - (setf (slot-value htcomponent 'page) page) - (unless client-id - (if static-id - (setf (htcomponent-client-id htcomponent) static-id) - (setf (htcomponent-client-id htcomponent) (generate-id id)))))) +(defmethod (setf htcomponent-page) ((page page) (htcomponent htcomponent)) + (setf (slot-value htcomponent 'page) page) + (when (htcomponent-real-id htcomponent) + (let ((id (getf (htcomponent-attributes htcomponent) :id)) + (static-id (getf (htcomponent-attributes htcomponent) :static-id)) + (client-id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent)))) + (unless client-id + (if static-id + (setf (htcomponent-client-id htcomponent) static-id) + (setf (htcomponent-client-id htcomponent) (generate-id id))))))) (defmethod page-request-parameters ((page page)) (if (and (boundp '*request*) (null (slot-value page 'request-parameters))) @@ -539,7 +561,7 @@ (pparameters (make-hash-table :test 'equal))) (loop for kv in parameters do (setf (gethash (string-upcase (car kv)) pparameters) - (append (gethash (string-upcase (car kv)) pparameters) + (append (gethash (string-upcase (car kv)) pparameters) (list (cdr kv))))) (setf (slot-value page 'request-parameters) pparameters)) (slot-value page 'request-parameters))) @@ -558,7 +580,7 @@ (writer (page-writer page))) (if (null jsonp) (apply #'format writer str rest) - (apply #'format writer (list + (apply #'format writer (list (regex-replace-all "\"" (regex-replace-all "\\\\\"" (regex-replace-all "\\n" @@ -574,16 +596,22 @@ (defmethod page-json-id-list ((page page)) (page-req-parameter page "json" t)) +(defmethod page-json-prefix ((page page)) + (or (page-req-parameter page "jsonPrefix" nil) "")) + +(defmethod page-json-suffix ((page page)) + (or (page-req-parameter page "jsonSuffix" nil) "")) + (defmethod page-init ((page page)) (progn - (reset-request-id-table-map) + (reset-request-id-table-map) (setf (page-can-print page) (null (page-json-id-list page))) (reset-request-id-table-map) (setf (page-tabulator page) 0))) (defmethod page-render-headings ((page page)) - (let* ((jsonp (page-json-id-list page)) - (encoding (page-encoding page)) + (let* ((jsonp (page-json-id-list page)) + (encoding (flexi-streams:external-format-name (or (page-external-format page) (reply-external-format)))) (xml-p (page-xmloutput page)) (doc-type (page-doc-type page))) (when (null jsonp) @@ -595,26 +623,29 @@ (defun json-validation-errors () "Composes the error part for the json reply" (let ((validation-errors (validation-errors))) - (if validation-errors - (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr - collect (symbol-name component-id) - collect (push 'array messages))) + (if validation-errors + (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr + collect (symbol-name component-id) + collect (push 'array messages))) (js-struct (ps:ps* `(create ,@errors)))) - (subseq js-struct 0 (1- (length js-struct)))) + (subseq js-struct 0 (1- (length js-struct)))) "null"))) (defun json-validation-compliances () "Composes the compliances part to form validation for the json reply" (let ((js-array (ps:ps* `(array ,@(validation-compliances))))) (subseq js-array 0 (1- (length js-array))))) - -(defmethod page-render ((page page)) + +(defmethod page-render ((page page)) (let ((body (page-content page)) - (jsonp (page-json-id-list page))) - (setf (reply-external-format) - (flexi-streams:make-external-format (page-encoding page) :eol-style :lf)) + (jsonp (page-json-id-list page)) + (external-format (page-external-format page))) + (unless (or (null external-format) + (eq (flexi-streams:external-format-name (reply-external-format)) + (flexi-streams:external-format-name external-format))) + (setf (reply-external-format) external-format)) (if (null body) - (format nil "null body for page ~a~%" (type-of page)) + (format nil "null body for page ~a~%" (type-of page)) (progn (setf (current-page) page) (page-init page) @@ -623,13 +654,15 @@ (page-init page) (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! (page-render-headings page) - (page-init page) + (page-init page) (when jsonp + (page-format-raw page (page-json-prefix page)) (page-format-raw page "{components:{")) (htcomponent-render (page-content page) page) ;Here we need a fresh new body!!! (when jsonp (page-format-raw page "},classInjections:\"") - (setf (page-can-print page) t) + (setf (page-can-print page) t + (page-injection-writing-p page) t) (dolist (injection (page-init-injections page)) (when injection (htcomponent-render injection page))) @@ -641,7 +674,8 @@ (page-format-raw page (json-validation-errors)) (page-format-raw page ",valid:") (page-format-raw page (json-validation-compliances)) - (page-format-raw page "}")))))) + (page-format-raw page "}") + (page-format-raw page (page-json-suffix page))))))) (defmethod page-body-init-scripts ((page page)) (let ((js-body "")) @@ -656,26 +690,26 @@ (tabulator (page-tabulator page)) (indent-p (page-indent page))) (when (and (<= 0 tabulator) indent-p (null jsonp)) - (page-format-raw page "~a" + (page-format-raw page "~a" (make-string tabulator :initial-element #\tab))))) (defmethod page-newline ((page page)) (let ((jsonp (page-json-id-list page)) (indent-p (page-indent page))) (when (and indent-p (null jsonp)) - (page-format-raw page "~%")))) + (page-format-raw page "~%")))) (defmethod page-init-injections ((page page)) (let ((tag-list) - (class-init-scripts "")) + (class-init-scripts "")) (dolist (script (reverse (page-class-initscripts page))) - (setf class-init-scripts (format nil "~a~%~a" + (setf class-init-scripts (format nil "~a~%~a" class-init-scripts script))) (unless (string= "" class-init-scripts) (let ((current-js (script> :type "text/javascript"))) (setf (htcomponent-body current-js) class-init-scripts) - (push current-js tag-list))) + (push current-js tag-list))) (dolist (js-file (page-script-files page)) (if (typep js-file 'htcomponent) (push js-file tag-list) @@ -701,24 +735,24 @@ (car (page-components-stack page))))) ;;;========= HTCOMPONENT ============================ (defmethod htcomponent-can-print ((htcomponent htcomponent)) - (let* ((id (htcomponent-client-id htcomponent)) - (page (htcomponent-page htcomponent)) + (let* ((id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) + (page (htcomponent-page htcomponent)) (print-status (page-can-print page)) (validation-errors (validation-errors)) (json-render-on-validation-errors-p (htcomponent-json-render-on-validation-errors-p htcomponent)) (render-p (or (and (member id (page-json-id-list page) :test #'string=) (null validation-errors)) print-status))) - #|json-render-on-validation-errors-p|# + #|json-render-on-validation-errors-p|# (or json-render-on-validation-errors-p print-status render-p))) (defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent)) - (validation-errors (validation-errors))) - (when (and jsonp - (or (and (null validation-errors) + (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) + (validation-errors (validation-errors))) + (when (and jsonp + (or (and (null validation-errors) (member id jsonp :test #'string-equal)) (htcomponent-json-render-on-validation-errors-p htcomponent))) (when (> (page-json-component-count page) 0) @@ -730,10 +764,10 @@ (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent)) + (id (when (slot-boundp htcomponent 'client-id) (htcomponent-client-id htcomponent))) (validation-errors (validation-errors))) - (when (and jsonp - (or (and (null validation-errors) + (when (and jsonp + (or (and (null validation-errors) (member id jsonp :test #'string-equal)) (htcomponent-json-render-on-validation-errors-p htcomponent))) (pop (page-json-component-id-list page)) @@ -744,21 +778,29 @@ (push htcomponent (page-components-stack page))) (defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack page))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))))) (defmethod htcomponent-render :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack page))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))))) (defmethod htcomponent-rewind :after ((htcomponent htcomponent) (page page)) (pop (page-components-stack page))) (defmethod htcomponent-prerender :after ((htcomponent htcomponent) (page page)) - (pop (page-components-stack page))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (pop (page-components-stack page))))) (defmethod htcomponent-render :after ((htcomponent htcomponent) (page page)) - (pop (page-components-stack page))) + (let ((render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (pop (page-components-stack page))))) (defmethod htcomponent-rewind ((htcomponent htcomponent) (page page)) (dolist (tag (htcomponent-body htcomponent)) @@ -766,30 +808,34 @@ (htcomponent-rewind tag page)))) (defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) - (let ((previous-print-status (page-can-print page))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htcomponent))) - (dolist (tag (htcomponent-body htcomponent)) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) - (when (null previous-print-status) - (setf (page-can-print page) nil)))) + (let ((previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htcomponent))) + (dolist (tag (htcomponent-body htcomponent)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag page))) + (when (null previous-print-status) + (setf (page-can-print page) nil))))) -(defmethod htcomponent-render ((htcomponent htcomponent) (page page)) +(defmethod htcomponent-render ((htcomponent htcomponent) (page page)) (let ((body-list (htcomponent-body htcomponent)) - (previous-print-status (page-can-print page))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htcomponent)) - (htcomponent-json-print-start-component htcomponent)) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htcomponent)))) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htcomponent)) + (htcomponent-json-print-start-component htcomponent)) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htcomponent))))) ;;;========= TAG ===================================== (defmethod tag-attributes ((tag tag)) @@ -797,32 +843,40 @@ (defmethod tag-render-attributes ((tag tag) (page page)) (when (htcomponent-attributes tag) - (loop for (k v) on (htcomponent-attributes tag) by #'cddr + (loop for (k v) on (htcomponent-attributes tag) by #'cddr do (progn - (assert (keywordp k)) - (when (functionp v) + (assert (keywordp k)) + (when (and (functionp v) (not (eq k :render-condition))) (setf v (funcall v))) - (when (and v (string-not-equal v "")) - (page-format page " ~a=\"~a\"" - (string-downcase (if (eq k :static-id) - "id" - (parenscript::symbol-to-js k))) + (when (numberp v) + (setf v (princ-to-string v))) + (when (and (not (eq k :render-condition)) v (string-not-equal v "")) + (page-format page " ~a=\"~a\"" + (if (eq k :static-id) + "id" + (parenscript::symbol-to-js k)) (let ((s (if (eq k :id) (prin1-to-string (htcomponent-client-id tag)) - (prin1-to-string v)))) ;escapes double quotes + (if (eq t v) + "\"true\"" + (prin1-to-string v))))) ;escapes double quotes (subseq s 1 (1- (length s)))))))))) (defmethod tag-render-starttag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (id (htcomponent-client-id tag)) + (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag))) (jsonp (page-json-id-list page)) (emptyp (htcomponent-empty tag)) - (xml-p (page-xmloutput page))) + (xml-p (page-xmloutput page)) + (injection-writing-p (page-injection-writing-p page))) (setf (page-lasttag page) tagname) - (unless (and jsonp (string= id (first (page-json-component-id-list page)))) + (when (or injection-writing-p + (null jsonp) + (null (and jsonp + (string= id (first (page-json-component-id-list page)))))) (page-newline page) - (page-print-tabulation page) - (page-format page "<~a" tagname) + (page-print-tabulation page) + (page-format page "<~a" tagname) (tag-render-attributes tag page) (if (null emptyp) (progn @@ -831,68 +885,77 @@ (if (null xml-p) (page-format page ">") (page-format page "/>")))))) - + (defmethod tag-render-endtag ((tag tag) (page page)) (let ((tagname (tag-name tag)) - (id (htcomponent-client-id tag)) + (id (when (slot-boundp tag 'client-id) (htcomponent-client-id tag))) (jsonp (page-json-id-list page)) (previous-tagname (page-lasttag page)) - (emptyp (htcomponent-empty tag))) - (when (and (null emptyp) (not (and jsonp - (string= id (first (page-json-component-id-list page)))))) - (progn + (emptyp (htcomponent-empty tag)) + (injection-writing-p (page-injection-writing-p page))) + (when (and (null emptyp) + (or injection-writing-p + (null jsonp) + (null (and jsonp + (string= id (first (page-json-component-id-list page))))))) + (progn (decf (page-tabulator page)) (if (string= tagname previous-tagname) (progn (page-format page "</~a>" tagname)) - (progn + (progn (page-newline page) (page-print-tabulation page) (page-format page "</~a>" tagname))))) (setf (page-lasttag page) nil))) -(defmethod htcomponent-render ((tag tag) (page page)) +(defmethod htcomponent-render ((tag tag) (page page)) (let ((body-list (htcomponent-body tag)) - (previous-print-status (page-can-print page))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print tag)) - (htcomponent-json-print-start-component tag)) - (when (or (page-can-print page) previous-print-status) - (tag-render-starttag tag page)) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (when (or (page-can-print page) previous-print-status) - (tag-render-endtag tag page)) - (unless previous-print-status - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component tag)))) - -;;;========= HTHEAD ====================================== -(defmethod htcomponent-render ((hthead hthead) (page page)) - (when (null (page-json-id-list page)) - (let ((body-list (htcomponent-body hthead)) - (injections (page-init-injections page))) - (tag-render-starttag hthead page) - (htcomponent-render (meta> :http-equiv "Content-Type" - :content (format nil "~a;charset=~a" - (page-mime-type page) - (page-encoding page))) - page) - (dolist (child-tag body-list) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition tag))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print tag)) + (htcomponent-json-print-start-component tag)) + (when (or (page-can-print page) previous-print-status) + (tag-render-starttag tag page)) + (dolist (child-tag body-list) (when child-tag - (cond + (cond ((stringp child-tag) (htcomponent-render ($> child-tag) page)) ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) (t (htcomponent-render child-tag page))))) - (dolist (injection injections) - (when injection - (htcomponent-render injection page))) - (tag-render-endtag hthead page)))) - + (when (or (page-can-print page) previous-print-status) + (tag-render-endtag tag page)) + (unless previous-print-status + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component tag))))) + +;;;========= HTHEAD ====================================== +(defmethod htcomponent-render ((hthead hthead) (page page)) + (let ((render-condition (htcomponent-render-condition hthead))) + (unless (and render-condition (null (funcall render-condition))) + (when (null (page-json-id-list page)) + (let ((body-list (htcomponent-body hthead)) + (injections (page-init-injections page)) + (encoding (flexi-streams:external-format-name (or (page-external-format page) (reply-external-format))))) + (tag-render-starttag hthead page) + (htcomponent-render (meta> :http-equiv "Content-Type" + :content (format nil "~a;charset=~a" + (page-mime-type page) + encoding)) + page) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (dolist (injection injections) + (when injection + (htcomponent-render injection page))) + (tag-render-endtag hthead page)))))) + ;;;========= HTSTRING =================================== (defmethod htcomponent-rewind((htstring htstring) (page page))) @@ -901,26 +964,28 @@ (defmethod htcomponent-render ((htstring htstring) (page page)) (let ((body (htcomponent-body htstring)) (jsonp (not (null (page-json-id-list page)))) - (print-p (page-can-print page))) - (when (and print-p body) - (when (functionp body) - (setf body (funcall body))) - (when jsonp - (setf body (regex-replace-all "\"" - (regex-replace-all "\\\\\"" - (regex-replace-all "\\n" - body - "\\n") - "\\\\\\\"") - "\\\""))) - (if (htstring-raw htstring) - (page-format-raw page body) - (loop for ch across body - do (case ch - ((#\<) (page-format-raw page "<")) - ((#\>) (page-format-raw page ">")) - ((#\&) (page-format-raw page "&")) - (t (page-format-raw page "~a" ch)))))))) + (print-p (page-can-print page)) + (render-condition (htcomponent-render-condition htstring))) + (unless (and render-condition (null (funcall render-condition))) + (when (and print-p body) + (when (functionp body) + (setf body (funcall body))) + (when jsonp + (setf body (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + body + "\\n") + "\\\\\\\"") + "\\\""))) + (if (htstring-raw htstring) + (page-format-raw page body) + (loop for ch across body + do (case ch + ((#\<) (page-format-raw page "<")) + ((#\>) (page-format-raw page ">")) + ((#\&) (page-format-raw page "&")) + (t (page-format-raw page "~a" ch))))))))) ;;;========= HTSCRIPT =================================== (defmethod htcomponent-prerender((htscript htscript) (page page))) @@ -928,76 +993,82 @@ (defmethod htcomponent-render ((htscript htscript) (page page)) (let ((xml-p (page-xmloutput page)) (body (htcomponent-body htscript)) - (previous-print-status (page-can-print page))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htscript)) - (htcomponent-json-print-start-component htscript)) - (unless (getf (htcomponent-attributes htscript) :type) - (append '(:type "text/javascript") (htcomponent-attributes htscript))) - (when (page-can-print page) - (tag-render-starttag htscript page) - (when (and (null (getf (htcomponent-attributes htscript) :src)) - (not (null (htcomponent-body htscript)))) - (if (null xml-p) - (page-format page "~%//") - (page-format page "~%//]]>"))) - (setf (page-lasttag page) nil) - (tag-render-endtag htscript page)) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htscript)))) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htscript))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htscript)) + (htcomponent-json-print-start-component htscript)) + (unless (getf (htcomponent-attributes htscript) :type) + (append '(:type "text/javascript") (htcomponent-attributes htscript))) + (when (page-can-print page) + (tag-render-starttag htscript page) + (when (and (null (getf (htcomponent-attributes htscript) :src)) + (not (null (htcomponent-body htscript)))) + (if (null xml-p) + (page-format page "~%//") + (page-format page "~%//]]>"))) + (setf (page-lasttag page) nil) + (tag-render-endtag htscript page)) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htscript))))) ;;;========= HTLINK ==================================== (defmethod htcomponent-render ((htlink htlink) (page page)) - (let ((previous-print-status (page-can-print page))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htlink)) - (htcomponent-json-print-start-component htlink)) - (when (page-can-print page) - (unless (getf (htcomponent-attributes htlink) :type) - (append '(:type "text/css") (htcomponent-attributes htlink))) - (unless (getf (htcomponent-attributes htlink) :rel) - (append '(:rel "styleshhet") (htcomponent-attributes htlink))) - (tag-render-starttag htlink page) - (tag-render-endtag htlink page)) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htlink)))) + (let ((previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htlink))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htlink)) + (htcomponent-json-print-start-component htlink)) + (when (page-can-print page) + (unless (getf (htcomponent-attributes htlink) :type) + (append '(:type "text/css") (htcomponent-attributes htlink))) + (unless (getf (htcomponent-attributes htlink) :rel) + (append '(:rel "styleshhet") (htcomponent-attributes htlink))) + (tag-render-starttag htlink page) + (tag-render-endtag htlink page)) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htlink))))) ;;;========= HTBODY =================================== (defmethod htcomponent-render ((htbody htbody) (page page)) (let ((body-list (htcomponent-body htbody)) - (previous-print-status (page-can-print page))) - (when (or (page-can-print page) previous-print-status) - (setf (page-can-print page) (htcomponent-can-print htbody)) - (htcomponent-json-print-start-component htbody)) - (when (page-can-print page) - (tag-render-starttag htbody page)) - (dolist (child-tag body-list) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (when (page-can-print page) - (htcomponent-render (htbody-init-scripts-tag page t) page) - (tag-render-endtag htbody page)) - (when (or (page-can-print page) previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component htbody)))) - + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition htbody))) + (unless (and render-condition (null (funcall render-condition))) + (when (or (page-can-print page) previous-print-status) + (setf (page-can-print page) (htcomponent-can-print htbody)) + (htcomponent-json-print-start-component htbody)) + (when (page-can-print page) + (tag-render-starttag htbody page)) + (dolist (child-tag body-list) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (when (page-can-print page) + (htcomponent-render (htbody-init-scripts-tag page t) page) + (tag-render-endtag htbody page)) + (when (or (page-can-print page) previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component htbody))))) + (defmethod htbody-init-scripts-tag ((page page) &optional on-load) (let ((js (script> :type "text/javascript")) (js-start-directive (if on-load (if (msie-p) @@ -1010,7 +1081,7 @@ "")) (page-body-init-scripts (page-body-init-scripts page))) (setf (htcomponent-page js) page - (htcomponent-body js) (when page-body-init-scripts + (htcomponent-body js) (when page-body-init-scripts (if (listp page-body-init-scripts) (append (list js-start-directive) page-body-init-scripts @@ -1022,18 +1093,18 @@ (defclass wcomponent (htcomponent) ((reserved-parameters :initarg :reserved-parameters :accessor wcomponent-reserved-parameters - :type cons + :type cons :documentation "Parameters that may not be used in the constructor function") (json-error-monitor-p :initarg :json-error-monitor-p :accessor htcomponent-json-error-monitor-p :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.") (informal-parameters :initform () :accessor wcomponent-informal-parameters - :type cons + :type cons :documentation "Informal parameters are parameters optional for the component") (allow-informal-parameters :initarg :allow-informal-parameters :reader wcomponent-allow-informal-parametersp - :allocation :class + :allocation :class :documentation "Determines if the component accepts informal parameters")) (:default-initargs :reserved-parameters nil :allow-informal-parameters t) @@ -1061,17 +1132,17 @@ (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)) + (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) + 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 + (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" + (error (format nil + "Component ~a doesn't accept informal parameters" slot-initarg)) (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) @@ -1085,7 +1156,7 @@ (real-id (or static-id id))) (setf (htcomponent-real-id instance) real-id) (when static-id - (remf parameters :id)) + (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr do (setf (slot-initialization instance initarg) value)) (setf (htcomponent-body instance) content) @@ -1102,8 +1173,8 @@ (let ((template (wcomponent-template wcomponent))) (wcomponent-before-rewind wcomponent page) (if (listp template) - (dolist (tag template) - (htcomponent-rewind tag page)) + (dolist (tag template) + (htcomponent-rewind tag page)) (htcomponent-rewind template page)) (wcomponent-after-rewind wcomponent page))) @@ -1111,51 +1182,55 @@ (defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page))) (defmethod htcomponent-prerender ((wcomponent wcomponent) (page page)) - (wcomponent-before-prerender wcomponent page) - (let ((previous-print-status (page-can-print page)) - (template (wcomponent-template wcomponent))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print wcomponent))) - (when (page-can-print page) - (dolist (script (htcomponent-script-files wcomponent)) - (pushnew script (page-script-files page) :test #'equal)) - (dolist (css (htcomponent-stylesheet-files wcomponent)) - (pushnew css (page-stylesheet-files page) :test #'equal)) - (dolist (js (htcomponent-class-initscripts wcomponent)) - (pushnew js (page-class-initscripts page) :test #'equal)) - (when (htcomponent-instance-initscript wcomponent) - (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) - (if (listp template) - (dolist (tag template) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-prerender tag page))) - (htcomponent-prerender template page)) - (when (null previous-print-status) - (setf (page-can-print page) nil))) - (wcomponent-after-prerender wcomponent page)) + (let ((render-condition (htcomponent-render-condition wcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (wcomponent-before-prerender wcomponent page) + (let ((previous-print-status (page-can-print page)) + (template (wcomponent-template wcomponent))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent))) + (when (page-can-print page) + (dolist (script (htcomponent-script-files wcomponent)) + (pushnew script (page-script-files page) :test #'equal)) + (dolist (css (htcomponent-stylesheet-files wcomponent)) + (pushnew css (page-stylesheet-files page) :test #'equal)) + (dolist (js (htcomponent-class-initscripts wcomponent)) + (pushnew js (page-class-initscripts page) :test #'equal)) + (when (htcomponent-instance-initscript wcomponent) + (pushnew (htcomponent-instance-initscript wcomponent) (page-instance-initscripts page) :test #'equal))) + (if (listp template) + (dolist (tag template) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-prerender tag page))) + (htcomponent-prerender template page)) + (when (null previous-print-status) + (setf (page-can-print page) nil))) + (wcomponent-after-prerender wcomponent page)))) (defmethod wcomponent-before-prerender ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-prerender ((wcomponent wcomponent) (page page))) (defmethod htcomponent-render ((wcomponent wcomponent) (page page)) (let ((template (wcomponent-template wcomponent)) - (previous-print-status (page-can-print page))) - (when (null previous-print-status) - (setf (page-can-print page) (htcomponent-can-print wcomponent)) - (htcomponent-json-print-start-component wcomponent)) - (wcomponent-before-render wcomponent page) - (unless (listp template) - (setf template (list template))) - (dolist (child-tag template) - (when child-tag - (cond - ((stringp child-tag) (htcomponent-render ($> child-tag) page)) - ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) - (t (htcomponent-render child-tag page))))) - (wcomponent-after-render wcomponent page) - (when (null previous-print-status) - (setf (page-can-print page) nil) - (htcomponent-json-print-end-component wcomponent)))) + (previous-print-status (page-can-print page)) + (render-condition (htcomponent-render-condition wcomponent))) + (unless (and render-condition (null (funcall render-condition))) + (when (null previous-print-status) + (setf (page-can-print page) (htcomponent-can-print wcomponent)) + (htcomponent-json-print-start-component wcomponent)) + (wcomponent-before-render wcomponent page) + (unless (listp template) + (setf template (list template))) + (dolist (child-tag template) + (when child-tag + (cond + ((stringp child-tag) (htcomponent-render ($> child-tag) page)) + ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) + (t (htcomponent-render child-tag page))))) + (wcomponent-after-render wcomponent page) + (when (null previous-print-status) + (setf (page-can-print page) nil) + (htcomponent-json-print-end-component wcomponent))))) (defmethod wcomponent-before-render ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-render ((wcomponent wcomponent) (page page))) @@ -1164,11 +1239,11 @@ (defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) -(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) +(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) (let ((dispatcher (message-dispatcher i18n-aware)) (result)) (when dispatcher - (progn + (progn (setf result (message-dispatch dispatcher key locale)) (when (and (null result) (> (length locale) 2)) (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) @@ -1179,7 +1254,7 @@ (setf (gethash key current-locale) value) (setf (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)) current-locale))) -(defmethod message-dispatch ((simple-message-dispatcher simple-message-dispatcher) key locale) +(defmethod message-dispatch ((simple-message-dispatcher simple-message-dispatcher) key locale) (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)))) (when current-locale (gethash key current-locale)))) Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Sat Jun 14 01:16:01 2008 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: src/components.lisp $ +;;; $Header: src/translators.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -35,15 +35,15 @@ (defmethod translator-value-type-to-string ((translator translator) value) (translator-value-encode translator value)) -(defmethod translator-encode ((translator translator) (wcomponent cinput)) +(defmethod translator-encode ((translator translator) (wcomponent base-cinput)) (let* ((page (htcomponent-page wcomponent)) (visit-object (or (cinput-visit-object wcomponent) page)) (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (value (page-req-parameter page (name-attr wcomponent) nil))) + (reader (cinput-reader wcomponent)) + (value (page-req-parameter page (name-attr wcomponent) nil))) (if (component-validation-errors wcomponent) value - (progn + (progn (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) @@ -52,14 +52,14 @@ (defmethod translator-type-to-string ((translator translator) (wcomponent cinput)) (translator-encode translator wcomponent)) -(defmethod translator-value-decode ((translator translator) value &optional client-id label) +(defmethod translator-value-decode ((translator translator) value &optional client-id label) (declare (ignore client-id label)) value) -(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label) +(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label) (translator-value-decode translator value client-id label)) -(defmethod translator-decode ((translator translator) (wcomponent wcomponent)) +(defmethod translator-decode ((translator translator) (wcomponent wcomponent)) (multiple-value-bind (client-id value) (component-id-and-value wcomponent) (translator-value-decode translator value client-id (label wcomponent)))) @@ -67,13 +67,13 @@ (defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent)) (translator-decode translator wcomponent)) -(setf *simple-translator* (make-instance 'translator)) +(setf *simple-translator* (make-instance 'translator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass translator-integer (translator) +(defclass translator-integer (translator) ((thousand-separator :initarg :thousand-separator :reader translator-thousand-separator :documentation "If specified (as character), it is the thousands separator. Despite of @@ -95,9 +95,9 @@ (signum-directive (if (translator-always-show-signum translator) "@" "")) - (control-string (if thousand-separator + (control-string (if thousand-separator (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive)))) + (format nil "~~~ad" signum-directive)))) (if thousand-separator (string-trim " " (format nil control-string thousand-separator value)) (format nil control-string value)))) @@ -108,28 +108,28 @@ (if thousand-separator (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) (parse-integer value)) - (error () (progn + (error () (progn (when label (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") label))) value))))) +(defvar *integer-translator* (make-instance 'translator-integer)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass translator-number (translator-integer) +(defclass translator-number (translator-integer) ((decimals-separator :initarg :decimals-separator :reader translator-decimals-separator :documentation "The decimal separator of the rendered number. Default to #\.") (decimal-digits :initarg :decimal-digits :reader translator-decimal-digits - :documentation "force the rendering of the value to a fixed number of decimal digits") + :documentation "force the rendering of the value to a fixed number of decimal digits") (coerce :initarg :coerce :accessor translator-coerce :documentation "Coerces the decoded input value to the given value type")) (:default-initargs :decimals-separator #\. - ;:integer-digits nil - :decimal-digits nil + :decimal-digits nil :coerce 'ratio) (:documentation "a translator object encodes and decodes integer values passed to a html input component")) @@ -140,20 +140,20 @@ (decimal-digits (translator-decimal-digits translator)) (decimals-separator (translator-decimals-separator translator)) (signum-directive (if (translator-always-show-signum translator) "@" "")) - (integer-control-string (if thousand-separator + (integer-control-string (if thousand-separator (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive)))) + (format nil "~~~ad" signum-directive)))) (multiple-value-bind (int-value dec-value) (floor value) (setf dec-value (coerce dec-value 'float)) - (format nil "~a~a" + (format nil "~a~a" (if thousand-separator (string-trim " " (format nil integer-control-string thousand-separator int-value)) - (format nil integer-control-string int-value)) - (cond + (format nil integer-control-string int-value)) + (cond ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) - (decimal-digits + (decimal-digits (let ((frac-part (subseq (format nil "~f" dec-value) 2))) (if (> (length frac-part) decimal-digits) (setf frac-part (subseq frac-part 0 decimal-digits)) @@ -163,8 +163,8 @@ (defmethod translator-value-decode ((translator translator-number) value &optional client-id label) (let ((thousand-separator (translator-thousand-separator translator)) - (type (translator-coerce translator)) - (new-value)) + (type (translator-coerce translator)) + (new-value)) (if thousand-separator (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value "")) (setf new-value value)) @@ -176,21 +176,23 @@ (if (integerp result) result (coerce result type))) - (error () (progn + (error () (progn (when label (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") label))) value))))) + +(defvar *number-translator* (make-instance 'translator-number)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass translator-date (translator) +(defclass translator-date (translator) ((local-time-format :initarg :local-time-format :reader translator-local-time-format :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are -expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)")) - (:default-initargs :local-time-format '(:month "/" :date "/" :year)) +expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)")) + (:default-initargs :local-time-format '(:year "-" :month "-" :date)) (:documentation "A translator object encodes and decodes local-date object value passed to a html input component. When decoding the input compoenent value string to a local-time instance if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATE-DATE\". @@ -199,18 +201,18 @@ (defmethod translator-value-encode ((translator translator-date) value) - (let* ((local-time-format (translator-local-time-format translator))) + (let* ((local-time-format (translator-local-time-format translator))) (if (and value (not (stringp value))) (local-time-to-string value local-time-format) value))) -(defmethod translator-value-decode ((translator translator-date) value &optional client-id label) +(defmethod translator-value-decode ((translator translator-date) value &optional client-id label) (let ((date-format (translator-local-time-format translator)) (sec 0) (min 0) (hour 0) - (day 0) - (month 0) + (day 1) + (month 1) (year 0) (old-value)) (when (and value (string-not-equal value "")) @@ -219,44 +221,51 @@ do (if (stringp element) (setf value (subseq value (length element))) (ccase element - (:second (multiple-value-bind (curr-value size) + (:second (multiple-value-bind (curr-value size) (parse-integer value :junk-allowed t) (setf value (subseq value size)) (setf sec curr-value))) - (:minute (multiple-value-bind (curr-value size) + (:minute (multiple-value-bind (curr-value size) (parse-integer value :junk-allowed t) (setf value (subseq value size)) (setf min curr-value))) - (:hour (multiple-value-bind (curr-value size) + (:hour (multiple-value-bind (curr-value size) (parse-integer value :junk-allowed t) (setf value (subseq value size)) (setf hour curr-value))) - (:date (multiple-value-bind (curr-value size) + (:date (multiple-value-bind (curr-value size) (parse-integer value :junk-allowed t) (setf value (subseq value size)) (setf day curr-value))) - (:month (multiple-value-bind (curr-value size) + (:month (multiple-value-bind (curr-value size) (parse-integer value :junk-allowed t) (setf value (subseq value size)) (setf month curr-value))) - (:year (multiple-value-bind (curr-value size) + (:year (multiple-value-bind (curr-value size) (parse-integer value :junk-allowed t) (setf value (subseq value size)) (setf year curr-value)))))) (if (and (string-equal value "") (>= sec 0) (>= min 0) - (>= hour 0) + (>= hour 0) (and (> month 0) (<= month 12)) (and (> day 0) (<= day (days-in-month month year)))) (encode-local-time 0 sec min hour day month year) - (progn + (progn (when label (add-exception client-id (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") label old-value))) value))))) +(defvar *date-translator-ymd* (make-instance 'translator-date)) + +(defvar *date-translator-time* (make-instance 'translator-date :local-time-format '("T" :hour ":" :minute ":" :second))) -(defclass translator-boolean (translator) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; Boolean translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-boolean (translator) () (:documentation "a translator object encodes and decodes boolean values passed to a html input component")) @@ -268,4 +277,26 @@ nil t)) -(defvar *boolean-translator* (make-instance 'translator-boolean)) \ No newline at end of file +(defvar *boolean-translator* (make-instance 'translator-boolean)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; File translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-file (translator) + () + (:documentation "a translator object encodes and decodes file values passed to a html input component of type file")) + +(defmethod translator-value-encode ((translator translator-file) value) + (cond + ((null value) "") + ((stringp value) value) + ((pathnamep value) (format nil "~a.~a" + (pathname-name value) + (pathname-type value))) + (t (second value)))) + +(defmethod translator-value-decode ((translator translator-file) value &optional client-id label) + value) + +(setf *file-translator* (make-instance 'translator-file)) \ No newline at end of file Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Sat Jun 14 01:16:01 2008 @@ -59,21 +59,21 @@ (simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!") (defvar *test-lisplet*) -(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" +(setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" :redirect-protected-resources-p t)) (defvar *test-lisplet2*) -(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" +(setf *test-lisplet2* (make-instance 'lisplet :realm "test2" :base-path "/test2")) ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) -(defvar *clawserver* (make-instance 'clawserver - :port 4242 - :sslport 4445 +(defvar *clawserver* (make-instance 'clawserver + :port 4242 + :sslport 4445 :base-path "/claw" :mod-lisp-p nil - :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" + :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) @@ -85,24 +85,24 @@ (declare (ignore request)) (let ((session *session*)) (when (and (string-equal user "kiuma") - (string-equal password "password")) + (string-equal password "password")) (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) - + (defclass test-configuration (configuration) ()) (defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*)) - (let ((lisplet (current-lisplet request))) + (let ((lisplet (current-lisplet request))) (multiple-value-bind (user password) - (if (eq (lisplet-authentication-type lisplet) :basic) + (if (eq (lisplet-authentication-type lisplet) :basic) (authorization) (values (aux-request-value 'user request) (aux-request-value 'password request))) (test-configuration-do-login request user password)))) (clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration)) - + (defun claw-tst-start () @@ -114,22 +114,22 @@ ;;;--------------------template-------------------------------- -(defclass site-template (wcomponent) +(defclass site-template (wcomponent) ((title :initarg :title :reader title)) (:metaclass metacomponent)) (defmethod wcomponent-template ((o site-template)) - (html> + (html> (head> - (title> + (title> (title o)) (style> :type "text/css" "input.error, div.error { background-color: #FF9999; } ")) - (body> + (body> (wcomponent-informal-parameters o) (div> :style "background-color: #DBDFE0;padding: 3px;" @@ -149,7 +149,7 @@ (defclass index-page (page) ()) -(defmethod page-content ((o index-page)) +(defmethod page-content ((o index-page)) (let ((clawserver-base-path (clawserver-base-path (current-server)))) (site-template> :title "Home test page" (p> :id "p" @@ -166,9 +166,9 @@ "show static file")) (li> (a> :href "images/matrix2.jpg" "show file by function")) - (li> (a> :href "../test/realm.html" :target "clwo1" + (li> (a> :href "../test/realm.html" :target "clwo1" "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" + (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> (a> :href "id-tests.html" "id generation test")) (li> (a> :href "form.html" "form components test")) @@ -177,7 +177,7 @@ (lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) -(defclass msie-p (wcomponent) +(defclass msie-p (wcomponent) () (:metaclass metacomponent)) @@ -186,7 +186,7 @@ (p> :static-id id))) (defmethod htcomponent-instance-initscript ((msie-p msie-p)) - (let ((id (htcomponent-client-id msie-p))) + (let ((id (htcomponent-client-id msie-p))) (format nil "document.getElementById('~a').innerHTML = '~a';" id (if (msie-p) @@ -195,14 +195,14 @@ (defclass info-page (page) ()) -(defmethod page-content ((o info-page)) +(defmethod page-content ((o info-page)) (let ((header-props (headers-in))) (site-template> :title "Header info page" (p> :id "p" (table> (tr> (td> :colspan "2" "Header info")) - (loop for key-val in header-props - collect (tr> + (loop for key-val in header-props + collect (tr> (td> (format nil "~a" (car key-val)) (td> (format nil "~a" (cdr key-val)))))))) (msie-p> :id "msie")))) @@ -210,12 +210,12 @@ (lisplet-register-page-location *test-lisplet* 'info-page "info.html") -(defun test-image-file () +(defun test-image-file () (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) (lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg") -(lisplet-register-function-location *test-lisplet* +(lisplet-register-function-location *test-lisplet* (lambda () (let ((path (test-image-file))) (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) @@ -228,20 +228,20 @@ ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ()) -(defmethod page-content ((o realm-page)) - (when (null hunchentoot:*session*) +(defmethod page-content ((o realm-page)) + (when (null hunchentoot:*session*) (claw-start-session)) (unless (session-value 'RND-NUMBER) (setf (session-value 'RND-NUMBER) (random 1000))) - (site-template> :title "Realm test page" + (site-template> :title "Realm test page" (p> - "session" + "session" (ul> - (li> (a> :href "http://www.gentoo.org" :target "gentoo" + (li> (a> :href "http://www.gentoo.org" :target "gentoo" "gentoo")) - (li> (a> :href "../test/realm.html" :target "clwo1" + (li> (a> :href "../test/realm.html" :target "clwo1" "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" + (li> (a> :href "../test2/realm.html" :target "clwo2" "realm on lisplet 'test2'")) (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) (li> "Remote Addr: " (session-remote-addr *session*)) @@ -260,22 +260,22 @@ (defmethod page-content ((o id-tests-page)) (let ((uid (generate-id "uid")) (uid2 (generate-id "uid"))) - (site-template> :title "a page title" + (site-template> :title "a page title" "\"<escaping>test\"" (hr>) - (div> :id "foo" :class "goo" + (div> :id "foo" :class "goo" :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") - (div> :id "foo" + (div> :id "foo" :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'foo'[click me, to see generated id]") - (div> :static-id uid + (div> :static-id uid :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") - (div> :static-id uid2 + (div> :static-id uid2 :onclick "this.innerHTML = this.id" :style "cursor: pointer;" "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")))) @@ -287,7 +287,7 @@ (defgeneric login-page-login (login-page)) -(defclass login-page (page) +(defclass login-page (page) ((username :initform "" :accessor login-page-username) (passowrd :initform "" @@ -296,7 +296,7 @@ (defmethod page-content ((login-page login-page)) (let ((princp (current-principal))) - (site-template> :title "a page title" + (site-template> :title "a page title" (if (null princp) (cform> :id "loginform" :method "post" :action #'login-page-login (table> @@ -304,19 +304,21 @@ (td> "Username") (td> (cinput> :id "username" - :type "text" - :accessor 'login-page-username))) + :type "text" + :accessor 'login-page-username) + "\(kiuma)")) (tr> (td> "Password") (td> (cinput> :id "passowrd" :type "password" - :accessor 'login-page-password))) + :accessor 'login-page-password) + "\(password)")) (tr> (td> :colspan "2" (csubmit> :id "submit" :value "Login"))))) - (p> - (with-message "WELCOME" "WELCOME") " " + (p> + (with-message "WELCOME" "WELCOME") " " (principal-name princp) (a> :href "index.html" "home")))))) @@ -327,12 +329,12 @@ (lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) -(defclass user () +(defclass user () ((name :initarg :name :accessor user-name) (surname :initarg :surname :accessor user-surname) - (gender :initarg :gender + (gender :initarg :gender :accessor user-gender) (age :initarg :age :accessor user-age) @@ -341,12 +343,12 @@ (sure :initarg :sure :accessor user-sure) (capital :initarg :capital - :accessor user-capital)) + :accessor user-capital)) (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree "")) (defgeneric form-page-update-user (form-page)) -(defclass form-page (page user) +(defclass form-page (page user) ((name :initarg :name :accessor form-page-name) (surname :initarg :surname @@ -367,7 +369,7 @@ (capital :initarg :capital :accessor form-page-capital) (birthday :initarg :birthday - :accessor form-page-birthday)) + :accessor form-page-birthday)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil @@ -396,16 +398,16 @@ (user-sure user) sure))) - + (defun validate-agree (component value) (declare (ignore value)) (validate nil - :component component + :component component :message (do-message "SURE-ERROR-MESSAGE" "You must be sure"))) -(defmethod page-content ((o form-page)) +(defmethod page-content ((o form-page)) (let ((user (form-page-user o))) - (site-template> :title "a page title" + (site-template> :title "a page title" (cform> :id "testform" :method "post" :action #'form-page-update-user (table> (tr> @@ -414,7 +416,7 @@ (cinput> :id "name" :type "text" :label "Name" - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-required (page-current-component o) value)) :accessor 'form-page-name)"*")) (tr> :id "messaged" @@ -423,7 +425,7 @@ (cinput> :id "surname" :type "text" :label "Surname" - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-required (page-current-component o) value) (validate-size (page-current-component o) value :min-size 1 :max-size 20)) :accessor 'form-page-surname)"*")) @@ -432,29 +434,29 @@ (td> (ccheckbox> :id "agree" :label (with-message "AGREE" "AGREE") - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-required (page-current-component o) value)) :accessor 'form-page-agree :value t)"*")) (tr> :id "sure" (td> (with-message "SURE" "SURE")) (td> - (cradio> :id "sure" + (cradio> :id "sure" :label (with-message "SURE" "SURE") :accessor 'form-page-sure - :value "yes") + :value "yes") (span> :style "margin-right:1.5em;" (with-message "YES" "yes")) - (cradio> :id "sure" + (cradio> :id "sure" :label (with-message "SURE" "SURE") - :validator #'(lambda (value) + :validator #'(lambda (value) (validate-agree (page-current-component o) value)) :accessor 'form-page-sure - :value "no") + :value "no") (span> :style "margin-right:1.5em;" (with-message "NO" "no")))) (tr> (td> "Gender") (td> - (cselect> :id "gender" + (cselect> :id "gender" :accessor 'form-page-gender (loop for gender in (list "M" "F") collect (option> :value gender @@ -470,7 +472,7 @@ :type "text" :label "Age" :translator (make-instance 'translator-integer :thousand-separator #\') - :validator #'(lambda (value) + :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-required component value) (validate-integer component value :min 1 :max 2000))) @@ -482,7 +484,7 @@ :type "text" :label "Birthday" :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) - :validator #'(lambda (value) + :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) :accessor 'form-page-birthday)"(dd-mm-yyyy)")) @@ -492,10 +494,10 @@ (cinput> :id "capital" :type "text" :label "Capital" - :translator (make-instance 'translator-number + :translator (make-instance 'translator-number :decimal-digits 2 :thousand-separator #\') - :validator #'(lambda (value) + :validator #'(lambda (value) (let ((component (page-current-component o))) (validate-required component value) (validate-number component value :min 1000.01 :max 500099/100))) @@ -503,7 +505,7 @@ (tr> (td> "Colors") (td> - (cselect> :id "colors" + (cselect> :id "colors" :multiple "true" :style "width:80px;height:120px;" :accessor 'form-page-colors @@ -511,15 +513,15 @@ collect (option> :value color (when (find color (form-page-colors o) :test #'string=) '(:selected "selected")) - (cond + (cond ((string= color "R") "red") ((string= color "G") "green") - (t "blue"))))))) + (t "blue"))))))) (tr> (td> :colspan "2" (csubmit> :id "submit" :value "OK"))))) - (p> - (exception-monitor> :class "error") + (p> + (exception-monitor> :id "exceptionMonitor" :class "error") (hr>) (h2> "From result:") (div> (format nil "Name: ~a" (user-name user)))

1 0

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

30 May '08

Author: achiumenti Date: Fri May 30 06:03:00 2008 New Revision: 49 Modified: trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/src/translators.lisp trunk/main/claw-core/src/validators.lisp trunk/main/claw-core/tests/test1.lisp Log: a lot of bug fixes, plus adding of checkbox and radio components Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Fri May 30 06:03:00 2008 @@ -41,9 +41,33 @@ (defgeneric translator-encode (translator wcomponent) (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string).")) +(defgeneric translator-type-to-string (translator wcomponent) + (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-encode")) + (defgeneric translator-decode (translator wcomponent) (:documentation "Decodes the input component value after a form submit (Decodes from string to type).")) +(defgeneric translator-string-to-type (translator wcomponent) + (:documentation "Decodes the input component value after a form submit (Decodes from string to type). It's a wrapper for translator-decode")) + +(defgeneric translator-value-encode (translator value) + (:documentation "Encodes the value, used when rendering the component (Encodes from type to string).")) + +(defgeneric translator-value-type-to-string (translator value) + (:documentation "Encodes the value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-value-encode")) + +(defgeneric translator-value-decode (translator value &optional client-id label) + (:documentation "Decodes value after a form submit (Decodes from string to type).")) + +(defgeneric translator-value-string-to-type (translator value &optional client-id label) + (:documentation "Decodes value after a form submit (Decodes from string to type). It's a wrapper for translator-value-decode")) + +(defgeneric label (cinput) + (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled")) + +(defgeneric name-attr (cinput) + (:documentation "Returns the name of the input component")) + (defclass translator () () (:documentation "a translator object encodes and decodes values passed to a html input component")) @@ -55,10 +79,12 @@ (defun component-validation-errors (component &optional (request *request*)) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) - (getf (validation-errors request) (make-symbol client-id)))) + (getf (validation-errors request) (intern client-id)))) ;-------------------------------------------------------------------------------- + + (defclass cform (wcomponent) ((action :initarg :action :accessor action @@ -94,7 +120,6 @@ (setf class "error") (setf class (format nil "~a error" class)))) (form> :static-id client-id - :name client-id :class class (wcomponent-informal-parameters cform) (input> :name *rewind-parameter* @@ -154,8 +179,7 @@ (accessor :initarg :accessor :reader cinput-accessor :documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters") - (label :initarg :label - :reader label + (label :initarg :label :documentation "The label is the description of the component. It's also be used when component validation fails.") (translator :initarg :translator :reader translator @@ -173,6 +197,15 @@ :label nil :translator *simple-translator* :validator nil :visit-object nil) (:documentation "Class inherited from both CINPUT and CSELECT")) +(defmethod label ((cinput base-cinput)) + (let ((label (slot-value cinput 'label))) + (if (functionp label) + (funcall label) + label))) + +(defmethod name-attr ((cinput base-cinput)) + (htcomponent-client-id cinput)) + (defclass cinput (base-cinput) ((input-type :initarg :type :reader input-type @@ -204,7 +237,7 @@ (setf value (translator-encode translator cinput)) (input> :static-id client-id :type type - :name client-id + :name (name-attr cinput) :class class :value value (wcomponent-informal-parameters cinput)))) @@ -233,7 +266,7 @@ (setf value (cond (from-request-p (page-req-parameter (htcomponent-page cinput) - client-id + (name-attr cinput) result-as-list-p)) ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) (t (funcall (fdefinition reader) visit-object)))) @@ -260,12 +293,15 @@ (describe-html-attributes-from-class-slot-initargs class) (describe-component-behaviour class)))) +(defmethod name-attr ((csubmit csubmit)) + (htcomponent-client-id csubmit)) + (defmethod wcomponent-template ((obj csubmit)) (let ((client-id (htcomponent-client-id obj)) (value (csubmit-value obj))) (input> :static-id client-id :type "submit" - :name client-id + :name (name-attr obj) :value value (wcomponent-informal-parameters obj)))) @@ -300,7 +336,7 @@ (input> :static-id submit-id :style "display:none;" :type "submit" - :name id + :name (name-attr obj) :value "-") (a> :static-id id :href (format nil "javascript:document.getElementById('~a').click();" submit-id) @@ -332,12 +368,135 @@ (setf class "error") (setf class (format nil "~a error" class)))) (select> :static-id client-id - :name client-id + :name (name-attr obj) :class class :multiple (cinput-result-as-list-p obj) (wcomponent-informal-parameters obj) (htcomponent-body obj)))) +;-------------------------------------------------------------------------------------------- +(defclass ccheckbox (cinput) + ((test :initarg :test + :accessor ccheckbox-test) + (value :initarg :value + :accessor ccheckbox-value)) + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal) + (:documentation "Request cycle aware component the renders as an INPUT tag class")) +(let ((class (find-class 'ccheckbox))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~a~%~%~a" + "Function that instantiates a CCHECKBOX component and renders a html <input> tag of type \"checkbox\"." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs (find-class 'cinput)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) +(defmethod wcomponent-template ((cinput ccheckbox)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (current-value (translator-type-to-string translator cinput)) + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + :checked (when (and current-value (equal value current-value)) "checked") + (wcomponent-informal-parameters cinput)))) + +(defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) + (let* ((visit-object (or (cinput-visit-object cinput) page)) + (client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (new-value (page-req-parameter page + client-id + result-as-list-p))) + (when new-value + (setf new-value (translator-string-to-type translator cinput))) + (unless (component-validation-errors cinput) + (when validator + (funcall validator (or new-value ""))) + (unless (component-validation-errors cinput) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object)))))) + +;------------------------------------------------------------------------------------- +(defclass cradio (ccheckbox) + () + (:metaclass metacomponent) + (:default-initargs :type "radio") + (:documentation "Request cycle aware component the renders as an INPUT tag class")) + +(let ((class (find-class 'cradio))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~a~a~%~%~a" + "Function that instantiates a CRADIO component and renders a html <input> tag of type \"radio\"." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs (find-class 'cinput)) + (describe-html-attributes-from-class-slot-initargs (find-class 'ccheckbox)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod name-attr ((ccheckbox ccheckbox)) + (htcomponent-real-id ccheckbox)) + +(defmethod wcomponent-after-rewind ((cinput cradio) (page page)) + (let* ((visit-object (or (cinput-visit-object cinput) page)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (ccheckbox-test (ccheckbox-test cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (value (translator-value-string-to-type translator (ccheckbox-value cinput))) + (new-value (page-req-parameter page + (name-attr cinput) + result-as-list-p)) + (checked)) + (when new-value + (setf new-value (translator-string-to-type translator cinput) + checked (funcall ccheckbox-test value new-value))) + (when (and checked (null (component-validation-errors cinput))) + (when validator + (funcall validator (or new-value ""))) + (when (null (component-validation-errors cinput)) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (funcall (fdefinition writer) new-value visit-object)))))) + +(defmethod wcomponent-template ((cinput cradio)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (current-value (translator-type-to-string translator cinput)) + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + :checked (when (and current-value (equal value current-value)) "checked") + (wcomponent-informal-parameters cinput)))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Fri May 30 06:03:00 2008 @@ -49,7 +49,7 @@ - :WELCOME-PAGE-P When true, the function will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location - :LOGIN-PAGE-P Marks the function as a login page")) -(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p) +(defgeneric lisplet-register-page-location (lisplet page-class location &key welcome-page-p login-page-p encoding) (:documentation "Registers a page into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page @@ -57,15 +57,17 @@ - LOCATION The url location where the page will be registered (relative to the lisplet base path) keys: - :WELCOME-PAGE-P When true, the page will be a welcome page, making the lisplet to redirect direct access to its base path to the expressed location -- :LOGIN-PAGE-P Marks the page as a login page")) +- :LOGIN-PAGE-P Marks the page as a login page +- :ENCODING The charset encoding used to render the resource")) -(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type) +(defgeneric lisplet-register-resource-location (lisplet resource-path location &optional content-type encoding) (:documentation "Registers a resource (file or directory) into a lisplet for dispatching. parameters: - LISPLET the lisplet that will dispatch the page - RESOURCE-PATH pathname of a file or directory that is to be registered for dispatching - LOCATION The url location where the resource will be registered (relative to the lisplet base path) -- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type")) +- CONTENT-TYPE Meaningful only when the resource-path points to a file, indicates the resource content type +- ENCODING The charset encoding used to render the resource")) (defgeneric lisplet-dispatch-method (lisplet) (:documentation "Performs authorizations checking then makes a call to LISPLET-DISPATCH-REQUEST @@ -106,7 +108,7 @@ (if handler (funcall handler) (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) + :title (format nil "Server error: ~a" error-code) :error-code error-code))) (with-output-to-string (*standard-output*) (page-render error-page))))))) @@ -120,6 +122,9 @@ (login-page :initarg :login-page :accessor lisplet-login-page :documentation "url location for the welcome page") + (encoding :initarg :encoding + :accessor lisplet-encoding + :documentation "The default charset external format for resources provided by this lisplet.") (realm :initarg :realm :reader lisplet-realm :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") @@ -137,6 +142,7 @@ :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) (:default-initargs :welcome-page nil :login-page nil + :encoding :utf-8 :realm "claw" :redirect-protected-resources-p nil) (:documentation "A lisplet is a container for resources provided trhough the clawserver. @@ -170,7 +176,7 @@ :basic)) (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) - (let ((pages (lisplet-pages lisplet))) + (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p @@ -178,16 +184,18 @@ (when login-page-p (setf (lisplet-login-page lisplet) location)))) -(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p) - (lisplet-register-function-location lisplet - #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location)))) - location - :welcome-page-p welcome-page-p - :login-page-p login-page-p)) - -(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) - (let ((pages (lisplet-pages lisplet))) +(defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p encoding) + (let ((charset-encoding (or encoding (lisplet-encoding lisplet)))) + (lisplet-register-function-location lisplet + #'(lambda () (with-output-to-string (*standard-output*) + (page-render (make-instance page-class :lisplet lisplet :url location :encoding charset-encoding)))) + location + :welcome-page-p welcome-page-p + :login-page-p login-page-p))) + +(defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type (encoding :utf-8)) + (let ((pages (lisplet-pages lisplet)) + (external-format (flexi-streams:make-external-format (or encoding (lisplet-encoding lisplet)) :eol-style :lf))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location @@ -199,11 +207,7 @@ (length (lisplet-base-path lisplet)) (length location) 1))) resource-path))) - (log-message :info "--------------------------------------------- ~% -script-name: \"~a\"~% -resource-path: \"~a\"~% -resource-full-path :\"~a\"~% ---------------------------------------------" (script-name) resource-path resource-full-path) + (setf (reply-external-format) external-format) (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -214,9 +218,7 @@ (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) - do (progn - (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url)) - (when (starts-with-subseq rel-script-name url) (return (funcall action))))))) + do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) @@ -266,8 +268,6 @@ for match = (format nil "~a/~a" base-path (car protected-resource)) for allowed-roles = (cdr protected-resource) do (when (or (starts-with-subseq match uri) (string= login-page-url uri)) - ;(when (lisplet-redirect-protected-resources-p lisplet) - ;(redirect-to-https server request)) (cond ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) (setf (return-code) +http-forbidden+) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Fri May 30 06:03:00 2008 @@ -289,7 +289,7 @@ (format nil "~{:~a ~}" (eval reserved-parameters)) "NONE")))) -(defun register-library-resource (location resource-path &optional content-type) +(defun register-library-resource (location resource-path &optional content-type (encoding :utf-8)) "Adds a RESOURCE \(a file or directory) as a library exposed resource to the given relative LOCATION." (setf *claw-libraries-resources* (sort-by-location (pushnew-location @@ -300,9 +300,13 @@ (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) (length location)))) - resource-path))) + resource-path)) + (charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) + (setf (reply-external-format) charset-encoding) (handle-static-file resource-full-path content-type))) - #'(lambda () (handle-static-file resource-path content-type)))) + #'(lambda () (let ((charset-encoding (flexi-streams:make-external-format encoding :eol-style :lf))) + (setf (reply-external-format) charset-encoding) + (handle-static-file resource-path content-type))))) *claw-libraries-resources*)))) (defun uri-to-pathname (uri &optional (relative t)) Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Fri May 30 06:03:00 2008 @@ -53,6 +53,7 @@ :empty-string-p :build-tagf :page + :page-encoding :page-url :page-lisplet :page-current-form @@ -68,6 +69,7 @@ :htcomponent-body :htcomponent-empty :htcomponent-client-id + :htcomponent-real-id :htcomponent-script-files :htcomponent-stylesheet-files :htcomponent-class-initscripts @@ -188,14 +190,18 @@ :wcomponent-before-prerender :wcomponent-after-prerender :wcomponent-before-render - :wcomponent-after-render + :wcomponent-after-render :cform :cform> :action :action-link - :action-link> + :action-link> :cinput :cinput> + :ccheckbox + :ccheckbox> + :cradio + :cradio> :cselect :cselect> :csubmit @@ -203,7 +209,12 @@ :csubmit-value :submit-link :submit-link> + :input-type + :ccheckbox-value + :css-class + :name-attr :lisplet + :lisplet-encoding :lisplet-pages :lisplet-register-page-location :lisplet-register-function-location @@ -269,10 +280,18 @@ :translator :translator-integer :translator-number + :translator-boolean :translator-date :translator-encode :translator-decode + :translator-string-to-type + :translator-type-to-string + :translator-value-decode + :translator-value-encode + :translator-value-string-to-type + :translator-value-type-to-string :*simple-translator* + :*boolean-translator* :*locales* :validate :validation-errors Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Fri May 30 06:03:00 2008 @@ -104,6 +104,7 @@ (error-code :initarg :error-code :reader page-error-code :documentation "The error code to display")) + (:default-initargs :encoding :utf-8) (:documentation "This is the page class used to render the http error messages.")) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Fri May 30 06:03:00 2008 @@ -226,9 +226,6 @@ (defvar *xhtml-1.0-frameset* "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Frameset//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd\">" "Page doctype as XHTML 4.01 FRAMESET") -(defvar *default-encoding* "UTF-8" - "Page default encoding (if no changes 'UTF-8')") - (defvar *rewind-parameter* "rewindobject" "The request parameter for the object asking for a rewind action") @@ -292,19 +289,20 @@ (id-table-map (request-id-table-map)) (id (getf (first fbody) :id)) (static-id (getf (first fbody) :static-id)) + (real-id (or static-id id)) (instance)) (when static-id (remf (first fbody) :id) (setf id nil)) (setf instance (make-instance parent :empty emptyp + :real-id real-id :name (string-downcase tag-name) :attributes (first fbody) :body (second fbody))) (if (null static-id) (when (and id-table-map id) - (setf (htcomponent-client-id instance) - (generate-id id))) + (setf (htcomponent-client-id instance) (generate-id id))) (setf (htcomponent-client-id instance) static-id)) instance)) @@ -378,9 +376,12 @@ (components-stack :initform nil :accessor page-components-stack :documentation "A stack of components enetered into rendering process.") - (content-type :initarg :content-type - :accessor page-content-type - :documentation "Define the content type of the page when rendered") + (mime-type :initarg :mime-type + :accessor page-mime-type + :documentation "Define the mime type of the page when rendered") + (encoding :initarg :encoding + :accessor page-encoding + :documentation "The charset external format. When not provided the lisplet one is used") (url :initarg :url :accessor page-url :documentation "The URL provided with this page instance")) (:default-initargs :writer t @@ -394,7 +395,7 @@ :xmloutput nil :doc-type *html-4.01-strict* :request-parameters nil - :content-type hunchentoot:*default-content-type* + :mime-type "text/html" :url nil) (:documentation "A page object holds claw components to be rendered") ) @@ -408,6 +409,8 @@ :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id :accessor htcomponent-client-id :documentation "The tag computed id if :ID war provided for the building function") + (real-id :initarg :real-id + :accessor htcomponent-real-id :documentation "The tag real id got from :ID or :STATIC-ID") (attributes :initarg :attributes :accessor htcomponent-attributes :documentation "The tag attributes") (empty :initarg :empty @@ -424,6 +427,7 @@ :body nil :json-render-on-validation-errors-p nil :client-id nil + :real-id nil :attributes nil :empty nil :script-files nil @@ -578,17 +582,15 @@ (setf (page-tabulator page) 0))) (defmethod page-render-headings ((page page)) - (let* ((writer (page-writer page)) - (jsonp (page-json-id-list page)) - (encoding (handler-case (format nil "~a" (stream-external-format writer)) - (error () (format nil "~a" *default-encoding*)))) + (let* ((jsonp (page-json-id-list page)) + (encoding (page-encoding page)) (xml-p (page-xmloutput page)) - (content-type (page-doc-type page))) + (doc-type (page-doc-type page))) (when (null jsonp) (when xml-p - (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) - (when content-type - (page-format-raw page "~a~%" content-type))))) + (page-format-raw page "<?xml version=\"1.0\" encoding=\"~a\"?>~%" encoding)) + (when doc-type + (page-format-raw page "~a~%" doc-type))))) (defun json-validation-errors () "Composes the error part for the json reply" @@ -609,7 +611,8 @@ (defmethod page-render ((page page)) (let ((body (page-content page)) (jsonp (page-json-id-list page))) - (setf (hunchentoot:content-type) (page-content-type page)) + (setf (reply-external-format) + (flexi-streams:make-external-format (page-encoding page) :eol-style :lf)) (if (null body) (format nil "null body for page ~a~%" (type-of page)) (progn @@ -874,7 +877,11 @@ (let ((body-list (htcomponent-body hthead)) (injections (page-init-injections page))) (tag-render-starttag hthead page) - (htcomponent-render (meta> :http-equiv "Content-Type" :content (page-content-type page)) page) + (htcomponent-render (meta> :http-equiv "Content-Type" + :content (format nil "~a;charset=~a" + (page-mime-type page) + (page-encoding page))) + page) (dolist (child-tag body-list) (when child-tag (cond @@ -1072,8 +1079,11 @@ (defun make-component (name parameters content) "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content." - (let ((instance (make-instance name)) - (static-id (getf parameters :static-id))) + (let* ((instance (make-instance name)) + (id (getf parameters :id)) + (static-id (getf parameters :static-id)) + (real-id (or static-id id))) + (setf (htcomponent-real-id instance) real-id) (when static-id (remf parameters :id)) (loop for (initarg value) on parameters by #'cddr Modified: trunk/main/claw-core/src/translators.lisp ============================================================================== --- trunk/main/claw-core/src/translators.lisp (original) +++ trunk/main/claw-core/src/translators.lisp Fri May 30 06:03:00 2008 @@ -29,28 +29,45 @@ (in-package :claw) +(defmethod translator-value-encode ((translator translator) value) + (format nil "~a" value)) + +(defmethod translator-value-type-to-string ((translator translator) value) + (translator-value-encode translator value)) + (defmethod translator-encode ((translator translator) (wcomponent cinput)) - (let ((page (htcomponent-page wcomponent)) - (visit-object (cinput-visit-object wcomponent)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent))) - (format nil "~a" (if (component-validation-errors wcomponent) - (page-req-parameter page (htcomponent-client-id wcomponent) nil) - (progn - (when (null visit-object) - (setf visit-object (htcomponent-page wcomponent))) - (if (and (null reader) accessor) - (funcall (fdefinition accessor) visit-object) - (funcall (fdefinition reader) visit-object))))))) + (let* ((page (htcomponent-page wcomponent)) + (visit-object (or (cinput-visit-object wcomponent) page)) + (accessor (cinput-accessor wcomponent)) + (reader (cinput-reader wcomponent)) + (value (page-req-parameter page (name-attr wcomponent) nil))) + (if (component-validation-errors wcomponent) + value + (progn + (setf value (cond + ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) + (t (funcall (fdefinition reader) visit-object)))) + (translator-value-encode translator value))))) + +(defmethod translator-type-to-string ((translator translator) (wcomponent cinput)) + (translator-encode translator wcomponent)) + +(defmethod translator-value-decode ((translator translator) value &optional client-id label) + (declare (ignore client-id label)) + value) + +(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label) + (translator-value-decode translator value client-id label)) (defmethod translator-decode ((translator translator) (wcomponent wcomponent)) - (multiple-value-bind (client-id new-value) + (multiple-value-bind (client-id value) (component-id-and-value wcomponent) - (declare (ignore client-id)) - new-value)) + (translator-value-decode translator value client-id (label wcomponent)))) -(setf *simple-translator* (make-instance 'translator)) +(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent)) + (translator-decode translator wcomponent)) +(setf *simple-translator* (make-instance 'translator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -58,56 +75,43 @@ (defclass translator-integer (translator) ((thousand-separator :initarg :thousand-separator - :reader translator-thousand-separator - :documentation "If specified (as character), it is the thousands separator. Despite of + :reader translator-thousand-separator + :documentation "If specified (as character), it is the thousands separator. Despite of its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator") (always-show-signum :initarg :always-show-signum - :reader translator-always-show-signum - :documentation "When true the signum is used also for displaying positive numbers.") + :reader translator-always-show-signum + :documentation "When true the signum is used also for displaying positive numbers.") (grouping-size :initarg :grouping-size - :reader translator-grouping-size - :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) + :reader translator-grouping-size + :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) (:default-initargs :thousand-separator nil :grouping-size 3 :always-show-signum nil) (:documentation "A translator object encodes and decodes integer values passed to a html input component")) -(defmethod translator-encode ((translator translator-integer) (wcomponent cinput)) - (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (grouping-size (translator-grouping-size translator)) - (thousand-separator (translator-thousand-separator translator)) - (signum-directive (if (translator-always-show-signum translator) - "@" - "")) - (control-string (if thousand-separator - (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (progn - (setf value (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (if thousand-separator - (string-trim " " (format nil control-string thousand-separator value)) - (format nil control-string value)))))) +(defmethod translator-value-encode ((translator translator-integer) value) + (let* ((grouping-size (translator-grouping-size translator)) + (thousand-separator (translator-thousand-separator translator)) + (signum-directive (if (translator-always-show-signum translator) + "@" + "")) + (control-string (if thousand-separator + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive)))) + (if thousand-separator + (string-trim " " (format nil control-string thousand-separator value)) + (format nil control-string value)))) -(defmethod translator-decode ((translator translator-integer) (wcomponent wcomponent)) +(defmethod translator-value-decode ((translator translator-integer) value &optional client-id label) (let ((thousand-separator (translator-thousand-separator translator))) - (multiple-value-bind (client-id value) - (component-id-and-value wcomponent) - (handler-case - (if thousand-separator - (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) - (parse-integer value)) - (error () (progn - (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label wcomponent))) - value)))))) + (handler-case + (if thousand-separator + (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) + (parse-integer value)) + (error () (progn + (when label + (add-exception client-id (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") label))) + value))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;; @@ -115,79 +119,67 @@ (defclass translator-number (translator-integer) ((decimals-separator :initarg :decimals-separator - :reader translator-decimals-separator - :documentation "The decimal separator of the rendered number. Default to #\.") + :reader translator-decimals-separator + :documentation "The decimal separator of the rendered number. Default to #\.") (decimal-digits :initarg :decimal-digits - :reader translator-decimal-digits - :documentation "force the rendering of the value to a fixed number of decimal digits") + :reader translator-decimal-digits + :documentation "force the rendering of the value to a fixed number of decimal digits") (coerce :initarg :coerce - :accessor translator-coerce - :documentation "Coerces the decoded input value to the given value type")) + :accessor translator-coerce + :documentation "Coerces the decoded input value to the given value type")) (:default-initargs :decimals-separator #\. - ;:integer-digits nil - :decimal-digits nil - :coerce 'ratio) + ;:integer-digits nil + :decimal-digits nil + :coerce 'ratio) (:documentation "a translator object encodes and decodes integer values passed to a html input component")) -(defmethod translator-encode ((translator translator-number) (wcomponent cinput)) - (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (thousand-separator (translator-thousand-separator translator)) - (grouping-size (translator-grouping-size translator)) - (decimal-digits (translator-decimal-digits translator)) - (decimals-separator (translator-decimals-separator translator)) - (signum-directive (if (translator-always-show-signum translator) "@" "")) - (integer-control-string (if thousand-separator - (format nil "~~~d,',v:~aD" grouping-size signum-directive) - (format nil "~~~ad" signum-directive))) - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (multiple-value-bind (int-value dec-value) - (floor (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (setf dec-value (coerce dec-value 'float)) - (format nil "~a~a" - (if thousand-separator - (string-trim " " (format nil integer-control-string thousand-separator int-value)) - (format nil integer-control-string int-value)) - (cond - ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) - (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) - (decimal-digits - (let ((frac-part (subseq (format nil "~f" dec-value) 2))) - (if (> (length frac-part) decimal-digits) - (setf frac-part (subseq frac-part 0 decimal-digits)) - (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) - (format nil "~a~a" decimals-separator frac-part))) - (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))) - +(defmethod translator-value-encode ((translator translator-number) value) + (let* ((thousand-separator (translator-thousand-separator translator)) + (grouping-size (translator-grouping-size translator)) + (decimal-digits (translator-decimal-digits translator)) + (decimals-separator (translator-decimals-separator translator)) + (signum-directive (if (translator-always-show-signum translator) "@" "")) + (integer-control-string (if thousand-separator + (format nil "~~~d,',v:~aD" grouping-size signum-directive) + (format nil "~~~ad" signum-directive)))) + (multiple-value-bind (int-value dec-value) + (floor value) + (setf dec-value (coerce dec-value 'float)) + (format nil "~a~a" + (if thousand-separator + (string-trim " " (format nil integer-control-string thousand-separator int-value)) + (format nil integer-control-string int-value)) + (cond + ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits) + (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0))) + (decimal-digits + (let ((frac-part (subseq (format nil "~f" dec-value) 2))) + (if (> (length frac-part) decimal-digits) + (setf frac-part (subseq frac-part 0 decimal-digits)) + (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0)))) + (format nil "~a~a" decimals-separator frac-part))) + (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2)))))))) -(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent)) +(defmethod translator-value-decode ((translator translator-number) value &optional client-id label) (let ((thousand-separator (translator-thousand-separator translator)) - (type (translator-coerce translator)) - (new-value)) - (multiple-value-bind (client-id value) - (component-id-and-value wcomponent) - (if thousand-separator - (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value "")) - (setf new-value value)) - (handler-case - (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value)) - (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))) - (dec-value (expt 10 (length (second decomposed-string)))) - (result (/ int-value dec-value))) - (if (integerp result) - result - (coerce result type))) - (error () (progn - (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label wcomponent))) - value)))))) - + (type (translator-coerce translator)) + (new-value)) + (if thousand-separator + (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value "")) + (setf new-value value)) + (handler-case + (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value)) + (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))) + (dec-value (expt 10 (length (second decomposed-string)))) + (result (/ int-value dec-value))) + (if (integerp result) + result + (coerce result type))) + (error () (progn + (when label + (add-exception client-id (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") label))) + value))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -195,8 +187,8 @@ (defclass translator-date (translator) ((local-time-format :initarg :local-time-format - :reader translator-local-time-format - :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are + :reader translator-local-time-format + :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)")) (:default-initargs :local-time-format '(:month "/" :date "/" :year)) (:documentation "A translator object encodes and decodes local-date object value passed to a html input component. @@ -206,76 +198,74 @@ -(defmethod translator-encode ((translator translator-date) (wcomponent cinput)) - (let* ((page (htcomponent-page wcomponent)) - (visit-object (or (cinput-visit-object wcomponent) page)) - (accessor (cinput-accessor wcomponent)) - (reader (cinput-reader wcomponent)) - (local-time-format (translator-local-time-format translator)) - (value (page-req-parameter page (htcomponent-client-id wcomponent) nil))) - (if (component-validation-errors wcomponent) - value - (progn - (setf value (cond - ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) - (if (and value (not (stringp value))) - (local-time-to-string value local-time-format) - value))))) +(defmethod translator-value-encode ((translator translator-date) value) + (let* ((local-time-format (translator-local-time-format translator))) + (if (and value (not (stringp value))) + (local-time-to-string value local-time-format) + value))) -(defmethod translator-decode ((translator translator-date) (wcomponent wcomponent)) +(defmethod translator-value-decode ((translator translator-date) value &optional client-id label) (let ((date-format (translator-local-time-format translator)) - (sec 0) - (min 0) - (hour 0) - (day 0) - (month 0) - (year 0) - (old-value)) - (multiple-value-bind (client-id new-value) - (component-id-and-value wcomponent) - (declare (ignore client-id)) - (when (and new-value (string-not-equal new-value "")) - (setf old-value new-value) - (loop for element in date-format - do (if (stringp element) - (setf new-value (subseq new-value (length element))) - (ccase element - (:second (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf sec value))) - (:minute (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf min value))) - (:hour (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf hour value))) - (:date (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf day value))) - (:month (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf month value))) - (:year (multiple-value-bind (value size) - (parse-integer new-value :junk-allowed t) - (setf new-value (subseq new-value size)) - (setf year value)))))) - (validate (and (string-equal new-value "") - (>= sec 0) - (>= min 0) - (>= hour 0) - (and (> month 0) (<= month 12)) - (and (> day 0) (<= day (days-in-month month year)))) - :component wcomponent - :message (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") - (label wcomponent) - old-value)) - (if (component-validation-errors wcomponent) - old-value - (encode-local-time 0 sec min hour day month year)))))) + (sec 0) + (min 0) + (hour 0) + (day 0) + (month 0) + (year 0) + (old-value)) + (when (and value (string-not-equal value "")) + (setf old-value value) + (loop for element in date-format + do (if (stringp element) + (setf value (subseq value (length element))) + (ccase element + (:second (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf sec curr-value))) + (:minute (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf min curr-value))) + (:hour (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf hour curr-value))) + (:date (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf day curr-value))) + (:month (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf month curr-value))) + (:year (multiple-value-bind (curr-value size) + (parse-integer value :junk-allowed t) + (setf value (subseq value size)) + (setf year curr-value)))))) + (if (and (string-equal value "") + (>= sec 0) + (>= min 0) + (>= hour 0) + (and (> month 0) (<= month 12)) + (and (> day 0) (<= day (days-in-month month year)))) + (encode-local-time 0 sec min hour day month year) + (progn + (when label + (add-exception client-id (format nil (do-message "VALIDATE-DATE" "Field ~a is not a valid date or wrong format: ~a") label old-value))) + value))))) + + +(defclass translator-boolean (translator) + () + (:documentation "a translator object encodes and decodes boolean values passed to a html input component")) + +(defmethod translator-value-encode ((translator translator-boolean) value) + (format nil "~a" value)) + +(defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label) + (if (string-equal value "NIL") + nil + t)) +(defvar *boolean-translator* (make-instance 'translator-boolean)) \ No newline at end of file Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Fri May 30 06:03:00 2008 @@ -53,14 +53,14 @@ (defun add-exception (id reason) "Adds an exception for the given input component identified by its ID with the message expressed by REASON" (let* ((validation-errors (validation-errors)) - (symbol-id (make-symbol id)) + (symbol-id (intern id)) (errors (getf validation-errors symbol-id))) (setf (getf validation-errors symbol-id) (nconc errors (list reason)) (validation-errors *request*) validation-errors))) (defun component-exceptions (id) "Returns a list of exception connectd to the given component" - (let ((symbol-id (make-symbol id))) + (let ((symbol-id (intern id))) (getf (validation-errors) symbol-id))) (defun validate (test &key component message) @@ -70,15 +70,15 @@ (add-validation-compliance client-id) (add-exception client-id message)))) -(defun validate-required (component value) +(defun validate-required (component value &key message) "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) (validate (and value (string-not-equal value "")) :component component - :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component))))) + :message (or message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component)))))) -(defun validate-size (component value &key min-size max-size) +(defun validate-size (component value &key min-size max-size message-low message-hi) "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. @@ -92,17 +92,17 @@ (when min-size (validate (>= value-len min-size) :component component - :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) - (label component) - min-size))) + :message (or message-low (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) + (label component) + min-size)))) (when max-size (validate (<= value-len max-size) :component component - :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) + :message (or message-hi (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) (label component) - max-size))))))) + max-size)))))))) -(defun validate-range (component value &key min max) +(defun validate-range (component value &key min max message-low message-hi) "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. @@ -112,21 +112,21 @@ (and (when min (validate (>= value min) :component component - :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") - (label component) - (if (typep min 'ratio) - (coerce min 'float) - min)))) + :message (or message-low (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") + (label component) + (if (typep min 'ratio) + (coerce min 'float) + min))))) (when max (validate (<= value max) :component component - :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") - (label component) - (if (typep max 'ratio) - (coerce max 'float) - max))))))) + :message (or message-hi (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") + (label component) + (if (typep max 'ratio) + (coerce max 'float) + max)))))))) -(defun validate-number (component value &key min max) +(defun validate-number (component value &key min max message-nan message-low message-hi) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\". The argument for the message will be the :label attribute of the COMPONENT." @@ -134,10 +134,10 @@ (let ((test (numberp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) - (validate-range component value :min min :max max))))) + :message (or message-nan (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component)))) + (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) -(defun validate-integer (component value &key min max) +(defun validate-integer (component value &key min max message-nan message-low message-hi) "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\". The argument for the message will be the :label attribute of the COMPONENT." @@ -145,11 +145,11 @@ (let ((test (integerp value))) (and (validate test :component component - :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) - (validate-range component value :min min :max max))))) + :message (or message-nan (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component)))) + (validate-range component value :min min :max max :message-low message-low :message-hi message-hi))))) -(defun validate-date-range (component value &key min max (use-date-p t) use-time-p) +(defun validate-date-range (component value &key min max (use-date-p t) use-time-p message-low message-hi) "Checks if the input field VALUE is a date between min and max. If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time. If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time. @@ -183,15 +183,15 @@ (and (when min (validate (local-time> new-value min) :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") - (label component) - (local-time-to-string min local-time-format)))) + :message (or message-low (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") + (label component) + (local-time-to-string min local-time-format))))) (when max (validate (local-time< new-value max) :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") - (label component) - (local-time-to-string max local-time-format)))))))) + :message (or message-hi (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") + (label component) + (local-time-to-string max local-time-format))))))))) @@ -213,16 +213,16 @@ (defmethod wcomponent-template ((exception-monitor exception-monitor)) (let ((client-id (htcomponent-client-id exception-monitor)) (validation-errors (validation-errors)) - (body (htcomponent-body exception-monitor))) + (body (htcomponent-body exception-monitor))) (div> :static-id client-id (wcomponent-informal-parameters exception-monitor) (when validation-errors (if body body - (ul> - (loop for component-exceptions in (rest validation-errors) by #'cddr - do (loop for message in component-exceptions - collect (li> message))))))))) + (ul> :id "errors" + (loop for (client-id component-exceptions) on validation-errors by #'cddr + collect (loop for message in component-exceptions + collect (li> message))))))))) ;;------------------------------------------------------------------------------------------- Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Fri May 30 06:03:00 2008 @@ -46,10 +46,15 @@ (simple-message-dispatcher-add-message *lisplet-messages* "en" "NAME" "Name") (simple-message-dispatcher-add-message *lisplet-messages* "en" "SURNAME" "Surname") (simple-message-dispatcher-add-message *lisplet-messages* "en" "WELCOME" "Welcome") +(simple-message-dispatcher-add-message *lisplet-messages* "en" "AGREE" "Agree") +(simple-message-dispatcher-add-message *lisplet-messages* "en" "SURE" "Are you sure?") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "YES" "sì") (simple-message-dispatcher-add-message *lisplet-messages* "it" "NAME" "Nome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "SURNAME" "Cognome") (simple-message-dispatcher-add-message *lisplet-messages* "it" "WELCOME" "Benvenuto") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE" "Sei sicuro?") +(simple-message-dispatcher-add-message *lisplet-messages* "it" "SURE-ERROR-MESSAGE" "Devi essere sicuro") (simple-message-dispatcher-add-message *lisplet-messages* "it" "VALIDATE-REQUIRED" "Il campo ~a non può essere vuoto!") @@ -120,7 +125,7 @@ (title> (title o)) (style> :type "text/css" - "input.error { + "input.error, div.error { background-color: #FF9999; } ")) @@ -331,9 +336,13 @@ :accessor user-gender) (age :initarg :age :accessor user-age) + (agree :initarg :agree + :accessor user-agree) + (sure :initarg :sure + :accessor user-sure) (capital :initarg :capital :accessor user-capital)) - (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0)) + (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0 :sure "" :agree "")) (defgeneric form-page-update-user (form-page)) @@ -351,11 +360,14 @@ :accessor form-page-user) (age :initarg :age :accessor form-page-age) + (agree :initarg :agree + :accessor form-page-agree) + (sure :initarg :sure + :accessor form-page-sure) (capital :initarg :capital :accessor form-page-capital) (birthday :initarg :birthday - :accessor form-page-birthday)) - + :accessor form-page-birthday)) (:default-initargs :name "kiuma" :surname "surnk" :colors nil @@ -364,6 +376,8 @@ :capital 500055/100 :birthday (now) :message-dispatcher *lisplet-messages* + :agree t + :sure "yes" :user (make-instance 'user))) (defmethod form-page-update-user ((form-page form-page)) @@ -371,113 +385,149 @@ (name (form-page-name form-page)) (surname (form-page-surname form-page)) (gender (form-page-gender form-page)) - (age (form-page-age form-page))) + (age (form-page-age form-page)) + (agree (form-page-agree form-page)) + (sure (form-page-sure form-page))) (setf (user-name user) name (user-surname user) surname (user-gender user) gender - (user-age user) age))) + (user-age user) age + (user-agree user) agree + (user-sure user) sure))) + - ;(defmethod message-dispatch ((object form-page) key locale) +(defun validate-agree (component value) + (declare (ignore value)) + (validate nil + :component component + :message (do-message "SURE-ERROR-MESSAGE" "You must be sure"))) -(defmethod page-content ((o form-page)) - (site-template> :title "a page title" - (cform> :id "testform" :method "post" :action #'form-page-update-user - (table> - (tr> - (td> "Name") - (td> - (cinput> :id "name" - :type "text" - :label "Name" - :validator #'(lambda (value) - (validate-required (page-current-component o) value)) - :accessor 'form-page-name)"*")) - (tr> :id "messaged" - (td> (with-message "SURNAME" "SURNAME")) - (td> - (cinput> :id "surname" - :type "text" - :label "Surname" - :validator #'(lambda (value) - (validate-required (page-current-component o) value) - (validate-size (page-current-component o) value :min-size 1 :max-size 20)) - :accessor 'form-page-surname)"*")) - (tr> - (td> "Gender") - (td> - (cselect> :id "gender" - :accessor 'form-page-gender - (loop for gender in (list "M" "F") - collect (option> :value gender - (when (string= gender (form-page-gender o)) - '(:selected "selected")) - (if (string= gender "M") - "Male" - "Female")))))) - (tr> - (td> "Age") - (td> - (cinput> :id "age" - :type "text" - :label "Age" - :translator (make-instance 'translator-integer :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-integer component value :min 1 :max 2000))) - :accessor 'form-page-age)"*")) - (tr> - (td> "Birthday") - (td> - (cinput> :id "bday" - :type "text" - :label "Birthday" - :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) - :accessor 'form-page-birthday)"(dd-mm-yyyy)")) - (tr> - (td> "Capital") - (td> - (cinput> :id "capital" - :type "text" - :label "Capital" - :translator (make-instance 'translator-number - :decimal-digits 2 - :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-number component value :min 1000.01 :max 500099/100))) - :accessor 'form-page-capital)"*")) - (tr> - (td> "Colors") - (td> - (cselect> :id "colors" - :multiple "true" - :style "width:80px;height:120px;" - :accessor 'form-page-colors - (loop for color in (list "R" "G" "B") - collect (option> :value color - (when (find color (form-page-colors o) :test #'string=) - '(:selected "selected")) - (cond - ((string= color "R") "red") - ((string= color "G") "green") - (t "blue"))))))) - (tr> - (td> :colspan "2" - (csubmit> :id "submit" :value "OK"))))) - (p> - (exception-monitor>) - (hr>) - (h2> "From result:") - (div> (format nil "Name: ~a" (user-name (form-page-user o)))) - (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) - (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) - (div> (format nil "Age: ~a" (user-age (form-page-user o))))))) +(defmethod page-content ((o form-page)) + (let ((user (form-page-user o))) + (site-template> :title "a page title" + (cform> :id "testform" :method "post" :action #'form-page-update-user + (table> + (tr> + (td> "Name") + (td> + (cinput> :id "name" + :type "text" + :label "Name" + :validator #'(lambda (value) + (validate-required (page-current-component o) value)) + :accessor 'form-page-name)"*")) + (tr> :id "messaged" + (td> (with-message "SURNAME" "SURNAME")) + (td> + (cinput> :id "surname" + :type "text" + :label "Surname" + :validator #'(lambda (value) + (validate-required (page-current-component o) value) + (validate-size (page-current-component o) value :min-size 1 :max-size 20)) + :accessor 'form-page-surname)"*")) + (tr> :id "agree" + (td> (with-message "AGREE" "AGREE")) + (td> + (ccheckbox> :id "agree" + :label (with-message "AGREE" "AGREE") + :validator #'(lambda (value) + (validate-required (page-current-component o) value)) + :accessor 'form-page-agree + :value t)"*")) + (tr> :id "sure" + (td> (with-message "SURE" "SURE")) + (td> + (cradio> :id "sure" + :label (with-message "SURE" "SURE") + :accessor 'form-page-sure + :value "yes") + (span> :style "margin-right:1.5em;" (with-message "YES" "yes")) + (cradio> :id "sure" + :label (with-message "SURE" "SURE") + :validator #'(lambda (value) + (validate-agree (page-current-component o) value)) + :accessor 'form-page-sure + :value "no") + (span> :style "margin-right:1.5em;" (with-message "NO" "no")))) + (tr> + (td> "Gender") + (td> + (cselect> :id "gender" + :accessor 'form-page-gender + (loop for gender in (list "M" "F") + collect (option> :value gender + (when (string= gender (form-page-gender o)) + '(:selected "selected")) + (if (string= gender "M") + "Male" + "Female")))))) + (tr> + (td> "Age") + (td> + (cinput> :id "age" + :type "text" + :label "Age" + :translator (make-instance 'translator-integer :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-integer component value :min 1 :max 2000))) + :accessor 'form-page-age)"*")) + (tr> + (td> "Birthday") + (td> + (cinput> :id "bday" + :type "text" + :label "Birthday" + :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) + :accessor 'form-page-birthday)"(dd-mm-yyyy)")) + (tr> + (td> "Capital") + (td> + (cinput> :id "capital" + :type "text" + :label "Capital" + :translator (make-instance 'translator-number + :decimal-digits 2 + :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-number component value :min 1000.01 :max 500099/100))) + :accessor 'form-page-capital)"*")) + (tr> + (td> "Colors") + (td> + (cselect> :id "colors" + :multiple "true" + :style "width:80px;height:120px;" + :accessor 'form-page-colors + (loop for color in (list "R" "G" "B") + collect (option> :value color + (when (find color (form-page-colors o) :test #'string=) + '(:selected "selected")) + (cond + ((string= color "R") "red") + ((string= color "G") "green") + (t "blue"))))))) + (tr> + (td> :colspan "2" + (csubmit> :id "submit" :value "OK"))))) + (p> + (exception-monitor> :class "error") + (hr>) + (h2> "From result:") + (div> (format nil "Name: ~a" (user-name user))) + (div> (format nil "Surname: ~a" (user-surname user))) + (div> (format nil "Gender: ~a" (user-gender user))) + (div> (format nil "Age: ~a" (user-age user))) + (div> (format nil "Agree: ~a" (user-agree user))) + (div> (format nil "Sure: ~a" (user-sure user))))))) (lisplet-register-page-location *test-lisplet* 'form-page "form.html")

1 0

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

24 May '08

Author: achiumenti Date: Sat May 24 13:18:39 2008 New Revision: 48 Modified: trunk/main/claw-core/claw.asd trunk/main/claw-core/src/components.lisp trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/misc.lisp trunk/main/claw-core/src/packages.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/src/tags.lisp trunk/main/claw-core/src/validators.lisp Log: a lot of bug fixes Modified: trunk/main/claw-core/claw.asd ============================================================================== --- trunk/main/claw-core/claw.asd (original) +++ trunk/main/claw-core/claw.asd Sat May 24 13:18:39 2008 @@ -31,7 +31,7 @@ :name "claw" :author "Andrea Chiumenti" :description "Common Lisp Active Web.A famework to write web applications" - :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence) + :depends-on (:closer-mop :hunchentoot :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :parenscript) :components ((:module src :components ((:file "packages") (:file "misc" :depends-on ("packages")) Modified: trunk/main/claw-core/src/components.lisp ============================================================================== --- trunk/main/claw-core/src/components.lisp (original) +++ trunk/main/claw-core/src/components.lisp Sat May 24 13:18:39 2008 @@ -55,7 +55,8 @@ (defun component-validation-errors (component &optional (request *request*)) "Resurns possible validation errors occurred during form rewinding bound to a specific component" (let ((client-id (htcomponent-client-id component))) - (assoc client-id (validation-errors request) :test #'equal))) + (getf (validation-errors request) (make-symbol client-id)))) + ;-------------------------------------------------------------------------------- (defclass cform (wcomponent) @@ -87,7 +88,7 @@ (defmethod wcomponent-template((cform cform)) (let ((client-id (htcomponent-client-id cform)) (class (css-class cform)) - (validation-errors (aux-request-value :validation-errors))) + (validation-errors (validation-errors))) (when validation-errors (if (or (null class) (string= class "")) (setf class "error") @@ -105,7 +106,7 @@ (setf (page-current-form pobj) obj)) (defmethod wcomponent-after-rewind ((obj cform) (pobj page)) - (let ((validation-errors (aux-request-value :validation-errors)) + (let ((validation-errors (validation-errors)) (action (action obj))) (unless validation-errors (when (or action (cform-rewinding-p obj pobj)) @@ -177,7 +178,7 @@ :reader input-type :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :empty t) + (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cinput))) Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Sat May 24 13:18:39 2008 @@ -196,8 +196,14 @@ (let ((resource-full-path (merge-pathnames (uri-to-pathname (subseq (script-name) (+ (length (clawserver-base-path (current-server))) - (length (lisplet-base-path (lisplet-base-path lisplet)))))) + (length (lisplet-base-path lisplet)) + (length location) 1))) resource-path))) + (log-message :info "--------------------------------------------- ~% +script-name: \"~a\"~% +resource-path: \"~a\"~% +resource-full-path :\"~a\"~% +--------------------------------------------" (script-name) resource-path resource-full-path) (handle-static-file resource-full-path content-type))) #'(lambda () (handle-static-file resource-path content-type)))) pages))))) @@ -208,10 +214,9 @@ (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))))) + do (progn + (log-message :info "rel-script-name: \"~a\" url: \"~a\" --- (starts-with-subseq rel-script-name url) : ~a" rel-script-name url (starts-with-subseq rel-script-name url)) + (when (starts-with-subseq rel-script-name url) (return (funcall action))))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) Modified: trunk/main/claw-core/src/misc.lisp ============================================================================== --- trunk/main/claw-core/src/misc.lisp (original) +++ trunk/main/claw-core/src/misc.lisp Sat May 24 13:18:39 2008 @@ -217,6 +217,22 @@ "Resurns possible validation errors occurred during form rewinding" (aux-request-value :validation-errors request)) +(defun (setf validation-errors) (value &optional (request *request*)) + "Sets possible validation errors occurred during form rewinding" + (setf (aux-request-value :validation-errors request) value)) + +(defun validation-compliances (&optional (request *request*)) + "Resurns the list of components that pass validation during form rewinding" + (aux-request-value :validation-compliances request)) + +(defun (setf validation-compliances) (value &optional (request *request*)) + "Sets the list of components that pass validation during form rewinding" + (setf (aux-request-value :validation-compliances request) value)) + +(defun add-validation-compliance (id &optional (request *request*)) + "Adds a component id to the list of components that pass validation during form rewinding" + (setf (validation-compliances request) (nconc (validation-compliances request) (list id)))) + (defclass metacomponent (standard-class) () (:documentation "This is the meta class the must be set for every WCOMPONENT. Modified: trunk/main/claw-core/src/packages.lisp ============================================================================== --- trunk/main/claw-core/src/packages.lisp (original) +++ trunk/main/claw-core/src/packages.lisp Sat May 24 13:18:39 2008 @@ -211,6 +211,7 @@ :lisplet-protect :lisplet-authentication-type :claw-start-session + :build-lisplet-location ;; clawserver :clawserver :clawserver-base-path @@ -234,6 +235,8 @@ #-:hunchentoot-no-ssl :clawserver-ssl-certificate-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-file #-:hunchentoot-no-ssl :clawserver-ssl-privatekey-password + :add-exception + :component-exceptions :msie-p :*id-and-static-id-description* :describe-component-behaviour @@ -273,6 +276,8 @@ :*locales* :validate :validation-errors + :validation-compliances + :add-validation-compliance :component-validation-errors :validate-required :validate-size Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Sat May 24 13:18:39 2008 @@ -385,21 +385,15 @@ (when (starts-with-subseq script-name base-path) (setf rel-script-name (subseq script-name (length base-path)) rel-script-name-libs (subseq script-name (1+ (length base-path)))) - (or + (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name-libs) - (null (starts-with-subseq rel-script-name-libs url))) (return nil)) - ((starts-with-subseq rel-script-name-libs url) (return (funcall action))))) + do (when (starts-with-subseq rel-script-name-libs url) (funcall action))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))))))) + do (when (starts-with-subseq rel-script-name url) (return (funcall action)))))))) (defmethod clawserver-dispatch-method ((clawserver clawserver)) (let ((result (clawserver-dispatch-request clawserver))) Modified: trunk/main/claw-core/src/tags.lisp ============================================================================== --- trunk/main/claw-core/src/tags.lisp (original) +++ trunk/main/claw-core/src/tags.lisp Sat May 24 13:18:39 2008 @@ -15,7 +15,7 @@ ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. -;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSEDse +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY @@ -105,9 +105,10 @@ This internal method is called to render these scripts. - PAGE is the page instance that must be given")) -(defgeneric htbody-init-scripts-tag (page) +(defgeneric htbody-init-scripts-tag (page &optional on-load) (:documentation "Encloses the init inscance scripts injected into the page into a <script> tag component -See PAGE-BODY-INIT-SCRIPTS form more info. +See PAGE-BODY-INIT-SCRIPTS form more info. If the ON-LOAD parameter it not nil, then the script will be executed +on the onload document event. - PAGE is the page instance that must be given")) (defgeneric page-current-component (page) @@ -370,6 +371,8 @@ :accessor page-lasttag :documentation "Last rendered tag. Needed for page output rendering") (json-component-count :initarg :json-component-count :accessor page-json-component-count :documentation "Need to render the json object after an xhr call.") + (json-component-id-list :initform () + :accessor page-json-component-id-list :documentation "The current component that will ber rendered into json reply object in an xhr call.") (request-parameters :initarg :request-parameters :documentation "This slot is used to avoid PAGE-REQUEST-PARAMETERS multimple computations, saving the result of this function on the first call and then using the cached value.") (components-stack :initform nil @@ -398,6 +401,9 @@ (defclass htcomponent (i18n-aware) ((page :initarg :page :reader htcomponent-page :documentation "The owner page") + (json-render-on-validation-errors-p :initarg :json-render-on-validation-errors-p + :reader htcomponent-json-render-on-validation-errors-p + :documentation "If from submission contains exceptions and the value is not nil, the component is rendered into the xhr json reply.") (body :initarg :body :accessor htcomponent-body :documentation "The tag body") (client-id :initarg :client-id @@ -416,6 +422,7 @@ :accessor htcomponent-instance-initscript :documentation "Page injectable javascript instance derectives")) (:default-initargs :page nil :body nil + :json-render-on-validation-errors-p nil :client-id nil :attributes nil :empty nil @@ -585,14 +592,19 @@ (defun json-validation-errors () "Composes the error part for the json reply" - (let ((validation-errors (aux-request-value :validation-errors))) + (let ((validation-errors (validation-errors))) (if validation-errors - (strings-to-jsarray - (loop for component-exceptions in validation-errors - collect (format "{~a:~a}"(car component-exceptions) - (strings-to-jsarray (loop for message in (cdr component-exceptions) - collect (prin1-to-string message)))))) + (let* ((errors (loop for (component-id messages) on validation-errors by #'cddr + collect (symbol-name component-id) + collect (push 'array messages))) + (js-struct (ps:ps* `(create ,@errors)))) + (subseq js-struct 0 (1- (length js-struct)))) "null"))) + +(defun json-validation-compliances () + "Composes the compliances part to form validation for the json reply" + (let ((js-array (ps:ps* `(array ,@(validation-compliances))))) + (subseq js-array 0 (1- (length js-array))))) (defmethod page-render ((page page)) (let ((body (page-content page)) @@ -624,6 +636,8 @@ (htcomponent-render init-scripts page))) (page-format-raw page "\",errors:") (page-format-raw page (json-validation-errors)) + (page-format-raw page ",valid:") + (page-format-raw page (json-validation-compliances)) (page-format-raw page "}")))))) (defmethod page-body-init-scripts ((page page)) @@ -687,26 +701,39 @@ (let* ((id (htcomponent-client-id htcomponent)) (page (htcomponent-page htcomponent)) (print-status (page-can-print page)) - (render-p (member id (page-json-id-list page) :test #'string=))) - (or print-status render-p))) + (validation-errors (validation-errors)) + (json-render-on-validation-errors-p (htcomponent-json-render-on-validation-errors-p htcomponent)) + (render-p (or (and (member id (page-json-id-list page) :test #'string=) + (null validation-errors)) + print-status))) + #|json-render-on-validation-errors-p|# + (or json-render-on-validation-errors-p print-status render-p))) (defmethod htcomponent-json-print-start-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (id (htcomponent-client-id htcomponent)) + (validation-errors (validation-errors))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (or (and (null validation-errors) + (member id jsonp :test #'string-equal)) + (htcomponent-json-render-on-validation-errors-p htcomponent))) (when (> (page-json-component-count page) 0) (page-format page ",")) (page-format-raw page "~a:\"" id) + (push id (page-json-component-id-list page)) (incf (page-json-component-count page))))) (defmethod htcomponent-json-print-end-component ((htcomponent htcomponent)) (let* ((page (htcomponent-page htcomponent)) (jsonp (page-json-id-list page)) - (id (htcomponent-client-id htcomponent))) + (id (htcomponent-client-id htcomponent)) + (validation-errors (validation-errors))) (when (and jsonp - (member id jsonp :test #'string-equal)) + (or (and (null validation-errors) + (member id jsonp :test #'string-equal)) + (htcomponent-json-render-on-validation-errors-p htcomponent))) + (pop (page-json-component-id-list page)) (page-format-raw page "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) @@ -776,7 +803,7 @@ (page-format page " ~a=\"~a\"" (string-downcase (if (eq k :static-id) "id" - (symbol-name k))) + (parenscript::symbol-to-js k))) (let ((s (if (eq k :id) (prin1-to-string (htcomponent-client-id tag)) (prin1-to-string v)))) ;escapes double quotes @@ -784,26 +811,32 @@ (defmethod tag-render-starttag ((tag tag) (page page)) (let ((tagname (tag-name tag)) + (id (htcomponent-client-id tag)) + (jsonp (page-json-id-list page)) (emptyp (htcomponent-empty tag)) (xml-p (page-xmloutput page))) (setf (page-lasttag page) tagname) - (page-newline page) - (page-print-tabulation page) - (page-format page "<~a" tagname) - (tag-render-attributes tag page) - (if (null emptyp) - (progn - (page-format page ">") - (incf (page-tabulator page))) - (if (null xml-p) + (unless (and jsonp (string= id (first (page-json-component-id-list page)))) + (page-newline page) + (page-print-tabulation page) + (page-format page "<~a" tagname) + (tag-render-attributes tag page) + (if (null emptyp) + (progn (page-format page ">") - (page-format page "/>"))))) + (incf (page-tabulator page))) + (if (null xml-p) + (page-format page ">") + (page-format page "/>")))))) (defmethod tag-render-endtag ((tag tag) (page page)) (let ((tagname (tag-name tag)) + (id (htcomponent-client-id tag)) + (jsonp (page-json-id-list page)) (previous-tagname (page-lasttag page)) (emptyp (htcomponent-empty tag))) - (when (null emptyp) + (when (and (null emptyp) (not (and jsonp + (string= id (first (page-json-component-id-list page)))))) (progn (decf (page-tabulator page)) (if (string= tagname previous-tagname) @@ -906,8 +939,8 @@ (dolist (element body) (when element (cond - ((stringp element) (htcomponent-render ($> element) page)) - ((functionp element) (htcomponent-render ($> (funcall element)) page)) + ((stringp element) (htcomponent-render ($raw> element) page)) + ((functionp element) (htcomponent-render ($raw> (funcall element)) page)) (t (htcomponent-render element page))))) (if (null xml-p) (page-format page "~%//-->") @@ -952,20 +985,22 @@ ((functionp child-tag) (htcomponent-render ($> (funcall child-tag)) page)) (t (htcomponent-render child-tag page))))) (when (page-can-print page) - (htcomponent-render (htbody-init-scripts-tag page) page) + (htcomponent-render (htbody-init-scripts-tag page t) page) (tag-render-endtag htbody page)) (when (or (page-can-print page) previous-print-status) (setf (page-can-print page) nil) (htcomponent-json-print-end-component htbody)))) -(defmethod htbody-init-scripts-tag ((page page)) +(defmethod htbody-init-scripts-tag ((page page) &optional on-load) (let ((js (script> :type "text/javascript")) - (js-start-directive (if (msie-p) - "window.attachEvent\('onload', function\(e) {" - "document.addEventListener\('DOMContentLoaded', function\(e) {")) - (js-end-directive (if (msie-p) - "});" - "}, false);")) + (js-start-directive (if on-load (if (msie-p) + "window.attachEvent\('onload', function\(e) {" + "document.addEventListener\('DOMContentLoaded', function\(e) {") + "")) + (js-end-directive (if on-load (if (msie-p) + "});" + "}, false);") + "")) (page-body-init-scripts (page-body-init-scripts page))) (setf (htcomponent-page js) page (htcomponent-body js) (when page-body-init-scripts @@ -982,6 +1017,9 @@ :accessor wcomponent-reserved-parameters :type cons :documentation "Parameters that may not be used in the constructor function") + (json-error-monitor-p :initarg :json-error-monitor-p + :accessor htcomponent-json-error-monitor-p + :documentation "When not nil, if the client has sent a XHR call, let the page to fill the errorComponents property of the json reply.") (informal-parameters :initform () :accessor wcomponent-informal-parameters :type cons Modified: trunk/main/claw-core/src/validators.lisp ============================================================================== --- trunk/main/claw-core/src/validators.lisp (original) +++ trunk/main/claw-core/src/validators.lisp Sat May 24 13:18:39 2008 @@ -39,44 +39,47 @@ (decode-local-time local-time) (declare (ignore nsec)) (loop for result = "" then (concatenate 'string result (if (stringp element) - element - (ccase element - (:second (format nil "~2,'0D" sec)) - (:minute (format nil "~2,'0D" min)) - (:hour (format nil "~2,'0D" hour)) - (:date (format nil "~2,'0D" day)) - (:month (format nil "~2,'0D" month)) - (:year (format nil "~4,'0D" year))))) + element + (ccase element + (:second (format nil "~2,'0D" sec)) + (:minute (format nil "~2,'0D" min)) + (:hour (format nil "~2,'0D" hour)) + (:date (format nil "~2,'0D" day)) + (:month (format nil "~2,'0D" month)) + (:year (format nil "~4,'0D" year))))) for element in format finally (return result)))) (defun add-exception (id reason) -"Adds an exception for the given input component identified by its ID with the message expressed by REASON" - (let* ((validation-errors (aux-request-value :validation-errors)) - (component-exceptions (assoc id validation-errors :test #'equal))) - (if component-exceptions - (setf (cdr component-exceptions) (append (cdr component-exceptions) (list reason))) - (if validation-errors - (setf (aux-request-value :validation-errors) (append validation-errors (list (cons id (list reason))))) - (setf (aux-request-value :validation-errors) (list (cons id (list reason)))))))) - + "Adds an exception for the given input component identified by its ID with the message expressed by REASON" + (let* ((validation-errors (validation-errors)) + (symbol-id (make-symbol id)) + (errors (getf validation-errors symbol-id))) + (setf (getf validation-errors symbol-id) (nconc errors (list reason)) + (validation-errors *request*) validation-errors))) + +(defun component-exceptions (id) + "Returns a list of exception connectd to the given component" + (let ((symbol-id (make-symbol id))) + (getf (validation-errors) symbol-id))) (defun validate (test &key component message) -"When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..." + "When test is nil, an exception message given by MESSAGE is added for the COMPONENT. See: ADD-EXCEPTION..." (let ((client-id (htcomponent-client-id component))) - (unless test - (add-exception client-id message)))) + (if test + (add-validation-compliance client-id) + (add-exception client-id message)))) (defun validate-required (component value) - "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be null.\" is sent with key \"VALIDATE-REQUIRED\". + "Checks if the required input field VALUE is present. If not, a localizable message \"Field ~a may not be empty.\" is sent with key \"VALIDATE-REQUIRED\". The argument for the message will be the :label attribute of the COMPONENT." (when (stringp value) (validate (and value (string-not-equal value "")) - :component component - :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be null.") (label component))))) + :component component + :message (format nil (do-message "VALIDATE-REQUIRED" "Field ~a may not be empty.") (label component))))) (defun validate-size (component value &key min-size max-size) -"Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. + "Checks if the input field VALUE legth is less then or greater then rispectively of the form keywords :MIN-SIZE and :MAX-SIZE. If less then :MIN-SIZE, a localizable message \"Size of ~a may not be less then ~a chars.\" is sent with key \"VALIDATE-SIZE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN-ZIZE value. If greater then :MAX-SIZE, a localizable message \"Size of ~a may not be more then ~a chars\" is sent with key \"VALIDATE-SIZE-MAX\". @@ -86,64 +89,64 @@ (setf value (format nil "~a" value)) (setf value-len (length value)) (and (= value-len 0) - (when min-size - (validate (>= value-len min-size) - :component component - :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) - (label component) - min-size))) - (when max-size - (validate (<= value-len max-size) - :component component - :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) - (label component) - max-size))))))) + (when min-size + (validate (>= value-len min-size) + :component component + :message (format nil (do-message "VALIDATE-SIZE-MIN" "Size of ~a may not be less then ~a chars." ) + (label component) + min-size))) + (when max-size + (validate (<= value-len max-size) + :component component + :message (format nil (do-message "VALIDATE-SIZE-MAX" "Size of ~a may not be more then ~a chars." ) + (label component) + max-size))))))) (defun validate-range (component value &key min max) -"Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. + "Checks if the numeric input field VALUE is less then or greater then rispectively of the form keywords :MIN and :MAX. If less then :MIN, a localizable message \"Field ~a is not less then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MIN\". The argument for the message will be the :label attribute of the COMPONENT and the :MIN value. If greater then :MIN, a localizable message \"Field ~a is not greater then or equal to ~d.\" is sent with key \"VALIDATE-RANGE-MAX\". The argument for the message will be the :label attribute of the COMPONENT and the :MAX value." (when value (and (when min - (validate (>= value min) - :component component - :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") - (label component) - (if (typep min 'ratio) - (coerce min 'float) - min)))) - (when max - (validate (<= value max) - :component component - :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") - (label component) - (if (typep max 'ratio) - (coerce max 'float) - max))))))) + (validate (>= value min) + :component component + :message (format nil (do-message "VALIDATE-RANGE-MIN" "Field ~a is not greater then or equal to ~d") + (label component) + (if (typep min 'ratio) + (coerce min 'float) + min)))) + (when max + (validate (<= value max) + :component component + :message (format nil (do-message "VALIDATE-RANGE-MAX" "Field ~a is not less then or equal to ~d") + (label component) + (if (typep max 'ratio) + (coerce max 'float) + max))))))) (defun validate-number (component value &key min max) -"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. + "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid number.\" is sent with key \"VALIDATE-NUMBER\". The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (numberp value))) (and (validate test - :component component - :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) - (validate-range component value :min min :max max))))) + :component component + :message (format nil (do-message "VALIDATE-NUMBER" "Field ~a is not a valid number.") (label component))) + (validate-range component value :min min :max max))))) (defun validate-integer (component value &key min max) -"Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. + "Checks if the input field VALUE is a valid number and then passes the validation to VALIDATION-RANGE. If not a number, a localizable message \"Field ~a is not a valid integer.\" is sent with key \"VALIDATE-INTEGER\". The argument for the message will be the :label attribute of the COMPONENT." (when value (let ((test (integerp value))) (and (validate test - :component component - :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) - (validate-range component value :min min :max max))))) + :component component + :message (format nil (do-message "VALIDATE-INTEGER" "Field ~a is not a valid integer.") (label component))) + (validate-range component value :min min :max max))))) (defun validate-date-range (component value &key min max (use-date-p t) use-time-p) @@ -157,64 +160,69 @@ The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword." (unless (component-validation-errors component) (let ((local-time-format '(:date "-" :month "-" :year)) - (new-value (make-instance 'local-time - :nsec (nsec-of value) - :sec (sec-of value) - :day (day-of value) - :timezone (timezone-of value)))) + (new-value (make-instance 'local-time + :nsec (nsec-of value) + :sec (sec-of value) + :day (day-of value) + :timezone (timezone-of value)))) (when (and use-date-p (not use-time-p)) - (setf (local-time:nsec-of new-value) 0 - (local-time:sec-of new-value) 0) - (when min - (setf (local-time:nsec-of min) 0 - (local-time:sec-of min) 0)) - (when max - (setf (local-time:nsec-of max) 0 - (local-time:sec-of max) 0))) + (setf (local-time:nsec-of new-value) 0 + (local-time:sec-of new-value) 0) + (when min + (setf (local-time:nsec-of min) 0 + (local-time:sec-of min) 0)) + (when max + (setf (local-time:nsec-of max) 0 + (local-time:sec-of max) 0))) (when (and (not use-date-p) use-time-p) - (setf (local-time:day-of new-value) 0) - (when min - (setf (local-time:day-of min) 0)) - (when max - (setf (local-time:day-of max) 0))) + (setf (local-time:day-of new-value) 0) + (when min + (setf (local-time:day-of min) 0)) + (when max + (setf (local-time:day-of max) 0))) (and (when min - (validate (local-time> new-value min) - :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") - (label component) - (local-time-to-string min local-time-format)))) - (when max - (validate (local-time< new-value max) - :component component - :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") - (label component) - (local-time-to-string max local-time-format)))))))) - + (validate (local-time> new-value min) + :component component + :message (format nil (do-message "VALIDATE-DATE-RANGE-MIN" "Field ~a is less then ~a.") + (label component) + (local-time-to-string min local-time-format)))) + (when max + (validate (local-time< new-value max) + :component component + :message (format nil (do-message "VALIDATE-DATE-RANGE-MAX" "Field ~a is greater then ~a.") + (label component) + (local-time-to-string max local-time-format)))))))) + ;; ------------------------------------------------------------------------------------ (defclass exception-monitor (wcomponent) () (:metaclass metacomponent) - (:default-initargs :empty t) + (:default-initargs :json-render-on-validation-errors-p t) (:documentation "If from submission contains exceptions. It displays exception messages")) (let ((class (find-class 'exception-monitor))) (closer-mop:ensure-finalized class) (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) - (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" - "If from submission contains exceptions. It displays exception messages with a <ul> list" - *id-and-static-id-description* - (describe-html-attributes-from-class-slot-initargs class) - (describe-component-behaviour class)))) + (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" + "If from submission contains exceptions. It displays exception messages with a <ul> list" + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) (defmethod wcomponent-template ((exception-monitor exception-monitor)) (let ((client-id (htcomponent-client-id exception-monitor)) - (validation-errors (aux-request-value :validation-errors))) - (when validation-errors - (ul> :static-id client-id - (wcomponent-informal-parameters exception-monitor) - (loop for component-exceptions in validation-errors - collect (loop for message in (cdr component-exceptions) - collect (li> message))))))) + (validation-errors (validation-errors)) + (body (htcomponent-body exception-monitor))) + (div> :static-id client-id + (wcomponent-informal-parameters exception-monitor) + (when validation-errors + (if body + body + (ul> + (loop for component-exceptions in (rest validation-errors) by #'cddr + do (loop for message in component-exceptions + collect (li> message))))))))) + ;;-------------------------------------------------------------------------------------------

1 0

[claw-cvs] r47 - trunk/main/claw-core/src
by achiumenti＠common-lisp.net 13 May '08

13 May '08

Author: achiumenti Date: Tue May 13 11:23:32 2008 New Revision: 47 Modified: trunk/main/claw-core/src/lisplet.lisp Log: corrected authorization logic Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Tue May 13 11:23:32 2008 @@ -264,16 +264,16 @@ ;(when (lisplet-redirect-protected-resources-p lisplet) ;(redirect-to-https server request)) (cond + ((and princp (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) + (setf (return-code) +http-forbidden+) + (throw 'handler-done nil)) ((and (null princp) auth-basicp) (setf (return-code) +http-authorization-required+ (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) (throw 'handler-done nil)) ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) (redirect-to-https server request login-page-url) - (throw 'handler-done nil)) - ((and (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) - (setf (return-code) +http-forbidden+) - (throw 'handler-done nil)) + (throw 'handler-done nil)) #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) (redirect-to-https server request) (throw 'handler-done nil))))))))

1 0

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

13 May '08

Author: achiumenti Date: Tue May 13 09:32:43 2008 New Revision: 46 Modified: trunk/main/claw-core/src/lisplet.lisp trunk/main/claw-core/src/server.lisp trunk/main/claw-core/tests/test1.lisp Log: corrected authorization logic Modified: trunk/main/claw-core/src/lisplet.lisp ============================================================================== --- trunk/main/claw-core/src/lisplet.lisp (original) +++ trunk/main/claw-core/src/lisplet.lisp Tue May 13 09:32:43 2008 @@ -99,42 +99,42 @@ (setf *http-error-handler* ;;overrides the default hunchentoot error handling #'(lambda (error-code) - (let* ((error-handlers (if (current-lisplet) - (lisplet-error-handlers (current-lisplet)) - (make-hash-table))) - (handler (gethash error-code error-handlers))) - (if handler - (funcall handler) - (let ((error-page (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) - :error-code error-code))) - (with-output-to-string (*standard-output*) (page-render error-page))))))) + (let* ((error-handlers (if (current-lisplet) + (lisplet-error-handlers (current-lisplet)) + (make-hash-table))) + (handler (gethash error-code error-handlers))) + (if handler + (funcall handler) + (let ((error-page (make-instance 'error-page + :title (format nil "Server error: ~a" error-code) + :error-code error-code))) + (with-output-to-string (*standard-output*) (page-render error-page))))))) (defclass lisplet (i18n-aware) ((base-path :initarg :base-path - :reader lisplet-base-path - :documentation "common base path all resources registered into this lisplet") + :reader lisplet-base-path + :documentation "common base path all resources registered into this lisplet") (welcome-page :initarg :welcome-page - :accessor lisplet-welcome-page - :documentation "url location for the welcome page") + :accessor lisplet-welcome-page + :documentation "url location for the welcome page") (login-page :initarg :login-page - :accessor lisplet-login-page - :documentation "url location for the welcome page") + :accessor lisplet-login-page + :documentation "url location for the welcome page") (realm :initarg :realm - :reader lisplet-realm - :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") + :reader lisplet-realm + :documentation "realm for requests that pass through this lisplet and session opened into this lisplet") (pages :initform nil - :accessor lisplet-pages - :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher") + :accessor lisplet-pages + :documentation "A collection of cons where the car is an url location and the cdr is a dispatcher") (error-handlers :initform (make-hash-table) - :accessor lisplet-error-handlers - :documentation "An hash table where keys are http error codes and values are functions with no parameters") + :accessor lisplet-error-handlers + :documentation "An hash table where keys are http error codes and values are functions with no parameters") (protected-resources :initform nil - :accessor lisplet-protected-resources - :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location") + :accessor lisplet-protected-resources + :documentation "A collection of cons where the car is the protected url location and the cdr is a string list of roles allowhed to access the relative location") (redirect-protected-resources-p :initarg :redirect-protected-resources-p - :accessor lisplet-redirect-protected-resources-p - :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) + :accessor lisplet-redirect-protected-resources-p + :documentation "When not null every request will be redirected in https mode. When running in mod-lisp mode, *apache-http-port* and *apache-https-port* values are used")) (:default-initargs :welcome-page nil :login-page nil :realm "claw" @@ -144,19 +144,19 @@ (defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) - (location (lisplet-base-path lisplet))) + (location (lisplet-base-path lisplet))) (setf (clawserver-dispatchers clawserver) (sort-by-location (pushnew-location - (cons location - #'(lambda () - (progn - (setf (current-realm *request*) (lisplet-realm lisplet) - (current-lisplet) lisplet) - (lisplet-dispatch-method lisplet)))) - dispatchers))))) + (cons location + #'(lambda () + (progn + (setf (current-realm *request*) (lisplet-realm lisplet) + (current-lisplet) lisplet) + (lisplet-dispatch-method lisplet)))) + dispatchers))))) (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((dispatchers (clawserver-dispatchers clawserver)) - (location (lisplet-base-path lisplet))) + (location (lisplet-base-path lisplet))) (remove-by-location location dispatchers))) @@ -172,7 +172,7 @@ (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) - (sort-by-location (pushnew-location (cons location function) pages))) + (sort-by-location (pushnew-location (cons location function) pages))) (when welcome-page-p (setf (lisplet-welcome-page lisplet) location)) (when login-page-p @@ -180,102 +180,100 @@ (defmethod lisplet-register-page-location ((lisplet lisplet) page-class location &key welcome-page-p login-page-p) (lisplet-register-function-location lisplet - #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :lisplet lisplet :url location)))) - location - :welcome-page-p welcome-page-p - :login-page-p login-page-p)) + #'(lambda () (with-output-to-string (*standard-output*) + (page-render (make-instance page-class :lisplet lisplet :url location)))) + location + :welcome-page-p welcome-page-p + :login-page-p login-page-p)) (defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) - (sort-by-location (pushnew-location - (cons location - (if (directory-pathname-p resource-path) - #'(lambda () - (let ((resource-full-path (merge-pathnames - (uri-to-pathname (subseq (script-name) - (+ (length (clawserver-base-path (current-server))) - (length (lisplet-base-path (lisplet-base-path lisplet)))))) - resource-path))) - (handle-static-file resource-full-path content-type))) - #'(lambda () (handle-static-file resource-path content-type)))) - pages))))) + (sort-by-location (pushnew-location + (cons location + (if (directory-pathname-p resource-path) + #'(lambda () + (let ((resource-full-path (merge-pathnames + (uri-to-pathname (subseq (script-name) + (+ (length (clawserver-base-path (current-server))) + (length (lisplet-base-path (lisplet-base-path lisplet)))))) + resource-path))) + (handle-static-file resource-full-path content-type))) + #'(lambda () (handle-static-file resource-path content-type)))) + pages))))) (defmethod lisplet-dispatch-request ((lisplet lisplet)) (let ((dispatchers (lisplet-pages lisplet)) - (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) + (rel-script-name (subseq (script-name) (1+ (length (build-lisplet-location lisplet)))))) (loop for dispatcher in dispatchers - for url = (car dispatcher) - for action = (cdr dispatcher) - do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))))) + for url = (car dispatcher) + for action = (cdr dispatcher) + do (cond + ((and (string< url rel-script-name) + (null (starts-with-subseq rel-script-name url))) (return nil)) + ((starts-with-subseq rel-script-name url) (return (funcall action))))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let ((base-path (build-lisplet-location lisplet)) - (uri (script-name)) - (welcome-page (lisplet-welcome-page lisplet))) + (uri (script-name)) + (welcome-page (lisplet-welcome-page lisplet))) (lisplet-check-authorization lisplet) - (when (= (return-code) +http-ok+) - (if (and welcome-page (string= uri base-path)) - (page-render (lisplet-welcome-page lisplet)) - (lisplet-dispatch-request lisplet))))) + (when (= (return-code) +http-ok+) + (if (and welcome-page (string= uri base-path)) + (page-render (lisplet-welcome-page lisplet)) + (lisplet-dispatch-request lisplet))))) (defmethod lisplet-protect ((lisplet lisplet) location roles) (let ((protected-resources (lisplet-protected-resources lisplet))) (setf (lisplet-protected-resources lisplet) - (sort-protected-resources (pushnew-location - (cons location roles) - protected-resources))))) - -(defun redirect-to-https (server request) - "Redirects a request sent through http using https" - (cond - ((= (server-port request) (clawserver-port server)) - (progn - (redirect (request-uri request) - :port (clawserver-sslport server) - :protocol :HTTPS) - (throw 'handler-done nil))) - ((= (server-port request) *apache-http-port*) - (progn - (redirect (request-uri request) - :port *apache-https-port* - :protocol :HTTPS) - (throw 'handler-done nil))))) + (sort-protected-resources (pushnew-location + (cons location roles) + protected-resources))))) + +(defun redirect-to-https (server request &optional uri) + "Redirects a request sent through http using https" + (let ((path (or uri (request-uri request))) + (port (server-port request)) + (protocol :http)) + #-:hunchentoot-no-ssl (when (or (clawserver-mod-lisp-p server) + (clawserver-ssl-certificate-file server)) + (setf protocol :https + port (if (clawserver-mod-lisp-p server) + *apache-https-port* + (clawserver-sslport server)))) + (redirect path :port port :protocol protocol))) (defmethod lisplet-check-authorization ((lisplet lisplet) &optional (request *request*)) - (let ((uri (script-name request)) - (base-path (build-lisplet-location lisplet)) - (protected-resources (lisplet-protected-resources lisplet)) - (princp (current-principal)) - (login-config (current-config)) - (login-page (lisplet-login-page lisplet)) - (server (current-server request)) - (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) + (let* ((uri (script-name request)) + (base-path (build-lisplet-location lisplet)) + (protected-resources (lisplet-protected-resources lisplet)) + (princp (current-principal)) + (login-config (current-config)) + (login-page-url (format nil "~a/~a" base-path (lisplet-login-page lisplet))) + (server (current-server request)) + (auth-basicp (eq (lisplet-authentication-type lisplet) :basic))) (setf (return-code) +http-ok+) (when login-config (when (and auth-basicp (null princp)) - (configuration-login login-config)) + (configuration-login login-config)) (setf princp (current-principal)) - (when (and login-page - (cl-ppcre:all-matches login-page uri)) - (redirect-to-https server request)) (loop for protected-resource in protected-resources - for match = (format nil "~a~a" base-path (car protected-resource)) - for allowed-roles = (cdr protected-resource) - do (when (starts-with-subseq match uri) - (when (lisplet-redirect-protected-resources-p lisplet) - (redirect-to-https server request)) - (if (null princp) - (progn - (when auth-basicp - (setf (header-out "WWW-Authenticate") - (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm))))) - (setf (return-code) +http-authorization-required+) - (throw 'handler-done nil)) - (unless (user-in-role-p allowed-roles) - (setf (return-code) +http-forbidden+) - (throw 'handler-done nil)))))))) + for match = (format nil "~a/~a" base-path (car protected-resource)) + for allowed-roles = (cdr protected-resource) + do (when (or (starts-with-subseq match uri) (string= login-page-url uri)) + ;(when (lisplet-redirect-protected-resources-p lisplet) + ;(redirect-to-https server request)) + (cond + ((and (null princp) auth-basicp) + (setf (return-code) +http-authorization-required+ + (header-out "WWW-Authenticate") (format nil "Basic realm=\"~A\"" (hunchentoot::quote-string (current-realm)))) + (throw 'handler-done nil)) + ((and (null princp) (null auth-basicp) (not (string= login-page-url uri))) + (redirect-to-https server request login-page-url) + (throw 'handler-done nil)) + ((and (not (user-in-role-p allowed-roles)) (not (string= login-page-url uri))) + (setf (return-code) +http-forbidden+) + (throw 'handler-done nil)) + #-:hunchentoot-no-ssl ((not (find (server-port request) (list (clawserver-sslport server) *apache-https-port*))) + (redirect-to-https server request) + (throw 'handler-done nil)))))))) Modified: trunk/main/claw-core/src/server.lisp ============================================================================== --- trunk/main/claw-core/src/server.lisp (original) +++ trunk/main/claw-core/src/server.lisp Tue May 13 09:32:43 2008 @@ -379,18 +379,20 @@ (let ((base-path (clawserver-base-path clawserver)) (dispatchers (clawserver-dispatchers clawserver)) (script-name (script-name)) - (rel-script-name)) + (rel-script-name) + (rel-script-name-libs)) (setf (current-server) clawserver) (when (starts-with-subseq script-name base-path) - (setf rel-script-name (subseq script-name (length base-path))) + (setf rel-script-name (subseq script-name (length base-path)) + rel-script-name-libs (subseq script-name (1+ (length base-path)))) (or (loop for dispatcher in *claw-libraries-resources* for url = (car dispatcher) for action = (cdr dispatcher) do (cond - ((and (string< url rel-script-name) - (null (starts-with-subseq rel-script-name url))) (return nil)) - ((starts-with-subseq rel-script-name url) (return (funcall action))))) + ((and (string< url rel-script-name-libs) + (null (starts-with-subseq rel-script-name-libs url))) (return nil)) + ((starts-with-subseq rel-script-name-libs url) (return (funcall action))))) (loop for dispatcher in dispatchers for url = (car dispatcher) for action = (cdr dispatcher) Modified: trunk/main/claw-core/tests/test1.lisp ============================================================================== --- trunk/main/claw-core/tests/test1.lisp (original) +++ trunk/main/claw-core/tests/test1.lisp Tue May 13 09:32:43 2008 @@ -37,8 +37,8 @@ (or #.*compile-file-pathname* *load-pathname*))) -(register-library-resource "/libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img")))) -(register-library-resource "/libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) +(register-library-resource "libs/images/" (make-pathname :directory (append (pathname-directory *this-file*) '("img")))) +(register-library-resource "libs/img.jpg" (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) (defvar *lisplet-messages* (make-instance 'simple-message-dispatcher)) @@ -55,23 +55,23 @@ (defvar *test-lisplet*) (setf *test-lisplet* (make-instance 'lisplet :realm "test1" :base-path "/test" - :redirect-protected-resources-p t)) + :redirect-protected-resources-p t)) (defvar *test-lisplet2*) (setf *test-lisplet2* (make-instance 'lisplet :realm "test2" - :base-path "/test2")) + :base-path "/test2")) ;;(defparameter *clawserver* (make-instance 'clawserver :port 4242 :base-path "/claw")) (defvar *clawserver* (make-instance 'clawserver - :port 4242 - :sslport 4445 - :base-path "/claw" - :mod-lisp-p nil - :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" - :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) + :port 4242 + :sslport 4445 + :base-path "/claw" + :mod-lisp-p nil + :ssl-certificate-file #P"/home/kiuma/pem/cacert.pem" + :ssl-privatekey-file #P"/home/kiuma/pem/privkey.pem")) -;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) + ;(setf (lisplet-redirect-protected-resources-p *test-lisplet*) t) (clawserver-register-lisplet *clawserver* *test-lisplet*) (clawserver-register-lisplet *clawserver* *test-lisplet2*) @@ -80,7 +80,7 @@ (declare (ignore request)) (let ((session *session*)) (when (and (string-equal user "kiuma") - (string-equal password "password")) + (string-equal password "password")) (setf (current-principal session) (make-instance 'principal :name user :roles '("user")))))) @@ -90,14 +90,14 @@ (defmethod configuration-login ((test-configuration test-configuration) &optional (request *request*)) (let ((lisplet (current-lisplet request))) (multiple-value-bind (user password) - (if (eq (lisplet-authentication-type lisplet) :basic) - (authorization) - (values (aux-request-value 'user request) - (aux-request-value 'password request))) + (if (eq (lisplet-authentication-type lisplet) :basic) + (authorization) + (values (aux-request-value 'user request) + (aux-request-value 'password request))) (test-configuration-do-login request user password)))) (clawserver-register-configuration *clawserver* "test1" (make-instance 'test-configuration)) - + (defun claw-tst-start () @@ -111,7 +111,7 @@ (defclass site-template (wcomponent) ((title :initarg :title - :reader title)) + :reader title)) (:metaclass metacomponent)) (defmethod wcomponent-template ((o site-template)) @@ -120,7 +120,7 @@ (title> (title o)) (style> :type "text/css" -"input.error { + "input.error { background-color: #FF9999; } ")) @@ -136,37 +136,41 @@ (defclass auth-page (page) ()) (defmethod page-content ((page auth-page)) (site-template> :title "Unauth test page" - (p> "protected content"))) -(lisplet-register-page-location *test-lisplet* 'auth-page "/unauth.html") -(lisplet-register-page-location *test-lisplet* 'auth-page "/auth.html") -(lisplet-protect *test-lisplet* "/auth.html" '("admin" "user")) -(lisplet-protect *test-lisplet* "/unauth.html" '("nobody")) + (p> "protected content"))) +(lisplet-register-page-location *test-lisplet* 'auth-page "unauth.html") +(lisplet-register-page-location *test-lisplet* 'auth-page "auth.html") +(lisplet-protect *test-lisplet* "auth.html" '("admin" "user")) +(lisplet-protect *test-lisplet* "unauth.html" '("nobody")) (defclass index-page (page) ()) -(defmethod page-content ((o index-page)) - (site-template> :title "Home test page" - (p> :id "p" - (ul> - (li> (a> :href "login.html" - "Do login")) - (li> (a> :href "info.html" - "Headers info")) - (li> (a> :href (format nil "~a/libs/images/matrix.jpg" (clawserver-base-path (current-server))) - "show static file provided by CLAW-TESTS package")) - (li> (a> :href "images/matrix.jpg" - "show static file")) - (li> (a> :href "images/matrix2.jpg" - "show file by function")) - (li> (a> :href "../test/realm.html" :target "clwo1" - "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" - "realm on lisplet 'test2'")) - (li> (a> :href "id-tests.html" "id generation test")) - (li> (a> :href "form.html" "form components test")) - (li> (a> :href "auth.html" "authorized page")) - (li> (a> :href "unauth.html" "unauthorized page")))))) -(lisplet-register-page-location *test-lisplet* 'index-page "/index.html" :welcome-page-p t) +(defmethod page-content ((o index-page)) + (let ((clawserver-base-path (clawserver-base-path (current-server)))) + (site-template> :title "Home test page" + (p> :id "p" + (ul> + (li> (a> :href "login.html" + "Do login")) + (li> (a> :href "info.html" + "Headers info")) + (li> (a> :href (format nil "~a/libs/images/matrix.jpg" clawserver-base-path) + "show static file provided by CLAW-TESTS package by folder")) + (li> (a> :href (format nil "~a/libs/img.jpg" clawserver-base-path) + "show static file provided by CLAW-TESTS package by file")) + (li> (a> :href "images/matrix.jpg" + "show static file")) + (li> (a> :href "images/matrix2.jpg" + "show file by function")) + (li> (a> :href "../test/realm.html" :target "clwo1" + "realm on lisplet 'test'")) + (li> (a> :href "../test2/realm.html" :target "clwo2" + "realm on lisplet 'test2'")) + (li> (a> :href "id-tests.html" "id generation test")) + (li> (a> :href "form.html" "form components test")) + (li> (a> :href "auth.html" "authorized page")) + (li> (a> :href "unauth.html" "unauthorized page"))))))) + +(lisplet-register-page-location *test-lisplet* 'index-page "index.html" :welcome-page-p t) (defclass msie-p (wcomponent) () @@ -179,43 +183,43 @@ (defmethod htcomponent-instance-initscript ((msie-p msie-p)) (let ((id (htcomponent-client-id msie-p))) (format nil "document.getElementById('~a').innerHTML = '~a';" - id - (if (msie-p) - "The browser is MSIE" - "The browser is not MSIE")))) + id + (if (msie-p) + "The browser is MSIE" + "The browser is not MSIE")))) (defclass info-page (page) ()) (defmethod page-content ((o info-page)) (let ((header-props (headers-in))) (site-template> :title "Header info page" - (p> :id "p" - (table> - (tr> (td> :colspan "2" "Header info")) - (loop for key-val in header-props - collect (tr> - (td> (format nil "~a" (car key-val)) - (td> (format nil "~a" (cdr key-val)))))))) - (msie-p> :id "msie")))) + (p> :id "p" + (table> + (tr> (td> :colspan "2" "Header info")) + (loop for key-val in header-props + collect (tr> + (td> (format nil "~a" (car key-val)) + (td> (format nil "~a" (cdr key-val)))))))) + (msie-p> :id "msie")))) -(lisplet-register-page-location *test-lisplet* 'info-page "/info.html") +(lisplet-register-page-location *test-lisplet* 'info-page "info.html") (defun test-image-file () (make-pathname :directory (append (pathname-directory *this-file*) '("img")) :name "matrix" :type "jpg")) -(lisplet-register-resource-location *test-lisplet* (test-image-file) "/images/matrix.jpg" "image/jpeg") +(lisplet-register-resource-location *test-lisplet* (test-image-file) "images/matrix.jpg" "image/jpeg") (lisplet-register-function-location *test-lisplet* - (lambda () - (let ((path (test-image-file))) - (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) - (with-open-file (in path :element-type 'flex:octet) - (let ((image-data (make-array (file-length in) - :element-type 'flex:octet))) - (read-sequence image-data in) - image-data)))) - "/images/matrix2.jpg" ) + (lambda () + (let ((path (test-image-file))) + (setf (hunchentoot:content-type) (hunchentoot:mime-type path)) + (with-open-file (in path :element-type 'flex:octet) + (let ((image-data (make-array (file-length in) + :element-type 'flex:octet))) + (read-sequence image-data in) + image-data)))) + "images/matrix2.jpg" ) ;;;--------------------realm test page-------------------------------- (defclass realm-page (page) ()) @@ -224,54 +228,54 @@ (claw-start-session)) (unless (session-value 'RND-NUMBER) (setf (session-value 'RND-NUMBER) (random 1000))) - (site-template> :title "Realm test page" - (p> - "session" - (ul> - (li> (a> :href "http://www.gentoo.org" :target "gentoo" - "gentoo")) - (li> (a> :href "../test/realm.html" :target "clwo1" - "realm on lisplet 'test'")) - (li> (a> :href "../test2/realm.html" :target "clwo2" - "realm on lisplet 'test2'")) - (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) - (li> "Remote Addr: " (session-remote-addr *session*)) - (li> "User agent: " (session-user-agent *session*)) - (li> "Lisplet Realm: " (current-realm)) - (li> "Session Realm: " (session-realm *session*)) - (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) - (li> "Request Realm: " (hunchentoot::realm *request*)))))) + (site-template> :title "Realm test page" + (p> + "session" + (ul> + (li> (a> :href "http://www.gentoo.org" :target "gentoo" + "gentoo")) + (li> (a> :href "../test/realm.html" :target "clwo1" + "realm on lisplet 'test'")) + (li> (a> :href "../test2/realm.html" :target "clwo2" + "realm on lisplet 'test2'")) + (li> "Rnd number value: " (format nil "~d" (session-value 'RND-NUMBER))) + (li> "Remote Addr: " (session-remote-addr *session*)) + (li> "User agent: " (session-user-agent *session*)) + (li> "Lisplet Realm: " (current-realm)) + (li> "Session Realm: " (session-realm *session*)) + (li> "Session value: " (format nil "~a" (hunchentoot::session-string *session*))) + (li> "Request Realm: " (hunchentoot::realm *request*)))))) -(lisplet-register-page-location *test-lisplet* 'realm-page "/realm.html") -(lisplet-register-page-location *test-lisplet2* 'realm-page "/realm.html") +(lisplet-register-page-location *test-lisplet* 'realm-page "realm.html") +(lisplet-register-page-location *test-lisplet2* 'realm-page "realm.html") ;;;--------------------id testing page-------------------------------- (defclass id-tests-page (page) ()) (defmethod page-content ((o id-tests-page)) (let ((uid (generate-id "uid")) - (uid2 (generate-id "uid"))) + (uid2 (generate-id "uid"))) (site-template> :title "a page title" - "\"<escaping>test\"" - (hr>) - (div> :id "foo" :class "goo" - :onclick "this.innerHTML = this.id" - :style "cursor: pointer;" - "passed id: 'foo'[click me, to see generated id]") - (div> :id "foo" - :onclick "this.innerHTML = this.id" - :style "cursor: pointer;" - "passed id: 'foo'[click me, to see generated id]") - (div> :static-id uid - :onclick "this.innerHTML = this.id" - :style "cursor: pointer;" - "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") - (div> :static-id uid2 - :onclick "this.innerHTML = this.id" - :style "cursor: pointer;" - "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")))) + "\"<escaping>test\"" + (hr>) + (div> :id "foo" :class "goo" + :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" + "passed id: 'foo'[click me, to see generated id]") + (div> :id "foo" + :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" + "passed id: 'foo'[click me, to see generated id]") + (div> :static-id uid + :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" + "passed id: 'uid' (generated with generate-id)[click me, to see generated id]") + (div> :static-id uid2 + :onclick "this.innerHTML = this.id" + :style "cursor: pointer;" + "passed id: 'uid' (generated with generate-id)[click me, to see generated id]")))) -(lisplet-register-page-location *test-lisplet* 'id-tests-page "/id-tests.html") +(lisplet-register-page-location *test-lisplet* 'id-tests-page "id-tests.html") ;;;--------------------from components testing page-------------------------------- @@ -280,77 +284,77 @@ (defclass login-page (page) ((username :initform "" - :accessor login-page-username) + :accessor login-page-username) (passowrd :initform "" - :accessor login-page-password)) + :accessor login-page-password)) (:default-initargs :message-dispatcher *lisplet-messages*)) (defmethod page-content ((login-page login-page)) (let ((princp (current-principal))) (site-template> :title "a page title" - (if (null princp) - (cform> :id "loginform" :method "post" :action #'login-page-login - (table> - (tr> - (td> "Username") - (td> - (cinput> :id "username" - :type "text" - :accessor 'login-page-username))) - (tr> - (td> "Password") - (td> - (cinput> :id "passowrd" - :type "password" - :accessor 'login-page-password))) - (tr> - (td> :colspan "2" - (csubmit> :id "submit" :value "Login"))))) - (p> - (with-message "WELCOME" "WELCOME") " " - (principal-name princp) - (a> :href "index.html" "home")))))) + (if (null princp) + (cform> :id "loginform" :method "post" :action #'login-page-login + (table> + (tr> + (td> "Username") + (td> + (cinput> :id "username" + :type "text" + :accessor 'login-page-username))) + (tr> + (td> "Password") + (td> + (cinput> :id "passowrd" + :type "password" + :accessor 'login-page-password))) + (tr> + (td> :colspan "2" + (csubmit> :id "submit" :value "Login"))))) + (p> + (with-message "WELCOME" "WELCOME") " " + (principal-name princp) + (a> :href "index.html" "home")))))) (defmethod login-page-login ((login-page login-page)) (setf (aux-request-value 'user) (login-page-username login-page) - (aux-request-value 'password) (login-page-password login-page)) + (aux-request-value 'password) (login-page-password login-page)) (login)) -(lisplet-register-page-location *test-lisplet* 'login-page "/login.html" :login-page-p t) +(lisplet-register-page-location *test-lisplet* 'login-page "login.html" :login-page-p t) (defclass user () ((name :initarg :name - :accessor user-name) + :accessor user-name) (surname :initarg :surname - :accessor user-surname) - (gender :initarg :gender - :accessor user-gender) + :accessor user-surname) + (gender :initarg :gender + :accessor user-gender) (age :initarg :age - :accessor user-age) + :accessor user-age) (capital :initarg :capital - :accessor user-capital)) + :accessor user-capital)) (:default-initargs :name "" :surname "" :gender "" :age "" :capital 0.0)) (defgeneric form-page-update-user (form-page)) (defclass form-page (page user) ((name :initarg :name - :accessor form-page-name) + :accessor form-page-name) (surname :initarg :surname - :accessor form-page-surname) + :accessor form-page-surname) (colors :initarg :colors - :accessor form-page-colors) + :accessor form-page-colors) (gender :initarg :gender - :writer setf-gender - :accessor form-page-gender) + :writer setf-gender + :accessor form-page-gender) (user :initarg :user - :accessor form-page-user) + :accessor form-page-user) (age :initarg :age - :accessor form-page-age) + :accessor form-page-age) (capital :initarg :capital - :accessor form-page-capital) + :accessor form-page-capital) (birthday :initarg :birthday - :accessor form-page-birthday)) + :accessor form-page-birthday)) (:default-initargs :name "kiuma" :surname "surnk" @@ -364,118 +368,118 @@ (defmethod form-page-update-user ((form-page form-page)) (let ((user (form-page-user form-page)) - (name (form-page-name form-page)) - (surname (form-page-surname form-page)) - (gender (form-page-gender form-page)) - (age (form-page-age form-page))) + (name (form-page-name form-page)) + (surname (form-page-surname form-page)) + (gender (form-page-gender form-page)) + (age (form-page-age form-page))) (setf (user-name user) name - (user-surname user) surname - (user-gender user) gender - (user-age user) age))) + (user-surname user) surname + (user-gender user) gender + (user-age user) age))) -;(defmethod message-dispatch ((object form-page) key locale) + ;(defmethod message-dispatch ((object form-page) key locale) (defmethod page-content ((o form-page)) (site-template> :title "a page title" - (cform> :id "testform" :method "post" :action #'form-page-update-user - (table> - (tr> - (td> "Name") - (td> - (cinput> :id "name" - :type "text" - :label "Name" - :validator #'(lambda (value) - (validate-required (page-current-component o) value)) - :accessor 'form-page-name)"*")) - (tr> :id "messaged" - (td> (with-message "SURNAME" "SURNAME")) - (td> - (cinput> :id "surname" - :type "text" - :label "Surname" - :validator #'(lambda (value) - (validate-required (page-current-component o) value) - (validate-size (page-current-component o) value :min-size 1 :max-size 20)) - :accessor 'form-page-surname)"*")) - (tr> - (td> "Gender") - (td> - (cselect> :id "gender" - :accessor 'form-page-gender - (loop for gender in (list "M" "F") - collect (option> :value gender - (when (string= gender (form-page-gender o)) - '(:selected "selected")) - (if (string= gender "M") - "Male" - "Female")))))) - (tr> - (td> "Age") - (td> - (cinput> :id "age" - :type "text" - :label "Age" - :translator (make-instance 'translator-integer :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-integer component value :min 1 :max 2000))) - :accessor 'form-page-age)"*")) - (tr> - (td> "Birthday") - (td> - (cinput> :id "bday" - :type "text" - :label "Birthday" - :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) - :accessor 'form-page-birthday)"(dd-mm-yyyy)")) - (tr> - (td> "Capital") - (td> - (cinput> :id "capital" - :type "text" - :label "Capital" - :translator (make-instance 'translator-number - :decimal-digits 2 - :thousand-separator #\') - :validator #'(lambda (value) - (let ((component (page-current-component o))) - (validate-required component value) - (validate-number component value :min 1000.01 :max 500099/100))) - :accessor 'form-page-capital)"*")) - (tr> - (td> "Colors") - (td> - (cselect> :id "colors" - :multiple "true" - :style "width:80px;height:120px;" - :accessor 'form-page-colors - (loop for color in (list "R" "G" "B") - collect (option> :value color - (when (find color (form-page-colors o) :test #'string=) - '(:selected "selected")) - (cond - ((string= color "R") "red") - ((string= color "G") "green") - (t "blue"))))))) - (tr> - (td> :colspan "2" - (csubmit> :id "submit" :value "OK"))))) - (p> - (exception-monitor>) - (hr>) - (h2> "From result:") - (div> (format nil "Name: ~a" (user-name (form-page-user o)))) - (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) - (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) - (div> (format nil "Age: ~a" (user-age (form-page-user o))))))) + (cform> :id "testform" :method "post" :action #'form-page-update-user + (table> + (tr> + (td> "Name") + (td> + (cinput> :id "name" + :type "text" + :label "Name" + :validator #'(lambda (value) + (validate-required (page-current-component o) value)) + :accessor 'form-page-name)"*")) + (tr> :id "messaged" + (td> (with-message "SURNAME" "SURNAME")) + (td> + (cinput> :id "surname" + :type "text" + :label "Surname" + :validator #'(lambda (value) + (validate-required (page-current-component o) value) + (validate-size (page-current-component o) value :min-size 1 :max-size 20)) + :accessor 'form-page-surname)"*")) + (tr> + (td> "Gender") + (td> + (cselect> :id "gender" + :accessor 'form-page-gender + (loop for gender in (list "M" "F") + collect (option> :value gender + (when (string= gender (form-page-gender o)) + '(:selected "selected")) + (if (string= gender "M") + "Male" + "Female")))))) + (tr> + (td> "Age") + (td> + (cinput> :id "age" + :type "text" + :label "Age" + :translator (make-instance 'translator-integer :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-integer component value :min 1 :max 2000))) + :accessor 'form-page-age)"*")) + (tr> + (td> "Birthday") + (td> + (cinput> :id "bday" + :type "text" + :label "Birthday" + :translator (make-instance 'translator-date :local-time-format '(:date "-" :month "-" :year)) + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-date-range component value :min (local-time:encode-local-time 0 0 0 0 31 12 1900)))) + :accessor 'form-page-birthday)"(dd-mm-yyyy)")) + (tr> + (td> "Capital") + (td> + (cinput> :id "capital" + :type "text" + :label "Capital" + :translator (make-instance 'translator-number + :decimal-digits 2 + :thousand-separator #\') + :validator #'(lambda (value) + (let ((component (page-current-component o))) + (validate-required component value) + (validate-number component value :min 1000.01 :max 500099/100))) + :accessor 'form-page-capital)"*")) + (tr> + (td> "Colors") + (td> + (cselect> :id "colors" + :multiple "true" + :style "width:80px;height:120px;" + :accessor 'form-page-colors + (loop for color in (list "R" "G" "B") + collect (option> :value color + (when (find color (form-page-colors o) :test #'string=) + '(:selected "selected")) + (cond + ((string= color "R") "red") + ((string= color "G") "green") + (t "blue"))))))) + (tr> + (td> :colspan "2" + (csubmit> :id "submit" :value "OK"))))) + (p> + (exception-monitor>) + (hr>) + (h2> "From result:") + (div> (format nil "Name: ~a" (user-name (form-page-user o)))) + (div> (format nil "Surname: ~a" (user-surname (form-page-user o)))) + (div> (format nil "Gender: ~a" (user-gender (form-page-user o)))) + (div> (format nil "Age: ~a" (user-age (form-page-user o))))))) -(lisplet-register-page-location *test-lisplet* 'form-page "/form.html") +(lisplet-register-page-location *test-lisplet* 'form-page "form.html")

1 0