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