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@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@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 ,@open-args))) - (unwind-protect - (progn ,@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 ,@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 ,@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@laas.fr> +;;; Time-stamp: <2004-03-05 emarsden> +;; +;; -(in-package :pg) +(in-package :postgresql) (eval-when (:compile-toplevel :load-toplevel :execute) #+allegro (require :socket)