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

[claw-cvs] r101 - trunk/main/claw-demo/src/backend
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

Author: achiumenti Date: Wed Oct 1 07:58:54 2008 New Revision: 101 Modified: 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/vo.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-demo/src/backend/dao.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/dao.lisp (original) +++ trunk/main/claw-demo/src/backend/dao.lisp Wed Oct 1 07:58:54 2008 @@ -113,7 +113,7 @@ (role-list (user-roles instance)) (role-id-column-name (slot-column-name 'user-role 'role-id)) (table-name (symbol-name (view-table (find-class 'user-role))))) - (when id + (when (and id role-list) (delete-records :from table-name :where (sql-operation 'and (sql-operation '= (slot-column-name 'user-role 'user-id) id) @@ -129,14 +129,15 @@ (user-id-column-name (slot-column-name 'user-role 'user-id)) (role-id-column-name (slot-column-name 'user-role 'role-id)) (role-list (user-roles instance)) - (roles-already-present-id-list (select role-id-column-name - :from table-name - :where (sql-operation 'in user-id-column-name - (loop for user-role in role-list - collect (table-id user-role))) - :flatp t - :refresh t - :database database))) + (roles-already-present-id-list (when role-list + (select role-id-column-name + :from table-name + :where (sql-operation 'in user-id-column-name + (loop for user-role in role-list + collect (table-id user-role))) + :flatp t + :refresh t + :database database)))) (dolist (role (user-roles instance)) (unless (member (table-id role) roles-already-present-id-list) (update-records-from-instance (make-instance 'user-role @@ -149,7 +150,7 @@ (address-list (customer-addresses instance)) (address-id-column-name (slot-column-name 'customer-address 'id)) (table-name (symbol-name (view-table (find-class 'customer-address))))) - (when id + (when (and id address-list) (delete-records :from table-name :where (sql-operation 'and (sql-operation '= (slot-column-name 'customer-address 'customer-id) id) @@ -202,3 +203,197 @@ v))) result)) + +;;---- CLSQL EXTENSIONS ------------------------ + +(in-package #:clsql-sys) + +(defclass sql-join-exp (sql-ident) + ((components :initarg :components) + (modifier :initarg :modifier) + (on :initarg :on))) + +(defmethod make-load-form ((sql sql-join-exp) &optional environment) + (declare (ignore environment)) + (with-slots (components modifier on) + sql + `(make-instance 'sql-join-exp :components ',components :modifier ',modifier :on ',on))) + +(defmethod output-sql ((expr sql-join-exp) database) + (with-slots (modifier components on) + expr + (output-sql (first components) database) + (write-string " " *sql-stream*) + (output-sql modifier database) + (write-string " " *sql-stream*) + (output-sql (second components) database) + (write-string " ON " *sql-stream*) + (output-sql on database))) + + +(defsql sql-join (:symbol "join") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-join-exp + :modifier 'JOIN :components (butlast rest) :on (third rest)) + (error 'sql-user-error "JOIN must have three arguments"))) + +(defsql sql-left-join (:symbol "left-join") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-join-exp + :modifier '|LEFT JOIN| :components (butlast rest) :on (third rest)) + (error 'sql-user-error "LEFT-JOIN must have three arguments"))) + +(defsql sql-right-join (:symbol "right-join") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-join-exp + :modifier '|RIGHT JOIN| :components (butlast rest) :on (third rest)) + (error 'sql-user-error "RIGHT-JOIN must have three arguments"))) + +(defsql sql-inner-join (:symbol "inner-join") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-join-exp + :modifier '|INNER JOIN| :components (butlast rest) :on (third rest)) + (error 'sql-user-error "INNER-JOIN must have three arguments"))) + +(defsql sql-outer-join (:symbol "outer-join") (&rest rest) + (if (= (length rest) 3) + (make-instance 'sql-join-exp + :modifier '|OUTER JOIN| :components (butlast rest) :on (third rest)) + (error 'sql-user-error "OUTER-JOIN must have three arguments"))) + + +(defun select (&rest select-all-args) + "Executes a query on DATABASE, which has a default value of +*DEFAULT-DATABASE*, specified by the SQL expressions supplied +using the remaining arguments in SELECT-ALL-ARGS. The SELECT +argument can be used to generate queries in both functional and +object oriented contexts. + +In the functional case, the required arguments specify the +columns selected by the query and may be symbolic SQL expressions +or strings representing attribute identifiers. Type modified +identifiers indicate that the values selected from the specified +column are converted to the specified lisp type. The keyword +arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY, +SET-OPERATION and WHERE are used to specify, using the symbolic +SQL syntax, the corresponding components of the SQL query +generated by the call to SELECT. RESULT-TYPES is a list of +symbols which specifies the lisp type for each field returned by +the query. If RESULT-TYPES is nil all results are returned as +strings whereas the default value of :auto means that the lisp +types are automatically computed for each field. FIELD-NAMES is t +by default which means that the second value returned is a list +of strings representing the columns selected by the query. If +FIELD-NAMES is nil, the list of column names is not returned as a +second value. + +In the object oriented case, the required arguments to SELECT are +symbols denoting View Classes which specify the database tables +to query. In this case, SELECT returns a list of View Class +instances whose slots are set from the attribute values of the +records in the specified table. Slot-value is a legal operator +which can be employed as part of the symbolic SQL syntax used in +the WHERE keyword argument to SELECT. REFRESH is nil by default +which means that the View Class instances returned are retrieved +from a cache if an equivalent call to SELECT has previously been +issued. If REFRESH is true, the View Class instances returned are +updated as necessary from the database and the generic function +INSTANCE-REFRESHED is called to perform any necessary operations +on the updated instances. + +In both object oriented and functional contexts, FLATP has a +default value of nil which means that the results are returned as +a list of lists. If FLATP is t and only one result is returned +for each record selected in the query, the results are returneds +as elements of a list." + + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + target-args)))) + (multiple-value-bind (target-args qualifier-args) + (query-get-selections select-all-args) + (unless (or *default-database* (getf qualifier-args :database)) + (signal-no-database-error nil)) + + (cond + ((select-objects target-args) + (let ((caching (getf qualifier-args :caching *default-caching*)) + (result-types (getf qualifier-args :result-types :auto)) + (refresh (getf qualifier-args :refresh nil)) + (database (or (getf qualifier-args :database) *default-database*)) + (order-by (getf qualifier-args :order-by))) + (remf qualifier-args :caching) + (remf qualifier-args :refresh) + (remf qualifier-args :result-types) + + ;; Add explicity table name to order-by if not specified and only + ;; one selected table. This is required so FIND-ALL won't duplicate + ;; the field + (when (and order-by (= 1 (length target-args))) + (let ((table-name (view-table (find-class (car target-args)))) + (order-by-list (copy-seq (listify order-by)))) + + (loop for i from 0 below (length order-by-list) + do (etypecase (nth i order-by-list) + (sql-ident-attribute + (unless (slot-value (nth i order-by-list) 'qualifier) + (setf (slot-value (nth i order-by-list) 'qualifier) table-name))) + (cons + (unless (slot-value (car (nth i order-by-list)) 'qualifier) + (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))))) + (setf (getf qualifier-args :order-by) order-by-list))) + + (cond + ((null caching) + (apply #'find-all target-args + (append qualifier-args + (list :result-types result-types :refresh refresh)))) + (t + (let ((cached (records-cache-results target-args qualifier-args database))) + (cond + ((and cached (not refresh)) + cached) + ((and cached refresh) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)) + (t + (let ((results (apply #'find-all target-args (append qualifier-args + `(:result-types :auto :refresh ,refresh))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)))))))) + (t + (let* ((expr (apply #'make-query select-all-args)) + (specified-types + (mapcar #'(lambda (attrib) + (if (typep attrib 'sql-ident-attribute) + (let ((type (slot-value attrib 'type))) + (if type + type + t)) + t)) + (slot-value expr 'selections)))) + (destructuring-bind (&key (flatp nil) + (result-types :auto) + (field-names t) + (database *default-database*) + &allow-other-keys) + qualifier-args + (progn + (when (listp (slot-value expr 'from)) + (let ((join (first (member-if #'(lambda (i) (typep i 'sql-join-exp)) (slot-value expr 'from))))) + (when join + (setf (slot-value expr 'from) join)))) + (query expr :flatp flatp + :result-types + ;; specifying a type for an attribute overrides result-types + (if (some #'(lambda (x) (not (eq t x))) specified-types) + specified-types + result-types) + :field-names field-names + :database database))))))))) + +(export '(sql-join sql-left-join sql-right-join sql-outer-join sql-inner-join)) \ No newline at end of file Modified: trunk/main/claw-demo/src/backend/packages.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/packages.lisp (original) +++ trunk/main/claw-demo/src/backend/packages.lisp Wed Oct 1 07:58:54 2008 @@ -31,7 +31,7 @@ (defpackage :claw-demo-backend - (:use :cl :clsql :clsql-postgresql :local-time :claw :closer-mop :split-sequence) + (:use :cl :clsql :clsql-sys :clsql-postgresql :local-time :claw :closer-mop :split-sequence) (:shadowing-import-from :local-time :timezone :decode-duration @@ -103,5 +103,8 @@ #:find-by-id #:delete-by-id #:delete-class-records + #:find-vo + #:count-vo #:find-user-by-name - #:find-customers)) \ No newline at end of file + #:find-customers + #:find-users)) \ No newline at end of file Modified: trunk/main/claw-demo/src/backend/service.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/service.lisp (original) +++ trunk/main/claw-demo/src/backend/service.lisp Wed Oct 1 07:58:54 2008 @@ -60,10 +60,25 @@ (second field)) (sql-expression :attribute field)))) -(defun find-vo (symbol-class &key (offset 0) (limit *select-limit*) (refresh t) where group-by having order-by) +(defun find-vo (symbol-class &key (offset 0) (limit *select-limit*) (refresh t) from where group-by having order-by (distinct t)) "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." +#| + (claw:log-message :info "--> ~a" (print-query (make-instance 'clsql-sys:query symbol-class + :from from + :where where + :group-by group-by + :having having + :order-by (when order-by (build-order-by order-by)) + :flatp t + :refresh refresh + :offset offset + :limit limit + :distinct distinct + :database *claw-demo-db*))) +|# (values (select symbol-class + :from from :where where :group-by group-by :having having @@ -72,18 +87,20 @@ :refresh refresh :offset offset :limit limit + :distinct distinct :database *claw-demo-db*) - (count-vo symbol-class :refresh refresh :where where :group-by group-by :having having))) + (count-vo symbol-class :refresh refresh :from from :where where :group-by group-by :having having))) -(defun count-vo (symbol-class &key (refresh t) where group-by having) +(defun count-vo (symbol-class &key (refresh t) from where group-by having (distinct t)) "Returns the number of records matching the given criteria" (first (select (sql-operation 'count '*) - :from (view-table (find-class symbol-class)) + :from (or from (view-table (find-class symbol-class))) :where where :group-by group-by :having having :flatp t :refresh refresh + :distinct distinct :database *claw-demo-db*))) (defun find-by-id (symbol-class id) @@ -135,3 +152,45 @@ (apply #'sql-operation (cons 'and where)) (first where)) :order-by sorting))) + +(clsql-sys:locally-enable-sql-reader-syntax) +(defun find-users (&key (offset 0) (limit *select-limit*) surname firstname email username (active :any) role-names sorting) + (let ((where (remove-if #'null (list + (when surname + (like-operation (sql-slot-value 'user 'surname) + surname)) + (when firstname + (like-operation (sql-slot-value 'user 'firstname) + firstname)) + (when username + (like-operation (sql-slot-value 'user 'username) + firstname)) + (when email + (like-operation (sql-slot-value 'user 'email) + email)) + (unless (eql active :any) + (sql-operation '= (sql-slot-value 'user 'active) + active)) + (when role-names + (sql-operation 'in (sql-slot-value 'role 'name) role-names)))))) + (find-vo 'user :offset offset + :limit limit + :from (sql-join (sql-join (view-table (find-class 'user)) + (view-table (find-class 'user-role)) + (sql-operation '= + (sql-slot-value 'user 'id) + (sql-slot-value 'user-role 'user-id))) + (view-table (find-class 'role)) + (sql-operation '= + (sql-slot-value 'user-role 'role-id) + (sql-slot-value 'role 'id))) + :where (if (> (length where) 1) + (apply #'sql-operation (cons 'and where)) + (first where)) + :order-by sorting))) + +#| +(defun oo () + (list [slot-value 'role 'id])) +|# +(clsql-sys:locally-disable-sql-reader-syntax) \ No newline at end of file Modified: trunk/main/claw-demo/src/backend/vo.lisp ============================================================================== --- trunk/main/claw-demo/src/backend/vo.lisp (original) +++ trunk/main/claw-demo/src/backend/vo.lisp Wed Oct 1 07:58:54 2008 @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: src/vo.lisp $ +;;; $Header: src/backend/vo.lisp $ ;;; Copyright (c) 2008, Andrea Chiumenti. All rights reserved.

1 0

[claw-cvs] r100 - trunk/main/claw-html.dojo/src
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

Author: achiumenti Date: Wed Oct 1 07:57:59 2008 New Revision: 100 Removed: trunk/main/claw-html.dojo/src/djtoolbar.fasl Modified: trunk/main/claw-html.dojo/src/djform.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-html.dojo/src/djform.lisp ============================================================================== --- trunk/main/claw-html.dojo/src/djform.lisp (original) +++ trunk/main/claw-html.dojo/src/djform.lisp Wed Oct 1 07:57:59 2008 @@ -79,7 +79,7 @@ (input> :static-id client-id :type type :dojoType dojo-type - :name client-id + :name (name-attr obj) :class class :value value (wcomponent-informal-parameters obj)))) @@ -218,7 +218,7 @@ (setf value (translator-encode translator obj)) (select> :static-id client-id :dojoType dojo-type - :name client-id + :name (name-attr obj) :class class :value value :multiple (cinput-result-as-list-p obj) @@ -333,9 +333,11 @@ (:default-initargs :dojo-require (list "dijit.form.Slider"))) (defclass _djslider-slider (cinput _djslider) - () + ((name :initarg :name + :reader base-cinput-name + :documentation "When specified the name tag attribute, otherwise the given component id is used")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :translator *number-translator*) + (:default-initargs :reserved-parameters (list :value) :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))

1 0

[claw-cvs] r99 - trunk/main/claw-html/src
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

Author: achiumenti Date: Wed Oct 1 07:57:12 2008 New Revision: 99 Modified: trunk/main/claw-html/src/components.lisp trunk/main/claw-html/src/packages.lisp trunk/main/claw-html/src/tags.lisp trunk/main/claw-html/src/translators.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw-html/src/components.lisp ============================================================================== --- trunk/main/claw-html/src/components.lisp (original) +++ trunk/main/claw-html/src/components.lisp Wed Oct 1 07:57:12 2008 @@ -38,9 +38,9 @@ - OBJ the wcomponent instance - PAGE-OBJ the wcomponent owner page")) -(defgeneric component-id-and-value (cinput &key from-request-p) +(defgeneric component-id-and-value (cinput) (:documentation "Returns the form component \(such as <input> and <select>) client-id and the associated value. -When FROM-REQUEST-P is not null, the value is retrived from the http request by its name, from the associated reader or accessor when nil")) +The value may be retrived from the http request by its name, from the associated reader or accessor when nil if no relative request parameter is set")) (defgeneric label (cinput) (:documentation "Returns the label that describes the component. It's also be used when component validation fails. If it's a function it is funcalled")) @@ -233,8 +233,14 @@ :documentation "The object hoding the property mapped to the current input html component. When nil the owner page is used.") (css-class :initarg :class :reader css-class - :documentation "the html component class attribute")) - (:default-initargs :multiple nil :writer nil :reader nil :accessor nil :class nil + :documentation "the html component class attribute") + (name :initarg :name + :reader base-cinput-name + :documentation "When specified the name tag attribute, otherwise the given component id is used") + (empty-to-null-p :initarg :empty-to-null-p + :reader base-cinput-empty-to-null-p + :documentation "When not NIL and empty string is threated as a NIL value")) + (:default-initargs :name nil :multiple nil :writer nil :reader nil :accessor nil :class nil :empty-to-null-p t :label nil :translator *simple-translator* :validator nil :visit-object *claw-current-page*) (:documentation "Class inherited from both CINPUT and CSELECT")) @@ -245,14 +251,15 @@ label))) (defmethod name-attr ((cinput base-cinput)) - (htcomponent-client-id cinput)) + (or (base-cinput-name cinput) + (htcomponent-client-id cinput))) (defclass cinput (base-cinput) ((input-type :initarg :type :reader input-type :documentation "The html <input> TYPE attribute. For submit type, use the CSUBMIT> function.")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name) :empty t :type "text") + (:default-initargs :reserved-parameters (list :value) :empty t :type "text") (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cinput))) @@ -298,13 +305,17 @@ (funcall validator cinput)) (unless (component-validation-errors cinput) (if (and (null writer) accessor) - (funcall (fdefinition `(setf ,accessor)) value visit-object) - (funcall (fdefinition writer) value visit-object))))))) + (funcall (fdefinition `(setf ,accessor)) (if (and (stringp value) (string= value "") (base-cinput-empty-to-null-p cinput)) + nil + value) visit-object) + (funcall (fdefinition writer) (if (and (stringp value) (string= value "") (base-cinput-empty-to-null-p cinput)) + nil + value) visit-object))))))) (defclass ctextarea (base-cinput) () (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :name) :empty nil) + (:default-initargs :empty nil) (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'ctextarea))) @@ -333,8 +344,9 @@ (wcomponent-informal-parameters ctextarea) (or value "")))) -(defmethod component-id-and-value ((cinput base-cinput) &key (from-request-p t)) +(defmethod component-id-and-value ((cinput base-cinput)) (let ((client-id (htcomponent-client-id cinput)) + (from-request-p (nth-value 1 (gethash (string-upcase (name-attr cinput)) (page-request-parameters *claw-current-page*)))) (visit-object (cinput-visit-object cinput)) (accessor (cinput-accessor cinput)) (reader (cinput-reader cinput)) @@ -347,14 +359,14 @@ (name-attr cinput) result-as-list-p)) ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) + (reader (funcall (fdefinition reader) visit-object)))) (values client-id value)))) ;--------------------------------------------------------------------------------------- (defclass cinput-file (cinput) () (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :value :name :type) :empty t :type "file" :translator *file-translator*) + (:default-initargs :reserved-parameters (list :value :type) :empty t :type "file" :translator *file-translator*) (:documentation "Request cycle aware component the renders as an INPUT tag class of type file")) (let ((class (find-class 'cinput-file))) @@ -374,7 +386,7 @@ :reader csubmit-value :documentation "The html VALUE attribute")) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :type :name) :empty t :action nil) + (:default-initargs :reserved-parameters (list :type ) :empty t :action nil) (:documentation "This component render as an INPUT tag class ot type submit, but can override the default CFORM action, using its own associated action")) @@ -443,7 +455,7 @@ ;-------------------------------------------------------------------------- (defclass cselect (base-cinput) () - (:default-initargs :reserved-parameters (list :type :name) :empty nil) + (:default-initargs :reserved-parameters (list :type) :empty nil) (:metaclass metacomponent) (:documentation "This component renders as a normal SELECT tag class, but it is request cycle aware.")) @@ -480,13 +492,14 @@ (value :initarg :value :accessor ccheckbox-value)) (:metaclass metacomponent) - (:default-initargs :reserved-parameters (list :name) :empty t :type "checkbox" :test #'equal) + (:default-initargs :reserved-parameters () :empty t :type "checkbox" :test #'equal :multiple t) (:documentation "Request cycle aware component the renders as an INPUT tag class. IMPORTANT its assigned id mus be unique since its NAME tag attribute will be extracted from the assigned id and not from the generate one as for other cinput components")) (defmethod name-attr ((cinput ccheckbox)) - (htcomponent-real-id cinput)) + (or (base-cinput-name cinput) + (htcomponent-real-id cinput))) (let ((class (find-class 'ccheckbox))) (closer-mop:ensure-finalized class) @@ -504,7 +517,7 @@ (translator (translator cinput)) (type (input-type cinput)) (value (translator-value-type-to-string translator (ccheckbox-value cinput))) - (current-value (translator-string-to-type translator cinput)) + (accessor-value (translator-string-to-type translator cinput)) (class (css-class cinput)) (test (ccheckbox-test cinput))) (when (component-validation-errors cinput) @@ -516,10 +529,11 @@ :name (name-attr cinput) :class class :value value - :checked (when (and current-value - (if (listp current-value) - (member (ccheckbox-value cinput) current-value :test test) - (funcall test (ccheckbox-value cinput) current-value))) "checked") + :checked (when (and (or (cinput-accessor cinput) + (cinput-reader cinput)) accessor-value + (if (listp accessor-value) + (member value accessor-value :test test) + (funcall test value accessor-value))) "checked") (wcomponent-informal-parameters cinput)))) (defmethod wcomponent-after-rewind ((cinput ccheckbox) (page page)) @@ -545,13 +559,14 @@ (unless (component-validation-errors cinput) (if (and (null writer) accessor) (funcall (fdefinition `(setf ,accessor)) new-value visit-object) - (funcall (fdefinition writer) new-value visit-object))))))) + (when writer + (funcall (fdefinition writer) new-value visit-object)))))))) ;------------------------------------------------------------------------------------- (defclass cradio (ccheckbox) () (:metaclass metacomponent) - (:default-initargs :type "radio") + (:default-initargs :type "radio" :multiple t :reserved-parameters '(:multiple)) (:documentation "Request cycle aware component the renders as an INPUT tag class")) (let ((class (find-class 'cradio))) @@ -566,9 +581,55 @@ (describe-html-attributes-from-class-slot-initargs class) (describe-component-behaviour class)))) -(defmethod name-attr ((ccheckbox ccheckbox)) - (htcomponent-real-id ccheckbox)) +(defmethod wcomponent-template ((cinput cradio)) + (let* ((client-id (htcomponent-client-id cinput)) + (translator (translator cinput)) + (type (input-type cinput)) + (value (translator-value-type-to-string translator (ccheckbox-value cinput))) + (accessor-value (first (translator-string-to-type translator cinput))) + (class (css-class cinput)) + (test (ccheckbox-test cinput))) + (when (component-validation-errors cinput) + (if (or (null class) (string= class "")) + (setf class "error") + (setf class (format nil "~a error" class)))) + (input> :static-id client-id + :type type + :name (name-attr cinput) + :class class + :value value + :checked (when (and (or (cinput-accessor cinput) + (cinput-reader cinput)) accessor-value + (funcall test value accessor-value)) "checked") + (wcomponent-informal-parameters cinput)))) + +(defmethod wcomponent-after-rewind ((cinput cradio) (page page)) + (when (cform-rewinding-p (page-current-form page) page) + (let* ((visit-object (cinput-visit-object cinput)) + (name (name-attr cinput)) + (translator (translator cinput)) + (accessor (cinput-accessor cinput)) + (writer (cinput-writer cinput)) + (validator (validator cinput)) + (result-as-list-p (cinput-result-as-list-p cinput)) + (new-value (page-req-parameter page + name + result-as-list-p))) + (when new-value + (setf new-value + (first (remove-if #'(lambda (x) (or (null x) (and (stringp x) (string-equal x "")))) + (loop for item in new-value + collect (translator-value-string-to-type translator item)))))) + (unless (or (null visit-object) (component-validation-errors cinput)) + (when validator + (funcall validator (or new-value ""))) + (unless (component-validation-errors cinput) + (if (and (null writer) accessor) + (funcall (fdefinition `(setf ,accessor)) new-value visit-object) + (when writer + (funcall (fdefinition writer) new-value visit-object)))))))) +#| (defmethod wcomponent-after-rewind ((cinput cradio) (page page)) (when (cform-rewinding-p (page-current-form page) page) (let* ((visit-object (cinput-visit-object cinput)) @@ -612,3 +673,4 @@ :value value :checked (when (and current-value (equal value current-value)) "checked") (wcomponent-informal-parameters cinput)))) +|# \ No newline at end of file Modified: trunk/main/claw-html/src/packages.lisp ============================================================================== --- trunk/main/claw-html/src/packages.lisp (original) +++ trunk/main/claw-html/src/packages.lisp Wed Oct 1 07:57:12 2008 @@ -229,6 +229,7 @@ ;;validation #:translator + #:validation-error-control-string #:translator-integer #:translator-number #:translator-boolean Modified: trunk/main/claw-html/src/tags.lisp ============================================================================== --- trunk/main/claw-html/src/tags.lisp (original) +++ trunk/main/claw-html/src/tags.lisp Wed Oct 1 07:57:12 2008 @@ -1179,13 +1179,13 @@ 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)) + (error (format nil "Parameter ~a for component ~a is reserved" initarg (type-of wcomponent))) (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)) + (type-of wcomponent))) (setf (getf (wcomponent-informal-parameters wcomponent) initarg) new-value)))))) Modified: trunk/main/claw-html/src/translators.lisp ============================================================================== --- trunk/main/claw-html/src/translators.lisp (original) +++ trunk/main/claw-html/src/translators.lisp Wed Oct 1 07:57:12 2008 @@ -79,7 +79,7 @@ (progn (setf value (cond ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object)) - (t (funcall (fdefinition reader) visit-object)))) + (reader (funcall (fdefinition reader) visit-object)))) (if (listp value) (loop for item in value collect (translator-value-encode translator item))

1 0

[claw-cvs] r98 - trunk/main/claw/src
by achiumenti＠common-lisp.net 01 Oct '08

01 Oct '08

Author: achiumenti Date: Wed Oct 1 07:56:41 2008 New Revision: 98 Modified: trunk/main/claw/src/lisplet.lisp Log: several bugfixes and enhancements Modified: trunk/main/claw/src/lisplet.lisp ============================================================================== --- trunk/main/claw/src/lisplet.lisp (original) +++ trunk/main/claw/src/lisplet.lisp Wed Oct 1 07:56:41 2008 @@ -258,5 +258,5 @@ (string-not-equal (claw-script-name) login-page-url)) (redirect-to-https (format nil "~a~a" *root-path* (lisplet-login-page lisplet)))) ((and sslport (not (= (claw-server-port) sslport))) - (redirect-to-https (format nil "~a~a" *root-path* (car protected-resource))) + (redirect-to-https (format nil "~a/~a" *root-path* (car protected-resource))) (throw 'handler-done nil)))))))))

1 0