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

Contents of /pg/sysdep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Mon Sep 18 21:33:10 2006 UTC (7 years, 7 months ago) by emarsden
Branch: MAIN
Changes since 1.13: +13 -13 lines
Make comparison in IMPLEMENTATION-NAME-FOR-ENCODING case-insensitive
(from ya007@yandex.ru).
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.14 ;;; Time-stamp: <2006-09-18 emarsden>
5 emarsden 1.2 ;;
6     ;;
7 emarsden 1.1
8 emarsden 1.2 (in-package :postgresql)
9 emarsden 1.1
10 emarsden 1.11 #+allegro (require :socket)
11     #+lispworks (require "comm")
12     #+cormanlisp (require :sockets)
13     #+armedbear (require :socket)
14    
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     (handler-case
92     (let ((fd (if host
93     (ext:connect-to-inet-socket host port)
94     (ext:connect-to-unix-socket
95     (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))
96     (sys:make-fd-stream fd :input t :output t
97     :element-type '(unsigned-byte 8)))
98     (error (e)
99     (error 'connection-failure
100     :host host
101     :port port
102     :transport-error e))))
103    
104     ;; this doesn't currently work, because WRITE-SEQUENCE is not
105     ;; implemented
106     #+(and cmu simple-streams broken)
107     (defun socket-connect (port host)
108     (declare (type integer port))
109     (handler-case
110     (make-instance 'stream:socket-simple-stream
111     :remote-host host
112     :remote-port port
113     :direction :io)
114     (error (e)
115     (error 'connection-failure
116     :host host
117     :port port
118     :transport-error e))))
119    
120     #+clisp
121     (defun socket-connect (port host)
122     (declare (type integer port))
123     (handler-case
124     (#+lisp=cl socket:socket-connect
125     #-lisp=cl lisp:socket-connect
126     port host :element-type '(unsigned-byte 8))
127     (error (e)
128     (declare (ignore e))
129     (error 'connection-failure :host host :port port))))
130    
131    
132 emarsden 1.4 #+(and db-sockets broken)
133 emarsden 1.1 (defun socket-connect (port host)
134     (declare (type integer port))
135     (handler-case
136     (let ((s (sockets:make-inet-socket :stream :tcp))
137     (num (car (sockets:host-ent-addresses
138     (sockets:get-host-by-name host)))))
139     (sockets:socket-connect s num port)
140     (sockets:socket-make-stream s :element-type '(unsigned-byte 8)
141     :input t :output t :buffering :none))
142     (error (e)
143     (error 'connection-failure
144     :host host
145     :port port
146     :transport-error e))))
147    
148     #+sbcl
149 emarsden 1.12 (defun socket-connect (port host-name)
150 emarsden 1.1 (declare (type integer port))
151 emarsden 1.12 (let ((host (if (typep host-name 'pathname)
152     (namestring host-name)
153     host-name)))
154     (handler-case
155     (sb-bsd-sockets:socket-make-stream
156     (if (eql #\/ (char host 0))
157     (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
158     (sb-bsd-sockets:socket-connect
159     s (format nil "~A.s.PGSQL.~D" (string host) port))
160     s)
161     (let ((s (make-instance 'sb-bsd-sockets:inet-socket
162     :type :stream :protocol :tcp))
163     (num (car (sb-bsd-sockets:host-ent-addresses
164     (sb-bsd-sockets:get-host-by-name host)))))
165     (sb-bsd-sockets:socket-connect s num port)
166     s))
167     :element-type '(unsigned-byte 8)
168     :input t
169     :output t
170     :buffering :none)
171     (error (e)
172     (error 'connection-failure :host host :port port :transport-error e)))))
173 emarsden 1.1
174     #+allegro
175     (defun socket-connect (port host)
176     (declare (type integer port))
177     (handler-case
178     (socket:make-socket :remote-host host
179     :remote-port port
180     :format :binary)
181     (error (e)
182 emarsden 1.3 (error 'connection-failure
183 emarsden 1.1 :host host
184     :port port
185     :transport-error e))))
186    
187     ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
188     ;; streams. Fixed in version 4.3.
189     #+lispworks
190     (defun socket-connect (port host)
191     (declare (type integer port))
192 emarsden 1.3 (handler-case
193     (comm:open-tcp-stream host port
194     :element-type '(unsigned-byte 8)
195     :direction :io)
196     (error (e)
197     (error 'connection-failure
198     :host host
199     :port port
200     :transport-error e))))
201 emarsden 1.1
202     ;; this doesn't work, since the Corman sockets module doesn't support
203     ;; binary I/O on socket streams.
204     #+cormanlisp
205     (defun socket-connect (port host)
206     (declare (type integer port))
207     (handler-case
208     (progn
209     (sockets:start-sockets)
210     (let ((sock (sockets:make-client-socket :host host :port port)))
211     (sockets:make-socket-stream sock)))
212     (error (e)
213 emarsden 1.3 (error 'connection-failure
214     :host host
215     :port port
216     :transport-error e))))
217 emarsden 1.1
218     #+openmcl
219     (defun socket-connect (port host)
220     (declare (type integer port))
221 emarsden 1.3 (handler-case
222     (if host
223     (make-socket :address-family :internet
224     :type :stream
225     :connect :active
226     :format :binary
227     :remote-host host
228     :remote-port port)
229     (make-socket :address-family :file
230     :type :stream
231     :connect :active
232     :format :binary
233     :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))
234     (error (e)
235     (error 'connection-failure
236     :host host
237     :port port
238     :transport-error e))))
239 emarsden 1.1
240     ;; from John DeSoi
241     #+(and mcl (not openmcl))
242     (defun socket-connect (port host)
243     (declare (type integer port))
244     (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))
245    
246     ;; There is a bug in MCL (4.3.1 tested) where read-sequence and
247     ;; write-sequence fail with binary tcp streams. These two methods
248     ;; provide a work-around.
249     #+(and mcl (not openmcl))
250     (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
251     (sequence ccl::simple-unsigned-byte-vector)
252     &key (start 0) end)
253     (ccl::stream-write-vector s sequence start (or end (length sequence)))
254     s)
255    
256     #+(and mcl (not openmcl))
257     (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
258     (sequence ccl::simple-unsigned-byte-vector)
259     &key (start 0) (end (length sequence)))
260     (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
261     sequence (- end start) start)
262     end)
263    
264    
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 emarsden 1.11 (require :socket))
290 emarsden 1.4
291 emarsden 1.1 #+armedbear
292     (defun socket-connect (port host)
293     (declare (type integer port))
294 emarsden 1.11 (handler-case
295     (ext:get-socket-stream (ext:make-socket host port)
296     :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 emarsden 1.11 ;; for Lispworks
305     ;; (defun encode-lisp-string (string)
306     ;; (translate-string-via-fli string :utf-8 :latin-1))
307     ;;
308     ;; (defun decode-external-string (string)
309     ;; (translate-string-via-fli string :latin-1 :utf-8))
310     ;;
311     ;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is
312     ;; ;; also null, and vice versa. So don't have to worry about
313     ;; ;; null-termination or length. (If we were translating to/from
314     ;; ;; :unicode, this would become an issue.)
315     ;;
316     ;; (defun translate-string-via-fli (string from to)
317     ;; (fli:with-foreign-string (ptr elements bytes :external-format from)
318     ;; string
319     ;; (declare (ignore elements bytes))
320     ;; (fli:convert-from-foreign-string ptr :external-format to)))
321    
322 emarsden 1.6
323     ;;; character encoding support
324    
325     (defvar *pg-client-encoding*)
326    
327 emarsden 1.11 (defun implementation-name-for-encoding (encoding)
328     (%sysdep "client encoding to external format name"
329     #+(and clisp unicode)
330 emarsden 1.14 (cond ((string-equal encoding "SQL_ASCII") charset:ascii)
331     ((string-equal encoding "LATIN1") charset:iso-8859-1)
332     ((string-equal encoding "LATIN9") charset:iso-8859-9)
333     ((string-equal encoding "UTF8") charset:utf-8)
334 emarsden 1.11 (t (error "unknown encoding ~A" encoding)))
335     #+(and allegro ics)
336 emarsden 1.14 (cond ((string-equal encoding "SQL_ASCII") :ascii)
337     ((string-equal encoding "LATIN1") :latin1)
338     ((string-equal encoding "LATIN9") :latin9)
339     ((string-equal encoding "UTF8") :utf8)
340 emarsden 1.11 (t (error "unknown encoding ~A" encoding)))
341     #+(and sbcl sb-unicode)
342 emarsden 1.14 (cond ((string-equal encoding "SQL_ASCII") :ascii)
343     ((string-equal encoding "LATIN1") :latin1)
344     ((string-equal encoding "LATIN9") :latin9)
345     ((string-equal encoding "UTF8") :utf8)
346 emarsden 1.11 (t (error "unknown encoding ~A" encoding)))
347 emarsden 1.13 #+(or cmu gcl ecl abcl openmcl)
348     nil))
349 emarsden 1.11
350 emarsden 1.6 (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*))
351     (declare (type string string))
352     (%sysdep "convert string to bytes"
353     #+(and clisp unicode)
354 emarsden 1.11 (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
355 emarsden 1.8 #+(and allegro ics)
356     (excl:string-to-octets string :null-terminate nil
357 emarsden 1.11 :external-format (implementation-name-for-encoding encoding))
358 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
359 emarsden 1.11 (sb-ext:string-to-octets string
360     :external-format (implementation-name-for-encoding encoding))
361 emarsden 1.13 #+(or cmu gcl ecl abcl openmcl)
362 emarsden 1.11 (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
363     (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
364     (map-into octets #'char-code string))
365     (error "Can't convert ~A string to octets" encoding))))
366 emarsden 1.6
367     (defun convert-string-from-bytes (bytes &optional (encoding *pg-client-encoding*))
368     (declare (type (vector (unsigned-byte 8)) bytes))
369     (%sysdep "convert octet-array to string"
370     #+(and clisp unicode)
371 emarsden 1.11 (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
372 emarsden 1.8 #+(and allegro ics)
373 emarsden 1.11 (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
374 pvaneynde 1.7 #+(and :sbcl :sb-unicode)
375 emarsden 1.11 (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
376 emarsden 1.6 ;; for implementations that have no support for character
377     ;; encoding, we assume that the encoding is an octet-for-octet
378     ;; encoding, and convert directly
379 emarsden 1.13 #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl)
380 emarsden 1.6 (let ((string (make-string (length bytes))))
381     (map-into string #'code-char bytes))))
382 emarsden 1.1
383    
384     ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5