[pg-cvs] CVS update: pg/stone-age-load.lisp pg/parsers.lisp pg/pg-tests.lisp pg/pg.asd pg/sysdep.lisp pg/v3-protocol.lisp
Eric Marsden
emarsden at common-lisp.net
Wed Aug 11 13:27:49 UTC 2004
Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv17889
Modified Files:
parsers.lisp pg-tests.lisp pg.asd sysdep.lisp v3-protocol.lisp
Added Files:
stone-age-load.lisp
Log Message:
add a file that does a manual load of pg
Date: Wed Aug 11 06:27:48 2004
Author: emarsden
Index: pg/parsers.lisp
diff -u pg/parsers.lisp:1.3 pg/parsers.lisp:1.4
--- pg/parsers.lisp:1.3 Wed Apr 21 12:23:18 2004
+++ pg/parsers.lisp Wed Aug 11 06:27:48 2004
@@ -82,7 +82,7 @@
("money" . ,'text-parser) ; "$12.34"
("abstime" . ,'timestamp-parser)
("date" . ,'date-parser)
- ("timestamp" . ,'timestamp-parser)
+ ("timestamp" . ,'timestamp-parser) ; or 'precise-timestamp-parser if you want milliseconds
("timestamptz" . ,'timestamp-parser)
("datetime" . ,'timestamp-parser)
("time" . ,'text-parser) ; preparsed "15:32:45"
Index: pg/pg-tests.lisp
diff -u pg/pg-tests.lisp:1.6 pg/pg-tests.lisp:1.7
--- pg/pg-tests.lisp:1.6 Sat Mar 20 13:48:41 2004
+++ pg/pg-tests.lisp Wed Aug 11 06:27:48 2004
@@ -1,8 +1,6 @@
;;; pg-tests.lisp -- incomplete test suite
;;;
;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-03-08 emarsden>
-;;
;;
;;
;; These tests assume that a table named "test" is defined in the
@@ -17,7 +15,7 @@
;; !!! CHANGE THE VALUES HERE !!!
(defun call-with-test-connection (function)
- (with-pg-connection (conn "template1" "emarsden" :host nil :port 5432)
+ (with-pg-connection (conn "test" "pgdotlisp" :host "melbourne" :port 5433 :password "lisp")
(funcall function conn)))
(defmacro with-test-connection ((conn) &body body)
@@ -348,31 +346,32 @@
(pg-exec conn "DROP TABLE foo")))
(defun test ()
- (with-test-connection (conn)
- (format t "Running pg.lisp tests against backend ~a~%" (pg-backend-version conn))
- ;; client encoding supported since PostgreSQL v7.1
- (format t "Client encoding is ~A~%" (pg-client-encoding conn))
- (format t "Date style is ~A~%" (pg-date-style conn))
- (let ((r2 (pg-exec conn "CREATE TABLE pgltest (a int, b float, c money)"))
- (r3 (pg-exec conn "INSERT INTO pgltest VALUES (3, -1234.5e67, '$123.45')"))
- (r4 (pg-exec conn "DROP TABLE pgltest")))
- (format t "~%==============================================~%")
- (format t "status of CREATE is ~s~%" (pg-result r2 :status))
- (format t "status of INSERT is ~s~%" (pg-result r3 :status))
- (format t "oid of INSERT is ~s~%" (pg-result r3 :oid))
- (format t "status of DROP is ~s~%" (pg-result r4 :status))
- (format t "==============================================~%")))
- (test-simple)
- (test-insert)
- (test-insert/float)
- (test-date)
- (test-booleans)
- (test-integrity)
- (test-notifications)
- (test-lo)
- (test-lo-read)
- #+cmu (test-lo-import)
- (test-pbe))
+ (let ((*pg-client-encoding* "UNICODE"))
+ (with-test-connection (conn)
+ (format t "Running pg.lisp tests against backend ~a~%" (pg-backend-version conn))
+ ;; client encoding supported since PostgreSQL v7.1
+ (format t "Client encoding is ~A~%" (pg-client-encoding conn))
+ (format t "Date style is ~A~%" (pg-date-style conn))
+ (let ((r2 (pg-exec conn "CREATE TABLE pgltest (a int, b float, c money)"))
+ (r3 (pg-exec conn "INSERT INTO pgltest VALUES (3, -1234.5e67, '$123.45')"))
+ (r4 (pg-exec conn "DROP TABLE pgltest")))
+ (format t "~%==============================================~%")
+ (format t "status of CREATE is ~s~%" (pg-result r2 :status))
+ (format t "status of INSERT is ~s~%" (pg-result r3 :status))
+ (format t "oid of INSERT is ~s~%" (pg-result r3 :oid))
+ (format t "status of DROP is ~s~%" (pg-result r4 :status))
+ (format t "==============================================~%")))
+ (test-simple)
+ (test-insert)
+ (test-insert/float)
+ (test-date)
+ (test-booleans)
+ (test-integrity)
+ (test-notifications)
+ (test-lo)
+ (test-lo-read)
+ #+cmu (test-lo-import)
+ (test-pbe)))
;; EOF
Index: pg/pg.asd
diff -u pg/pg.asd:1.5 pg/pg.asd:1.6
--- pg/pg.asd:1.5 Thu Apr 1 10:35:19 2004
+++ pg/pg.asd Wed Aug 11 06:27:48 2004
@@ -10,7 +10,7 @@
#+cmu
(defmethod perform :before ((o load-op) (c pg-component))
- (ext:load-foreign "/usr/lib/libcrypt.a"))
+ (ext:load-foreign "/usr/lib/libcrypt.so"))
(defsystem :pg
:name "Socket-level PostgreSQL interface"
Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.5 pg/sysdep.lisp:1.6
--- pg/sysdep.lisp:1.5 Thu Apr 1 10:35:19 2004
+++ pg/sysdep.lisp Wed Aug 11 06:27:48 2004
@@ -1,7 +1,7 @@
;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
;;;
;;; Author: Eric Marsden <emarsden at laas.fr>
-;;; Time-stamp: <2004-04-01 emarsden>
+;;; Time-stamp: <2004-04-23 emarsden>
;;
;;
@@ -15,6 +15,13 @@
#+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
+
+(defmacro %sysdep (desc &rest forms)
+ (when (null forms)
+ (error "No system dependent code to ~A" desc))
+ (car forms))
+
+
#+(and cmu glibc2)
(eval-when (:compile-toplevel :load-toplevel)
(format t ";; Loading libcrypt~%")
@@ -292,6 +299,37 @@
:host host
:port port
:transport-error e))))
+
+
+
+;;; character encoding support
+
+(defvar *pg-client-encoding*)
+
+(defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
+ (declare (type string string))
+ (%sysdep "convert string to bytes"
+ #+(and clisp unicode)
+ (ext:convert-string-to-bytes string encoding)
+ #+(and acl ics)
+ (excl:string-to-octets string :external-format encoding)
+ #+(or cmu sbcl gcl ecl)
+ (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
+ (map-into octets #'char-code string))))
+
+(defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
+ (declare (type (vector (unsigned-byte 8)) bytes))
+ (%sysdep "convert octet-array to string"
+ #+(and clisp unicode)
+ (ext:convert-string-from-bytes bytes encoding)
+ #+(and acl ics)
+ (ext:octets-to-string bytes :external-format encoding)
+ ;; for implementations that have no support for character
+ ;; encoding, we assume that the encoding is an octet-for-octet
+ ;; encoding, and convert directly
+ #+(or cmu sbcl gcl ecl)
+ (let ((string (make-string (length bytes))))
+ (map-into string #'code-char bytes))))
;; EOF
Index: pg/v3-protocol.lisp
diff -u pg/v3-protocol.lisp:1.11 pg/v3-protocol.lisp:1.12
--- pg/v3-protocol.lisp:1.11 Thu Apr 22 10:00:12 2004
+++ pg/v3-protocol.lisp Wed Aug 11 06:27:48 2004
@@ -7,6 +7,8 @@
(defclass pgcon-v3 (pgcon)
((parameters :accessor pgcon-parameters
:initform (list))
+ (encoding :accessor pgcon-encoding
+ :initform nil)
(sql-stream :initform nil
:accessor pgcon-sql-stream
:type (or null stream))))
@@ -77,7 +79,9 @@
(data :initarg :data
:type (array (unsigned-byte 8) *))
(position :initform 0
- :type integer)))
+ :type integer)
+ (connection :initarg :connection
+ :type pgcon-v3)))
(defmethod print-object ((object pg-packet) stream)
(print-unreadable-object (object stream :type t :identity t)
@@ -159,7 +163,8 @@
(packet (make-instance 'pg-packet
:type (code-char type)
:length length
- :data data)))
+ :data data
+ :connection connection)))
(case (pg-packet-type packet)
(( #\E) ; error
(read-and-generate-error-response packet)
@@ -224,16 +229,14 @@
(1+ (logxor result
#xFFFFFFFF)))))
result)))
- (:method ((packet pg-packet) (type (eql :cstring)))
- (with-slots (data position)
- packet
+ ;; a string that does not get encoded
+ (:method ((packet pg-packet) (type (eql :ucstring)))
+ (with-slots (data position) packet
(let* ((end (position 0 data :start position))
- ;; end is where the 0 byte is
- (result (unless (= end position)
+ (result (unless (eql end position)
(make-array (- end position)
:element-type 'base-char))))
- ;; FIXME need to handle charset encoding issues here
(when result
(loop :for i :from position :below end
:for j :from 0
@@ -242,7 +245,22 @@
(code-char
(elt data i))))
(setf position (1+ end))
- result)))))
+ result))))
+
+ ;; a string that does get encoded, if the current connection has set
+ ;; its prefered encoding
+ (:method ((packet pg-packet) (type (eql :cstring)))
+ (with-slots (data position connection) packet
+ (cond ((pgcon-encoding connection)
+ (let* ((end (position 0 data :start position))
+ (result (unless (eql end position)
+ (convert-string-from-bytes (subseq data position end)))))
+ (when result (setf position (1+ end)))
+ result))
+ ;; the encoding has not yet been set, so revert to :ucstring behaviour
+ (t
+ (read-from-packet packet :ucstring))))))
+
;; FIXME need to check all callers of this function to distinguish
;; between uses that expect charset encoding to be handled, and those
@@ -287,10 +305,8 @@
((:byte :char) 1)
((:int16) 2)
((:int32) 4)
- ((:cstring
- :rawdata)
- (+ 1
- (length value)))))))
+ ((:cstring) (1+ (length (convert-string-to-bytes value))))
+ ((:ucstring :rawdata) (1+ (length value)))))))
(data (make-array (- length 4)
:element-type '(unsigned-byte 8)))
(stream (pgcon-stream connection)))
@@ -320,12 +336,9 @@
(setf (elt data (+ 2 position)) (ldb (byte 8 8) value))
(setf (elt data (+ 3 position)) (ldb (byte 8 0) value))
(incf position 4))
- ;; FIXME need to deal with text encoding issues here:
- ;; transform from the Lisp string representation to the
- ;; encoding selected by *PG-CLIENT-ENCODING*.
- ((:cstring)
- (check-type value string)
+ ((:ucstring)
+ (check-type value string)
(loop for char across value
do
(setf (elt data position)
@@ -333,9 +346,17 @@
(incf position))
(setf (elt data position) 0)
(incf position))
+
+ ((:cstring)
+ (check-type value string)
+ (let ((encoded (convert-string-to-bytes value)))
+ (replace data encoded :start1 position)
+ (incf position (length encoded)))
+ (setf (elt data position) 0)
+ (incf position))
+
((:rawdata)
(check-type value (array (unsigned-byte 8) *))
-
(replace data value :start1 position)
(incf position (length value)))))
@@ -392,14 +413,14 @@
(error 'authentication-failure
:reason "Kerberos5 authentication not supported"))
((3) ; AuthUnencryptedPassword
- (send-packet connection #\p `((:cstring ,password)))
+ (send-packet connection #\p `((:ucstring ,password)))
(%flush connection))
((4) ; AuthEncryptedPassword
(let* ((salt (read-string-from-packet packet 2))
(crypted (crypt password salt)))
#+debug
(format *debug-io* "CryptAuth: Got salt of ~s~%" salt)
- (send-packet connection #\p `((:cstring ,crypted)))
+ (send-packet connection #\p `((:ucstring ,crypted)))
(%flush connection)))
((5) ; AuthMD5Password
#+debug
@@ -407,7 +428,7 @@
(force-output *debug-io*)
(let* ((salt (read-string-from-packet packet 4))
(ciphered (md5-encode-password user password salt)))
- (send-packet connection #\p `((:cstring ,ciphered)))
+ (send-packet connection #\p `((:ucstring ,ciphered)))
(%flush connection)))
((6) ; AuthSCMPassword
(error 'authentication-failure
@@ -425,8 +446,8 @@
(setf (pgcon-secret connection) secret)))
(( #\S)
;; Status
- (let* ((parameter (read-from-packet packet :cstring))
- (value (read-from-packet packet :cstring)))
+ (let* ((parameter (read-from-packet packet :ucstring))
+ (value (read-from-packet packet :ucstring)))
(push (cons parameter value) (pgcon-parameters connection))))
((#\Z)
;; Ready for Query
@@ -435,14 +456,14 @@
(char-code #\I))
(warn "~&Got status ~S but wanted I~%"
(code-char status)))
-
+
+ (when *pg-client-encoding*
+ (setf (pg-client-encoding connection) *pg-client-encoding*))
(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.
More information about the Pg-cvs
mailing list