/[pg]/pg/sysdep.lisp
ViewVC logotype

Diff of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by emarsden, Wed Mar 3 13:11:50 2004 UTC revision 1.19 by emarsden, Sun Nov 19 18:47:59 2006 UTC
# Line 1  Line 1 
1  ;;; system-dependent parts of pg-dot-lisp  ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2    ;;;
3    ;;; Author: Eric Marsden <eric.marsden@free.fr>
4    ;;; Time-stamp: <2006-11-19 emarsden>
5    ;;
6    ;;
7    
8  (in-package :pg)  (in-package :postgresql)
9    
10  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
   #+allegro (require :socket)  
11    #+lispworks (require "comm")    #+lispworks (require "comm")
12    #+cormanlisp (require :sockets)    #+cormanlisp (require :sockets)
13    #+sbcl (progn (require :asdf) (require :sb-bsd-sockets))    #+armedbear (require :socket))
14    #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))  
15    
16    (defmacro %sysdep (desc &rest forms)
17      (when (null forms)
18        (error "No system dependent code to ~A" desc))
19      (car forms))
20    
21    
22  #+(and cmu glibc2)  #+(and cmu glibc2)
# Line 30  Line 39 
39    key)    key)
40    
41    
42    (defun md5-digest (string &rest strings)
43      (declare (type simple-string string))
44      (let ((vec (md5sum-sequence
45                  (map '(vector (unsigned-byte 8)) #'char-code
46                       (apply #'concatenate 'string string strings)))))
47        (format nil "~(~{~2,'0X~}~)" (coerce vec 'list))))
48    
49    (defun md5-encode-password (user password salt)
50      (concatenate 'string "md5"
51                   (md5-digest (md5-digest password user) salt)))
52    
53    
54    
55  ;; this is a little fiddly, because CLISP can be built without support  ;; this is a little fiddly, because CLISP can be built without support
56  ;; for the Linux package  ;; for the Linux package
57  ;; #+CLISP  ;; #+CLISP
# Line 66  Line 88 
88  #+cmu  #+cmu
89  (defun socket-connect (port host)  (defun socket-connect (port host)
90    (declare (type integer port))    (declare (type integer port))
91    (handler-case    (let ((host (if (typep host 'pathname)
92     (let ((fd (if host                    (namestring host)
93                   (ext:connect-to-inet-socket host port)                    host)))
94                   (ext:connect-to-unix-socket      (handler-case
95                    (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))          (let ((fd (if (eql #\/ (char host 0))
96       (sys:make-fd-stream fd :input t :output t                        (ext:connect-to-unix-socket
97                           :element-type '(unsigned-byte 8)))                         (format nil "~A.s.PGSQL.~D" (string host) port))
98     (error (e)                        (ext:connect-to-inet-socket host port))))
99        (error 'connection-failure            (sys:make-fd-stream fd :input t :output t
100               :host host                                :element-type '(unsigned-byte 8)))
101               :port port        (error (e)
102               :transport-error e))))          (error 'connection-failure
103                   :host host
104                   :port port
105                   :transport-error e)))))
106    
107  ;; this doesn't currently work, because WRITE-SEQUENCE is not  ;; this doesn't currently work, because WRITE-SEQUENCE is not
108  ;; implemented  ;; implemented
# Line 101  Line 126 
126    (handler-case    (handler-case
127     (#+lisp=cl socket:socket-connect     (#+lisp=cl socket:socket-connect
128      #-lisp=cl lisp:socket-connect      #-lisp=cl lisp:socket-connect
129      port host :element-type '(unsigned-byte 8))      port host
130        :element-type '(unsigned-byte 8)
131        :buffered t)
132     (error (e)     (error (e)
133        (declare (ignore e))        (declare (ignore e))
134        (error 'connection-failure :host host :port port))))        (error 'connection-failure :host host :port port))))
135    
136    
 #+db-sockets  
 (defun socket-connect (port host)  
   (declare (type integer port))  
   (handler-case  
    (let ((s (sockets:make-inet-socket :stream :tcp))  
          (num (car (sockets:host-ent-addresses  
                     (sockets:get-host-by-name host)))))  
      (sockets:socket-connect s num port)  
      (sockets:socket-make-stream s :element-type '(unsigned-byte 8)  
                                  :input t :output t :buffering :none))  
    (error (e)  
       (error 'connection-failure  
              :host host  
              :port port  
              :transport-error e))))  
   
137  #+sbcl  #+sbcl
138  (defun socket-connect (port host)  (defun socket-connect (port host-name)
139    (declare (type integer port))    (declare (type integer port))
140    (handler-case    (let ((host (if (typep host-name 'pathname)
141        (sb-bsd-sockets:socket-make-stream                    (namestring host-name)
142         (if host                    host-name)))
143             (let ((s (make-instance 'sb-bsd-sockets:inet-socket      (handler-case
144                                     :type :stream :protocol :tcp))          (sb-bsd-sockets:socket-make-stream
145                   (num (car (sb-bsd-sockets:host-ent-addresses           (if (eql #\/ (char host 0))
146                              (sb-bsd-sockets:get-host-by-name host)))))               (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
147               (sb-bsd-sockets:socket-connect s num port)                 (sb-bsd-sockets:socket-connect
148               s)                  s (format nil  "~A.s.PGSQL.~D" (string host) port))
149             (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))                 s)
150               (sb-bsd-sockets:socket-connect               (let ((s (make-instance 'sb-bsd-sockets:inet-socket
151                s (format nil "/var/run/postgresql/.s.PGSQL.~D" port))                           :type :stream :protocol :tcp))
152               s))                     (num (car (sb-bsd-sockets:host-ent-addresses
153         :element-type '(unsigned-byte 8)                                (sb-bsd-sockets:get-host-by-name host)))))
154         :input t                 (sb-bsd-sockets:socket-connect s num port)
155         :output t                 s))
156         :buffering :none)           :element-type '(unsigned-byte 8)
157      (error (e)           :input t
158        (error 'connection-failure :host host :port port :transport-error e))))           :output t
159             :buffering :none)
160          (error (e)
161            (error 'connection-failure :host host :port port :transport-error e)))))
162    
163  #+allegro  #+allegro
164  (defun socket-connect (port host)  (defun socket-connect (port host)
165    (declare (type integer port))    (declare (type integer port))
166    (handler-case    (handler-case
167     (socket:make-socket :remote-host host        (if (eql #\/ (char host 0))
168                         :remote-port port            (socket:make-socket :type :stream
169                         :format :binary)                                :address-family :file
170     (error (e)                                :connect :active
171        (signal 'connection-failure                                :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port)
172                :host host                                :format :binary)
173                :port port            (socket:make-socket :remote-host host
174                :transport-error e))))                                :remote-port port
175                                  :connect :active
176                                  :format :binary))
177        (error (e)
178          (error 'connection-failure
179                 :host host
180                 :port port
181                 :transport-error e))))
182    
183  ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary  ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
184  ;; streams. Fixed in version 4.3.  ;; streams. Fixed in version 4.3.
185  #+lispworks  #+lispworks
186  (defun socket-connect (port host)  (defun socket-connect (port host)
187    (declare (type integer port))    (declare (type integer port))
188    (comm:open-tcp-stream host port    (handler-case
189                          :element-type '(unsigned-byte 8)        (comm:open-tcp-stream host port
190                          :direction :io))                              :element-type '(unsigned-byte 8)
191                                :direction :io)
192        ;; note that Lispworks (at least 4.3) does not signal an error if
193        ;; the hostname cannot be resolved; it simply returns NIL
194        (error (e)
195          (error 'connection-failure
196                 :host host
197                 :port port
198                 :transport-error e))))
199    
200  ;; this doesn't work, since the Corman sockets module doesn't support  ;; this doesn't work, since the Corman sockets module doesn't support
201  ;; binary I/O on socket streams.  ;; binary I/O on socket streams.
# Line 179  Line 208 
208          (let ((sock (sockets:make-client-socket :host host :port port)))          (let ((sock (sockets:make-client-socket :host host :port port)))
209            (sockets:make-socket-stream sock)))            (sockets:make-socket-stream sock)))
210      (error (e)      (error (e)
211        (declare (ignore e))        (error 'connection-failure
212        (error 'connection-failure :host host :port port))))               :host host
213                 :port port
214                 :transport-error e))))
215    
216  #+openmcl  #+openmcl
217  (defun socket-connect (port host)  (defun socket-connect (port host)
218    (declare (type integer port))    (declare (type integer port))
219    (let ((sock (make-socket :type :stream    (let ((host (if (typep host 'pathname)
220                             :connect :active                    (namestring host)
221                             :format :binary                    host)))
222                             :remote-host host      (handler-case
223                             :remote-port port)))          (if (eql #\/ (char host 0))
224      sock))              (make-socket :address-family :file
225                             :type :stream
226                             :connect :active
227                             :format :binary
228                             :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port))
229                (make-socket :address-family :internet
230                             :type :stream
231                             :connect :active
232                             :format :binary
233                             :remote-host host
234                             :remote-port port))
235          (error (e)
236            (error 'connection-failure
237                   :host host
238                   :port port
239                   :transport-error e)))))
240    
241  ;; from John DeSoi  ;; from John DeSoi
242  #+(and mcl (not openmcl))  #+(and mcl (not openmcl))
# Line 217  Line 263 
263    end)    end)
264    
265    
 ;; there seems to be a bug in ECL's binary socket streams; data is corrupted  
266  #+ecl  #+ecl
267  (defun socket-connect (port host)  (defun socket-connect (port host)
268    (declare (type integer port))    (declare (type integer port))
269    (si:open-client-stream host port))    (handler-case
270          (si:open-client-stream host port)
271  ;; #+ecl      (error (e)
272  ;; (defun write-sequence (seq stream &key start end)        (error 'connection-failure
273  ;;   (declare (ignore start end))               :host host
274  ;;   (loop :for element :across seq               :port port
275  ;;         :do (write-byte element stream)))               :transport-error e))))
 ;;  
 ;; #+ecl  
 ;; (defun read-bytes (connection howmany)  
 ;;   (let ((v (make-array howmany :element-type '(unsigned-byte 8)))  
 ;;         (s (pgcon-stream connection)))  
 ;;     (loop :for pos :below howmany  
 ;;           :do (setf (aref v pos) (read-byte s)))  
 ;;     v))  
 ;;  
 ;; #+ecl  
 ;; (defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))  
 ;;   (loop :for pos :from start :below end  
 ;;         :do (setf (aref seq pos) (read-byte stream))))  
   
276    
277    
278    
# Line 253  Line 284 
284    (si::socket port :host host))    (si::socket port :host host))
285    
286    
287    
288    #+armedbear
289    (eval-when (:load-toplevel :execute :compile-toplevel)
290      (require :socket))
291    
292    ;; could provide support for connections via a unix-domain socket by
293    ;; using http://freshmeat.net/projects/j-buds/ (requires linking to a
294    ;; shared libary)
295  #+armedbear  #+armedbear
296  (defun socket-connect (port host)  (defun socket-connect (port host)
297    (declare (type integer port))    (declare (type integer port))
298    (ext:make-binary-socket host port))    (handler-case
299          (ext:get-socket-stream (ext:make-socket host port)
300                                 :element-type '(unsigned-byte 8))
301        (error (e)
302          (error 'connection-failure
303                 :host host
304                 :port port
305                 :transport-error e))))
306    
 #+armedbear  
 (defun cl:write-sequence (seq stream &key (start 0) (end (length seq)))  
   (declare (ignore start end))  
   (loop :for element :across seq  
         :do (write-byte element stream)))  
307    
308  #+armedbear  ;; for Lispworks
309  (defun read-bytes (connection howmany)  ;;     (defun encode-lisp-string (string)
310    (let ((v (make-array howmany :element-type '(unsigned-byte 8)))  ;;       (translate-string-via-fli string :utf-8 :latin-1))
311          (s (pgcon-stream connection)))  ;;
312      (loop :for pos :below howmany  ;;     (defun decode-external-string (string)
313            :do (setf (aref v pos) (read-byte s)))  ;;       (translate-string-via-fli string :latin-1 :utf-8))
314      v))  ;;
315    ;;     ;; Note that a :utf-8 encoding of a null in a latin-1 string is
316    ;;     ;; also null, and vice versa.  So don't have to worry about
317    ;;     ;; null-termination or length. (If we were translating to/from
318    ;;     ;; :unicode, this would become an issue.)
319    ;;
320    ;;     (defun translate-string-via-fli (string from to)
321    ;;       (fli:with-foreign-string (ptr elements bytes :external-format from)
322    ;;        string
323    ;;      (declare (ignore elements bytes))
324    ;;      (fli:convert-from-foreign-string ptr :external-format to)))
325    
326    
327    ;;; character encoding support
328    
329    (defvar *pg-client-encoding*)
330    
331    (defun implementation-name-for-encoding (encoding)
332      (%sysdep "convert from client encoding to external format name"
333         #+(and clisp unicode)
334         (cond ((string-equal encoding "SQL_ASCII") charset:ascii)
335               ((string-equal encoding "LATIN1") charset:iso-8859-1)
336               ((string-equal encoding "LATIN2") charset:iso-8859-2)
337               ((string-equal encoding "LATIN9") charset:iso-8859-9)
338               ((string-equal encoding "UTF8") charset:utf-8)
339               (t (error "unknown encoding ~A" encoding)))
340         #+(and allegro ics)
341         (cond ((string-equal encoding "SQL_ASCII") :ascii)
342               ((string-equal encoding "LATIN1") :latin1)
343               ((string-equal encoding "LATIN9") :latin9)
344               ((string-equal encoding "UTF8") :utf8)
345               (t (error "unknown encoding ~A" encoding)))
346         #+(and sbcl sb-unicode)
347         (cond ((string-equal encoding "SQL_ASCII") :ascii)
348               ((string-equal encoding  "LATIN1") :iso-8859-1)
349               ((string-equal encoding  "LATIN2") :iso-8859-2)
350               ((string-equal encoding "LATIN9") :iso-8859-9)
351               ((string-equal encoding "UTF8") :utf8)
352               (t (error "unknown encoding ~A" encoding)))
353         #+(or cmu gcl ecl abcl openmcl lispworks)
354         nil))
355    
356    (defun convert-string-to-bytes (string encoding)
357      (declare (type string string))
358      (%sysdep "convert string to octet-array"
359         #+(and clisp unicode)
360         (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
361         #+(and allegro ics)
362         (excl:string-to-octets string :null-terminate nil
363                                :external-format (implementation-name-for-encoding encoding))
364         #+(and :sbcl :sb-unicode)
365         (sb-ext:string-to-octets string
366                                  :external-format (implementation-name-for-encoding encoding))
367         #+(or cmu gcl ecl abcl openmcl lispworks)
368         (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
369             (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
370               (map-into octets #'char-code string))
371             (error "Can't convert ~A string to octets" encoding))))
372    
373    (defun convert-string-from-bytes (bytes encoding)
374      (declare (type (vector (unsigned-byte 8)) bytes))
375      (%sysdep "convert octet-array to string"
376        #+(and clisp unicode)
377        (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
378        #+(and allegro ics)
379        (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
380        #+(and :sbcl :sb-unicode)
381        (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
382        ;; for implementations that have no support for character
383        ;; encoding, we assume that the encoding is an octet-for-octet
384        ;; encoding, and convert directly
385        #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl lispworks)
386        (let ((string (make-string (length bytes))))
387          (map-into string #'code-char bytes))))
388    
 #+armedbear  
 (defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))  
   (loop :for pos :from start :below end  
         :do (setf (aref seq pos) (read-byte stream))))  
389    
390  ;; EOF  ;; EOF

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.19

  ViewVC Help
Powered by ViewVC 1.1.5