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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide 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 emarsden 1.2 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2     ;;;
3     ;;; Author: Eric Marsden <emarsden@laas.fr>
4 emarsden 1.6 ;;; Time-stamp: <2004-04-23 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.5 #+sbcl (progn (require :asdf) (require :sb-bsd-sockets) (require :sb-md5))
15 emarsden 1.1 #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
16    
17    
18 emarsden 1.6
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 emarsden 1.1 #+(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 emarsden 1.5
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 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     ;; 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 emarsden 1.3 (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 emarsden 1.1
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 emarsden 1.4
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 emarsden 1.1 #+armedbear
293     (defun socket-connect (port host)
294     (declare (type integer port))
295 emarsden 1.3 (handler-case
296 emarsden 1.4 (ext:make-socket host port :element-type '(unsigned-byte 8))
297 emarsden 1.3 (error (e)
298     (error 'connection-failure
299     :host host
300     :port port
301     :transport-error e))))
302 emarsden 1.6
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 emarsden 1.1
334    
335     ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5