parsers.lisp 11.8 KB
Newer Older
Eric Marsden's avatar
Eric Marsden committed
1 2
;;; parsers.lisp -- type coercion support
;;;
3
;;; Author: Eric Marsden <eric.marsden@free.fr>
Eric Marsden's avatar
Eric Marsden committed
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
;;
;;
;; When returning data from a SELECT statement, PostgreSQL starts by
;; sending some metadata describing the attributes. This information
;; is read by `PG:READ-ATTRIBUTES', and consists of each attribute's
;; name (as a string), its size (in bytes), and its type (as an oid
;; which points to a row in the PostgreSQL system table pg_type). Each
;; row in pg_type includes the type's name (as a string).
;;
;; We are able to parse a certain number of the PostgreSQL types (for
;; example, numeric data is converted to a numeric Common Lisp type,
;; dates are converted to the CL date representation, booleans to
;; lisp booleans). However, there isn't a fixed mapping from a
;; type to its OID which is guaranteed to be stable across database
;; installations, so we need to build a table mapping OIDs to parser
;; functions.
;;
;; This is done by the procedure `PG:INITIALIZE-PARSERS', which is run
;; the first time a connection is initiated with the database from
;; this invocation of CL, and which issues a SELECT statement to
;; extract the required information from pg_type. This initialization
;; imposes a slight overhead on the first request, which you can avoid
;; by setting `*PG-DISABLE-TYPE-COERCION*' to non-nil if it bothers you.
;; ====================================================================


;;; TODO ============================================================
;;
;; * add a mechanism for parsing user-defined types. The user should
;;   be able to define a parse function and a type-name; we query
;;   pg_type to get the type's OID and add the information to
;;   pg:*parsers*.
;;


39 40 41
(declaim (optimize (speed 3) (safety 1)))


Eric Marsden's avatar
Eric Marsden committed
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
(in-package :postgresql)


(defvar *pg-disable-type-coercion* nil
  "Non-nil disables the type coercion mechanism.
The default is nil, which means that data recovered from the
database is coerced to the corresponding Common Lisp type before
being returned; for example numeric data is transformed to CL
numbers, and booleans to booleans.

The coercion mechanism requires an initialization query to the
database, in order to build a table mapping type names to OIDs. This
option is provided mainly in case you wish to avoid the overhead of
this initial query. The overhead is only incurred once per session
(not per connection to the backend).")

;; alist of (oid . parser) pairs. This is built dynamically at
;; initialization of the connection with the database (once generated,
;; the information is shared between connections).
(defvar *parsers* '())


64 65 66 67
(defvar *type-to-oid*
  (make-hash-table :test #'eq)
  "Is a hashtable for turning a typename into a OID.
Needed to define the type of objects in pg-prepare")
Eric Marsden's avatar
Eric Marsden committed
68 69 70

(defvar *type-parsers*
  `(("bool"      . ,'bool-parser)
71
    ("bytea"     . ,'identity)
Eric Marsden's avatar
Eric Marsden committed
72 73 74 75 76 77 78
    ("char"      . ,'text-parser)
    ("char2"     . ,'text-parser)
    ("char4"     . ,'text-parser)
    ("char8"     . ,'text-parser)
    ("char16"    . ,'text-parser)
    ("text"      . ,'text-parser)
    ("varchar"   . ,'text-parser)
79
    ("numeric"   . ,'numeric-parser)
Eric Marsden's avatar
Eric Marsden committed
80 81 82
    ("int2"      . ,'integer-parser)
    ("int4"      . ,'integer-parser)
    ("int8"      . ,'integer-parser)
83
    ;; int2vector
Eric Marsden's avatar
Eric Marsden committed
84
    ("oid"       . ,'integer-parser)
85 86 87
    ;; oidvector
    ;; bit
    ;; varbit
88 89 90 91
    ;; record
    ;; cstring
    ;; any
    ("row"       . ,'row-parser)
Eric Marsden's avatar
Eric Marsden committed
92 93 94 95 96
    ("float4"    . ,'float-parser)
    ("float8"    . ,'float-parser)
    ("money"     . ,'text-parser)       ; "$12.34"
    ("abstime"   . ,'timestamp-parser)
    ("date"      . ,'date-parser)
97
    ("timestamp" . ,'timestamp-parser)  ; or 'precise-timestamp-parser if you want milliseconds
Eric Marsden's avatar
Eric Marsden committed
98 99 100 101 102 103 104 105 106 107 108 109 110
    ("timestamptz" . ,'timestamp-parser)
    ("datetime"  . ,'timestamp-parser)
    ("time"      . ,'text-parser)     ; preparsed "15:32:45"
    ("timetz"    . ,'text-parser)
    ("reltime"   . ,'text-parser)     ; don't know how to parse these
    ("timespan"  . ,'interval-parser)
    ("interval"  . ,'interval-parser)
    ("tinterval" . ,'interval-parser)))


;; see `man pgbuiltin' for details on PostgreSQL builtin types
(defun integer-parser (str) (parse-integer str))

111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
;; from Risto Sakari Laakso <rlaakso@cc.hut.fi>
;; 
;; http://www.postgresql.org/docs/7.4/static/datatype.html#DATATYPE-NUMERIC-DECIMAL
;; 
;; NUMERIC(precision, scale)
;; 
;; The scale of a numeric is the count of decimal digits in the
;; fractional part, to the right of the decimal point. The precision of a
;; numeric is the total count of significant digits in the whole number, that
;; is, the number of digits to both sides of the decimal point.
(defun numeric-parser (str)         
  (let ((dot-pos (position #\. str))
        integer-part
        (decimal-part 0))
    ;; parse up to #\., or whole string if #\. not present 
    (setq integer-part (parse-integer (subseq str 0 dot-pos)))
    ;; if #\. present ..
    (when dot-pos
      (let* ((decimal-str (subseq str (1+ dot-pos)))
             (dec-str-len (length decimal-str)))
        
        ;; if has at least one digit after #\.
        (when (> dec-str-len 0)
          ;; parse integer after #\. and divide by 10^(digits), i.e. ".023" => 23/1000     
          (setq decimal-part (/ (parse-integer decimal-str) (expt 10 dec-str-len))))))
136 137 138
    (if (eq #\- (elt str 0))
        (- integer-part decimal-part)
        (+ integer-part decimal-part))))
139 140

;; FIXME switch to a specialized float parser that conses less
Eric Marsden's avatar
Eric Marsden committed
141
(defun float-parser (str)
142
  (declare (type simple-string str))
Eric Marsden's avatar
Eric Marsden committed
143 144 145
  (let ((*read-eval* nil))
    (read-from-string str)))

146 147 148 149 150 151
;; here we are assuming that the value of *PG-CLIENT-ENCODING* is
;; compatible with the encoding that the CL implementation uses for
;; strings. The backend should convert all values belonging to one of
;; the text data types from the table's internal representation to
;; that requested by the client, so here we don't need to do any
;; conversion.
Eric Marsden's avatar
Eric Marsden committed
152 153 154
(defun text-parser (str) str)

(defun bool-parser (str)
155
  (declare (type simple-string str))
Eric Marsden's avatar
Eric Marsden committed
156 157 158 159 160 161
  (cond ((string= "t" str) t)
        ((string= "f" str) nil)
        (t (error 'protocol-error
                  :reason "Badly formed boolean from backend: ~s" str))))

(defun parse-timestamp (str)
162
  (declare (type simple-string str))
163 164 165 166 167 168 169
  (let* ((year (parse-integer str :start 0 :end 4))
         (month (parse-integer str :start 5 :end 7))
         (day (parse-integer str :start 8 :end 10))
         (hours (parse-integer str :start 11 :end 13))
         (minutes (parse-integer str :start 14 :end 16))
         (seconds (parse-integer str :start 17 :end 19))
         (length (length str))
170
         (start-tz (if (find (char str (- length 3)) "+-")
171
                       (- length 3)))
Eric Marsden's avatar
Eric Marsden committed
172
         (tz (when start-tz
173 174 175 176
               (parse-integer str :start start-tz)))
         (milliseconds (if (and (< 19 length) (eql (char str 19) #\.))
                           (parse-integer str :start 20 :end start-tz)
                           0)))
Eric Marsden's avatar
Eric Marsden committed
177 178 179 180 181 182 183 184 185 186
    (values year month day hours minutes seconds milliseconds tz)))

;; format for abstime/timestamp etc with ISO output syntax is
;;
;;    "1999-01-02 05:11:23.0345645+01"
;;
;; which we convert to a CL universal time. Thanks to James Anderson
;; for a fix for timestamp format in PostgreSQL 7.3 (with or without
;; tz, with or without milliseconds).
(defun timestamp-parser (str)
187 188 189 190 191 192 193 194
  ;; Test for the special values 'infinity' and '-infinity'
  (cond ((digit-char-p (schar str 0))
         (multiple-value-bind (year month day hours minutes seconds)
             (parse-timestamp str)
           (encode-universal-time seconds minutes hours day month year)))
	((equal str "infinity") :infinity)
	((equal str "-infinity") :-infinity)
	(t (error "Unknown special timestamp value ~A" str))))
Eric Marsden's avatar
Eric Marsden committed
195 196 197 198 199 200 201 202 203 204

(defun precise-timestamp-parser (str)
  (multiple-value-bind (year month day hours minutes seconds milliseconds)
      (parse-timestamp str)
    (+ (encode-universal-time seconds minutes hours day month year)
       (/ milliseconds 1000.0))))

;; An interval is what you get when you subtract two timestamps. We
;; convert to a number of seconds.
(defun interval-parser (str)
205 206 207 208
  (let* ((hours (parse-integer str :start 0 :end 2))
         (minutes (parse-integer str :start 3 :end 5))
         (seconds (parse-integer str :start 6 :end 8))
         (milliseconds (parse-integer str :start 9)))
Eric Marsden's avatar
Eric Marsden committed
209 210 211 212 213 214 215 216 217 218
    (+ (/ milliseconds (expt 10.0 (- (length str) 9)))
       seconds
       (* 60 minutes)
       (* 60 60 hours))))


;; format for abstime/timestamp etc with ISO output syntax is
;;;    "1999-01-02 00:00:00+01"
;; which we convert to a CL universal time
(defun isodate-parser (str)
219 220 221 222 223 224 225
  (let ((year    (parse-integer str :start 0 :end 4))
        (month   (parse-integer str :start 5 :end 7))
        (day     (parse-integer str :start 8 :end 10))
        (hours   (parse-integer str :start 11 :end 13))
        (minutes (parse-integer str :start 14 :end 16))
        (seconds (parse-integer str :start 17 :end 19))
        (tz      (parse-integer str :start 19 :end 22)))
Eric Marsden's avatar
Eric Marsden committed
226 227 228 229 230 231
    (encode-universal-time seconds minutes hours day month year tz)))

;; format for date with ISO output syntax is
;;;    "1999-01-02"
;; which we convert to a CL universal time
(defun date-parser (str)
232 233 234
  (let ((year    (parse-integer str :start 0 :end 4))
        (month   (parse-integer str :start 5 :end 7))
        (day     (parse-integer str :start 8 :end 10)))
Eric Marsden's avatar
Eric Marsden committed
235 236
    (encode-universal-time 0 0 0 day month year)))

237 238 239 240 241 242 243 244 245 246 247 248 249

;; http://www.postgresql.org/docs/8.1/interactive/sql-expressions.html#SQL-SYNTAX-ROW-CONSTRUCTORS
;;
;; these are in the format "(foo,bar,baz)"
(defun row-parser (str)
  (assert (char= #\( (char str 0)))
  (loop :with start = 1
        :with last = (- (length str) 1)
        :for end = (or (position #\, str :start start) last)
        :collect (subseq str start end)
        :do (setq start (1+ end))
        :until (>= end last)))

Eric Marsden's avatar
Eric Marsden committed
250 251 252 253 254 255 256 257 258
(defun initialize-parsers (connection)
  (let* ((pgtypes (pg-exec connection "SELECT typname,oid FROM pg_type"))
         (tuples (pg-result pgtypes :tuples)))
    (setq *parsers* '())
    (map nil
     (lambda (tuple)
       (let* ((typname (first tuple))
              (oid (parse-integer (second tuple)))
              (type (assoc typname *type-parsers* :test #'string=)))
259 260 261 262 263 264 265
         (cond
           ((consp type)
            (setf (gethash (intern typname :keyword) *type-to-oid*)
                  oid)
            (push (cons oid (cdr type)) *parsers*))
           (t
            #+debug
Eric Marsden's avatar
Eric Marsden committed
266
            (warn "Unknown PostgreSQL type found: '~A' oid: '~A'"
267 268
                   typname
                   oid)))))
Eric Marsden's avatar
Eric Marsden committed
269 270
     tuples)))

271 272
;; FIXME should perhaps resignal parse errors as a condition derived
;; from POSTGRESQL-ERROR
Eric Marsden's avatar
Eric Marsden committed
273
(defun parse (str oid)
274
  (declare (type simple-string str))
Eric Marsden's avatar
Eric Marsden committed
275 276 277 278 279
  (let ((parser (assoc oid *parsers* :test #'eql)))
    (if (consp parser)
        (funcall (cdr parser) str)
        str)))

280 281 282 283 284 285 286 287 288 289
(defun lookup-type (type)
  "Given the name of a type, returns the oid of the type or NIL if
not found"
  (let ((type (etypecase type
                (symbol
                 type)
                (string
                 (intern type :keyword)))))
    (gethash type *type-to-oid*)))

290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314


;; PQescapeBytea	- converts from binary string to the
;; minimal encoding necessary to include the string in an SQL
;; INSERT statement with a bytea type column as the target.
;; 
;; The following transformations are applied
;; '\0' == ASCII  0 == \000
;; '\'' == ASCII 39 == ''
;; '\\' == ASCII 92 == \\
;; anything < 0x20, or > 0x7e ---> \ooo
;; 								(where ooo is an octal expression)
;; If not std_strings, all backslashes sent to the output are doubled.
;;
;; http://www.postgresql.org/docs/8.1/static/datatype-binary.html
(defun bytea->string (data)
  (declare (type (vector (unsigned-byte 8) *) data))
  (with-output-to-string (out)
    (loop :for octet :across data :do
          (cond ((<= 32 octet 126)
                 (write-char (code-char octet) out))
                (t
                 (format out "\\~3,'0O" octet))))))


Eric Marsden's avatar
Eric Marsden committed
315
;; EOF