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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5