combined value to db-type coersion routines into single

`coerce-value-to-db-type` fn

db-objs makes use of this as does :clsql-helper-slot-coercer system
(which defines a (setf closer-mop:slot-value-using-class) method)
using the same coersion routine.

re #3
re fisxoj/clsql-helper
re Programming:#449 (1.75)

clsql.lisp

@@ -350,31 +350,95 @@
          (:mssql "smalldatetime")))
       )))
 
-(defun coerce-value-to-db-type (val db-type)
+(defun string-to-boolean (s)
+  "convert a string to a boolean value"
+  (typecase s
+    (list (mapcar #'string-to-boolean s))
+    (string (if
+             (member (trim-and-nullify s)
+                     (list "T" "true" "1" "yes" "y")
+                     :test #'equalp)
+             t nil))
+    (t s)))
+
+(define-condition type-coercion-error (error)
+  ((val :accessor val :initarg :val :initform nil)
+   (to-type :accessor to-type :initarg :to-type :initform nil)
+   (message :accessor message :initarg :message :initform nil))
+  (:report (lambda (c s) (format s "Cant coerce val:~A to db-type:~A"
+                            (val c) (to-type c)))))
+
+(defun type-coercion-error (val to-type)
+  (restart-case (error 'type-coercion-error :val val :to-type to-type)
+    (use-value (new-val) (values new-val t))
+    (continue () val)))
+
+(defmethod coerce-value-to-db-type (val db-type)
+  "Coerces a value to the correct db-type
+
+   if the conversion fails signals a continueable type-coercion-error
+   (use-value is also available)
+
+   returns  (values val coerced?)
+     the coerced value and whether or not a coersion took place
+  "
   (cond
-    ((subtypep db-type 'clsql-sys:varchar)
-     (trim-and-nullify (princ-to-string val)))
+    ((or (null val) (null db-type)) val)
+
+    ((subtypep db-type 'string)
+     (typecase val
+       (string val)
+       (t (values
+           (trim-and-nullify (princ-to-string val))
+           t))))
+
     ((subtypep db-type 'integer)
-     (etypecase val
-       (string (parse-integer val))
-       (integer val)))
+     (typecase val
+       (string (values (parse-integer val) t))
+       (integer val)
+       (t (type-coercion-error val db-type))))
+
     ((subtypep db-type 'double-float)
-     (etypecase val
-       (string (relaxed-parse-float val))
-       (number val)))
+     (typecase val
+       (double-float val)
+       (number (values (float val 0.0d0) t))
+       (string (values (relaxed-parse-float val) t))
+       (t (type-coercion-error val db-type))))
+
+    ((subtypep db-type 'float)
+     (typecase val
+       (float val)
+       (number (values (float val 0.0) t))
+       (string (values (relaxed-parse-float val) t))
+       (t (type-coercion-error val db-type))))
+
     ((subtypep db-type 'number)
-     (etypecase val
-       (string (relaxed-parse-float val))
-       (number val)))
-    ((subtypep db-type 'clsql:date) (convert-to-clsql-date val))
-    ((subtypep db-type 'clsql:wall-time ) (convert-to-clsql-datetime val))
+     (typecase val
+       (number val)
+       (string (values (relaxed-parse-float val) t))
+       (t (type-coercion-error val db-type))))
+
+    ((subtypep db-type 'clsql:date)
+     (typecase val
+       (clsql:date val)
+       (t (alexandria:if-let ((it (convert-to-clsql-date val)))
+            (values it t)
+            (type-coercion-error val 'clsql:date)))))
+
+    ((subtypep db-type 'clsql:wall-time )
+     (typecase val
+       (clsql:wall-time val)
+       (t (alexandria:if-let ((it (convert-to-clsql-datetime val)))
+            (values it t)
+            (type-coercion-error val 'clsql:wall-time)))))
+
     ((subtypep db-type 'boolean)
      (typecase val
-       (string (not (null (member val (list "T" "true" "1" "y" "yes") :test #'string-equal))))
+       (integer (values (not (zerop val)) t))
+       (string (values (string-to-boolean val) t))
        (T val)))
-    ((subtypep db-type 'clsql-sys:duration )
-     (error "NO COERCION IMPLEMENTED"))
-    (T (error "NO COERCION IMPLEMENTED"))))
+
+    (T (type-coercion-error val db-type))))
 
 (defun format-value-for-database (d &optional stream)
   "prints a correctly sql escaped value for postgres"
@@ -401,9 +465,9 @@
   "From N rows and some column-names make N instances of class filling data from rows
    using make instance"
   (iter (for row in rows)
-      (for o = (apply #'make-instance class
-                      (make-instance-plist columns row)))
-      (collect o)))
+    (for o = (apply #'make-instance class
+                    (make-instance-plist columns row)))
+    (collect o)))
 
 (defun make-instances-setting-slot-values (class columns rows)
   "From N rows and column-name make N instances of class filling data from rows
@@ -514,8 +578,19 @@
       (collect (symbol-munger:underscores->keyword k))
       (collect v))))
 
+(defun %coerce-rows
+    (class slot-names rows
+     &aux (types (iter (for s in slot-names)
+                   (collect (access:access
+                             (access:class-slot-by-name class s)
+                             #'clsql-sys::specified-type)))))
+  (iter (for row in rows)
+    (collect (iter (for d in row)
+               (for type in types)
+               (collect (coerce-value-to-db-type d type))))))
+
 (defun db-objs (class cmd &key params (make-instances-fn #'make-instances)
-                          log
+                          log (coerce-rows? t)
                           (column-munger #'symbol-munger:underscores->lisp-symbol))
   "retrieve objects of type class from the database using db-query
 
@@ -526,6 +601,7 @@
          ;; intern in the package expected
          (*package* (find-package (symbol-package class)))
          (fields (mapcar column-munger fields)))
+    (when coerce-rows? (setf rows (%coerce-rows class fields rows)))
     (funcall make-instances-fn class fields rows)))
 
 (defun db-objs-select (class columns &key select-args (make-instances-fn #'make-instances))

package.lisp

@@ -1,6 +1,7 @@
 (cl:defpackage :clsql-helper
   (:use :cl :cl-user :iter)
   (:export
+   #:type-coercion-error
    ;; dirty
    #:dirty-slots
    #:slot-dirty?

set-slot-value-using-class.lisp

@@ -1,17 +1,6 @@
 (in-package :clsql-helper)
 (cl-interpol:enable-interpol-syntax)
 
-(defun string-to-boolean (s)
-  "convert a string to a boolean value"
-  (typecase s
-    (list (mapcar #'string-to-boolean s))
-    (string (if
-             (member (trim-and-nullify s)
-                     (list "T" "true" "1" "yes")
-                     :test #'equalp)
-             t nil))
-    (t s)))
-
 (defmethod (setf closer-mop:slot-value-using-class)
     (new
      (class clsql-sys::standard-db-class)
@@ -20,64 +9,21 @@
   "Ensure that if we try to set a slot on a db-object to a value whos type doesnt match
    that we coerce that value to an appropriate clsql type
 
-   Conversions:
-      strings to date
-      numbers to double-float
-      symbols to strings
-      bits to booleans
+   Conversions run through `coerce-value-to-db-type`
 
    "
-  (let ((spec-type (clsql-sys::specified-type slot)))
-  (if spec-type
-      (cond
-        ((and (subtypep spec-type 'boolean)
-              (typep new '(integer 0 1)))
-         (setf (closer-mop:slot-value-using-class
-                class object slot)
-               (= 1 new)))
-        ((and (subtypep spec-type 'boolean)
-              (typep new 'string))
-         (setf (closer-mop:slot-value-using-class class object slot)
-               (string-to-boolean new)))
-        ;; should have been an integer, but got a string
-        ((and (subtypep spec-type 'integer)
-              (typep new 'string))
-         (setf new (trim-and-nullify new))
-         (setf (closer-mop:slot-value-using-class
-                class object slot)
-               (when new (parse-integer new))))
-
-        ;; should have been an float, but got a string
-        ((and (subtypep spec-type '(or number double-float))
-              (stringp new))
-         (setf (closer-mop:slot-value-using-class
-                class object slot)
-               (relaxed-parse-float new)))
-
-        ;; got a number that wasnt a double-float, but should have been
-	((and (subtypep spec-type 'double-float)
-              (typep new 'number)
-	      (not (typep new 'double-float)))
-	 (setf (closer-mop:slot-value-using-class class object slot)
-	       (coerce new 'double-float)))
-
-        ;; should have been a datetime
-        ((and (subtypep spec-type 'clsql-sys:wall-time)
-              (not (typep new '(or null clsql-sys:wall-time))))
-         (let ((it (convert-to-clsql-datetime new)))
-           (unless it (error "bad-type-conversion to datetime ~A" it))
-           (setf (closer-mop:slot-value-using-class class object slot) it )))
-
-        ;; should have been a date
-        ((and (subtypep spec-type 'clsql-sys:date)
-              (not (typep new '(or null clsql-sys:date))))
-         (let ((it (convert-to-clsql-date new)))
-           (unless it (error "bad-type-conversion to date ~A" it))
-           (setf (closer-mop:slot-value-using-class class object slot) it)))
-
-	;; we specified a string, we have a value and the value isnt a string
-	((and new (not (stringp new)) (subtypep (clsql-sys::specified-type slot) 'string))
-	 (setf (closer-mop:slot-value-using-class class object slot)
-	       (princ-to-string new)))
-	(t (call-next-method)))
-      (call-next-method))))
+  (let* ((spec-type (clsql-sys::specified-type slot))
+         val coerced?)
+    ;; skip bad conversions and leave it for the db to signal
+    (handler-bind ((type-coercion-error
+                     (lambda (c)
+                       (unless (member (to-type c) (list 'clsql:wall-time 'clsql:date))
+                         (continue c)))))
+      (multiple-value-setq (val coerced?)
+        (coerce-value-to-db-type new spec-type)))
+
+    ;; we want to prevent infinite recursion if we didnt convert, if we did,
+    ;; give all multimethods a shot at the new value
+    (if coerced?
+        (setf (closer-mop:slot-value-using-class class object slot) val)
+        (call-next-method))))

tests/clsql.lisp

@@ -194,7 +194,9 @@
             (log-database-command (sql-log)
               (clsql:query "SELECT id, name FROM test WHERE ID=1"))))
         :test #'string-equal))
-   ))
+   )
+
+ )
 
 (define-test clsql-date/times->utime-test (:tags '(dates))
   (let ((utime 3542038020))

tests/set-slot-value-using-class.lisp

@@ -64,22 +64,23 @@
     (assert-true (typep (role-id u) 'integer))
 
     (setf (date-entered u) "7/7/1977 11:43:26.123456")
-    (assert-true (typep (date-entered u) 'clsql-sys:wall-time) (date-entered u))
+    (assert-true (typep (date-entered u) 'clsql-sys:wall-time) (date-entered u) :checked-string)
+
     (setf (date-entered u) (convert-to-clsql-date "7/7/1977 11:43:26.123456"))
-    (assert-true (typep (date-entered u) 'clsql-sys:wall-time) (date-entered u))
+    (assert-true (typep (date-entered u) 'clsql-sys:wall-time) (date-entered u) :checked-date)
     (setf (date-entered u) (convert-to-clsql-datetime "7/7/1977 11:43:26.123456"))
-    (assert-true (typep (date-entered u) 'clsql-sys:wall-time) (date-entered u))
+    (assert-true (typep (date-entered u) 'clsql-sys:wall-time) (date-entered u) :checked-datetime)
     (setf (date-entered u) nil)
-    (assert-true (typep (date-entered u) 'null) (date-entered u))
-    (assert-error 'error (setf (date-entered u) "asdf"))
+    (assert-true (typep (date-entered u) 'null) (date-entered u) :checked-null)
+    (assert-error 'clsql-helper:type-coercion-error (setf (date-entered u) "asdf") :checked-error)
 
     (setf (edate u) nil)
     (assert-true (typep (edate u) 'null) (edate u))
     (setf (edate u) "7/7/1977")
     (assert-true (typep (edate u) 'clsql-sys:date) (edate u))
     (setf (edate u) (convert-to-clsql-datetime "7/7/1977"))
     (assert-true (typep (edate u) 'clsql-sys:date) (edate u))
-    (assert-error 'error (setf (edate u) "asdf"))
+    (assert-error 'clsql-helper:type-coercion-error (setf (edate u) "asdf"))
 
     (setf (amount u) 23)
     (assert-true (typep (amount u) 'double-float) (amount u))