Update of /project/pg/cvsroot/pg In directory common-lisp.net:/tmp/cvs-serv30232
Modified Files: lowlevel.lisp sysdep.lisp v2-protocol.lisp v3-protocol.lisp Log Message: - improvements to the system-dependent functionality: OpenMCL is able to use a local connection to the backend; most implementations resignal connection errors as a postgres-error.
- fixes to the lowlevel code
Date: Mon Mar 8 13:12:45 2004 Author: emarsden
Index: pg/lowlevel.lisp diff -u pg/lowlevel.lisp:1.2 pg/lowlevel.lisp:1.3 --- pg/lowlevel.lisp:1.2 Mon Mar 8 11:45:16 2004 +++ pg/lowlevel.lisp Mon Mar 8 13:12:45 2004 @@ -52,6 +52,7 @@ (defun %read-bytes (stream howmany) "Reads HOWMANY bytes from the STREAM. Returns the array of " + (declare (type stream stream)) (let ((v (make-array howmany :element-type '(unsigned-byte 8)))) (read-sequence v stream) v)) @@ -65,6 +66,7 @@ (defun %read-bytes (stream howmany) "Reads HOWMANY bytes from the STREAM. Returns the array of " + (declare (type stream stream)) (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))) @@ -72,19 +74,18 @@ ) v))
-(defun %read-chars (connection howmany) +(defun %read-chars (stream howmany) (declare (type fixnum howmany)) - (let ((bytes (%read-bytes connection howmany)) + (let ((bytes (%read-bytes stream howmany)) (str (make-string howmany))) (dotimes (i howmany) (setf (aref str i) (code-char (aref bytes i)))) str))
-(defun %read-cstring (connection maxbytes) +(defun %read-cstring (stream maxbytes) "Read a null-terminated string from CONNECTION." (declare (type fixnum maxbytes)) - (let ((stream (pgcon-stream connection)) - (chars nil)) + (let ((chars nil)) (do ((b (read-byte stream nil nil) (read-byte stream nil nil)) (i 0 (+ i 1))) ((or (= i maxbytes) ; reached allowed length
Index: pg/sysdep.lisp diff -u pg/sysdep.lisp:1.2 pg/sysdep.lisp:1.3 --- pg/sysdep.lisp:1.2 Fri Mar 5 13:08:08 2004 +++ pg/sysdep.lisp Mon Mar 8 13:12:45 2004 @@ -1,7 +1,7 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden emarsden@laas.fr -;;; Time-stamp: <2004-03-05 emarsden> +;;; Time-stamp: <2004-03-08 emarsden> ;; ;;
@@ -159,7 +159,7 @@ :remote-port port :format :binary) (error (e) - (signal 'connection-failure + (error 'connection-failure :host host :port port :transport-error e)))) @@ -169,9 +169,15 @@ #+lispworks (defun socket-connect (port host) (declare (type integer port)) - (comm:open-tcp-stream host port - :element-type '(unsigned-byte 8) - :direction :io)) + (handler-case + (comm:open-tcp-stream host port + :element-type '(unsigned-byte 8) + :direction :io) + (error (e) + (error 'connection-failure + :host host + :port port + :transport-error e))))
;; this doesn't work, since the Corman sockets module doesn't support ;; binary I/O on socket streams. @@ -184,18 +190,32 @@ (let ((sock (sockets:make-client-socket :host host :port port))) (sockets:make-socket-stream sock))) (error (e) - (declare (ignore e)) - (error 'connection-failure :host host :port port)))) + (error 'connection-failure + :host host + :port port + :transport-error e))))
#+openmcl (defun socket-connect (port host) (declare (type integer port)) - (let ((sock (make-socket :type :stream - :connect :active - :format :binary - :remote-host host - :remote-port port))) - sock)) + (handler-case + (if host + (make-socket :address-family :internet + :type :stream + :connect :active + :format :binary + :remote-host host + :remote-port port) + (make-socket :address-family :file + :type :stream + :connect :active + :format :binary + :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port))) + (error (e) + (error 'connection-failure + :host host + :port port + :transport-error e))))
;; from John DeSoi #+(and mcl (not openmcl)) @@ -226,27 +246,13 @@ #+ecl (defun socket-connect (port host) (declare (type integer port)) - (si:open-client-stream host port)) - -;; #+ecl -;; (defun write-sequence (seq stream &key start end) -;; (declare (ignore start end)) -;; (loop :for element :across seq -;; :do (write-byte element stream))) -;; -;; #+ecl -;; (defun read-bytes (connection howmany) -;; (let ((v (make-array howmany :element-type '(unsigned-byte 8))) -;; (s (pgcon-stream connection))) -;; (loop :for pos :below howmany -;; :do (setf (aref v pos) (read-byte s))) -;; v)) -;; -;; #+ecl -;; (defun cl:read-sequence (seq stream &key (start 0) (end (length seq))) -;; (loop :for pos :from start :below end -;; :do (setf (aref seq pos) (read-byte stream)))) - + (handler-case + (si:open-client-stream host port) + (error (e) + (error 'connection-failure + :host host + :port port + :transport-error e))))
@@ -261,25 +267,13 @@ #+armedbear (defun socket-connect (port host) (declare (type integer port)) - (ext:make-binary-socket host port)) - -#+armedbear -(defun cl:write-sequence (seq stream &key (start 0) (end (length seq))) - (declare (ignore start end)) - (loop :for element :across seq - :do (write-byte element stream))) - -#+armedbear -(defun read-bytes (connection howmany) - (let ((v (make-array howmany :element-type '(unsigned-byte 8))) - (s (pgcon-stream connection))) - (loop :for pos :below howmany - :do (setf (aref v pos) (read-byte s))) - v)) + (handler-case + (ext:make-binary-socket host port) + (error (e) + (error 'connection-failure + :host host + :port port + :transport-error e))))
-#+armedbear -(defun cl:read-sequence (seq stream &key (start 0) (end (length seq))) - (loop :for pos :from start :below end - :do (setf (aref seq pos) (read-byte stream))))
;; EOF
Index: pg/v2-protocol.lisp diff -u pg/v2-protocol.lisp:1.2 pg/v2-protocol.lisp:1.3 --- pg/v2-protocol.lisp:1.2 Mon Mar 8 10:01:53 2004 +++ pg/v2-protocol.lisp Mon Mar 8 13:12:45 2004 @@ -34,7 +34,7 @@ ((69) (close stream) (error 'authentication-failure - :reason (%read-cstring connection 4096))) + :reason (%read-cstring stream 4096)))
;; Authentication ((82) @@ -54,7 +54,7 @@ (send-int connection 0 1) (%flush connection)) ((4) ; AuthEncryptedPassword - (let* ((salt (%read-chars connection 2)) + (let* ((salt (%read-chars stream 2)) (crypted (crypt password salt))) #+debug (format *debug-io* "Got salt of ~s~%" salt) @@ -109,7 +109,7 @@
;; CompletedResponse, #\C ((67) - (let ((status (%read-cstring connection +MAX_MESSAGE_LEN+))) + (let ((status (%read-cstring stream +MAX_MESSAGE_LEN+))) (setf (pgresult-status result) status) (setf (pgresult-tuples result) (nreverse tuples)) (setf (pgresult-attributes result) attributes) @@ -124,7 +124,7 @@
;; ErrorResponse, #\E ((69) - (let ((msg (%read-cstring connection +MAX_MESSAGE_LEN+))) + (let ((msg (%read-cstring stream +MAX_MESSAGE_LEN+))) (error 'backend-error :reason msg)))
;; #\G and #\H: start copy in, start copy out @@ -147,7 +147,7 @@
;; CursorResponse, #\P ((80) - (let ((str (%read-cstring connection +MAX_MESSAGE_LEN+))) + (let ((str (%read-cstring stream +MAX_MESSAGE_LEN+))) (declare (ignore str)) ;; (format *debug-io* "Portal name ~a~%" str) )) @@ -204,13 +204,13 @@ (let ((len (read-net-int connection 4))) (if integer-result (setq result (read-net-int connection len)) - (setq result (%read-chars connection len))))) + (setq result (%read-chars (pgcon-stream 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))) + ((69) (error 'backend-error :reason (%read-cstring (pgcon-stream connection) 4096)))
;; NoticeResponse ((78) @@ -240,7 +240,7 @@ (attributes '())) (do ((i attribute-count (- i 1))) ((zerop i) (nreverse attributes)) - (let ((type-name (%read-cstring connection +MAX_MESSAGE_LEN+)) + (let ((type-name (%read-cstring (pgcon-stream 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 !! @@ -266,7 +266,7 @@ (defun read-tuple/v2 (connection attributes) (let* ((num-attributes (length attributes)) (num-bytes (ceiling (/ num-attributes 8))) - (bitmap (%read-bytes connection num-bytes)) + (bitmap (%read-bytes (pgcon-stream connection) num-bytes)) (correction (if (pgcon-binary-p connection) 0 -4)) (tuples '())) (do ((i 0 (+ i 1)) @@ -276,13 +276,13 @@ (push nil tuples)) (t (let* ((len (+ (read-net-int connection 4) correction)) - (raw (%read-chars connection (max 0 len))) + (raw (%read-chars (pgcon-stream 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+) + (push (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+) (pgcon-notices connection)))
Index: pg/v3-protocol.lisp diff -u pg/v3-protocol.lisp:1.4 pg/v3-protocol.lisp:1.5 --- pg/v3-protocol.lisp:1.4 Mon Mar 8 11:45:16 2004 +++ pg/v3-protocol.lisp Mon Mar 8 13:12:45 2004 @@ -71,7 +71,7 @@ :type base-char :reader pg-packet-type) (length :initarg :length - :type (integer 32)) + :type (unsigned-byte 32)) (data :initarg :data :type (array (unsigned-byte 8) *)) (position :initform 0