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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Mar 8 18:12:45 2004 UTC (10 years, 1 month ago) by emarsden
Branch: MAIN
Changes since 1.2: +47 -53 lines
  - improvements to the system-dependent functionality: OpenMCL is
    able to use a local connection to the backend; most
    implementations resignal connection errors as a postgres-error.

  - fixes to the lowlevel code
1 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2 ;;;
3 ;;; Author: Eric Marsden <emarsden@laas.fr>
4 ;;; Time-stamp: <2004-03-08 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))
15 #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))
16
17
18 #+(and cmu glibc2)
19 (eval-when (:compile-toplevel :load-toplevel)
20 (format t ";; Loading libcrypt~%")
21 ;; (ext:load-foreign "/lib/libcrypt.so.1")
22 (sys::load-object-file "/usr/lib/libcrypt.so"))
23
24 #+(and cmu glibc2)
25 (defun crypt (key salt)
26 (declare (type string key salt))
27 (alien:alien-funcall
28 (alien:extern-alien "crypt"
29 (function c-call:c-string c-call:c-string c-call:c-string))
30 key salt))
31
32 #-(and cmu glibc2)
33 (defun crypt (key salt)
34 (declare (ignore salt))
35 key)
36
37
38 ;; this is a little fiddly, because CLISP can be built without support
39 ;; for the Linux package
40 ;; #+CLISP
41 ;; (defun crypt (key salt)
42 ;; (linux::crypt key salt))
43
44
45 ;; bug in WRITE-SEQUENCE in CMUCL
46 #+(or cmu18c cmu18d)
47 (defun write-sequence (seq stream &key start end)
48 (declare (ignore start end))
49 (loop :for element :across seq
50 :do (write-byte element stream)))
51
52
53
54 ;; work around bug in FASL fop dumping
55 #+cmu (setf c::top-level-lambda-max 0)
56
57
58 #+(and cmu ssl)
59 (defun socket-connect (port host)
60 (declare (type integer port))
61 (handler-case
62 (let ((fd (ext:connect-to-inet-socket host port)))
63 (ssl:make-ssl-client-stream fd))
64 (error (e)
65 (error 'connection-failure
66 :host host
67 :port port
68 :transport-error e))))
69
70
71 #+cmu
72 (defun socket-connect (port host)
73 (declare (type integer port))
74 (handler-case
75 (let ((fd (if host
76 (ext:connect-to-inet-socket host port)
77 (ext:connect-to-unix-socket
78 (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))
79 (sys:make-fd-stream fd :input t :output t
80 :element-type '(unsigned-byte 8)))
81 (error (e)
82 (error 'connection-failure
83 :host host
84 :port port
85 :transport-error e))))
86
87 ;; this doesn't currently work, because WRITE-SEQUENCE is not
88 ;; implemented
89 #+(and cmu simple-streams broken)
90 (defun socket-connect (port host)
91 (declare (type integer port))
92 (handler-case
93 (make-instance 'stream:socket-simple-stream
94 :remote-host host
95 :remote-port port
96 :direction :io)
97 (error (e)
98 (error 'connection-failure
99 :host host
100 :port port
101 :transport-error e))))
102
103 #+clisp
104 (defun socket-connect (port host)
105 (declare (type integer port))
106 (handler-case
107 (#+lisp=cl socket:socket-connect
108 #-lisp=cl lisp:socket-connect
109 port host :element-type '(unsigned-byte 8))
110 (error (e)
111 (declare (ignore e))
112 (error 'connection-failure :host host :port port))))
113
114
115 #+db-sockets
116 (defun socket-connect (port host)
117 (declare (type integer port))
118 (handler-case
119 (let ((s (sockets:make-inet-socket :stream :tcp))
120 (num (car (sockets:host-ent-addresses
121 (sockets:get-host-by-name host)))))
122 (sockets:socket-connect s num port)
123 (sockets:socket-make-stream s :element-type '(unsigned-byte 8)
124 :input t :output t :buffering :none))
125 (error (e)
126 (error 'connection-failure
127 :host host
128 :port port
129 :transport-error e))))
130
131 #+sbcl
132 (defun socket-connect (port host)
133 (declare (type integer port))
134 (handler-case
135 (sb-bsd-sockets:socket-make-stream
136 (if host
137 (let ((s (make-instance 'sb-bsd-sockets:inet-socket
138 :type :stream :protocol :tcp))
139 (num (car (sb-bsd-sockets:host-ent-addresses
140 (sb-bsd-sockets:get-host-by-name host)))))
141 (sb-bsd-sockets:socket-connect s num port)
142 s)
143 (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
144 (sb-bsd-sockets:socket-connect
145 s (format nil "/var/run/postgresql/.s.PGSQL.~D" port))
146 s))
147 :element-type '(unsigned-byte 8)
148 :input t
149 :output t
150 :buffering :none)
151 (error (e)
152 (error 'connection-failure :host host :port port :transport-error e))))
153
154 #+allegro
155 (defun socket-connect (port host)
156 (declare (type integer port))
157 (handler-case
158 (socket:make-socket :remote-host host
159 :remote-port port
160 :format :binary)
161 (error (e)
162 (error 'connection-failure
163 :host host
164 :port port
165 :transport-error e))))
166
167 ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
168 ;; streams. Fixed in version 4.3.
169 #+lispworks
170 (defun socket-connect (port host)
171 (declare (type integer port))
172 (handler-case
173 (comm:open-tcp-stream host port
174 :element-type '(unsigned-byte 8)
175 :direction :io)
176 (error (e)
177 (error 'connection-failure
178 :host host
179 :port port
180 :transport-error e))))
181
182 ;; this doesn't work, since the Corman sockets module doesn't support
183 ;; binary I/O on socket streams.
184 #+cormanlisp
185 (defun socket-connect (port host)
186 (declare (type integer port))
187 (handler-case
188 (progn
189 (sockets:start-sockets)
190 (let ((sock (sockets:make-client-socket :host host :port port)))
191 (sockets:make-socket-stream sock)))
192 (error (e)
193 (error 'connection-failure
194 :host host
195 :port port
196 :transport-error e))))
197
198 #+openmcl
199 (defun socket-connect (port host)
200 (declare (type integer port))
201 (handler-case
202 (if host
203 (make-socket :address-family :internet
204 :type :stream
205 :connect :active
206 :format :binary
207 :remote-host host
208 :remote-port port)
209 (make-socket :address-family :file
210 :type :stream
211 :connect :active
212 :format :binary
213 :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
214 (error (e)
215 (error 'connection-failure
216 :host host
217 :port port
218 :transport-error e))))
219
220 ;; from John DeSoi
221 #+(and mcl (not openmcl))
222 (defun socket-connect (port host)
223 (declare (type integer port))
224 (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
225
226 ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
227 ;; write-sequence fail with binary tcp streams. These two methods
228 ;; provide a work-around.
229 #+(and mcl (not openmcl))
230 (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
231 (sequence ccl::simple-unsigned-byte-vector)
232 &key (start 0) end)
233 (ccl::stream-write-vector s sequence start (or end (length sequence)))
234 s)
235
236 #+(and mcl (not openmcl))
237 (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
238 (sequence ccl::simple-unsigned-byte-vector)
239 &key (start 0) (end (length sequence)))
240 (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
241 sequence (- end start) start)
242 end)
243
244
245 ;; there seems to be a bug in ECL's binary socket streams; data is corrupted
246 #+ecl
247 (defun socket-connect (port host)
248 (declare (type integer port))
249 (handler-case
250 (si:open-client-stream host port)
251 (error (e)
252 (error 'connection-failure
253 :host host
254 :port port
255 :transport-error e))))
256
257
258
259 ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
260 ;; work, DEFINE-CONDITION not implemented, ...
261 #+gcl
262 (defun socket-connect (port host)
263 (declare (type integer port))
264 (si::socket port :host host))
265
266
267 #+armedbear
268 (defun socket-connect (port host)
269 (declare (type integer port))
270 (handler-case
271 (ext:make-binary-socket host port)
272 (error (e)
273 (error 'connection-failure
274 :host host
275 :port port
276 :transport-error e))))
277
278
279 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5