[pg-cvs] CVS update: pg/CREDITS pg/TODO pg/large-object.lisp pg/meta-queries.lisp pg/parsers.lisp pg/utility.lisp pg/v2-protocol.lisp pg/v3-protocol.lisp pg/pg-tests.lisp pg/pg.asd pg/pg.lisp pg/sysdep.lisp
Eric Marsden
emarsden at common-lisp.net
Fri Mar 5 18:08:09 UTC 2004
Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv31521
Modified Files:
pg-tests.lisp pg.asd pg.lisp sysdep.lisp
Added Files:
CREDITS TODO large-object.lisp meta-queries.lisp parsers.lisp
utility.lisp v2-protocol.lisp v3-protocol.lisp
Log Message:
Integrate Peter Van Eynde's v3 protocol support:
- create PGCON-V2 and PGCON-V3 classes
- PG-CONNECT attempts to connect using v3 protocol, and falls back
to v2 protocol for older backends; return a PGCON-V2 or PGCON-V3
object
- PG-EXEC and FN and PG-DISCONNECT are generic functions that
dispatch on the connection type
- protocol code split into v2-protocol.lisp and v3-protocol.lisp
TBD: cleaning up the notification & error reporting support, and
factorizing more code between the two protocol versions.
Also split code out into multiple files:
- large-object support
- metainformation about databases
- parsing and type coercion support
- utility functions and macros
Date: Fri Mar 5 13:08:08 2004
Author: emarsden
Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.1.1.1 pg/pg-tests.lisp:1.2
--- pg/pg-tests.lisp:1.1.1.1 Wed Mar 3 08:11:50 2004
+++ pg/pg-tests.lisp Fri Mar 5 13:08:08 2004
@@ -1,4 +1,8 @@
-;; == testing ==============================================================
+;;; pg-tests.lisp -- incomplete test suite
+;;;
+;;; Author: Eric Marsden <emarsden at laas.fr>
+;;; Time-stamp: <2004-03-05 emarsden>
+;;
;;
;;
;; These tests assume that a table named "test" is defined in the
@@ -13,7 +17,7 @@
;; !!! CHANGE THE VALUES HERE !!!
(defun call-with-test-connection (function)
- (with-pg-connection (conn "test" "emarsden" :host "melbourne" :port 5433)
+ (with-pg-connection (conn "template1" "emarsden" :host nil :port 5432)
(funcall function conn)))
(defmacro with-test-connection ((conn) &body body)
@@ -301,5 +305,6 @@
(test-lo)
(test-lo-read)
#+cmu (test-lo-import))
+
;; EOF
Index: pg/pg.asd
diff -u pg/pg.asd:1.1.1.1 pg/pg.asd:1.2
--- pg/pg.asd:1.1.1.1 Wed Mar 3 08:11:50 2004
+++ pg/pg.asd Fri Mar 5 13:08:08 2004
@@ -15,8 +15,14 @@
(defsystem :pg
:name "Socket-level PostgreSQL interface"
:author "Eric Marsden"
- :version "0.19"
+ :version "0.21"
:components ((:file "defpackage")
(:file "sysdep" :depends-on ("defpackage"))
- (:pg-component "pg" :depends-on ("sysdep"))))
+ (:file "meta-queries" :depends-on ("defpackage"))
+ (:file "parsers" :depends-on ("defpackage"))
+ (:file "utility" :depends-on ("defpackage"))
+ (:pg-component "pg" :depends-on ("sysdep" "parsers"))
+ (:file "large-object" :depends-on ("pg"))
+ (:file "v2-protocol" :depends-on ("pg" "large-object" "utility"))
+ (:file "v3-protocol" :depends-on ("pg" "large-object" "utility"))))
Index: pg/pg.lisp
diff -u pg/pg.lisp:1.1.1.1 pg/pg.lisp:1.2
--- pg/pg.lisp:1.1.1.1 Wed Mar 3 08:11:50 2004
+++ pg/pg.lisp Fri Mar 5 13:08:08 2004
@@ -1,8 +1,8 @@
;;; pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp
;;
;; Author: Eric Marsden <emarsden at laas.fr>
-;; Time-stamp: <2004-02-18 emarsden>
-;; Version: 0.20
+;; Time-stamp: <2004-03-05 emarsden>
+;; Version: 0.21
;;
;; Copyright (C) 1999,2000,2001,2002,2003 Eric Marsden
;;
@@ -69,28 +69,10 @@
;; a change in PostgreSQL timestamp format.
-;;; 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*.
-;;
-;; * update to protocol version 3, as per
-;; http://developer.postgresql.org/docs/postgres/protocol-changes.html
-;; esp with respect to error responses
-
(declaim (optimize (speed 3) (safety 1)))
(in-package :postgresql)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- #+allegro (require :socket)
- #+lispworks (require "comm")
- #+cormanlisp (require :sockets)
- #+sbcl (progn (require :asdf) (require :sb-bsd-sockets))
- #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
-
(define-condition postgresql-error (simple-error) ())
(define-condition connection-failure (postgresql-error)
@@ -102,6 +84,7 @@
:reader connection-failure-transport-error))
(:report
(lambda (exc stream)
+ (declare (type stream stream))
(format stream "Couldn't connect to PostgreSQL database at ~a:~a.
Connection attempt reported ~A.
Is the postmaster running and accepting TCP connections?~%"
@@ -114,6 +97,7 @@
:reader authentication-failure-reason))
(:report
(lambda (exc stream)
+ (declare (type stream stream))
(format stream "PostgreSQL authentication failure: ~a~%"
(authentication-failure-reason exc)))))
@@ -122,6 +106,7 @@
:reader protocol-error-reason))
(:report
(lambda (exc stream)
+ (declare (type stream stream))
(format stream "PostgreSQL protocol error: ~a~%"
(protocol-error-reason exc)))))
@@ -130,15 +115,12 @@
:reader backend-error-reason))
(:report
(lambda (exc stream)
+ (declare (type stream stream))
(format stream "PostgreSQL backend error: ~a~%"
(backend-error-reason exc)))))
(defconstant +NAMEDATALEN+ 32) ; postgres_ext.h
-(defconstant +PG_PROTOCOL_LATEST_MAJOR+ 2) ; libpq/pgcomm.h
-(defconstant +PG_PROTOCOL_63_MAJOR+ 1)
-(defconstant +PG_PROTOCOL_62_MAJOR+ 0)
-(defconstant +PG_PROTOCOL_LATEST_MINOR+ 0)
(defconstant +SM_DATABASE+ 64)
(defconstant +SM_USER+ 32)
(defconstant +SM_OPTIONS+ 64)
@@ -155,289 +137,70 @@
(defconstant +MAX_MESSAGE_LEN+ 8192) ; libpq-fe.h
-(defconstant +INV_ARCHIVE+ #x10000) ; fe-lobj.c
-(defconstant +INV_WRITE+ #x20000)
-(defconstant +INV_READ+ #x40000)
-(defconstant +LO_BUFSIZ+ 1024)
-
-;; 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 *pg-client-encoding* "LATIN1"
"The encoding to use for text data, for example \"LATIN1\", \"UNICODE\", \"EUC_JP\".
See <http://www.postgresql.org/docs/7.3/static/multibyte.html>.")
(defvar *pg-date-style* "ISO")
-(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).")
+(defclass pgcon ()
+ ((stream :accessor pgcon-stream
+ :initarg :stream
+ :initform nil)
+ (host :accessor pgcon-host
+ :initarg :host
+ :initform nil)
+ (port :accessor pgcon-port
+ :initarg :port
+ :initform 0)
+ (pid :accessor pgcon-pid)
+ (secret :accessor pgcon-secret)
+ (notices :accessor pgcon-notices
+ :initform (list))
+ (binary-p :accessor pgcon-binary-p
+ :initform nil)))
+(defmethod print-object ((self pgcon) stream)
+ (print-unreadable-object (self stream :type nil)
+ (with-slots (pid host port) self
+ (format stream "PostgreSQL connection to backend pid ~d at ~a:~d"
+ pid host port))))
-(defstruct (pgcon (:print-function print-pgcon))
- stream pid secret notices (binary-p nil) host port)
(defstruct pgresult connection status attributes tuples)
-(defun print-pgcon (self &optional (stream t) depth)
- (declare (ignore depth))
- (print-unreadable-object (self stream :type nil)
- (format stream "PostgreSQL connection to backend pid ~d at ~a:~d"
- (pgcon-pid self)
- (pgcon-host self)
- (pgcon-port self))))
-
-(defun pg-date-style (conn)
- (let ((res (pg-exec conn "SHOW datestyle")))
- (first (pg-result res :tuple 0))))
-
-(defun set-pg-date-style (conn new-date-style)
- (declare (type simple-string new-date-style))
- (pg-exec conn "SET datestyle TO " new-date-style))
-
-(defsetf pg-date-style set-pg-date-style)
-
-;; see http://www.postgresql.org/docs/7.3/static/multibyte.html
-(defun pg-client-encoding (conn)
- "Return a string identifying the client encoding."
- (let ((res (pg-exec conn "SHOW client_encoding")))
- (first (pg-result res :tuple 0))))
-
-(defun set-pg-client-encoding (conn new-encoding)
- "Set the client_encoding."
- (declare (type simple-string new-encoding))
- (pg-exec conn "SET client_encoding TO " new-encoding))
-
-(defsetf pg-client-encoding set-pg-client-encoding)
-
-
-(defmacro with-pg-connection ((con &rest open-args) &body body)
- "Bindspec is of the form (connection open-args), where OPEN-ARGS are
-as for PG-CONNECT. The database connection is bound to the variable
-CONNECTION. If the connection is unsuccessful, the forms are not
-evaluated. Otherwise, the BODY forms are executed, and upon
-termination, normal or otherwise, the database connection is closed."
- `(let ((,con (pg-connect , at open-args)))
- (unwind-protect
- (progn , at body)
- (when ,con (pg-disconnect ,con)))))
-
-#-old-version
-(defmacro with-pg-transaction (con &body body)
- "Execute BODY forms in a BEGIN..END block.
-If a PostgreSQL error occurs during execution of the forms, execute
-a ROLLBACK command.
-Large-object manipulations _must_ occur within a transaction, since
-the large object descriptors are only valid within the context of a
-transaction."
- `(progn
- (pg-exec ,con "BEGIN WORK")
- (handler-case (prog1 (progn , at body) (pg-exec ,con "COMMIT WORK"))
- (error (e)
- (pg-exec ,con "ROLLBACK WORK")
- (error e)))))
-
-
-;;; this version thanks to Daniel Barlow. The old version would abort
-;;; the transaction before entering the debugger, which made
-;;; debugging difficult.
-(defmacro with-pg-transaction (con &body body)
- "Execute BODY forms in a BEGIN..END block.
-If a PostgreSQL error occurs during execution of the forms, execute
-a ROLLBACK command.
-Large-object manipulations _must_ occur within a transaction, since
-the large object descriptors are only valid within the context of a
-transaction."
- (let ((success (gensym "SUCCESS")))
- `(let (,success)
- (unwind-protect
- (prog2
- (pg-exec ,con "BEGIN WORK")
- (progn , at body)
- (setf ,success t))
- (pg-exec ,con (if ,success "COMMIT WORK" "ROLLBACK WORK"))))))
-
-(defun pg-for-each (conn select-form callback)
- "Create a cursor for SELECT-FORM, and call CALLBACK for each result.
-Uses the PostgreSQL database connection CONN. SELECT-FORM must be an
-SQL SELECT statement. The cursor is created using an SQL DECLARE
-CURSOR command, then results are fetched successively until no results
-are left. The cursor is then closed.
-
-The work is performed within a transaction. The work can be
-interrupted before all tuples have been handled by THROWing to a tag
-called 'pg-finished."
- (let ((cursor (symbol-name (gensym "PGCURSOR"))))
- (catch 'pg-finished
- (with-pg-transaction conn
- (pg-exec conn "DECLARE " cursor " CURSOR FOR " select-form)
- (unwind-protect
- (loop :for res = (pg-result (pg-exec conn "FETCH 1 FROM " cursor) :tuples)
- :until (zerop (length res))
- :do (funcall callback (first res)))
- (pg-exec conn "CLOSE " cursor))))))
+(defgeneric pg-exec (connection &rest args))
+
+(defgeneric fn (connection fn integer-result &rest args))
+(defgeneric pg-disconnect (connection))
+
+
+
+;; first attempt to connect to connect using the v3 protocol; if this
+;; results in an ErrorResponse we close the connection and retry using
+;; the v2 protocol. This allows us to connect to PostgreSQL 7.4
+;; servers using the benefits of the new protocol, but still interact
+;; with older servers.
(defun pg-connect (dbname user &key (host "localhost") (port 5432) (password ""))
"Initiate a connection with the PostgreSQL backend.
Connect to the database DBNAME with the username USER,
on PORT of HOST, providing PASSWORD if necessary. Return a
connection to the database (as an opaque type). If HOST is nil, attempt
-to connect to the database using a Unix socket."
- (let* ((stream (socket-connect port host))
- (connection (make-pgcon :stream stream :host host :port port))
- (user-packet-length (+ +SM_USER+ +SM_OPTIONS+ +SM_UNUSED+ +SM_TTY+)))
- ;; send the startup packet
- (send-int connection +STARTUP_PACKET_SIZE+ 4)
- (send-int connection +PG_PROTOCOL_LATEST_MAJOR+ 2)
- (send-int connection +PG_PROTOCOL_LATEST_MINOR+ 2)
- (send-string connection dbname +SM_DATABASE+)
- (send-string connection user user-packet-length)
- (flush connection)
- #+cmu (ext:finalize connection (lambda () (pg-disconnect connection)))
- (loop
- (case (read-byte stream)
- ;; ErrorResponse
- ((69) (error 'authentication-failure
- :reason (read-cstring connection 4096)))
-
- ;; Authentication
- ((82)
- (case (read-net-int connection 4)
- ((0) ; AuthOK
- (and (not *pg-disable-type-coercion*)
- (null *parsers*)
- (initialize-parsers connection))
- (when *pg-date-style*
- (setf (pg-date-style connection) *pg-date-style*))
- (when *pg-client-encoding*
- (setf (pg-client-encoding connection) *pg-client-encoding*))
- (return connection))
- ((3) ; AuthUnencryptedPassword
- (send-int connection (+ 5 (length password)) 4)
- (send-string connection password)
- (send-int connection 0 1)
- (flush connection))
- ((4) ; AuthEncryptedPassword
- (let* ((salt (read-chars connection 2))
- (crypted (crypt password salt)))
- #+debug
- (format *debug-io* "Got salt of ~s~%" salt)
- (send-int connection (+ 5 (length crypted)) 4)
- (send-string connection crypted)
- (send-int connection 0 1)
- (flush connection)))
- ((1) ; AuthKerberos4
- (error 'authentication-failure
- :reason "Kerberos4 authentication not supported"))
- ((2) ; AuthKerberos5
- (error 'authentication-failure
- :reason "Kerberos5 authentication not supported"))
- (t (error 'authentication-failure
- :reason "unknown authentication type"))))
-
- (t (error 'protocol-error
- :reason "expected an authentication response"))))))
-
-(defun pg-exec (connection &rest args)
- "Execute the SQL command given by the concatenation of ARGS
-on the database to which we are connected via CONNECTION. Return
-a result structure which can be decoded using `pg-result'."
- (let ((sql (apply #'concatenate 'simple-string args))
- (stream (pgcon-stream connection))
- (tuples '())
- (attributes '())
- (result (make-pgresult :connection connection)))
- (when (> (length sql) +MAX_MESSAGE_LEN+)
- (error "SQL statement too long: ~A" sql))
- (write-byte 81 stream)
- (send-string connection sql)
- (write-byte 0 stream)
- (flush connection)
- (do ((b (read-byte stream nil :eof)
- (read-byte stream nil :eof)))
- ((eq b :eof) (error 'protocol-error :reason "unexpected EOF from backend"))
- (case b
- ;; asynchronous notify, #\A
- ((65)
- ;; read the pid
- (read-net-int connection 4)
- (handle-notice connection))
-
- ;; BinaryRow, #\B
- ((66)
- (setf (pgcon-binary-p connection) t)
- (unless attributes
- (error 'protocol-error :reason "Tuple received before metadata"))
- (push (read-tuple connection attributes) tuples))
-
- ;; CompletedResponse, #\C
- ((67)
- (let ((status (read-cstring connection +MAX_MESSAGE_LEN+)))
- (setf (pgresult-status result) status)
- (setf (pgresult-tuples result) (nreverse tuples))
- (setf (pgresult-attributes result) attributes)
- (return result)))
-
- ;; AsciiRow (text data transfer), #\D
- ((68)
- (setf (pgcon-binary-p connection) nil)
- (unless attributes
- (error 'protocol-error :reason "Tuple received before metadata"))
- (push (read-tuple connection attributes) tuples))
-
- ;; ErrorResponse, #\E
- ((69)
- (let ((msg (read-cstring connection +MAX_MESSAGE_LEN+)))
- (error 'backend-error :reason msg)))
-
- ;; #\G and #\H: start copy in, start copy out
-
- ;; EmptyQueryResponse, #\I
- ((73)
- (let ((c (read-byte stream)))
- (when (< 0 c)
- (error 'protocol-error :reason "Garbled data"))))
-
- ;; BackendKeyData, #\K
- ((75)
- (setf (pgcon-pid connection) (read-net-int connection 4))
- (setf (pgcon-secret connection) (read-net-int connection 4)))
-
- ;; NotificationResponse, #\N
- ((78)
- (setf (pgcon-pid connection) (read-net-int connection 4))
- (handle-notice connection))
-
- ;; CursorResponse, #\P
- ((80)
- (let ((str (read-cstring connection +MAX_MESSAGE_LEN+)))
- (declare (ignore str))
- ;; (format *debug-io* "Portal name ~a~%" str)
- ))
-
- ;; RowDescription (metadata for subsequent tuples), #\T
- ((84)
- (and attributes (error "Cannot handle multiple result group"))
- (setq attributes (read-attributes connection)))
-
- ;; ReadyForQuery
- ((90) t)
-
- (t
- (error 'protocol-error
- :reason (format nil "Unknown response type from backend ~d" b)))))))
+to connect to the database using a Unix socket.
+We first attempt to speak the PostgreSQL 7.4 protocol, and fall back to
+the older network protocol if necessary."
+ (handler-case (pg-connect/v3 dbname user
+ :host host
+ :port port
+ :password password)
+ (protocol-error (c)
+ (warn "reconnecting using protocol version 2")
+ (pg-connect/v2 dbname user
+ :host host
+ :port port
+ :password password))))
(defun pg-result (result what &rest args)
@@ -466,420 +229,9 @@
(error "Only INSERT commands generate an oid: ~s" status))))
(t (error "Unknown result request: ~s" what))))
-(defun pg-disconnect (connection)
- (write-byte 88 (pgcon-stream connection))
- (flush connection)
- (close (pgcon-stream connection))
- (values))
-
-
-
-;; Attribute information is as follows
-;; attribute-name (string)
-;; attribute-type as an oid from table pg_type
-;; attribute-size (in bytes?)
-(defun read-attributes (connection)
- (let ((attribute-count (read-net-int connection 2))
- (attributes '()))
- (do ((i attribute-count (- i 1)))
- ((zerop i) (nreverse attributes))
- (let ((type-name (read-cstring connection +MAX_MESSAGE_LEN+))
- (type-id (read-net-int connection 4))
- (type-len (read-net-int connection 2))
- ;; this doesn't exist in the 6.3 protocol !!
- (type-modifier (read-net-int connection 4)))
- (declare (ignore type-modifier))
- (push (list type-name type-id type-len) attributes)))))
-
-;; the bitmap is a string, which we interpret as a sequence of bytes
-(defun bitmap-ref (bitmap ref)
- (multiple-value-bind (char-ref bit-ref)
- (floor ref 8)
- (logand #b10000000 (ash (aref bitmap char-ref) bit-ref))))
-
-;; the server starts by sending a bitmap indicating which tuples are
-;; NULL. "A bit map with one bit for each field in the row. The 1st
-;; field corresponds to bit 7 (MSB) of the 1st byte, the 2nd field
-;; corresponds to bit 6 of the 1st byte, the 8th field corresponds to
-;; bit 0 (LSB) of the 1st byte, the 9th field corresponds to bit 7 of
-;; the 2nd byte, and so on. Each bit is set if the value of the
-;; corresponding field is not NULL. If the number of fields is not a
-;; multiple of 8, the remainder of the last byte in the bit map is
-;; wasted."
-(defun read-tuple (connection attributes)
- (let* ((num-attributes (length attributes))
- (num-bytes (ceiling (/ num-attributes 8)))
- (bitmap (read-bytes connection num-bytes))
- (correction (if (pgcon-binary-p connection) 0 -4))
- (tuples '()))
- (do ((i 0 (+ i 1))
- (type-ids (mapcar #'second attributes) (cdr type-ids)))
- ((= i num-attributes) (nreverse tuples))
- (cond ((zerop (bitmap-ref bitmap i))
- (push nil tuples))
- (t
- (let* ((len (+ (read-net-int connection 4) correction))
- (raw (read-chars connection (max 0 len)))
- (parsed (parse raw (car type-ids))))
- (push parsed tuples)))))))
-
-;; FIXME could signal a postgresql-notification condition
-(defun handle-notice (connection)
- (push (read-cstring connection +MAX_MESSAGE_LEN+)
- (pgcon-notices connection)))
-
-
-;; type coercion support ==============================================
-;;
-;; 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.
-;; ====================================================================
-
-(defvar type-parsers
- `(("bool" . ,'bool-parser)
- ("char" . ,'text-parser)
- ("char2" . ,'text-parser)
- ("char4" . ,'text-parser)
- ("char8" . ,'text-parser)
- ("char16" . ,'text-parser)
- ("text" . ,'text-parser)
- ("varchar" . ,'text-parser)
- ("numeric" . ,'integer-parser)
- ("int2" . ,'integer-parser)
- ("int4" . ,'integer-parser)
- ("int8" . ,'integer-parser)
- ("oid" . ,'integer-parser)
- ("float4" . ,'float-parser)
- ("float8" . ,'float-parser)
- ("money" . ,'text-parser) ; "$12.34"
- ("abstime" . ,'timestamp-parser)
- ("date" . ,'date-parser)
- ("timestamp" . ,'timestamp-parser)
- ("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))
-
-(defun float-parser (str) (read-from-string str))
-
-;; FIXME this may need support for charset decoding
-(defun text-parser (str) str)
-
-(defun bool-parser (str)
- (cond ((string= "t" str) t)
- ((string= "f" str) nil)
- (t (error "Badly formed boolean from backend: ~s" str))))
-
-(defun parse-timestamp (str)
- (let* ((year (parse-integer (subseq str 0 4)))
- (month (parse-integer (subseq str 5 7)))
- (day (parse-integer (subseq str 8 10)))
- (hours (parse-integer (subseq str 11 13)))
- (minutes (parse-integer (subseq str 14 16)))
- (seconds (parse-integer (subseq str 17 19)))
- (start-tz (if (eql #\+ (char str (- (length str) 3)))
- (- (length str) 3)))
- (tz (when start-tz
- (parse-integer (subseq str start-tz))))
- (milliseconds (if (eql (char str 19) #\.)
- (parse-integer (subseq str 20 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)
- (multiple-value-bind (year month day hours minutes seconds)
- (parse-timestamp str)
- (encode-universal-time seconds minutes hours day month year)))
-
-(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 (subseq str 0 2)))
- (minutes (parse-integer (subseq str 3 5)))
- (seconds (parse-integer (subseq str 6 8)))
- (milliseconds (parse-integer (subseq str 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 (subseq str 0 4)))
- (month (parse-integer (subseq str 5 7)))
- (day (parse-integer (subseq str 8 10)))
- (hours (parse-integer (subseq str 11 13)))
- (minutes (parse-integer (subseq str 14 16)))
- (seconds (parse-integer (subseq str 17 19)))
- (tz (parse-integer (subseq str 19 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 (subseq str 0 4)))
- (month (parse-integer (subseq str 5 7)))
- (day (parse-integer (subseq str 8 10))))
- (encode-universal-time 0 0 0 day month year)))
-
-(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=)))
- (if (consp type)
- (push (cons oid (cdr type)) *parsers*))))
- tuples)))
-
-(defun parse (str oid)
- (let ((parser (assoc oid *parsers* :test #'eql)))
- (if (consp parser)
- (funcall (cdr parser) str)
- str)))
-
-;; large objects support ===============================================
-;;
-;; Sir Humphrey: Who is Large and to what does he object?
-;;
-;; Large objects are the PostgreSQL way of doing what most databases
-;; call BLOBs (binary large objects). In addition to being able to
-;; stream data to and from large objects, PostgreSQL's
-;; object-relational capabilities allow the user to provide functions
-;; which act on the objects.
-;;
-;; For example, the user can define a new type called "circle", and
-;; define a C or Tcl function called `circumference' which will act on
-;; circles. There is also an inheritance mechanism in PostgreSQL.
-;;
-;; The PostgreSQL large object interface is similar to the Unix file
-;; system, with open, read, write, lseek etc.
-;;
-;; Implementation note: the network protocol for large objects changed
-;; around version 6.5 to use network order for integers.
-;; =====================================================================
-
-(defvar *lo-initialized* nil)
-(defvar *lo-functions* '())
-
-(defun lo-init (connection)
- (let ((res (pg-exec connection
- "SELECT proname, oid from pg_proc WHERE "
- "proname = 'lo_open' OR "
- "proname = 'lo_close' OR "
- "proname = 'lo_creat' OR "
- "proname = 'lo_unlink' OR "
- "proname = 'lo_lseek' OR "
- "proname = 'lo_tell' OR "
- "proname = 'loread' OR "
- "proname = 'lowrite'")))
- (setq *lo-functions* '())
- (dolist (tuple (pg-result res :tuples))
- (push (cons (car tuple) (cadr tuple)) *lo-functions*))
- (unless (= 8 (length *lo-functions*))
- (error "Couldn't find OIDs for all the large object functions"))
- (setq *lo-initialized* t)))
-
-;; Execute one of the large-object functions (lo_open, lo_close etc).
-;; Argument FN is either an integer, in which case it is the OID of an
-;; element in the pg_proc table, and otherwise it is a string which we
-;; look up in the alist *lo-functions* to find the corresponding OID.
-(defun fn (connection fn integer-result &rest args)
- (or *lo-initialized* (lo-init connection))
- (let ((fnid (cond ((integerp fn) fn)
- ((not (stringp fn))
- (error "Expecting a string or an integer: ~s" fn))
- ((assoc fn *lo-functions* :test #'string=)
- (cdr (assoc fn *lo-functions* :test #'string=)))
- (t (error "Unknown builtin function ~s" fn)))))
- (send-int connection 70 1) ; function call
- (send-int connection 0 1)
- (send-int connection fnid 4)
- (send-int connection (length args) 4)
- (dolist (arg args)
- (cond ((integerp arg)
- (send-int connection 4 4)
- (send-int connection arg 4))
- ((stringp arg)
- (send-int connection (length arg) 4)
- (send-string connection arg))
- (t (error 'protocol-error
- :reason (format nil "Unknown fastpath type ~s" arg)))))
- (flush connection)
- (loop :with result = nil
- :with ready = nil
- :for b = (read-byte (pgcon-stream connection) nil :eof) :do
- (case b
- ;; FunctionResultResponse
- ((86)
- (let ((res (read-byte (pgcon-stream connection) nil :eof)))
- (cond ((= res 0) ; empty result
- (return-from fn nil))
- ((= res 71) ; nonempty result
- (let ((len (read-net-int connection 4)))
- (if integer-result
- (setq result (read-net-int connection len))
- (setq result (read-chars connection len)))))
- (t (error 'protocol-error :reason "wierd FunctionResultResponse")))))
-
- ;; end of FunctionResult
- ((48) (return-from fn result))
-
- ((69) (error 'backend-error :reason (read-cstring connection 4096)))
-
- ;; NoticeResponse
- ((78)
- (setf (pgcon-pid connection) (read-net-int connection 4))
- (handle-notice connection))
-
- ;; ReadyForQuery
- ((90) (setq ready t))
-
- (t (error 'protocol-error
- :reason (format nil "Unexpected byte ~s" b)))))))
-
-;; returns an OID
-(defun pglo-create (connection &optional (modestr "r"))
- (let* ((mode (cond ((integerp modestr) modestr)
- ((string= "r" modestr) +INV_READ+)
- ((string= "w" modestr) +INV_WRITE+)
- ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+))
- (t (error "Bad mode ~s" modestr))))
- (oid (fn connection "lo_creat" t mode)))
- (unless (integerp oid)
- (error 'backend-error :reason "Didn't return an OID"))
- (when (zerop oid)
- (error 'backend-error :reason "Can't create large object"))
- oid))
-
-;; args = modestring (default "r", or "w" or "rw")
-;; returns a file descriptor for use in later lo-* procedures
-(defun pglo-open (connection oid &optional (modestr "r"))
- (let* ((mode (cond ((integerp modestr) modestr)
- ((string= "r" modestr) +INV_READ+)
- ((string= "w" modestr) +INV_WRITE+)
- ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+))
- (t (error "Bad mode ~s" modestr))))
- (fd (fn connection "lo_open" t oid mode)))
- (assert (integerp fd))
- fd))
-
-(defun pglo-close (connection fd)
- (fn connection "lo_close" t fd))
-
-(defun pglo-read (connection fd bytes)
- (fn connection "loread" nil fd bytes))
-
-(defun pglo-write (connection fd buf)
- (fn connection "lowrite" t fd buf))
-
-(defun pglo-lseek (connection fd offset whence)
- (fn connection "lo_lseek" t fd offset whence))
-
-(defun pglo-tell (connection fd)
- (fn connection "lo_tell" t fd))
-
-(defun pglo-unlink (connection oid)
- (fn connection "lo_unlink" t oid))
-
-(defun pglo-import (connection filename)
- (let ((buf (make-string +LO_BUFSIZ+))
- (oid (pglo-create connection "rw")))
- (with-open-file (in filename :direction :input)
- (loop :with fdout = (pglo-open connection oid "w")
- :for bytes = (read-sequence buf in)
- :until (< bytes +LO_BUFSIZ+)
- :do (pglo-write connection fdout buf)
- :finally
- (pglo-write connection fdout (subseq buf 0 bytes))
- (pglo-close connection fdout)))
- oid))
-
-(defun pglo-export (connection oid filename)
- (with-open-file (out filename :direction :output)
- (loop :with fdin = (pglo-open connection oid "r")
- :for str = (pglo-read connection fdin +LO_BUFSIZ+)
- :until (zerop (length str))
- :do (write-sequence str out)
- :finally (pglo-close connection fdin))))
-
-
-;; DBMS metainformation ================================================
-;;
-;; Metainformation such as the list of databases present in the
-;; database management system, list of tables, attributes per table.
-;; This information is not available directly, but can be deduced by
-;; querying the system tables.
-;;
-;; Based on the queries issued by psql in response to user commands
-;; `\d' and `\d tablename'; see file pgsql/src/bin/psql/psql.c
-;; =====================================================================
-(defun pg-databases (conn)
- "Return a list of the databases available at this site."
- (let ((res (pg-exec conn "SELECT datname FROM pg_database")))
- (reduce #'append (pg-result res :tuples))))
-
-(defun pg-tables (conn)
- "Return a list of the tables present in this database."
- (let ((res (pg-exec conn "SELECT relname FROM pg_class, pg_user WHERE "
- "(relkind = 'r') AND relname !~ '^pg_' AND usesysid = relowner ORDER BY relname")))
- (reduce #'append (pg-result res :tuples))))
-
-(defun pg-columns (conn table)
- "Return a list of the columns present in TABLE."
- (let ((res (pg-exec conn (format nil "SELECT * FROM ~s WHERE 0 = 1" table))))
- (mapcar #'first (pg-result res :attributes))))
-
-(defun pg-backend-version (conn)
- "Return a string identifying the version and operating environment of the backend."
- (let ((res (pg-exec conn "SELECT version()")))
- (first (pg-result res :tuple 0))))
+
+
+
;; support routines ===================================================
@@ -934,7 +286,7 @@
(defun read-cstring (connection maxbytes)
"Read a null-terminated string from CONNECTION."
- (declare (type fixnum howmany))
+ (declare (type fixnum maxbytes))
(let ((stream (pgcon-stream connection))
(chars nil))
(do ((b (read-byte stream nil nil) (read-byte stream nil nil))
Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.1.1.1 pg/sysdep.lisp:1.2
--- pg/sysdep.lisp:1.1.1.1 Wed Mar 3 08:11:50 2004
+++ pg/sysdep.lisp Fri Mar 5 13:08:08 2004
@@ -1,6 +1,11 @@
-;;; system-dependent parts of pg-dot-lisp
+;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
+;;;
+;;; Author: Eric Marsden <emarsden at laas.fr>
+;;; Time-stamp: <2004-03-05 emarsden>
+;;
+;;
-(in-package :pg)
+(in-package :postgresql)
(eval-when (:compile-toplevel :load-toplevel :execute)
#+allegro (require :socket)
More information about the Pg-cvs
mailing list