cl-postgres/interpret.lisp

   1 (in-package :cl-postgres)
   2
   3 (defparameter *timestamp-format* :unbound
   4   "This is used to communicate the format \(integer or float) used for
   5 timestamps and intervals in the current connection, so that the
   6 interpreters for those types know how to parse them.")
   7
   8 (defparameter *sql-readtable* (make-hash-table)
   9   "The exported special var holding the current read table, a hash
  10   mapping OIDs to (binary-p . interpreter-function) pairs.")
  11
  12 (defun interpret-as-text (stream size)
  13   "This interpreter is used for types that we have no specific
  14 interpreter for -- it just reads the value as a string. \(Values of
  15 unknown types are passed in text form.)"
  16   (enc-read-string stream :byte-length size))
  17
  18 (let ((default-interpreter (cons nil #'interpret-as-text)))
  19   (defun type-interpreter (oid)
  20     "Returns a pair representing the interpretation rules for this
  21 type. The car is a boolean indicating whether the type should be
  22 fetched as binary, and the cdr is a function that will read the value
  23 from the socket and build a Lisp value from it."
  24     (gethash oid *sql-readtable* default-interpreter)))
  25
  26 (defun set-sql-reader (oid function &key (table *sql-readtable*) binary-p)
  27   "Add an sql reader to a readtable. When the reader is not binary, it
  28 is wrapped by a function that will read the string from the socket."
  29   (setf (gethash oid table)
  30         (if binary-p
  31             (cons t function)
  32             (cons nil (lambda (stream size)
  33                         (funcall function
  34                                  (enc-read-string stream :byte-length size))))))
  35   table)
  36
  37 (defmacro binary-reader (fields &body value)
  38   "A slightly convoluted macro for defining interpreter functions. It
  39 allows two forms. The first is to pass a single type identifier, in
  40 which case a value of this type will be read and returned directly.
  41 The second is to pass a list of lists containing names and types, and
  42 then a body. In this case the names will be bound to values read from
  43 the socket and interpreted as the given types, and then the body will
  44 be run in the resulting environment. If the last field is of type
  45 bytes, string, or uint2s, all remaining data will be read and
  46 interpreted as an array of the given type."
  47   (let ((stream-name (gensym))
  48         (size-name (gensym))
  49         (length-used 0))
  50     (flet ((read-type (type &optional modifier)
  51              (ecase type
  52                (bytes `(read-bytes ,stream-name (- ,size-name ,length-used)))
  53                (string `(enc-read-string ,stream-name :byte-length (- ,size-name ,length-used)))
  54                (uint2s `(let* ((size (/ (- ,size-name ,length-used) 2))
  55                                (result (make-array size :element-type '(unsigned-byte 16))))
  56                          (dotimes (i size)
  57                            (setf (elt result i) (read-uint2 ,stream-name)))
  58                          result))
  59                (int (assert (integerp modifier))
  60                     (incf length-used modifier)
  61                     `(,(integer-reader-name modifier t) ,stream-name))
  62                (uint (assert (integerp modifier))
  63                      (incf length-used modifier)
  64                      `(,(integer-reader-name modifier nil) ,stream-name)))))
  65       `(lambda (,stream-name ,size-name)
  66          (declare (type stream ,stream-name)
  67                   (type integer ,size-name)
  68                   (ignorable ,size-name))
  69          ,(if (consp fields)
  70               `(let ,(loop :for field :in fields
  71                            :collect `(,(first field) ,(apply #'read-type (cdr field))))
  72                  ,@value)
  73               (read-type fields (car value)))))))
  74
  75 (defmacro define-interpreter (oid name fields &body value)
  76   "Shorthand for defining binary readers."
  77   (declare (ignore name)) ;; Names are there just for clarity
  78   `(set-sql-reader ,oid (binary-reader ,fields ,@value) :binary-p t))
  79
  80 (define-interpreter 18 "char" int 1)
  81 (define-interpreter 21 "int2" int 2)
  82 (define-interpreter 23 "int4" int 4)
  83 (define-interpreter 20 "int8" int 8)
  84
  85 (define-interpreter 26 "oid" uint 4)
  86
  87 (define-interpreter 16 "bool" ((value int 1))
  88   (if (zerop value) nil t))
  89
  90 (define-interpreter 17 "bytea" bytes)
  91 (define-interpreter 25 "text" string)
  92 (define-interpreter 1042 "bpchar" string)
  93 (define-interpreter 1043 "varchar" string)
  94
  95 (defun read-row-value (stream size)
  96   (declare (type stream stream)
  97            (type integer size)
  98            (ignore size))
  99   (let ((num-fields (read-uint4 stream)))
 100     (loop for i below num-fields
 101        collect (let ((oid (read-uint4 stream))
 102                      (size (read-int4 stream)))
 103                  (declare (type (signed-byte 32) size))
 104                  (if (eq size -1)
 105                      :null
 106                      (funcall (cdr (type-interpreter oid)) stream size))))))
 107
 108 ;; "row" types
 109 (set-sql-reader 2249 #'read-row-value :binary-p t)
 110
 111 (defun read-binary-bits (stream size)
 112   (declare (type stream stream)
 113            (type integer size))
 114   (let ((byte-count (- size 4))
 115         (bit-count (read-uint4 stream)))
 116     (let ((bit-bytes (read-bytes stream byte-count))
 117           (bit-array (make-array (list bit-count) :element-type 'bit)))
 118       (loop for i below bit-count
 119          do (let ((cur-byte (ash i -3))
 120                   (cur-bit (ldb (byte 3 0) i)))
 121               (setf (aref bit-array i)
 122                     (ldb (byte 1 (logxor cur-bit 7)) (aref bit-bytes cur-byte)))))
 123       bit-array)))
 124
 125 (set-sql-reader 1560 #'read-binary-bits :binary-p t)
 126 (set-sql-reader 1562 #'read-binary-bits :binary-p t)
 127
 128 (defun read-binary-array-value (stream size)
 129   (declare (type stream stream)
 130            (type integer size)
 131            (ignore size))
 132   (let ((num-dims (read-uint4 stream))
 133         (has-null (read-uint4 stream))
 134         (element-type (read-uint4 stream)))
 135     (declare (ignore has-null))
 136     (let* ((array-dims
 137             (loop for i below num-dims
 138                collect (let ((dim (read-uint4 stream))
 139                              (lb (read-uint4 stream)))
 140                          (declare (ignore lb))
 141                          dim)))
 142            (num-items (reduce #'* array-dims)))
 143       (let ((results (make-array array-dims)))
 144         (loop for i below num-items
 145            do (let ((size (read-int4 stream)))
 146                 (declare (type (signed-byte 32) size))
 147                 (setf (row-major-aref results i)
 148                       (if (eq size -1)
 149                           :null
 150                           (funcall (cdr (type-interpreter element-type)) stream size)))))
 151         results))))
 152
 153 (dolist (oid '(
 154                1000 ;; boolean array
 155                1001 ;; bytea array
 156                1002 ;; char array
 157                1003 ;; name (internal PG type) array
 158                1005 ;; int2 array
 159                1007 ;; integer array
 160                1009 ;; text array
 161                1014 ;; bpchar array
 162                1015 ;; varchar array
 163                1016 ;; int8 array
 164                1017 ;; point array
 165                1018 ;; lseg array
 166                1020 ;; box array
 167                1021 ;; float4 array
 168                1022 ;; float8 array
 169                1028 ;; oid array
 170                1115 ;; timestamp array
 171                1182 ;; date array
 172                1187 ;; interval array
 173                1561 ;; bit array
 174                1563 ;; varbit array
 175                1231 ;; numeric array
 176                2287 ;; record array
 177                ))
 178   (set-sql-reader oid #'read-binary-array-value :binary-p t))
 179
 180 (define-interpreter 600 "point" ((point-x-bits uint 8)
 181                                  (point-y-bits uint 8))
 182   (list (cl-postgres-ieee-floats:decode-float64 point-x-bits)
 183         (cl-postgres-ieee-floats:decode-float64 point-y-bits)))
 184
 185 (define-interpreter 601 "lseg" ((point-x1-bits uint 8)
 186                                 (point-y1-bits uint 8)
 187                                 (point-x2-bits uint 8)
 188                                 (point-y2-bits uint 8))
 189   (list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
 190               (cl-postgres-ieee-floats:decode-float64 point-y1-bits))
 191         (list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
 192               (cl-postgres-ieee-floats:decode-float64 point-y2-bits))))
 193
 194 (define-interpreter 603 "box" ((point-x1-bits uint 8)
 195                                (point-y1-bits uint 8)
 196                                (point-x2-bits uint 8)
 197                                (point-y2-bits uint 8))
 198   (list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
 199               (cl-postgres-ieee-floats:decode-float64 point-y1-bits))
 200         (list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
 201               (cl-postgres-ieee-floats:decode-float64 point-y2-bits))))
 202
 203 (define-interpreter 700 "float4" ((bits uint 4))
 204   (cl-postgres-ieee-floats:decode-float32 bits))
 205 (define-interpreter 701 "float8" ((bits uint 8))
 206   (cl-postgres-ieee-floats:decode-float64 bits))
 207
 208 ;; Numeric types are rather involved. I got some clues on their
 209 ;; structure from http://archives.postgresql.org/pgsql-interfaces/2004-08/msg00000.php
 210 (define-interpreter 1700 "numeric"
 211     ((length uint 2)
 212      (weight int 2)
 213      (sign int 2)
 214      (dscale int 2)
 215      (digits uint2s))
 216   (declare (ignore dscale))
 217   (let ((total (loop :for i :from (1- length) :downto 0
 218                      :for scale = 1 :then (* scale #.(expt 10 4))
 219                      :summing (* scale (elt digits i))))
 220         (scale (- length weight 1)))
 221     (unless (zerop sign)
 222       (setf total (- total)))
 223     (/ total (expt 10000 scale))))
 224
 225 ;; Since date and time types are the most likely to require custom
 226 ;; readers, there is a hook for easily adding binary readers for them.
 227
 228 (defun set-date-reader (f table)
 229   (set-sql-reader 1082 (binary-reader ((days int 4))
 230                          (funcall f days))
 231                   :table table
 232                   :binary-p t))
 233
 234 (defun interpret-usec-bits (bits)
 235   "Decode a 64 bit time-related value based on the timestamp format
 236 used. Correct for sign bit when using integer format."
 237   (ecase *timestamp-format*
 238     (:float (round (* (cl-postgres-ieee-floats:decode-float64 bits) 1000000)))
 239     (:integer (if (logbitp 63 bits)
 240                   (dpb bits (byte 63 0) -1)
 241                   bits))))
 242
 243 (defun set-interval-reader (f table)
 244   (set-sql-reader 1186 (binary-reader ((usec-bits uint 8) (days int 4) (months int 4))
 245                          (funcall f months days (interpret-usec-bits usec-bits)))
 246                   :table table
 247                   :binary-p t))
 248
 249 (defun set-usec-reader (oid f table)
 250   (set-sql-reader oid (binary-reader ((usec-bits uint 8))
 251                         (funcall f (interpret-usec-bits usec-bits)))
 252                   :table table
 253                   :binary-p t))
 254
 255 ;; Public interface for adding date/time readers
 256
 257 (defun set-sql-datetime-readers (&key date timestamp timestamp-with-timezone interval time
 258                                  (table *sql-readtable*))
 259   (when date (set-date-reader date table))
 260   (when timestamp (set-usec-reader 1114 timestamp table))
 261   (when timestamp-with-timezone (set-usec-reader 1184 timestamp-with-timezone table))
 262   (when interval (set-interval-reader interval table))
 263   (when time (set-usec-reader 1083 time table))
 264   table)
 265
 266 ;; Provide meaningful defaults for the date/time readers.
 267
 268 (defconstant +start-of-2000+ (encode-universal-time 0 0 0 1 1 2000 0))
 269 (defconstant +seconds-in-day+ (* 60 60 24))
 270
 271 (set-sql-datetime-readers
 272  :date (lambda (days-since-2000)
 273          (+ +start-of-2000+ (* days-since-2000 +seconds-in-day+)))
 274  :timestamp (lambda (useconds-since-2000)
 275               (+ +start-of-2000+ (floor useconds-since-2000 1000000)))
 276  :timestamp-with-timezone (lambda (useconds-since-2000)
 277                             (+ +start-of-2000+ (floor useconds-since-2000 1000000)))
 278  :interval (lambda (months days useconds)
 279              (multiple-value-bind (sec us) (floor useconds 1000000)
 280                `((:months ,months) (:days ,days) (:seconds ,sec) (:useconds ,us))))
 281  :time (lambda (usecs)
 282          (multiple-value-bind (seconds usecs)
 283              (floor usecs 1000000)
 284            (multiple-value-bind (minutes seconds)
 285                (floor seconds 60)
 286              (multiple-value-bind (hours minutes)
 287                  (floor minutes 60)
 288                `((:hours ,hours) (:minutes ,minutes) (:seconds ,seconds) (:microseconds ,usecs)))))))
 289
 290 ;; Readers for a few of the array types
 291
 292 (defun read-array-value (transform)
 293   (declare #.*optimize*)
 294   (lambda (value)
 295     (declare (type string value))
 296     (let ((pos 0))
 297       (declare (type fixnum pos))
 298       (labels ((readelt ()
 299                  (case (char value pos)
 300                    (#\" (interpret
 301                          (with-output-to-string (out)
 302                            (loop :with escaped := nil :for ch := (char value (incf pos)) :do
 303                               (when (and (char= ch #\") (not escaped)) (return))
 304                               (setf escaped (and (not escaped) (char= ch #\\)))
 305                               (unless escaped (write-char ch out)))
 306                            (incf pos))))
 307                    (#\{ (incf pos)
 308                         (unless (char= (char value pos) #\})
 309                           (loop :for val := (readelt) :collect val :into vals :do
 310                              (let ((next (char value pos)))
 311                                (incf pos)
 312                                (ecase next (#\,) (#\} (return vals)))))))
 313                    (t (let ((start pos))
 314                         (loop :for ch := (char value pos) :do
 315                            (when (or (char= ch #\,) (char= ch #\}))
 316                              (return (interpret (subseq value start pos))))
 317                            (incf pos))))))
 318                (interpret (word)
 319                  (if (string= word "NULL") :null (funcall transform word))))
 320         (let* ((arr (readelt))
 321                (dim (if arr (loop :for x := arr :then (car x) :while (consp x) :collect (length x)) '(0))))
 322           (make-array dim :initial-contents arr))))))
 323
 324 ;; Working with tables.
 325
 326 (defun copy-sql-readtable (&optional (table *sql-readtable*))
 327   (let ((new-table (make-hash-table)))
 328     (maphash (lambda (oid interpreter) (setf (gethash oid new-table) interpreter))
 329              table)
 330     new-table))
 331
 332 (defparameter *default-sql-readtable* (copy-sql-readtable *sql-readtable*)
 333   "A copy of the default readtable that client code can fall back
 334   on.")
 335
 336 (defun default-sql-readtable ()
 337   *default-sql-readtable*)