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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Mar 5 18:08:08 2004 UTC (10 years, 1 month ago) by emarsden
Branch: MAIN
Changes since 1.1: +7 -2 lines
Integrate Peter Van Eynde's v3 protocol support:

   - create PGCON-V2 and PGCON-V3 classes
   - PG-CONNECT attempts to connect using v3 protocol, and falls back
     to v2 protocol for older backends; return a PGCON-V2 or PGCON-V3
     object
   - PG-EXEC and FN and PG-DISCONNECT are generic functions that
     dispatch on the connection type
   - protocol code split into v2-protocol.lisp and v3-protocol.lisp

TBD: cleaning up the notification & error reporting support, and
factorizing more code between the two protocol versions.


Also split code out into multiple files:

   - large-object support
   - metainformation about databases
   - parsing and type coercion support
   - utility functions and macros
1 ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
2 ;;;
3 ;;; Author: Eric Marsden <emarsden@laas.fr>
4 ;;; Time-stamp: <2004-03-05 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 (signal '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 (comm:open-tcp-stream host port
173 :element-type '(unsigned-byte 8)
174 :direction :io))
175
176 ;; this doesn't work, since the Corman sockets module doesn't support
177 ;; binary I/O on socket streams.
178 #+cormanlisp
179 (defun socket-connect (port host)
180 (declare (type integer port))
181 (handler-case
182 (progn
183 (sockets:start-sockets)
184 (let ((sock (sockets:make-client-socket :host host :port port)))
185 (sockets:make-socket-stream sock)))
186 (error (e)
187 (declare (ignore e))
188 (error 'connection-failure :host host :port port))))
189
190 #+openmcl
191 (defun socket-connect (port host)
192 (declare (type integer port))
193 (let ((sock (make-socket :type :stream
194 :connect :active
195 :format :binary
196 :remote-host host
197 :remote-port port)))
198 sock))
199
200 ;; from John DeSoi
201 #+(and mcl (not openmcl))
202 (defun socket-connect (port host)
203 (declare (type integer port))
204 (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
205
206 ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
207 ;; write-sequence fail with binary tcp streams. These two methods
208 ;; provide a work-around.
209 #+(and mcl (not openmcl))
210 (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
211 (sequence ccl::simple-unsigned-byte-vector)
212 &key (start 0) end)
213 (ccl::stream-write-vector s sequence start (or end (length sequence)))
214 s)
215
216 #+(and mcl (not openmcl))
217 (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
218 (sequence ccl::simple-unsigned-byte-vector)
219 &key (start 0) (end (length sequence)))
220 (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
221 sequence (- end start) start)
222 end)
223
224
225 ;; there seems to be a bug in ECL's binary socket streams; data is corrupted
226 #+ecl
227 (defun socket-connect (port host)
228 (declare (type integer port))
229 (si:open-client-stream host port))
230
231 ;; #+ecl
232 ;; (defun write-sequence (seq stream &key start end)
233 ;; (declare (ignore start end))
234 ;; (loop :for element :across seq
235 ;; :do (write-byte element stream)))
236 ;;
237 ;; #+ecl
238 ;; (defun read-bytes (connection howmany)
239 ;; (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
240 ;; (s (pgcon-stream connection)))
241 ;; (loop :for pos :below howmany
242 ;; :do (setf (aref v pos) (read-byte s)))
243 ;; v))
244 ;;
245 ;; #+ecl
246 ;; (defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))
247 ;; (loop :for pos :from start :below end
248 ;; :do (setf (aref seq pos) (read-byte stream))))
249
250
251
252
253 ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
254 ;; work, DEFINE-CONDITION not implemented, ...
255 #+gcl
256 (defun socket-connect (port host)
257 (declare (type integer port))
258 (si::socket port :host host))
259
260
261 #+armedbear
262 (defun socket-connect (port host)
263 (declare (type integer port))
264 (ext:make-binary-socket host port))
265
266 #+armedbear
267 (defun cl:write-sequence (seq stream &key (start 0) (end (length seq)))
268 (declare (ignore start end))
269 (loop :for element :across seq
270 :do (write-byte element stream)))
271
272 #+armedbear
273 (defun read-bytes (connection howmany)
274 (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
275 (s (pgcon-stream connection)))
276 (loop :for pos :below howmany
277 :do (setf (aref v pos) (read-byte s)))
278 v))
279
280 #+armedbear
281 (defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))
282 (loop :for pos :from start :below end
283 :do (setf (aref seq pos) (read-byte stream))))
284
285 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5