cl-postgres/sql-string.lisp

   1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*-
   2 (in-package :cl-postgres)
   3
   4 (defun escape-bytes (bytes)
   5   "Escape an array of octets in PostgreSQL's horribly inefficient
   6 textual format for binary data."
   7   (let ((*print-pretty* nil))
   8     (with-output-to-string (out)
   9       (loop :for byte :of-type fixnum :across bytes
  10             :do (if (or (< byte 32) (> byte 126) (= byte 39) (= byte 92))
  11                     (progn
  12                       (princ #\\ out)
  13                       (princ (digit-char (ldb (byte 3 6) byte) 8) out)
  14                       (princ (digit-char (ldb (byte 3 3) byte) 8) out)
  15                       (princ (digit-char (ldb (byte 3 0) byte) 8) out))
  16                     (princ (code-char byte) out))))))
  17
  18 (defun write-ratio-as-floating-point (number stream digit-length-limit)
  19   "Given a ratio, a stream and a digital-length-limit, if
  20 *silently-truncate-ratios* is true, will return a potentially truncated ratio.
  21 If false and the digital-length-limit is reached, it will throw an error noting
  22 the loss of precision and offering to continue or reset
  23 *silently-truncate-ratios* to true. Code contributed by Attila Lendvai."
  24   (declare #.*optimize* (type fixnum digit-length-limit))
  25   (check-type number ratio)
  26   (let ((silently-truncate? *silently-truncate-ratios*))
  27     (flet ((fail ()
  28                  (unless silently-truncate?
  29                    (restart-case
  30                     (error 'database-error :message
  31                            (format nil "Can not write the ratio ~A as a floating point number with only ~A available digits. You may want to (setf ~S t) if you don't mind the loss of precision."
  32                                    number digit-length-limit '*silently-truncate-ratios*))
  33                     (continue ()
  34                               :report (lambda (stream)
  35                                         (write-string "Ignore this precision loss and continue"
  36                                                       stream))
  37                               (setf silently-truncate? t))
  38                     (disable-assertion ()
  39                                        :report (lambda (stream)
  40                                                  (write-string "Set ~S to true (the precision loss of ratios will be silently ignored in this Lisp VM)." stream))
  41                                        (setf silently-truncate? t)
  42                                        (setf *silently-truncate-ratios* t))))))
  43       (multiple-value-bind (quotient remainder)
  44           (truncate (if (< number 0)
  45                         (progn
  46                           (write-char #\- stream)
  47                           (- number))
  48                       number))
  49         (let* ((quotient-part (princ-to-string quotient))
  50                (remaining-digit-length (- digit-length-limit
  51                                           (length quotient-part))))
  52           (write-string quotient-part stream)
  53           (when (<= remaining-digit-length 0)
  54             (fail))
  55           (unless (zerop remainder)
  56             (write-char #\. stream))
  57           (loop
  58            :for decimal-digits :upfrom 1
  59            :until (zerop remainder)
  60            :do (progn
  61                  (when (> decimal-digits remaining-digit-length)
  62                    (fail)
  63                    (return))
  64                  (multiple-value-bind (quotient rem) (floor (* remainder 10))
  65                    (princ quotient stream)
  66                    (setf remainder rem)))))))))
  67
  68 (defun write-quoted (string out)
  69   (write-char #\" out)
  70   (loop :for ch :across string :do
  71      (when (member ch '(#\" #\\))
  72        (write-char #\\ out))
  73      (write-char ch out))
  74   (write-char #\" out))
  75
  76 (defgeneric to-sql-string (arg)
  77   (:documentation "Convert a Lisp value to its textual unescaped SQL
  78 representation. Returns a second value indicating whether this value should be
  79 escaped if it is to be put directly into a query. Generally any string is going
  80 to be designated to be escaped.
  81
  82 You can define to-sql-string methods for your own datatypes if you want to be
  83 able to pass them to exec-prepared. When a non-NIL second value is returned,
  84 this may be T to indicate that the first value should simply be escaped as a
  85 string, or a second string providing a type prefix for the value. (This is
  86 different from s-sql::to-s-sql-string only in the handling of cons lists.")
  87   (:method ((arg string))
  88     (values arg t))
  89   (:method ((arg vector))
  90     (if (typep arg '(vector (unsigned-byte 8)))
  91         (values (escape-bytes arg) t)
  92         (values
  93          (with-output-to-string (out)
  94            (write-char #\{  out)
  95            (loop :for sep := "" :then #\, :for x :across arg :do
  96               (princ sep out)
  97               (multiple-value-bind (string escape) (to-sql-string x)
  98               (if escape (write-quoted string out) (write-string string out))))
  99            (write-char #\} out))
 100          t)))
 101   (:method ((arg cons))                 ;lists, but not nil
 102     (if (alexandria:proper-list-p arg)
 103         (values
 104             (with-output-to-string (out)
 105               (write-char #\{  out)
 106               (loop :for sep := "" :then #\, :for x :in arg :do
 107                 (princ sep out)
 108                 (multiple-value-bind (string escape) (to-sql-string x)
 109                   (if escape (write-quoted string out) (write-string string out))))
 110               (write-char #\} out))
 111             t)
 112         (error "Value ~S can not be converted to an SQL literal." arg)))
 113   (:method ((arg array))
 114     (values
 115      (with-output-to-string (out)
 116        (labels ((recur (dims off)
 117                   (write-char #\{ out)
 118                   (if (cdr dims)
 119                       (let ((factor (reduce #'* (cdr dims))))
 120                         (loop :for i :below (car dims) :for sep := ""
 121                                 :then #\, :do
 122                            (princ sep out)
 123                            (recur (cdr dims) (+ off (* factor i)))))
 124                       (loop :for sep := "" :then #\, :for i :from off
 125                               :below (+ off (car dims)) :do
 126                          (princ sep out)
 127                          (multiple-value-bind (string escape)
 128                              (to-sql-string (row-major-aref arg i))
 129                            (if escape (write-quoted string out)
 130                                (write-string string out)))))
 131                   (write-char #\} out)))
 132          (recur (array-dimensions arg) 0)))
 133      t))
 134   (:method ((arg integer))
 135     (princ-to-string arg))
 136   (:method ((arg float))
 137     (format nil "~f" arg))
 138   #-clisp (:method ((arg double-float)) ;; CLISP doesn't allow methods on double-float
 139             (format nil "~,,,,,,'EE" arg))
 140   (:method ((arg ratio))
 141     ;; Possible optimization: we could probably build up the same binary
 142     ;; structure postgres sends us instead of sending it as a string. See
 143     ;; the "numeric" interpreter for more details...
 144     (with-output-to-string (result)
 145       ;; PostgreSQL happily handles 200+ decimal digits, but the SQL standard
 146       ;; only requires 38 digits from the NUMERIC type, and Oracle also doesn't
 147       ;; handle more. For practical reasons we also draw the line there. If
 148       ;; someone needs full rational numbers then
 149       ;; 200 wouldn't help them much more than 38...
 150       (write-ratio-as-floating-point arg result 38)))
 151   (:method ((arg (eql t)))
 152     "true")
 153   (:method ((arg (eql nil)))
 154     "false")
 155   (:method ((arg (eql :null)))
 156     "NULL")
 157   (:method ((arg t))
 158     (error "Value ~S can not be converted to an SQL literal." arg)))
 159
 160 (defgeneric serialize-for-postgres (arg)
 161   (:documentation "Conversion function used to turn a lisp value into a value
 162 that PostgreSQL understands when sent through its socket connection. May return
 163 a string or a (vector (unsigned-byte 8)).")
 164   (:method ((arg integer))
 165     (int-to-vector arg))
 166   #-clisp (:method ((arg single-float))
 167             (int32-to-vector (cl-postgres-ieee-floats:encode-float32 arg)))
 168   #+clisp (:method ((arg float))
 169     (int32-to-vector (cl-postgres-ieee-floats:encode-float32 arg)))
 170   #-clisp   (:method ((arg double-float)) ;; CLISP doesn't allow methods on double-float
 171               (int64-to-vector (cl-postgres-ieee-floats:encode-float64 arg)))
 172   (:method (arg)
 173     (cond ((typep arg 'boolean)
 174            (if arg (int8-to-vector 1)
 175                (int8-to-vector 0)))
 176 ;;          ((typep arg 'uuid-string) (uuid-to-byte-array arg))
 177           (t (to-sql-string arg)))))