[pg-cvs] CVS update: pg/sysdep.lisp

[Eric Marsden]

Update of /project/pg/cvsroot/pg
In directory common-lisp.net:/tmp/cvs-serv4467

Modified Files:
	sysdep.lisp 
Log Message:
Fix sockets for recent ABCL versions.

Modify the client-encoding code to work with multiple implementations
(incomplete testing). 

Date: Mon Dec 19 23:18:37 2005
Author: emarsden

Index: pg/sysdep.lisp
diff -u pg/sysdep.lisp:1.10 pg/sysdep.lisp:1.11
--- pg/sysdep.lisp:1.10	Tue Oct 18 15:07:27 2005
+++ pg/sysdep.lisp	Mon Dec 19 23:18:32 2005
@@ -1,12 +1,17 @@
 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
 ;;;
 ;;; Author: Eric Marsden <eric.marsden at free.fr>
-;;; Time-stamp: <2005-07-17 emarsden>
+;;; Time-stamp: <2005-12-09 emarsden>
 ;;
 ;;
 
 (in-package :postgresql)
 
+#+allegro (require :socket)
+#+lispworks (require "comm")
+#+cormanlisp (require :sockets)
+#+armedbear (require :socket)
+
 
 (defmacro %sysdep (desc &rest forms)
   (when (null forms)
@@ -278,14 +283,14 @@
 
 #+armedbear
 (eval-when (:load-toplevel :execute :compile-toplevel)
-  (require 'format))
+  (require :socket))
 
-;; MAKE-SOCKET with :element-type as per 2004-03-09
 #+armedbear
 (defun socket-connect (port host)
   (declare (type integer port))
-  (handler-case 
-      (ext:make-socket host port :element-type '(unsigned-byte 8))
+  (handler-case
+      (ext:get-socket-stream (ext:make-socket host port)
+                             :element-type '(unsigned-byte 8))
     (error (e)
       (error 'connection-failure
              :host host
@@ -293,48 +298,84 @@
              :transport-error e))))
 
 
+;; for Lispworks
+;;     (defun encode-lisp-string (string)
+;;       (translate-string-via-fli string :utf-8 :latin-1))
+;; 
+;;     (defun decode-external-string (string)
+;;       (translate-string-via-fli string :latin-1 :utf-8))
+;; 
+;;     ;; Note that a :utf-8 encoding of a null in a latin-1 string is
+;;     ;; also null, and vice versa.  So don't have to worry about
+;;     ;; null-termination or length. (If we were translating to/from
+;;     ;; :unicode, this would become an issue.)
+;; 
+;;     (defun translate-string-via-fli (string from to)
+;;       (fli:with-foreign-string (ptr elements bytes :external-format from)
+;; 	  string
+;; 	(declare (ignore elements bytes))
+;; 	(fli:convert-from-foreign-string ptr :external-format to)))
+
 
 ;;; character encoding support
 
 (defvar *pg-client-encoding*)
 
-#+(and :sbcl :sb-unicode)
-(defun sbcl-ext-form-from-client-encoding (encoding)
-  (cond
-   ((string= encoding "SQL_ASCII") :ascii)
-   ((string= encoding  "LATIN1") :latin1)
-   ((string= encoding "LATIN9") :latin9)
-   ((string= encoding "UNICODE") :utf8)
-   (t (error "unkown encoding ~A" encoding))))
-  
+(defun implementation-name-for-encoding (encoding)
+  (%sysdep "client encoding to external format name"
+     #+(and clisp unicode)
+     (cond ((string= encoding "SQL_ASCII") :ascii)
+           ((string= encoding "LATIN1") :latin1)
+           ((string= encoding "LATIN9") :latin9)
+           ((string= encoding "UNICODE") :utf8)
+           (t (error "unknown encoding ~A" encoding)))
+     #+(and allegro ics)
+     (cond ((string= encoding "SQL_ASCII") :ascii)
+           ((string= encoding "LATIN1") :latin1)
+           ((string= encoding "LATIN9") :latin9)
+           ((string= encoding "UNICODE") :utf8)
+           (t (error "unknown encoding ~A" encoding)))
+     #+(and sbcl sb-unicode)
+     (cond ((string= encoding "SQL_ASCII") :ascii)
+           ((string= encoding  "LATIN1") :latin1)
+           ((string= encoding "LATIN9") :latin9)
+           ((string= encoding "UNICODE") :utf8)
+           (t (error "unknown encoding ~A" encoding)))
+     #+(or cmu gcl ecl abcl)
+     (cond ((string= encoding "SQL_ASCII") :ascii)
+           ((string= encoding "LATIN1") :latin1)
+           ((string= encoding "LATIN9") :latin9))))
+
 (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)
+     (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
      #+(and allegro ics)
      (excl:string-to-octets string :null-terminate nil
-			    :external-format encoding)
+			    :external-format (implementation-name-for-encoding encoding))
      #+(and :sbcl :sb-unicode)
-     (sb-ext:string-to-octets string :external-format (sbcl-ext-form-from-client-encoding encoding))
-     #+(or cmu sbcl gcl ecl)
-     (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
-       (map-into octets #'char-code string))))
+     (sb-ext:string-to-octets string
+                              :external-format (implementation-name-for-encoding encoding))
+     #+(or cmu gcl ecl abcl)
+     (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))))
 
 (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)
+    (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
     #+(and allegro ics)
-    (excl:octets-to-string bytes :external-format encoding)
+    (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
     #+(and :sbcl :sb-unicode)
-    (sb-ext:octets-to-string bytes :external-format
-			     (sbcl-ext-form-from-client-encoding encoding))
+    (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)
+    #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl)
     (let ((string (make-string (length bytes))))
       (map-into string #'code-char bytes))))