[claw-cvs] r24 - trunk/main/claw-core/src

[achiumenti at common-lisp.net]

Author: achiumenti
Date: Sun Mar 30 23:48:36 2008
New Revision: 24

Modified:
   trunk/main/claw-core/src/validators.lisp
Log:
beginning of local-time integration

Modified: trunk/main/claw-core/src/validators.lisp
==============================================================================
--- trunk/main/claw-core/src/validators.lisp	(original)
+++ trunk/main/claw-core/src/validators.lisp	Sun Mar 30 23:48:36 2008
@@ -30,10 +30,10 @@
 (in-package :claw)
 
 (defgeneric translator-encode (translator wcomponent)
-  (:documentation "Encodes the input component value, used when rendering the component"))
+  (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))
 
 (defgeneric translator-decode (translator wcomponent)
-  (:documentation "Decodes the input component value after a form submit."))
+  (:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))
 
 (defclass translator () 
   ()
@@ -63,6 +63,11 @@
   "*SIMPLE-TRANSLATOR* is the default translator for any CINPUT component. 
 Its encoder and decoder methods pass values unchanged")
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (defclass translator-integer (translator) 
   ((thousand-separator :initarg :thousand-separator
 	 :reader translator-thousand-separator
@@ -115,7 +120,9 @@
 	  (parse-integer (regex-replace-all (format nil "~a" thousand-separator) new-value ""))
 	  (parse-integer new-value)))))
 
-;;=========================================
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defclass translator-number (translator-integer) 
   ((decimals-separator :initarg :decimals-separator
@@ -197,7 +204,83 @@
 	    (coerce result type))))))
 
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defclass translator-date (translator) 
+  ((date-format :initarg :date-format
+		:reader translator-date-fromat
+		:documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
+expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)"))   
+  (:default-initargs :date-format '(:month "/" :date "/" :year))
+  (:documentation "A translator object encodes and decodes local-date object value passed to a html input component"))
+
+
+#|
+(defmethod translator-encode ((translator translator-number) (wcomponent wcomponent))
+  (let* ((page (htcomponent-page wcomponent))
+	 (visit-object (wcomponent-parameter-value wcomponent :visit-object))
+	 (accessor (wcomponent-parameter-value wcomponent :accessor))
+	 (reader (wcomponent-parameter-value wcomponent :reader))
+	 (thousand-separator (translator-thousand-separator translator))
+	 (grouping-size (translator-grouping-size translator))
+	 (decimal-digits (translator-decimal-digits translator))
+	 (decimals-separator (translator-decimals-separator translator))
+	 (signum-directive (if (translator-always-show-signum translator)
+			       "@"
+			       ""))
+	 (integer-control-string (if thousand-separator			   
+			     (format nil "~~~d,' ,v:~aD"  grouping-size signum-directive)
+			     (format nil "~~~ad"  signum-directive)))
+	 
+	 (value (page-req-parameter page (htcomponent-client-id wcomponent) nil)))    
+    (if (component-validation-errors wcomponent)
+	value
+	(progn 
+	  (when (null visit-object)
+	    (setf visit-object (htcomponent-page wcomponent)))
+	  (multiple-value-bind (int-value dec-value)
+	      (floor (cond
+		       ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
+		       (t (funcall (fdefinition reader) visit-object))))
+	    (progn 	      
+	      (setf dec-value (coerce dec-value 'float))
+	    (format nil "~a~a" (if thousand-separator
+				 (string-trim " " (format nil integer-control-string thousand-separator int-value))
+				 (format nil integer-control-string int-value))		    
+		    (cond 
+		      ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
+		       (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
+		      (decimal-digits 
+		       (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
+			 (if (> (length frac-part) decimal-digits)
+			     (setf frac-part (subseq frac-part 0 decimal-digits))
+			     (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
+			 (format nil "~a~a" decimals-separator frac-part)))
+		      (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2)))))))))))
+
 
+(defmethod translator-decode ((translator translator-number) (wcomponent wcomponent))
+  (let* ((thousand-separator (translator-thousand-separator translator))
+	 (type (translator-coerce translator)) 
+	 (int-value)
+	 (dec-value))
+    (multiple-value-bind (client-id new-value)	
+	(component-id-and-value wcomponent)
+      (declare (ignore client-id))
+      (when thousand-separator
+	(setf new-value (regex-replace-all (format nil "~a" thousand-separator) new-value "")))
+      (let ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
+	    (result))
+	(setf int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string)))
+	      dec-value (expt 10 (length (second decomposed-string)))
+	      result (/ int-value dec-value))
+	(if (integerp result)
+	    result
+	    (coerce result type))))))
+|#
 ;;----------------------------------------------------------------------------------------
 (defun add-exception (id reason) 
 "Adds an exception for the given input component identified by its ID with the message expressed by REASON"