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

[claw-cvs] r75 - trunk/main/dojo
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 07:06:04 2008 New Revision: 75 Removed: trunk/main/dojo/ Log: CLAW deleted old demo integration

1 0

[claw-cvs] r74 - trunk/main/claw-demo/test/backend
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 07:03:39 2008 New Revision: 74 Added: trunk/main/claw-demo/test/backend/ trunk/main/claw-demo/test/backend/tests.lisp Log: CLAW demo tests Added: trunk/main/claw-demo/test/backend/tests.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/test/backend/tests.lisp Tue Aug 26 07:03:39 2008 @@ -0,0 +1,226 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/setup.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-demo-backend) + +(lift:deftestsuite claw-demo-backend-testsuite () + () + (:setup (let ((*default-database* + (db-connect '("127.0.0.1" "claw-demo-test" "claw-demo" "demo")))) + (drop-claw-demo-tables) + (create-claw-demo-tables))) + (:teardown (db-disconnect))) + +(lift:addtest (claw-demo-backend-testsuite) + simple-insert + (let ((role (make-instance 'role :name "admin" :description "Administration role"))) + (update-db-item role) + (lift:ensure (table-id role)) + (setf role (first (find-vo 'role + :where (sql-operation 'like + (sql-expression-upper :attribute (slot-column-name 'role 'name)) + (string-upcase "admiN"))))) + (lift:ensure role) + (lift:ensure (= (table-version role) 0)) + (setf (role-description role) "Administration") + (update-db-item role) + (setf role (first (find-vo 'role + :where (sql-operation 'like + (sql-expression-upper :attribute (slot-column-name 'role 'name)) + (string-upcase "admiN"))))) + (lift:ensure (> (table-version role) 0)))) + +(lift:addtest (claw-demo-backend-testsuite) + simple-empty-table + (let* ((name "simple-empty-table") + (role (make-instance 'role :name name))) + (update-db-item role) + (lift:ensure (find-vo 'role) :report "Role table is empty") + (delete-class-records 'role) + (let ((rs (find-vo 'role :refresh t))) + (lift:ensure-null rs :report "Role table is NOT empty ~a" :arguments ((length rs)))))) + +(lift:addtest (claw-demo-backend-testsuite) + user-roles-relation + (let ((role1 (make-instance 'role :name "role1")) + (role2 (make-instance 'role :name "role2")) + (user (make-instance 'user :firstname "Jhon" + :surname "Doe" + :username "jd" + :password "pwd" + :email "jd(a)new.com"))) + (delete-class-records 'user-role) + (delete-class-records 'user) + (delete-class-records 'role) + (update-db-item role1) + (update-db-item role2) + (lift:ensure (= (length (find-vo 'role)) 2) :report "Role table size is not 2") + (setf (user-roles user) (list role1 role2)) ;here we add two roles to the user + (update-db-item user) + (multiple-value-bind (records count) + (find-vo 'user) + (lift:ensure (= count 1)) + (lift:ensure (= (length (user-roles (first records))) 2))) + (setf (user-username user) "changed") ;here we ensure that the user doesn't loose roles after a change + (update-db-item user) + (multiple-value-bind (records count) + (find-vo 'user) + (lift:ensure (= count 1)) + (lift:ensure (= (length (user-roles (first records))) 2))))) + +(lift:addtest (claw-demo-backend-testsuite) + user-roles-fk + (let ((role1 (make-instance 'role :name "roleA")) + (role2 (make-instance 'role :name "roleB")) + (user (make-instance 'user :firstname "Jhon" + :surname "Doe" + :username "jd" + :password "pwd" + :email "jd(a)new.com"))) + (delete-class-records 'user) + (delete-class-records 'role) + (update-db-item role1) + (update-db-item role2) + (setf (user-roles user) (list role1 role2)) + (update-db-item user) + (delete-class-records 'role + :where (sql-operation '= + (sql-expression :attribute (slot-column-name 'role 'name)) + "roleA")) + (setf user (reload-db-item user)) + (lift:ensure (= (length (user-roles user)) 1) + :report "Expected 1 role for test user, found ~d" + :arguments ((length (user-roles user)))) + (lift:ensure (= (length (role-users role2)) 1) + :report "Expected 1 user for test role \"roleB\", found ~d" + :arguments ((length (role-users role2)))) + (delete-class-records 'user) + (lift:ensure (null (find-vo 'user)) + :report "Users table is not empty") + (setf role2 (reload-db-item role2)) + (let ((role-users (role-users role2))) + (lift:ensure (null role-users) + :report "Role \"roleB\" still contains references to ~d user\(s)" + :arguments ((length role-users)))))) + +(lift:addtest (claw-demo-backend-testsuite) + cusromer-creation + (let ((customer (make-instance 'customer + :name1 "Andrea" + :name2 "Chiumenti" + :email "a.chiumenti(a)new.com" + :phone1 "+393900001" + :phone2 "+393900002" + :phone3 "+393900003" + :fax "+393900010" + :vat "9999999999" + :code1 "code1" + :code1 "code2" + :code1 "code3" + :code1 "code4" + :addresses (list (make-instance 'customer-address + :address "St. Foo, 1" + :city "Milano" + :zip "20100" + :state "MI" + :country "ITALY") + (make-instance 'customer-address + :address-type 1 + :address "St. Bar, 1" + :zip "20100" + :city "Milano" + :state "MI" + :country "ITALY"))))) + (delete-class-records 'customer) + (update-db-item customer) + (let ((addresses (find-vo 'customer-address + :where (sql-operation '= + (sql-expression :attribute (slot-column-name 'customer-address 'customer-id)) + (table-id customer))))) + (lift:ensure (= (length addresses) + 2) + :report "Expected 2 customer address records, found ~d" + :arguments ((length addresses))) + ;;testing referential integrity + (delete-db-item customer) + (let ((addresses (find-vo 'customer-address))) + (lift:ensure-null addresses + :report "Table cutomer-addresses expected to be empty. Found ~d records." + :arguments ((length addresses))))))) + +(lift:addtest (claw-demo-backend-testsuite) + find-user-by-name + (let ((admin-role (make-instance 'role :name "administrator")) + (user-role (make-instance 'role :name "user"))) + (update-db-item admin-role) + (update-db-item user-role) + (update-db-item (make-instance 'user :firstname "Andrea" + :surname "Chiumenti" + :username "admin" + :password "admin" + :email "admin(a)new.com" + :roles (list admin-role user-role))) + (lift:ensure (find-user-by-name "admin")))) + +(lift:addtest (claw-demo-backend-testsuite) + like-operation + (let ((admin-role (make-instance 'role :name "administrator")) + (user-role (make-instance 'role :name "user"))) + (update-db-item admin-role) + (update-db-item user-role) + (update-db-item (make-instance 'user :firstname "Andrea" + :surname "Chiumenti" + :username "admin\\&1" + :password "admin" + :email "admin(a)new.com" + :roles (list admin-role user-role))) + (lift:ensure (find-vo 'user :where (like-operation 'username "*n\\&1"))) + (lift:ensure-null (find-vo 'user :where (like-operation 'username "*n\\&"))))) + + +(lift:addtest (claw-demo-backend-testsuite) + find-customers + (let ((customer (make-instance 'customer + :name1 "Andrea" + :name2 "Chiumenti" + :email "a.chiumenti(a)new.com" + :phone1 "+393900001" + :phone2 "+393900002" + :phone3 "+393900003" + :fax "+393900010" + :vat "9999999999" + :code1 "code1" + :code1 "code2" + :code1 "code3" + :code1 "code4"))) + (delete-class-records 'customer) + (update-db-item customer) + (lift:ensure (find-customers :name1 "andrea")) + (lift:ensure (find-customers :name1 "andrea" :name2 "ch*")) + (lift:ensure (find-customers))))

1 0

[claw-cvs] r73 - in trunk/main/claw: . src
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 06:59:27 2008 New Revision: 73 Modified: trunk/main/claw/claw.asd trunk/main/claw/src/auth.lisp trunk/main/claw/src/lisplet.lisp trunk/main/claw/src/misc.lisp trunk/main/claw/src/packages.lisp trunk/main/claw/src/server.lisp Log: CLAW application server Modified: trunk/main/claw/claw.asd ============================================================================== --- trunk/main/claw/claw.asd (original) +++ trunk/main/claw/claw.asd Tue Aug 26 06:59:27 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 :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :bordeaux-threads :md5) + :depends-on (:closer-mop :cl-ppcre :cl-fad :alexandria :local-time :split-sequence :bordeaux-threads :md5) :components ((:module src :components ((:file "packages") (:file "mime-type" :depends-on ("packages")) Modified: trunk/main/claw/src/auth.lisp ============================================================================== --- trunk/main/claw/src/auth.lisp (original) +++ trunk/main/claw/src/auth.lisp Tue Aug 26 06:59:27 2008 @@ -57,4 +57,5 @@ (defun login () "Performs user authentication for the reaml where the request has been created" (let* ((login-config (gethash *claw-current-realm* (clawserver-login-config *clawserver*)))) - (configuration-login login-config))) \ No newline at end of file + (when (and login-config (null (current-principal))) + (setf (current-principal) (configuration-login login-config))))) \ No newline at end of file Modified: trunk/main/claw/src/lisplet.lisp ============================================================================== --- trunk/main/claw/src/lisplet.lisp (original) +++ trunk/main/claw/src/lisplet.lisp Tue Aug 26 06:59:27 2008 @@ -125,6 +125,8 @@ (defmethod clawserver-register-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((lisplets (clawserver-lisplets clawserver)) (location (lisplet-base-path lisplet))) + (unless (string= "/" (subseq location 0 1)) + (setf location (concatenate 'string "/" location))) (setf (clawserver-lisplets clawserver) (sort-by-location (pushnew-location (cons location lisplet) @@ -133,6 +135,8 @@ (defmethod clawserver-unregister-lisplet ((clawserver clawserver) (lisplet lisplet)) (let ((lisplets (clawserver-lisplets clawserver)) (location (lisplet-base-path lisplet))) + (unless (string= "/" (subseq location 0 1)) + (setf location (concatenate 'string "/" location))) (remove-by-location location lisplets))) @@ -146,6 +150,8 @@ :basic)) (defmethod lisplet-register-function-location ((lisplet lisplet) function location &key welcome-page-p login-page-p) + (unless (string= "/" (subseq location 0 1)) + (setf location (concatenate 'string "/" location))) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location (cons location function) pages))) @@ -155,6 +161,8 @@ (setf (lisplet-login-page lisplet) location)))) (defmethod lisplet-register-resource-location ((lisplet lisplet) resource-path location &optional content-type) + (unless (string= "/" (subseq location 0 1)) + (setf location (concatenate 'string "/" location))) (let ((pages (lisplet-pages lisplet))) (setf (lisplet-pages lisplet) (sort-by-location (pushnew-location @@ -165,7 +173,7 @@ (uri-to-pathname (subseq (claw-script-name) (+ (length (clawserver-base-path *clawserver*)) (length (lisplet-base-path lisplet)) - (length location) 1))) + (length location) ))) resource-path))) (claw-handle-static-file resource-full-path content-type))) #'(lambda () (claw-handle-static-file resource-path content-type)))) @@ -174,11 +182,14 @@ (defmethod lisplet-dispatch-request ((lisplet lisplet) uri) (let ((dispatchers (lisplet-pages lisplet)) - (rel-script-name (subseq uri (1+ (length (build-lisplet-location lisplet)))))) + (rel-script-name (subseq uri (length (build-lisplet-location lisplet))))) + (setf (claw-return-code) +http-not-found+) (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)))))) + do (when (starts-with-subseq url rel-script-name) + (setf (claw-return-code) +http-ok+) + (return (funcall action)))))) (defmethod lisplet-dispatch-method ((lisplet lisplet)) (let* ((*claw-current-realm* (lisplet-realm lisplet)) @@ -232,18 +243,19 @@ (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 (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 (claw-return-code) +http-forbidden+) - (throw 'handler-done nil)) - ((and (null princp) auth-basicp) - (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 login-page-url) - (throw 'handler-done nil)) - ((and sslport (not (= (claw-server-port) sslport))) - (redirect-to-https) - (throw 'handler-done nil)))))))) + 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 (claw-return-code) +http-forbidden+) + (throw 'handler-done nil)) + ((and (null princp) auth-basicp) + (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 login-page-url) + (throw 'handler-done nil)) + ((and sslport (not (= (claw-server-port) sslport))) + (redirect-to-https) + (throw 'handler-done nil)))))))) Modified: trunk/main/claw/src/misc.lisp ============================================================================== --- trunk/main/claw/src/misc.lisp (original) +++ trunk/main/claw/src/misc.lisp Tue Aug 26 06:59:27 2008 @@ -415,7 +415,7 @@ "Detects if current principal belongs to any of the expressed roles" (let ((principal (current-principal))) (when principal - (loop for el in (principal-roles principal) thereis (member el roles))))) + (loop for el in (principal-roles principal) thereis (member el roles :test #'string-equal))))) (defun current-config () "Returns the current configuration object for the realm of the request" @@ -495,6 +495,8 @@ (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." + (unless (string= "/" (subseq location 0 1)) + (setf location (concatenate 'string "/" location))) (setf *claw-libraries-resources* (sort-by-location (pushnew-location (cons location Modified: trunk/main/claw/src/packages.lisp ============================================================================== --- trunk/main/claw/src/packages.lisp (original) +++ trunk/main/claw/src/packages.lisp Tue Aug 26 06:59:27 2008 @@ -31,8 +31,9 @@ (defpackage :claw - (:use :cl :closer-mop :alexandria :cl-ppcre :cl-fad :local-time :split-sequence :bordeaux-threads :md5) + (:use :cl :closer-mop :alexandria :cl-ppcre :local-time :split-sequence :bordeaux-threads :md5) (:shadow :flatten) + (:import-from :cl-fad :directory-pathname-p) (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") (:export #:*clawserver-base-path* #:*apache-http-port* @@ -135,15 +136,10 @@ #:session-manager #:default-session-manager - - #:error-page - #:error-page-renderer + #:error-renderer #:mime-type #:duplicate-back-slashes - - #:make-page-renderer - #:lisplet #:lisplet-log-manager #:lisplet-server-addrss Modified: trunk/main/claw/src/server.lisp ============================================================================== --- trunk/main/claw/src/server.lisp (original) +++ trunk/main/claw/src/server.lisp Tue Aug 26 06:59:27 2008 @@ -1,4 +1,4 @@ -;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: src/server.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. @@ -30,7 +30,7 @@ (in-package :claw) ;;------------------------------------------------------------------------------------------ -(defgeneric error-page-renderer (clawserver &key error-code) +(defgeneric error-renderer (clawserver &key error-code) (:documentation "Method for rendering http errors. This method should be overridden.")) (defgeneric clawserver-host (clawserver) @@ -41,11 +41,11 @@ (: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. + (: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). + (: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) @@ -61,14 +61,14 @@ 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. + (: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. +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) @@ -80,7 +80,7 @@ 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). + (: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.")) @@ -100,7 +100,7 @@ (: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. + (: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) @@ -145,15 +145,15 @@ 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. + (: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. +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) @@ -296,53 +296,58 @@ (script-name (connector-script-name connector)) (rel-script-name) (rel-script-name-libs) - (http-result)) - (handler-bind ((error (lambda (cond) - (logger-log (clawserver-log-manager clawserver) :error "~a" cond) - (with-output-to-string (*standard-output*) - (error-page-renderer clawserver :error-code +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 lisplet-cons in lisplets - for url = (car lisplet-cons) - for lisplet = (cdr lisplet-cons) - do (when (starts-with-subseq rel-script-name url) (return (funcall #'lisplet-dispatch-method lisplet)))))))))) - (or http-result - (let ((error-handler (and *claw-current-lisplet* - (gethash (or - (let ((return-code (claw-return-code))) - (if (= return-code +http-ok+) - nil - return-code)) - +http-not-found+) - (lisplet-error-handlers *claw-current-lisplet*))))) - (when error-handler - (funcall error-handler))) - (with-output-to-string (*standard-output*) - (error-page-renderer clawserver (or - (let ((return-code (claw-return-code))) - (if (= return-code +http-ok+) - nil - return-code)) - +http-not-found+))))))) + (http-result nil)) + (handler-case + (progn + (unwind-protect + (catch 'handler-done + (progn + (setf (claw-return-code) +http-not-found+) + (if (starts-with-subseq base-path script-name) + (progn + (setf rel-script-name (subseq script-name (length base-path)) + rel-script-name-libs (subseq script-name (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 url rel-script-name-libs) + (setf (claw-return-code) +http-ok+) + (funcall action))) + (loop for lisplet-cons in lisplets + for url = (car lisplet-cons) + for lisplet = (cdr lisplet-cons) + do (when (starts-with-subseq url rel-script-name) + (setf (claw-return-code) +http-ok+) + (return (funcall #'lisplet-dispatch-method lisplet))))))))))) + (or http-result + (and (>= (claw-return-code) 400) + (or + (let ((error-handler (and *claw-current-lisplet* + (gethash (or + (let ((return-code (claw-return-code))) + (if (= return-code +http-ok+) + nil + return-code)) + +http-not-found+) + (lisplet-error-handlers *claw-current-lisplet*))))) + (when error-handler + (funcall error-handler))) + (with-output-to-string (*standard-output*) + (error-renderer clawserver :error-code (or + (let ((return-code (claw-return-code))) + (if (= return-code +http-ok+) + nil + return-code)) + +http-not-found+))))) + )) + (error (cond) + (logger-log (clawserver-log-manager clawserver) :error "~a" cond) + (with-output-to-string (*standard-output*) (error-renderer clawserver :error-code +http-internal-server-error+)))))) (defmethod clawserver-dispatch-method ((clawserver clawserver)) - (let ((result (clawserver-dispatch-request clawserver)) - (connector (clawserver-connector clawserver))) - (if (null result) - #'(lambda () (when (= (connector-return-code connector) 200) ;OK - (setf (connector-return-code connector) 404))) ; Not found - #'(lambda () result)))) + #'(lambda () (clawserver-dispatch-request clawserver))) (defmethod clawserver-start ((clawserver clawserver)) (let ((*clawserver* clawserver) @@ -511,13 +516,63 @@ (defmethod clawserver-script-name ((clawserver clawserver)) (connector-script-name (clawserver-connector clawserver))) -(defmethod error-page-renderer ((clawserver clawserver) &key (error-code 404)) - (format nil "<html> +(defmethod error-renderer ((clawserver clawserver) &key (error-code 404)) + (let ((request-uri (connector-request-uri (clawserver-connector clawserver))) + (connector (clawserver-connector clawserver)) + (style "body { + font-family: arial, elvetica; + font-size: 7pt; +} +span.blue { + padding: 0 3px; + background-color: #525D76; + color: white; + font-weight: bolder; + margin-right: .25em; +} +p.h1, p.h2 { + padding: 0 3px; + background-color: #525D76; + color: white; + font-weight: bolder; + font-size: 2em; + margin: 0; + margin-bottom: .5em; +} +p.h2 {font-size: 1.5em;}")) + (setf (connector-return-code connector) error-code) + (format t "<html> <head> <title>Error ~a</title> + <style>~a</style> </head> <body> -<h1>HTTP Status ~a</h1> -<h2>~a</h2> + <p> + <p class='h1'> + HTTP Status ~a - ~a + </p> + <hr noshade='noshade'> + <p> + <span class='blue'>type</span> + Status report + </p> + <p> + <span class='blue'>url</span> + ~a + </p> + <p> + <span class='blue'>description</span> + ~a + </p> + <hr noshade='noshade'> + <p class='h2'> + CLAW server + </p> + </p> </body> -</html>" error-code error-code (gethash error-code *http-reason-phrase-map*))) \ No newline at end of file +</html>" + error-code ;title + style ;tyle + error-code request-uri + request-uri + (gethash error-code *http-reason-phrase-map*)))) \ No newline at end of file

1 0

