Added a read-decimal-value function using cl-decimals
authorRuss Tyndall <russ@acceleration.net>
Fri, 9 Oct 2015 15:49:24 +0000 (11:49 -0400)
committerRuss Tyndall <russ@acceleration.net>
Fri, 9 Oct 2015 15:49:24 +0000 (11:49 -0400)
I was having problems with postgresql returning formatted
currency strings for money types (eg: "$ 12,535.20")

https://github.com/tlikonen/cl-decimals

ChangeLog
clsql.asd
sql/decimals.lisp [new file with mode: 0644]
sql/oodml.lisp
sql/utils.lisp
tests/test-internal.lisp

index ccc8afc..6cedb6c 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,8 @@
-
+2015-10-09 Russ Tyndall <russ@acceleration.net> 
+        * add decimals.lisp file https://github.com/tlikonen/cl-decimals
+       * use this for safe parsing of numeric / decimal / rational types
+       * Added because newer postgres print money types as currency strings
+       
 2015-08-12 Kevin Rosenberg <kevin@rosenberg.net>
        * Version 6.6.3 release
        * db-oracle/oracle-sql.lisp: Patch for PostgreSQL socket interface
index 74afd3b..4f00950 100644 (file)
--- a/clsql.asd
+++ b/clsql.asd
@@ -54,6 +54,7 @@ oriented interface."
                         (:file "base-classes" :depends-on ("package"))
                          (:file "conditions" :depends-on ("base-classes"))
                          (:file "db-interface" :depends-on ("conditions"))
+                         (:file "decimals" :depends-on ("package" "db-interface"))
                         (:file "utils" :depends-on ("package" "db-interface"))
                         (:file "time" :depends-on ("package" "conditions" "utils"))
                          (:file "generics" :depends-on ("package"))))
