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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Sun Jul 17 15:46:32 2005 UTC (8 years, 9 months ago) by emarsden
Branch: MAIN
Changes since 1.8: +5 -5 lines
Use the updated MD5 code, that operates on octet arrays rather than
strings.
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.8 ;;; Time-stamp: <2005-07-17 emarsden>
5 emarsden 1.2 ;;
6     ;;
7 emarsden 1.1
8 emarsden 1.2 (in-package :postgresql)
9 emarsden 1.1
10     (eval-when (:compile-toplevel :load-toplevel :execute)
11     #+allegro (require :socket)
12     #+lispworks (require "comm")
13     #+cormanlisp (require :sockets)
14 emarsden 1.9 #+sbcl (require :sb-bsd-sockets)
15 emarsden 1.1 #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
16    
17    
18 emarsden 1.6 (defmacro %sysdep (desc &rest forms)
19     (when (null forms)
20     (error "No system dependent code to ~A" desc))
21     (car forms))
22    
23    
24 emarsden 1.1 #+(and cmu glibc2)
25     (eval-when (:compile-toplevel :load-toplevel)
26     (format t ";; Loading libcrypt~%")
27     ;; (ext:load-foreign "/lib/libcrypt.so.1")
28     (sys::load-object-file "/usr/lib/libcrypt.so"))
29    
30     #+(and cmu glibc2)
31     (defun crypt (key salt)
32     (declare (type string key salt))
33     (alien:alien-funcall
34     (alien:extern-alien "crypt"
35     (function c-call:c-string c-call:c-string c-call:c-string))
36     key salt))
37    
38     #-(and cmu glibc2)
39     (defun crypt (key salt)
40     (declare (ignore salt))
41     key)
42 emarsden 1.5
43    
44     (defun md5-digest (string &rest strings)
45     (declare (type simple-string string))
46 emarsden 1.9 (let ((vec (md5sum-sequence
47     (map '(vector (unsigned-byte 8)) #'char-code
48     (apply #'concatenate 'string string strings)))))
49 emarsden 1.5 (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 emarsden 1.1
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 emarsden 1.4 #+(and db-sockets broken)
135 emarsden 1.1 (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 emarsden 1.3 (error 'connection-failure
182 emarsden 1.1 :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 emarsden 1.3 (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 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.3 (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 emarsden 1.1
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     #+ecl
265     (defun socket-connect (port host)
266     (declare (type integer port))
267 emarsden 1.3 (handler-case
268     (si:open-client-stream host port)
269     (error (e)
270     (error 'connection-failure
271     :host host
272     :port port
273     :transport-error e))))
274 emarsden 1.1
275    
276    
277     ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
278     ;; work, DEFINE-CONDITION not implemented, ...
279     #+gcl
280     (defun socket-connect (port host)
281     (declare (type integer port))
282     (si::socket port :host host))
283    
284    
285 emarsden 1.4
286     #+armedbear
287     (eval-when (:load-toplevel :execute :compile-toplevel)
288     (require 'format))
289    
290     ;; MAKE-SOCKET with :element-type as per 2004-03-09
291 emarsden 1.1 #+armedbear
292     (defun socket-connect (port host)
293     (declare (type integer port))
294 emarsden 1.3 (handler-case
295 emarsden 1.4 (ext:make-socket host port :element-type '(unsigned-byte 8))
296 emarsden 1.3 (error (e)
297     (error 'connection-failure
298     :host host
299     :port port
300     :transport-error e))))
301 emarsden 1.6
302    
303    
304     ;;; character encoding support
305    
306     (defvar *pg-client-encoding*)
307    
308 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
309     (defun sbcl-ext-form-from-client-encoding (encoding)
310     (cond
311     ((string= encoding "SQL_ASCII") :ascii)
312     ((string= encoding "LATIN1") :latin1)
313     ((string= encoding "LATIN9") :latin9)
314     ((string= encoding "UNICODE") :utf8)
315     (t (error "unkown encoding ~A" encoding))))
316    
317 emarsden 1.6 (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
318     (declare (type string string))
319     (%sysdep "convert string to bytes"
320     #+(and clisp unicode)
321     (ext:convert-string-to-bytes string encoding)
322 emarsden 1.8 #+(and allegro ics)
323     (excl:string-to-octets string :null-terminate nil
324     :external-format encoding)
325 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
326     (sb-ext:string-to-octets string :external-format (sbcl-ext-form-from-client-encoding encoding))
327 emarsden 1.6 #+(or cmu sbcl gcl ecl)
328     (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
329     (map-into octets #'char-code string))))
330    
331     (defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
332     (declare (type (vector (unsigned-byte 8)) bytes))
333     (%sysdep "convert octet-array to string"
334     #+(and clisp unicode)
335     (ext:convert-string-from-bytes bytes encoding)
336 emarsden 1.8 #+(and allegro ics)
337     (excl:octets-to-string bytes :external-format encoding)
338 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
339     (sb-ext:octets-to-string bytes :external-format encoding)
340 emarsden 1.6 ;; for implementations that have no support for character
341     ;; encoding, we assume that the encoding is an octet-for-octet
342     ;; encoding, and convert directly
343 pvaneynde 1.7 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl)
344 emarsden 1.6 (let ((string (make-string (length bytes))))
345     (map-into string #'code-char bytes))))
346 emarsden 1.1
347    
348     ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5