1 ;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: clit -*-
2 ;;; $Id: compat.lisp,v 1.3 2003/07/08 12:10:16 kevin Exp $
8 (defun make-process (name func)
9 #+cmu (mp:make-process func :name name)
10 #+allegro (mp:process-run-function name func)
11 #+lispworks (mp:process-run-function name nil func)
12 #+sb-thread (sb-thread:make-thread func)
13 #+clisp (funcall func)
16 (defun destroy-process (process)
17 #+cmu (mp:destroy-process process)
18 #+allegro (mp:process-kill process)
19 #+sbcl-thread (sb-thread:destroy-thread process)
20 #+lispworks (mp:process-kill process)
23 (defun make-lock (name)
24 #+allegro (mp:make-process-lock :name name)
25 #+cmu (mp:make-lock name)
26 #+lispworks (mp:make-lock :name name)
27 #+sbcl-thread (sb-thread:make-mutex :name name)
30 (defmacro with-lock-held ((lock) &body body)
32 `(mp:with-process-lock (,lock) ,@body)
34 `(mp:with-lock-held (,lock) ,@body)
36 `(mp:with-lock (,lock) ,@body)
38 `(sb-thread:with-recursive-lock (,lock) ,@body)
47 (define-condition lw-stream-error (error)
48 ((stream :initarg :stream
49 :reader stream-error-stream)
50 (action :initarg :action
51 :reader stream-error-action)
53 :reader stream-error-code)
54 (identifier :initarg :identifier
55 :reader stream-error-identifier))
56 (:report (lambda (condition stream)
57 (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
58 (stream-error-action condition)
59 (stream-error-identifier condition)
60 (stream-error-code condition)
61 (stream-error-stream condition)))))
63 (define-condition socket-error (lw-stream-error)
65 (:report (lambda (condition stream)
66 (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
67 (stream-error-action condition)
68 (stream-error-identifier condition)
69 (stream-error-code condition)
70 (stream-error-stream condition)))))
73 ((passive-socket :type fixnum
74 :initarg :passive-socket
75 :reader socket-os-fd)))
77 (defclass passive-socket (socket)
78 ((element-type :type (member signed-byte unsigned-byte base-char)
79 :initarg :element-type
85 (defmethod print-object ((passive-socket passive-socket) stream)
86 (print-unreadable-object (passive-socket stream :type t :identity nil)
87 (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
89 (defclass binary-socket-stream (comm:socket-stream) ())
90 (defclass input-binary-socket-stream (binary-socket-stream)())
91 (defclass output-binary-socket-stream (binary-socket-stream)())
92 (defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
95 (defun %socket-error-identifier (code)
99 (99 :address-not-available)
102 (103 :connection-aborted)
103 (104 :connection-reset)
104 (105 :no-buffer-space)
106 (110 :connection-timed-out)
107 (111 :connection-refused)
109 (113 :host-unreachable)
110 (otherwise :unknown)))
113 (defun %socket-error-identifier (code)
115 (10048 :address-in-use)
116 (10049 :address-not-available)
117 (10050 :network-down)
118 (10052 :network-reset)
119 (10053 :connection-aborted)
120 (10054 :connection-reset)
121 (10055 :no-buffer-space)
123 (10060 :connection-timed-out)
124 (10061 :connection-refused)
126 (10065 :host-unreachable)
127 (otherwise :unknown)))
129 (defun socket-error (stream error-code action format-string &rest format-args)
130 (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
131 (error 'socket-error :stream stream :code code
132 :identifier (if (keywordp error-code)
134 (%socket-error-identifier error-code))
136 :format-control "~A occured while doing socket IO (~?)"
137 :format-arguments (list 'socket-error format-string format-args))))
140 (defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
141 (apply #'socket-error stream error-code :IO format-string format-args))
143 (defmethod stream-input-available ((fd fixnum))
144 (comm::socket-listen fd))
146 (defmethod stream-input-available ((stream stream::os-file-handle-stream))
147 (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
149 (defmethod stream-input-available ((stream comm:socket-stream))
150 (or (comm::socket-listen (comm:socket-stream-socket stream))
153 (defmethod stream-input-available ((stream passive-socket))
154 (comm::socket-listen (socket-os-fd stream)))
156 (defun %new-passive-socket (local-port)
157 (multiple-value-bind (socket error-location error-code)
158 (comm::create-tcp-socket-for-service local-port)
159 (cond (socket socket)
160 (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
165 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
166 "Create, bind and listen to an inet socket on *:PORT.
167 setsockopt SO_REUSEADDR if :reuse is not nil"
168 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
172 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
173 (sb-bsd-sockets:socket-bind
174 socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
175 (sb-bsd-sockets:socket-listen socket 15)
178 (defun create-inet-listener (port &key (format :text) (reuse-address t))
179 #+cmu (ext:create-inet-listener port)
181 (socket:make-socket :connect :passive :local-port port :format :binary
185 (if (or (null port) (integerp port))
187 (error "illegal value for port: ~s" port)))
188 :reuse-address reuse-address)
190 (listen-to-inet-port :port port :reuse reuse-address)
191 #+clisp (ext:socket-server port)
193 (let ((comm::*use_so_reuseaddr* reuse-address))
194 (make-instance 'passive-socket
196 :passive-socket (%new-passive-socket port)
197 :element-type (case format
198 (:text 'base-char))))
201 (defun make-fd-stream (socket &key input output element-type)
203 (sys:make-fd-stream socket :input input :output output
204 :element-type element-type)
206 (sb-bsd-sockets:socket-make-stream socket :input input :output output
207 :element-type element-type)
208 #-(or cmu sbcl) (declare (ignore input output element-type))
209 #-(or cmu sbcl) socket
213 (defun accept-tcp-connection (listener)
216 (mp:process-wait-until-fd-usable listener :input)
218 (nth-value 0 (ext:accept-tcp-connection listener))
221 (when (sb-sys:wait-until-fd-usable
222 (sb-bsd-sockets:socket-file-descriptor listener) :input)
223 (sb-bsd-sockets:socket-make-stream
224 (sb-bsd-sockets:socket-accept listener)
225 :element-type 'base-char
228 (socket:accept-connection listener)
230 (ext:socket-accept listener)
233 (loop while (not (stream-input-available listener))
235 (make-instance 'bidirectional-binary-socket-stream
236 :socket (comm::get-fd-from-socket
237 (socket-os-fd listener))
239 :element-type (element-type listener)))
244 (defmacro errorset (form display)
248 (declare (ignorable e))
250 (format t "~&Error: ~A~%" e)))))
252 (defun close-passive-socket (socket)
253 #+allegro (close socket)
254 #+cmu (unix:unix-close socket)
255 #+sbcl (sb-unix:unix-close
256 (sb-bsd-sockets:socket-file-descriptor socket))
257 #+clisp (close socket)
258 #+lispworks (comm::close-socket (socket-os-fd socket))
262 (defun close-active-socket (socket)
266 (defun ipaddr-to-dotted (ipaddr &key values)
267 "Convert from 32-bit integer to dotted string."
268 (declare (type (unsigned-byte 32) ipaddr))
269 (let ((a (logand #xff (ash ipaddr -24)))
270 (b (logand #xff (ash ipaddr -16)))
271 (c (logand #xff (ash ipaddr -8)))
272 (d (logand #xff ipaddr)))
275 (format nil "~d.~d.~d.~d" a b c d))))
278 (defun dotted-to-ipaddr (dotted &key (errorp t))
279 "Convert from dotted string to 32-bit integer."
280 (declare (string dotted))
282 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
283 (+ (ash (first ll) 24) (ash (second ll) 16)
284 (ash (third ll) 8) (fourth ll)))
286 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
287 (+ (ash (first ll) 24) (ash (second ll) 16)
288 (ash (third ll) 8) (fourth ll))))))
291 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
293 (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
294 (sb-bsd-sockets:host-ent-name
295 (sb-bsd-sockets:get-host-by-address
296 (sb-bsd-sockets:make-inet-address ipaddr))))
299 (defun lookup-hostname (host &key ignore-cache)
301 (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
303 (sb-bsd-sockets:host-ent-address
304 (sb-bsd-sockets:get-host-by-name host))
305 (dotted-to-ipaddr (ipaddr-to-dotted host))))
308 (defun make-active-socket (server port)
309 #+allegro (socket:make-socket :remote-host server
311 #+lispworks (comm:open-tcp-stream server port)
312 #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
315 (sb-bsd-sockets:socket-connect
316 socket (lookup-hostname server) port)
317 (sb-bsd-sockets:socket-make-stream socket
320 :element-type 'base-char))
322 (sys:make-fd-stream (ext:connect-to-inet-socket host port)
323 :input t :output t :element-type 'base-char)