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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show 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 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2 ;;;
3 ;;; Author: Eric Marsden <eric.marsden@free.fr>
4 ;;; Time-stamp: <2005-12-09 emarsden>
5 ;;
6 ;;
7
8 (in-package :postgresql)
9
10 #+allegro (require :socket)
11 #+lispworks (require "comm")
12 #+cormanlisp (require :sockets)
13 #+armedbear (require :socket)
14
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)
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
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
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 #+(and db-sockets broken)
133 (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 (error 'connection-failure
180 :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 (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
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 (error 'connection-failure
211 :host host
212 :port port
213 :transport-error e))))
214
215 #+openmcl
216 (defun socket-connect (port host)
217 (declare (type integer port))
218 (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
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 (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
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
284 #+armedbear
285 (eval-when (:load-toplevel :execute :compile-toplevel)
286 (require :socket))
287
288 #+armedbear
289 (defun socket-connect (port host)
290 (declare (type integer port))
291 (handler-case
292 (ext:get-socket-stream (ext:make-socket host port)
293 :element-type '(unsigned-byte 8))
294 (error (e)
295 (error 'connection-failure
296 :host host
297 :port port
298 :transport-error e))))
299
300
301 ;; 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
320 ;;; character encoding support
321
322 (defvar *pg-client-encoding*)
323
324 (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 (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 (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
354 #+(and allegro ics)
355 (excl:string-to-octets string :null-terminate nil
356 :external-format (implementation-name-for-encoding encoding))
357 #+(and :sbcl :sb-unicode)
358 (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
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 (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
371 #+(and allegro ics)
372 (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
373 #+(and :sbcl :sb-unicode)
374 (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
375 ;; 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 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl)
379 (let ((string (make-string (length bytes))))
380 (map-into string #'code-char bytes))))
381
382
383 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5