[pg-devel] [PATCH] CLSQL support, more encodings, float parser, etc
Vladimir Sekissov
svg at surnet.ru
Thu Nov 23 14:00:40 UTC 2006
Good day,
The patch in the attachment contains some changes to Pg you could find
useful:
- "hand-made" float parser;
- support most PostgreSQL client encodings on unicode platforms;
- allow any PostgreSQL unibyte client encoding on 8-bit platforms;
- use CFFI interface to "crypt";
- preliminary CLSQL support. All CLSQL tests are passed
except one because driver currently supports only two types of result
type conversions - nil and :auto.
Patch was tested on CMUCL-19c and SBCL-0.9.18 (unicode and 8-bit).
Best Regards,
Vladimir Sekissov
-------------- next part --------------
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/clsql/clsql-postgresql-pg.asd pg/clsql/clsql-postgresql-pg.asd
--- pg.orig/clsql/clsql-postgresql-pg.asd 1970-01-01 05:00:00.000000000 +0500
+++ pg/clsql/clsql-postgresql-pg.asd 2006-11-23 15:54:57.000000000 +0500
@@ -0,0 +1,22 @@
+;;;; clsql-postgresql-pg.lisp -- Pg support for CLSQL
+;;;; Authors: Vladimir Sekissov <svg at surnet.ru>
+;;;; $Id$
+;;;;
+
+(defpackage #:clsql-postgresql-pg-system (:use #:asdf #:cl))
+(in-package #:clsql-postgresql-pg-system)
+
+;;; System definition
+
+(defsystem clsql-postgresql-pg
+ :name "cl-sql-postgresql-pg"
+ :author "Vladimir Sekissov <svg at surnet.ru>"
+ :licence "Lessor Lisp General Public License"
+ :description "Common Lisp SQL PostgreSQL Socket Driver"
+ :depends-on (:clsql :pg)
+ :components
+ ((:file "postgresql-pg-package")
+ (:file "postgresql-pg-api")
+ (:file "postgresql-pg-sql")
+ (:file "postgresql-pg-objects"))
+ :serial t)
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/clsql/postgresql-pg-api.lisp pg/clsql/postgresql-pg-api.lisp
--- pg.orig/clsql/postgresql-pg-api.lisp 1970-01-01 05:00:00.000000000 +0500
+++ pg/clsql/postgresql-pg-api.lisp 2006-11-23 15:18:07.000000000 +0500
@@ -0,0 +1,32 @@
+;;;; postgresql-pg-api.lisp -- Pg support for CLSQL
+;;;; Authors: Vladimir Sekissov <svg at surnet.ru>
+;;;; $Id$
+;;;;
+
+(in-package #:postgresql-pg)
+
+(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :postgresql-pg)))
+ "T if foreign library was able to be loaded successfully. Always true for
+socket interface"
+ t)
+
+(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-pg)))
+ t)
+
+(defconstant +postgresql-server-default-port+ 5432
+ "Default port of PostgreSQL server.")
+
+;; TODO - add encoding argument
+(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
+ (port +postgresql-server-default-port+)
+ (database (cmucl-compat:required-argument))
+ (user (cmucl-compat:required-argument))
+ password)
+ (pg:pg-connect database user
+ :host host
+ :port port
+ :password (or password "")))
+
+
+(defun close-postgresql-connection (connection)
+ (pg:pg-disconnect connection))
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/clsql/postgresql-pg-objects.lisp pg/clsql/postgresql-pg-objects.lisp
--- pg.orig/clsql/postgresql-pg-objects.lisp 1970-01-01 05:00:00.000000000 +0500
+++ pg/clsql/postgresql-pg-objects.lisp 2006-11-23 15:16:58.000000000 +0500
@@ -0,0 +1,24 @@
+;;;; postgresql-pg-objects.lisp -- Pg support for CLSQL
+;;;; Authors: Vladimir Sekissov <svg at surnet.ru>
+;;;; $Id$
+;;;;
+
+(in-package #:clsql-sys)
+
+(defmethod read-sql-value (val (type (eql 'boolean)) (database clsql-postgresql-pg:postgresql-pg-database) db-type)
+ (declare (ignore db-type))
+ (typecase val
+ (string (call-next-method))
+ (t val)))
+
+(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database clsql-postgresql-pg:postgresql-pg-database) db-type)
+ (declare (ignore db-type))
+ (typecase val
+ (string (call-next-method))
+ (t val)))
+
+(defmethod read-sql-value (val (type (eql 'wall-time)) (database clsql-postgresql-pg:postgresql-pg-database) db-type)
+ (declare (ignore db-type))
+ (typecase val
+ (integer (clsql:utime->time val))
+ (t (call-next-method))))
\ ? ????? ????? ??? ????? ??????
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/clsql/postgresql-pg-package.lisp pg/clsql/postgresql-pg-package.lisp
--- pg.orig/clsql/postgresql-pg-package.lisp 1970-01-01 05:00:00.000000000 +0500
+++ pg/clsql/postgresql-pg-package.lisp 2006-11-23 15:17:29.000000000 +0500
@@ -0,0 +1,13 @@
+;;;; postgresql-pg-package.lisp -- Pg support for CLSQL
+;;;; Authors: Vladimir Sekissov <svg at surnet.ru>
+;;;; $Id$
+;;;;
+
+(in-package #:cl-user)
+
+(defpackage #:postgresql-pg
+ (:use #:cl #:pg)
+ (:export #:+postgresql-server-default-port+
+ #:open-postgresql-connection
+ #:close-postgresql-connection))
+
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/clsql/postgresql-pg-sql.lisp pg/clsql/postgresql-pg-sql.lisp
--- pg.orig/clsql/postgresql-pg-sql.lisp 1970-01-01 05:00:00.000000000 +0500
+++ pg/clsql/postgresql-pg-sql.lisp 2006-11-23 15:17:58.000000000 +0500
@@ -0,0 +1,192 @@
+;;;; postgresql-pg-sql.lisp -- Pg support for CLSQL
+;;;; Authors: Vladimir Sekissov <svg at surnet.ru>
+;;;; $Id$
+;;;;
+
+(in-package #:cl-user)
+
+(defpackage :clsql-postgresql-pg
+ (:use #:common-lisp #:clsql-sys #:postgresql-pg)
+ (:export #:postgresql-pg-database)
+ (:documentation "This is the CLSQL socket interface to PostgreSQL."))
+
+(in-package #:clsql-postgresql-pg)
+
+;; interface foreign library loading routines
+
+(clsql-sys:database-type-load-foreign :postgresql-pg)
+
+(defun convert-to-clsql-error (database expression condition)
+ (error 'sql-database-data-error
+ :database database
+ :expression expression
+ :error-id (type-of condition)
+ :message (format nil "~a" condition)))
+
+(defmacro with-postgresql-handlers
+ ((database &optional expression)
+ &body body)
+ (let ((database-var (gensym))
+ (expression-var (gensym)))
+ `(let ((,database-var ,database)
+ (,expression-var ,expression))
+ (handler-bind ((pg:postgresql-error
+ (lambda (c)
+ (convert-to-clsql-error
+ ,database-var ,expression-var c))))
+ , at body))))
+
+(defmethod database-initialize-database-type ((database-type
+ (eql :postgresql-pg)))
+ t)
+
+(defclass postgresql-pg-database (generic-postgresql-database)
+ ((connection :accessor database-connection
+ :initarg :connection
+ :type pg::pgcon)))
+
+(defmethod database-type ((database postgresql-pg-database))
+ :postgresql-pg)
+
+(defmethod database-name-from-spec (connection-spec
+ (database-type (eql :postgresql-pg)))
+ (check-connection-spec connection-spec database-type
+ (host db user password &optional port options tty))
+ (destructuring-bind (host db user password &optional port options tty)
+ connection-spec
+ (declare (ignore password options tty))
+ (concatenate 'string
+ (etypecase host
+ (null
+ "localhost")
+ (pathname (namestring host))
+ (string host))
+ (when port
+ (concatenate 'string
+ ":"
+ (etypecase port
+ (integer (write-to-string port))
+ (string port))))
+ "/" db "/" user)))
+
+(defmethod database-connect (connection-spec
+ (database-type (eql :postgresql-pg)))
+ (check-connection-spec connection-spec database-type
+ (host db user password &optional port))
+ (destructuring-bind (host db user password &optional
+ (port +postgresql-server-default-port+))
+ connection-spec
+ (handler-case
+ (handler-bind ((warning
+ (lambda (c)
+ (warn 'sql-warning
+ :format-control "~A"
+ :format-arguments
+ (list (princ-to-string c))))))
+ (open-postgresql-connection :host host :port port
+ :database db :user user
+ :password password))
+ (pg:postgresql-error (c)
+ ;; Connect failed
+ (error 'sql-connection-error
+ :database-type database-type
+ :connection-spec connection-spec
+ :error-id (type-of c)
+ :message (format nil "~a" c)))
+ (:no-error (connection)
+ ;; Success, make instance
+ (make-instance 'postgresql-pg-database
+ :name (database-name-from-spec connection-spec
+ database-type)
+ :database-type :postgresql-pg
+ :connection-spec connection-spec
+ :connection connection)))))
+
+(defmethod database-disconnect ((database postgresql-pg-database))
+ (close-postgresql-connection (database-connection database))
+ t)
+
+(defmethod database-query (expression (database postgresql-pg-database) result-types field-names)
+ (let ((connection (database-connection database)))
+ (with-postgresql-handlers (database expression)
+ (let* ((pg:*pg-coerce-result-types* result-types)
+ (result (pg:pg-exec connection (string expression))))
+ (values (pg:pg-result result :tuples)
+ (when field-names
+ (mapcar #'car (pg:pg-result result :attributes))))))))
+
+(defmethod database-execute-command (expression (database postgresql-pg-database))
+ (let ((connection (database-connection database)))
+ (with-postgresql-handlers (database expression)
+ (pg:pg-exec connection (string expression)))))
+
+(defstruct postgresql-pg-result-set
+ (tuples nil))
+
+(defmethod database-query-result-set ((expression string)
+ (database postgresql-pg-database)
+ &key full-set result-types)
+ (declare (ignore full-set))
+ (let ((connection (database-connection database)))
+ (with-postgresql-handlers (database expression)
+ (let* ((pg:*pg-coerce-result-types* result-types)
+ (result (pg:pg-exec connection (string expression))))
+ (values (make-postgresql-pg-result-set :tuples (pg:pg-result result :tuples))
+ (length (pg:pg-result result :attributes)))))))
+
+(defmethod database-dump-result-set (result-set
+ (database postgresql-pg-database))
+ (declare (ignore result-set database))
+ t)
+
+(defmethod database-store-next-row (result-set
+ (database postgresql-pg-database)
+ list)
+ (with-postgresql-handlers (database)
+ (when (postgresql-pg-result-set-tuples result-set)
+ (loop
+ with row = (pop (postgresql-pg-result-set-tuples result-set))
+ for rest on list
+ do
+ (setf (car rest) (pop row)))
+ list)))
+
+(defmethod database-create (connection-spec (type (eql :postgresql-pg)))
+ (destructuring-bind (host name user password) connection-spec
+ (let ((database (database-connect (list host "template1" user password)
+ type)))
+ (unwind-protect
+ (execute-command (format nil "create database ~A" name))
+ (database-disconnect database)))))
+
+(defmethod database-destroy (connection-spec (type (eql :postgresql-pg)))
+ (destructuring-bind (host name user password) connection-spec
+ (let ((database (database-connect (list host "template1" user password)
+ type)))
+ (unwind-protect
+ (execute-command (format nil "drop database ~A" name))
+ (database-disconnect database)))))
+
+
+(defmethod database-probe (connection-spec (type (eql :postgresql-pg)))
+ (when (find (second connection-spec) (database-list connection-spec type)
+ :test #'string-equal)
+ t))
+
+
+;; Database capabilities
+
+(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-pg)))
+ nil)
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-pg)))
+ t)
+
+(defmethod db-type-default-case ((db-type (eql :postgresql-pg)))
+ :lower)
+
+(defmethod database-underlying-type ((database postgresql-pg-database))
+ :postgresql)
+
+(when (clsql-sys:database-type-library-loaded :postgresql-pg)
+ (clsql-sys:initialize-database-type :database-type :postgresql-pg))
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/defpackage.lisp pg/defpackage.lisp
--- pg.orig/defpackage.lisp 2005-07-17 21:44:48.000000000 +0600
+++ pg/defpackage.lisp 2006-11-22 17:00:37.000000000 +0500
@@ -9,6 +9,7 @@
(:export #:pg-connect #:pg-exec #:pg-result #:pg-disconnect
#:pgcon-sql-stream
#:*pg-disable-type-coercion*
+ #:*pg-coerce-result-types*
#:*pg-client-encoding*
#:pg-databases #:pg-tables #:pg-columns
#:pg-backend-version
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/parsers.lisp pg/parsers.lisp
--- pg.orig/parsers.lisp 2006-10-23 01:29:47.000000000 +0600
+++ pg/parsers.lisp 2006-11-23 14:44:23.000000000 +0500
@@ -135,11 +135,58 @@
(setq decimal-part (/ (parse-integer decimal-str) (expt 10 dec-str-len))))))
(+ integer-part decimal-part)))
-;; FIXME switch to a specialized float parser that conses less
(defun float-parser (str)
(declare (type simple-string str))
- (let ((*read-eval* nil))
- (read-from-string str)))
+
+ (let ((idx 0)
+ (str-len (length str)))
+ (labels ((nxt-char ()
+ (when (< idx str-len)
+ (prog1 (char str idx)
+ (incf idx))))
+ (cur-char ()
+ (when (< idx str-len)
+ (char str idx)))
+ (read-integer ()
+ (multiple-value-bind (int int-idx)
+ (parse-integer str :start idx :junk-allowed t)
+ (multiple-value-prog1 (values int (- int-idx idx))
+ (setf idx int-idx))))
+ (read-sign ()
+ (case (cur-char)
+ (#\- (nxt-char)
+ -1)
+ (#\+ (nxt-char)
+ 1)
+ (otherwise 1)))
+ (read-fractional-part ()
+ (case (cur-char)
+ (#\. (nxt-char)
+ (multiple-value-bind (int count)
+ (read-integer)
+ (when int
+ (* int (expt 10 (- count))))))
+ (otherwise nil)))
+ (read-exponent ()
+ (case (cur-char)
+ ((#\e #\E) (nxt-char)
+ (read-integer))
+ (otherwise 0))))
+ (let ((sign (read-sign))
+ (int-part (read-integer))
+ (fractional-part (read-fractional-part))
+ (exponent (read-exponent)))
+
+ (unless (and (or int-part fractional-part)
+ (= idx str-len))
+ (error "Unknown float format or not a float ~a" str))
+
+ (unless int-part
+ (setf int-part 0))
+ (* (+ (coerce int-part 'double-float)
+ (or fractional-part 0))
+ (expt 10 exponent)
+ sign)))))
;; here we are assuming that the value of *PG-CLIENT-ENCODING* is
;; compatible with the encoding that the CL implementation uses for
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/pg.asd pg/pg.asd
--- pg.orig/pg.asd 2006-09-30 22:51:12.000000000 +0600
+++ pg/pg.asd 2006-11-22 11:46:25.000000000 +0500
@@ -8,12 +8,6 @@
(defclass pg-component (cl-source-file)
())
-;; For CMUCL, ensure that the crypt library is loaded before
-;; attempting to load the code.
-#+cmu
-(defmethod perform :before ((o load-op) (c pg-component))
- (ext:load-foreign "/usr/lib/libcrypt.so"))
-
(defsystem :pg
:name "Socket-level PostgreSQL interface"
:author "Eric Marsden"
@@ -23,7 +17,8 @@
#+cormanlisp :sockets
#+sbcl :sb-bsd-sockets
#+sbcl :sb-rotate-byte
- #+(and mcl (not openmcl)) "OPENTRANSPORT")
+ #+(and mcl (not openmcl)) "OPENTRANSPORT"
+ :cffi)
:components ((:file "md5")
(:file "defpackage" :depends-on ("md5"))
(:pg-component "sysdep" :depends-on ("defpackage" "md5"))
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/pg.lisp pg/pg.lisp
--- pg.orig/pg.lisp 2006-11-21 01:50:36.000000000 +0500
+++ pg/pg.lisp 2006-11-23 16:02:32.000000000 +0500
@@ -127,6 +127,8 @@
(defvar *pg-date-style* "ISO")
+(defvar *pg-coerce-result-types* t
+ "Convert query results to types declared by backend database.")
(defclass pgcon ()
((stream :accessor pgcon-stream
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/sysdep.lisp pg/sysdep.lisp
--- pg.orig/sysdep.lisp 2006-11-19 23:47:59.000000000 +0500
+++ pg/sysdep.lisp 2006-11-22 11:59:17.000000000 +0500
@@ -18,26 +18,16 @@
(error "No system dependent code to ~A" desc))
(car forms))
-
-#+(and cmu glibc2)
(eval-when (:compile-toplevel :load-toplevel)
- (format t ";; Loading libcrypt~%")
- ;; (ext:load-foreign "/lib/libcrypt.so.1")
- (sys::load-object-file "/usr/lib/libcrypt.so"))
-
-#+(and cmu glibc2)
-(defun crypt (key salt)
- (declare (type string key salt))
- (alien:alien-funcall
- (alien:extern-alien "crypt"
- (function c-call:c-string c-call:c-string c-call:c-string))
- key salt))
-
-#-(and cmu glibc2)
-(defun crypt (key salt)
- (declare (ignore salt))
- key)
-
+ (cffi:define-foreign-library libcrypt
+ (:unix (:default "libcrypt"))
+ (t (:default "libcrypt")))
+
+ (cffi:use-foreign-library libcrypt))
+
+(cffi:defcfun ("crypt" crypt) :string
+ (key :string)
+ (salt :string))
(defun md5-digest (string &rest strings)
(declare (type simple-string string))
@@ -323,68 +313,184 @@
;; (declare (ignore elements bytes))
;; (fli:convert-from-foreign-string ptr :external-format to)))
-
-;;; character encoding support
-
-(defvar *pg-client-encoding*)
+(defvar *pg-multibyte-encodings*
+ '("BIG5"
+ "EUC_CN"
+ "EUC_JP"
+ "EUC_KR"
+ "EUC_TW"
+ "GB18030"
+ "GBK"
+ "JOHAB"
+ "MULE_INTERNAL"
+ "SJIS"
+ "UHC"
+ "UTF8"))
+
+(defvar *pg-implementation-encodings*
+ (let ((tbl (make-hash-table :test #'equalp)))
+ (mapc
+ #'(lambda (kv)
+ (when (cdr kv)
+ (setf (gethash (car kv) tbl) (cadr kv))))
+ '(("ISO_8859_5"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-5
+ #+(and clisp unicode) charset:iso-8859-5)
+ ("ISO_8859_6"
+ #+(and sbcl sb-unicode) :iso-8859-6
+ #+(and allegro ics) :iso8859-6
+ #+(and clisp unicode) charset:iso-8859-6
+ )
+ ("ISO_8859_7"
+ #+(and sbcl sb-unicode) :iso-8859-7
+ #+(and allegro ics) :iso8859-7
+ #+(and clisp unicode) charset:iso-8859-7
+ )
+ ("ISO_8859_8"
+ #+(and sbcl sb-unicode) :iso-8859-8
+ #+(and allegro ics) :iso8859-8
+ #+(and clisp unicode) charset:iso-8859-8
+ )
+ ("KOI8"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :koi8-r
+ #+(and clisp unicode) charset:koi8-r
+ )
+ ("LATIN1"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-1
+ #+(and clisp unicode) charset:iso-8859-1)
+ ("LATIN2"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-2
+ #+(and clisp unicode) charset:iso-8859-2)
+ ("LATIN3"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-3
+ #+(and clisp unicode) charset:iso-8859-3)
+ ("LATIN4"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-4
+ #+(and clisp unicode) charset:iso-8859-4)
+ ("LATIN5"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-5
+ #+(and clisp unicode) charset:iso-8859-9)
+ ("LATIN6"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-6
+ #+(and clisp unicode) charset:iso-8859-10)
+ ("LATIN7"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-7
+ #+(and clisp unicode) charset:iso-8859-13)
+ ("LATIN8"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-8
+ #+(and clisp unicode) charset:iso-8859-14)
+ ("LATIN9"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :latin-9
+ #+(and clisp unicode) charset:iso-8859-15)
+ ("LATIN10"
+ #+(and clisp unicode) charset:iso-8859-16)
+ ("SQL_ASCII"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :ascii
+ #+(and clisp unicode) charset:ascii)
+ ("UTF8"
+ #+(or (and sbcl sb-unicode) (and allegro ics)) :utf-8
+ #+(and clisp unicode) charset:utf-8)
+ ("EUC_JP"
+ #+(and sbcl sb-unicode) :eucjp
+ #+(and allegro ics) :euc
+ #+(and clisp unicode) charset:eucjp)
+ ("WIN866"
+ #+(and sbcl sb-unicode) :cp866
+ #+(and clisp unicode) charset:cp866)
+ ("WIN874"
+ #+(and sbcl sb-unicode) :cp874
+ #+(and allegro ics) :874
+ #+(and clisp unicode) charset:cp874)
+ ("WIN1250"
+ #+(and sbcl sb-unicode) :windows-1250
+ #+(and allegro ics) :1250
+ #+(and clisp unicode) charset:windows-1250)
+ ("WIN1251"
+ #+(and sbcl sb-unicode) :windows-1251
+ #+(and allegro ics) :1251
+ #+(and clisp unicode) charset:windows-1251)
+ ("WIN1252"
+ #+(and sbcl sb-unicode) :windows-1252
+ #+(and allegro ics) :1252
+ #+(and clisp unicode) charset:windows-1252)
+ ("WIN1253"
+ #+(and sbcl sb-unicode) :windows-1253
+ #+(and allegro ics) :1253
+ #+(and clisp unicode) charset:windows-1253)
+ ("WIN1254"
+ #+(and sbcl sb-unicode) :windows-1254
+ #+(and allegro ics) :1254
+ #+(and clisp unicode) charset:windows-1254)
+ ("WIN1255"
+ #+(and sbcl sb-unicode) :windows-1255
+ #+(and allegro ics) :1255
+ #+(and clisp unicode) charset:windows-1255)
+ ("WIN1256"
+ #+(and sbcl sb-unicode) :windows-1256
+ #+(and allegro ics) :1256
+ #+(and clisp unicode) charset:windows-1256)
+ ("WIN1257"
+ #+(and sbcl sb-unicode) :windows-1257
+ #+(and allegro ics) :1257
+ #+(and clisp unicode) charset:windows-1257)
+ ("WIN1258"
+ #+(and sbcl sb-unicode) :windows-1258
+ #+(and allegro ics) :1258
+ #+(and clisp unicode) charset:windows-1258)))
+ tbl))
(defun implementation-name-for-encoding (encoding)
(%sysdep "convert from client encoding to external format name"
- #+(and clisp unicode)
- (cond ((string-equal encoding "SQL_ASCII") charset:ascii)
- ((string-equal encoding "LATIN1") charset:iso-8859-1)
- ((string-equal encoding "LATIN2") charset:iso-8859-2)
- ((string-equal encoding "LATIN9") charset:iso-8859-9)
- ((string-equal encoding "UTF8") charset:utf-8)
- (t (error "unknown encoding ~A" encoding)))
- #+(and allegro ics)
- (cond ((string-equal encoding "SQL_ASCII") :ascii)
- ((string-equal encoding "LATIN1") :latin1)
- ((string-equal encoding "LATIN9") :latin9)
- ((string-equal encoding "UTF8") :utf8)
- (t (error "unknown encoding ~A" encoding)))
- #+(and sbcl sb-unicode)
- (cond ((string-equal encoding "SQL_ASCII") :ascii)
- ((string-equal encoding "LATIN1") :iso-8859-1)
- ((string-equal encoding "LATIN2") :iso-8859-2)
- ((string-equal encoding "LATIN9") :iso-8859-9)
- ((string-equal encoding "UTF8") :utf8)
- (t (error "unknown encoding ~A" encoding)))
- #+(or cmu gcl ecl abcl openmcl lispworks)
- nil))
+ #+(or (and sbcl (not sb-unicode)) (and clisp (not unicode)) (and allegro (not ics)) cmu gcl ecl abcl openmcl lispworks)
+ (if (not (member encoding *pg-multibyte-encodings* :test #'equalp))
+ nil
+ (error "Unsupported multibyte encoding in unibyte environment ~a"
+ encoding))
+ #+(or (and sbcl sb-unicode) (and clisp unicode) (and allegro ics))
+ (let ((impl-enc (gethash encoding *pg-implementation-encodings*)))
+ (if impl-enc
+ impl-enc
+ (error "Unknown or unsupported encoding ~a" encoding)))
+ ))
(defun convert-string-to-bytes (string encoding)
(declare (type string string))
- (%sysdep "convert string to octet-array"
- #+(and clisp unicode)
- (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
- #+(and allegro ics)
- (excl:string-to-octets string :null-terminate nil
- :external-format (implementation-name-for-encoding encoding))
- #+(and :sbcl :sb-unicode)
- (sb-ext:string-to-octets string
- :external-format (implementation-name-for-encoding encoding))
- #+(or cmu gcl ecl abcl openmcl lispworks)
- (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
- (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
- (map-into octets #'char-code string))
- (error "Can't convert ~A string to octets" encoding))))
+
+ (let ((imp-enc (implementation-name-for-encoding encoding)))
+ (declare (ignorable imp-enc))
+ (%sysdep "convert string to octet-array"
+ #+(and clisp unicode)
+ (ext:convert-string-to-bytes string imp-enc)
+ #+(and allegro ics)
+ (excl:string-to-octets string :null-terminate nil :external-format imp-enc)
+ #+(and sbcl sb-unicode)
+ (sb-ext:string-to-octets string :external-format imp-enc)
+ #+(and sbcl (not sb-unicode))
+ (sb-ext:string-to-octets string)
+ #+(or (and clisp (not unicode)) (and allegro (not ics)) cmu gcl ecl abcl openmcl lispworks)
+ (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
+ (map-into octets #'char-code string)))))
(defun convert-string-from-bytes (bytes encoding)
(declare (type (vector (unsigned-byte 8)) bytes))
- (%sysdep "convert octet-array to string"
- #+(and clisp unicode)
- (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
- #+(and allegro ics)
- (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
- #+(and :sbcl :sb-unicode)
- (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding 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 (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl lispworks)
- (let ((string (make-string (length bytes))))
- (map-into string #'code-char bytes))))
+
+ (let ((imp-enc (implementation-name-for-encoding encoding)))
+ (declare (ignorable imp-enc))
+ (%sysdep "convert octet-array to string"
+ #+(and clisp unicode)
+ (ext:convert-string-from-bytes bytes imp-enc)
+ #+(and allegro ics)
+ (excl:octets-to-string bytes :external-format imp-enc)
+ #+(and :sbcl :sb-unicode)
+ (sb-ext:octets-to-string bytes :external-format imp-enc)
+ #+(and sbcl (not sb-unicode))
+ (sb-ext:octets-to-string bytes)
+ ;; 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 gcl ecl abcl openmcl lispworks)
+ (let ((string (make-string (length bytes))))
+ (map-into string #'code-char bytes)))))
;; EOF
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/v2-protocol.lisp pg/v2-protocol.lisp
--- pg.orig/v2-protocol.lisp 2006-11-21 01:50:36.000000000 +0500
+++ pg/v2-protocol.lisp 2006-11-23 16:02:35.000000000 +0500
@@ -294,7 +294,9 @@
(t
(let* ((len (+ (read-net-int connection 4) correction))
(raw (%read-chars (pgcon-stream connection) (max 0 len)))
- (parsed (parse raw (car type-ids))))
+ (parsed (if *pg-coerce-result-types*
+ (parse raw (car type-ids))
+ raw)))
(push parsed tuples)))))))
;; FIXME could signal a postgresql-notification condition
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/v3-protocol.lisp pg/v3-protocol.lisp
--- pg.orig/v3-protocol.lisp 2006-11-21 01:50:36.000000000 +0500
+++ pg/v3-protocol.lisp 2006-11-23 16:02:36.000000000 +0500
@@ -685,7 +685,10 @@
(raw (unless (= length -1)
(read-string-from-packet packet length))))
(if raw
- (push (parse raw (car type-ids)) tuples)
+ (push (if *pg-coerce-result-types*
+ (parse raw (car type-ids))
+ raw)
+ tuples)
(push nil tuples))))))
;; Execute one of the large-object functions (lo_open, lo_close etc).
More information about the pg-devel
mailing list