[claw-cvs] r72 - in trunk/main/claw-demo: . src src/backend src/frontend src/frontend/docroot src/frontend/docroot/css src/frontend/docroot/img test
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 06:57:00 2008 New Revision: 72 Added: trunk/main/claw-demo/ trunk/main/claw-demo/claw-demo.asd trunk/main/claw-demo/src/ trunk/main/claw-demo/src/backend/ trunk/main/claw-demo/src/backend/dao.lisp trunk/main/claw-demo/src/backend/packages.lisp trunk/main/claw-demo/src/backend/service.lisp trunk/main/claw-demo/src/backend/setup.lisp trunk/main/claw-demo/src/backend/vo.lisp trunk/main/claw-demo/src/frontend/ trunk/main/claw-demo/src/frontend/auth.lisp trunk/main/claw-demo/src/frontend/commons.lisp trunk/main/claw-demo/src/frontend/customers.lisp trunk/main/claw-demo/src/frontend/docroot/ trunk/main/claw-demo/src/frontend/docroot/css/ trunk/main/claw-demo/src/frontend/docroot/css/style.css trunk/main/claw-demo/src/frontend/docroot/img/ trunk/main/claw-demo/src/frontend/docroot/img/bg.png (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/claw.png (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/clawDemo.png (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/clawHead.png (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.gif (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.png (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/img/spinner.gif (contents, props changed) trunk/main/claw-demo/src/frontend/docroot/spinner.gif (contents, props changed) trunk/main/claw-demo/src/frontend/index.lisp trunk/main/claw-demo/src/frontend/login.lisp trunk/main/claw-demo/src/frontend/logout.lisp trunk/main/claw-demo/src/frontend/main.lisp trunk/main/claw-demo/src/frontend/packages.lisp trunk/main/claw-demo/test/ Log: CLAW demo application Added: trunk/main/claw-demo/claw-demo.asd ============================================================================== --- (empty file) +++ trunk/main/claw-demo/claw-demo.asd Tue Aug 26 06:57:00 2008 @@ -0,0 +1,74 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: claw-demo.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-demo-test-backend + :components ((:module "test" + :components ((:module backend + :components ((:file "tests")))))) + :depends-on (:claw-demo-backend :lift)) + +(asdf:defsystem :claw-demo-backend + :name "claw-demo-backend" + :author "Andrea Chiumenti" + :description "Demo application for claw, backend part." + :depends-on (:clsql :clsql-postgresql :local-time :claw :closer-mop :split-sequence) + :components ((:module src + :components ((:module backend + :components ((:file "packages") + (:file "vo" :depends-on ("packages")) + (:file "setup" :depends-on ("packages" "vo")) + (:file "dao" :depends-on ("vo" "setup")) + (:file "service" :depends-on ("dao")))))))) + +(asdf:defsystem :claw-demo-frontend + :name "claw-demo-frontend" + :author "Andrea Chiumenti" + :description "Demo application for claw, frontend part." + :depends-on (:local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend) + :components ((:module src + :components ((:module frontend + :components ((:file "packages") + (:file "auth" :depends-on ("packages")) + (:file "commons" :depends-on ("packages")) + (:file "main" :depends-on ("packages" "auth")) + (:file "index" :depends-on ("commons" "main")) + (:file "logout" :depends-on ("commons" "main")) + (:file "login" :depends-on ("commons" "main")) + (:file "customers" :depends-on ("commons" "main")))))))) + + +(asdf:defsystem :claw-demo + :name "claw-demo" + :author "Andrea Chiumenti" + :description "Demo application for claw." + :in-order-to ((test-op (load-op :claw-demo-test-backend))) + :perform (test-op :after (op c) + (describe (funcall (find-symbol "RUN-TESTS" "LIFT") + :suite (find-symbol "CLAW-DEMO-BACKEND-TESTSUITE" "CLAW-DEMO-BACKEND")))) + :depends-on (:clsql :clsql-postgresql :local-time :claw :closer-mop :claw-demo-backend :claw-demo-frontend)) Added: trunk/main/claw-demo/src/backend/dao.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/backend/dao.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,166 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/dao.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-demo-backend) + +(defgeneric check-instance-version (base-table &key database) + (:documentation "Versioning support for base-table instances")) + +(defgeneric sign-table-update (base-table) + (:documentation "Set insert/modify user and date to the given record")) + + +(defgeneric local-time-to-timestamp (local-time)) + +(defmethod local-time-to-timestamp ((local-time local-time)) + (with-decoded-local-time (:sec sec :minute minute :hour hour :day day :month month :year year) + local-time + (make-time + :year year :month month :day day :hour hour :minute minute :second sec))) + +(defmethod sign-table-update ((base-table base-table)) + (let ((user-name (or (and *clawserver* + (current-principal) + (principal-name (current-principal))) + "anonymous")) + (now-timestamp (local-time-to-timestamp (now)))) + (when (null (table-insert-user base-table)) + (setf (table-insert-user base-table) user-name + (table-insert-date base-table) now-timestamp)) + (setf (table-update-user base-table) user-name + (table-update-date base-table) now-timestamp))) + + +(defun slot-column-name (symbol-class slot-name) + (let ((slot (loop for slot in (closer-mop:class-slots (find-class symbol-class)) + when (and (typep slot 'clsql-sys::view-class-effective-slot-definition) + (equal (closer-mop:slot-definition-name slot) slot-name)) + return slot))) + (when slot + (slot-value slot 'clsql-sys::column)))) + +(defun sql-expression-upper (&key string table alias attribute type) + (sql-operation 'upper (sql-expression :string string :table table :alias alias :attribute attribute :type type))) + +#.(locally-enable-sql-reader-syntax) + +(defmethod check-instance-version ((instance base-table) &key (database *default-database*)) + (let* ((instance-version (table-version instance)) + (table (view-table (class-of instance))) + (instance-id (table-id instance)) + (version (first (select [version] + :from table + :where [= [id] instance-id] + :flatp t + :refresh t + :database database)))) + (when (and version (not (= version instance-version))) + (error "Wrong version number (given ~d , expected ~d) for record id ~d on table ~a" + instance-version + version + instance-id + table)))) + +(defmethod delete-instance-records :before ((instance base-table)) + (check-instance-version instance :database (clsql-sys::view-database instance))) + + + +(defmethod update-records-from-instance :before ((instance base-table) &key (database *default-database*)) + (check-instance-version instance :database database) + (sign-table-update instance) + (if (and (slot-boundp instance 'id) (not (null (table-id instance)))) + (incf (table-version instance)) + (unless (typep instance 'base-table-121) + (let ((sequence-name (format nil + "~a_id_seq" + (string-downcase (symbol-name (view-table (class-of instance))))))) + (setf (table-id instance) (sequence-next sequence-name :database database)))))) + +(defmethod update-record-from-slot :before ((instance base-table) slot &key (database *default-database*)) + (declare (ignore slot database)) + (check-instance-version instance)) + + +(defmethod update-records-from-instance :before ((instance user) &key (database *default-database*)) + (let ((id (table-id instance))) + (when id + (delete-records :from [users-roles] :where [= [user-id] id])))) + +(defmethod update-records-from-instance :after ((instance user) &key (database *default-database*)) + (let ((id (table-id instance))) + (dolist (role (user-roles instance)) + (update-records-from-instance (make-instance 'user-role :user-id id :role-id (table-id role)))))) + + +(defmethod update-records-from-instance :before ((instance customer) &key (database *default-database*)) + (let ((id (table-id instance))) + (when id + (delete-records :from [customer-addresses] :where [= [customer-id] id])))) + +(defmethod update-records-from-instance :after ((instance customer) &key (database *default-database*)) + (let ((id (table-id instance))) + (dolist (address (customer-addresses instance)) + (setf (customer-address-customer-id address) id) + (update-records-from-instance address)))) + +(defmethod delete-instance-records :before ((instance user)) + (let ((id (table-id instance))) + (when id + (delete-records :from [users-roles] :where [= [user-id] id])))) + + +(defmethod delete-instance-records :before ((instance customer)) + (let ((id (table-id instance))) + (when id + (delete-records :from [customer-addresses] :where [= [customer-id] id])))) + +(defmethod delete-instance-records :before ((instance role)) + (let ((id (table-id instance))) + (when id + (delete-records :from [users-roles] :where [= [role-id] id])))) + +(defun like-operation (name value &key (insensitive t) (wild-char #\*)) + (setf value (format nil "~{~A~^\\\\~}" (split-sequence #\\ value))) + (unless (eql wild-char #\%) + (setf value (format nil "~{~A~^\\%~}" (split-sequence #\% value)))) + (let ((v (if (eql wild-char #\%) + value + (substitute #\% wild-char value))) + (result)) + (setf result (sql-operation 'LIKE + (if insensitive + (sql-operation 'UPPER name) + name) + (if insensitive + (sql-operation 'UPPER v) + v))) + result)) + +#.(locally-disable-sql-reader-syntax) \ No newline at end of file Added: trunk/main/claw-demo/src/backend/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/backend/packages.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,102 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/package.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-demo-backend + (:use :cl :clsql :clsql-postgresql :local-time :claw :closer-mop :split-sequence) + (:shadowing-import-from :local-time + :timezone + :decode-duration + :format-duration + :parse-datestring + :universal-time + :parse-timestring) + (:documentation "A demo application for CLAW") + (:export #:demo-setup + #:db-connect + #:db-disconnect + ;; --- Value objects --- ;; + #:base-table + #:table-id + #:table-version + #:table-update-user + #:table-insert-user + #:table-update-date + #:table-insert-date + #:user + #:user-firstname + #:user-surname + #:user-username + #:user-email + #:user-password + #:user-active + #:user-roles + #:role + #:role-name + #:role-description + #:role-users + #:city + #:city-name + #:city-zip + #:city-iso-state + #:city-iso-country + #:city-alt-code + #:customer + #:customer-name1 + #:customer-name2 + #:customer-email + #:customer-phone1 + #:customer-phone2 + #:customer-phone3 + #:customer-fax + #:customer-addresses + #:customer-vat + #:customer-vat + #:customer-code1 + #:customer-code2 + #:customer-code3 + #:customer-code4 + #:customer-address + #:customer-address-name1 + #:customer-address-name2 + #:customer-address-address-type + #:customer-address-address + #:customer-address-city + #:customer-address-zip + #:customer-address-state + #:customer-address-country + ;; --- Business methods --- ;; + #:update-db-item + #:delete-db-item + #:reload-db-item + #:delete-class-records + #:find-user-by-name + #:find-customers)) \ No newline at end of file Added: trunk/main/claw-demo/src/backend/service.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/backend/service.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,121 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/service.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-demo-backend) + +(defvar *select-limit* 1000000) + +(defgeneric update-db-item (base-table) + (:documentation "Updates or inserts an item in a transaction aware context")) + +(defgeneric delete-db-item (base-table) + (:documentation "Deletes an item in a transaction aware context")) + +(defgeneric reload-db-item (base-table) + (:documentation "Reloads an item.")) + +#.(locally-enable-sql-reader-syntax) + +(defmethod update-db-item ((item base-table)) + (with-transaction (:database *claw-demo-db*) + (update-records-from-instance item))) + +(defmethod delete-db-item ((item base-table)) + (with-transaction (:database *claw-demo-db*) + (delete-instance-records item))) + +(defun delete-class-records (symbol-class &key where) + (with-transaction (:database *claw-demo-db*) + (let ((table-name (symbol-name (view-table (find-class symbol-class))))) + (delete-records :from table-name :where where)))) + +(defun find-vo (symbol-class &key (offset 0) (limit *select-limit*) (refresh t) where group-by having order-by) + "Returns a pair of values where the first is the select result, and the second is the total record amount without considering offset and limit keys." + (values + (select symbol-class + :where where + :group-by group-by + :having having + :order-by order-by + :flatp t + :refresh refresh + :offset offset + :limit limit) + (count-vo symbol-class :refresh refresh :where where :group-by group-by :having having))) + +(defun count-vo (symbol-class &key (refresh t) where group-by having) + "Returns the number of records matching the given criteria" + (first (select [count [*]] + :from (view-table (find-class symbol-class)) + :where where + :group-by group-by + :having having + :flatp t + :refresh refresh))) + +(defmethod reload-db-item ((item base-table)) + "Reloads item data selecting the item by its id. This function isn't destructive" + (let ((symbol-class (class-name (class-of item))) + (id (table-id item))) + (first (select symbol-class + :where [= [slot-value symbol-class 'id] id] + :flatp t + :refresh t)))) + +(defun find-user-by-name (name) + (let ((where (sql-operation '= (slot-column-name 'user 'username) name))) + (first (select 'user + :where where + :flatp t + :refresh t)))) + +(defun find-customers (&key (offset 0) (limit *select-limit*) name1 name2 email vat phone sorting) + (let ((where (remove-if #'null (list + (when name1 + (like-operation (slot-column-name 'customer 'name1) + name1)) + (when name2 + (like-operation (slot-column-name 'customer 'name2) + name2)) + (when email + (like-operation (slot-column-name 'customer 'email) + email)) + (when vat + (sql-operation '= (slot-column-name 'customer 'vat) + vat)) + (when phone + (sql-operation '= (slot-column-name 'customer 'phone1) + phone)))))) + (find-vo 'customer :offset offset + :limit limit + :where (if (> (length where) 1) + (apply #'sql-operation (cons 'and where)) + (first where))))) + +#.(locally-disable-sql-reader-syntax) \ No newline at end of file Added: trunk/main/claw-demo/src/backend/setup.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/backend/setup.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,106 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/setup.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-demo-backend) + +(defvar *claw-demo-db* nil + "The demo datebase") + +(defun db-connect (&optional (connection-string '("127.0.0.1" "claw-demo" "claw-demo" "demo"))) + (setf *claw-demo-db* (connect connection-string :database-type :postgresql :pool t))) + +(defun db-disconnect () + (disconnect :database *claw-demo-db*)) + + +(defun create-claw-demo-tables () + (let ((*default-database* *claw-demo-db*)) + (create-view-from-class 'user-role) + (create-view-from-class 'user) + (create-view-from-class 'role) + (let ((user-role-table (symbol-name (view-table (find-class 'user-role))))) + (execute-command (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a_fk1 FOREIGN KEY (~a) REFERENCES ~a (id) ON DELETE CASCADE" + user-role-table + user-role-table + (slot-column-name 'user-role 'user-id) + (symbol-name (view-table (find-class 'user))))) + (execute-command (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a_fk2 FOREIGN KEY (~a) REFERENCES ~a (id) ON DELETE CASCADE" + user-role-table + user-role-table + (slot-column-name 'user-role 'role-id) + (symbol-name (view-table (find-class 'role)))))) + (create-view-from-class 'city) + (create-view-from-class 'customer) + (create-view-from-class 'customer-address) + (let ((customer-address-table (symbol-name (view-table (find-class 'customer-address))))) + (execute-command (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a_fk1 FOREIGN KEY (~a) REFERENCES ~a (id) ON DELETE CASCADE" + customer-address-table + customer-address-table + (slot-column-name 'customer-address 'customer-id) + (symbol-name (view-table (find-class 'customer)))))))) + +(defun drop-claw-demo-tables () + (let ((*default-database* *claw-demo-db*) + (user-role-table (symbol-name (view-table (find-class 'user-role)))) + (customer-address-table (symbol-name (view-table (find-class 'customer-address))))) + (dolist (table (list-tables)) + (execute-command (format nil "DROP TABLE ~a CASCADE" table))) + (dolist (sequence (list-sequences)) + (execute-command (format nil "DROP SEQUENCE ~a" sequence))))) + +(defun demo-setup () + (db-connect) + (drop-claw-demo-tables) + (create-claw-demo-tables) + (with-transaction () + (let ((admin-role (make-instance 'role :name "administrator")) + (user-role (make-instance 'role :name "user"))) + (update-db-item admin-role) + (update-db-item user-role) + (update-db-item (make-instance 'user :firstname "Andrea" + :surname "Chiumenti" + :username "admin" + :password "admin" + :email "admin(a)new.com" + :roles (list admin-role user-role))) + (loop for i from 1 to 400 + do (update-db-item (make-instance 'customer + :name1 (format nil "Andrea~a" i) + :name2 (format nil "Chiumenti~a" i) + :email (format nil "a~a.chiumenti(a)new.com" i) + :phone1 "+393900001" + :phone2 "+393900002" + :phone3 "+393900003" + :fax "+393900010" + :vat (format nil "9999999999-~a" i) + :code1 (format nil "code1-~a" i) + :code1 (format nil "code2-~a" i) + :code1 (format nil "code3-~a" i) + :code1 (format nil "code4-~a" i)))))) + (db-disconnect)) \ No newline at end of file Added: trunk/main/claw-demo/src/backend/vo.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/backend/vo.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,267 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/vo.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-demo-backend) + +(def-view-class base-table () + ((id :db-kind :key + :accessor table-id + :initarg :id + :type integer + :db-type "serial" + :db-constraints :not-null) + (version :accessor table-version + :initarg :version + :type integer + :db-constraints :not-null) + (update-user :accessor table-update-user + :initarg :update-user + :type (varchar 80)) + (insert-user :accessor table-insert-user + :initarg :insert-user + :type (varchar 80)) + (update-date :accessor table-update-date + :initarg :update-date + :type wall-time) + (insert-date :accessor table-insert-date + :initarg :insert-date + :type wall-time)) + (:default-initargs :id nil + :version 0 + :update-user nil + :insert-user nil + :update-date nil + :insert-date nil)) + +(def-view-class base-table-121 (base-table) + ((id :db-kind :key + :accessor table-id + :initarg :id + :type integer + :db-constraints :not-null))) + +(def-view-class user-role () + ((user-id :db-kind :key + :initarg :user-id + :accessor user-role-user-id + :type integer + :db-constraints :not-null) + (role-id :db-kind :key + :initarg :role-id + :accessor user-role-role-id + :type integer + :db-constraints :not-null) + (users :db-kind :join + :accessor user-role-users + :db-info (:join-class user + :home-key user-id + :foreign-key id + :retrieval :immediate + :set t)) + (roles :db-kind :join + :accessor user-role-roles + :db-info (:join-class role + :home-key role-id + :foreign-key id + :retrieval :immediate + :set t))) + (:base-table users-roles)) + +(def-view-class user (base-table) + ((firstname :initarg :firstname + :accessor user-firstname + :type (varchar 80) + :db-constraints :not-null) + (surname :initarg :surname + :accessor user-surname + :type (varchar 80) + :db-constraints :not-null) + (username :initarg :username + :accessor user-username + :type (varchar 80) + :db-constraints :not-null) + (email :initarg :email + :accessor user-email + :type (varchar 200) + :db-constraints :not-null) + (password :initarg :password + :accessor user-password + :type (varchar 100) + :db-constraints :not-null) + (active :initarg :active + :accessor user-active + :type boolean + :db-constraints :not-null) + (roles :db-kind :join + :initarg :roles + :accessor user-roles + :db-info (:join-class user-role + :home-key id + :foreign-key user-id + :target-slot roles + :set t))) + (:default-initargs :active t) + (:base-table users)) + +(def-view-class role (base-table) + ((name :initarg :name + :accessor role-name + :type (varchar 20) + :db-constraints :not-null) + (description :initarg :description + :accessor role-description + :type (varchar 200)) + (users :db-kind :join + :accessor role-users + :db-info (:join-class user-role + :home-key id + :foreign-key role-id + :target-slot users + :set t))) + (:default-initargs :description "") + (:base-table roles)) + + +(def-view-class city (base-table) + ((city-name :initarg :name + :accessor city-name + :type (varchar 120) + :db-constraints :not-null) + (zip :initarg :zip + :accessor city-zip + :type (string 5) + :db-constraints :not-null) + (iso-state :initarg :iso-state + :accessor city-iso-state + :type (string 5)) ;ISO_3166-2 + (iso-country :initarg :isocountry + :accessor city-iso-country + :type (string 3)) ;ISO_3166-1 Alpha-3 + (alt-code :initarg :alt-code + :accessor city-alt-code + :type (varchar 50))) + (:default-initargs :iso-state nil :iso-country nil + :alt-code nil) + (:base-table cities)) + + +(def-view-class customer (base-table) + ((name1 :initarg :name1 + :accessor customer-name1 + :type (varchar 150) + :db-constraints :not-null) + (name2 :initarg :name2 + :accessor customer-name2 + :type (varchar 80)) + (email :initarg :email + :accessor customer-email + :type (varchar 200)) + (phone1 :initarg :phone1 + :accessor customer-phone1 + :type (varchar 25)) + (phone2 :initarg :phone2 + :accessor customer-phone2 + :type (varchar 25)) + (phone3 :initarg :phone3 + :accessor customer-phone3 + :type (varchar 25)) + (fax :initarg :fax + :accessor customer-fax + :type (varchar 25)) + (addresses :db-kind :join + :initarg :addresses + :accessor customer-addresses + :db-info (:join-class customer-address + :home-key id + :foreign-key customer-id + :retrieval :deferred + :set t)) + (vat :initarg :vat + :accessor customer-vat + :type (varchar 50) + :db-constraints :unique) + (code1 :initarg :code1 + :accessor customer-code1 + :type (varchar 50) + :db-constraints :unique) + (code2 :initarg :code2 + :accessor customer-code2 + :type (varchar 50) + :db-constraints :unique) + (code3 :initarg :code3 + :type (varchar 50) + :accessor customer-code3 + :db-constraints :unique) + (code4 :initarg :code4 + :accessor customer-code4 + :type (varchar 50) + :db-constraints :unique)) + (:default-initargs :name2 nil :email nil + :phone1 nil :phone2 nil :phone3 nil + :fax nil + :vat nil :code1 nil :code2 nil :code3 nil :code4 nil) + (:base-table customers)) + +(def-view-class customer-address (base-table) + ((address-type :initarg :address-type + :accessor customer-address-type + :type integer + :db-constraints :not-null) + (address :initarg :address + :accessor customer-address-address + :type (varchar 200) + :db-constraints :not-null) + (city :initarg :city + :accessor customer-address-city + :type (varchar 120) + :db-constraints :not-null) + (zip :initarg :zip + :accessor customer-address-zip + :type (string 5) + :db-constraints :not-null) + (state :initarg :state + :accessor customer-address-state + :type (varchar 120) + :db-constraints :not-null) + (country :initarg :country + :accessor customer-address-country + :type (varchar 80) + :db-constraints :not-null) + (customer-id :initarg :customer-id + :accessor customer-address-customer-id + :type integer + :db-constraints :not-null) + (customer :initarg :customer + :db-info (:join-class customer + :home-key customer-id + :foreign-key id + :retrieval :immediate + :set nil))) + (:default-initargs :address-type 0) + (:base-table customer-addresses)) Added: trunk/main/claw-demo/src/frontend/auth.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/auth.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,63 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/auth.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-demo-frontend) + +(defclass demo-principal (principal) + ((firstname :initarg :firstname + :accessor demo-principal-firstname) + (surname :initarg :surname + :accessor demo-principal-surname)) + (:default-initargs :firstname "" :surname "")) + +(defclass demo-configuration (configuration) + () + (:documentation "Authorization configuration for application +atuhentication and authorization management.")) + +(defmethod configuration-login ((configuration configuration)) + (multiple-value-bind (user password) + (if (eq (lisplet-authentication-type *claw-current-lisplet*) :basic) + (claw-authorization) + (values (claw-parameter "username") + (claw-parameter "password"))) + (unwind-protect + (progn + (log-message :info "ppppppppppppppp") + (db-connect) + (let ((user-vo (find-user-by-name user))) + (when (and user-vo (string= password (user-password user-vo))) + (log-message :info "----> ~a " (user-roles user-vo)) + (make-instance 'demo-principal + :name (user-username user-vo) + :firstname (user-firstname user-vo) + :surname (user-surname user-vo) + :roles (loop for role-vo in (user-roles user-vo) + collect (role-name (first role-vo))))))) + (db-disconnect)))) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/commons.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/commons.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,223 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/commons.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-demo-frontend) + + + + +(defclass site-template (wcomponent) + ((title :initarg :title + :reader site-template-title) + (djconfig :initarg :djconfig + :reader site-template-djconfig)) + (:metaclass metacomponent) + (:default-initargs :djconfig nil)) + +(defclass redirect (wcomponent) + ((href :initarg :href + :reader redirect-href)) + (:metaclass metacomponent)) + +(defmethod htcomponent-instance-initscript ((redirect redirect)) + (ps:ps* `(location.replace ,(redirect-href redirect)))) + +(defmethod wcomponent-template ((redirect redirect)) + ($> "")) + +(defun current-site-template () + (claw-aux-request-value 'site-template)) + +(defmethod wcomponent-template ((site-template site-template)) + (let ((principal (current-principal))) + (html> + (head> + (title> (site-template-title site-template)) + (link> :href (format nil "~a/docroot/css/style.css" (build-lisplet-location *claw-current-lisplet*)) + :rel "stylesheet" + :type "text/css")) + (djbody> :is-debug "false" + :theme "soria" + :class "demo" + :djconfig (site-template-djconfig site-template) + (wcomponent-informal-parameters site-template) + (div> :class "topheader" + (div> :class "logoDemo") + (div> :class "logoClaw")) + (djtoolbar> :id "menuBar" :class "menuBar" + (djdrop-down-button> (span> "File") + (djmenu> + (djmenu-item> :id "loginMenu" + :render-condition #'(lambda () (null principal)) + :on-click (ps:ps* `(location.replace ,(format nil "~a/login.html" (build-lisplet-location *claw-current-lisplet*)))) + "Login") + (djmenu-item> :id "logoutMenu" + :render-condition #'(lambda () principal) + :on-click (ps:ps* `(location.replace ,(format nil "~a/logout.html" (build-lisplet-location *claw-current-lisplet*)))) + "Logout"))) + (djdrop-down-button> :render-condition #'(lambda () principal) + (span> "Anagraphics") + (djmenu> + (djmenu-item> :id "customersMenu" + :on-click (ps:ps* `(location.replace ,(format nil "~a/customers.html" (build-lisplet-location *claw-current-lisplet*)))) + "Customers") + (djmenu-item> :id "usersMenu" + :render-condition #'(lambda () (user-in-role-p '("admin"))) + "Users")))) + (div> :class "contentBody" + (htcomponent-body site-template)))))) + +(defclass db-page (page) + ()) + +(defmethod page-render :around ((db-page db-page)) + (let ((result)) + (unwind-protect (progn + (db-connect) + (setf result (call-next-method))) + (db-disconnect)) + result)) + + + +(defgeneric pager-count-pages (pager)) + +(defgeneric pager-current-page (pager)) + +(defgeneric pager-page-list (pager)) + +(defgeneric set-offset-value (pager page)) + +(defclass pager (wcomponent) + ((update-component-id :initarg :update-component-id + :accessor pager-update-component-id) + (class :initarg :class + :reader pager-class) + (page-size :initarg :page-size + :reader pager-page-size) + (visible-pages :initarg :visible-pages + :accessor pager-visible-pages) + (total-items :initarg :total-items + :accessor pager-total-items) + (first-item-offset :initarg :first-item-offset + :accessor pager-first-item-offset)) + (:metaclass metacomponent) + (:default-initargs :page-size 10 :visible-pages 10 :class "pager")) + +(defmethod wcomponent-template ((pager pager)) + (let ((total-items (pager-total-items pager)) + (page-size (pager-page-size pager)) + (page-list (pager-page-list pager)) + (current-page (pager-current-page pager)) + (count-pages (pager-count-pages pager)) + (id (htcomponent-client-id pager))) + (when (> total-items page-size) + (div> + :static-id id + :class (pager-class pager) + (wcomponent-informal-parameters pager) + + (when (> current-page 1) + (list (div> :class "button first" + (span> :on-click (set-offset-value pager 1) "first")) + (div> :class "button previous" + (span> :on-click (set-offset-value pager (1- current-page)) "previous")))) + (loop for page in page-list + collect (if (= page current-page) + (div> :class "current page" + (span> (format nil "~a" page))) + (div> :class "page" (span> :on-click (set-offset-value pager page) (format nil "~a" page))))) + (when (< current-page count-pages) + (list (div> :class "button next" + (span> :on-click (set-offset-value pager (1+ current-page)) "next")) + (div> :class "button last" + (span> :on-click (set-offset-value pager count-pages) "last")))))))) + +(defmethod htcomponent-class-initscripts ((pager pager)) + (let ((update-component-id (pager-update-component-id pager)) + (page-size (pager-page-size pager))) + (list + (ps:ps* `(defun pager-go-to (page) + (setf (slot-value (dojo.by-id ,update-component-id) 'value) (* (1- page) ,page-size)) + (defvar form-id (slot-value (slot-value (dojo.by-id ,update-component-id) 'form) 'id)) + (let ((form-el (or (dijit.by-id form-id) + (dojo.by-id form-id)))) + (.submit form-el))))))) + +(defmethod set-offset-value ((pager pager) page) + (ps:ps* `(pager-go-to ,page))) + +(defmethod pager-count-pages ((pager pager)) + (let ((page-size (pager-page-size pager)) + (total-items (pager-total-items pager))) + (count-pages page-size total-items))) + +(defun count-pages (page-size total-items) + (multiple-value-bind (pages rest) + (truncate total-items page-size) + (when (> rest 0) (incf pages)) + pages)) + +(defmethod pager-current-page ((pager pager)) + (let ((page-size (pager-page-size pager)) + (first-item-offset (pager-first-item-offset pager))) + (multiple-value-bind (page rest) + (truncate (1+ first-item-offset) page-size) + (when (> rest 0) (incf page)) + page))) + +(defmethod pager-page-list ((pager pager)) + (let ((current-page (pager-current-page pager)) + (count-pages (pager-count-pages pager)) + (visible-pages (pager-visible-pages pager)) + (pages-before-current-page) + (pages-after-current-page) + (result)) + (when (> current-page 1) + (setf pages-before-current-page + (reverse + (loop for page from (1- current-page) downto (max 1 (- current-page + (truncate visible-pages 2))) + collect page)))) + (when (< current-page count-pages) + (setf pages-after-current-page + (loop for page from (1+ current-page) to (min count-pages (+ (1- current-page) + (- visible-pages (length pages-before-current-page)))) + collect page))) + (setf result (append pages-before-current-page (list current-page) pages-after-current-page)) + (let ((result-length (length result)) + (first-result-page (first result))) + (if (< result-length visible-pages) + (append (reverse (loop for page from (1- first-result-page) downto (max 1 (- first-result-page (- visible-pages result-length))) + collect page)) result) + result)))) + +(defun null-when-empty (string) + (unless (string= string "") + string)) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/customers.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/customers.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,237 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/customers.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-demo-frontend) + +(defgeneric edit-customer-save (edit-customer)) + +(defclass edit-customer (wcomponent) + ((customer :initarg :customer + :accessor edit-customer-customer) + (on-before-submit :initarg :on-before-submit + :accessor on-before-submit) + (on-xhr-finish :initarg :on-xhr-finish + :accessor on-xhr-finish)) + (:metaclass metacomponent) + (:default-initargs :on-before-submit nil :on-xhr-finish nil :customer (make-instance 'customer))) + +(defmethod wcomponent-template ((obj edit-customer)) + (let ((id (htcomponent-client-id obj)) + (visit-object (edit-customer-customer obj))) + (djform> :static-id id + :class "customerForm" + :update-id id + :action 'edit-customer-save + :action-object obj + :on-before-submit (on-before-submit obj) + :on-xhr-finish (on-xhr-finish obj) + (cinput> :type "hidden" :visit-object visit-object + :accessor 'table-id) + (div> :class "label name1" + (span> "Name 1") + (djvalidation-text-box> :visit-object visit-object + :required "true" + :label "Name 1" + :accessor 'customer-name1)) + (div> :class "label name2" + (span> "Name 2") + (djvalidation-text-box> :visit-object visit-object + :label "Name 2" + :accessor 'customer-name2)) + (div> :class "label email" + (span> "Email") + (djvalidation-text-box> :visit-object visit-object + :label "Email" + :accessor 'customer-email)) + (div> :class "label pone1" + (span> "Phone 1") + (djvalidation-text-box> :visit-object visit-object + :label "Phone 1" + :accessor 'customer-phone1)) + (div> :class "label pone2" + (span> "Phone 2") + (djvalidation-text-box> :visit-object visit-object + :label "Phone 2" + :accessor 'customer-phone2)) + (div> :class "label pone3" + (span> "Phone 3") + (djvalidation-text-box> :visit-object visit-object + :label "Phone 3" + :accessor 'customer-phone3)) + (div> :class "label fax" + (span> "Fax") + (djvalidation-text-box> :visit-object visit-object + :label "Fax" + :accessor 'customer-fax)) + (div> :class "label vat" + (span> "VAT") + (djvalidation-text-box> :visit-object visit-object + :label "VAT" + :accessor 'customer-vat)) + (div> :class "label code1" + (span> "Code 1") + (djvalidation-text-box> :visit-object visit-object + :label "Code 1" + :accessor 'customer-code1)) + (div> :class "label code2" + (span> "Code 2") + (djvalidation-text-box> :visit-object visit-object + :label "Code 2" + :accessor 'customer-code2)) + (div> :class "label code3" + (span> "Code 3") + (djvalidation-text-box> :visit-object visit-object + :label "Code 3" + :accessor 'customer-code3)) + (div> :class "label code4" + (span> "Code 4") + (djvalidation-text-box> :visit-object visit-object + :label "Code 4" + :accessor 'customer-code4)) + (div> :class "buttons" + (djsubmit-button> :value "Save"))))) + +(defmethod edit-customer-save ((obj edit-customer)) + (let ((id (htcomponent-client-id obj))) + (handler-case + (update-db-item (edit-customer-customer obj)) + (error (cond) + (add-validation-error id cond))))) + +(defgeneric customers-page-find-users (customers-page)) + +(defgeneric customers-page-offset-reset (customers-page)) + +(defclass customers-page (db-page) + ((customers :initform nil + :accessor customers-page-customers) + (customers-total-count :initform 0 + :accessor customers-page-customers-total-count) + (list-size :initarg :list-size + :accessor customers-page-list-size) + (offset :initform 0 + :accessor customers-page-offset) + (name1 :initform "" + :accessor customers-page-name1) + (name2 :initform "" + :accessor customers-page-name2) + (email :initform "" + :accessor customers-page-email) + (vat :initform "" + :accessor customers-page-vat) + (phone :initform "" + :accessor customers-page-phone)) + (:default-initargs :list-size 20)) + +(defmethod customers-page-offset-reset ((page customers-page)) 0) + +(defmethod page-content ((page customers-page)) + (let ((spinner-id (generate-id "spinner")) + (form-id (generate-id "customersForm")) + (customers (customers-page-customers page)) + (offset-id (generate-id "offset"))) + (site-template> :title "CLAW Demo anagraphics" + (djfloating-content> :static-id spinner-id + (img> :alt "spinner" + :src "docroot/img/spinner.gif")) + (djform> :static-id form-id + :action 'customers-page-find-users + :update-id form-id + :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) + (div> (div> :class "searchParameters hlist" + (div> :class "item" (span> :class "name1" "Name") + (djtext-box> :label "name" :id "name1" :accessor 'customers-page-name1) + (djtext-box> :label "name" :id "name2" :accessor 'customers-page-name2)) + (div> :class "item" (span> :class "email" "Email") + (djtext-box> :label "email" :id "email" :accessor 'customers-page-email)) + (div> :class "item" (span> :class "vat" "VAT") + (djtext-box> :label "vat" :id "vat" :accessor 'customers-page-vat)) + (div> :class "item" (span> :class "phone" "phone") + (djtext-box> :label "phone" :id "phone" :accessor 'customers-page-phone))) + (cinput> :type "hidden" + :static-id offset-id + :translator *integer-translator* + :reader 'customers-page-offset-reset + :writer (attribute-value '(setf customers-page-offset))) + (djsubmit-button> :id "search" + :value "Search")) + (table> :class "listTable" + (tr> :class "header" + (th> :class "name" "Name") + (th> :class "email" "Email") + (th> :class "vat" "VAT") + (th> :class "phone" "Phone")) + (loop for customer in customers + for index = 0 then (incf index) + collect (tr> :class (if (evenp index) "item even" "item odd") + (td> (customer-name1 customer) + " " + (customer-name2 customer)) + (td> (customer-email customer)) + (td> (customer-vat customer)) + (td> (customer-phone1 customer))))) + (pager> :id "pager" + :update-component-id offset-id + :page-size (customers-page-list-size page) + :total-items (customers-page-customers-total-count page) + :first-item-offset (customers-page-offset page)))))) + +(defmethod customers-page-find-users ((page customers-page)) + (let ((name1 (customers-page-name1 page)) + (name2 (customers-page-name2 page)) + (email (customers-page-email page)) + (vat (customers-page-vat page)) + (phone (customers-page-phone page))) + (multiple-value-bind (customers total-size) + (find-customers :offset (customers-page-offset page) + :limit (customers-page-list-size page) + :name1 (null-when-empty name1) + :name2 (null-when-empty name2) + :email (null-when-empty email) + :vat (null-when-empty vat) + :phone (null-when-empty phone)) + (setf (customers-page-customers page) customers + (customers-page-customers-total-count page) total-size)))) + +(defmethod page-before-render ((page customers-page)) + (unless (page-req-parameter page *rewind-parameter*) + (multiple-value-bind (customers total-size) + (find-customers :offset 0 + :limit (customers-page-list-size page)) + (setf (customers-page-customers page) customers + (customers-page-customers-total-count page) total-size)))) + + +(lisplet-register-function-location *dojo-demo-lisplet* + (make-page-renderer 'customers-page #'claw-post-parameters #'claw-get-parameters) + "customers.html") + +(lisplet-protect *dojo-demo-lisplet* "customers.html" '("administrator" "user")) + Added: trunk/main/claw-demo/src/frontend/docroot/css/style.css ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/docroot/css/style.css Tue Aug 26 06:57:00 2008 @@ -0,0 +1,120 @@ +body.demo { + width: 1000px; + margin: 0 auto; + padding: 0 100px; + background: #14335C url('../img/bg.png') repeat-x scroll 0 0; + font-family: arial; +} + +.contentBody { + margin-top: 0; + background: white; + min-height: 450px; + padding: 10px; +} + +.contentBody ul { + margin: 0; +} + +p.header { + background: #9CBBE5; + padding: .5em; + margin-top:0; +} + +.unclosable .dijitDialogCloseIcon { + display: none; +} + +.dialogLabel { + width: 80px; + text-align: right; + display:-moz-inline-stack; + display:inline-block; +} + +.buttonContainer { + margin-top: 1em; + border-top: 1px solid #BDD6F0; + padding-top: .5em; + text-align: center; +} + +#exceptionMonitor ul { + list-style-type: none; + color: red; +} + +.topheader { + position: relative; + height: 140px; + background: url(../img/clawHead.png) 0 0 no-repeat; + z-index: 100; +} + +.logoDemo { + position: absolute; + top: 35px; + background: url(../img/clawDemo.png) 0 0 no-repeat; + height: 106px; + width: 301px; + margin-left: 700px; + z-index: 200; +} + +.topheader .logoClaw { + position: absolute; + top: 5px; + background: url(../img/claw.png) 0 0 no-repeat; + height: 123px; + width: 123px; + margin-left:20px; + z-index: 300; +} + +.soria .listTable { + width: 100%; + border-collapse: collapse; +} + +.soria .listTable .header { + background:#EAEAEA; + border-bottom:1px solid #CCCCCC; +} + +.soria .listTable .header th { + padding:3px 0 1px 3px; +} + + +.pager { + text-align: center; +} + +.pager div { + display:-moz-inline-stack; + display:inline-block; + cursor: pointer; +} + +.pager div.page { + width: 20px; +} + +.pager div.button { + padding-left: 3px; + padding-right: 3px; +} + +.pager div.current { + cursor: default; + font-weight: bold; +} + +.hlist div.item { + float: left; +} +.searchParameters div.item span { + display: block; +} \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/docroot/img/bg.png ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/claw.png ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/clawDemo.png ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/clawHead.png ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.gif ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/roundedbg.png ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/img/spinner.gif ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/docroot/spinner.gif ============================================================================== Binary file. No diff available. Added: trunk/main/claw-demo/src/frontend/index.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/index.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,58 @@ +;;; -*- 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-demo-frontend) + + +(defclass index-page (page) + ((username :initform nil + :accessor index-page-username) + (passwd :initform nil + :accessor index-page-password))) + +(defmethod page-content ((o index-page)) + (site-template> :title "Home test page" + (ul> + (li> (a> :href "index.html" "Home")) + (li> (a> :href "info.html" "HTTP Header info")) + (li> (a> :href "realm.html" "realm on test")) + (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 "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-function-location *dojo-demo-lisplet* + (make-page-renderer 'index-page #'claw-post-parameters #'claw-get-parameters) + "index.html" + :welcome-page-p t) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/login.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/login.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,86 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/login.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-demo-frontend) + +(defgeneric login-page-do-login (login-page)) + +(defclass login-page (page) + ((username :initform "" + :accessor login-page-username) + (passwd :initform "" + :accessor login-page-password))) + +(defmethod page-content ((o login-page)) + (let ((login-result-id (generate-id "loginResult")) + (spinner-id (generate-id "spinner"))) + (site-template> :title "CLAW Demo login" + (djdialog> :id "loginDialog" + :title "Login into system" + :class "unclosable" + (djfloating-content> :static-id spinner-id + (img> :alt "spinner" + :src "docroot/img/spinner.gif")) + (djform> :id "login" + :class "loginForm" + :action 'login-page-do-login + :update-id login-result-id + :on-before-submit (ps:ps* `(.show (dijit.by-id ,spinner-id))) + :on-xhr-finish (ps:ps* `(.hide (dijit.by-id ,spinner-id))) + (div> + (span> :class "dialogLabel" "Username") + (djvalidation-text-box> :id "username" + :label "Username" + :required "true" + :accessor 'login-page-username)) + (div> + (span> :class "dialogLabel" "Password") + (djvalidation-text-box> :id "password" + :label "Password" + :required "true" + :accessor 'login-page-password)) + (div> :class "buttonContainer" + (djsubmit-button> :value "Login") + (exception-monitor> :id "exceptionMonitor"))) + (div> :static-id login-result-id + (redirect> :render-condition #'current-principal + :id "redirect" + :href (format nil "~a/index.html" (build-lisplet-location *claw-current-lisplet*))))) + (script> (ps:ps* `(dojo.add-on-load (lambda () (.show (dijit.by-id "loginDialog"))))))))) + +(lisplet-register-function-location *dojo-demo-lisplet* + (make-page-renderer 'login-page #'claw-post-parameters #'claw-get-parameters) + "login.html" + :login-page-p t) + +(defmethod login-page-do-login ((page login-page)) + (log-message :error "Performing login") + (unless (login) + (add-validation-error "login" + "Invalid user or password"))) \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/logout.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/logout.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,46 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: dojo/tests/logout.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-demo-frontend) + +(defgeneric do-logout (page)) + +(defclass logout-page (page) + ()) + +(defmethod page-content ((o logout-page)) + (do-logout o)) + +(defmethod do-logout ((demo-page logout-page)) + (claw-remove-session) + (claw-redirect (format nil "~a/index.html" (build-lisplet-location *claw-current-lisplet*)) :protocol :http)) + +(lisplet-register-function-location *dojo-demo-lisplet* + (make-page-renderer 'logout-page #'claw-post-parameters #'claw-get-parameters) + "logout.html") \ No newline at end of file Added: trunk/main/claw-demo/src/frontend/main.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/main.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,74 @@ +;;; -*- 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-demo-frontend) + + +(defvar *main-file* (load-time-value + (or #.*compile-file-pathname* *load-pathname*))) + +(defvar *dojo-demo-lisplet*) + +(setf *dojo-demo-lisplet* (make-instance 'lisplet :realm "demo" + :redirect-protected-resources-p t + :base-path "/demo")) + +(defvar *ht-connector* (make-instance 'hunchentoot-connector + :port 4242 + :sslport nil + :behind-apache-p t + :mod-lisp-p nil)) + +(defvar *sm* (make-instance 'default-session-manager)) + +(defvar *ht-log-manager* (make-instance 'hunchentoot-logger)) + +(defvar *dojo-clawserver* (make-instance 'clawserver + :connector *ht-connector* + :log-manager *ht-log-manager* + :session-manager *sm* + :base-path "/claw")) + +(clawserver-register-lisplet *dojo-clawserver* *dojo-demo-lisplet*) + +(clawserver-register-configuration *dojo-clawserver* "demo" (make-instance 'demo-configuration)) + +(let ((path (make-pathname :directory (append (pathname-directory *main-file*) '("docroot")))) + (*clawserver* *dojo-clawserver*)) + (log-message :info "Registering resource ~a" path) + (lisplet-register-resource-location *dojo-demo-lisplet* + path + "docroot/")) + +(defun djstart () + (clawserver-start *dojo-clawserver*)) + +(defun djstop () + (clawserver-stop *dojo-clawserver*)) + Added: trunk/main/claw-demo/src/frontend/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-demo/src/frontend/packages.lisp Tue Aug 26 06:57:00 2008 @@ -0,0 +1,36 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/package.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-demo-frontend + (:use :cl :local-time :claw :hunchentoot-connector :claw-html :claw-html.dojo :claw-demo-backend) + (:documentation "A demo application for CLAW") + #|(:export #:demo-setup)|#) \ No newline at end of file

1 0

[claw-cvs] r71 - in trunk/main/claw-html: . src
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 06:50:29 2008 New Revision: 71 Modified: trunk/main/claw-html/claw-html.asd trunk/main/claw-html/src/components.lisp trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp Log: CLAW html framework Modified: trunk/main/claw-html/claw-html.asd ============================================================================== --- trunk/main/claw-html/claw-html.asd (original) +++ trunk/main/claw-html/claw-html.asd Tue Aug 26 06:50:29 2008 @@ -41,8 +41,8 @@ ;(:file "connector" :depends-on ("misc")) ;(:file "logger" :depends-on ("misc")) ;(:file "session-manager" :depends-on ("misc")) - (:file "tags" :depends-on ("packages")) - (:file "meta" :depends-on ("packages")) + (:file "meta" :depends-on ("packages")) + (:file "tags" :depends-on ("packages" "meta")) (:file "components" :depends-on ("tags" "meta")) (:file "validators" :depends-on ("components")) (:file "translators" :depends-on ("validators")))))) Modified: trunk/main/claw-html/src/components.lisp ============================================================================== --- trunk/main/claw-html/src/components.lisp (original) +++ trunk/main/claw-html/src/components.lisp Tue Aug 26 06:50:29 2008 @@ -61,13 +61,16 @@ ((action :initarg :action :accessor action :documentation "Function performed after user submission") + (action-object :initarg :action-object + :accessor action-object + :documentation "The object that will be applied to the ACTION property") (css-class :initarg :class :reader css-class :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") + (:default-initargs :action nil :class nil :method "post" :action-object nil) (:documentation "Internal use component")) (defmethod wcomponent-after-rewind ((obj _cform) (pobj page)) @@ -76,7 +79,7 @@ (when (and (null validation-errors) action (cform-rewinding-p obj pobj)) - (funcall action pobj)))) + (funcall action (or (action-object obj) pobj))))) (defmethod cform-rewinding-p ((cform _cform) (page page)) (string= (htcomponent-client-id cform) @@ -213,8 +216,8 @@ (defclass cinput (base-cinput) ((input-type :initarg :type - :reader input-type - :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) + :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 :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) @@ -254,7 +257,6 @@ (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)) @@ -367,7 +369,8 @@ (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))))) + (setf (action current-form) action + (action-object current-form) (or (action-object obj) (action-object current-form))))))) ;----------------------------------------------------------------------------- (defclass submit-link (csubmit) Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Tue Aug 26 06:50:29 2008 @@ -47,8 +47,10 @@ #:render-error-page ;#:duplicate-back-slashes + #:attribute-value #:build-tagf #:page + #:page-before-render #:page-render #:make-page-renderer #:page-current-form @@ -80,6 +82,7 @@ #:$> #:$raw> ;empty tags definition + #:*empty-tags* #:area> #:base> #:basefont> Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Tue Aug 26 06:50:29 2008 @@ -64,6 +64,10 @@ (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle. - PAGE is the page instance that must be given")) +(defgeneric page-before-render (page) + (:documentation "This method is called as first instruction of PAGE-RENDER. + - 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 must be reinitialized during sub-phases (rewinding, pre-rendering, rendering). @@ -247,9 +251,9 @@ "List of component id that pass the validation") (defvar *claw-current-page* nil - "The CLAW page currently rendering") + "The CLAW page currently rendering") -(defvar *id-table-map* +(defvar *id-table-map* (make-hash-table :test 'equal) "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 \"compId_1\", the third time will be \"compId_2\" and so on") @@ -261,7 +265,13 @@ (defvar *file-translator* nil "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".") - +(defstruct list-for-tag-attribute + "Since tag attributes values are flattened, it is impossible to pass lists as values. Use this struct to pass lists to values" + (value nil)) + +(defun attribute-value (value) + "Creates an unflattenable value for tag attributes. This is particularly useful when you need to pass a list as an attribute value" + (make-list-for-tag-attribute :value value)) (defun flatten (tree &optional result-list) "Traverses the tree in order, collecting even non-null leaves into a list." @@ -290,7 +300,7 @@ do (if (and (null body) (or (keywordp elem) (keywordp last-elem))) - (push elem attributes) + (push (or (when (list-for-tag-attribute-p elem) (list-for-tag-attribute-value elem)) elem) attributes) (when elem (push elem body)))) (list (reverse attributes) (reverse body)))) @@ -356,24 +366,6 @@ ;;;---------------------------------------------------------------- -#| -(defclass message-dispatcher () - () - (:documentation "This is and interface for message dispatchers")) - -(defclass simple-message-dispatcher (message-dispatcher) - ((locales :initform (make-hash-table :test #'equal) - :accessor simple-message-dispatcher-locales - :documentation "Hash table of locales strings and KEY/VALUE message pairs")) - (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases.")) - -(defclass i18n-aware (message-dispatcher) - ((message-dispatcher :initarg :message-dispatcher - :accessor message-dispatcher - :documentation "Reference to a MESSAGE-DISPATCHER instance")) - (:default-initargs :message-dispatcher nil) - (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE")) -|# (defclass page() ((writer :initarg :writer @@ -412,8 +404,8 @@ :reader page-post-parameters :documentation "http request post parameters") (get-parameters :initarg :get-parameters - :reader page-get-parameters - :documentation "http request get parameters") + :reader page-get-parameters + :documentation "http request get parameters") (components-stack :initform nil :accessor page-components-stack :documentation "A stack of components enetered into rendering process.") @@ -424,8 +416,8 @@ :accessor page-external-format-encoding :documentation "Symbol for page charset encoding \(Such as UTF-8)") (injection-writing-p :initform nil - :accessor page-injection-writing-p - :documentation "Flag that becomes true when rendering page injections")) + :accessor page-injection-writing-p + :documentation "Flag that becomes true when rendering page injections")) (:default-initargs :writer t :external-format-encoding :utf-8 :script-files nil @@ -444,7 +436,13 @@ (defun make-page-renderer (page-class http-post-parameters http-get-parameters) "Generates a lambda function from PAGE-RENDER method, that may be used into LISPLET-REGISTER-FUNCTION-LOCATION" #'(lambda () (with-output-to-string (*standard-output*) - (page-render (make-instance page-class :post-parameters http-post-parameters :get-parameters http-get-parameters))))) + (page-render (make-instance page-class + :post-parameters (if (functionp http-post-parameters) + (funcall http-post-parameters) + http-post-parameters) + :get-parameters (if (functionp http-get-parameters) + (funcall http-get-parameters) + http-get-parameters)))))) (defclass htcomponent () ((page :initarg :page @@ -661,44 +659,45 @@ (let ((js-array (ps:ps* `(array ,@*validation-compliances*)))) (subseq js-array 0 (1- (length js-array))))) +(defmethod page-before-render ((page page)) + nil) + (defmethod page-render ((page page)) (let ((*claw-current-page* page) - (*id-table-map* nil) + (*id-table-map* (make-hash-table :test 'equal)) (*validation-errors* nil) (*validation-compliances* nil) - (body (page-content page)) (jsonp (page-json-id-list page))) - (if (null body) - (format nil "null body for page ~a~%" (type-of page)) - (progn - (page-init page) - (when (page-req-parameter page *rewind-parameter*) - (htcomponent-rewind body page)) - (page-init page) - (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! - (page-render-headings page) - (page-init page) - (when jsonp - (page-format-raw page (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 - (page-injection-writing-p page) t) - (dolist (injection (page-init-injections page)) - (when injection - (htcomponent-render injection page))) - (page-format-raw page "\",instanceInjections:\"") - (let ((init-scripts (htbody-init-scripts-tag page))) - (when init-scripts - (htcomponent-render init-scripts page))) - (page-format-raw page "\",errors:") - (page-format-raw page (json-validation-errors)) - (page-format-raw page ",valid:") - (page-format-raw page (json-validation-compliances)) - (page-format-raw page "}") - (page-format-raw page (page-json-suffix page))))))) + (progn + (page-init page) + (page-before-render page) + (when (page-req-parameter page *rewind-parameter*) + (htcomponent-rewind (page-content page) page)) + (page-init page) + (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! + (page-render-headings page) + (page-init page) + (when jsonp + (page-format-raw page (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 + (page-injection-writing-p page) t) + (dolist (injection (page-init-injections page)) + (when injection + (htcomponent-render injection page))) + (page-format-raw page "\",instanceInjections:\"") + (let ((init-scripts (htbody-init-scripts-tag page))) + (when init-scripts + (htcomponent-render init-scripts page))) + (page-format-raw page "\",errors:") + (page-format-raw page (json-validation-errors)) + (page-format-raw page ",valid:") + (page-format-raw page (json-validation-compliances)) + (page-format-raw page "}") + (page-format-raw page (page-json-suffix page)))))) (defmethod page-body-init-scripts ((page page)) (let ((js-body "")) @@ -757,225 +756,227 @@ (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))) - (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))) - (or json-render-on-validation-errors-p print-status render-p))) +(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))) + (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 (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) - (page-format page ",")) - (page-format-raw page "~a:\"" id) - (push id (page-json-component-id-list page)) - (incf (page-json-component-count page))))) +(let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (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) + (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 (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))) - (pop (page-json-component-id-list page)) - (page-format-raw page "\"")))) +(let* ((page (htcomponent-page htcomponent)) + (jsonp (page-json-id-list page)) + (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))) + (pop (page-json-component-id-list page)) + (page-format-raw page "\"")))) (defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) - (setf (htcomponent-page htcomponent) page) - (push htcomponent (page-components-stack page))) +(setf (htcomponent-page htcomponent) page) +(push htcomponent (page-components-stack page))) (defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page 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))))) +(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)) - (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))))) +(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))) +(pop (page-components-stack page))) (defmethod htcomponent-prerender :after ((htcomponent htcomponent) (page page)) - (let ((render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (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)) - (let ((render-condition (htcomponent-render-condition htcomponent))) - (unless (and render-condition (null (funcall render-condition))) - (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)) - (when (subtypep (type-of tag) 'htcomponent) - (htcomponent-rewind tag page)))) +(dolist (tag (htcomponent-body htcomponent)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-rewind tag page)))) (defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) - (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))))) +(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)) - (let ((body-list (htcomponent-body 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))))) +(let ((body-list (htcomponent-body 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)) - (htcomponent-attributes tag)) +(htcomponent-attributes tag)) (defmethod tag-render-attributes ((tag tag) (page page)) - (when (htcomponent-attributes tag) - (loop for (k v) on (htcomponent-attributes tag) by #'cddr - do (progn - (assert (keywordp k)) - (when (and (functionp v) (not (eq k :render-condition))) - (setf v (funcall v))) - (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)) - (if (eq t v) - "\"true\"" - (prin1-to-string v))))) ;escapes double quotes - (subseq s 1 (1- (length s)))))))))) +(when (htcomponent-attributes tag) + (loop for (k v) on (htcomponent-attributes tag) by #'cddr + do (progn + (assert (keywordp k)) + (when (and (functionp v) (not (eq k :render-condition))) + (setf v (funcall v))) + (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)) + (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 (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)) - (injection-writing-p (page-injection-writing-p page))) - (setf (page-lasttag page) tagname) - (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) - (tag-render-attributes tag page) - (if (null emptyp) - (progn +(let ((tagname (tag-name 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)) + (injection-writing-p (page-injection-writing-p page))) + (setf (page-lasttag page) tagname) + (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) + (tag-render-attributes tag page) + (if (null emptyp) + (progn + (page-format page ">") + (incf (page-tabulator page))) + (if (null xml-p) (page-format page ">") - (incf (page-tabulator page))) - (if (null xml-p) - (page-format page ">") - (page-format page "/>")))))) + (page-format page "/>")))))) (defmethod tag-render-endtag ((tag tag) (page page)) - (let ((tagname (tag-name 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)) - (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 - (page-newline page) - (page-print-tabulation page) - (page-format page "</~a>" tagname))))) - (setf (page-lasttag page) nil))) +(let ((tagname (tag-name 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)) + (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 + (page-newline page) + (page-print-tabulation page) + (page-format page "</~a>" tagname))))) + (setf (page-lasttag page) nil))) (defmethod htcomponent-render ((tag tag) (page page)) - (let ((body-list (htcomponent-body tag)) - (previous-print-status (page-can-print page)) - (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 - ((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))))) +(let ((body-list (htcomponent-body tag)) + (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 + ((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)) - (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 (page-external-format-encoding page))) - (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)))))) +(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 (page-external-format-encoding page))) + (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 =================================== @@ -983,397 +984,284 @@ (defmethod htcomponent-prerender((htstring htstring) (page page))) (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)) - (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))))))))) +(let ((body (htcomponent-body htstring)) + (jsonp (not (null (page-json-id-list page)))) + (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))) (defmethod htcomponent-render ((htscript htscript) (page page)) - (let ((xml-p (page-xmloutput page)) - (body (htcomponent-body 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))))) +(let ((xml-p (page-xmloutput page)) + (body (htcomponent-body 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)) - (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))))) +(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)) - (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))))) +(let ((body-list (htcomponent-body 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-control-string-directive (if on-load - " +(let ((js (script> :type "text/javascript")) + (js-control-string-directive (if on-load + " var bodyInitFunction = function\(e){~{~a~}};~% if (/MSIE (\\d+\\.\\d+);/.test(navigator.userAgent)) {~% window.attachEvent\('onload', bodyInitFunction);~% } else {~% document.addEventListener\('DOMContentLoaded', bodyInitFunction, false);~% }" - "~{~a~}~%")) - (page-body-init-scripts (page-body-init-scripts page))) - (setf (htcomponent-page js) page - (htcomponent-body js) (when page-body-init-scripts - (format nil js-control-string-directive (if (listp page-body-init-scripts) - page-body-init-scripts - (list page-body-init-scripts))))) - js)) + "~{~a~}~%")) + (page-body-init-scripts (page-body-init-scripts page))) + (setf (htcomponent-page js) page + (htcomponent-body js) (when page-body-init-scripts + (format nil js-control-string-directive (if (listp page-body-init-scripts) + page-body-init-scripts + (list page-body-init-scripts))))) + js)) ;;;========= WCOMPONENT =================================== (defclass wcomponent (htcomponent) - ((reserved-parameters :initarg :reserved-parameters - :accessor wcomponent-reserved-parameters - :type cons - :documentation "Parameters that may not be used in the constructor function") - (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 - :documentation "Informal parameters are parameters optional for the component") - (allow-informal-parameters :initarg :allow-informal-parameters - :reader wcomponent-allow-informal-parametersp - :allocation :class - :documentation "Determines if the component accepts informal parameters")) - (:default-initargs :reserved-parameters nil - :allow-informal-parameters t) - (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) +((reserved-parameters :initarg :reserved-parameters + :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 + :documentation "Informal parameters are parameters optional for the component") + (allow-informal-parameters :initarg :allow-informal-parameters + :reader wcomponent-allow-informal-parametersp + :allocation :class + :documentation "Determines if the component accepts informal parameters")) +(:default-initargs :reserved-parameters nil + :allow-informal-parameters t) +(:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) (defun slot-initarg-p (initarg class-precedence-list) - "Returns nil if a slot with that initarg isn't found into the list of classes passed" - (loop for class in class-precedence-list - do (let* ((direct-slots (closer-mop:class-direct-slots class)) - (result (loop for slot in direct-slots - do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) - (return initarg))))) - (when result - (return result))))) +"Returns nil if a slot with that initarg isn't found into the list of classes passed" +(loop for class in class-precedence-list + do (let* ((direct-slots (closer-mop:class-direct-slots class)) + (result (loop for slot in direct-slots + do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) + (return initarg))))) + (when result + (return result))))) (defmethod initialize-instance :after ((instance wcomponent) &rest rest) - (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) - (informal-parameters (loop for (k v) on rest by #'cddr - for result = () - do (unless (slot-initarg-p k class-precedence-list) - (push v result) - (push k result)) - finally (return result)))) - (setf (slot-value instance 'informal-parameters) informal-parameters))) +(let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) + (informal-parameters (loop for (k v) on rest by #'cddr + for result = () + do (unless (slot-initarg-p k class-precedence-list) + (push v result) + (push k result)) + finally (return result)))) + (setf (slot-value instance 'informal-parameters) informal-parameters))) (defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg) - (let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg)) - (new-value (if (eq slot-initarg :id) (generate-id value) value)) - (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) - do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) - (return (closer-mop:slot-definition-name slot-definition)))))) - (if (find initarg (wcomponent-reserved-parameters wcomponent)) - (error (format nil "Parameter ~a is reserved" initarg)) - (if slot-name - (setf (slot-value wcomponent slot-name) new-value) - (if (null (wcomponent-allow-informal-parametersp wcomponent)) - (error (format nil - "Component ~a doesn't accept informal parameters" - slot-initarg)) - (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) +(let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg)) + (new-value (if (eq slot-initarg :id) (generate-id value) value)) + (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) + do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) + (return (closer-mop:slot-definition-name slot-definition)))))) + (if (find initarg (wcomponent-reserved-parameters wcomponent)) + (error (format nil "Parameter ~a is reserved" initarg)) + (if slot-name + (setf (slot-value wcomponent slot-name) new-value) + (if (null (wcomponent-allow-informal-parametersp wcomponent)) + (error (format nil + "Component ~a doesn't accept informal parameters" + slot-initarg)) + (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) (defun make-component (name parameters content) - "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the +"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)) - (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 - do (setf (slot-initialization instance initarg) value)) - (setf (htcomponent-body instance) content) - instance)) +(unless (or (getf parameters :id) + (getf parameters :static-id)) + (setf (getf parameters :id) "claw")) +(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 + do (setf (slot-initialization instance initarg) value)) + (setf (htcomponent-body instance) content) + instance)) (defun build-component (component-name &rest rest) - "This function is the one that WCOMPONENT init functions call to intantiate their relative components. +"This function is the one that WCOMPONENT init functions call to intantiate their relative components. The REST parameter is flattened and divided into a pair, where the first element is the alist of the component parameters, while the second is the component body." - (let ((fbody (parse-htcomponent-function (flatten rest)))) - (make-component component-name (first fbody) (second fbody)))) +(let ((fbody (parse-htcomponent-function (flatten rest)))) + (make-component component-name (first fbody) (second fbody)))) (defmethod htcomponent-rewind ((wcomponent wcomponent) (page page)) - (let ((template (wcomponent-template wcomponent))) - (wcomponent-before-rewind wcomponent page) - (if (listp template) - (dolist (tag template) - (htcomponent-rewind tag page)) - (htcomponent-rewind template page)) - (wcomponent-after-rewind wcomponent page))) +(let ((template (wcomponent-template wcomponent))) + (wcomponent-before-rewind wcomponent page) + (if (listp template) + (dolist (tag template) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) + (wcomponent-after-rewind wcomponent page))) (defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page))) (defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page))) (defmethod htcomponent-prerender ((wcomponent wcomponent) (page 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) - (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) - (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) + (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) + (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)) - (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))))) +(let ((template (wcomponent-template 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))) -(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")) - (:documentation "This is the page class used to render -the http error messages.")) - -(defclass error-page-template (wcomponent) - ((title :initarg :title - :reader title - :documentation "The page title") - (error-code :initarg :error-code - :reader error-code - :documentation "The http error code. For details consult http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html") - (style :initarg :style - :reader style - :documentation "The CSS <style> element, used to beautify the error page.")) - (:default-initargs :style " -body { - font-family: arial, elvetica; - font-size: 7pt; -} -span.blue { - background-color: #525D76; - color: white; - font-weight: bolder; - margin-right: .25em; -} -p.h1, p.h2 { - background-color: #525D76; - color: white; - font-weight: bolder; - font-size: 2em; - margin: 0; - margin-bottom: .5em; -} -p.h2 {font-size: 1.5em;}" :empty t :allow-informal-parameters nil) - (:metaclass metacomponent) - (:documentation "The template for the error-page")) - -(let ((class (find-class 'error-page-template))) - (closer-mop:ensure-finalized class) - (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) - (format nil "Description: ~a~%Parameters:~%~a~%~%~a" - "Function that instantiates an ERROR-PAGE-TEMPLATE component and renders a html tenplate for CLAW generic error pages." - (describe-html-attributes-from-class-slot-initargs class) - (describe-component-behaviour class)))) - -(defmethod wcomponent-template ((error-page-template error-page-template)) - (let ((error-code (error-code error-page-template)) - (title (title error-page-template)) - (style (style error-page-template)) - (request-uri (connector-request-uri (clawserver-connector *clawserver*)))) - (html> - (head> - (title> title) - (style> style)) - (body> - (p> - (p> :class "h1" - (format nil "HTTP Status ~a - ~a" error-code request-uri)) - (hr> :noshade "noshade") - (p> - (span> :class "blue" - ($> "type")) - "Status report") - (p> - (span> :class "blue" - "url") - request-uri) - (p> - (span> :class "blue" - "description") - (gethash error-code *http-reason-phrase-map*) - (hr> :noshade "noshade")) - (p> :class "h2" - "claw server")))))) - -(defmethod page-content ((error-page error-page)) - (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))))) - -(defun render-error-page (&optional (error-code 404)) - "This function renders a http error page." - (let ((connector (clawserver-connector clawserver))) - (page-render (make-instance 'error-page - :title (format nil "Server error: ~a" error-code) - :error-code error-code)))) -#| -(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) - -(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) - (let ((dispatcher (message-dispatcher i18n-aware)) - (result)) - (when dispatcher - (progn - (setf result (message-dispatch dispatcher key locale)) - (when (and (null result) (> (length locale) 2)) - (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) - result)) - -(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value) - (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher) (make-hash-table :test #'equal)))) - (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) - (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)))) - (when current-locale - (gethash key current-locale)))) -|#

1 0

[claw-cvs] r70 - in trunk/main/claw-html.dojo: . src src/js
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 06:49:29 2008 New Revision: 70 Added: trunk/main/claw-html.dojo/ trunk/main/claw-html.dojo/README trunk/main/claw-html.dojo/claw-html.dojo.asd trunk/main/claw-html.dojo/src/ trunk/main/claw-html.dojo/src/dijit.lisp trunk/main/claw-html.dojo/src/djbody.lisp trunk/main/claw-html.dojo/src/djbutton.lisp trunk/main/claw-html.dojo/src/djclaw.lisp trunk/main/claw-html.dojo/src/djcolorpalette.lisp trunk/main/claw-html.dojo/src/djcontainers.lisp trunk/main/claw-html.dojo/src/djcontent-pane.lisp trunk/main/claw-html.dojo/src/djdialog.lisp trunk/main/claw-html.dojo/src/djform.lisp trunk/main/claw-html.dojo/src/djlayout.lisp trunk/main/claw-html.dojo/src/djlink.lisp trunk/main/claw-html.dojo/src/djmenu.lisp trunk/main/claw-html.dojo/src/djprogressbar.lisp trunk/main/claw-html.dojo/src/djtitlepane.lisp trunk/main/claw-html.dojo/src/djtoolbar.fasl (contents, props changed) trunk/main/claw-html.dojo/src/djtoolbar.lisp trunk/main/claw-html.dojo/src/djtooltip.lisp trunk/main/claw-html.dojo/src/djtree.lisp trunk/main/claw-html.dojo/src/djwidget.lisp trunk/main/claw-html.dojo/src/js/ trunk/main/claw-html.dojo/src/js/ActionLink.js trunk/main/claw-html.dojo/src/js/Dialog.js trunk/main/claw-html.dojo/src/js/Editor.js trunk/main/claw-html.dojo/src/js/Editor2.js trunk/main/claw-html.dojo/src/js/FloatingContent.js trunk/main/claw-html.dojo/src/js/Form.js trunk/main/claw-html.dojo/src/js/HardLink.js trunk/main/claw-html.dojo/src/js/Rounded.js trunk/main/claw-html.dojo/src/js/claw.js trunk/main/claw-html.dojo/src/misc.lisp trunk/main/claw-html.dojo/src/packages.lisp Log: CLAW dojo integration Added: trunk/main/claw-html.dojo/README ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/README Tue Aug 26 06:49:29 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/claw-html.dojo/claw-html.dojo.asd ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/claw-html.dojo.asd Tue Aug 26 06:49:29 2008 @@ -0,0 +1,54 @@ +;;; -*- 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-html.dojo + :name "claw-html.dojo" + :author "Andrea Chiumenti" + :description "claw dojo-1.1.0 integration" + :depends-on (:claw :claw-html :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")) + (:file "djtoolbar" :depends-on ("djwidget")))))) Added: trunk/main/claw-html.dojo/src/dijit.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/dijit.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djbody.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djbody.lisp Tue Aug 26 06:49:29 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 *clawserver*)) + :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 *clawserver*)) + :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 *clawserver*)) + (format nil "~a/dojotoolkit/dijit/themes/dijit.css" (clawserver-base-path *clawserver*)) + (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/claw-html.dojo/src/djbutton.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djbutton.lisp Tue Aug 26 06:49:29 2008 @@ -0,0 +1,88 @@ +;;; -*- 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)) + (setf (djsubmit-button-form obj) (page-current-form page))) + +(defmethod wcomponent-before-render ((obj djsubmit-button) (page 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/claw-html.dojo/src/djclaw.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djclaw.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djcolorpalette.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djcolorpalette.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djcontainers.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djcontainers.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djcontent-pane.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djcontent-pane.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djdialog.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djdialog.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djform.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djform.lisp Tue Aug 26 06:49:29 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 (input-type obj)) + (dojo-type (djwidget-dojo-type obj)) + (translator (translator obj)) + (value "") + (class (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 (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 (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 (claw-script-name))) + (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 *clawserver*)))) + +(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/claw-html.dojo/src/djlayout.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djlayout.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djlink.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djlink.lisp Tue Aug 26 06:49:29 2008 @@ -0,0 +1,54 @@ +;;; -*- 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 "claw.ActionLink" :update-id ())) + +(defmethod wcomponent-template((o djaction-link)) + (let ((client-id (htcomponent-client-id o)) + (update-id (update-id o)) + (dojo-type (djwidget-dojo-type o))) + (a> :static-id client-id + :href "#" + :hxr t + :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 o) + (htcomponent-body o)))) + + Added: trunk/main/claw-html.dojo/src/djmenu.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djmenu.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djprogressbar.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djprogressbar.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djtitlepane.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djtitlepane.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djtoolbar.fasl ============================================================================== Binary file. No diff available. Added: trunk/main/claw-html.dojo/src/djtoolbar.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djtoolbar.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djtooltip.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djtooltip.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djtree.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djtree.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/djwidget.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/djwidget.lisp Tue Aug 26 06:49:29 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/claw-html.dojo/src/js/ActionLink.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/ActionLink.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,130 @@ +/** +;;; $Header: dojo/src/js/ActionLink.js $ + +;;; 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. +*/ + + if(!dojo._hasResource["claw.ActionLink"]){ + dojo.provide("claw.ActionLink"); + + dojo.require("dijit._Widget"); + dojo.require("dijit._Templated"); + dojo.declare( + "claw.ActionLink", + [dijit._Widget, dijit._Templated], + { + xhrTimeout: "",//2000, + updateId: null, + enctype: "", + xhr: true, + templateString: "<a dojoAttachPoint='containerNode' dojoAttachEvent='onclick:_onClick' href='#'></a>", + jsonContent: {}, + _updateParts: function (reply) { + for (var item in reply.components) { + var element = dojo.byId(item); + if ((element != null) && (reply.components[item] != null)) { + var list = dojo.query('[widgetId]', element); + dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); + element.innerHTML = reply.components[item]; + dojo.parser.parse(element, true); + } + } + }, + + _evalReplClassScripts: function (reply) { + dijit.byId('scripts-content-pane').setContent(reply.classInjections); + }, + + _evalReplInstanceScripts: function (reply) { + dijit.byId('scripts-content-pane').setContent(reply.instanceInjections); + }, + + _updateAndEval: function (reply) { + console.debug("Plain object as string is: ", reply); + console.debug("Object as string is: ", dojo.toJson(reply, true)); + this._evalReplClassScripts(reply); + this._updateParts(reply); + this._evalReplInstanceScripts(reply); + }, + click: function(){ + if(!(this.onClick() === false) && !this.xhr){ + this.containerNode.click(); + } + }, + _onClick: function(e){ + // summary: + // Callback when user submits the form. This method is + // intended to be over-ridden, but by default it checks and + // returns the validity of form elements. When the `submit` + // method is called programmatically, the return value from + // `onSubmit` is used to compute whether or not submission + // should proceed + + if (this.xhr) { + if (e) { + e.preventDefault(); + } + this.onBeforeClick(e); + var thisLink = this; + var jsonContent = dojo.mixin(this.jsonContent, { json : thisLink.updateId, rewindobject : thisLink.id }); + this.jsonContent = {}; + var linkId = this.id; + dojo.xhrPost({ + url: '#', + load : function (data) { + try { + thisLink._updateAndEval(data); + } finally { + thisLink.onXhrFinish(e); + } + }, + error : function (data) {console.error(data);thisLink.onXhrFinish(e);}, + timeout : thisLink.xhrTimeout, + handleAs : 'json', + content : jsonContent }); + } + return true; + }, + + onBeforeClick: function(/*Event?*/e){ + // summary: + // Callback when user submits the form. This method is + // intended to be over-ridden. When the `submit` calls dojo.xhrPost + // this method is called before. + }, + + onXhrFinish: function(/*Event?*/e){ + // summary: + // Callback when user submits the form. This method is + // intended to be over-ridden. After the call to dojo.xhrPost + // thouches lload or error this event is fired + } + } + ); + + } + Added: trunk/main/claw-html.dojo/src/js/Dialog.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/Dialog.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,40 @@ +/** +;;; $Header: dojo/src/js/HardLink.js $ + +;;; 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. +*/ + +//if(!dojo._hasResource["claw.Dialog"]){ //_hasResource checks added by build. Do not use _hasResource directly in your code. + dojo.provide("claw.Dialog"); + + dojo.require("dijit.Dialog"); + + dojo.declare( + "claw.Dialog", + dijit.Dialog + ); +//} \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/Editor.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/Editor.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,63 @@ +/** +;;; $Header: dojo/src/js/Editor.js $ + +;;; 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. +*/ + + +if(!dojo._hasResource["claw.Editor"]){ + dojo.provide("claw.Editor"); + dojo.require("dijit.Editor"); + dojo.declare( + "claw.Editor", + dijit.Editor, + { + name: "", + hidden: null, + postCreate: function(){ + this.inherited(arguments); + this.hidden = dojo.doc.createElement('input'); + var hidden = this.hidden; + hidden.type = "hidden"; + hidden.name = this.name; + this.domNode.parentNode.appendChild(this.hidden); + var theEditor = this; + if (this.hidden.form) { + var theForm = dijit.byId(this.hidden.form.id); + if (theForm) { + dojo.connect(theForm, + "onBeforeSubmit", + function(e) {hidden.value = theEditor.getValue();}); + } + } + }, + destroy: function(){ + this.domNode.parentNode.removeChild(this.hidden); + this.inherited(arguments); + } + }); +} \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/Editor2.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/Editor2.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,63 @@ +/** +;;; $Header: dojo/src/js/Editor.js $ + +;;; 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. +*/ + + +if(!dojo._hasResource["claw.Editor2"]){ + dojo.provide("claw.Editor2"); + dojo.require("dijit.Editor"); + dojo.require("dojox.lang.aspect"); + dojo.declare( + "claw.Editor2", + dijit.Editor, + { + name: "", + hidden: null, + postCreate: function(){ + this.inherited(arguments); + this.hidden = dojo.doc.createElement('input'); + var hidden = this.hidden; + hidden.type = "hidden"; + hidden.name = this.name; + this.domNode.parentNode.appendChild(this.hidden); + var aop = dojox.lang.aspect; + var theEditor = this; + if (this.hidden.form) { + var theForm = dijit.byId(this.hidden.form.id); + if (!theForm) + theForm = this.hidden.form; + aop.advise(theForm, /submit/, { before: function(args) {hidden.value = theEditor.getValue();} }); + } + }, + destroy: function(){ + this.domNode.parentNode.removeChild(this.hidden); + this.inherited(arguments); + } + }); +} \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/FloatingContent.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/FloatingContent.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,47 @@ +/** +;;; $Header: dojo/src/js/FloatingContent.js $ + +;;; 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. +*/ + +if(!dojo._hasResource["claw.FloatingContent"]){ //_hasResource checks added by build. Do not use _hasResource directly in your code. + dojo._hasResource["claw.FloatingContent"] = true; + dojo.provide("claw.FloatingContent"); + + dojo.require("dijit.Dialog"); + + dojo.declare( + "claw.FloatingContent", + dijit.Dialog, + { + + templateString:"<div class=\"dijitDialog\" style=\"border:0;\" tabindex=\"-1\" waiRole=\"dialog\" waiState=\"labelledby-${id}_title\">\n\t<div dojoAttachPoint=\"containerNode\"></div>\n</div>", + _getFocusItems: function (domNode) {} + + } + ); +} \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/Form.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/Form.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,157 @@ +y/** +;;; $Header: dojo/src/js/Form.js $ + +;;; 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. +*/ + +if(!dojo._hasResource["claw.Form"]){ +dojo.provide("claw.Form"); + +dojo.require("dojo.io.iframe"); +dojo.require("dijit.form.Form"); + +dojo.declare( + "claw.Form", + [dijit.form.Form], + { + // summary: + // Adds conveniences to regular HTML form + + // HTML <FORM> attributes + xhrTimeout: "",//2000, + updateId: null, + enctype: "", + xhr: null, + jsonContent: {}, + _updateParts: function (reply) { + for (var item in reply.components) { + var element = dojo.byId(item); + if ((element != null) && (reply.components[item] != null)) { + var list = dojo.query('[widgetId]', element); + dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); + element.innerHTML = reply.components[item]; + dojo.parser.parse(element, true); + } + } + }, + + _evalReplClassScripts: function (reply) { + dijit.byId('scripts-content-pane').setContent(reply.classInjections); + }, + + _evalReplInstanceScripts: function (reply) { + dijit.byId('scripts-content-pane').setContent(reply.instanceInjections); + }, + + _updateAndEval: function (reply) { + console.debug("Plain object as string is: ", reply); + console.debug("Object as string is: ", dojo.toJson(reply, true)); + this._evalReplClassScripts(reply); + this._updateParts(reply); + this._evalReplInstanceScripts(reply); + }, + submit: function(){ + if(!(this.onSubmit() === false) && !this.xhr){ + this.containerNode.submit(); + } + }, + onSubmit: function(e){ + // summary: + // Callback when user submits the form. This method is + // intended to be over-ridden, but by default it checks and + // returns the validity of form elements. When the `submit` + // method is called programmatically, the return value from + // `onSubmit` is used to compute whether or not submission + // should proceed + + var valid = this.validate(); // Boolean + + if (valid && this.xhr) { + if (e) { + e.preventDefault(); + } + this.onBeforeSubmit(e); + var thisForm = this; + var jsonContent = dojo.mixin(this.jsonContent, { json : thisForm.updateId }); + this.jsonContent = {}; + var formId = this.id; + if (this.enctype != 'multipart/form-data') { + dojo.xhrPost({ + url: '#', + load : function (data) { + try { + thisForm._updateAndEval(data); + } finally { + thisForm.onXhrFinish(e); + } + }, + error : function (data) {console.error(data);thisForm.onXhrFinish(e);}, + timeout : thisForm.xhrTimeout, + handleAs : 'json', + form : formId, + content : jsonContent }); + } else { + jsonContent = dojo.mixin(jsonContent, { jsonPrefix: '<textarea>', jsonSuffix: '</textarea>' }); + dojo.io.iframe.send({ + load : function (data) { + try { + thisForm._updateAndEval(data); + } finally { + thisForm.onXhrFinish(e); + } + }, + error : function (data) { + console.error(data); + thisForm.onXhrFinish(e); + }, + timeout : thisForm.xhrTimeout, + handleAs : 'json', + form: formId, + content : jsonContent }); + } + } + return valid; + }, + + onBeforeSubmit: function(/*Event?*/e){ + // summary: + // Callback when user submits the form. This method is + // intended to be over-ridden. When the `submit` calls dojo.xhrPost + // this method is called before. + }, + + onXhrFinish: function(/*Event?*/e){ + // summary: + // Callback when user submits the form. This method is + // intended to be over-ridden. After the call to dojo.xhrPost + // thouches lload or error this event is fired + } + } +); + +} + Added: trunk/main/claw-html.dojo/src/js/HardLink.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/HardLink.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,64 @@ +/** +;;; $Header: dojo/src/js/HardLink.js $ + +;;; 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. +*/ + +if(!dojo._hasResource["claw.HardLink"]){ //_hasResource checks added by build. Do not use _hasResource directly in your code. + dojo._hasResource["claw.HardLink"] = true; + dojo.provide("claw.HardLink"); + + dojo.require("dijit._Widget"); + + dojo.declare( + "claw.HardLink", + dijit._Widget, + { + + // connectId: String + // Id of domNode to attach the hard link to. + + refId: "", + + style: "display:none;", + + destroy: function () { + if (this.refId) { + var widget = dijit.byId(this.refId); + if (widget) { + var domNode = widget.domNode; + var list = dojo.query('[widgetId]', domNode); + dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); + widget.destroy(); + } + } + this.inherited(arguments); + } + + } + ); +} \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/Rounded.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/Rounded.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,58 @@ +/** +;;; $Header: dojo/src/js/LoadingSpinner.js $ + +;;; 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. +*/ + +if(!dojo._hasResource["claw.Rounded"]){ //_hasResource checks added by build. Do not use _hasResource directly in your code. + dojo._hasResource["claw.Rounded"] = true; + dojo.provide("claw.Rounded"); + + dojo.require("dijit._Widget"); + dojo.require("dijit._Templated"); + + + dojo.declare( + "claw.Rounded", + [dijit._Widget, dijit._Templated], + { + templateString:"<div class=\"Rounded\" dojoAttachPoint=\"outerNode\">\n\t<div class=\"RoundedContent\" dojoAttachPoint=\"roundedContent\">\n\t\t<div class=\"RoundedTop\" dojoAttachPoint=\"roundedTop\"></div>\n\t\t<div dojoAttachPoint=\"contentNode\">\n\t\t\t<div dojoAttachPoint=\"containerNode\"></div>\n\t\t</div>\n\t</div>\n\t<div class=\"RoundedBottom\" dojoAttachPoint=\"roundedBottom\">\n\t\t<div dojoAttachPoint=\"roundedBottomDiv\"></div>\n\t</div>\n</div>", + bgImg: "", // standard background image (png) + bgImgAlt: "", // background image for ie6 + + postCreate: function() { + dojo.style(this.contentNode, "height", dojo.style(this.outerNode, "height")-10+'px'); // TODO: Calculate correct height + var alt = (this.bgImgAlt.length && dojo.isIE < 7 && dojo.isIE > 0); + dojo.forEach(["roundedContent","roundedTop","roundedBottom","roundedBottomDiv"], + function(elName){ + dojo.style(this[elName],"backgroundImage", "url(" + (alt ? this.bgImgAlt : this.bgImg) + ")"); + }, + this); + } + }); + +} \ No newline at end of file Added: trunk/main/claw-html.dojo/src/js/claw.js ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/js/claw.js Tue Aug 26 06:49:29 2008 @@ -0,0 +1,59 @@ +/** +;;; $Header: dojo/src/js/claw.js $ + +;;; 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. +*/ + +//dojo.require('dijit.Tooltip'); + +var claw = { + _updateParts: function (reply) { + for (var item in reply.components) { + var element = dojo.byId(item); + if ((element != null) && (reply.components[item] != null)) { + var list = dojo.query('[widgetId]', element); + dojo.forEach(list.map(dijit.byNode), function(widget){if (widget) widget.destroy(); }); + element.innerHTML = reply.components[item]; + dojo.parser.parse(element, true); + } + } + }, + _evalReplClassScripts: function (reply) { + dijit.byId('scripts-content-pane').setContent(reply.classInjections); + }, + _evalReplInstanceScripts: function (reply) { + dijit.byId('scripts-content-pane').setContent(reply.instanceInjections); + }, + updateAndEval: function (reply) { + console.debug("Plain object as string is: ", reply); + console.debug("Object as string is: ", dojo.toJson(reply, true)); + this._evalReplClassScripts(reply); + this._updateParts(reply); + this._evalReplInstanceScripts(reply); + + } +}; \ No newline at end of file Added: trunk/main/claw-html.dojo/src/misc.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/misc.lisp Tue Aug 26 06:49:29 2008 @@ -0,0 +1,44 @@ +;;; -*- 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")) +(register-library-resource "dojotoolkit/claw/ActionLink.js" (make-pathname :directory (append (pathname-directory *dojo-misc-file*) '("js")) :name "ActionLink" :type "js")) Added: trunk/main/claw-html.dojo/src/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html.dojo/src/packages.lisp Tue Aug 26 06:49:29 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-html.dojo + (:nicknames :dojo) + (:use :cl :claw :claw-html :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>))

1 0

[claw-cvs] r69 - trunk/main/dojo/tests
by achiumenti＠common-lisp.net 25 Jul '08

25 Jul '08

Author: achiumenti Date: Fri Jul 25 11:21:01 2008 New Revision: 69 Modified: trunk/main/dojo/tests/ajax-test.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/header-info-page.lisp trunk/main/dojo/tests/index.lisp trunk/main/dojo/tests/realm.lisp trunk/main/dojo/tests/slider-test.lisp Log: nomsg Modified: trunk/main/dojo/tests/ajax-test.lisp ============================================================================== --- trunk/main/dojo/tests/ajax-test.lisp (original) +++ trunk/main/dojo/tests/ajax-test.lisp Fri Jul 25 11:21:01 2008 @@ -283,4 +283,4 @@ (build-lisplet-location *claw-current-lisplet*))))))))) -(lisplet-register-page-location *dojo-test-lisplet* 'ajax-page "ajax.html") \ No newline at end of file +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'ajax-page) "ajax.html") \ No newline at end of file Modified: trunk/main/dojo/tests/djbutton-test.lisp ============================================================================== --- trunk/main/dojo/tests/djbutton-test.lisp (original) +++ trunk/main/dojo/tests/djbutton-test.lisp Fri Jul 25 11:21:01 2008 @@ -72,4 +72,4 @@ "Toggle me")))) -(lisplet-register-page-location *dojo-test-lisplet* 'djbutton-page "djbutton.html") \ No newline at end of file +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'djbutton-page) "djbutton.html") \ No newline at end of file Modified: trunk/main/dojo/tests/djcalendar-test.lisp ============================================================================== --- trunk/main/dojo/tests/djcalendar-test.lisp (original) +++ trunk/main/dojo/tests/djcalendar-test.lisp Fri Jul 25 11:21:01 2008 @@ -84,4 +84,4 @@ (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 +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'djcalendar-page) "djcalendar.html") \ No newline at end of file Modified: trunk/main/dojo/tests/djcolorpalette-test.lisp ============================================================================== --- trunk/main/dojo/tests/djcolorpalette-test.lisp (original) +++ trunk/main/dojo/tests/djcolorpalette-test.lisp Fri Jul 25 11:21:01 2008 @@ -48,4 +48,4 @@ (djcolor-palette>))) dialog)))) -(lisplet-register-page-location *dojo-test-lisplet* 'djcolorpalette-page "djcolorpalette.html") \ No newline at end of file +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'djcolorpalette-page) "djcolorpalette.html") \ No newline at end of file Modified: trunk/main/dojo/tests/djdialog-test.lisp ============================================================================== --- trunk/main/dojo/tests/djdialog-test.lisp (original) +++ trunk/main/dojo/tests/djdialog-test.lisp Fri Jul 25 11:21:01 2008 @@ -64,4 +64,4 @@ :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 +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'djdialog-page) "djdialog.html") \ No newline at end of file Modified: trunk/main/dojo/tests/djeditor-test.lisp ============================================================================== --- trunk/main/dojo/tests/djeditor-test.lisp (original) +++ trunk/main/dojo/tests/djeditor-test.lisp Fri Jul 25 11:21:01 2008 @@ -130,4 +130,4 @@ :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 +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'djeditor-page) "djeditor.html") \ No newline at end of file Modified: trunk/main/dojo/tests/djmenu-test.lisp ============================================================================== --- trunk/main/dojo/tests/djmenu-test.lisp (original) +++ trunk/main/dojo/tests/djmenu-test.lisp Fri Jul 25 11:21:01 2008 @@ -269,4 +269,4 @@ -(lisplet-register-page-location *dojo-test-lisplet* 'djmenu-page "djmenu.html") \ No newline at end of file +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'djmenu-page) "djmenu.html") \ No newline at end of file Modified: trunk/main/dojo/tests/header-info-page.lisp ============================================================================== --- trunk/main/dojo/tests/header-info-page.lisp (original) +++ trunk/main/dojo/tests/header-info-page.lisp Fri Jul 25 11:21:01 2008 @@ -43,5 +43,5 @@ (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") +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'header-info-page) "info.html") Modified: trunk/main/dojo/tests/index.lisp ============================================================================== --- trunk/main/dojo/tests/index.lisp (original) +++ trunk/main/dojo/tests/index.lisp Fri Jul 25 11:21:01 2008 @@ -48,4 +48,4 @@ (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 +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'index-page) "index.html" :welcome-page-p t) \ No newline at end of file Modified: trunk/main/dojo/tests/realm.lisp ============================================================================== --- trunk/main/dojo/tests/realm.lisp (original) +++ trunk/main/dojo/tests/realm.lisp Fri Jul 25 11:21:01 2008 @@ -63,5 +63,5 @@ (li> "Rnd number value: " #'(lambda () (format nil "~d" (realm-page-rnd-numuber o)))))))) -(lisplet-register-page-location *dojo-test-lisplet* 'realm-page "realm.html") -(lisplet-register-page-location *dojo-test-lisplet2* 'realm-page "realm.html") +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'realm-page) "realm.html") +(lisplet-register-function-location *dojo-test-lisplet2* (make-page-renderer 'realm-page) "realm.html") Modified: trunk/main/dojo/tests/slider-test.lisp ============================================================================== --- trunk/main/dojo/tests/slider-test.lisp (original) +++ trunk/main/dojo/tests/slider-test.lisp Fri Jul 25 11:21:01 2008 @@ -139,4 +139,4 @@ (slider-page-message-content pobj))))) -(lisplet-register-page-location *dojo-test-lisplet* 'slider-page "slider.html") \ No newline at end of file +(lisplet-register-function-location *dojo-test-lisplet* (make-page-renderer 'slider-page) "slider.html") \ No newline at end of file

