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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Mon Sep 18 21:33:10 2006 UTC (7 years, 7 months ago) by emarsden
Branch: MAIN
Changes since 1.13: +13 -13 lines
Make comparison in IMPLEMENTATION-NAME-FOR-ENCODING case-insensitive
(from ya007@yandex.ru).
1 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2 ;;;
3 ;;; Author: Eric Marsden <eric.marsden@free.fr>
4 ;;; Time-stamp: <2006-09-18 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-name)
150 (declare (type integer port))
151 (let ((host (if (typep host-name 'pathname)
152 (namestring host-name)
153 host-name)))
154 (handler-case
155 (sb-bsd-sockets:socket-make-stream
156 (if (eql #\/ (char host 0))
157 (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
158 (sb-bsd-sockets:socket-connect
159 s (format nil "~A.s.PGSQL.~D" (string host) port))
160 s)
161 (let ((s (make-instance 'sb-bsd-sockets:inet-socket
162 :type :stream :protocol :tcp))
163 (num (car (sb-bsd-sockets:host-ent-addresses
164 (sb-bsd-sockets:get-host-by-name host)))))
165 (sb-bsd-sockets:socket-connect s num port)
166 s))
167 :element-type '(unsigned-byte 8)
168 :input t
169 :output t
170 :buffering :none)
171 (error (e)
172 (error 'connection-failure :host host :port port :transport-error e)))))
173
174 #+allegro
175 (defun socket-connect (port host)
176 (declare (type integer port))
177 (handler-case
178 (socket:make-socket :remote-host host
179 :remote-port port
180 :format :binary)
181 (error (e)
182 (error 'connection-failure
183 :host host
184 :port port
185 :transport-error e))))
186
187 ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
188 ;; streams. Fixed in version 4.3.
189 #+lispworks
190 (defun socket-connect (port host)
191 (declare (type integer port))
192 (handler-case
193 (comm:open-tcp-stream host port
194 :element-type '(unsigned-byte 8)
195 :direction :io)
196 (error (e)
197 (error 'connection-failure
198 :host host
199 :port port
200 :transport-error e))))
201
202 ;; this doesn't work, since the Corman sockets module doesn't support
203 ;; binary I/O on socket streams.
204 #+cormanlisp
205 (defun socket-connect (port host)
206 (declare (type integer port))
207 (handler-case
208 (progn
209 (sockets:start-sockets)
210 (let ((sock (sockets:make-client-socket :host host :port port)))
211 (sockets:make-socket-stream sock)))
212 (error (e)
213 (error 'connection-failure
214 :host host
215 :port port
216 :transport-error e))))
217
218 #+openmcl
219 (defun socket-connect (port host)
220 (declare (type integer port))
221 (handler-case
222 (if host
223 (make-socket :address-family :internet
224 :type :stream
225 :connect :active
226 :format :binary
227 :remote-host host
228 :remote-port port)
229 (make-socket :address-family :file
230 :type :stream
231 :connect :active
232 :format :binary
233 :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
234 (error (e)
235 (error 'connection-failure
236 :host host
237 :port port
238 :transport-error e))))
239
240 ;; from John DeSoi
241 #+(and mcl (not openmcl))
242 (defun socket-connect (port host)
243 (declare (type integer port))
244 (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
245
246 ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
247 ;; write-sequence fail with binary tcp streams. These two methods
248 ;; provide a work-around.
249 #+(and mcl (not openmcl))
250 (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
251 (sequence ccl::simple-unsigned-byte-vector)
252 &key (start 0) end)
253 (ccl::stream-write-vector s sequence start (or end (length sequence)))
254 s)
255
256 #+(and mcl (not openmcl))
257 (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
258 (sequence ccl::simple-unsigned-byte-vector)
259 &key (start 0) (end (length sequence)))
260 (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
261 sequence (- end start) start)
262 end)
263
264
265 #+ecl
266 (defun socket-connect (port host)
267 (declare (type integer port))
268 (handler-case
269 (si:open-client-stream host port)
270 (error (e)
271 (error 'connection-failure
272 :host host
273 :port port
274 :transport-error e))))
275
276
277
278 ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
279 ;; work, DEFINE-CONDITION not implemented, ...
280 #+gcl
281 (defun socket-connect (port host)
282 (declare (type integer port))
283 (si::socket port :host host))
284
285
286
287 #+armedbear
288 (eval-when (:load-toplevel :execute :compile-toplevel)
289 (require :socket))
290
291 #+armedbear
292 (defun socket-connect (port host)
293 (declare (type integer port))
294 (handler-case
295 (ext:get-socket-stream (ext:make-socket host port)
296 :element-type '(unsigned-byte 8))
297 (error (e)
298 (error 'connection-failure
299 :host host
300 :port port
301 :transport-error e))))
302
303
304 ;; for Lispworks
305 ;; (defun encode-lisp-string (string)
306 ;; (translate-string-via-fli string :utf-8 :latin-1))
307 ;;
308 ;; (defun decode-external-string (string)
309 ;; (translate-string-via-fli string :latin-1 :utf-8))
310 ;;
311 ;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is
312 ;; ;; also null, and vice versa. So don't have to worry about
313 ;; ;; null-termination or length. (If we were translating to/from
314 ;; ;; :unicode, this would become an issue.)
315 ;;
316 ;; (defun translate-string-via-fli (string from to)
317 ;; (fli:with-foreign-string (ptr elements bytes :external-format from)
318 ;; string
319 ;; (declare (ignore elements bytes))
320 ;; (fli:convert-from-foreign-string ptr :external-format to)))
321
322
323 ;;; character encoding support
324
325 (defvar *pg-client-encoding*)
326
327 (defun implementation-name-for-encoding (encoding)
328 (%sysdep "client encoding to external format name"
329 #+(and clisp unicode)
330 (cond ((string-equal encoding "SQL_ASCII") charset:ascii)
331 ((string-equal encoding "LATIN1") charset:iso-8859-1)
332 ((string-equal encoding "LATIN9") charset:iso-8859-9)
333 ((string-equal encoding "UTF8") charset:utf-8)
334 (t (error "unknown encoding ~A" encoding)))
335 #+(and allegro ics)
336 (cond ((string-equal encoding "SQL_ASCII") :ascii)
337 ((string-equal encoding "LATIN1") :latin1)
338 ((string-equal encoding "LATIN9") :latin9)
339 ((string-equal encoding "UTF8") :utf8)
340 (t (error "unknown encoding ~A" encoding)))
341 #+(and sbcl sb-unicode)
342 (cond ((string-equal encoding "SQL_ASCII") :ascii)
343 ((string-equal encoding "LATIN1") :latin1)
344 ((string-equal encoding "LATIN9") :latin9)
345 ((string-equal encoding "UTF8") :utf8)
346 (t (error "unknown encoding ~A" encoding)))
347 #+(or cmu gcl ecl abcl openmcl)
348 nil))
349
350 (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
351 (declare (type string string))
352 (%sysdep "convert string to bytes"
353 #+(and clisp unicode)
354 (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
355 #+(and allegro ics)
356 (excl:string-to-octets string :null-terminate nil
357 :external-format (implementation-name-for-encoding encoding))
358 #+(and :sbcl :sb-unicode)
359 (sb-ext:string-to-octets string
360 :external-format (implementation-name-for-encoding encoding))
361 #+(or cmu gcl ecl abcl openmcl)
362 (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
363 (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
364 (map-into octets #'char-code string))
365 (error "Can't convert ~A string to octets" encoding))))
366
367 (defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
368 (declare (type (vector (unsigned-byte 8)) bytes))
369 (%sysdep "convert octet-array to string"
370 #+(and clisp unicode)
371 (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
372 #+(and allegro ics)
373 (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
374 #+(and :sbcl :sb-unicode)
375 (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
376 ;; for implementations that have no support for character
377 ;; encoding, we assume that the encoding is an octet-for-octet
378 ;; encoding, and convert directly
379 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl)
380 (let ((string (make-string (length bytes))))
381 (map-into string #'code-char bytes))))
382
383
384 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5