- pg-cvs@common-lisp.net - mailman3.common-lisp.net

[pg-cvs] CVS update: pg/pg-tests.lisp
by Peter Van Eynde 08 Mar '04

08 Mar '04

Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv13025 Modified Files: pg-tests.lisp Log Message: added pbe test Date: Mon Mar 8 09:37:43 2004 Author: pvaneynde Index: pg/pg-tests.lisp diff -u pg/pg-tests.lisp:1.2 pg/pg-tests.lisp:1.3 --- pg/pg-tests.lisp:1.2 Fri Mar 5 13:08:08 2004 +++ pg/pg-tests.lisp Mon Mar 8 09:37:43 2004 @@ -7,7 +7,7 @@ ;; ;; These tests assume that a table named "test" is defined in the ;; system catalog, and that the user identified in -;; CALL-WITH-TEST-CONNECTION has the rights to access that table. +;; CALL-WITH-TEST-CONNECTION has the rights to access that table. (defpackage :pg-tests (:use :cl @@ -279,6 +279,42 @@ (pg-exec conn "DROP TABLE pgmt"))) +(defun test-pbe () + (with-test-connection (conn) + (when (pg-supports-pbe conn) + (format *debug-io* "~&Testing pbe...") + (let ((res nil) + (count 0) + (created nil)) + (unwind-protect + (progn + (pg-exec conn "CREATE TABLE count_test(key int, val int)") + (setq created t) + (format *debug-io* "~&table created") + (pg-prepare conn "ct_insert" + "INSERT INTO count_test VALUES ($1, $2)" + '("int4" "int4")) + (loop :for i :from 1 :to 100 + :do + (pg-bind conn + "ct_portal" "ct_insert" + `((:int32 ,i) + (:int32 ,(* i i)))) + (pg-execute conn "ct_portal") + (pg-close-portal conn "ct_portal")) + (format *debug-io* "~&data inserted") + (setq res (pg-exec conn "SELECT count(val) FROM count_test")) + (assert (eql 100 (first (pg-result res :tuple 0)))) + (setq res (pg-exec conn "SELECT sum(key) FROM count_test")) + (assert (eql 5050 (first (pg-result res :tuple 0)))) + ;; this iterator does the equivalent of the sum(key) SQL statement + ;; above, but on the client side. + (pg-for-each conn "SELECT key FROM count_test" + (lambda (tuple) (incf count (first tuple)))) + (assert (= 5050 count))) + (when created + (pg-exec conn "DROP TABLE count_test"))))))) + (defun test () (with-test-connection (conn) @@ -304,7 +340,8 @@ (test-notifications) (test-lo) (test-lo-read) - #+cmu (test-lo-import)) + #+cmu (test-lo-import) + (test-pbe)) ;; EOF

1 0

[pg-cvs] CVS update: pg/parsers.lisp
by Peter Van Eynde 08 Mar '04

08 Mar '04

Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv12704 Modified Files: parsers.lisp Log Message: added type-to-oid table and lookup-type function to aid in bpe operations Date: Mon Mar 8 09:37:37 2004 Author: pvaneynde Index: pg/parsers.lisp diff -u pg/parsers.lisp:1.1 pg/parsers.lisp:1.2 --- pg/parsers.lisp:1.1 Fri Mar 5 13:08:08 2004 +++ pg/parsers.lisp Mon Mar 8 09:37:36 2004 @@ -59,7 +59,10 @@ (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) @@ -96,6 +99,8 @@ ;; FIXME switch to a specialized float parser (defun float-parser (str) + (declare (type simple-string str)) + (let ((*read-eval* nil)) (read-from-string str))) @@ -103,12 +108,14 @@ (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 (subseq str 0 4))) (month (parse-integer (subseq str 5 7))) (day (parse-integer (subseq str 8 10))) @@ -172,8 +179,8 @@ ;; 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)))) + (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) @@ -185,14 +192,33 @@ (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*)))) + (cond + ((consp type) + (setf (gethash (intern typname :keyword) *type-to-oid*) + oid) + (push (cons oid (cdr type)) *parsers*)) + (t + #+debug + (warn "Unknown postgresSQL type found: '~A' oid: '~A'" + typname + oid))))) tuples))) (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*))) ;; EOF

1 0

[pg-cvs] CVS update: pg/pg.lisp pg/v3-protocol.lisp
by Peter Van Eynde 08 Mar '04

08 Mar '04

Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv7425 Modified Files: pg.lisp v3-protocol.lisp Log Message: pg.lisp: - make print-object more robust - added documentation to the defgenerics - added some declarations v3-protocol.lisp: - make errors restartable as we hope to sync again with the db - return errors from read-packet because sometimes it is the only clue we get that there is no more output - replaced arefs with the faster elt - unified query followup into do-followup-query - added pbe (prepare bind execute) support Date: Mon Mar 8 09:37:31 2004 Author: pvaneynde Index: pg/pg.lisp diff -u pg/pg.lisp:1.2 pg/pg.lisp:1.3 --- pg/pg.lisp:1.2 Fri Mar 5 13:08:08 2004 +++ pg/pg.lisp Mon Mar 8 09:37:31 2004 @@ -40,7 +40,7 @@ ;; Exceptions are Corman Common Lisp whose socket streams do not ;; support binary I/O. ;; -;; See the README for API documentation. +;; See the README for API documentation. ;; This code has been tested or reported to work with ;; @@ -81,7 +81,7 @@ (port :initarg :port :reader connection-failure-port) (transport-error :initarg :transport-error - :reader connection-failure-transport-error)) + :reader connection-failure-transport-error)) (:report (lambda (exc stream) (declare (type stream stream)) @@ -90,7 +90,7 @@ Is the postmaster running and accepting TCP connections?~%" (connection-failure-host exc) (connection-failure-port exc) - (connection-failure-transport-error exc))))) + (connection-failure-transport-error exc))))) (define-condition authentication-failure (postgresql-error) ((reason :initarg :reason @@ -162,21 +162,66 @@ :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)))) + (print-unreadable-object (self stream :type nil) + (with-slots (pid host port) self + (format stream "PostgreSQL connection to backend pid ~d at ~a:~d" + (when (slot-boundp self 'pid) + pid) + (when (slot-boundp self 'host) + host) + (when (slot-boundp self 'port) + port))))) (defstruct pgresult connection status attributes tuples) -(defgeneric pg-exec (connection &rest args)) - -(defgeneric fn (connection fn integer-result &rest args)) - -(defgeneric pg-disconnect (connection)) - - +(defgeneric pg-exec (connection &rest args) + (:documentation + "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'.")) + +(defgeneric fn (connection fn integer-result &rest args) + (:documentation + "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.")) + +(defgeneric pg-disconnect (connection) + (:documentation + "Disconnects from the DB")) + +(defgeneric pg-supports-pbe (connection) + (:documentation + "Returns true if the connection supports pg-prepare/-bind and -execute") + (:method (connection) + (declare (ignore connection)) + nil)) + +(defgeneric pg-prepare (connection statement-name sql-statement &optional type-of-parameters) + (:documentation + "Prepares a sql-statement give a given statement-name (can be empty) +and optionally declares the types of the parameters as a list of strings. +You can define parameters to be filled in later by using $1 and so on.")) + +(defgeneric pg-bind (connection portal statement-name list-of-types-and-values) + (:documentation + "Gives the values for the parameters defined in the statement-name. The types +can be one of :char :byte :int16 :int32 or :cstring")) + +(defgeneric pg-execute (connection portal &optional maxinum-number-of-rows) + (:documentation + "Executes the portal defined previously and return (optionally) up to maximum-number-of-row. +For an unlimited number of rows use 0")) + +(defgeneric pg-close-statement (connection statement-name) + (:documentation + "Closes a prepared statement")) + +(defgeneric pg-close-portal (connection portal) + (:documentation + "Closes a prepared statement")) ;; first attempt to connect to connect using the v3 protocol; if this ;; results in an ErrorResponse we close the connection and retry using @@ -196,6 +241,7 @@ :port port :password password) (protocol-error (c) + (declare (ignore c)) (warn "reconnecting using protocol version 2") (pg-connect/v2 dbname user :host host @@ -214,6 +260,7 @@ :tuple n -> return the nth component of the data :oid -> return the OID (a unique identifier generated by PostgreSQL for each row resulting from an insertion" + (declare (type pgresult result)) (cond ((eq :connection what) (pgresult-connection result)) ((eq :status what) (pgresult-status result)) ((eq :attributes what) (pgresult-attributes result)) @@ -238,6 +285,9 @@ ;; read an integer in network byte order (defun read-net-int (connection bytes) + (declare (type (integer 0) bytes) + (type pgcon connection)) + (do ((i bytes (- i 1)) (stream (pgcon-stream connection)) (accum 0)) @@ -271,8 +321,8 @@ (let ((v (make-array howmany :element-type '(unsigned-byte 8))) (s (pgcon-stream connection))) (do ((continue-at (read-sequence v s :start 0 :end howmany) - (read-sequence v s :start continue-at :end howmany))) - ((= continue-at howmany)) + (read-sequence v s :start continue-at :end howmany))) + ((= continue-at howmany)) ) v)) Index: pg/v3-protocol.lisp diff -u pg/v3-protocol.lisp:1.1 pg/v3-protocol.lisp:1.2 --- pg/v3-protocol.lisp:1.1 Fri Mar 5 13:08:08 2004 +++ pg/v3-protocol.lisp Mon Mar 8 09:37:31 2004 @@ -15,46 +15,46 @@ ((severity :initarg :severity :reader error-response-severity) (code :initarg :code - :reader error-response-code) + :reader error-response-code) (message :initarg :message - :reader error-response-message) + :reader error-response-message) (detail :initarg :detail - :reader error-response-detail) + :reader error-response-detail) (hint :initarg :hint - :reader error-response-hint) + :reader error-response-hint) (position :initarg :position - :reader error-response-position) + :reader error-response-position) (where :initarg :where - :reader error-response-where) + :reader error-response-where) (file :initarg :file - :reader error-response-file) + :reader error-response-file) (line :initarg :line - :reader error-response-line) + :reader error-response-line) (routine :initarg :routine - :reader error-response-routine)) + :reader error-response-routine)) (:report (lambda (exc stream) (format stream "PostgreSQL ~A: (~A) ~A, ~A. Hint: ~A File: ~A, line ~A/~A ~A -> ~A" - (ignore-errors - (error-response-severity exc)) - (ignore-errors - (error-response-code exc)) - (ignore-errors - (error-response-message exc)) - (ignore-errors - (error-response-detail exc)) - (ignore-errors - (error-response-hint exc)) - (ignore-errors - (error-response-file exc)) - (ignore-errors - (error-response-line exc)) - (ignore-errors - (error-response-position exc)) - (ignore-errors - (error-response-routine exc)) - (ignore-errors - (error-response-where exc)))))) + (ignore-errors + (error-response-severity exc)) + (ignore-errors + (error-response-code exc)) + (ignore-errors + (error-response-message exc)) + (ignore-errors + (error-response-detail exc)) + (ignore-errors + (error-response-hint exc)) + (ignore-errors + (error-response-file exc)) + (ignore-errors + (error-response-line exc)) + (ignore-errors + (error-response-position exc)) + (ignore-errors + (error-response-routine exc)) + (ignore-errors + (error-response-where exc)))))) ;; packets send/received are always: @@ -68,24 +68,24 @@ (defclass pg-packet () ((type :initarg :type - :type base-char - :reader pg-packet-type) + :type base-char + :reader pg-packet-type) (length :initarg :length - :type (integer 32)) + :type (integer 32)) (data :initarg :data - :type (array (unsigned-byte 8) *)) + :type (array (unsigned-byte 8) *)) (position :initform 0 - :type integer))) + :type integer))) (defmethod print-object ((object pg-packet) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "type: ~A length: ~A position: ~A" - (and (slot-boundp object 'type) - (slot-value object 'type)) - (and (slot-boundp object 'length) - (slot-value object 'length)) - (and (slot-boundp object 'position) - (slot-value object 'position))))) + (and (slot-boundp object 'type) + (slot-value object 'type)) + (and (slot-boundp object 'length) + (slot-value object 'length)) + (and (slot-boundp object 'position) + (slot-value object 'position))))) ;; first some help functions: @@ -98,8 +98,8 @@ (when (= 1 (ldb (byte 1 7) result)) ;; negative (setf result (- - (1+ (logxor result - #xFF))))) + (1+ (logxor result + #xFF))))) result)) (defun %read-net-int16 (stream) @@ -107,12 +107,12 @@ The signed integer is presumed to be in network order. Returns the integer." (let ((result (+ (* 256 (read-byte stream)) - (read-byte stream)))) + (read-byte stream)))) (when (= 1 (ldb (byte 1 15) result)) ;; negative (setf result (- - (1+ (logxor result - #xFFFF))))) + (1+ (logxor result + #xFFFF))))) result)) (defun %read-net-int32 (stream) @@ -120,14 +120,14 @@ The signed integer is presumed to be in network order. Returns the integer." (let ((result (+ (* 256 256 256 (read-byte stream)) - (* 256 256 (read-byte stream)) - (* 256 (read-byte stream)) - (read-byte stream)))) + (* 256 256 (read-byte stream)) + (* 256 (read-byte stream)) + (read-byte stream)))) (when (= 1 (ldb (byte 1 31) result)) ;; negative (setf result (- - (1+ (logxor result - #xFFFFFFFF))))) + (1+ (logxor result + #xFFFFFFFF))))) result)) #-cmu @@ -149,8 +149,8 @@ Returns the array of " (let ((v (make-array howmany :element-type '(unsigned-byte 8)))) (do ((continue-at (read-sequence v stream :start 0 :end howmany) - (read-sequence v stream :start continue-at :end howmany))) - ((= continue-at howmany)) + (read-sequence v stream :start continue-at :end howmany))) + ((= continue-at howmany)) ) v)) @@ -161,38 +161,41 @@ (defun read-and-generate-error-response (packet) (let ((args nil)) (loop :for field-type = (read-from-packet packet :byte) - :until (= field-type 0) - :do - (let ((message (read-from-packet packet :cstring))) - (push message args) - (push - (ecase (code-char field-type) - ((#\S) :severity) - ((#\C) :code) - ((#\M) :message) - ((#\D) :detail) - ((#\H) :hint) - ((#\P) :position) - ((#\W) :where) - ((#\F) :file) - ((#\L) :line) - ((#\R) :routine)) - args))) - (apply #'error - 'error-response - args))) + :until (= field-type 0) + :do + (let ((message (read-from-packet packet :cstring))) + (push message args) + (push + (ecase (code-char field-type) + ((#\S) :severity) + ((#\C) :code) + ((#\M) :message) + ((#\D) :detail) + ((#\H) :hint) + ((#\P) :position) + ((#\W) :where) + ((#\F) :file) + ((#\L) :line) + ((#\R) :routine)) + args))) + ;; we are trying to recover from errors too: + (apply #'cerror + "Try to continue, should do a rollback" + 'error-response + args))) (defun read-and-handle-notification-response (connection packet) - (declare (type pg-packet packet)) - + (declare (type pg-packet packet) + (type pgcon-v3 connection)) + (let* ((pid (read-from-packet packet :int32)) - (name-condition (read-from-packet packet :cstring)) - (additional-information (read-from-packet packet :cstring))) + (name-condition (read-from-packet packet :cstring)) + (additional-information (read-from-packet packet :cstring))) (setf (pgcon-pid connection) pid) (format t "~&Got notice: ~S, ~S" - name-condition - additional-information) + name-condition + additional-information) (push name-condition (pgcon-notices connection)))) @@ -201,10 +204,11 @@ (defun read-packet (connection) "Reads a packet from the connection. -Returns the packet, handles errors and notices automagically" +Returns the packet, handles errors and notices automagically, +but will still return them" (let* ((stream (pgcon-stream connection)) - (type (%read-net-int8 stream)) - (length (%read-net-int32 stream))) + (type (%read-net-int8 stream)) + (length (%read-net-int32 stream))) ;; detect a bogus protocol response from the backend, which ;; probably means that we're in PG-CONNECT/V3 but talking to an ;; old backend that only understands the V2 protocol. Heuristics @@ -221,16 +225,16 @@ :length length :data data))) (case (pg-packet-type packet) - (( #\E) ; error + (( #\E) ; error (read-and-generate-error-response packet) - ;; in case we handled it: - (read-packet connection)) - (( #\N) ; Notice - (handle-notice/v3 connection packet)) + packet) + (( #\N) ; Notice + (handle-notice/v3 connection packet) + packet) (t ;; return the packet packet))))) - + ;; Not to get at the data: (defgeneric read-from-packet (packet type) @@ -238,70 +242,70 @@ "Reads an integer from the given PACKET with type TYPE") (:method ((packet pg-packet) (type (eql :char))) (with-slots (data position) - packet + packet (prog1 - (aref data position) - (incf position)))) + (elt data position) + (incf position)))) (:method ((packet pg-packet) (type (eql :byte))) (with-slots (data position) - packet + packet - (let ((result (aref data position))) - (incf position) - (when (= 1 (ldb (byte 1 7) result)) - ;; negative - (setf result (- - (1+ (logxor result - #xFF))))) - result))) + (let ((result (elt data position))) + (incf position) + (when (= 1 (ldb (byte 1 7) result)) + ;; negative + (setf result (- + (1+ (logxor result + #xFF))))) + result))) (:method ((packet pg-packet) (type (eql :int16))) (with-slots (data position) - packet + packet - (let ((result (+ (* 256 (aref data position)) - (aref data (1+ position))))) - (incf position 2) - (when (= 1 (ldb (byte 1 15) result)) - ;; negative - (setf result (- - (1+ (logxor result - #xFFFF))))) - result))) + (let ((result (+ (* 256 (elt data position)) + (elt data (1+ position))))) + (incf position 2) + (when (= 1 (ldb (byte 1 15) result)) + ;; negative + (setf result (- + (1+ (logxor result + #xFFFF))))) + result))) (:method ((packet pg-packet) (type (eql :int32))) (with-slots (data position) - packet + packet - (let ((result (+ (* 256 256 256 (aref data position)) - (* 256 256 (aref data (1+ position))) - (* 256 (aref data (+ 2 position))) - (aref data (+ 3 position))))) - - (incf position 4) - (when (= 1 (ldb (byte 1 31) result)) - ;; negative - (setf result (- - (1+ (logxor result - #xFFFFFFFF))))) - result))) + (let ((result (+ (* 256 256 256 (elt data position)) + (* 256 256 (elt data (1+ position))) + (* 256 (elt data (+ 2 position))) + (elt data (+ 3 position))))) + + (incf position 4) + (when (= 1 (ldb (byte 1 31) result)) + ;; negative + (setf result (- + (1+ (logxor result + #xFFFFFFFF))))) + result))) (:method ((packet pg-packet) (type (eql :cstring))) (with-slots (data position) - packet + packet (let* ((end (position 0 data :start position)) - ;; end is where the 0 byte is - (result (unless (= end position) - (make-array (- end position) - :element-type 'base-char)))) - (when result - (loop :for i :from position :below end - :for j :from 0 - :do - (setf (aref result j) - (code-char - (aref data i)))) - (setf position (1+ end)) - result))))) + ;; end is where the 0 byte is + (result (unless (= end position) + (make-array (- end position) + :element-type 'base-char)))) + (when result + (loop :for i :from position :below end + :for j :from 0 + :do + (setf (elt result j) + (code-char + (elt data i)))) + (setf position (1+ end)) + result))))) (defgeneric read-string-from-packet (packet length) (:documentation @@ -311,19 +315,19 @@ (:method ((packet pg-packet) (length integer)) (when (<= length 0) (error "length cannot be negative. is: ~S" - length)) + length)) (let ((result (make-array length - :element-type 'base-char))) + :element-type 'base-char))) (with-slots (data position) - packet - (loop :for i :from 0 :below length - :do - (setf (aref result i) - (code-char - (the (unsigned-byte 8) - (aref data (+ i position)))))) - (incf position length) - result)))) + packet + (loop :for i :from 0 :below length + :do + (setf (elt result i) + (code-char + (the (unsigned-byte 8) + (elt data (+ i position)))))) + (incf position length) + result)))) ;; now sending data: @@ -331,10 +335,10 @@ (defun %send-net-int (stream int bytes) (let ((v (make-array bytes :element-type '(unsigned-byte 8)))) (loop for offset from (* 8 (1- bytes)) downto 0 by 8 - for data = (ldb (byte 8 offset) int) - for i from 0 - do - (setf (aref v i) data)) + for data = (ldb (byte 8 offset) int) + for i from 0 + do + (setf (elt v i) data)) #+debug (format t "~&writing: ~S~%" v) (write-sequence v stream))) @@ -345,7 +349,7 @@ (v (make-array len :element-type '(unsigned-byte 8)))) ;; convert the string to a vector of bytes (dotimes (i len) - (setf (aref v i) (char-code (aref str i)))) + (setf (elt v i) (char-code (elt str i)))) (write-sequence v stream) (write-byte 0 stream))) @@ -360,57 +364,56 @@ of items with as first element one of :byte, :char :int16 :int32 or :cstring and as second element the value of the parameter" - #+nil (declare (type base-char code)) (let* ((length (+ 4 - (loop for (type value) in description - sum (ecase type - ((:byte :char) 1) - ((:int16) 2) - ((:int32) 4) - ((:cstring) - (+ 1 - (length value))))))) - (data (make-array (- length 4) - :element-type '(unsigned-byte 8))) - (stream (pgcon-stream connection))) + (loop for (type value) in description + sum (ecase type + ((:byte :char) 1) + ((:int16) 2) + ((:int32) 4) + ((:cstring) + (+ 1 + (length value))))))) + (data (make-array (- length 4) + :element-type '(unsigned-byte 8))) + (stream (pgcon-stream connection))) (loop for (type value) in description - with position = 0 - do - (ecase type - ((:byte) - (check-type value (unsigned-byte 8)) - (setf (aref data position) value) - (incf position)) - ((:char) - (check-type value base-char) - (setf (aref data position) (char-code value)) - (incf position)) - ((:int16) - (check-type value (unsigned-byte 16)) - (setf (aref data position) (ldb (byte 8 8) value)) - (setf (aref data (+ 1 position)) (ldb (byte 8 0) value)) - (incf position 2)) - ((:int32) - (check-type value (unsigned-byte 32)) - - (setf (aref data position) (ldb (byte 8 24) value)) - (setf (aref data (+ 1 position)) (ldb (byte 8 16) value)) - (setf (aref data (+ 2 position)) (ldb (byte 8 8) value)) - (setf (aref data (+ 3 position)) (ldb (byte 8 0) value)) - (incf position 4)) - ((:cstring) - (check-type value string) - - (loop for char across value - do - (setf (aref data position) - (char-code char)) - (incf position)) - (setf (aref data position) 0) - (incf position)))) + with position = 0 + do + (ecase type + ((:byte) + (check-type value (unsigned-byte 8)) + (setf (elt data position) value) + (incf position)) + ((:char) + (check-type value base-char) + (setf (elt data position) (char-code value)) + (incf position)) + ((:int16) + (check-type value (unsigned-byte 16)) + (setf (elt data position) (ldb (byte 8 8) value)) + (setf (elt data (+ 1 position)) (ldb (byte 8 0) value)) + (incf position 2)) + ((:int32) + (check-type value (unsigned-byte 32)) + + (setf (elt data position) (ldb (byte 8 24) value)) + (setf (elt data (+ 1 position)) (ldb (byte 8 16) value)) + (setf (elt data (+ 2 position)) (ldb (byte 8 8) value)) + (setf (elt data (+ 3 position)) (ldb (byte 8 0) value)) + (incf position 4)) + ((:cstring) + (check-type value string) + + (loop for char across value + do + (setf (elt data position) + (char-code char)) + (incf position)) + (setf (elt data position) 0) + (incf position)))) (%send-net-int stream (char-code code) 1) (%send-net-int stream length 4 ) @@ -426,16 +429,16 @@ (let* ((stream (socket-connect port host)) (connection (make-instance 'pgcon-v3 :stream stream :host host :port port)) (user-packet-length (+ 4 ; length - 4 ; protocol version - (length "user") - 1 - (length user) - 1 - (length "database") - 1 - (length dbname) - 1 - 1))) + 4 ; protocol version + (length "user") + 1 + (length user) + 1 + (length "database") + 1 + (length dbname) + 1 + 1))) ;; send the startup packet ;; this is one of the only non-standard packets! (%send-net-int stream user-packet-length 4) @@ -453,138 +456,205 @@ :for packet = (read-packet connection) :do (case (pg-packet-type packet) - ;; Authentication Request: - (( #\R) - (let* ((code (read-from-packet packet :int32))) - (case code - ((0) ;; AuthOK - ) - ((1) ; AuthKerberos4 - (error 'authentication-failure - :reason "Kerberos4 authentication not supported")) - ((2) ; AuthKerberos5 - (error 'authentication-failure - :reason "Kerberos5 authentication not supported")) - ((3) ; AuthUnencryptedPassword - (send-packet connection - #\p - `((:cstring ,password))) - (%flush connection)) - ((4) ; AuthEncryptedPassword - (let* ((salt (read-string-from-packet packet 2)) - (crypted (crypt password salt))) - #+debug - (format *debug-io* "Got salt of ~s~%" salt) - (send-packet connection - #\p - `((:cstring ,crypted))) - (%flush connection))) - ((5) ; AuthMD5Password - (error 'authentication-failure - :reason "MD5 authentication not supported")) - ((6) ; AuthSCMPassword - (error 'authentication-failure - :reason "SCM authentication not supported")) - (t (error 'authentication-failure - :reason "unknown authentication type"))))) - (( #\K) ; Cancelation - (let* ((pid (read-from-packet packet :int32)) - (secret (read-from-packet packet :int32))) - #+debug - (format t "~&Got cancelation data") - - (setf (pgcon-pid connection) pid) - (setf (pgcon-secret connection) secret))) - (( #\S) ; Status - (let* ((parameter (read-from-packet packet :cstring)) - (value (read-from-packet packet :cstring))) + ((#\R) + ;; Authentication Request: + (let* ((code (read-from-packet packet :int32))) + (case code + ((0) ;; AuthOK + ) + ((1) ; AuthKerberos4 + (error 'authentication-failure + :reason "Kerberos4 authentication not supported")) + ((2) ; AuthKerberos5 + (error 'authentication-failure + :reason "Kerberos5 authentication not supported")) + ((3) ; AuthUnencryptedPassword + (send-packet connection + #\p + `((:cstring ,password))) + (%flush connection)) + ((4) ; AuthEncryptedPassword + (let* ((salt (read-string-from-packet packet 2)) + (crypted (crypt password salt))) + #+debug + (format *debug-io* "Got salt of ~s~%" salt) + (send-packet connection + #\p + `((:cstring ,crypted))) + (%flush connection))) + ((5) ; AuthMD5Password + (error 'authentication-failure + :reason "MD5 authentication not supported")) + ((6) ; AuthSCMPassword + (error 'authentication-failure + :reason "SCM authentication not supported")) + (t (error 'authentication-failure + :reason "unknown authentication type"))))) + (( #\K) + ;; Cancelation + (let* ((pid (read-from-packet packet :int32)) + (secret (read-from-packet packet :int32))) + #+debug + (format t "~&Got cancelation data") + + (setf (pgcon-pid connection) pid) + (setf (pgcon-secret connection) secret))) + (( #\S) + ;; Status + (let* ((parameter (read-from-packet packet :cstring)) + (value (read-from-packet packet :cstring))) (push (cons parameter value) (pgcon-parameters connection)))) - ((#\Z) ; Ready for Query - (let* ((status (read-from-packet packet :byte))) - (unless (= status - (char-code #\I)) - (warn "~&Got status ~S but wanted I~%" - (code-char status))) - - (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))) + ((#\Z) + ;; Ready for Query + (let* ((status (read-from-packet packet :byte))) + (unless (= status + (char-code #\I)) + (warn "~&Got status ~S but wanted I~%" + (code-char status))) + + (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))) + ((#\E) + ;; an error, we should abort. + (return nil)) + ((#\N) + ;; We ignore Notices + t) (t (error 'protocol-error :reason "expected an authentication response")))))) +(defun do-followup-query (connection) + "Does the followup of a query" + + (let ((tuples '()) + (attributes '()) + (result (make-pgresult :connection connection))) + + (%flush connection) + + (loop + :for packet = (read-packet connection) + :with got-data-p = nil + :do + (when packet + (case (pg-packet-type packet) + ((#\S) + ;; Parameter status? not documented as return! + ;; XXX investigate + (let* ((parameter (read-from-packet packet :cstring)) + (value (read-from-packet packet :cstring))) + ;;#+debug + (warn "~&Got unexpected parameter ~S = ~S" + parameter + value))) + ((#\A) + ;; NotificationResponse + ;; Not documented? + ;; XXX investigate + (read-and-handle-notification-response connection packet)) + ((#\C) + ;; CommandComplete + (let ((status (read-from-packet packet :cstring))) + (setf (pgresult-status result) status) + (setf (pgresult-tuples result) (nreverse tuples)) + (setf (pgresult-attributes result) attributes)) + (setf got-data-p t)) + ((#\G) + ;; CopyInResponse + (cerror "Just ignore it" "What to do with #\G?") + ;; The backend is ready to copy data from the frontend to a table; + ;; see Section 44.2.5 in http://www.postgresql.org/docs/7.4/interactive/protocol-flow.html + ;; for now we make it fail gracefully: + (send-packet connection + #\f + ;;CopyFail + '((:cstring "not implemented by pg.lisp yet"))) + ) + ((#\H) + ;; CopyOutResponse + (cerror "Just ignore it" "What to do with #\H?") + ;; The backend is ready to copy data from a table to the frontend; + ;; see Section 44.2.5. + ;; for now we make it fail gracefully (we cannot stop the transfer... + ) + (( #\d + ;; CopyData + #\c + ;;CopyDone + ) + t) + ((#\T) + ;; RowDescription (metadata for subsequent tuples), #\T + (and attributes (error "Cannot handle multiple result group")) + (setq attributes (read-attributes/v3 packet))) + ((#\D) + ;; AsciiRow (text data transfer), #\D + (setf got-data-p t) + (setf (pgcon-binary-p connection) nil) + (unless attributes + (error 'protocol-error :reason "Tuple received before metadata")) + (push (read-tuple/v3 packet attributes) tuples)) + ((#\I) + ;; EmptyQueryResponse, #\I + ;; so no result. + (setf got-data-p t) + (setf (pgresult-status result) "SELECT") + (setf (pgresult-tuples result) nil) + (setf (pgresult-attributes result) nil)) + ((#\Z) + ;; ReadyForQuery + ;; + ;; it might be a result from a previous + ;; query + (when got-data-p + (return result))) + ((#\s) + ;; PortalSuspend + ;; we're done in any case: + (return result)) + ((#\2 + ;; BindComplete + #\1 + ;; ParseComplete + #\3 + ;; CloseComplete + #\n + ;; NoData + ) + ;; we ignore these messages + t) + ((#\E + ;; an error, we bravely try to recover... + #\N) + ;; and we ignore Notices + t) + (t + (warn "Got unexpected packet: ~S, resetting connection" + packet) + ;; sync + (send-packet connection + #\S + nil) + (%flush connection))))))) + (defmethod pg-exec ((connection pgcon-v3) &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)) - (tuples '()) - (attributes '()) - (result (make-pgresult :connection connection))) + (let ((sql (apply #'concatenate 'simple-string args))) (when (> (length sql) +MAX_MESSAGE_LEN+) (error "SQL statement too long: ~A" sql)) (send-packet connection #\Q `((:cstring ,sql))) (%flush connection) - (loop - for packet = (read-packet connection) - do - (ecase (pg-packet-type packet) - ((#\S) - (let* ((parameter (read-from-packet packet :cstring)) - (value (read-from-packet packet :cstring))) - (push (cons parameter value) (pgcon-parameters connection)))) - ((#\A) - ;; NotificationResponse - ;; Not documented? - ;; XXX investigate - (read-and-handle-notification-response connection packet)) - ((#\C) - ;; CommandComplete - (let ((status (read-from-packet packet :cstring))) - (setf (pgresult-status result) status) - (setf (pgresult-tuples result) (nreverse tuples)) - (setf (pgresult-attributes result) attributes))) - ((#\G) - ;; CopyInResponse - (error "What to do with #\G?") - ;; The backend is ready to copy data from the frontend to a table; - ;; see Section 44.2.5. - ) - ((#\H) - ;; CopyOutResponse - (error "What to do with #\H") - ;; The backend is ready to copy data from a table to the frontend; - ;; see Section 44.2.5. - ) - ((#\T) - ;; RowDescription (metadata for subsequent tuples), #\T - (and attributes (error "Cannot handle multiple result group")) - (setq attributes (read-attributes/v3 packet))) - ((#\D) - ;; AsciiRow (text data transfer), #\D - (setf (pgcon-binary-p connection) nil) - (unless attributes - (error 'protocol-error :reason "Tuple received before metadata")) - (push (read-tuple/v3 packet attributes) tuples)) - ((#\I) - ;; EmptyQueryResponse, #\I - ;; so no result. - (setf (pgresult-status result) "SELECT") - (setf (pgresult-tuples result) nil) - (setf (pgresult-attributes result) nil)) - ((#\N) ; NotificationResponse - ;; the notification has already been handled - t) - ((#\Z) - ;; ReadyForQuery - ;; we're done: - (return result)))))) + (do-followup-query connection))) (defmethod pg-disconnect ((connection pgcon-v3)) @@ -601,41 +671,41 @@ (do ((i attribute-count (- i 1))) ((zerop i) (nreverse attributes)) (let* ((type-name (read-from-packet packet :cstring)) - (table-id (read-from-packet packet :int32)) - (column-id (read-from-packet packet :int16)) - (type-id (read-from-packet packet :int32)) - (type-len (read-from-packet packet :int16)) - (type-mod (read-from-packet packet :int32)) - (format-code (read-from-packet packet :int16))) + (table-id (read-from-packet packet :int32)) + (column-id (read-from-packet packet :int16)) + (type-id (read-from-packet packet :int32)) + (type-len (read-from-packet packet :int16)) + (type-mod (read-from-packet packet :int32)) + (format-code (read-from-packet packet :int16))) (declare (ignore type-mod format-code - table-id column-id)) + table-id column-id)) (push (list type-name type-id type-len) attributes))))) (defun read-tuple/v3 (packet attributes) (let* ((num-attributes (length attributes)) - (number (read-from-packet packet :int16)) + (number (read-from-packet packet :int16)) (tuples '())) (unless (= num-attributes - number) + number) (error "Should ~S not be equal to ~S" - num-attributes - number)) + num-attributes + number)) (do ((i 0 (+ i 1)) (type-ids (mapcar #'second attributes) (cdr type-ids))) ((= i num-attributes) (nreverse tuples)) (let* ((length (read-from-packet packet :int32)) - (raw (unless (= length -1) - (read-string-from-packet packet length)))) - (if raw - (push (parse raw (car type-ids)) tuples) - (push nil tuples)))))) + (raw (unless (= length -1) + (read-string-from-packet packet length)))) + (if raw + (push (parse raw (car type-ids)) tuples) + (push nil tuples)))))) ;; 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. (defmethod fn ((connection pgcon-v3) fn integer-result &rest args) - (or *lo-initialized* (lo-init connection)) + (or *lo-initialized* (lo-init connection)) (let ((fnid (cond ((integerp fn) fn) ((not (stringp fn)) (error "Expecting a string or an integer: ~s" fn)) @@ -643,59 +713,73 @@ (cdr (assoc fn *lo-functions* :test #'string=))) (t (error "Unknown builtin function ~s" fn))))) (send-packet connection - #\F - `((:int32 ,fnid) - (:int16 ,(length args)) - ,@(let ((result nil)) - (loop for arg in args - do - (cond - ((integerp arg) - (push `(:int16 1) - result)) - ((stringp arg) - (push `(:int16 0) - result)) - (t (error 'protocol-error - :reason (format nil "Unknown fastpath type ~s" arg))))) - (nreverse result)) - (:int16 ,(length args)) - ,@(let ((result nil)) - (loop for arg in args - do - (cond - ((integerp arg) - (push '(:int32 4) result) - (push `(:int32 ,arg) result)) - ((stringp arg) - (push `(:int32 ,(1+ (length arg))) result) - (push `(:cstring ,arg) result)) - (t (error 'protocol-error - :reason (format nil "Unknown fastpath type ~s" arg))))) - (nreverse result)) - (:int16 ,(if integer-result 1 0)))) + #\F + `((:int32 ,fnid) + (:int16 ,(length args)) + ,@(let ((result nil)) + (loop for arg in args + do + (cond + ((integerp arg) + (push `(:int16 1) + result)) + ((stringp arg) + (push `(:int16 0) + result)) + (t (error 'protocol-error + :reason (format nil "Unknown fastpath type ~s" arg))))) + (nreverse result)) + (:int16 ,(length args)) + ,@(let ((result nil)) + (loop for arg in args + do + (cond + ((integerp arg) + (push '(:int32 4) result) + (push `(:int32 ,arg) result)) + ((stringp arg) + (push `(:int32 ,(1+ (length arg))) result) + (push `(:cstring ,arg) result)) + (t (error 'protocol-error + :reason (format nil "Unknown fastpath type ~s" arg))))) + (nreverse result)) + (:int16 ,(if integer-result 1 0)))) (%flush connection) (loop :with result = nil - :for packet = (read-packet connection) - :do - (ecase (pg-packet-type packet) - ((#\V) - (let* ((length (read-from-packet packet :int32)) - (data (unless (= length -1) - (if integer-result - (ecase length - ((1) - (read-from-packet packet :byte)) - ((2) - (read-from-packet packet :int16)) - ((4) - (read-from-packet packet :int32))) - (read-string-from-packet packet length))))) - (if data - (setf result data) - (return-from fn nil)))) - ((#\Z) - (return-from fn result)))))) + :for packet = (read-packet connection) + :do + (case (pg-packet-type packet) + ((#\V) + (let* ((length (read-from-packet packet :int32)) + (data (unless (= length -1) + (if integer-result + (ecase length + ((1) + (read-from-packet packet :byte)) + ((2) + (read-from-packet packet :int16)) + ((4) + (read-from-packet packet :int32))) + (read-string-from-packet packet length))))) + (if data + (setf result data) + (return-from fn nil)))) + ((#\Z) + (return-from fn result)) + ((#\E) + ;; an error, we should abort. + (return nil)) + ((#\N) + ;; We ignore Notices + t) + (t + (warn "Got unexpected packet: ~S, resetting connection" + packet) + ;; sync + (send-packet connection + #\S + nil) + (%flush connection)))))) @@ -722,8 +806,8 @@ (defun handle-notice/v3 (connection packet) (loop :with notification = (make-instance 'backend-notification) :for field-type = (read-from-packet packet :byte) - :until (= field-type 0) - :do (let ((message (read-from-packet packet :cstring)) + :until (= field-type 0) + :do (let ((message (read-from-packet packet :cstring)) (slot (ecase (code-char field-type) ((#\S) 'severity) ((#\C) 'code) @@ -739,5 +823,142 @@ :finally (push notification (pgcon-notices connection))) packet) + + +;; prepare/bind/execute functions + +(defmethod pg-supports-pbe ((connection pgcon-v3)) + (declare (ignore connection)) + t) + +(defmethod pg-prepare ((connection pgcon-v3) (statement-name string) (sql-statement string) &optional type-of-parameters) + (let ((types (when type-of-parameters + (loop :for type :in type-of-parameters + :for oid = (or (lookup-type type) + (error "type not found")) + :collect `(:int32 ,oid))))) + + (cond + (types + (send-packet connection + #\P + `((:cstring ,statement-name) + (:cstring ,sql-statement) + (:int16 ,(length types)) + ,@(when types + types)))) + (t + (send-packet connection + #\P + `((:cstring ,statement-name) + (:cstring ,sql-statement) + (:int16 0))))) + t)) + +(defmethod pg-bind ((connection pgcon-v3) (portal string) (statement-name string) list-of-types-and-values) + (let ((formats (when list-of-types-and-values + (loop :for (type value) :in list-of-types-and-values + :collect + (ecase type + ((:string) `(:int16 0)) + ((:byte :int16 :int32 :char) `(:int16 1)))))) + (data nil)) + + (when list-of-types-and-values + (loop :for (type value) :in list-of-types-and-values + :do + (ecase type + ((:int32) + (push '(:int32 4) data) + (push `(:int32 ,value) data)) + ((:int16) + (push '(:int32 2) data) + (push `(:int16 ,value) data)) + ((:byte) + (push '(:int32 1) data) + (push `(:int8 ,value) data)) + ((:char) + (push '(:int32 1) data) + (push `(:int8 ,(char-code value)) data)) + ((:string) + (push `(:int32 ,(1+ (length value))) data) + (push `(:cstring ,value) data)))) + + (setf data (nreverse data))) + + (cond + (list-of-types-and-values + (send-packet connection + #\B + `((:cstring ,portal) + (:cstring ,statement-name) + (:int16 ,(length formats)) + ,@formats + (:int16 ,(length formats)) + ,@data + (:int16 0)))) + (t + (send-packet connection + #\B + `((:cstring ,portal) + (:cstring ,statement-name) + (:int16 0) + (:int16 0) + (:int16 0))))) + t)) + +(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maxinum-number-of-rows 0)) + + ;; have it describe the result: + (send-packet connection + #\D + `((:char #\P) + (:cstring ,portal))) + ;; execute the query: + (send-packet connection + #\E + `((:cstring ,portal) + (:int32 ,maxinum-number-of-rows))) + ;; send all data: + (send-packet connection + #\S + nil) + (%flush connection) + + (do-followup-query connection)) + +(defun pg-close (connection name type) + (declare (type pgcon connection) + (type string name) + (type base-char type)) + + (send-packet connection + #\C + `((:char ,type) + (:cstring ,name))) + (%flush connection) + (loop :for packet = (read-packet connection) + :do + (case (pg-packet-type packet) + ((#\B #\Z) + ;; Close Complete + ;; or + ;; ReadyForQuery + (return)) + (t + (warn "Got unexpected packet: ~S, resetting connection" + packet) + ;; sync + (send-packet connection + #\S + nil) + (%flush connection)))) + t) + +(defmethod pg-close-statement ((connection pgcon-v3) (statement-name string)) + (pg-close connection statement-name #\s)) + +(defmethod pg-close-portal ((connection pgcon-v3) (portal string)) + (pg-close connection portal #\P)) ;; EOF

1 0

[pg-cvs] CVS update: pg/pg.asd
by Peter Van Eynde 06 Mar '04

06 Mar '04

Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv8996 Modified Files: pg.asd Log Message: the crypt library actually is loaded in sysdep.lisp Date: Sat Mar 6 17:59:39 2004 Author: pvaneynde Index: pg/pg.asd diff -u pg/pg.asd:1.2 pg/pg.asd:1.3 --- pg/pg.asd:1.2 Fri Mar 5 13:08:08 2004 +++ pg/pg.asd Sat Mar 6 17:59:39 2004 @@ -17,11 +17,11 @@ :author "Eric Marsden" :version "0.21" :components ((:file "defpackage") - (:file "sysdep" :depends-on ("defpackage")) + (:pg-component "sysdep" :depends-on ("defpackage")) (:file "meta-queries" :depends-on ("defpackage")) (:file "parsers" :depends-on ("defpackage")) (:file "utility" :depends-on ("defpackage")) - (:pg-component "pg" :depends-on ("sysdep" "parsers")) + (:file "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"))))

1 0

[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
by Eric Marsden 05 Mar '04

05 Mar '04

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

1 0

[pg-cvs] CVS update: Module imported: pg
by Eric Marsden 03 Mar '04

03 Mar '04

Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv9233 Log Message: initial import Status: Vendor Tag: clnet Release Tags: start N pg/pg.lisp N pg/README N pg/pg-tests.lisp N pg/defpackage.lisp N pg/pg.asd N pg/sysdep.lisp N pg/NEWS N pg/cmucl-install-subsystem.lisp No conflicts created by this import Date: Wed Mar 3 08:11:50 2004 Author: emarsden New module pg added

1 0