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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Mon Dec 19 22:18:32 2005 UTC (8 years, 3 months ago) by emarsden
Branch: MAIN
Changes since 1.10: +66 -25 lines
Fix sockets for recent ABCL versions.

Modify the client-encoding code to work with multiple implementations
(incomplete testing).
1 emarsden 1.2 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2     ;;;
3 emarsden 1.9 ;;; Author: Eric Marsden <eric.marsden@free.fr>
4 emarsden 1.11 ;;; Time-stamp: <2005-12-09 emarsden>
5 emarsden 1.2 ;;
6     ;;
7 emarsden 1.1
8 emarsden 1.2 (in-package :postgresql)
9 emarsden 1.1
10 emarsden 1.11 #+allegro (require :socket)
11     #+lispworks (require "comm")
12     #+cormanlisp (require :sockets)
13     #+armedbear (require :socket)
14    
15 emarsden 1.1
16 emarsden 1.6 (defmacro %sysdep (desc &rest forms)
17     (when (null forms)
18     (error "No system dependent code to ~A" desc))
19     (car forms))
20    
21    
22 emarsden 1.1 #+(and cmu glibc2)
23     (eval-when (:compile-toplevel :load-toplevel)
24     (format t ";; Loading libcrypt~%")
25     ;; (ext:load-foreign "/lib/libcrypt.so.1")
26     (sys::load-object-file "/usr/lib/libcrypt.so"))
27    
28     #+(and cmu glibc2)
29     (defun crypt (key salt)
30     (declare (type string key salt))
31     (alien:alien-funcall
32     (alien:extern-alien "crypt"
33     (function c-call:c-string c-call:c-string c-call:c-string))
34     key salt))
35    
36     #-(and cmu glibc2)
37     (defun crypt (key salt)
38     (declare (ignore salt))
39     key)
40 emarsden 1.5
41    
42     (defun md5-digest (string &rest strings)
43     (declare (type simple-string string))
44 emarsden 1.9 (let ((vec (md5sum-sequence
45     (map '(vector (unsigned-byte 8)) #'char-code
46     (apply #'concatenate 'string string strings)))))
47 emarsden 1.5 (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 emarsden 1.1
54    
55     ;; this is a little fiddly, because CLISP can be built without support
56     ;; for the Linux package
57     ;; #+CLISP
58     ;; (defun crypt (key salt)
59     ;; (linux::crypt key salt))
60    
61    
62     ;; bug in WRITE-SEQUENCE in CMUCL
63     #+(or cmu18c cmu18d)
64     (defun write-sequence (seq stream &key start end)
65     (declare (ignore start end))
66     (loop :for element :across seq
67     :do (write-byte element stream)))
68    
69    
70    
71     ;; work around bug in FASL fop dumping
72     #+cmu (setf c::top-level-lambda-max 0)
73    
74    
75     #+(and cmu ssl)
76     (defun socket-connect (port host)
77     (declare (type integer port))
78     (handler-case
79     (let ((fd (ext:connect-to-inet-socket host port)))
80     (ssl:make-ssl-client-stream fd))
81     (error (e)
82     (error 'connection-failure
83     :host host
84     :port port
85     :transport-error e))))
86    
87    
88     #+cmu
89     (defun socket-connect (port host)
90     (declare (type integer port))
91     (handler-case
92     (let ((fd (if host
93     (ext:connect-to-inet-socket host port)
94     (ext:connect-to-unix-socket
95     (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))
96     (sys:make-fd-stream fd :input t :output t
97     :element-type '(unsigned-byte 8)))
98     (error (e)
99     (error 'connection-failure
100     :host host
101     :port port
102     :transport-error e))))
103    
104     ;; this doesn't currently work, because WRITE-SEQUENCE is not
105     ;; implemented
106     #+(and cmu simple-streams broken)
107     (defun socket-connect (port host)
108     (declare (type integer port))
109     (handler-case
110     (make-instance 'stream:socket-simple-stream
111     :remote-host host
112     :remote-port port
113     :direction :io)
114     (error (e)
115     (error 'connection-failure
116     :host host
117     :port port
118     :transport-error e))))
119    
120     #+clisp
121     (defun socket-connect (port host)
122     (declare (type integer port))
123     (handler-case
124     (#+lisp=cl socket:socket-connect
125     #-lisp=cl lisp:socket-connect
126     port host :element-type '(unsigned-byte 8))
127     (error (e)
128     (declare (ignore e))
129     (error 'connection-failure :host host :port port))))
130    
131    
132 emarsden 1.4 #+(and db-sockets broken)
133 emarsden 1.1 (defun socket-connect (port host)
134     (declare (type integer port))
135     (handler-case
136     (let ((s (sockets:make-inet-socket :stream :tcp))
137     (num (car (sockets:host-ent-addresses
138     (sockets:get-host-by-name host)))))
139     (sockets:socket-connect s num port)
140     (sockets:socket-make-stream s :element-type '(unsigned-byte 8)
141     :input t :output t :buffering :none))
142     (error (e)
143     (error 'connection-failure
144     :host host
145     :port port
146     :transport-error e))))
147    
148     #+sbcl
149     (defun socket-connect (port host)
150     (declare (type integer port))
151     (handler-case
152     (sb-bsd-sockets:socket-make-stream
153     (if host
154     (let ((s (make-instance 'sb-bsd-sockets:inet-socket
155     :type :stream :protocol :tcp))
156     (num (car (sb-bsd-sockets:host-ent-addresses
157     (sb-bsd-sockets:get-host-by-name host)))))
158     (sb-bsd-sockets:socket-connect s num port)
159     s)
160     (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
161     (sb-bsd-sockets:socket-connect
162     s (format nil "/var/run/postgresql/.s.PGSQL.~D" port))
163     s))
164     :element-type '(unsigned-byte 8)
165     :input t
166     :output t
167     :buffering :none)
168     (error (e)
169     (error 'connection-failure :host host :port port :transport-error e))))
170    
171     #+allegro
172     (defun socket-connect (port host)
173     (declare (type integer port))
174     (handler-case
175     (socket:make-socket :remote-host host
176     :remote-port port
177     :format :binary)
178     (error (e)
179 emarsden 1.3 (error 'connection-failure
180 emarsden 1.1 :host host
181     :port port
182     :transport-error e))))
183    
184     ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
185     ;; streams. Fixed in version 4.3.
186     #+lispworks
187     (defun socket-connect (port host)
188     (declare (type integer port))
189 emarsden 1.3 (handler-case
190     (comm:open-tcp-stream host port
191     :element-type '(unsigned-byte 8)
192     :direction :io)
193     (error (e)
194     (error 'connection-failure
195     :host host
196     :port port
197     :transport-error e))))
198 emarsden 1.1
199     ;; this doesn't work, since the Corman sockets module doesn't support
200     ;; binary I/O on socket streams.
201     #+cormanlisp
202     (defun socket-connect (port host)
203     (declare (type integer port))
204     (handler-case
205     (progn
206     (sockets:start-sockets)
207     (let ((sock (sockets:make-client-socket :host host :port port)))
208     (sockets:make-socket-stream sock)))
209     (error (e)
210 emarsden 1.3 (error 'connection-failure
211     :host host
212     :port port
213     :transport-error e))))
214 emarsden 1.1
215     #+openmcl
216     (defun socket-connect (port host)
217     (declare (type integer port))
218 emarsden 1.3 (handler-case
219     (if host
220     (make-socket :address-family :internet
221     :type :stream
222     :connect :active
223     :format :binary
224     :remote-host host
225     :remote-port port)
226     (make-socket :address-family :file
227     :type :stream
228     :connect :active
229     :format :binary
230     :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
231     (error (e)
232     (error 'connection-failure
233     :host host
234     :port port
235     :transport-error e))))
236 emarsden 1.1
237     ;; from John DeSoi
238     #+(and mcl (not openmcl))
239     (defun socket-connect (port host)
240     (declare (type integer port))
241     (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
242    
243     ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
244     ;; write-sequence fail with binary tcp streams. These two methods
245     ;; provide a work-around.
246     #+(and mcl (not openmcl))
247     (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
248     (sequence ccl::simple-unsigned-byte-vector)
249     &key (start 0) end)
250     (ccl::stream-write-vector s sequence start (or end (length sequence)))
251     s)
252    
253     #+(and mcl (not openmcl))
254     (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
255     (sequence ccl::simple-unsigned-byte-vector)
256     &key (start 0) (end (length sequence)))
257     (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
258     sequence (- end start) start)
259     end)
260    
261    
262     #+ecl
263     (defun socket-connect (port host)
264     (declare (type integer port))
265 emarsden 1.3 (handler-case
266     (si:open-client-stream host port)
267     (error (e)
268     (error 'connection-failure
269     :host host
270     :port port
271     :transport-error e))))
272 emarsden 1.1
273    
274    
275     ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
276     ;; work, DEFINE-CONDITION not implemented, ...
277     #+gcl
278     (defun socket-connect (port host)
279     (declare (type integer port))
280     (si::socket port :host host))
281    
282    
283 emarsden 1.4
284     #+armedbear
285     (eval-when (:load-toplevel :execute :compile-toplevel)
286 emarsden 1.11 (require :socket))
287 emarsden 1.4
288 emarsden 1.1 #+armedbear
289     (defun socket-connect (port host)
290     (declare (type integer port))
291 emarsden 1.11 (handler-case
292     (ext:get-socket-stream (ext:make-socket host port)
293     :element-type '(unsigned-byte 8))
294 emarsden 1.3 (error (e)
295     (error 'connection-failure
296     :host host
297     :port port
298     :transport-error e))))
299 emarsden 1.6
300    
301 emarsden 1.11 ;; for Lispworks
302     ;; (defun encode-lisp-string (string)
303     ;; (translate-string-via-fli string :utf-8 :latin-1))
304     ;;
305     ;; (defun decode-external-string (string)
306     ;; (translate-string-via-fli string :latin-1 :utf-8))
307     ;;
308     ;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is
309     ;; ;; also null, and vice versa. So don't have to worry about
310     ;; ;; null-termination or length. (If we were translating to/from
311     ;; ;; :unicode, this would become an issue.)
312     ;;
313     ;; (defun translate-string-via-fli (string from to)
314     ;; (fli:with-foreign-string (ptr elements bytes :external-format from)
315     ;; string
316     ;; (declare (ignore elements bytes))
317     ;; (fli:convert-from-foreign-string ptr :external-format to)))
318    
319 emarsden 1.6
320     ;;; character encoding support
321    
322     (defvar *pg-client-encoding*)
323    
324 emarsden 1.11 (defun implementation-name-for-encoding (encoding)
325     (%sysdep "client encoding to external format name"
326     #+(and clisp unicode)
327     (cond ((string= encoding "SQL_ASCII") :ascii)
328     ((string= encoding "LATIN1") :latin1)
329     ((string= encoding "LATIN9") :latin9)
330     ((string= encoding "UNICODE") :utf8)
331     (t (error "unknown encoding ~A" encoding)))
332     #+(and allegro ics)
333     (cond ((string= encoding "SQL_ASCII") :ascii)
334     ((string= encoding "LATIN1") :latin1)
335     ((string= encoding "LATIN9") :latin9)
336     ((string= encoding "UNICODE") :utf8)
337     (t (error "unknown encoding ~A" encoding)))
338     #+(and sbcl sb-unicode)
339     (cond ((string= encoding "SQL_ASCII") :ascii)
340     ((string= encoding "LATIN1") :latin1)
341     ((string= encoding "LATIN9") :latin9)
342     ((string= encoding "UNICODE") :utf8)
343     (t (error "unknown encoding ~A" encoding)))
344     #+(or cmu gcl ecl abcl)
345     (cond ((string= encoding "SQL_ASCII") :ascii)
346     ((string= encoding "LATIN1") :latin1)
347     ((string= encoding "LATIN9") :latin9))))
348    
349 emarsden 1.6 (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
350     (declare (type string string))
351     (%sysdep "convert string to bytes"
352     #+(and clisp unicode)
353 emarsden 1.11 (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
354 emarsden 1.8 #+(and allegro ics)
355     (excl:string-to-octets string :null-terminate nil
356 emarsden 1.11 :external-format (implementation-name-for-encoding encoding))
357 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
358 emarsden 1.11 (sb-ext:string-to-octets string
359     :external-format (implementation-name-for-encoding encoding))
360     #+(or cmu gcl ecl abcl)
361     (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
362     (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
363     (map-into octets #'char-code string))
364     (error "Can't convert ~A string to octets" encoding))))
365 emarsden 1.6
366     (defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
367     (declare (type (vector (unsigned-byte 8)) bytes))
368     (%sysdep "convert octet-array to string"
369     #+(and clisp unicode)
370 emarsden 1.11 (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
371 emarsden 1.8 #+(and allegro ics)
372 emarsden 1.11 (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
373 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
374 emarsden 1.11 (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
375 emarsden 1.6 ;; for implementations that have no support for character
376     ;; encoding, we assume that the encoding is an octet-for-octet
377     ;; encoding, and convert directly
378 emarsden 1.11 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl)
379 emarsden 1.6 (let ((string (make-string (length bytes))))
380     (map-into string #'code-char bytes))))
381 emarsden 1.1
382    
383     ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5