1 0

[claw-cvs] r68 - in trunk/main/claw.i18n: . src
by achiumenti＠common-lisp.net 25 Jul '08

25 Jul '08

Author: achiumenti Date: Fri Jul 25 11:20:31 2008 New Revision: 68 Added: trunk/main/claw.i18n/ trunk/main/claw.i18n/claw.i18n.asd trunk/main/claw.i18n/src/ trunk/main/claw.i18n/src/i18n.lisp trunk/main/claw.i18n/src/locales.lisp trunk/main/claw.i18n/src/packages.lisp Log: internationalization package Added: trunk/main/claw.i18n/claw.i18n.asd ============================================================================== --- (empty file) +++ trunk/main/claw.i18n/claw.i18n.asd Fri Jul 25 11:20:31 2008 @@ -0,0 +1,38 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: claw-i18n.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.i18n + :name "claw.i18n" + :author "Andrea Chiumenti" + :description "Localization library." + :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 "i18n" :depends-on ("packages")) + (:file "locales" :depends-on ("i18n"))) Added: trunk/main/claw.i18n/src/i18n.lisp ============================================================================== --- (empty file) +++ trunk/main/claw.i18n/src/i18n.lisp Fri Jul 25 11:20:31 2008 @@ -0,0 +1,103 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/components.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw.i18n) + +(defvar *locales* (make-hash-table :test 'equal) + "A hash table of locale key strings and lists of locale directives. +You should use locale access functions to get its internal values.") + +(defun number-format-grouping-separator (&optional (locale (user-locale))) + "Returns the character used as thousands grouping separator for numbers" + (getf (getf (gethash locale *locales*) :number-format) :grouping-separator)) + +(defun number-format-decimal-separator (&optional (locale (user-locale))) + "Returns the character used as decimals separator for numbers" + (getf (getf (gethash locale *locales*) :number-format) :decimal-separator)) + +(defun ampm (&optional (locale (user-locale))) + "Returns a list with the localized version of AM and PM for time" + (getf (gethash locale *locales*) :ampm)) + +(defun monthes (&optional (locale (user-locale))) + "Returns a localized list of monthes in long form" + (getf (gethash locale *locales*) :months)) + +(defun short-monthes (&optional (locale (user-locale))) + "Returns a localized list of monthes in short form" + (getf (gethash locale *locales*) :short-months)) + +(defun first-day-of-the-week (&optional (locale (user-locale))) + "Returns the first day position of the week for the given locale, being sunday on position 0 and saturday on position 6" + (1- (getf (gethash locale *locales*) :first-day-of-the-week))) + +(defun weekdays (&optional (locale (user-locale))) + "Returns a localized list of days of the week in long form" + (getf (gethash locale *locales*) :weekdays)) + +(defun short-weekdays (&optional (locale (user-locale))) + "Returns a localized list of days of the week in short form" + (getf (gethash locale *locales*) :short-weekdays)) + +(defun eras (&optional (locale (user-locale))) + "Returns a list with the localized version of BC and AD eras" + (getf (gethash locale *locales*) :eras)) + +;;----------------------------------------------------------------------------------------------------------- + +(defvar *message-dispatcher* nil + "Global variable holding a MESSAGE-DISPATCHER, usually bound to the current lisplet, when it holds one") + +(defgeneric message-dispatch (object key locale) + (:documentation "Returns the KEY translation by the given LOCALE")) + +(defclass message-dispatcher (claw-service) + () + (:default-initargs :name 'message-dispatcher) + (:documentation "This is and interface for message dispatchers")) + +(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) + +(defun do-message (key &optional (default "") (locale (user-locale))) + "This function dispatches a message with the *message-dispatcher* object." + (or (and *message-dispatcher* + (message-dispatch *message-dispatcher* key locale)) + default)) + +(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.")) + +(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value) + (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher) (make-hash-table :test #'equal)))) + (setf (gethash key current-locale) value) + (setf (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)) current-locale))) + Added: trunk/main/claw.i18n/src/locales.lisp ============================================================================== --- (empty file) +++ trunk/main/claw.i18n/src/locales.lisp Fri Jul 25 11:20:31 2008 @@ -0,0 +1,1857 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/locales.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. + +;;; --*-- AUTOMATICALLY GENERATED - DO NOT EDIT !!!!! --*-- + +(in-package :claw.i18n) + +(setf (gethash "ja_JP" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "JPY") + :DATE-FORMAT (list + :AMPM '("午前" "午後") + :MONTHS '("1月" "2月" "3月" "4月" "5月" "6月" "7月" "8月" "9月" "10月" "11月" "12月") + :SHORT-MONTHS '("1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("日曜日" "月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日") + :SHORT-WEEKDAYS '("日" "月" "火" "水" "木" "金" "土") + :ERAS '("紀元前" "西暦")))) + +(setf (gethash "es_PE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "PEN") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "en" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "ja_JP" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "JPY") + :DATE-FORMAT (list + :AMPM '("午前" "午後") + :MONTHS '("1月" "2月" "3月" "4月" "5月" "6月" "7月" "8月" "9月" "10月" "11月" "12月") + :SHORT-MONTHS '("1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("日曜日" "月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日") + :SHORT-WEEKDAYS '("日" "月" "火" "水" "木" "金" "土") + :ERAS '("紀元前" "西暦")))) + +(setf (gethash "es_PA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "PAB") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "sr_BA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "BAM") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануар" "фебруар" "март" "април" "мај" "јуни" "јули" "август" "септембар" "октобар" "новембар" "децембар") + :SHORT-MONTHS '("јан" "феб" "мар" "апр" "мај" "јун" "јул" "авг" "сеп" "окт" "нов" "дец") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("недеља" "понедељак" "уторак" "сриједа" "четвртак" "петак" "субота") + :SHORT-WEEKDAYS '("нед" "пон" "уто" "сри" "чет" "пет" "суб") + :ERAS '("п. н. е." "н. е")))) + +(setf (gethash "mk" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануари" "февруари" "март" "април" "мај" "јуни" "јули" "август" "септември" "октомври" "ноември" "декември") + :SHORT-MONTHS '("јан." "фев." "мар." "апр." "мај." "јун." "јул." "авг." "септ." "окт." "ноем." "декем.") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("недела" "понеделник" "вторник" "среда" "четврток" "петок" "сабота") + :SHORT-WEEKDAYS '("нед." "пон." "вт." "сре." "чет." "пет." "саб.") + :ERAS '("пр.н.е." "ае.")))) + +(setf (gethash "es_GT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "GTQ") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_AE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "AED") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "no_NO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "NOK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "mars" "april" "mai" "juni" "juli" "august" "september" "oktober" "november" "desember") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "mai" "jun" "jul" "aug" "sep" "okt" "nov" "des") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("søndag" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag") + :SHORT-WEEKDAYS '("sø" "ma" "ti" "on" "to" "fr" "lø") + :ERAS '("BC" "AD")))) + +(setf (gethash "sq_AL" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "ALL") + :DATE-FORMAT (list + :AMPM '("PD" "MD") + :MONTHS '("janar" "shkurt" "mars" "prill" "maj" "qershor" "korrik" "gusht" "shtator" "tetor" "nëntor" "dhjetor") + :SHORT-MONTHS '("Jan" "Shk" "Mar" "Pri" "Maj" "Qer" "Kor" "Gsh" "Sht" "Tet" "Nën" "Dhj") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("e diel" "e hënë" "e martë" "e mërkurë" "e enjte" "e premte" "e shtunë") + :SHORT-WEEKDAYS '("Die" "Hën" "Mar" "Mër" "Enj" "Pre" "Sht") + :ERAS '("p.e.r." "n.e.r.")))) + +(setf (gethash "bg" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Януари" "Февруари" "Март" "Април" "Май" "Юни" "Юли" "Август" "Септември" "Октомври" "Ноември" "Декември") + :SHORT-MONTHS '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Неделя" "Понеделник" "Вторник" "Сряда" "Четвъртък" "Петък" "Събота") + :SHORT-WEEKDAYS '("Нд" "Пн" "Вт" "Ср" "Чт" "Пт" "Сб") + :ERAS '("пр.н.е." "н.е.")))) + +(setf (gethash "ar_IQ" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "IQD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "ar_YE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "YER") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "hu" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("DE" "DU") + :MONTHS '("január" "február" "március" "április" "május" "június" "július" "augusztus" "szeptember" "október" "november" "december") + :SHORT-MONTHS '("jan." "febr." "márc." "ápr." "máj." "jún." "júl." "aug." "szept." "okt." "nov." "dec.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("vasárnap" "hétfő" "kedd" "szerda" "csütörtök" "péntek" "szombat") + :SHORT-WEEKDAYS '("V" "H" "K" "Sze" "Cs" "P" "Szo") + :ERAS '("i.e." "i.u.")))) + +(setf (gethash "pt_PT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Janeiro" "Fevereiro" "Março" "Abril" "Maio" "Junho" "Julho" "Agosto" "Setembro" "Outubro" "Novembro" "Dezembro") + :SHORT-MONTHS '("Jan" "Fev" "Mar" "Abr" "Mai" "Jun" "Jul" "Ago" "Set" "Out" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Domingo" "Segunda-feira" "Terça-feira" "Quarta-feira" "Quinta-feira" "Sexta-feira" "Sábado") + :SHORT-WEEKDAYS '("Dom" "Seg" "Ter" "Qua" "Qui" "Sex" "Sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "el_CY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "CYP") + :DATE-FORMAT (list + :AMPM '("ΠΜ" "ΜΜ") + :MONTHS '("Ιανουάριος" "Φεβρουάριος" "Μάρτιος" "Απρίλιος" "Μάιος" "Ιούνιος" "Ιούλιος" "Αύγουστος" "Σεπτέμβριος" "Οκτώβριος" "Νοέμβριος" "Δεκέμβριος") + :SHORT-MONTHS '("Ιαν" "Φεβ" "Μαρ" "Απρ" "Μαϊ" "Ιουν" "Ιουλ" "Αυγ" "Σεπ" "Οκτ" "Νοε" "Δεκ") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Κυριακή" "Δευτέρα" "Τρίτη" "Τετάρτη" "Πέμπτη" "Παρασκευή" "Σάββατο") + :SHORT-WEEKDAYS '("Κυρ" "Δευ" "Τρι" "Τετ" "Πεμ" "Παρ" "Σαβ") + :ERAS '("π.Χ." "μ.Χ.")))) + +(setf (gethash "ar_QA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "QAR") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "mk_MK" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "MKD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануари" "февруари" "март" "април" "мај" "јуни" "јули" "август" "септември" "октомври" "ноември" "декември") + :SHORT-MONTHS '("јан." "фев." "мар." "апр." "мај." "јун." "јул." "авг." "септ." "окт." "ноем." "декем.") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("недела" "понеделник" "вторник" "среда" "четврток" "петок" "сабота") + :SHORT-WEEKDAYS '("нед." "пон." "вт." "сре." "чет." "пет." "саб.") + :ERAS '("пр.н.е." "ае.")))) + +(setf (gethash "sv" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januari" "februari" "mars" "april" "maj" "juni" "juli" "augusti" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "maj" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("söndag" "måndag" "tisdag" "onsdag" "torsdag" "fredag" "lördag") + :SHORT-WEEKDAYS '("sö" "må" "ti" "on" "to" "fr" "lö") + :ERAS '("BC" "AD")))) + +(setf (gethash "de_CH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\' :DECIMAL-SEPARATOR #\. "CHF") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") + :SHORT-MONTHS '("Jan" "Feb" "Mrz" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag") + :SHORT-WEEKDAYS '("So" "Mo" "Di" "Mi" "Do" "Fr" "Sa") + :ERAS '("v. Chr." "n. Chr.")))) + +(setf (gethash "en_US" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "USD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "fi_FI" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("tammikuu" "helmikuu" "maaliskuu" "huhtikuu" "toukokuu" "kesäkuu" "heinäkuu" "elokuu" "syyskuu" "lokakuu" "marraskuu" "joulukuu") + :SHORT-MONTHS '("tammi" "helmi" "maalis" "huhti" "touko" "kesä" "heinä" "elo" "syys" "loka" "marras" "joulu") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("sunnuntai" "maanantai" "tiistai" "keskiviikko" "torstai" "perjantai" "lauantai") + :SHORT-WEEKDAYS '("su" "ma" "ti" "ke" "to" "pe" "la") + :ERAS '("BC" "AD")))) + +(setf (gethash "is" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janúar" "febrúar" "mars" "apríl" "maí" "júní" "júlí" "ágúst" "september" "október" "nóvember" "desember") + :SHORT-MONTHS '("jan." "feb." "mar." "apr." "maí" "jún." "júl." "ágú." "sep." "okt." "nóv." "des.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("sunnudagur" "mánudagur" "þriðjudagur" "miðvikudagur" "fimmtudagur" "föstudagur" "laugardagur") + :SHORT-WEEKDAYS '("sun." "mán." "þri." "mið." "fim." "fös." "lau.") + :ERAS '("BC" "AD")))) + +(setf (gethash "cs" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("dop." "odp.") + :MONTHS '("leden" "únor" "březen" "duben" "květen" "červen" "červenec" "srpen" "září" "říjen" "listopad" "prosinec") + :SHORT-MONTHS '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Neděle" "Pondělí" "Úterý" "Středa" "Čtvrtek" "Pátek" "Sobota") + :SHORT-WEEKDAYS '("Ne" "Po" "Út" "St" "Čt" "Pá" "So") + :ERAS '("př.Kr." "po Kr.")))) + +(setf (gethash "en_MT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "MTL") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "sl_SI" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "marec" "april" "maj" "junij" "julij" "avgust" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "maj" "jun" "jul" "avg" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Nedelja" "Ponedeljek" "Torek" "Sreda" "Četrtek" "Petek" "Sobota") + :SHORT-WEEKDAYS '("Ned" "Pon" "Tor" "Sre" "Čet" "Pet" "Sob") + :ERAS '("pr.n.š." "po Kr.")))) + +(setf (gethash "sk_SK" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "SKK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("január" "február" "marec" "apríl" "máj" "jún" "júl" "august" "september" "október" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "máj" "jún" "júl" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Nedeľa" "Pondelok" "Utorok" "Streda" "Štvrtok" "Piatok" "Sobota") + :SHORT-WEEKDAYS '("Ne" "Po" "Ut" "St" "Št" "Pi" "So") + :ERAS '("pred n.l." "n.l.")))) + +(setf (gethash "it" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("gennaio" "febbraio" "marzo" "aprile" "maggio" "giugno" "luglio" "agosto" "settembre" "ottobre" "novembre" "dicembre") + :SHORT-MONTHS '("gen" "feb" "mar" "apr" "mag" "giu" "lug" "ago" "set" "ott" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domenica" "lunedì" "martedì" "mercoledì" "giovedì" "venerdì" "sabato") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mer" "gio" "ven" "sab") + :ERAS '("BC" "dopo Cristo")))) + +(setf (gethash "tr_TR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "TRY") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Ocak" "Şubat" "Mart" "Nisan" "Mayıs" "Haziran" "Temmuz" "Ağustos" "Eylül" "Ekim" "Kasım" "Aralık") + :SHORT-MONTHS '("Oca" "Şub" "Mar" "Nis" "May" "Haz" "Tem" "Ağu" "Eyl" "Eki" "Kas" "Ara") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Pazar" "Pazartesi" "Salı" "Çarşamba" "Perşembe" "Cuma" "Cumartesi") + :SHORT-WEEKDAYS '("Paz" "Pzt" "Sal" "Çar" "Per" "Cum" "Cmt") + :ERAS '("BC" "AD")))) + +(setf (gethash "zh" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("上午" "下午") + :MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :SHORT-MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :SHORT-WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :ERAS '("公元前" "公元")))) + +(setf (gethash "th" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("ก่อนเที่ยง" "หลังเที่ยง") + :MONTHS '("มกราคม" "กุมภาพันธ์" "มีนาคม" "เมษายน" "พฤษภาคม" "มิถุนายน" "กรกฎาคม" "สิงหาคม" "กันยายน" "ตุลาคม" "พฤศจิกายน" "ธันวาคม") + :SHORT-MONTHS '("ม.ค." "ก.พ." "มี.ค." "เม.ย." "พ.ค." "มิ.ย." "ก.ค." "ส.ค." "ก.ย." "ต.ค." "พ.ย." "ธ.ค.") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("วันอาทิตย์" "วันจันทร์" "วันอังคาร" "วันพุธ" "วันพฤหัสบดี" "วันศุกร์" "วันเสาร์") + :SHORT-WEEKDAYS '("อา." "จ." "อ." "พ." "พฤ." "ศ." "ส.") + :ERAS '("ปีก่อนคริสต์กาลที่" "ค.ศ.")))) + +(setf (gethash "ar_SA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "SAR") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "no" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "mars" "april" "mai" "juni" "juli" "august" "september" "oktober" "november" "desember") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "mai" "jun" "jul" "aug" "sep" "okt" "nov" "des") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("søndag" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag") + :SHORT-WEEKDAYS '("sø" "ma" "ti" "on" "to" "fr" "lø") + :ERAS '("BC" "AD")))) + +(setf (gethash "en_GB" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "GBP") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "sr_CS" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "CSD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануар" "фебруар" "март" "април" "мај" "јун" "јул" "август" "септембар" "октобар" "новембар" "децембар") + :SHORT-MONTHS '("јан" "феб" "мар" "апр" "мај" "јун" "јул" "авг" "сеп" "окт" "нов" "дец") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("недеља" "понедељак" "уторак" "среда" "четвртак" "петак" "субота") + :SHORT-WEEKDAYS '("нед" "пон" "уто" "сре" "чет" "пет" "суб") + :ERAS '("п. н. е." "н. е")))) + +(setf (gethash "lt" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Sausio" "Vasario" "Kovo" "Balandžio" "Gegužės" "Birželio" "Liepos" "Rugpjūčio" "Rugsėjo" "Spalio" "Lapkričio" "Gruodžio") + :SHORT-MONTHS '("Sau" "Vas" "Kov" "Bal" "Geg" "Bir" "Lie" "Rgp" "Rgs" "Spa" "Lap" "Grd") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sekmadienis" "Pirmadienis" "Antradienis" "Trečiadienis" "Ketvirtadienis" "Penktadienis" "Šeštadienis") + :SHORT-WEEKDAYS '("Sk" "Pr" "An" "Tr" "Kt" "Pn" "Št") + :ERAS '("pr.Kr." "po.Kr.")))) + +(setf (gethash "ro" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("ianuarie" "februarie" "martie" "aprilie" "mai" "iunie" "iulie" "august" "septembrie" "octombrie" "noiembrie" "decembrie") + :SHORT-MONTHS '("Ian" "Feb" "Mar" "Apr" "Mai" "Iun" "Iul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("duminică" "luni" "marţi" "miercuri" "joi" "vineri" "sîmbătă") + :SHORT-WEEKDAYS '("D" "L" "Ma" "Mi" "J" "V" "S") + :ERAS '("d.C." "î.d.C.")))) + +(setf (gethash "en_NZ" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "NZD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "no_NO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "NOK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "mars" "april" "mai" "juni" "juli" "august" "september" "oktober" "november" "desember") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "mai" "jun" "jul" "aug" "sep" "okt" "nov" "des") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("søndag" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag") + :SHORT-WEEKDAYS '("sø" "ma" "ti" "on" "to" "fr" "lø") + :ERAS '("BC" "AD")))) + +(setf (gethash "lt_LT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "LTL") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Sausio" "Vasario" "Kovo" "Balandžio" "Gegužės" "Birželio" "Liepos" "Rugpjūčio" "Rugsėjo" "Spalio" "Lapkričio" "Gruodžio") + :SHORT-MONTHS '("Sau" "Vas" "Kov" "Bal" "Geg" "Bir" "Lie" "Rgp" "Rgs" "Spa" "Lap" "Grd") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sekmadienis" "Pirmadienis" "Antradienis" "Trečiadienis" "Ketvirtadienis" "Penktadienis" "Šeštadienis") + :SHORT-WEEKDAYS '("Sk" "Pr" "An" "Tr" "Kt" "Pn" "Št") + :ERAS '("pr.Kr." "po.Kr.")))) + +(setf (gethash "es_NI" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "NIO") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "nl" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januari" "februari" "maart" "april" "mei" "juni" "juli" "augustus" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mrt" "apr" "mei" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("zondag" "maandag" "dinsdag" "woensdag" "donderdag" "vrijdag" "zaterdag") + :SHORT-WEEKDAYS '("zo" "ma" "di" "wo" "do" "vr" "za") + :ERAS '("BC" "AD")))) + +(setf (gethash "ga_IE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "EUR") + :DATE-FORMAT (list + :AMPM '("a.m." "p.m.") + :MONTHS '("Eanáir" "Feabhra" "Márta" "Aibreán" "Bealtaine" "Meitheamh" "Iúil" "Lúnasa" "Meán Fómhair" "Deireadh Fómhair" "Samhain" "Nollaig") + :SHORT-MONTHS '("Ean" "Feabh" "Márta" "Aib" "Beal" "Meith" "Iúil" "Lún" "MFómh" "DFómh" "Samh" "Noll") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Dé Domhnaigh" "Dé Luain" "Dé Máirt" "Dé Céadaoin" "Déardaoin" "Dé hAoine" "Dé Sathairn") + :SHORT-WEEKDAYS '("Domh" "Luan" "Máirt" "Céad" "Déar" "Aoine" "Sath") + :ERAS '("RC" "AD")))) + +(setf (gethash "fr_BE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvier" "février" "mars" "avril" "mai" "juin" "juillet" "août" "septembre" "octobre" "novembre" "décembre") + :SHORT-MONTHS '("janv." "févr." "mars" "avr." "mai" "juin" "juil." "août" "sept." "oct." "nov." "déc.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi") + :SHORT-WEEKDAYS '("dim." "lun." "mar." "mer." "jeu." "ven." "sam.") + :ERAS '("BC" "ap. J.-C.")))) + +(setf (gethash "es_ES" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_LB" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "LBP") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("كانون الثاني" "شباط" "آذار" "نيسان" "نوار" "حزيران" "تموز" "آب" "أيلول" "تشرين الأول" "تشرين الثاني" "كانون الأول") + :SHORT-MONTHS '("كانون الثاني" "شباط" "آذار" "نيسان" "نوار" "حزيران" "تموز" "آب" "أيلول" "تشرين الأول" "تشرين الثاني" "كانون الأول") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :ERAS '("ق.م" "م")))) + +(setf (gethash "ko" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("오전" "오후") + :MONTHS '("1월" "2월" "3월" "4월" "5월" "6월" "7월" "8월" "9월" "10월" "11월" "12월") + :SHORT-MONTHS '("1월" "2월" "3월" "4월" "5월" "6월" "7월" "8월" "9월" "10월" "11월" "12월") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("일요일" "월요일" "화요일" "수요일" "목요일" "금요일" "토요일") + :SHORT-WEEKDAYS '("일" "월" "화" "수" "목" "금" "토") + :ERAS '("BC" "AD")))) + +(setf (gethash "fr_CA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "CAD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvier" "février" "mars" "avril" "mai" "juin" "juillet" "août" "septembre" "octobre" "novembre" "décembre") + :SHORT-MONTHS '("janv." "févr." "mars" "avr." "mai" "juin" "juil." "août" "sept." "oct." "nov." "déc.") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi") + :SHORT-WEEKDAYS '("dim." "lun." "mar." "mer." "jeu." "ven." "sam.") + :ERAS '("BC" "ap. J.-C.")))) + +(setf (gethash "et_EE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "EEK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Jaanuar" "Veebruar" "Märts" "Aprill" "Mai" "Juuni" "Juuli" "August" "September" "Oktoober" "November" "Detsember") + :SHORT-MONTHS '("Jaan" "Veebr" "Märts" "Apr" "Mai" "Juuni" "Juuli" "Aug" "Sept" "Okt" "Nov" "Dets") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("pühapäev" "esmaspäev" "teisipäev" "kolmapäev" "neljapäev" "reede" "laupäev") + :SHORT-WEEKDAYS '("P" "E" "T" "K" "N" "R" "L") + :ERAS '("e.m.a." "m.a.j.")))) + +(setf (gethash "ar_KW" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "KWD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "sr_RS" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "RSD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануар" "фебруар" "март" "април" "мај" "јун" "јул" "август" "септембар" "октобар" "новембар" "децембар") + :SHORT-MONTHS '("јан" "феб" "мар" "апр" "мај" "јун" "јул" "авг" "сеп" "окт" "нов" "дец") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("недеља" "понедељак" "уторак" "среда" "четвртак" "петак" "субота") + :SHORT-WEEKDAYS '("нед" "пон" "уто" "сре" "чет" "пет" "суб") + :ERAS '("п. н. е." "н. е")))) + +(setf (gethash "es_US" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "USD") + :DATE-FORMAT (list + :AMPM '("a.m." "p.m.") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("a.C." "d.C.")))) + +(setf (gethash "es_MX" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "MXN") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_SD" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "SDD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "in_ID" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "IDR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januari" "Februari" "Maret" "April" "Mei" "Juni" "Juli" "Agustus" "September" "Oktober" "November" "Desember") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "Mei" "Jun" "Jul" "Agu" "Sep" "Okt" "Nov" "Des") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Minggu" "Senin" "Selasa" "Rabu" "Kamis" "Jumat" "Sabtu") + :SHORT-WEEKDAYS '("Min" "Sen" "Sel" "Rab" "Kam" "Jum" "Sab") + :ERAS '("BCE" "CE")))) + +(setf (gethash "ru" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Январь" "Февраль" "Март" "Апрель" "Май" "Июнь" "Июль" "Август" "Сентябрь" "Октябрь" "Ноябрь" "Декабрь") + :SHORT-MONTHS '("янв" "фев" "мар" "апр" "май" "июн" "июл" "авг" "сен" "окт" "ноя" "дек") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("воскресенье" "понедельник" "вторник" "среда" "четверг" "пятница" "суббота") + :SHORT-WEEKDAYS '("Вс" "Пн" "Вт" "Ср" "Чт" "Пт" "Сб") + :ERAS '("до н.э." "н.э.")))) + +(setf (gethash "lv" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvāris" "februāris" "marts" "aprīlis" "maijs" "jūnijs" "jūlijs" "augusts" "septembris" "oktobris" "novembris" "decembris") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "Maijs" "Jūn" "Jūl" "Aug" "Sep" "Okt" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("svētdiena" "pirmdiena" "otrdiena" "trešdiena" "ceturtdiena" "piektdiena" "sestdiena") + :SHORT-WEEKDAYS '("Sv" "P" "O" "T" "C" "Pk" "S") + :ERAS '("pmē" "mē")))) + +(setf (gethash "es_UY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "UYU") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "lv_LV" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "LVL") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvāris" "februāris" "marts" "aprīlis" "maijs" "jūnijs" "jūlijs" "augusts" "septembris" "oktobris" "novembris" "decembris") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "Maijs" "Jūn" "Jūl" "Aug" "Sep" "Okt" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("svētdiena" "pirmdiena" "otrdiena" "trešdiena" "ceturtdiena" "piektdiena" "sestdiena") + :SHORT-WEEKDAYS '("Sv" "P" "O" "T" "C" "Pk" "S") + :ERAS '("pmē" "mē")))) + +(setf (gethash "iw" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("ינואר" "פברואר" "מרץ" "אפריל" "מאי" "יוני" "יולי" "אוגוסט" "ספטמבר" "אוקטובר" "נובמבר" "דצמבר") + :SHORT-MONTHS '("ינו" "פבר" "מרץ" "אפר" "מאי" "יונ" "יול" "אוג" "ספט" "אוק" "נוב" "דצמ") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("יום ראשון" "יום שני" "יום שלישי" "יום רביעי" "יום חמישי" "יום שישי" "שבת") + :SHORT-WEEKDAYS '("א" "ב" "ג" "ד" "ה" "ו" "ש") + :ERAS '("לסה"נ" "לפסה"נ")))) + +(setf (gethash "pt_BR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "BRL") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Janeiro" "Fevereiro" "Março" "Abril" "Maio" "Junho" "Julho" "Agosto" "Setembro" "Outubro" "Novembro" "Dezembro") + :SHORT-MONTHS '("Jan" "Fev" "Mar" "Abr" "Mai" "Jun" "Jul" "Ago" "Set" "Out" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Domingo" "Segunda-feira" "Terça-feira" "Quarta-feira" "Quinta-feira" "Sexta-feira" "Sábado") + :SHORT-WEEKDAYS '("Dom" "Seg" "Ter" "Qua" "Qui" "Sex" "Sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_SY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "SYP") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("كانون الثاني" "شباط" "آذار" "نيسان" "نواران" "حزير" "تموز" "آب" "أيلول" "تشرين الأول" "تشرين الثاني" "كانون الأول") + :SHORT-MONTHS '("كانون الثاني" "شباط" "آذار" "نيسان" "نوار" "حزيران" "تموز" "آب" "أيلول" "تشرين الأول" "تشرين الثاني" "كانون الأول") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :ERAS '("ق.م" "م")))) + +(setf (gethash "hr" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("siječanj" "veljača" "ožujak" "travanj" "svibanj" "lipanj" "srpanj" "kolovoz" "rujan" "listopad" "studeni" "prosinac") + :SHORT-MONTHS '("sij" "vel" "ožu" "tra" "svi" "lip" "srp" "kol" "ruj" "lis" "stu" "pro") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("nedjelja" "ponedjeljak" "utorak" "srijeda" "četvrtak" "petak" "subota") + :SHORT-WEEKDAYS '("ned" "pon" "uto" "sri" "čet" "pet" "sub") + :ERAS '("BC" "AD")))) + +(setf (gethash "et" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Jaanuar" "Veebruar" "Märts" "Aprill" "Mai" "Juuni" "Juuli" "August" "September" "Oktoober" "November" "Detsember") + :SHORT-MONTHS '("Jaan" "Veebr" "Märts" "Apr" "Mai" "Juuni" "Juuli" "Aug" "Sept" "Okt" "Nov" "Dets") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("pühapäev" "esmaspäev" "teisipäev" "kolmapäev" "neljapäev" "reede" "laupäev") + :SHORT-WEEKDAYS '("P" "E" "T" "K" "N" "R" "L") + :ERAS '("e.m.a." "m.a.j.")))) + +(setf (gethash "es_DO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "DOP") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "fr_CH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\' :DECIMAL-SEPARATOR #\. "CHF") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvier" "février" "mars" "avril" "mai" "juin" "juillet" "août" "septembre" "octobre" "novembre" "décembre") + :SHORT-MONTHS '("janv." "févr." "mars" "avr." "mai" "juin" "juil." "août" "sept." "oct." "nov." "déc.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi") + :SHORT-WEEKDAYS '("dim." "lun." "mar." "mer." "jeu." "ven." "sam.") + :ERAS '("BC" "ap. J.-C.")))) + +(setf (gethash "hi_IN" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "INR") + :DATE-FORMAT (list + :AMPM '("पूर्वाह्न" "अपराह्न") + :MONTHS '("जनवरी" "फ़रवरी" "मार्च" "अप्रैल" "मई" "जून" "जुलाई" "अगस्त" "सितंबर" "अक्‍तूबर" "नवंबर" "दिसंबर") + :SHORT-MONTHS '("जनवरी" "फ़रवरी" "मार्च" "अप्रैल" "मई" "जून" "जुलाई" "अगस्त" "सितंबर" "अक्‍तूबर" "नवंबर" "दिसंबर") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("रविवार" "सोमवार" "मंगलवार" "बुधवार" "गुरुवार" "शुक्रवार" "शनिवार") + :SHORT-WEEKDAYS '("रवि" "सोम" "मंगल" "बुध" "गुरु" "शुक्र" "शनि") + :ERAS '("ईसापूर्व" "सन")))) + +(setf (gethash "es_VE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "VEB") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_BH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "BHD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "en_PH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "PHP") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_TN" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "TND") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "fi" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("tammikuu" "helmikuu" "maaliskuu" "huhtikuu" "toukokuu" "kesäkuu" "heinäkuu" "elokuu" "syyskuu" "lokakuu" "marraskuu" "joulukuu") + :SHORT-MONTHS '("tammi" "helmi" "maalis" "huhti" "touko" "kesä" "heinä" "elo" "syys" "loka" "marras" "joulu") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("sunnuntai" "maanantai" "tiistai" "keskiviikko" "torstai" "perjantai" "lauantai") + :SHORT-WEEKDAYS '("su" "ma" "ti" "ke" "to" "pe" "la") + :ERAS '("BC" "AD")))) + +(setf (gethash "de_AT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Jänner" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") + :SHORT-MONTHS '("Jän" "Feb" "Mär" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag") + :SHORT-WEEKDAYS '("So" "Mo" "Di" "Mi" "Do" "Fr" "Sa") + :ERAS '("v. Chr." "n. Chr.")))) + +(setf (gethash "es" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "nl_NL" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januari" "februari" "maart" "april" "mei" "juni" "juli" "augustus" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mrt" "apr" "mei" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("zondag" "maandag" "dinsdag" "woensdag" "donderdag" "vrijdag" "zaterdag") + :SHORT-WEEKDAYS '("zo" "ma" "di" "wo" "do" "vr" "za") + :ERAS '("BC" "AD")))) + +(setf (gethash "es_EC" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "USD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "zh_TW" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "TWD") + :DATE-FORMAT (list + :AMPM '("上午" "下午") + :MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :SHORT-MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :SHORT-WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :ERAS '("西元前" "西元")))) + +(setf (gethash "ar_JO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "JOD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("كانون الثاني" "شباط" "آذار" "نيسان" "نوار" "حزيران" "تموز" "آب" "أيلول" "تشرين الأول" "تشرين الثاني" "كانون الأول") + :SHORT-MONTHS '("كانون الثاني" "شباط" "آذار" "نيسان" "نوار" "حزيران" "تموز" "آب" "أيلول" "تشرين الأول" "تشرين الثاني" "كانون الأول") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :ERAS '("ق.م" "م")))) + +(setf (gethash "be" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("студзеня" "лютага" "сакавіка" "красавіка" "мая" "чрвеня" "ліпеня" "жніўня" "верасня" "кастрычніка" "листапада" "снежня") + :SHORT-MONTHS '("стд" "лют" "скв" "крс" "май" "чрв" "лпн" "жнв" "врс" "кст" "лст" "снж") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("нядзеля" "панядзелак" "аўторак" "серада" "чацвер" "пятніца" "субота") + :SHORT-WEEKDAYS '("нд" "пн" "ат" "ср" "чц" "пт" "сб") + :ERAS '("да н.е." "н.е.")))) + +(setf (gethash "is_IS" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "ISK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janúar" "febrúar" "mars" "apríl" "maí" "júní" "júlí" "ágúst" "september" "október" "nóvember" "desember") + :SHORT-MONTHS '("jan." "feb." "mar." "apr." "maí" "jún." "júl." "ágú." "sep." "okt." "nóv." "des.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("sunnudagur" "mánudagur" "þriðjudagur" "miðvikudagur" "fimmtudagur" "föstudagur" "laugardagur") + :SHORT-WEEKDAYS '("sun." "mán." "þri." "mið." "fim." "fös." "lau.") + :ERAS '("BC" "AD")))) + +(setf (gethash "es_CO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "COP") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "es_CR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "CRC") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "es_CL" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "CLP") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_EG" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "EGP") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "en_ZA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "ZAR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "th_TH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "THB") + :DATE-FORMAT (list + :AMPM '("ก่อนเที่ยง" "หลังเที่ยง") + :MONTHS '("มกราคม" "กุมภาพันธ์" "มีนาคม" "เมษายน" "พฤษภาคม" "มิถุนายน" "กรกฎาคม" "สิงหาคม" "กันยายน" "ตุลาคม" "พฤศจิกายน" "ธันวาคม") + :SHORT-MONTHS '("ม.ค." "ก.พ." "มี.ค." "เม.ย." "พ.ค." "มิ.ย." "ก.ค." "ส.ค." "ก.ย." "ต.ค." "พ.ย." "ธ.ค.") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("วันอาทิตย์" "วันจันทร์" "วันอังคาร" "วันพุธ" "วันพฤหัสบดี" "วันศุกร์" "วันเสาร์") + :SHORT-WEEKDAYS '("อา." "จ." "อ." "พ." "พฤ." "ศ." "ส.") + :ERAS '("ปีก่อนคริสต์กาลที่" "ค.ศ.")))) + +(setf (gethash "el_GR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("πμ" "μμ") + :MONTHS '("Ιανουάριος" "Φεβρουάριος" "Μάρτιος" "Απρίλιος" "Μάϊος" "Ιούνιος" "Ιούλιος" "Αύγουστος" "Σεπτέμβριος" "Οκτώβριος" "Νοέμβριος" "Δεκέμβριος") + :SHORT-MONTHS '("Ιαν" "Φεβ" "Μαρ" "Απρ" "Μαϊ" "Ιουν" "Ιουλ" "Αυγ" "Σεπ" "Οκτ" "Νοε" "Δεκ") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Κυριακή" "Δευτέρα" "Τρίτη" "Τετάρτη" "Πέμπτη" "Παρασκευή" "Σάββατο") + :SHORT-WEEKDAYS '("Κυρ" "Δευ" "Τρι" "Τετ" "Πεμ" "Παρ" "Σαβ") + :ERAS '("BC" "AD")))) + +(setf (gethash "it_IT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("gennaio" "febbraio" "marzo" "aprile" "maggio" "giugno" "luglio" "agosto" "settembre" "ottobre" "novembre" "dicembre") + :SHORT-MONTHS '("gen" "feb" "mar" "apr" "mag" "giu" "lug" "ago" "set" "ott" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domenica" "lunedì" "martedì" "mercoledì" "giovedì" "venerdì" "sabato") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mer" "gio" "ven" "sab") + :ERAS '("BC" "dopo Cristo")))) + +(setf (gethash "ca" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("gener" "febrer" "març" "abril" "maig" "juny" "juliol" "agost" "setembre" "octubre" "novembre" "desembre") + :SHORT-MONTHS '("gen." "feb." "març" "abr." "maig" "juny" "jul." "ag." "set." "oct." "nov." "des.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("diumenge" "dilluns" "dimarts" "dimecres" "dijous" "divendres" "dissabte") + :SHORT-WEEKDAYS '("dg." "dl." "dt." "dc." "dj." "dv." "ds.") + :ERAS '("BC" "AD")))) + +(setf (gethash "hu_HU" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "HUF") + :DATE-FORMAT (list + :AMPM '("DE" "DU") + :MONTHS '("január" "február" "március" "április" "május" "június" "július" "augusztus" "szeptember" "október" "november" "december") + :SHORT-MONTHS '("jan." "febr." "márc." "ápr." "máj." "jún." "júl." "aug." "szept." "okt." "nov." "dec.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("vasárnap" "hétfő" "kedd" "szerda" "csütörtök" "péntek" "szombat") + :SHORT-WEEKDAYS '("V" "H" "K" "Sze" "Cs" "P" "Szo") + :ERAS '("i.e." "i.u.")))) + +(setf (gethash "fr" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvier" "février" "mars" "avril" "mai" "juin" "juillet" "août" "septembre" "octobre" "novembre" "décembre") + :SHORT-MONTHS '("janv." "févr." "mars" "avr." "mai" "juin" "juil." "août" "sept." "oct." "nov." "déc.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi") + :SHORT-WEEKDAYS '("dim." "lun." "mar." "mer." "jeu." "ven." "sam.") + :ERAS '("BC" "ap. J.-C.")))) + +(setf (gethash "en_IE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "uk_UA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "UAH") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("січня" "лютого" "березня" "квітня" "травня" "червня" "липня" "серпня" "вересня" "жовтня" "листопада" "грудня") + :SHORT-MONTHS '("січ" "лют" "бер" "квіт" "трав" "черв" "лип" "серп" "вер" "жовт" "лист" "груд") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("неділя" "понеділок" "вівторок" "середа" "четвер" "п'ятниця" "субота") + :SHORT-WEEKDAYS '("нд" "пн" "вт" "ср" "чт" "пт" "сб") + :ERAS '("до н.е." "після н.е.")))) + +(setf (gethash "pl_PL" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "PLN") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("styczeń" "luty" "marzec" "kwiecień" "maj" "czerwiec" "lipiec" "sierpień" "wrzesień" "październik" "listopad" "grudzień") + :SHORT-MONTHS '("sty" "lut" "mar" "kwi" "maj" "cze" "lip" "sie" "wrz" "paź" "lis" "gru") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("niedziela" "poniedziałek" "wtorek" "środa" "czwartek" "piątek" "sobota") + :SHORT-WEEKDAYS '("N" "Pn" "Wt" "Śr" "Cz" "Pt" "So") + :ERAS '("p.n.e." "n.e.")))) + +(setf (gethash "fr_LU" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvier" "février" "mars" "avril" "mai" "juin" "juillet" "août" "septembre" "octobre" "novembre" "décembre") + :SHORT-MONTHS '("janv." "févr." "mars" "avr." "mai" "juin" "juil." "août" "sept." "oct." "nov." "déc.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi") + :SHORT-WEEKDAYS '("dim." "lun." "mar." "mer." "jeu." "ven." "sam.") + :ERAS '("BC" "ap. J.-C.")))) + +(setf (gethash "nl_BE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januari" "februari" "maart" "april" "mei" "juni" "juli" "augustus" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mrt" "apr" "mei" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("zondag" "maandag" "dinsdag" "woensdag" "donderdag" "vrijdag" "zaterdag") + :SHORT-WEEKDAYS '("zo" "ma" "di" "wo" "do" "vr" "za") + :ERAS '("BC" "AD")))) + +(setf (gethash "en_IN" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "INR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "ca_ES" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("gener" "febrer" "març" "abril" "maig" "juny" "juliol" "agost" "setembre" "octubre" "novembre" "desembre") + :SHORT-MONTHS '("gen." "feb." "març" "abr." "maig" "juny" "jul." "ag." "set." "oct." "nov." "des.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("diumenge" "dilluns" "dimarts" "dimecres" "dijous" "divendres" "dissabte") + :SHORT-WEEKDAYS '("dg." "dl." "dt." "dc." "dj." "dv." "ds.") + :ERAS '("BC" "AD")))) + +(setf (gethash "ar_MA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "MAD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "es_BO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "BOB") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "en_AU" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "AUD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "sr" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануар" "фебруар" "март" "април" "мај" "јун" "јул" "август" "септембар" "октобар" "новембар" "децембар") + :SHORT-MONTHS '("јан" "феб" "мар" "апр" "мај" "јун" "јул" "авг" "сеп" "окт" "нов" "дец") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("недеља" "понедељак" "уторак" "среда" "четвртак" "петак" "субота") + :SHORT-WEEKDAYS '("нед" "пон" "уто" "сре" "чет" "пет" "суб") + :ERAS '("п. н. е." "н. е")))) + +(setf (gethash "zh_SG" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "SGD") + :DATE-FORMAT (list + :AMPM '("上午" "下午") + :MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :SHORT-MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :SHORT-WEEKDAYS '("周日" "周一" "周二" "周三" "周四" "周五" "周六") + :ERAS '("公元前" "公元")))) + +(setf (gethash "pt" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Janeiro" "Fevereiro" "Março" "Abril" "Maio" "Junho" "Julho" "Agosto" "Setembro" "Outubro" "Novembro" "Dezembro") + :SHORT-MONTHS '("Jan" "Fev" "Mar" "Abr" "Mai" "Jun" "Jul" "Ago" "Set" "Out" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Domingo" "Segunda-feira" "Terça-feira" "Quarta-feira" "Quinta-feira" "Sexta-feira" "Sábado") + :SHORT-WEEKDAYS '("Dom" "Seg" "Ter" "Qua" "Qui" "Sex" "Sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "uk" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("січня" "лютого" "березня" "квітня" "травня" "червня" "липня" "серпня" "вересня" "жовтня" "листопада" "грудня") + :SHORT-MONTHS '("січ" "лют" "бер" "квіт" "трав" "черв" "лип" "серп" "вер" "жовт" "лист" "груд") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("неділя" "понеділок" "вівторок" "середа" "четвер" "п'ятниця" "субота") + :SHORT-WEEKDAYS '("нд" "пн" "вт" "ср" "чт" "пт" "сб") + :ERAS '("до н.е." "після н.е.")))) + +(setf (gethash "es_SV" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "SVC") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "ru_RU" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "RUB") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Январь" "Февраль" "Март" "Апрель" "Май" "Июнь" "Июль" "Август" "Сентябрь" "Октябрь" "Ноябрь" "Декабрь") + :SHORT-MONTHS '("янв" "фев" "мар" "апр" "май" "июн" "июл" "авг" "сен" "окт" "ноя" "дек") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("воскресенье" "понедельник" "вторник" "среда" "четверг" "пятница" "суббота") + :SHORT-WEEKDAYS '("Вс" "Пн" "Вт" "Ср" "Чт" "Пт" "Сб") + :ERAS '("до н.э." "н.э.")))) + +(setf (gethash "ko_KR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "KRW") + :DATE-FORMAT (list + :AMPM '("오전" "오후") + :MONTHS '("1월" "2월" "3월" "4월" "5월" "6월" "7월" "8월" "9월" "10월" "11월" "12월") + :SHORT-MONTHS '("1월" "2월" "3월" "4월" "5월" "6월" "7월" "8월" "9월" "10월" "11월" "12월") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("일요일" "월요일" "화요일" "수요일" "목요일" "금요일" "토요일") + :SHORT-WEEKDAYS '("일" "월" "화" "수" "목" "금" "토") + :ERAS '("BC" "AD")))) + +(setf (gethash "vi" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("SA" "CH") + :MONTHS '("tháng một" "tháng hai" "tháng ba" "tháng tư" "tháng năm" "tháng sáu" "tháng bảy" "tháng tám" "tháng chín" "tháng mười" "tháng mười một" "tháng mười hai") + :SHORT-MONTHS '("thg 1" "thg 2" "thg 3" "thg 4" "thg 5" "thg 6" "thg 7" "thg 8" "thg 9" "thg 10" "thg 11" "thg 12") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Chủ nhật" "Thứ hai" "Thứ ba" "Thứ tư" "Thứ năm" "Thứ sáu" "Thứ bảy") + :SHORT-WEEKDAYS '("CN" "Th 2" "Th 3" "Th 4" "Th 5" "Th 6" "Th 7") + :ERAS '("tr. CN" "sau CN")))) + +(setf (gethash "ar_DZ" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "DZD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "vi_VN" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "VND") + :DATE-FORMAT (list + :AMPM '("SA" "CH") + :MONTHS '("tháng một" "tháng hai" "tháng ba" "tháng tư" "tháng năm" "tháng sáu" "tháng bảy" "tháng tám" "tháng chín" "tháng mười" "tháng mười một" "tháng mười hai") + :SHORT-MONTHS '("thg 1" "thg 2" "thg 3" "thg 4" "thg 5" "thg 6" "thg 7" "thg 8" "thg 9" "thg 10" "thg 11" "thg 12") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Chủ nhật" "Thứ hai" "Thứ ba" "Thứ tư" "Thứ năm" "Thứ sáu" "Thứ bảy") + :SHORT-WEEKDAYS '("CN" "Th 2" "Th 3" "Th 4" "Th 5" "Th 6" "Th 7") + :ERAS '("tr. CN" "sau CN")))) + +(setf (gethash "sr_ME" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("јануар" "фебруар" "март" "април" "мај" "јун" "јул" "август" "септембар" "октобар" "новембар" "децембар") + :SHORT-MONTHS '("јан" "феб" "мар" "апр" "мај" "јун" "јул" "авг" "сеп" "окт" "нов" "дец") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("недеља" "понедељак" "уторак" "среда" "четвртак" "петак" "субота") + :SHORT-WEEKDAYS '("нед" "пон" "уто" "сре" "чет" "пет" "суб") + :ERAS '("п. н. е." "н. е")))) + +(setf (gethash "sq" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("PD" "MD") + :MONTHS '("janar" "shkurt" "mars" "prill" "maj" "qershor" "korrik" "gusht" "shtator" "tetor" "nëntor" "dhjetor") + :SHORT-MONTHS '("Jan" "Shk" "Mar" "Pri" "Maj" "Qer" "Kor" "Gsh" "Sht" "Tet" "Nën" "Dhj") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("e diel" "e hënë" "e martë" "e mërkurë" "e enjte" "e premte" "e shtunë") + :SHORT-WEEKDAYS '("Die" "Hën" "Mar" "Mër" "Enj" "Pre" "Sht") + :ERAS '("p.e.r." "n.e.r.")))) + +(setf (gethash "ar_LY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "LYD") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "ar" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "zh_CN" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "CNY") + :DATE-FORMAT (list + :AMPM '("上午" "下午") + :MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :SHORT-MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :SHORT-WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :ERAS '("公元前" "公元")))) + +(setf (gethash "be_BY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "BYR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("студзеня" "лютага" "сакавіка" "красавіка" "мая" "чрвеня" "ліпеня" "жніўня" "верасня" "кастрычніка" "листапада" "снежня") + :SHORT-MONTHS '("стд" "лют" "скв" "крс" "май" "чрв" "лпн" "жнв" "врс" "кст" "лст" "снж") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("нядзеля" "панядзелак" "аўторак" "серада" "чацвер" "пятніца" "субота") + :SHORT-WEEKDAYS '("нд" "пн" "ат" "ср" "чц" "пт" "сб") + :ERAS '("да н.е." "н.е.")))) + +(setf (gethash "zh_HK" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "HKD") + :DATE-FORMAT (list + :AMPM '("上午" "下午") + :MONTHS '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") + :SHORT-MONTHS '("1月" "2月" "3月" "4月" "5月" "6月" "7月" "8月" "9月" "10月" "11月" "12月") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("星期日" "星期一" "星期二" "星期三" "星期四" "星期五" "星期六") + :SHORT-WEEKDAYS '("日" "一" "二" "三" "四" "五" "六") + :ERAS '("西元前" "西元")))) + +(setf (gethash "ja" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("午前" "午後") + :MONTHS '("1月" "2月" "3月" "4月" "5月" "6月" "7月" "8月" "9月" "10月" "11月" "12月") + :SHORT-MONTHS '("1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("日曜日" "月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日") + :SHORT-WEEKDAYS '("日" "月" "火" "水" "木" "金" "土") + :ERAS '("紀元前" "西暦")))) + +(setf (gethash "iw_IL" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "ILS") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("ינואר" "פברואר" "מרץ" "אפריל" "מאי" "יוני" "יולי" "אוגוסט" "ספטמבר" "אוקטובר" "נובמבר" "דצמבר") + :SHORT-MONTHS '("ינו" "פבר" "מרץ" "אפר" "מאי" "יונ" "יול" "אוג" "ספט" "אוק" "נוב" "דצמ") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("יום ראשון" "יום שני" "יום שלישי" "יום רביעי" "יום חמישי" "יום שישי" "שבת") + :SHORT-WEEKDAYS '("א" "ב" "ג" "ד" "ה" "ו" "ש") + :ERAS '("לסה"נ" "לפסה"נ")))) + +(setf (gethash "bg_BG" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "BGN") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Януари" "Февруари" "Март" "Април" "Май" "Юни" "Юли" "Август" "Септември" "Октомври" "Ноември" "Декември") + :SHORT-MONTHS '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Неделя" "Понеделник" "Вторник" "Сряда" "Четвъртък" "Петък" "Събота") + :SHORT-WEEKDAYS '("Нд" "Пн" "Вт" "Ср" "Чт" "Пт" "Сб") + :ERAS '("пр.н.е." "н.е.")))) + +(setf (gethash "in" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januari" "Februari" "Maret" "April" "Mei" "Juni" "Juli" "Agustus" "September" "Oktober" "November" "Desember") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "Mei" "Jun" "Jul" "Agu" "Sep" "Okt" "Nov" "Des") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Minggu" "Senin" "Selasa" "Rabu" "Kamis" "Jumat" "Sabtu") + :SHORT-WEEKDAYS '("Min" "Sen" "Sel" "Rab" "Kam" "Jum" "Sab") + :ERAS '("BCE" "CE")))) + +(setf (gethash "mt_MT" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "MTL") + :DATE-FORMAT (list + :AMPM '("QN" "WN") + :MONTHS '("Jannar" "Frar" "Marzu" "April" "Mejju" "Ġunju" "Lulju" "Awissu" "Settembru" "Ottubru" "Novembru" "Diċembru") + :SHORT-MONTHS '("Jan" "Fra" "Mar" "Apr" "Mej" "Ġun" "Lul" "Awi" "Set" "Ott" "Nov" "Diċ") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Il-Ħadd" "It-Tnejn" "It-Tlieta" "L-Erbgħa" "Il-Ħamis" "Il-Ġimgħa" "Is-Sibt") + :SHORT-WEEKDAYS '("Ħad" "Tne" "Tli" "Erb" "Ħam" "Ġim" "Sib") + :ERAS '("QK" "WK")))) + +(setf (gethash "es_PY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "PYG") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "sl" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "marec" "april" "maj" "junij" "julij" "avgust" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "maj" "jun" "jul" "avg" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Nedelja" "Ponedeljek" "Torek" "Sreda" "Četrtek" "Petek" "Sobota") + :SHORT-WEEKDAYS '("Ned" "Pon" "Tor" "Sre" "Čet" "Pet" "Sob") + :ERAS '("pr.n.š." "po Kr.")))) + +(setf (gethash "fr_FR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("janvier" "février" "mars" "avril" "mai" "juin" "juillet" "août" "septembre" "octobre" "novembre" "décembre") + :SHORT-MONTHS '("janv." "févr." "mars" "avr." "mai" "juin" "juil." "août" "sept." "oct." "nov." "déc.") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi") + :SHORT-WEEKDAYS '("dim." "lun." "mar." "mer." "jeu." "ven." "sam.") + :ERAS '("BC" "ap. J.-C.")))) + +(setf (gethash "cs_CZ" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "CZK") + :DATE-FORMAT (list + :AMPM '("dop." "odp.") + :MONTHS '("leden" "únor" "březen" "duben" "květen" "červen" "červenec" "srpen" "září" "říjen" "listopad" "prosinec") + :SHORT-MONTHS '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Neděle" "Pondělí" "Úterý" "Středa" "Čtvrtek" "Pátek" "Sobota") + :SHORT-WEEKDAYS '("Ne" "Po" "Út" "St" "Čt" "Pá" "So") + :ERAS '("př.Kr." "po Kr.")))) + +(setf (gethash "it_CH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\' :DECIMAL-SEPARATOR #\. "CHF") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("gennaio" "febbraio" "marzo" "aprile" "maggio" "giugno" "luglio" "agosto" "settembre" "ottobre" "novembre" "dicembre") + :SHORT-MONTHS '("gen" "feb" "mar" "apr" "mag" "giu" "lug" "ago" "set" "ott" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domenica" "lunedì" "martedì" "mercoledì" "giovedì" "venerdì" "sabato") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mer" "gio" "ven" "sab") + :ERAS '("BC" "dopo Cristo")))) + +(setf (gethash "ro_RO" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "RON") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("ianuarie" "februarie" "martie" "aprilie" "mai" "iunie" "iulie" "august" "septembrie" "octombrie" "noiembrie" "decembrie") + :SHORT-MONTHS '("Ian" "Feb" "Mar" "Apr" "Mai" "Iun" "Iul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("duminică" "luni" "marţi" "miercuri" "joi" "vineri" "sîmbătă") + :SHORT-WEEKDAYS '("D" "L" "Ma" "Mi" "J" "V" "S") + :ERAS '("d.C." "î.d.C.")))) + +(setf (gethash "es_PR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "USD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "en_CA" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "CAD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "de_DE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") + :SHORT-MONTHS '("Jan" "Feb" "Mrz" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag") + :SHORT-WEEKDAYS '("So" "Mo" "Di" "Mi" "Do" "Fr" "Sa") + :ERAS '("v. Chr." "n. Chr.")))) + +(setf (gethash "ga" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("a.m." "p.m.") + :MONTHS '("Eanáir" "Feabhra" "Márta" "Aibreán" "Bealtaine" "Meitheamh" "Iúil" "Lúnasa" "Meán Fómhair" "Deireadh Fómhair" "Samhain" "Nollaig") + :SHORT-MONTHS '("Ean" "Feabh" "Márta" "Aib" "Beal" "Meith" "Iúil" "Lún" "MFómh" "DFómh" "Samh" "Noll") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Dé Domhnaigh" "Dé Luain" "Dé Máirt" "Dé Céadaoin" "Déardaoin" "Dé hAoine" "Dé Sathairn") + :SHORT-WEEKDAYS '("Domh" "Luan" "Máirt" "Céad" "Déar" "Aoine" "Sath") + :ERAS '("RC" "AD")))) + +(setf (gethash "de_LU" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "EUR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") + :SHORT-MONTHS '("Jan" "Feb" "Mrz" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag") + :SHORT-WEEKDAYS '("So" "Mo" "Di" "Mi" "Do" "Fr" "Sa") + :ERAS '("v. Chr." "n. Chr.")))) + +(setf (gethash "de" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") + :SHORT-MONTHS '("Jan" "Feb" "Mrz" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dez") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag") + :SHORT-WEEKDAYS '("So" "Mo" "Di" "Mi" "Do" "Fr" "Sa") + :ERAS '("v. Chr." "n. Chr.")))) + +(setf (gethash "es_AR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "ARS") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + +(setf (gethash "sk" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("január" "február" "marec" "apríl" "máj" "jún" "júl" "august" "september" "október" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "máj" "jún" "júl" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Nedeľa" "Pondelok" "Utorok" "Streda" "Štvrtok" "Piatok" "Sobota") + :SHORT-WEEKDAYS '("Ne" "Po" "Ut" "St" "Št" "Pi" "So") + :ERAS '("pred n.l." "n.l.")))) + +(setf (gethash "ms_MY" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "MYR") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januari" "Februari" "Mac" "April" "Mei" "Jun" "Julai" "Ogos" "September" "Oktober" "November" "Disember") + :SHORT-MONTHS '("Jan" "Feb" "Mac" "Apr" "Mei" "Jun" "Jul" "Ogos" "Sep" "Okt" "Nov" "Dis") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Ahad" "Isnin" "Selasa" "Rabu" "Khamis" "Jumaat" "Sabtu") + :SHORT-WEEKDAYS '("Ahd" "Isn" "Sel" "Rab" "Kha" "Jum" "Sab") + :ERAS '("BCE" "CE")))) + +(setf (gethash "hr_HR" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "HRK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("siječanj" "veljača" "ožujak" "travanj" "svibanj" "lipanj" "srpanj" "kolovoz" "rujan" "listopad" "studeni" "prosinac") + :SHORT-MONTHS '("sij" "vel" "ožu" "tra" "svi" "lip" "srp" "kol" "ruj" "lis" "stu" "pro") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("nedjelja" "ponedjeljak" "utorak" "srijeda" "četvrtak" "petak" "subota") + :SHORT-WEEKDAYS '("ned" "pon" "uto" "sri" "čet" "pet" "sub") + :ERAS '("BC" "AD")))) + +(setf (gethash "en_SG" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "SGD") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") + :SHORT-MONTHS '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + :SHORT-WEEKDAYS '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat") + :ERAS '("BC" "AD")))) + +(setf (gethash "da" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "marts" "april" "maj" "juni" "juli" "august" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "maj" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("søndag" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag") + :SHORT-WEEKDAYS '("sø" "ma" "ti" "on" "to" "fr" "lø") + :ERAS '("BC" "AD")))) + +(setf (gethash "mt" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("QN" "WN") + :MONTHS '("Jannar" "Frar" "Marzu" "April" "Mejju" "Ġunju" "Lulju" "Awissu" "Settembru" "Ottubru" "Novembru" "Diċembru") + :SHORT-MONTHS '("Jan" "Fra" "Mar" "Apr" "Mej" "Ġun" "Lul" "Awi" "Set" "Ott" "Nov" "Diċ") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Il-Ħadd" "It-Tnejn" "It-Tlieta" "L-Erbgħa" "Il-Ħamis" "Il-Ġimgħa" "Is-Sibt") + :SHORT-WEEKDAYS '("Ħad" "Tne" "Tli" "Erb" "Ħam" "Ġim" "Sib") + :ERAS '("QK" "WK")))) + +(setf (gethash "pl" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("styczeń" "luty" "marzec" "kwiecień" "maj" "czerwiec" "lipiec" "sierpień" "wrzesień" "październik" "listopad" "grudzień") + :SHORT-MONTHS '("sty" "lut" "mar" "kwi" "maj" "cze" "lip" "sie" "wrz" "paź" "lis" "gru") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("niedziela" "poniedziałek" "wtorek" "środa" "czwartek" "piątek" "sobota") + :SHORT-WEEKDAYS '("N" "Pn" "Wt" "Śr" "Cz" "Pt" "So") + :ERAS '("p.n.e." "n.e.")))) + +(setf (gethash "ar_OM" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "OMR") + :DATE-FORMAT (list + :AMPM '("ص" "م") + :MONTHS '("يناير" "فبراير" "مارس" "أبريل" "مايو" "يونيو" "يوليو" "أغسطس" "سبتمبر" "أكتوبر" "نوفمبر" "ديسمبر") + :SHORT-MONTHS '("ينا" "فبر" "مار" "أبر" "ماي" "يون" "يول" "أغس" "سبت" "أكت" "نوف" "ديس") + :FIRST-DAY-OF-THE-WEEK 7 + :WEEKDAYS '("الأحد" "الاثنين" "الثلاثاء" "الأربعاء" "الخميس" "الجمعة" "السبت") + :SHORT-WEEKDAYS '("ح" "ن" "ث" "ر" "خ" "ج" "س") + :ERAS '("ق.م" "م")))) + +(setf (gethash "tr" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Ocak" "Şubat" "Mart" "Nisan" "Mayıs" "Haziran" "Temmuz" "Ağustos" "Eylül" "Ekim" "Kasım" "Aralık") + :SHORT-MONTHS '("Oca" "Şub" "Mar" "Nis" "May" "Haz" "Tem" "Ağu" "Eyl" "Eki" "Kas" "Ara") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Pazar" "Pazartesi" "Salı" "Çarşamba" "Perşembe" "Cuma" "Cumartesi") + :SHORT-WEEKDAYS '("Paz" "Pzt" "Sal" "Çar" "Per" "Cum" "Cmt") + :ERAS '("BC" "AD")))) + +(setf (gethash "th_TH" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "THB") + :DATE-FORMAT (list + :AMPM '("ก่อนเที่ยง" "หลังเที่ยง") + :MONTHS '("มกราคม" "กุมภาพันธ์" "มีนาคม" "เมษายน" "พฤษภาคม" "มิถุนายน" "กรกฎาคม" "สิงหาคม" "กันยายน" "ตุลาคม" "พฤศจิกายน" "ธันวาคม") + :SHORT-MONTHS '("ม.ค." "ก.พ." "มี.ค." "เม.ย." "พ.ค." "มิ.ย." "ก.ค." "ส.ค." "ก.ย." "ต.ค." "พ.ย." "ธ.ค.") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("วันอาทิตย์" "วันจันทร์" "วันอังคาร" "วันพุธ" "วันพฤหัสบดี" "วันศุกร์" "วันเสาร์") + :SHORT-WEEKDAYS '("อา." "จ." "อ." "พ." "พฤ." "ศ." "ส.") + :ERAS '("ปีก่อนคริสต์กาลที่" "ค.ศ.")))) + +(setf (gethash "el" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "XXX") + :DATE-FORMAT (list + :AMPM '("πμ" "μμ") + :MONTHS '("Ιανουάριος" "Φεβρουάριος" "Μάρτιος" "Απρίλιος" "Μάϊος" "Ιούνιος" "Ιούλιος" "Αύγουστος" "Σεπτέμβριος" "Οκτώβριος" "Νοέμβριος" "Δεκέμβριος") + :SHORT-MONTHS '("Ιαν" "Φεβ" "Μαρ" "Απρ" "Μαϊ" "Ιουν" "Ιουλ" "Αυγ" "Σεπ" "Οκτ" "Νοε" "Δεκ") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("Κυριακή" "Δευτέρα" "Τρίτη" "Τετάρτη" "Πέμπτη" "Παρασκευή" "Σάββατο") + :SHORT-WEEKDAYS '("Κυρ" "Δευ" "Τρι" "Τετ" "Πεμ" "Παρ" "Σαβ") + :ERAS '("BC" "AD")))) + +(setf (gethash "ms" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "XXX") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("Januari" "Februari" "Mac" "April" "Mei" "Jun" "Julai" "Ogos" "September" "Oktober" "November" "Disember") + :SHORT-MONTHS '("Jan" "Feb" "Mac" "Apr" "Mei" "Jun" "Jul" "Ogos" "Sep" "Okt" "Nov" "Dis") + :FIRST-DAY-OF-THE-WEEK 1 + :WEEKDAYS '("Ahad" "Isnin" "Selasa" "Rabu" "Khamis" "Jumaat" "Sabtu") + :SHORT-WEEKDAYS '("Ahd" "Isn" "Sel" "Rab" "Kha" "Jum" "Sab") + :ERAS '("BCE" "CE")))) + +(setf (gethash "sv_SE" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\ :DECIMAL-SEPARATOR #\, "SEK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januari" "februari" "mars" "april" "maj" "juni" "juli" "augusti" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "maj" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("söndag" "måndag" "tisdag" "onsdag" "torsdag" "fredag" "lördag") + :SHORT-WEEKDAYS '("sö" "må" "ti" "on" "to" "fr" "lö") + :ERAS '("BC" "AD")))) + +(setf (gethash "da_DK" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\. :DECIMAL-SEPARATOR #\, "DKK") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("januar" "februar" "marts" "april" "maj" "juni" "juli" "august" "september" "oktober" "november" "december") + :SHORT-MONTHS '("jan" "feb" "mar" "apr" "maj" "jun" "jul" "aug" "sep" "okt" "nov" "dec") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("søndag" "mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag") + :SHORT-WEEKDAYS '("sø" "ma" "ti" "on" "to" "fr" "lø") + :ERAS '("BC" "AD")))) + +(setf (gethash "es_HN" *locales*) + (list + :NUMBER-FORMAT (list :GROUPING-SEPARATOR #\, :DECIMAL-SEPARATOR #\. "HNL") + :DATE-FORMAT (list + :AMPM '("AM" "PM") + :MONTHS '("enero" "febrero" "marzo" "abril" "mayo" "junio" "julio" "agosto" "septiembre" "octubre" "noviembre" "diciembre") + :SHORT-MONTHS '("ene" "feb" "mar" "abr" "may" "jun" "jul" "ago" "sep" "oct" "nov" "dic") + :FIRST-DAY-OF-THE-WEEK 2 + :WEEKDAYS '("domingo" "lunes" "martes" "miércoles" "jueves" "viernes" "sábado") + :SHORT-WEEKDAYS '("dom" "lun" "mar" "mié" "jue" "vie" "sáb") + :ERAS '("BC" "AD")))) + Added: trunk/main/claw.i18n/src/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw.i18n/src/packages.lisp Fri Jul 25 11:20:31 2008 @@ -0,0 +1,51 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/package.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.i18n + (:use :cl :claw :local-time) + (:shadow :flatten) + (:documentation "A service for CLAW application server, that performs internationalization \(i18n)") + (:export #:number-format-grouping-separator + #:number-format-decimal-separator + #:ampm + #:monthes + #:short-monthes + #:first-day-of-the-week + #:weekdays + #:short-weekdays + #:eras + #:*message-dispatcher* + #:message-dispatcher + #:message-dispatch + #:do-message + #:simple-message-dispatcher + #:simple-message-dispatcher-add-message)) \ No newline at end of file

1 0

[claw-cvs] r67 - trunk/main/claw-core
by achiumenti＠common-lisp.net 25 Jul '08

25 Jul '08

Author: achiumenti Date: Fri Jul 25 11:18:24 2008 New Revision: 67 Removed: trunk/main/claw-core/ Log: deleting claw-core, migrated to claw

1 0

[claw-cvs] r66 - in trunk/main/claw-html: . src
by achiumenti＠common-lisp.net 25 Jul '08

25 Jul '08

Author: achiumenti Date: Fri Jul 25 11:09:52 2008 New Revision: 66 Added: trunk/main/claw-html/ trunk/main/claw-html/claw-html.asd trunk/main/claw-html/src/ trunk/main/claw-html/src/components.lisp trunk/main/claw-html/src/meta.lisp trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp trunk/main/claw-html/src/translators.lisp trunk/main/claw-html/src/validators.lisp Log: claw html framework Added: trunk/main/claw-html/claw-html.asd ============================================================================== --- (empty file) +++ trunk/main/claw-html/claw-html.asd Fri Jul 25 11:09:52 2008 @@ -0,0 +1,50 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: claw-html.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-html + :name "claw-html" + :author "Andrea Chiumenti" + :description "Common Lisp Active Web HTML generator." + :depends-on (:closer-mop :local-time :parenscript :cl-ppcre :split-sequence) + :components ((:module src + :components ((:file "packages") + ;(:file "mime-type" :depends-on ("packages")) + ;(:file "misc" :depends-on ("mime-type")) + ;:(:file "i18n" :depends-on ("packages")) + ;(:file "locales" :depends-on ("i18n")) + ;(:file "connector" :depends-on ("misc")) + ;(:file "logger" :depends-on ("misc")) + ;(:file "session-manager" :depends-on ("misc")) + (:file "tags" :depends-on ("packages")) + (:file "meta" :depends-on ("packages")) + (:file "components" :depends-on ("tags" "meta")) + (:file "validators" :depends-on ("components")) + (:file "translators" :depends-on ("validators")))))) + ;(:file "server" :depends-on ("components")) + ;(:file "lisplet" :depends-on ("server")))))) Added: trunk/main/claw-html/src/components.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html/src/components.lisp Fri Jul 25 11:09:52 2008 @@ -0,0 +1,562 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/components.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-html) + +(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 +") + +(defgeneric cform-rewinding-p (obj page-obj) + (: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. +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 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")) + +(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* (intern client-id)))) + +;-------------------------------------------------------------------------------- + + + +(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") + (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")) + +(let ((class (find-class 'cform))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~%~%~a" + "Function that instantiates a CFORM component and renders a html <form> tag." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + + +(defmethod 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 "")) + (setf class "error") + (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" + :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-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) () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :href)) + (:documentation "This component behaves like a CFORM, firing it's associated action once clicked. +It renders as a normal link.")) + +(let ((class (find-class 'action-link))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a" + "Instantiates an ACTION-LINK that renders an <a> link that cals a page method." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'cform)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod wcomponent-template((o action-link)) + (let ((client-id (htcomponent-client-id o))) + (when (null client-id) + (setf client-id "")) + (a> :static-id client-id + :href (format nil "?~a=~a" *rewind-parameter* client-id) + (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") + (writer :initarg :writer + :reader cinput-writer + :documentation "Visit object slot writer symbol, used to write the input value to the visit object") + (reader :initarg :reader + :reader cinput-reader + :documentation "Visit object slot reader symbol, used to get the corresponding value from the visit object") + (accessor :initarg :accessor + :reader cinput-accessor + :documentation "Visit object slot accessor symbol. It can be used in place of the :READER and :WRITER parameters") + (label :initarg :label + :documentation "The label is the description of the component. It's also be used when component validation fails.") + (translator :initarg :translator + :reader translator + :documentation "A validator instance that encodes and decodes input values to and from the visit object mapped property") + (validator :initarg :validator + :reader validator + :documentation "A function that accept the passed component value during submission and performs the validation logic calling the validator functions.") + (visit-object :initarg :visit-object + :reader cinput-visit-object + :documentation "The object hoding the property mapped to the current input html component. When nil the owner page is used.") + (css-class :initarg :class + :reader css-class + :documentation "the html component class attribute")) + (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil + :label nil :translator *simple-translator* :validator nil :visit-object nil) + (:documentation "Class inherited from both CINPUT and CSELECT")) + +(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 + :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")) + +(let ((class (find-class 'cinput))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a" + "Function that instantiates a CINPUT component and renders a html <input> tag." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod wcomponent-template ((cinput cinput)) + (let ((client-id (htcomponent-client-id cinput)) + (type (input-type cinput)) + (translator (translator cinput)) + (value "") + (class (css-class cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (setf value (translator-encode translator cinput)) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + (wcomponent-informal-parameters cinput)))) + +(defmethod wcomponent-after-rewind ((cinput base-cinput) (page page)) + (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))) +; (log-message :info "********************* ~a : ~a" cinput value) + (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))))))) + +(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)) + (reader (cinput-reader cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (value "")) + (setf value + (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))) + +;--------------------------------------------------------------------------------------- +(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) + ((value :initarg :value + :reader csubmit-value + :documentation "The html VALUE attribute")) + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :type :name) :empty t :action nil) + (:documentation "This component render as an INPUT tag class ot type submit, but +can override the default CFORM action, using its own associated action")) + +(let ((class (find-class 'csubmit))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a" + "Function that instantiates a CSUBMIT component and renders a html <input> tag of submit type." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'cform)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod 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 (name-attr obj) + :value value + (wcomponent-informal-parameters obj)))) + +(defmethod wcomponent-after-rewind ((obj csubmit) (pobj page)) + (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) + () + (:metaclass metacomponent) + (:default-initargs :reserved-parameters (list :href) :empty nil) + (:documentation "This component renders as a normal link, but behaves like a CSUBMIT, +so it can be used instead of CSUBMIT when needed")) + +(let ((class (find-class 'submit-link))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a" + "Function that instantiates a SUBMIT-LINK component and renders a html <a> tag that can submit the form where it is contained." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'cform)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod wcomponent-template ((obj submit-link)) + (let* ((id (htcomponent-client-id obj)) + (submit-id (generate-id id))) + (list + (input> :static-id submit-id + :style "display:none;" + :type "submit" + :name (name-attr obj) + :value "-") + (a> :static-id id + :href (format nil "javascript:document.getElementById('~a').click();" submit-id) + (wcomponent-informal-parameters obj) + (htcomponent-body obj))))) + +;-------------------------------------------------------------------------- +(defclass cselect (base-cinput) () + (:default-initargs :reserved-parameters (list :type :name) :empty nil) + (:metaclass metacomponent) + (:documentation "This component renders as a normal SELECT tag class, +but it is request cycle aware.")) + +(let ((class (find-class 'cselect))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~a~a~%~%~a" + "Function that instantiates a CSELECT component and renders a html <select> tag." + *id-and-static-id-description* + (describe-html-attributes-from-class-slot-initargs (find-class 'base-cinput)) + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod wcomponent-template ((obj cselect)) + (let ((client-id (htcomponent-client-id obj)) + (class (css-class obj))) + (when (component-validation-errors obj) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (select> :static-id client-id + :name (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)) + (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) + (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)) + (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)) + (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)))) Added: trunk/main/claw-html/src/meta.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html/src/meta.lisp Fri Jul 25 11:09:52 2008 @@ -0,0 +1,82 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/meta.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-html) + +(defclass metacomponent (standard-class) + () + (:documentation "This is the meta class the must be set for every WCOMPONENT. +It creates a function whose name is the WCOMPONENT class name plus the character '>'. +The function may then be called as any other claw tag function.")) + +(defmethod closer-mop:validate-superclass ((class metacomponent)(super standard-class)) + t) + + +(defun find-first-classdefault-initarg-value (initargs initarg) + "Returns the first class default init arg value matching matching the given INITARG" + (loop for current-initarg in initargs + do (when (eq (first current-initarg) initarg) + (return (second current-initarg))))) + +(defmethod initialize-instance :after ((class metacomponent) &key) + (let* ((name (class-name class)) + (builder-function (format nil "~a>" name)) + (symbolf (find-symbol builder-function))) + (unless symbolf + (setf symbolf (intern builder-function))) + (setf (fdefinition symbolf) #'(lambda(&rest rest) (build-component name rest))))) + +(defun describe-html-attributes-from-class-slot-initargs (class) + "Helper function that generates documentation for wcomponent init functions" + (let* ((class-slots (closer-mop:class-direct-slots class))) + (format nil "~{~%~a~}" + (remove-if #'null + (reverse (loop for slot in class-slots + collect (let ((slot-initarg (first (closer-mop:slot-definition-initargs slot)))) + (when slot-initarg + (format nil + "- :~a ~a" + slot-initarg + (documentation slot 't)))))))))) + +(defun describe-component-behaviour (class) + "Returns the behaviour descrioption of a WCOMPONENT init function. If it allows informal parameters, body and the reserved parameters" + (let* ((initargs (closer-mop:class-default-initargs class)) + (reserved-parameters (find-first-classdefault-initarg-value initargs :reserved-parameters))) + (format nil "Allows informal parameters: ~a~%Allows body: ~a~%Reserved parameters: ~a" + (if (find-first-classdefault-initarg-value initargs :allow-informal-parameters) + "Yes" + "No") + (if (find-first-classdefault-initarg-value initargs :empty) + "No" + "Yes") + (if reserved-parameters + (format nil "~{:~a ~}" (eval reserved-parameters)) + "NONE")))) Added: trunk/main/claw-html/src/packages.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html/src/packages.lisp Fri Jul 25 11:09:52 2008 @@ -0,0 +1,256 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/package.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-html + (:use :cl :closer-mop :local-time :parenscript :cl-ppcre :split-sequence) + (:shadow :flatten) + (:documentation "A comprehensive web application framework and server for the Common Lisp programming language") + (:export #:*html-4.01-strict* + #:*html-4.01-transitional* + #:*html-4.01-frameset* + #:*xhtml-1.0-strict* + #:*xhtml-1.0-transitional* + #:*xhtml-1.0-frameset* + #:*rewind-parameter* + #:*validation-errors* + + #:error-page + #:render-error-page + + ;#:duplicate-back-slashes + #:build-tagf + #:page + #:page-render + #:make-page-renderer + #: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> + ;standard tags + #:a> + #:abbr> + #:acronym> + #:address> + #:applet> + #:b> + #:bdo> + #:big> + #:blockquote> + #:body> + #:button> + #:caption> + #:center> + #:cite> + #:code> + #:colgroup> + #:dd> + #:del> + #:dfn> + #:dir> + #:div> + #:dl> + #:dt> + #:em> + #:fieldset> + #:font> + #:form> + #:frameset> + #:h1> + #:h2> + #:h3> + #:h4> + #:h5> + #:h6> + #:head> + #:html> + #:i> + #:iframe> + #:ins> + #:kbd> + #:label> + #:legend> + #:li> + #:map> + #:menu> + #:noframes> + #:noscript> + #:object> + #:ol> + #:optgroup> + #:option> + #:p> + #:pre> + #:q> + #:s> + #:samp> + #:script> + #:select> + #:small> + #:span> + #:strike> + #:strong> + #:style> + #:sub> + #:sup> + #:table> + #:tbody> + #:td> + #:textarea> + #:tfoot> + #:th> + #:thead> + #:title> + #:tr> + #:tt> + #:u> + #:ul> + #:var> + ;; class modifiers + #:page-content + #:generate-id + #:metacomponent + #:wcomponent + #:wcomponent-informal-parameters + #:wcomponent-allow-informal-parametersp + #:wcomponent-template + #:wcomponent-before-rewind + #:wcomponent-after-rewind + #:wcomponent-before-prerender + #:wcomponent-after-prerender + #:wcomponent-before-render + #:wcomponent-after-render + #:cform + #: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 + + #:component-exceptions + #:*id-and-static-id-description* + + #:describe-component-behaviour + #:describe-html-attributes-from-class-slot-initargs + + ;;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* + #:validate + #:add-validation-error + #: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 Added: trunk/main/claw-html/src/tags.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html/src/tags.lisp Fri Jul 25 11:09:52 2008 @@ -0,0 +1,1379 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/tags.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-html) + +(defgeneric page-req-parameter (page name &optional as-list) + (: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 +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 +an xhr request is sent from the browser. + - PAGE is the page instance that must be given")) + +(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) + (:documentation "Internal method for page initialization. + - PAGE is the page instance that must be given")) + +(defgeneric page-render (page) + (:documentation "This method is the main method fired from the framework to render the desired page and to handle all the request cycle. + - 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 +must be reinitialized during sub-phases (rewinding, pre-rendering, rendering). + - PAGE is the page instance that must be given")) + +(defgeneric page-render-headings (page) + (: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. +Parameters are collected as lists so that this method can collect parameters that appear moter then once.")) + +(defgeneric page-print-tabulation (page) + (:documentation "This internal method is called during the rendering phase if tabulation is enabled. It writes the right amount +of tabs chars to indent the page. + - PAGE is the page instance that must be given")) + +(defgeneric page-newline (page) + (:documentation "This internal method simply writes the rest of page content on a new line when needed. + - PAGE is the page instance that must be given")) + +(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. + - PAGE is the page instance that must be given + - STR The format control + - REST The format arguments +See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) + +(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. + - PAGE is the page instance that must be given + - STR The format control + - REST The format arguments +See http://www.lisp.org/HyperSpec/Body/fun_format.html#format for more info.")) + +(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. +This internal method is called to render these scripts. + - 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 +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) + (: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. +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. +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. +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 +if a component may be rendered into the reply + - HTCOMPONENT is the htcomponent instance")) + +(defgeneric htcomponent-json-print-start-component (htcomponent) + (:documentation "Internal method called to render the json reply during the render cycle phase +on component start. + - HTCOMPONENT is the htcomponent instance")) + +(defgeneric htcomponent-json-print-end-component (htcomponent) + (:documentation "Internal method called to render the json reply during the render cycle phase +on component end. + - HTCOMPONENT is the htcomponent instance")) + +(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")) + +(defgeneric tag-render-endtag (tag page) + (:documentation "Internal method to print out the closing html tag during the render phase + - TAG is the tag instance + - PAGE the page instance")) + +(defgeneric tag-render-attributes (tag page) + (:documentation "Internal method to print out the attributes of an html tag during the render phase + - TAG is the tag instance + - PAGE the page instance")) + +(defgeneric tag-attributes (tag) + (:documentation "Returns an alist of tag attributes")) + +(defgeneric (setf htcomponent-page) (page htcomponent) + (:documentation "Internal method to set the component owner page and to assign +an unique id attribute when provided. + - HTCOMPONENT is the tag instance + - PAGE the page instance")) + +(defgeneric (setf slot-initialization) (value wcomponent slot-initarg) + (:documentation "Sets a slot by its :INITARG. It's used just after instance creation")) + +(defgeneric wcomponent-before-rewind (wcomponent page) + (:documentation "Method called by the framework before the rewinding phase. It is intended to be eventually overridden in descendant classes. + - WCOMPONENT is the tag instance + - PAGE the page instance")) + +(defgeneric wcomponent-after-rewind (wcomponent page) + (:documentation "Method called by the framework after the rewinding phase. It is intended to be eventually overridden in descendant classes. + - WCOMPONENT is the tag instance + - PAGE the page instance")) +(defgeneric wcomponent-before-prerender (wcomponent page) + (:documentation "Method called by the framework before the pre-rendering phase. It is intended to be eventually overridden in descendant classes. + - WCOMPONENT is the tag instance + - PAGE the page instance")) + +(defgeneric wcomponent-after-prerender (wcomponent page) + (:documentation "Method called by the framework after the pre-rendering phase. It is intended to be eventually overridden in descendant classes. + - WCOMPONENT is the tag instance + - PAGE the page instance")) +(defgeneric wcomponent-before-render (wcomponent page) + (:documentation "Method called by the framework before the rendering phase. It is intended to be eventually overridden in descendant classes. + - WCOMPONENT is the tag instance + - PAGE the page instance")) + +(defgeneric wcomponent-after-render (wcomponent page) + (:documentation "Method called by the framework after the rendering phase. It is intended to be eventually overridden in descendant classes. + - WCOMPONENT is the tag instance + - PAGE the page instance")) + +(defgeneric wcomponent-template (wcomponent) + (:documentation "The component template. What gives to each wcomponent its unique aspect and features")) + +(defgeneric simple-message-dispatcher-add-message (simple-message-dispatcher locale key value) + (:documentation "Adds a key value pair to a given locale for message translation")) + +(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\">" + "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\">" + "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\">" + "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\">" + "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\">" + "Page doctype as XHTML 4.01 FRAMESET") + +(defvar *rewind-parameter* "rewindobject" + "The request parameter name for the object asking for a rewind action") + +(defvar *empty-tags* + (list "area" "base" "basefont" "br" "col" "frame" + "hr" "img" "input" "isindex" "meta" + "param" "link") + "List of html empty tags") + +(defvar *validation-errors* nil + "A plist where key is a component id and value is a list of validation error messages related to that component.") + +(defvar *validation-compliances* nil + "List of component id that pass the validation") + +(defvar *claw-current-page* nil + "The CLAW page currently rendering") + +(defvar *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 +time this id will be used, it will be rendered as \"compId_1\", the third time will be \"compId_2\" and so on") + +(defvar *simple-translator* nil + "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component. +Its encoder and decoder methods pass values unchanged") + +(defvar *file-translator* nil + "*FILE-TRANSLATOR* is the default translator for any CINPUT component of type \"file\".") + + + +(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 + ((consp element) (setf result (append (nreverse (flatten element result-list)) result))) + (t (push element result)))) + (nreverse result))) + +(defun add-validation-compliance (id) + "Adds a component id to the list of components that pass validation during form rewinding" + (setf *validation-compliances* (nconc *validation-compliances* (list id)))) + +(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." + (setf *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) + (or (keywordp elem) + (keywordp last-elem))) + (push elem attributes) + (when elem + (push elem body)))) + (list (reverse attributes) (reverse body)))) + + +(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." + (let* ((id-ht *id-table-map*) + (client-id-index (gethash id id-ht 0)) + (result)) + (if (= 0 client-id-index) + (setf result id) + (setf result (format nil "~a_~d" id client-id-index))) + (setf (gethash id id-ht) (1+ client-id-index)) + result)) + +(defun build-tagf (tag-name parent emptyp &rest rest) + "This function is used to create a tag object instance +- TAG-NAME the a string tag name to create, for example \"span\" +- PARENT the parent class. usually TAG +- 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 *id-table-map*) + (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 attributes :id) + (setf id nil)) + (when render-condition + (remf attributes :render-condition)) + (setf instance (make-instance parent + :empty emptyp + :real-id real-id + :name (string-downcase tag-name) + :render-condition render-condition + :attributes attributes + :body (second fbody))) + (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) + "Internal function that generates an htcomponent creation function from the component class name +- TAG-NAME the symbol class name of the component +- EMPTYP determines if the tag must be rendered as an empty tag during the request cycle phase." + (let ((fsymbol (intern (format nil "~a>" (string-upcase tag-name))))) + (setf (fdefinition fsymbol) + #'(lambda (&rest rest) (build-tagf tag-name 'tag emptyp rest))) + (setf (documentation fsymbol 'function) (format nil "This function generates the ~a<~a> html tag" + (if emptyp + "empty " + "") + tag-name)))) + + +;;;---------------------------------------------------------------- +#| +(defclass message-dispatcher () + () + (:documentation "This is and interface for message dispatchers")) + +(defclass simple-message-dispatcher (message-dispatcher) + ((locales :initform (make-hash-table :test #'equal) + :accessor simple-message-dispatcher-locales + :documentation "Hash table of locales strings and KEY/VALUE message pairs")) + (:documentation "A message disptcher that leave data unchanged during encoding and decoding phases.")) + +(defclass i18n-aware (message-dispatcher) + ((message-dispatcher :initarg :message-dispatcher + :accessor message-dispatcher + :documentation "Reference to a MESSAGE-DISPATCHER instance")) + (:default-initargs :message-dispatcher nil) + (:documentation "All classes that need to dispatch messages are subclasses of I18N-AWARE")) +|# + +(defclass page() + ((writer :initarg :writer + :accessor page-writer :documentation "The output stream for this page instance") + (can-print :initform nil + :accessor page-can-print + :documentation "Controls the printing process when a json request is dispatched. +Only components with a matching id and their contents can be printed") + (script-files :initarg :script-files + :accessor page-script-files :documentation "Holds component class scripts files injected by components during the request cycle") + (stylesheet-files :initarg :stylesheet-files + :accessor page-stylesheet-files :documentation "Holds component class css files injected by components during the request cycle") + (class-initscripts :initarg :class-initscripts + :accessor page-class-initscripts :documentation "Holds component class javascript directives injected by components during the request cycle") + (instancee-initscripts :initarg :instance-initscripts + :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 + :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 + :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.") + (post-parameters :initarg :post-parameters + :reader page-post-parameters + :documentation "http request post parameters") + (get-parameters :initarg :get-parameters + :reader page-get-parameters + :documentation "http request get parameters") + (components-stack :initform nil + :accessor page-components-stack + :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") + (external-format-encoding :initarg :external-format-encoding + :accessor page-external-format-encoding + :documentation "Symbol for page charset encoding \(Such as UTF-8)") + (injection-writing-p :initform nil + :accessor page-injection-writing-p + :documentation "Flag that becomes true when rendering page injections")) + (:default-initargs :writer t + :external-format-encoding :utf-8 + :script-files nil + :json-component-count 0 + :stylesheet-files nil + :class-initscripts nil + :instance-initscripts nil + :indent t + :tabulator 0 + :xmloutput nil + :doc-type *html-4.01-strict* + :request-parameters nil + :mime-type "text/html") + (:documentation "A page object holds claw components to be rendered") ) + +(defun make-page-renderer (page-class http-post-parameters http-get-parameters) + "Generates a lambda function from PAGE-RENDER method, that may be used into LISPLET-REGISTER-FUNCTION-LOCATION" + #'(lambda () (with-output-to-string (*standard-output*) + (page-render (make-instance page-class :post-parameters http-post-parameters :get-parameters http-get-parameters))))) + +(defclass htcomponent () + ((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 + :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 + :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 + :accessor htcomponent-stylesheet-files :documentation "Page injectable css files") + (class-initscripts :initarg :class-initscripts + :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 + :body nil + :json-render-on-validation-errors-p nil + :real-id nil + :attributes nil + :empty nil + :render-condition nil + :script-files nil + :stylesheet-files nil + :class-initscripts nil + :instance-initscript nil) + (:documentation "Base class for all other claw components")) + +(defclass tag (htcomponent) + ((name :initarg :name + :reader tag-name :documentation "The tag name to be rendered")) + (:default-initargs :name nil) + (:documentation "This class is used to render the most part of html tags")) + +(defclass htstring (htcomponent) + ((raw :initarg :raw + :accessor htstring-raw :documentation "Determines if the string content must be html escaped or not")) + (:default-initargs :raw nil) + (:documentation "Component needed to render strings")) + + + +(defmethod initialize-instance :after ((inst tag) &rest keys) + (let ((emptyp (getf keys :empty)) + (body (getf keys :body))) + (when (and (not (null emptyp)) + (not (null body))) + (error (format nil "This tag cannot have a body <~a> body: '~a'" (tag-name inst) body))))) + +(defun $> (value) + "Creates an escaping htstring component" + (make-instance 'htstring :body value)) + +(defun $raw> (value) + "Creates a non escaping htstring component" + (make-instance 'htstring :body value :raw t)) + +(defclass htscript (tag) () + (:documentation "Creates a component for rendering a <script> tag")) + +(defun script> (&rest rest) + "This function generates the <script> html tag" + (build-tagf "script" 'htscript nil rest)) + +(defclass htlink (tag) () + (:documentation "Creates a component for rendering a <link> tag")) + +(defun link> (&rest rest) + "This function generates the <link> html tag" + (build-tagf "link" 'htlink t rest)) + +(defclass htbody (tag) () + (:documentation "Creates a component for rendering a <body> tag")) + +(defun body> (&rest rest) + "This function generates the <body> html tag" + (build-tagf "body" 'htbody nil rest)) + +(defclass hthead (tag) () + (:documentation "Creates a component for rendering a <head> tag")) + +(defun head> (&rest rest) + "Renders a <head> tag" + (build-tagf "head" 'hthead nil rest)) + +(mapcar #'(lambda (tag-name) (generate-tagf tag-name t)) + ;;Creates empty tag initialization functions. But the ones directly defined + *empty-tags*) + +(mapcar #'(lambda (tag-name) (generate-tagf tag-name nil)) + ;;Creates non empty tag initialization functions. But the ones directly defined + '("a" "abbr" "acronym" "address" "applet" + "b" "bdo" "big" "blockquote" "button" + "caption" "center" "cite" "code" "colgroup" + "dd" "del" "dfn" "dir" "div" "dl" "dt" + "em" + "fieldset" "font" "form" "frameset" + "h1" "h2" "h3" "h4" "h5" "h6" "html" + "i" "iframe" "ins" + "kbd" + "label" "legend" "li" + "map" "menu" + "noframes" "noscript" + "object" "ol" "optgroup" "option" + "p" "pre" + "q" + "s" "samp" "select" "small" "span" "strike" "strong" "style" "sub" "sup" + "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" + "u" "ul" "var")) + +;;;--------------------METHODS implementation---------------------------------------------- +(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 (null (slot-value page 'request-parameters)) + (let ((parameters (append (page-post-parameters page) (page-get-parameters page))) + (pparameters (make-hash-table :test 'equal))) + (loop for kv in parameters + do (setf (gethash (string-upcase (car kv)) pparameters) + (append (gethash (string-upcase (car kv)) pparameters) + (list (cdr kv))))) + (setf (slot-value page 'request-parameters) pparameters)) + (slot-value page 'request-parameters))) + +(defmethod page-req-parameter ((page page) name &optional as-list) + (let ((parameters (page-request-parameters page)) + (retval)) + (when parameters + (setf retval (gethash (string-upcase name) parameters)) + (if (or (null retval) as-list) + retval + (first retval))))) + +(defmethod page-format ((page page) str &rest rest) + (let ((jsonp (page-json-id-list page)) + (writer (page-writer page))) + (if (null jsonp) + (apply #'format writer str rest) + (apply #'format writer (list + (regex-replace-all "\"" + (regex-replace-all "\\\\\"" + (regex-replace-all "\\n" + (apply #'format nil str rest) + "\\n") + "\\\\\\\"") + "\\\"")))))) + +(defmethod page-format-raw ((page page) str &rest rest) + (let ((writer (page-writer page))) + (apply #'format writer str rest))) + +(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) + (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-external-format-encoding page)) + (xml-p (page-xmloutput 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 doc-type + (page-format-raw page "~a~%" doc-type))))) + +(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))) + (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 ((*claw-current-page* page) + (*id-table-map* nil) + (*validation-errors* nil) + (*validation-compliances* nil) + (body (page-content page)) + (jsonp (page-json-id-list page))) + (if (null body) + (format nil "null body for page ~a~%" (type-of page)) + (progn + (page-init page) + (when (page-req-parameter page *rewind-parameter*) + (htcomponent-rewind body page)) + (page-init page) + (htcomponent-prerender (page-content page) page) ;Here we need a fresh new body!!! + (page-render-headings page) + (page-init page) + (when jsonp + (page-format-raw page (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 + (page-injection-writing-p page) t) + (dolist (injection (page-init-injections page)) + (when injection + (htcomponent-render injection page))) + (page-format-raw page "\",instanceInjections:\"") + (let ((init-scripts (htbody-init-scripts-tag page))) + (when init-scripts + (htcomponent-render init-scripts page))) + (page-format-raw page "\",errors:") + (page-format-raw page (json-validation-errors)) + (page-format-raw page ",valid:") + (page-format-raw page (json-validation-compliances)) + (page-format-raw page "}") + (page-format-raw page (page-json-suffix page))))))) + +(defmethod page-body-init-scripts ((page page)) + (let ((js-body "")) + (dolist (current-js (reverse (page-instance-initscripts page))) + (setf js-body (format nil "~a~%~a~%" js-body current-js))) + (if (string= "" js-body) + js-body + (format nil "~a" js-body)))) + +(defmethod page-print-tabulation ((page page)) + (let ((jsonp (page-json-id-list page)) + (tabulator (page-tabulator page)) + (indent-p (page-indent page))) + (when (and (<= 0 tabulator) indent-p (null jsonp)) + (page-format-raw page "~a" + (make-string tabulator :initial-element #\tab))))) + +(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 "~%")))) + +(defmethod page-init-injections ((page page)) + (let ((tag-list) + (class-init-scripts "")) + (dolist (script (reverse (page-class-initscripts page))) + (setf class-init-scripts (format nil "~a~%~a" + class-init-scripts + script))) + (unless (string= "" class-init-scripts) + (let ((current-js (script> :type "text/javascript"))) + (setf (htcomponent-body current-js) class-init-scripts) + (push current-js tag-list))) + (dolist (js-file (page-script-files page)) + (if (typep js-file 'htcomponent) + (push js-file tag-list) + (let ((current-js (script> :type "text/javascript" :src ""))) + (setf (getf (htcomponent-attributes current-js) :src) js-file) + (push current-js tag-list)))) + (dolist (css-file (page-stylesheet-files page)) + (if (typep css-file 'htcomponent) + (push css-file tag-list) + (let ((current-css (link> :rel "stylesheet" :type "text/css" :href ""))) + (setf (getf (htcomponent-attributes current-css) :href) css-file) + (push current-css tag-list)))) + + tag-list)) + +(defmethod page-current-component ((page page)) + (car (page-components-stack page))) + +(defun current-component () + "Returns the component that is currently rendering" + (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))) + (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))) + (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 (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) + (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 (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))) + (pop (page-json-component-id-list page)) + (page-format-raw page "\"")))) + +(defmethod htcomponent-rewind :before ((htcomponent htcomponent) (page page)) + (setf (htcomponent-page htcomponent) page) + (push htcomponent (page-components-stack page))) + +(defmethod htcomponent-prerender :before ((htcomponent htcomponent) (page 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)) + (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)) + (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)) + (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)) + (when (subtypep (type-of tag) 'htcomponent) + (htcomponent-rewind tag page)))) + +(defmethod htcomponent-prerender ((htcomponent htcomponent) (page page)) + (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)) + (let ((body-list (htcomponent-body 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)) + (htcomponent-attributes tag)) + +(defmethod tag-render-attributes ((tag tag) (page page)) + (when (htcomponent-attributes tag) + (loop for (k v) on (htcomponent-attributes tag) by #'cddr + do (progn + (assert (keywordp k)) + (when (and (functionp v) (not (eq k :render-condition))) + (setf v (funcall v))) + (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)) + (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 (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)) + (injection-writing-p (page-injection-writing-p page))) + (setf (page-lasttag page) tagname) + (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) + (tag-render-attributes tag page) + (if (null emptyp) + (progn + (page-format page ">") + (incf (page-tabulator page))) + (if (null xml-p) + (page-format page ">") + (page-format page "/>")))))) + +(defmethod tag-render-endtag ((tag tag) (page page)) + (let ((tagname (tag-name 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)) + (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 + (page-newline page) + (page-print-tabulation page) + (page-format page "</~a>" tagname))))) + (setf (page-lasttag page) nil))) + +(defmethod htcomponent-render ((tag tag) (page page)) + (let ((body-list (htcomponent-body tag)) + (previous-print-status (page-can-print page)) + (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 + ((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)) + (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 (page-external-format-encoding page))) + (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))) +(defmethod htcomponent-prerender((htstring htstring) (page page))) + +(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)) + (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))) + +(defmethod htcomponent-render ((htscript htscript) (page page)) + (let ((xml-p (page-xmloutput page)) + (body (htcomponent-body 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)) + (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)) + (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-control-string-directive (if on-load + " +var bodyInitFunction = function\(e){~{~a~}};~% +if (/MSIE (\\d+\\.\\d+);/.test(navigator.userAgent)) {~% + window.attachEvent\('onload', bodyInitFunction);~% +} else {~% + document.addEventListener\('DOMContentLoaded', bodyInitFunction, false);~% +}" + "~{~a~}~%")) + (page-body-init-scripts (page-body-init-scripts page))) + (setf (htcomponent-page js) page + (htcomponent-body js) (when page-body-init-scripts + (format nil js-control-string-directive (if (listp page-body-init-scripts) + page-body-init-scripts + (list page-body-init-scripts))))) + js)) + +;;;========= WCOMPONENT =================================== +(defclass wcomponent (htcomponent) + ((reserved-parameters :initarg :reserved-parameters + :accessor wcomponent-reserved-parameters + :type cons + :documentation "Parameters that may not be used in the constructor function") + (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 + :documentation "Informal parameters are parameters optional for the component") + (allow-informal-parameters :initarg :allow-informal-parameters + :reader wcomponent-allow-informal-parametersp + :allocation :class + :documentation "Determines if the component accepts informal parameters")) + (:default-initargs :reserved-parameters nil + :allow-informal-parameters t) + (:documentation "Base class for creationg customized web components. Use this or one of its subclasses to make your own.")) + +(defun slot-initarg-p (initarg class-precedence-list) + "Returns nil if a slot with that initarg isn't found into the list of classes passed" + (loop for class in class-precedence-list + do (let* ((direct-slots (closer-mop:class-direct-slots class)) + (result (loop for slot in direct-slots + do (when (eq (first (closer-mop:slot-definition-initargs slot)) initarg) + (return initarg))))) + (when result + (return result))))) + +(defmethod initialize-instance :after ((instance wcomponent) &rest rest) + (let* ((class-precedence-list (closer-mop:compute-class-precedence-list (class-of instance))) + (informal-parameters (loop for (k v) on rest by #'cddr + for result = () + do (unless (slot-initarg-p k class-precedence-list) + (push v result) + (push k result)) + finally (return result)))) + (setf (slot-value instance 'informal-parameters) informal-parameters))) + +(defmethod (setf slot-initialization) (value (wcomponent wcomponent) slot-initarg) + (let* ((initarg (if (or (eq slot-initarg :static-id) (eq slot-initarg :id)) :client-id slot-initarg)) + (new-value (if (eq slot-initarg :id) (generate-id value) value)) + (slot-name (loop for slot-definition in (closer-mop:class-slots (class-of wcomponent)) + do (when (eq (car (last (closer-mop:slot-definition-initargs slot-definition))) initarg) + (return (closer-mop:slot-definition-name slot-definition)))))) + (if (find initarg (wcomponent-reserved-parameters wcomponent)) + (error (format nil "Parameter ~a is reserved" initarg)) + (if slot-name + (setf (slot-value wcomponent slot-name) new-value) + (if (null (wcomponent-allow-informal-parametersp wcomponent)) + (error (format nil + "Component ~a doesn't accept informal parameters" + slot-initarg)) + (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) + + +(defun make-component (name parameters content) + "This function instantiates a wcomponent by the passed NAME, separetes parameters into formal(the ones that are the +initarg of a slot, and informal parameters, that have their own slot in common. The CONTENT is the body content." + (let* ((instance (make-instance name)) + (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 + do (setf (slot-initialization instance initarg) value)) + (setf (htcomponent-body instance) content) + instance)) + +(defun build-component (component-name &rest rest) + "This function is the one that WCOMPONENT init functions call to intantiate their relative components. +The REST parameter is flattened and divided into a pair, where the first element is the alist of the component parameters, +while the second is the component body." + (let ((fbody (parse-htcomponent-function (flatten rest)))) + (make-component component-name (first fbody) (second fbody)))) + +(defmethod htcomponent-rewind ((wcomponent wcomponent) (page page)) + (let ((template (wcomponent-template wcomponent))) + (wcomponent-before-rewind wcomponent page) + (if (listp template) + (dolist (tag template) + (htcomponent-rewind tag page)) + (htcomponent-rewind template page)) + (wcomponent-after-rewind wcomponent page))) + +(defmethod wcomponent-before-rewind ((wcomponent wcomponent) (page page))) +(defmethod wcomponent-after-rewind ((wcomponent wcomponent) (page page))) + +(defmethod htcomponent-prerender ((wcomponent wcomponent) (page 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) + (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) + (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)) + (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))) + +(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")) + (:documentation "This is the page class used to render +the http error messages.")) + +(defclass error-page-template (wcomponent) + ((title :initarg :title + :reader title + :documentation "The page title") + (error-code :initarg :error-code + :reader error-code + :documentation "The http error code. For details consult http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html") + (style :initarg :style + :reader style + :documentation "The CSS <style> element, used to beautify the error page.")) + (:default-initargs :style " +body { + font-family: arial, elvetica; + font-size: 7pt; +} +span.blue { + background-color: #525D76; + color: white; + font-weight: bolder; + margin-right: .25em; +} +p.h1, p.h2 { + background-color: #525D76; + color: white; + font-weight: bolder; + font-size: 2em; + margin: 0; + margin-bottom: .5em; +} +p.h2 {font-size: 1.5em;}" :empty t :allow-informal-parameters nil) + (:metaclass metacomponent) + (:documentation "The template for the error-page")) + +(let ((class (find-class 'error-page-template))) + (closer-mop:ensure-finalized class) + (setf (documentation (find-symbol (format nil "~a>" (class-name class))) 'function) + (format nil "Description: ~a~%Parameters:~%~a~%~%~a" + "Function that instantiates an ERROR-PAGE-TEMPLATE component and renders a html tenplate for CLAW generic error pages." + (describe-html-attributes-from-class-slot-initargs class) + (describe-component-behaviour class)))) + +(defmethod wcomponent-template ((error-page-template error-page-template)) + (let ((error-code (error-code error-page-template)) + (title (title error-page-template)) + (style (style error-page-template)) + (request-uri (connector-request-uri (clawserver-connector *clawserver*)))) + (html> + (head> + (title> title) + (style> style)) + (body> + (p> + (p> :class "h1" + (format nil "HTTP Status ~a - ~a" error-code request-uri)) + (hr> :noshade "noshade") + (p> + (span> :class "blue" + ($> "type")) + "Status report") + (p> + (span> :class "blue" + "url") + request-uri) + (p> + (span> :class "blue" + "description") + (gethash error-code *http-reason-phrase-map*) + (hr> :noshade "noshade")) + (p> :class "h2" + "claw server")))))) + +(defmethod page-content ((error-page error-page)) + (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))))) + +(defun render-error-page (&optional (error-code 404)) + "This function renders a http error page." + (let ((connector (clawserver-connector clawserver))) + (page-render (make-instance 'error-page + :title (format nil "Server error: ~a" error-code) + :error-code error-code)))) +#| +(defmethod message-dispatch ((message-dispatcher message-dispatcher) key locale) nil) + +(defmethod message-dispatch ((i18n-aware i18n-aware) key locale) + (let ((dispatcher (message-dispatcher i18n-aware)) + (result)) + (when dispatcher + (progn + (setf result (message-dispatch dispatcher key locale)) + (when (and (null result) (> (length locale) 2)) + (setf result (message-dispatch dispatcher key (subseq locale 0 2)))))) + result)) + +(defmethod simple-message-dispatcher-add-message ((simple-message-dispatcher simple-message-dispatcher) locale key value) + (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher) (make-hash-table :test #'equal)))) + (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) + (let ((current-locale (gethash locale (simple-message-dispatcher-locales simple-message-dispatcher)))) + (when current-locale + (gethash key current-locale)))) +|# Added: trunk/main/claw-html/src/translators.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html/src/translators.lisp Fri Jul 25 11:09:52 2008 @@ -0,0 +1,338 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/translators.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-html) + +(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")) + +(defclass translator () + ((validation-error-control-string :initarg :validation-error-control-string + :reader validation-error-control-string + :documentation "Control string that accepts a label attribute")) + (:documentation "a translator object encodes and decodes values passed to a html input component") + (:default-initargs :validation-error-control-string nil)) + +(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 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))) + (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 value) + (component-id-and-value wcomponent) + (translator-value-decode translator value client-id (label wcomponent)))) + +(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent)) + (translator-decode translator wcomponent)) + +(setf *simple-translator* (make-instance '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 +its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator") + (always-show-signum :initarg :always-show-signum + :reader translator-always-show-signum + :documentation "When true the signum is used also for displaying positive numbers.") + (grouping-size :initarg :grouping-size + :reader translator-grouping-size + :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3")) + (:default-initargs :thousand-separator nil + :grouping-size 3 + :always-show-signum nil) + (:documentation "A translator object encodes and decodes integer values passed to a html input component")) + +(defmethod translator-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-value-decode ((translator translator-integer) value &optional client-id label) + (let ((thousand-separator (translator-thousand-separator translator))) + (handler-case + (if thousand-separator + (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value "")) + (parse-integer value)) + (error () (progn + (when label + (add-validation-error client-id (format nil (or (validation-error-control-string translator) + "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) + ((decimals-separator :initarg :decimals-separator + :reader translator-decimals-separator + :documentation "The decimal separator of the rendered number. Default to #\.") + (decimal-digits :initarg :decimal-digits + :reader translator-decimal-digits + :documentation "force the rendering of the value to a fixed number of decimal digits") + (coerce :initarg :coerce + :accessor translator-coerce + :documentation "Coerces the decoded input value to the given value type")) + (:default-initargs :decimals-separator #\. + :decimal-digits nil + :coerce 'ratio) + (:documentation "a translator object encodes and decodes integer values passed to a html input component")) + + +(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-value-decode ((translator translator-number) value &optional client-id label) + (let ((thousand-separator (translator-thousand-separator translator)) + (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-validation-error client-id (format nil (or (validation-error-control-string translator) + "Field ~a is not a valid number.") label))) + value))))) + + +(defvar *number-translator* (make-instance 'translator-number)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass translator-date (translator) + ((local-time-format :initarg :local-time-format + :reader translator-local-time-format + :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are +expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)")) + (:default-initargs :local-time-format '(: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\". +The argument for the message will be the :label attribute of the COMPONENT and the input component string 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-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 1) + (month 1) + (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-validation-error client-id (format nil (or (validation-error-control-string translator) + "Field ~a is not a valid date or wrong format.") label))) + value))))) + +(defvar *date-translator-ymd* (make-instance 'translator-date)) + +(defvar *date-translator-time* (make-instance 'translator-date :local-time-format '("T" :hour ":" :minute ":" :second))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;; Boolean translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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) + (declare (ignore client-id label)) + (if (string-equal value "NIL") + nil + t)) + +(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) + (declare (ignore client-id label)) + value) + +(setf *file-translator* (make-instance 'translator-file)) \ No newline at end of file Added: trunk/main/claw-html/src/validators.lisp ============================================================================== --- (empty file) +++ trunk/main/claw-html/src/validators.lisp Fri Jul 25 11:09:52 2008 @@ -0,0 +1,225 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: src/components.lisp $ + +;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :claw-html) + +(defgeneric local-time-to-string (local-time format) + (:documentation "Writes a local-time instance the FORMAT list where element are joined together and :SECOND :MINUTE :HOUR :DATE :MONTH and :YEAR are +expanded into seconds for :SECOND, minutes for :MINUTE, hour of the day for :HOUR, day of the month for :DATE, month number for :MONTH and the year for :YEAR. +A format list may be for example '(:month \"/\" :date \"/\" :year)")) + +(defmethod local-time-to-string ((local-time local-time) format) + (multiple-value-bind (nsec sec min hour day month year) + (decode-local-time local-time) + (declare (ignore nsec)) + (loop for result = "" then (concatenate 'string result (if (stringp element) + element + (ccase element + (:second (format nil "~2,'0D" sec)) + (:minute (format nil "~2,'0D" min)) + (:hour (format nil "~2,'0D" hour)) + (:date (format nil "~2,'0D" day)) + (:month (format nil "~2,'0D" month)) + (:year (format nil "~4,'0D" year))))) + for element in format + finally (return result)))) + +(defun add-validation-error (id reason) + "Adds an exception for the given input component identified by its ID with the message expressed by REASON" + (let* ((symbol-id (intern id)) + (errors (getf *validation-errors* symbol-id))) + (setf (getf *validation-errors* symbol-id) (nconc errors (list reason))))) + +(defun component-exceptions (id) + "Returns a list of exception connectd to the given component" + (let ((symbol-id (intern 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-VALIDATION-ERROR..." + (let ((client-id (htcomponent-client-id component))) + (if test + (add-validation-compliance client-id) + (add-validation-error client-id message)))) + +(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 (or message (format nil "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. +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\". +The argument for the message will be the :label attribute of the COMPONENT and the :MAX-ZIZE value." + (let ((value-len 0)) + (when value + (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 (or message-low (format nil "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 (or message-hi (format nil "Size of ~a may not be more then ~a chars." + (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. +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 (or message-low (format nil "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 (or message-hi (format nil "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 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." + (when value + (let ((test (numberp value))) + (and (validate test + :component component + :message (or message-nan (format nil "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 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." + (when value + (let ((test (integerp value))) + (and (validate test + :component component + :message (or message-nan (format nil "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) + "Checks if the input field VALUE is a date between min and max. +If :USE-DATE-P is not nil and :USE-TIME-P is nil, validation is made without considering the time part of local-time. +If :USE-DATE-P nil and :USE-TIME-P is not nil, validation is made without considering the date part of local-time. +If :USE-DATE-P and :USE-TIME-P are both not nil or nil, validation is made considering the date and time part of local-time. +If value is less then the date passed to :MIN, a localizable message \"Field ~a is less then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MIN\". +The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MIN parsed with the :LOCAL-TIME-FORMAT keyword. +If value is greater then the date passed to :MAX, a localizable message \"Field ~a is greater then ~a.\" is sent with key \"VALIDATE-DATE-RANGE-MAX\". +The argument for the message will be the :label attribute of the COMPONENT and the value passed to :MAX parsed with the :LOCAL-TIME-FORMAT keyword." + (unless (component-validation-errors component) + (let ((local-time-format '(:date "-" :month "-" :year)) + (new-value (make-instance 'local-time + :nsec (nsec-of value) + :sec (sec-of value) + :day (day-of value) + :timezone (timezone-of value)))) + (when (and use-date-p (not use-time-p)) + (setf (local-time:nsec-of new-value) 0 + (local-time:sec-of new-value) 0) + (when min + (setf (local-time:nsec-of min) 0 + (local-time:sec-of min) 0)) + (when max + (setf (local-time:nsec-of max) 0 + (local-time:sec-of max) 0))) + (when (and (not use-date-p) use-time-p) + (setf (local-time:day-of new-value) 0) + (when min + (setf (local-time:day-of min) 0)) + (when max + (setf (local-time:day-of max) 0))) + (and (when min + (validate (local-time> new-value min) + :component component + :message (or message-low (format nil "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 "Field ~a is greater then ~a." + (label component) + (local-time-to-string max local-time-format))))))))) + + + +;; ------------------------------------------------------------------------------------ +(defclass exception-monitor (wcomponent) () + (:metaclass metacomponent) + (: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)))) + +(defmethod wcomponent-template ((exception-monitor exception-monitor)) + (let ((client-id (htcomponent-client-id exception-monitor)) + (body (htcomponent-body exception-monitor))) + (div> :static-id client-id + (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))))))))) + + +;;-------------------------------------------------------------------------------------------

1 0