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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5