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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Sat Sep 30 16:51:12 2006 UTC (7 years, 6 months ago) by emarsden
Branch: MAIN
Changes since 1.16: +19 -9 lines
Add unix-domain socket support for Allegro CL (tested with Express
edition for Linux/x86).
1 emarsden 1.2 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2     ;;;
3 emarsden 1.9 ;;; Author: Eric Marsden <eric.marsden@free.fr>
4 emarsden 1.17 ;;; Time-stamp: <2006-09-30 emarsden>
5 emarsden 1.2 ;;
6     ;;
7 emarsden 1.1
8 emarsden 1.2 (in-package :postgresql)
9 emarsden 1.1
10 emarsden 1.15 (eval-when (:compile-toplevel :load-toplevel :execute)
11     #+lispworks (require "comm")
12     #+cormanlisp (require :sockets)
13     #+armedbear (require :socket))
14 emarsden 1.11
15 emarsden 1.1
16 emarsden 1.6 (defmacro %sysdep (desc &rest forms)
17     (when (null forms)
18     (error "No system dependent code to ~A" desc))
19     (car forms))
20    
21    
22 emarsden 1.1 #+(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 emarsden 1.5
41    
42     (defun md5-digest (string &rest strings)
43     (declare (type simple-string string))
44 emarsden 1.9 (let ((vec (md5sum-sequence
45     (map '(vector (unsigned-byte 8)) #'char-code
46     (apply #'concatenate 'string string strings)))))
47 emarsden 1.5 (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 emarsden 1.1
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 emarsden 1.15 (let ((host (if (typep host 'pathname)
92     (namestring host)
93     host)))
94     (handler-case
95     (let ((fd (if (eql #\/ (char host 0))
96     (ext:connect-to-unix-socket
97     (format nil "~A.s.PGSQL.~D" (string host) port))
98     (ext:connect-to-inet-socket host port))))
99     (sys:make-fd-stream fd :input t :output t
100     :element-type '(unsigned-byte 8)))
101     (error (e)
102     (error 'connection-failure
103     :host host
104     :port port
105     :transport-error e)))))
106 emarsden 1.1
107     ;; this doesn't currently work, because WRITE-SEQUENCE is not
108     ;; implemented
109     #+(and cmu simple-streams broken)
110     (defun socket-connect (port host)
111     (declare (type integer port))
112     (handler-case
113     (make-instance 'stream:socket-simple-stream
114     :remote-host host
115     :remote-port port
116     :direction :io)
117     (error (e)
118     (error 'connection-failure
119     :host host
120     :port port
121     :transport-error e))))
122    
123     #+clisp
124     (defun socket-connect (port host)
125     (declare (type integer port))
126     (handler-case
127     (#+lisp=cl socket:socket-connect
128     #-lisp=cl lisp:socket-connect
129 emarsden 1.16 port host
130     :element-type '(unsigned-byte 8)
131     :buffered t)
132 emarsden 1.1 (error (e)
133     (declare (ignore e))
134     (error 'connection-failure :host host :port port))))
135    
136    
137     #+sbcl
138 emarsden 1.12 (defun socket-connect (port host-name)
139 emarsden 1.1 (declare (type integer port))
140 emarsden 1.12 (let ((host (if (typep host-name 'pathname)
141     (namestring host-name)
142     host-name)))
143     (handler-case
144     (sb-bsd-sockets:socket-make-stream
145     (if (eql #\/ (char host 0))
146     (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
147     (sb-bsd-sockets:socket-connect
148     s (format nil "~A.s.PGSQL.~D" (string host) port))
149     s)
150     (let ((s (make-instance 'sb-bsd-sockets:inet-socket
151     :type :stream :protocol :tcp))
152     (num (car (sb-bsd-sockets:host-ent-addresses
153     (sb-bsd-sockets:get-host-by-name host)))))
154     (sb-bsd-sockets:socket-connect s num port)
155     s))
156     :element-type '(unsigned-byte 8)
157     :input t
158     :output t
159     :buffering :none)
160     (error (e)
161     (error 'connection-failure :host host :port port :transport-error e)))))
162 emarsden 1.1
163     #+allegro
164     (defun socket-connect (port host)
165     (declare (type integer port))
166     (handler-case
167 emarsden 1.17 (if (eql #\/ (char host 0))
168     (socket:make-socket :type :stream
169     :address-family :file
170     :connect :active
171     ;; :local-filename (format nil "~A.s.PGSQL.~D" (string host) port)
172     :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port)
173     :format :binary)
174     (socket:make-socket :remote-host host
175     :remote-port port
176     :connect :active
177     :format :binary))
178     (error (e)
179 emarsden 1.3 (error 'connection-failure
180 emarsden 1.17 :host host
181     :port port
182     :transport-error e))))
183 emarsden 1.1
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 emarsden 1.3 (handler-case
190     (comm:open-tcp-stream host port
191     :element-type '(unsigned-byte 8)
192     :direction :io)
193 emarsden 1.15 ;; note that Lispworks (at least 4.3) does not signal an error if
194     ;; the hostname cannot be resolved; it simply returns NIL
195 emarsden 1.3 (error (e)
196     (error 'connection-failure
197     :host host
198     :port port
199     :transport-error e))))
200 emarsden 1.1
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 emarsden 1.3 (error 'connection-failure
213     :host host
214     :port port
215     :transport-error e))))
216 emarsden 1.1
217     #+openmcl
218     (defun socket-connect (port host)
219     (declare (type integer port))
220 emarsden 1.15 (let ((host (if (typep host 'pathname)
221     (namestring host)
222     host)))
223     (handler-case
224     (if (eql #\/ (char host 0))
225     (make-socket :address-family :file
226     :type :stream
227     :connect :active
228     :format :binary
229     :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port))
230     (make-socket :address-family :internet
231     :type :stream
232     :connect :active
233     :format :binary
234     :remote-host host
235     :remote-port port))
236     (error (e)
237     (error 'connection-failure
238     :host host
239     :port port
240     :transport-error e)))))
241 emarsden 1.1
242     ;; from John DeSoi
243     #+(and mcl (not openmcl))
244     (defun socket-connect (port host)
245     (declare (type integer port))
246     (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
247    
248     ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
249     ;; write-sequence fail with binary tcp streams. These two methods
250     ;; provide a work-around.
251     #+(and mcl (not openmcl))
252     (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
253     (sequence ccl::simple-unsigned-byte-vector)
254     &key (start 0) end)
255     (ccl::stream-write-vector s sequence start (or end (length sequence)))
256     s)
257    
258     #+(and mcl (not openmcl))
259     (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
260     (sequence ccl::simple-unsigned-byte-vector)
261     &key (start 0) (end (length sequence)))
262     (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
263     sequence (- end start) start)
264     end)
265    
266    
267     #+ecl
268     (defun socket-connect (port host)
269     (declare (type integer port))
270 emarsden 1.3 (handler-case
271     (si:open-client-stream host port)
272     (error (e)
273     (error 'connection-failure
274     :host host
275     :port port
276     :transport-error e))))
277 emarsden 1.1
278    
279    
280     ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
281     ;; work, DEFINE-CONDITION not implemented, ...
282     #+gcl
283     (defun socket-connect (port host)
284     (declare (type integer port))
285     (si::socket port :host host))
286    
287    
288 emarsden 1.4
289     #+armedbear
290     (eval-when (:load-toplevel :execute :compile-toplevel)
291 emarsden 1.11 (require :socket))
292 emarsden 1.4
293 emarsden 1.17 ;; could provide support for connections via a unix-domain socket by
294     ;; using http://freshmeat.net/projects/j-buds/ (requires linking to a
295     ;; shared libary)
296 emarsden 1.1 #+armedbear
297     (defun socket-connect (port host)
298     (declare (type integer port))
299 emarsden 1.11 (handler-case
300     (ext:get-socket-stream (ext:make-socket host port)
301     :element-type '(unsigned-byte 8))
302 emarsden 1.3 (error (e)
303     (error 'connection-failure
304     :host host
305     :port port
306     :transport-error e))))
307 emarsden 1.6
308    
309 emarsden 1.11 ;; for Lispworks
310     ;; (defun encode-lisp-string (string)
311     ;; (translate-string-via-fli string :utf-8 :latin-1))
312     ;;
313     ;; (defun decode-external-string (string)
314     ;; (translate-string-via-fli string :latin-1 :utf-8))
315     ;;
316     ;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is
317     ;; ;; also null, and vice versa. So don't have to worry about
318     ;; ;; null-termination or length. (If we were translating to/from
319     ;; ;; :unicode, this would become an issue.)
320     ;;
321     ;; (defun translate-string-via-fli (string from to)
322     ;; (fli:with-foreign-string (ptr elements bytes :external-format from)
323     ;; string
324     ;; (declare (ignore elements bytes))
325     ;; (fli:convert-from-foreign-string ptr :external-format to)))
326    
327 emarsden 1.6
328     ;;; character encoding support
329    
330     (defvar *pg-client-encoding*)
331    
332 emarsden 1.11 (defun implementation-name-for-encoding (encoding)
333 emarsden 1.15 (%sysdep "convert from client encoding to external format name"
334 emarsden 1.11 #+(and clisp unicode)
335 emarsden 1.14 (cond ((string-equal encoding "SQL_ASCII") charset:ascii)
336     ((string-equal encoding "LATIN1") charset:iso-8859-1)
337     ((string-equal encoding "LATIN9") charset:iso-8859-9)
338     ((string-equal encoding "UTF8") charset:utf-8)
339 emarsden 1.11 (t (error "unknown encoding ~A" encoding)))
340     #+(and allegro ics)
341 emarsden 1.14 (cond ((string-equal encoding "SQL_ASCII") :ascii)
342     ((string-equal encoding "LATIN1") :latin1)
343     ((string-equal encoding "LATIN9") :latin9)
344     ((string-equal encoding "UTF8") :utf8)
345 emarsden 1.11 (t (error "unknown encoding ~A" encoding)))
346     #+(and sbcl sb-unicode)
347 emarsden 1.14 (cond ((string-equal encoding "SQL_ASCII") :ascii)
348     ((string-equal encoding "LATIN1") :latin1)
349     ((string-equal encoding "LATIN9") :latin9)
350     ((string-equal encoding "UTF8") :utf8)
351 emarsden 1.11 (t (error "unknown encoding ~A" encoding)))
352 emarsden 1.15 #+(or cmu gcl ecl abcl openmcl lispworks)
353 emarsden 1.13 nil))
354 emarsden 1.11
355 emarsden 1.6 (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
356     (declare (type string string))
357 emarsden 1.15 (%sysdep "convert string to octet-array"
358 emarsden 1.6 #+(and clisp unicode)
359 emarsden 1.11 (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
360 emarsden 1.8 #+(and allegro ics)
361     (excl:string-to-octets string :null-terminate nil
362 emarsden 1.11 :external-format (implementation-name-for-encoding encoding))
363 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
364 emarsden 1.11 (sb-ext:string-to-octets string
365     :external-format (implementation-name-for-encoding encoding))
366 emarsden 1.15 #+(or cmu gcl ecl abcl openmcl lispworks)
367 emarsden 1.11 (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
368     (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
369     (map-into octets #'char-code string))
370     (error "Can't convert ~A string to octets" encoding))))
371 emarsden 1.6
372     (defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
373     (declare (type (vector (unsigned-byte 8)) bytes))
374     (%sysdep "convert octet-array to string"
375     #+(and clisp unicode)
376 emarsden 1.11 (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
377 emarsden 1.8 #+(and allegro ics)
378 emarsden 1.11 (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
379 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
380 emarsden 1.11 (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
381 emarsden 1.6 ;; for implementations that have no support for character
382     ;; encoding, we assume that the encoding is an octet-for-octet
383     ;; encoding, and convert directly
384 emarsden 1.15 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl lispworks)
385 emarsden 1.6 (let ((string (make-string (length bytes))))
386     (map-into string #'code-char bytes))))
387 emarsden 1.1
388    
389     ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5