cl-pg 1:20061216-5 / usr / share / common-lisp / source / pg / parsers.lisp

;;; parsers.lisp -- type coercion support
;;;
;;; Author: Eric Marsden <eric.marsden@free.fr>
;;
;;
;; 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*.
;;


(declaim (optimize (speed 3) (safety 1)))


(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* '())


(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")

(defvar *type-parsers*
  `(("bool"      . ,'bool-parser)
    ("bytea"     . ,'identity)
    ("char"      . ,'text-parser)
    ("char2"     . ,'text-parser)
    ("char4"     . ,'text-parser)
    ("char8"     . ,'text-parser)
    ("char16"    . ,'text-parser)
    ("text"      . ,'text-parser)
    ("varchar"   . ,'text-parser)
    ("numeric"   . ,'numeric-parser)
    ("int2"      . ,'integer-parser)
    ("int4"      . ,'integer-parser)
    ("int8"      . ,'integer-parser)
    ;; int2vector
    ("oid"       . ,'integer-parser)
    ;; oidvector
    ;; bit
    ;; varbit
    ;; record
    ;; cstring
    ;; any
    ("row"       . ,'row-parser)
    ("float4"    . ,'float-parser)
    ("float8"    . ,'float-parser)
    ("money"     . ,'text-parser)       ; "$12.34"
    ("abstime"   . ,'timestamp-parser)
    ("date"      . ,'date-parser)
    ("timestamp" . ,'timestamp-parser)  ; or 'precise-timestamp-parser if you want milliseconds
    ("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))

;; 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))))))
    (if (eq #\- (elt str 0))
        (- integer-part decimal-part)
        (+ integer-part decimal-part))))

;; FIXME switch to a specialized float parser that conses less
(defun float-parser (str)
  (declare (type simple-string str))
  (let ((*read-eval* nil))
    (read-from-string str)))

;; 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.
(defun text-parser (str) str)

(defun bool-parser (str)
  (declare (type simple-string str))
  (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)
  (declare (type simple-string str))
  (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))
         (start-tz (if (find (char str (- length 3)) "+-")
                       (- length 3)))
         (tz (when start-tz
               (parse-integer str :start start-tz)))
         (milliseconds (if (and (< 19 length) (eql (char str 19) #\.))
                           (parse-integer str :start 20 :end start-tz)
                           0)))
    (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)
  ;; 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))))

(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)
  (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)))
    (+ (/ 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)
  (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)))
    (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)
  (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)))
    (encode-universal-time 0 0 0 day month year)))


;; 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)))

(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=)))
         (cond
           ((consp type)
            (setf (gethash (intern typname :keyword) *type-to-oid*)
                  oid)
            (push (cons oid (cdr type)) *parsers*))
           (t
            #+debug
            (warn "Unknown PostgreSQL type found: '~A' oid: '~A'"
                   typname
                   oid)))))
     tuples)))

;; FIXME should perhaps resignal parse errors as a condition derived
;; from POSTGRESQL-ERROR
(defun parse (str oid)
  (declare (type simple-string str))
  (let ((parser (assoc oid *parsers* :test #'eql)))
    (if (consp parser)
        (funcall (cdr parser) str)
        str)))

(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*)))



;; 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))))))


;; EOF