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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Tue Oct 18 13:07:27 2005 UTC (8 years, 6 months ago) by pvaneynde
Branch: MAIN
Changes since 1.9: +2 -8 lines
Modified sbcl unicode support, works for me.
Moved requires into asdf package, otherwise we get asdf package problems, unknown if it works with other lisps
1 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2 ;;;
3 ;;; Author: Eric Marsden <eric.marsden@free.fr>
4 ;;; Time-stamp: <2005-07-17 emarsden>
5 ;;
6 ;;
7
8 (in-package :postgresql)
9
10
11 (defmacro %sysdep (desc &rest forms)
12 (when (null forms)
13 (error "No system dependent code to ~A" desc))
14 (car forms))
15
16
17 #+(and cmu glibc2)
18 (eval-when (:compile-toplevel :load-toplevel)
19 (format t ";; Loading libcrypt~%")
20 ;; (ext:load-foreign "/lib/libcrypt.so.1")
21 (sys::load-object-file "/usr/lib/libcrypt.so"))
22
23 #+(and cmu glibc2)
24 (defun crypt (key salt)
25 (declare (type string key salt))
26 (alien:alien-funcall
27 (alien:extern-alien "crypt"
28 (function c-call:c-string c-call:c-string c-call:c-string))
29 key salt))
30
31 #-(and cmu glibc2)
32 (defun crypt (key salt)
33 (declare (ignore salt))
34 key)
35
36
37 (defun md5-digest (string &rest strings)
38 (declare (type simple-string string))
39 (let ((vec (md5sum-sequence
40 (map '(vector (unsigned-byte 8)) #'char-code
41 (apply #'concatenate 'string string strings)))))
42 (format nil "~(~{~2,'0X~}~)" (coerce vec 'list))))
43
44 (defun md5-encode-password (user password salt)
45 (concatenate 'string "md5"
46 (md5-digest (md5-digest password user) salt)))
47
48
49
50 ;; this is a little fiddly, because CLISP can be built without support
51 ;; for the Linux package
52 ;; #+CLISP
53 ;; (defun crypt (key salt)
54 ;; (linux::crypt key salt))
55
56
57 ;; bug in WRITE-SEQUENCE in CMUCL
58 #+(or cmu18c cmu18d)
59 (defun write-sequence (seq stream &key start end)
60 (declare (ignore start end))
61 (loop :for element :across seq
62 :do (write-byte element stream)))
63
64
65
66 ;; work around bug in FASL fop dumping
67 #+cmu (setf c::top-level-lambda-max 0)
68
69
70 #+(and cmu ssl)
71 (defun socket-connect (port host)
72 (declare (type integer port))
73 (handler-case
74 (let ((fd (ext:connect-to-inet-socket host port)))
75 (ssl:make-ssl-client-stream fd))
76 (error (e)
77 (error 'connection-failure
78 :host host
79 :port port
80 :transport-error e))))
81
82
83 #+cmu
84 (defun socket-connect (port host)
85 (declare (type integer port))
86 (handler-case
87 (let ((fd (if host
88 (ext:connect-to-inet-socket host port)
89 (ext:connect-to-unix-socket
90 (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))
91 (sys:make-fd-stream fd :input t :output t
92 :element-type '(unsigned-byte 8)))
93 (error (e)
94 (error 'connection-failure
95 :host host
96 :port port
97 :transport-error e))))
98
99 ;; this doesn't currently work, because WRITE-SEQUENCE is not
100 ;; implemented
101 #+(and cmu simple-streams broken)
102 (defun socket-connect (port host)
103 (declare (type integer port))
104 (handler-case
105 (make-instance 'stream:socket-simple-stream
106 :remote-host host
107 :remote-port port
108 :direction :io)
109 (error (e)
110 (error 'connection-failure
111 :host host
112 :port port
113 :transport-error e))))
114
115 #+clisp
116 (defun socket-connect (port host)
117 (declare (type integer port))
118 (handler-case
119 (#+lisp=cl socket:socket-connect
120 #-lisp=cl lisp:socket-connect
121 port host :element-type '(unsigned-byte 8))
122 (error (e)
123 (declare (ignore e))
124 (error 'connection-failure :host host :port port))))
125
126
127 #+(and db-sockets broken)
128 (defun socket-connect (port host)
129 (declare (type integer port))
130 (handler-case
131 (let ((s (sockets:make-inet-socket :stream :tcp))
132 (num (car (sockets:host-ent-addresses
133 (sockets:get-host-by-name host)))))
134 (sockets:socket-connect s num port)
135 (sockets:socket-make-stream s :element-type '(unsigned-byte 8)
136 :input t :output t :buffering :none))
137 (error (e)
138 (error 'connection-failure
139 :host host
140 :port port
141 :transport-error e))))
142
143 #+sbcl
144 (defun socket-connect (port host)
145 (declare (type integer port))
146 (handler-case
147 (sb-bsd-sockets:socket-make-stream
148 (if host
149 (let ((s (make-instance 'sb-bsd-sockets:inet-socket
150 :type :stream :protocol :tcp))
151 (num (car (sb-bsd-sockets:host-ent-addresses
152 (sb-bsd-sockets:get-host-by-name host)))))
153 (sb-bsd-sockets:socket-connect s num port)
154 s)
155 (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
156 (sb-bsd-sockets:socket-connect
157 s (format nil "/var/run/postgresql/.s.PGSQL.~D" port))
158 s))
159 :element-type '(unsigned-byte 8)
160 :input t
161 :output t
162 :buffering :none)
163 (error (e)
164 (error 'connection-failure :host host :port port :transport-error e))))
165
166 #+allegro
167 (defun socket-connect (port host)
168 (declare (type integer port))
169 (handler-case
170 (socket:make-socket :remote-host host
171 :remote-port port
172 :format :binary)
173 (error (e)
174 (error 'connection-failure
175 :host host
176 :port port
177 :transport-error e))))
178
179 ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
180 ;; streams. Fixed in version 4.3.
181 #+lispworks
182 (defun socket-connect (port host)
183 (declare (type integer port))
184 (handler-case
185 (comm:open-tcp-stream host port
186 :element-type '(unsigned-byte 8)
187 :direction :io)
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 (handler-case
214 (if host
215 (make-socket :address-family :internet
216 :type :stream
217 :connect :active
218 :format :binary
219 :remote-host host
220 :remote-port port)
221 (make-socket :address-family :file
222 :type :stream
223 :connect :active
224 :format :binary
225 :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
226 (error (e)
227 (error 'connection-failure
228 :host host
229 :port port
230 :transport-error e))))
231
232 ;; from John DeSoi
233 #+(and mcl (not openmcl))
234 (defun socket-connect (port host)
235 (declare (type integer port))
236 (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
237
238 ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
239 ;; write-sequence fail with binary tcp streams. These two methods
240 ;; provide a work-around.
241 #+(and mcl (not openmcl))
242 (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
243 (sequence ccl::simple-unsigned-byte-vector)
244 &key (start 0) end)
245 (ccl::stream-write-vector s sequence start (or end (length sequence)))
246 s)
247
248 #+(and mcl (not openmcl))
249 (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
250 (sequence ccl::simple-unsigned-byte-vector)
251 &key (start 0) (end (length sequence)))
252 (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
253 sequence (- end start) start)
254 end)
255
256
257 #+ecl
258 (defun socket-connect (port host)
259 (declare (type integer port))
260 (handler-case
261 (si:open-client-stream host port)
262 (error (e)
263 (error 'connection-failure
264 :host host
265 :port port
266 :transport-error e))))
267
268
269
270 ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
271 ;; work, DEFINE-CONDITION not implemented, ...
272 #+gcl
273 (defun socket-connect (port host)
274 (declare (type integer port))
275 (si::socket port :host host))
276
277
278
279 #+armedbear
280 (eval-when (:load-toplevel :execute :compile-toplevel)
281 (require 'format))
282
283 ;; MAKE-SOCKET with :element-type as per 2004-03-09
284 #+armedbear
285 (defun socket-connect (port host)
286 (declare (type integer port))
287 (handler-case
288 (ext:make-socket host port :element-type '(unsigned-byte 8))
289 (error (e)
290 (error 'connection-failure
291 :host host
292 :port port
293 :transport-error e))))
294
295
296
297 ;;; character encoding support
298
299 (defvar *pg-client-encoding*)
300
301 #+(and :sbcl :sb-unicode)
302 (defun sbcl-ext-form-from-client-encoding (encoding)
303 (cond
304 ((string= encoding "SQL_ASCII") :ascii)
305 ((string= encoding "LATIN1") :latin1)
306 ((string= encoding "LATIN9") :latin9)
307 ((string= encoding "UNICODE") :utf8)
308 (t (error "unkown encoding ~A" encoding))))
309
310 (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
311 (declare (type string string))
312 (%sysdep "convert string to bytes"
313 #+(and clisp unicode)
314 (ext:convert-string-to-bytes string encoding)
315 #+(and allegro ics)
316 (excl:string-to-octets string :null-terminate nil
317 :external-format encoding)
318 #+(and :sbcl :sb-unicode)
319 (sb-ext:string-to-octets string :external-format (sbcl-ext-form-from-client-encoding encoding))
320 #+(or cmu sbcl gcl ecl)
321 (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
322 (map-into octets #'char-code string))))
323
324 (defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
325 (declare (type (vector (unsigned-byte 8)) bytes))
326 (%sysdep "convert octet-array to string"
327 #+(and clisp unicode)
328 (ext:convert-string-from-bytes bytes encoding)
329 #+(and allegro ics)
330 (excl:octets-to-string bytes :external-format encoding)
331 #+(and :sbcl :sb-unicode)
332 (sb-ext:octets-to-string bytes :external-format
333 (sbcl-ext-form-from-client-encoding encoding))
334 ;; for implementations that have no support for character
335 ;; encoding, we assume that the encoding is an octet-for-octet
336 ;; encoding, and convert directly
337 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl)
338 (let ((string (make-string (length bytes))))
339 (map-into string #'code-char bytes))))
340
341
342 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5