r10398: 12 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net>

        * Version 3.1.10
        * db-postgresql-socket/postgresql-socket-api.lisp: Commit patch
        from Janis Dzerins to support unicode on SBCL
        * sql/syntax: Commit patch from Alan Shields to improve reporting
        of invalid syntax statements.

diff --git a/ChangeLog b/ChangeLog
index b92bd38884a553224974a4c0f42adbfa61d451a7..2e405734c7a4e18c1b783a42634aa6989a299341 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+12 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net>
+       * Version 3.1.10
+       * db-postgresql-socket/postgresql-socket-api.lisp: Commit patch
+       from Janis Dzerins to support unicode on SBCL
+       * sql/syntax: Commit patch from Alan Shields to improve reporting
+       of invalid syntax statements.
+       

 06 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.1.9
        * db-mysql/mysql-sql.lisp: Add port to connection specification
 06 Apr 2005 Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.1.9
        * db-mysql/mysql-sql.lisp: Add port to connection specification

diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp
index 4546d095ad23f0a95b2cc197ba13a5c05c96a2f4..bacaa98932caee2366ef99f845c8f866df9eb2c8 100644 (file)
--- a/db-postgresql-socket/postgresql-socket-api.lisp
+++ b/db-postgresql-socket/postgresql-socket-api.lisp
@@ -107,10 +107,13 @@ 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

   (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))
+  #+sb-unicode
+  (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)


@@ -151,10 +154,20 @@ socket interface"
 
 (defun read-socket-value-string (socket)
   (declare (type stream socket))
 
 (defun read-socket-value-string (socket)
   (declare (type stream socket))

+  #-sb-unicode

   (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)))
+  #+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)
+          do (vector-push-extend code bytes))
+    (sb-ext:octets-to-string bytes)))

 
 
 (defmacro define-message-sender (name (&rest args) &rest clauses)
 
 
 (defmacro define-message-sender (name (&rest args) &rest clauses)


@@ -200,15 +213,20 @@ socket interface"
   (int32 key))
 
 
   (int32 key))
 
 

-(defun read-socket-sequence (string stream)
+(defun read-socket-sequence (stream length)

   "KMR -- Added to support reading from binary stream into a string"
   "KMR -- Added to support reading from binary stream into a string"

-  (declare (string string)
-          (stream stream)
+  (declare (stream stream)

           (optimize (speed 3) (safety 0)))
           (optimize (speed 3) (safety 0)))

-  (dotimes (i (length string))
-    (declare (fixnum i))
-    (setf (char string i) (code-char (read-byte stream))))
-  string)
+  #-sb-unicode
+  (let ((result (make-string length)))
+    (dotimes (i (length string) result)
+      (declare (fixnum i))
+      (setf (char string i) (code-char (read-byte stream)))))
+  #+sb-unicode
+  (let ((bytes (make-array length :element-type '(unsigned-byte 8))))
+    (declare (type (simple-array (unsigned-byte 8) (*)) bytes))
+    (read-sequence bytes stream)
+    (sb-ext:octets-to-string bytes)))

 
 
 ;;; Support for encrypted password transmission
 
 
 ;;; Support for encrypted password transmission


@@ -324,7 +342,7 @@ socket interface"
      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
                                :type :stream
                                :protocol :tcp)))
      (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
                                :type :stream
                                :protocol :tcp)))

-       (sb-bsd-sockets:socket-connect 
+       (sb-bsd-sockets:socket-connect

        sock 
        (sb-bsd-sockets:host-ent-address
         (sb-bsd-sockets:get-host-by-name host)) 
        sock 
        (sb-bsd-sockets:host-ent-address
         (sb-bsd-sockets:get-host-by-name host)) 


@@ -461,16 +479,14 @@ connection, if it is still open."
                      (postgresql-connection-password connection))
                       (force-output socket))
                    (4
                      (postgresql-connection-password connection))
                       (force-output socket))
                    (4

-                    (let ((salt (make-string 2)))
-                      (read-socket-sequence salt socket)
+                    (let ((salt (read-socket-sequence socket 2)))

                       (send-encrypted-password-message
                        socket
                        (crypt-password
                         (postgresql-connection-password connection) salt)))
                      (force-output socket))
                    (5
                       (send-encrypted-password-message
                        socket
                        (crypt-password
                         (postgresql-connection-password connection) salt)))
                      (force-output socket))
                    (5

-                    (let ((salt (make-string 4)))
-                      (read-socket-sequence salt socket)
+                    (let ((salt (read-socket-sequence socket 4)))

                       (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
                                                 (postgresql-connection-user connection)))
                              (pwd (encrypt-md5 pwd2 salt)))
                       (let* ((pwd2 (encrypt-md5 (postgresql-connection-password connection)
                                                 (postgresql-connection-user connection)))
                              (pwd (encrypt-md5 pwd2 salt)))


@@ -637,9 +653,7 @@ connection, if it is still open."
       (:double
        (read-double-from-socket socket length))
       (t
       (:double
        (read-double-from-socket socket length))
       (t

-       (let ((result (make-string length)))
-        (read-socket-sequence result socket)
-        result)))))
+       (read-socket-sequence socket length)))))

 
 (uffi:def-constant +char-code-zero+ (char-code #\0))
 (uffi:def-constant +char-code-minus+ (char-code #\-))
 
 (uffi:def-constant +char-code-zero+ (char-code #\0))
 (uffi:def-constant +char-code-minus+ (char-code #\-))

diff --git a/sql/syntax.lisp b/sql/syntax.lisp
index eb19060c4b6ad655eab3c542d1a1482aa03a7925..a898dfb47baf7aeef3a4038ed49309244c5ef05a 100644 (file)
--- a/sql/syntax.lisp
+++ b/sql/syntax.lisp
@@ -88,13 +88,18 @@ reader syntax is disabled."
 (defun sql-reader-open (stream char)
   (declare (ignore char))
   (let ((sqllist (read-delimited-list #\] stream t)))
 (defun sql-reader-open (stream char)
   (declare (ignore char))
   (let ((sqllist (read-delimited-list #\] stream t)))

-    (cond ((string= (write-to-string (car sqllist)) "||")
-           (cons (sql-operator 'concat-op) (cdr sqllist)))
-          ((and (= (length sqllist) 1) (eql (car sqllist) '*))
-           (apply #'generate-sql-reference sqllist))
-          ((sql-operator (car sqllist))
-           (cons (sql-operator (car sqllist)) (cdr sqllist)))
-          (t (apply #'generate-sql-reference sqllist)))))
+    (handler-case
+       (cond ((string= (write-to-string (car sqllist)) "||")
+              (cons (sql-operator 'concat-op) (cdr sqllist)))
+             ((and (= (length sqllist) 1) (eql (car sqllist) '*))
+              (apply #'generate-sql-reference sqllist))
+             ((sql-operator (car sqllist))
+              (cons (sql-operator (car sqllist)) (cdr sqllist)))
+             (t (apply #'generate-sql-reference sqllist)))
+      (sql-user-error (c)
+       (error 'sql-user-error
+              :message (format nil "Error ~A occured while attempting to parse '~A' at file position ~A"
+                               (sql-user-error-message c) sqllist (file-position stream)))))))

 
 (defun disable-sql-close-syntax ()
   "Internal function that disables the close syntax when leaving
 
 (defun disable-sql-close-syntax ()
   "Internal function that disables the close syntax when leaving