Add unicode for CCL for pgsql-socket

diff --git a/ChangeLog b/ChangeLog
index 0fcc5b084fe387704b4ecfae73a52f533c399863..c4d9559ef903aa3eb1edbfd9902fbc9d50c40e58 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-06-12  Kevin Rosenberg <kevin@rosenberg.net>
+       * db-postgresql-socket/postgresql-socket-api.lisp:
+       Patch from Otto Diesenbacher for UTF8 encoded strings
+       for CCL. FIXME: The best patch would be to use the
+       user-set encoding from the database object and use
+       UFFI's encoding strings to/from octet vectors rather
+       than SB-UNICODE and CCL specific code in this file.
+

 2011-04-21  Kevin Rosenberg <kevin@rosenberg.net>
        * sql/generics.lisp: Add defgeneric for new
        database-last-auto-increment-id
 2011-04-21  Kevin Rosenberg <kevin@rosenberg.net>
        * sql/generics.lisp: Add defgeneric for new
        database-last-auto-increment-id

diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp
index b12424cce74aa77c547d9a18725b5aee0ec40ffc..899d3bbba49911a1c61d2cc47707599fe88818f4 100644 (file)
--- a/db-postgresql-socket/postgresql-socket-api.lisp
+++ b/db-postgresql-socket/postgresql-socket-api.lisp
@@ -17,6 +17,15 @@
 
 (in-package #:postgresql-socket)
 
 
 (in-package #:postgresql-socket)
 

+;; KMR: 2011-06-12
+;; FIXME: The file has code specific to sb-unicode and CCL
+;; to assume UTF8 encoded strings.
+;; Best fix would be to use the user-specified encoding that is now
+;; stored in the database object and use the UFFI 2.x encoding functions
+;; to convert strings to/from octet vectors. This allows encoding
+;; other than UTF8 and also works on all CL implementations that
+;; support wide character strings
+

 (uffi:def-enum pgsql-ftype
     ((:bytea 17)
      (:int2 21)
 (uffi:def-enum pgsql-ftype
     ((:bytea 17)
      (:int2 21)


@@ -105,13 +114,18 @@ socket interface"
 (defun send-socket-value-string (socket value)
   (declare (type stream socket)
            (type string value))
 (defun send-socket-value-string (socket value)
   (declare (type stream socket)
            (type string value))

-  #-sb-unicode
+  #-(or sb-unicode ccl)

   (loop for char across value
   (loop for char across value

-        for code = (char-code char)
-        do (write-byte code socket)
-        finally (write-byte 0 socket))
+     for code = (char-code char)
+     do (write-byte code socket)
+     finally (write-byte 0 socket))
+  #+ccl
+  (write-sequence (ccl:encode-string-to-octets
+                   value :external-format :utf-8) socket)
+  (write-byte 0 socket)

   #+sb-unicode
   #+sb-unicode

-  (write-sequence (sb-ext:string-to-octets value :null-terminate t) socket)
+  (write-sequence (sb-ext:string-to-octets value :null-terminate t)
+                  socket)

   nil)
 
 (defun send-socket-value-limstring (socket value limit)
   nil)
 
 (defun send-socket-value-limstring (socket value limit)


@@ -150,24 +164,33 @@ socket interface"
   (declare (type stream socket))
   (read-byte socket))
 
   (declare (type stream socket))
   (read-byte socket))
 

+

 (defun read-socket-value-string (socket)
   (declare (type stream socket))
 (defun read-socket-value-string (socket)
   (declare (type stream socket))

-  #-sb-unicode
+  #-(or sb-unicode ccl)

   (with-output-to-string (out)
     (loop for code = (read-byte socket)
   (with-output-to-string (out)
     (loop for code = (read-byte socket)

-          until (zerop code)
-          do (write-char (code-char code) out)))
+       until (zerop code)
+       do (write-char (code-char code) out)))
+  #+ccl
+  (let ((bytes (make-array 64
+                           :element-type '(unsigned-byte 8)
+                           :adjustable t
+                           :fill-pointer 0)))
+    (loop for code = (read-byte socket)
+       until (zerop code)
+       do (vector-push-extend code bytes))
+    (ccl:decode-string-from-octets bytes :external-format :utf-8))

   #+sb-unicode
   (let ((bytes (make-array 64
                            :element-type '(unsigned-byte 8)
                            :adjustable t
                            :fill-pointer 0)))
     (loop for code = (read-byte socket)
   #+sb-unicode
   (let ((bytes (make-array 64
                            :element-type '(unsigned-byte 8)
                            :adjustable t
                            :fill-pointer 0)))
     (loop for code = (read-byte socket)

-          until (zerop code)
+       until (zerop code)

           do (vector-push-extend code bytes))
     (sb-ext:octets-to-string bytes)))
 
           do (vector-push-extend code bytes))
     (sb-ext:octets-to-string bytes)))
 

-

 (defmacro define-message-sender (name (&rest args) &rest clauses)
   (let ((socket-var (gensym))
         (body nil))
 (defmacro define-message-sender (name (&rest args) &rest clauses)
   (let ((socket-var (gensym))
         (body nil))


@@ -214,11 +237,18 @@ socket interface"
 (defun read-socket-sequence (stream length &optional (allow-wide t))
   (declare (stream stream)
            (optimize (speed 3) (safety 0)))
 (defun read-socket-sequence (stream length &optional (allow-wide t))
   (declare (stream stream)
            (optimize (speed 3) (safety 0)))

-  #-sb-unicode
+  #-(or sb-unicode ccl)

   (let ((result (make-string length)))
     (dotimes (i length result)
       (declare (fixnum i))
       (setf (char result i) (code-char (read-byte stream)))))
   (let ((result (make-string length)))
     (dotimes (i length result)
       (declare (fixnum i))
       (setf (char result i) (code-char (read-byte stream)))))

+  #+ccl
+  (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
+    (read-sequence bytes stream)
+    (if allow-wide
+       (ccl:decode-string-from-octets bytes :external-format :utf-8)
+       (map 'string #'code-char bytes)))

   #+sb-unicode
   (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
     (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
   #+sb-unicode
   (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
     (declare (type (simple-array (unsigned-byte 8) (*)) bytes))

diff --git a/debian/changelog b/debian/changelog
index c579adf699b9d57c3895808f05da476adcec917a..681b6f1770f31bc723a6b8a7882b844401ac726d 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (5.3.3-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Sun, 12 Jun 2011 09:49:33 -0600
+

 cl-sql (5.3.2-1) unstable; urgency=low
 
   * New upstream
 cl-sql (5.3.2-1) unstable; urgency=low
 
   * New upstream