cl-postgres/sql-string.lisp

   1 (in-package :cl-postgres)
   2
   3 (defun escape-bytes (bytes)
   4   "Escape an array of octets in PostgreSQL's horribly inefficient
   5 textual format for binary data."
   6   (let ((*print-pretty* nil))
   7     (with-output-to-string (out)
   8       (loop :for byte :of-type fixnum :across bytes
   9             :do (if (or (< byte 32) (> byte 126) (= byte 39) (= byte 92))
  10                     (progn
  11                       (princ #\\ out)
  12                       (princ (digit-char (ldb (byte 3 6) byte) 8) out)
  13                       (princ (digit-char (ldb (byte 3 3) byte) 8) out)
  14                       (princ (digit-char (ldb (byte 3 0) byte) 8) out))
  15                     (princ (code-char byte) out))))))
  16
  17 (defparameter *silently-truncate-rationals* t)
  18
  19 (defun write-rational-as-floating-point (number stream digit-length-limit)
  20   (declare #.*optimize*)
  21   (flet ((fail ()
  22            (if *silently-truncate-rationals*
  23                (return-from write-rational-as-floating-point)
  24                (error 'database-error :message
  25                       (format nil "Can not write the rational ~a with only ~a digits"
  26                               number digit-length-limit)))))
  27     (multiple-value-bind (quotient remainder)
  28         (truncate (if (< number 0) (prog1 (- number) (write-char #\- stream)) number))
  29       (let* ((quotient-part (princ-to-string quotient))
  30              (decimal-length-limit (- digit-length-limit (length quotient-part))))
  31         (write-string quotient-part stream)
  32         (when (<= decimal-length-limit 0) (fail))
  33         (unless (zerop remainder) (write-char #\. stream))
  34         (loop :for decimal-digits :upfrom 1 :until (zerop remainder)
  35               :do (when (> decimal-digits decimal-length-limit) (fail))
  36               :do (multiple-value-bind (quotient rem) (floor (* remainder 10))
  37                     (princ quotient stream)
  38                     (setf remainder rem)))))))
  39
  40 (defun write-quoted (string out)
  41   (write-char #\" out)
  42   (loop :for ch :across string :do
  43      (when (member ch '(#\" #\\))
  44        (write-char #\\ out))
  45      (write-char ch out))
  46   (write-char #\" out))
  47
  48 (defgeneric to-sql-string (arg)
  49   (:documentation "Turn a lisp value into a string containing its SQL
  50 representation. Returns an optional second value that indicates
  51 whether the string should be escaped before being put into a query.")
  52   (:method ((arg string))
  53     (values arg t))
  54   (:method ((arg vector))
  55     (if (typep arg '(vector (unsigned-byte 8)))
  56         (values (escape-bytes arg) t)
  57         (values
  58          (with-output-to-string (out)
  59            (write-char #\{  out)
  60            (loop :for sep := "" :then #\, :for x :across arg :do
  61               (princ sep out)
  62               (multiple-value-bind (string escape) (to-sql-string x)
  63               (if escape (write-quoted string out) (write-string string out))))
  64            (write-char #\} out))
  65          t)))
  66   (:method ((arg array))
  67     (values
  68      (with-output-to-string (out)
  69        (labels ((recur (dims off)
  70                   (write-char #\{ out)
  71                   (if (cdr dims)
  72                       (let ((factor (reduce #'* (cdr dims))))
  73                         (loop :for i :below (car dims) :for sep := "" :then #\, :do
  74                            (princ sep out)
  75                            (recur (cdr dims) (+ off (* factor i)))))
  76                       (loop :for sep := "" :then #\, :for i :from off :below (+ off (car dims)) :do
  77                          (princ sep out)
  78                          (multiple-value-bind (string escape) (to-sql-string (row-major-aref arg i))
  79                            (if escape (write-quoted string out) (write-string string out)))))
  80                   (write-char #\} out)))
  81          (recur (array-dimensions arg) 0)))
  82      t))
  83   (:method ((arg integer))
  84     (princ-to-string arg))
  85   (:method ((arg float))
  86     (format nil "~f" arg))
  87   #-clisp (:method ((arg double-float)) ;; CLISP doesn't allow methods on double-float
  88             (format nil "~,,,,,,'EE" arg))
  89   (:method ((arg ratio))
  90     ;; Possible optimization: we could probably build up the same binary structure postgres
  91     ;; sends us instead of sending it as a string. See the "numeric" interpreter for more details...
  92     (with-output-to-string (result)
  93       ;; PostgreSQL happily handles 200+ decimal digits, but the SQL standard only requires
  94       ;; 38 digits from the NUMERIC type, and Oracle also doesn't handle more. For practical
  95       ;; reasons we also draw the line there. If someone needs full rational numbers then
  96       ;; 200 wouldn't help them much more than 38...
  97       (write-rational-as-floating-point arg result 38)))
  98   (:method ((arg (eql t)))
  99     "true")
 100   (:method ((arg (eql nil)))
 101     "false")
 102   (:method ((arg (eql :null)))
 103     "NULL")
 104   (:method ((arg t))
 105     (error "Value ~S can not be converted to an SQL literal." arg)))
 106
 107 (defgeneric serialize-for-postgres (arg)
 108   (:documentation "Conversion function used to turn a lisp value into a value that PostgreSQL understands when sent through its socket connection. May return a string or a (vector (unsigned-byte 8)).")
 109   (:method (arg)
 110     (to-sql-string arg)))