diff --git a/sql/decimals.lisp b/sql/decimals.lisp
new file mode 100644 (file)
index 0000000..b8df6fc
--- /dev/null
@@ -0,0 +1,419 @@
+;;; DECIMALS
+;;
+;; A decimal number parser and formatting package for Common Lisp.
+;;
+;; Author: Teemu Likonen <tlikonen@iki.fi>
+;;
+;; License: Public domain
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+(defpackage #:decimals
+  (:use #:cl)
+  (:export #:round-half-away-from-zero
+           #:format-decimal-number
+           #:parse-decimal-number
+           #:decimal-parse-error
+           #:define-decimal-formatter))
+
+(in-package #:decimals)
+
+
+(defun round-half-away-from-zero (number &optional (divisor 1))
+
+  "Divide _number_ by _divisor_ and round the result to the nearest integer.
+If the result is half-way between two integers round away from zero. Two
+values are returned: quotient and remainder.
+
+This is similar to `cl:round` function except that `cl:round` rounds to
+an even integer when number is exactly between two integers. Examples:
+
+    (round-half-away-from-zero 3/2) => 2, -1/2
+    (round 3/2)                     => 2, -1/2
+
+    (round-half-away-from-zero 5/2) => 3, -1/2
+    (round 5/2)                     => 2, 1/2"
+
+  (if (zerop number)
+      (values 0 0)
+      (let ((quotient (if (plusp number)
+                          (floor (+ (/ number divisor) 1/2))
+                          (ceiling (- (/ number divisor) 1/2)))))
+        (values quotient (- number (* quotient divisor))))))
+
+
+(defun divide-into-groups (string &key (separator #\Space) (from-end nil)
+                           (group-digits 3))
+
+  (assert (and (integerp group-digits)
+               (plusp group-digits))
+          (group-digits)
+          "The GROUP-DIGITS argument must be a positive integer")
+
+  (setf separator (princ-to-string separator))
+
+  (if (zerop (length separator))
+      string
+      (flet ((make-groups (string separator)
+               (loop :with length := (length string)
+                     :with result := (make-array length :element-type 'character
+                                                 :fill-pointer 0 :adjustable t)
+                     :for c :across string
+                     :for i :upfrom 1
+                     :do (vector-push-extend c result)
+                     :if (and (zerop (rem i group-digits))
+                              (< i length))
+                     :do (loop :for c :across separator
+                               :do (vector-push-extend c result))
+                     :finally (return result))))
+
+        (if from-end
+            (nreverse (make-groups (reverse string) (reverse separator)))
+            (make-groups string separator)))))
+
+
+(defun decimal-round-split (number &key
+                            (round-magnitude 0)
+                            (rounder #'round-half-away-from-zero)
+                            (positive-sign #\+)
+                            (negative-sign #\-)
+                            (zero-sign nil))
+
+  (assert (integerp round-magnitude) (round-magnitude)
+          "ROUND-MAGNITUDE argument must be an integer.")
+
+  (when (floatp number)
+    (setf number (rational number)))
+
+  (let ((divisor (expt 10 round-magnitude)))
+    (setf number (* divisor (funcall rounder number divisor))))
+
+  (let ((sign (cond ((plusp number) (or positive-sign ""))
+                    ((minusp number) (or negative-sign ""))
+                    (t (or zero-sign "")))))
+
+    (multiple-value-bind (integer fractional)
+        (truncate (abs number))
+      (let ((fractional-string
+             (with-output-to-string (out)
+               (loop :with next := fractional
+                     :with remainder
+                     :repeat (abs round-magnitude)
+                     :until (zerop next)
+                     :do
+                     (setf (values next remainder) (truncate (* next 10)))
+                     (princ next out)
+                     (setf next remainder)))))
+        (list (princ-to-string sign)
+              (princ-to-string integer)
+              fractional-string)))))
+
+
+(defun string-align (string width &key (side :left) (char #\Space))
+  (if (>= (length string) width)
+      string
+      (let ((result (make-string width :initial-element char)))
+        (ecase side
+          (:left (replace result string))
+          (:right (replace result string
+                           :start1 (- width (length string))))))))
+
+
+(defun format-decimal-number (number &key
+                              (round-magnitude 0)
+                              (rounder #'round-half-away-from-zero)
+                              (decimal-separator #\.)
+                              (integer-group-separator nil)
+                              (integer-group-digits 3)
+                              (integer-minimum-width 0)
+                              (integer-pad-char #\Space)
+                              (fractional-group-separator nil)
+                              (fractional-group-digits 3)
+                              (fractional-minimum-width 0)
+                              (fractional-pad-char #\Space)
+                              (show-trailing-zeros nil)
+                              (positive-sign nil)
+                              (negative-sign #\-)
+                              (zero-sign nil))
+
+  "Apply specified decimal number formatting rules to _number_ and
+return a formatted string.
+
+The second return value is (almost) the same formatted string divided
+into four strings. It's a list of four strings: sign, integer part,
+decimal separator and fractional part. Formatting arguments
+_integer-minimum-width_ and _fractional-minimum-width_ do not apply to
+the second return value. Everything else does.
+
+_Number_ must be of type `real`. This function uses `rational` types
+internally. If the given _number_ is a `float` it is first turned into
+`rational` by calling `cl:rational`.
+
+Formatting rules are specified with keyword arguments, as described
+below. The default value is in parentheses.
+
+  * `round-magnitude (0)`
+
+    This is the order of magnitude used for rounding. The value must be
+    an integer and it is interpreted as a power of 10.
+
+  * `show-trailing-zeros (nil)`
+
+    If the value is non-nil print all trailing zeros in fractional part.
+    Examples:
+
+        (format-decimal-number 1/5 :round-magnitude -3
+                               :show-trailing-zeros nil)
+        => \"0.2\"
+
+        (format-decimal-number 1/5 :round-magnitude -3
+                               :show-trailing-zeros t)
+        => \"0.200\"
+
+  * `rounder (#'round-half-away-from-zero)`
+
+    The value must be a function (or a symbol naming a function). It is
+    used to round the number to the specified round magnitude. The
+    function must work like `cl:truncate`, `cl:floor`, `cl:ceiling` and
+    `cl:round`, that is, take two arguments, a number and a divisor, and
+    return the quotient as the first value.
+
+    This package introduces another rounding function,
+    `round-half-away-from-zero`, which is used by default. See its
+    documentation for more information.
+
+  * `decimal-separator (#\\.)`
+
+    If the value is non-nil the `princ` output of the value will be
+    added between integer and fractional parts. Probably the most useful
+    types are `character` and `string`.
+
+  * `integer-group-separator    (nil)`
+  * `fractional-group-separator (nil)`
+
+    If the value is non-nil the digits in integer or fractional parts
+    are put in groups. The `princ` output of the value will be added
+    between digit groups.
+
+  * `integer-group-digits    (3)`
+  * `fractional-group-digits (3)`
+
+    The value is a positive integer defining the number of digits in
+    groups.
+
+  * `integer-minimum-width    (0)`
+  * `fractional-minimum-width (0)`
+
+    Format integer or fractional part using minimum of this amount of
+    characters, possibly using some padding characters (see below).
+    _positive-sign_, _negative-sign_ or _zero-sign_ (see below) is
+    included when calculating the width of the integer part. Similarly
+    _decimal-separator_ is included when calculating the width of the
+    fractional part.
+
+  * `integer-pad-char    (#\\Space)`
+  * `fractional-pad-char (#\\Space)`
+
+    The value is the padding character which is used to fill
+    _integer-minimum-width_ or _fractional-minimum-width_.
+
+  * `positive-sign (nil)`
+  * `negative-sign (#\\-)`
+  * `zero-sign     (nil)`
+
+    If values are non-nil these are used as the leading sign for
+    positive, negative and zero numbers. The `princ` output of the value
+    is used."
+
+  (destructuring-bind (sign integer fractional)
+      (decimal-round-split number
+                           :round-magnitude round-magnitude
+                           :rounder rounder
+                           :positive-sign positive-sign
+                           :negative-sign negative-sign
+                           :zero-sign zero-sign)
+
+    (setf decimal-separator (if decimal-separator
+                                (princ-to-string decimal-separator)
+                                "")
+          integer (divide-into-groups
+                   integer
+                   :separator (or integer-group-separator "")
+                   :group-digits integer-group-digits
+                   :from-end t)
+          fractional (divide-into-groups
+                      (if (and show-trailing-zeros
+                               (plusp (- (- (length fractional))
+                                         round-magnitude)))
+                          (replace (make-string (abs round-magnitude)
+                                                :initial-element #\0)
+                                   fractional)
+                          fractional)
+                      :separator (or fractional-group-separator "")
+                      :group-digits fractional-group-digits
+                      :from-end nil))
+
+    (values
+     (concatenate
+      'string
+      (string-align (concatenate 'string sign integer)
+                    integer-minimum-width
+                    :side :right :char integer-pad-char)
+      (string-align (if (plusp (length fractional))
+                        (concatenate 'string decimal-separator fractional)
+                        "")
+                    fractional-minimum-width
+                    :side :left :char fractional-pad-char))
+     (list sign integer decimal-separator fractional))))
+
+
+(defmacro define-decimal-formatter (name &body keyword-arguments)
+
+  "Define a decimal number formatter function to use with the `~/`
+directive of `cl:format`. The valid format is this:
+
+    (define-decimal-formatter name
+      (:keyword form)
+      ...)
+
+_Name_ is the symbol that names the function. _Keyword_ must be a valid
+keyword argument for the `format-decimal-number` function (see its
+documentation for more information). _Form_ is evaluated and the value
+is used with the _keyword_ argument. Macro's side effect is that global
+function _name_ is defined. It can be used with the `~/` directive of
+`cl:format` function.
+
+Examples:
+
+    (define-decimal-formatter my-formatter
+      (:round-magnitude -6)
+      (:decimal-separator \",\")
+      (:integer-group-separator \" \")
+      (:integer-minimum-width 4)
+      (:fractional-group-separator \" \")
+      (:fractional-minimum-width 10)
+      (:show-trailing-zeros t))
+    => MY-FORMATTER
+
+    (format nil \"~/my-formatter/\" 10/6)
+    => \"   1,666 667  \"
+
+    (format nil \"~/my-formatter/\" 100/8)
+    => \"  12,500 000  \"
+
+The `~/` directive function call can optionally take up to three
+arguments to override the defaults:
+
+    ~round-magnitude,integer-minimum-width,fractional-minimum-width/FUNCTION/
+
+For example:
+
+    (format nil \"~-2,3,4/my-formatter/\" 10/6)
+    => \"  1,67 \""
+
+  (let ((key-arg (gensym)))
+    `(let ((,key-arg (list ,@(loop :for (keyword value) :in keyword-arguments
+                                   :do (assert (keywordp keyword) (keyword)
+                                               "Keyword required.")
+                                   :collect keyword :collect value))))
+
+       (defun ,name (stream number &optional colon-p at-sign-p
+                     round-magnitude integer-minimum-width
+                     fractional-minimum-width)
+         (declare (ignore colon-p at-sign-p))
+
+         (let ((args (copy-list ,key-arg)))
+           (when round-magnitude
+             (setf (getf args :round-magnitude)
+                   round-magnitude))
+           (when integer-minimum-width
+             (setf (getf args :integer-minimum-width)
+                   integer-minimum-width))
+           (when fractional-minimum-width
+             (setf (getf args :fractional-minimum-width)
+                   fractional-minimum-width))
+           (princ (apply #'format-decimal-number number args) stream))))))
+
+
+(defun number-string-to-integer (string)
+  (handler-case (parse-integer string)
+    (parse-error () nil)))
+
+
+(defun number-string-to-fractional (string)
+  (when (every #'digit-char-p string)
+    (setf string (string-right-trim "0" string))
+    (handler-case (/ (parse-integer string)
+                     (expt 10 (length string)))
+      (parse-error () nil))))
+
+
+(define-condition decimal-parse-error (parse-error)
+  nil
+  (:report "Not a valid decimal number string.")
+  (:documentation
+   "Function `parse-decimal-number` signals this condition when it
+couldn't parse a decimal number from string."))
+
+
+(defun parse-decimal-number (string &key
+                             (decimal-separator #\.)
+                             (positive-sign #\+)
+                             (negative-sign #\-)
+                             (start 0) (end nil))
+
+  "Examine _string_ (or its substring from _start_ to _end_) for a
+decimal number. Assume that the decimal number is exact and return it as
+a rational number.
+
+Rules for parsing: First all leading and trailing `#\\Space` characters
+are stripped. The resulting string may start with a _positive-sign_ or a
+_negative-sign_ character. The latter causes this function to assume a
+negative number. The following characters in the string must include one
+or more digit characters and it may include one _decimal-separator_
+character which separates integer and fractional parts. All other
+characters are illegal. If these rules are not met a
+`decimal-parse-error` condition is signaled.
+
+Examples:
+
+    (parse-decimal-number \"0.2\")  => 1/5
+    (parse-decimal-number \".2\")   => 1/5
+    (parse-decimal-number \"+3.\")  => 3
+    (parse-decimal-number \" -7 \") => -7
+
+    (parse-decimal-number \"−12,345\"
+                          :decimal-separator #\\,
+                          :negative-sign #\\−)
+    => -2469/200"
+
+  (setf string (string-trim " " (subseq string start end)))
+  (if (not (plusp (length string)))
+      (error 'decimal-parse-error)
+      (let ((sign 1))
+        (cond ((char= (aref string 0) negative-sign)
+               (setf sign -1
+                     string (subseq string 1)))
+              ((char= (aref string 0) positive-sign)
+               (setf string (subseq string 1))))
+
+        (if (and (every (lambda (item)
+                          (or (digit-char-p item)
+                              (char= item decimal-separator)))
+                        string)
+                 (some #'digit-char-p string)
+                 (<= 0 (count decimal-separator string) 1))
+
+            (let ((pos (position decimal-separator string)))
+              (* sign
+                 (+ (or (number-string-to-integer (subseq string 0 pos))
+                        0)
+                    (if pos
+                        (or (number-string-to-fractional
+                             (subseq string (1+ pos)))
+                            0)
+                        0))))
+
+            (error 'decimal-parse-error)))))
index 0e4810b..072bc4a 100644 (file)
            ;; maybe wrong type of float
            (float val))
          (if (eql type 'double-float) 1.0d0 1.0s0)))
-       (number (read-from-string val))
+       (number (read-decimal-value val))
        ((boolean generalized-boolean)
         (if (member val '(nil t))
             val
index be1396e..df3b705 100644 (file)
@@ -424,6 +424,26 @@ is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.h
     (unless stream
       (get-output-stream-string out))))
 
+(defun read-decimal-value (string)
+  (let* ((comma 0)
+         (dot 0)
+         (last))
+    (loop for c across string
+          do (case c
+               (#\. (incf dot) (setf last 'dot))
+               (#\, (incf comma) (setf last 'comma))))
+    (let* ((bag (if (and (eql last 'dot) (eql dot 1))
+                    ".0123456789+-"
+                    ",0123456789+-"))
+           (clean (with-output-to-string (out)
+                    (loop for c across string
+                          do (when (find c bag :test #'char=)
+                               (write-char c out))))))
+      (if (and (eql last 'dot) (eql dot 1))
+          (decimals:parse-decimal-number clean)
+          (decimals:parse-decimal-number
+           clean :decimal-separator #\,)))))
+
 
 (defun filter-plist (plist &rest keys-to-remove)
   "Returns a copy of the given plist with indicated key-value pairs
index 8ee2b03..61076c6 100644 (file)
        (list (clsql:sql [foo]) (clsql:sql [foo]) (clsql:sql [foo.bar])))
      ("FOO" "FOO" "FOO.BAR"))
 
-    ))
+    (deftest :currency/read-value/1
+      (list
+       (clsql-sys::read-decimal-value "$ 10,500.30")
+       (clsql-sys::read-decimal-value "$ 10.500,30")
+       (clsql-sys::read-decimal-value "-10 500,30")
+       (clsql-sys::read-decimal-value "$ 10.500,30"))
+      (1050030/100 1050030/100 -1050030/100 1050030/100))
 
+    ))