[pg-cvs] CVS update: pg/lowlevel.lisp pg/sysdep.lisp pg/v2-protocol.lisp pg/v3-protocol.lisp
Eric Marsden
emarsden at common-lisp.net
Mon Mar 8 18:12:46 UTC 2004
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 at 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
More information about the Pg-cvs
mailing list