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

[claw-cvs] r76 - trunk/main/connectors/hunchentoot/src
by achiumenti＠common-lisp.net 26 Aug '08

26 Aug '08

Author: achiumenti Date: Tue Aug 26 07:08:35 2008 New Revision: 76 Modified: trunk/main/connectors/hunchentoot/src/hunchentoot.lisp Log: updated hunchentoot connector Modified: trunk/main/connectors/hunchentoot/src/hunchentoot.lisp ============================================================================== --- trunk/main/connectors/hunchentoot/src/hunchentoot.lisp (original) +++ trunk/main/connectors/hunchentoot/src/hunchentoot.lisp Tue Aug 26 07:08:35 2008 @@ -29,8 +29,9 @@ (in-package :hunchentoot-connector) -(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) -(setf hunchentoot:*default-content-type* "text/html; charset=utf-8") +(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf) + hunchentoot:*default-content-type* "text/html; charset=utf-8" + hunchentoot:*handle-http-errors-p* nil) (defgeneric claw-to-hunchentoot-cookie (claw-cookie) (:documentation "Returns hunchentoot cookie from a claw cookie")) @@ -313,14 +314,12 @@ (defmethod (setf connector-reply-external-format-encoding) (value (connector hunchentoot-connector)) (let ((encoding (flexi-streams:external-format-name (hunchentoot:reply-external-format)))) - ;(log-message :info "ENCODING: ~a| VALUE: ~a" encoding value) (unless (and (null value) (equal encoding value)) (setf (hunchentoot:reply-external-format) (flex:make-external-format value :eol-style :lf))))) (defmethod connector-writer ((connector hunchentoot-connector)) (hunchentoot:send-headers)) - ;*standard-output*) (defmethod connector-redirect ((connector hunchentoot-connector) target &key host port protocol add-session-id code) (hunchentoot:redirect target

1 0

[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