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@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@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.