1 ;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: clit -*-
2 ;;; $Id: compat.lisp,v 1.2 2003/07/08 08:34:22 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 ((passive-socket :type fixnum
48 :initarg :passive-socket
49 :reader socket-os-fd)))
51 (defclass passive-socket (socket)
52 ((element-type :type (member signed-byte unsigned-byte base-char)
53 :initarg :element-type
59 (defmethod print-object ((passive-socket passive-socket) stream)
60 (print-unreadable-object (passive-socket stream :type t :identity nil)
61 (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
63 (defclass binary-socket-stream (comm:socket-stream) ())
64 (defclass input-binary-socket-stream (binary-socket-stream)())
65 (defclass output-binary-socket-stream (binary-socket-stream)())
66 (defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
69 (defun %socket-error-identifier (code)
73 (99 :address-not-available)
76 (103 :connection-aborted)
77 (104 :connection-reset)
78 (105 :no-buffer-space)
80 (110 :connection-timed-out)
81 (111 :connection-refused)
83 (113 :host-unreachable)
84 (otherwise :unknown)))
87 (defun %socket-error-identifier (code)
89 (10048 :address-in-use)
90 (10049 :address-not-available)
92 (10052 :network-reset)
93 (10053 :connection-aborted)
94 (10054 :connection-reset)
95 (10055 :no-buffer-space)
97 (10060 :connection-timed-out)
98 (10061 :connection-refused)
100 (10065 :host-unreachable)
101 (otherwise :unknown)))
103 (defun socket-error (stream error-code action format-string &rest format-args)
104 (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
105 (error 'socket-error :stream stream :code code
106 :identifier (if (keywordp error-code)
108 (%socket-error-identifier error-code))
110 :format-control "~A occured while doing socket IO (~?)"
111 :format-arguments (list 'socket-error format-string format-args))))
114 (defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
115 (apply #'socket-error stream error-code :IO format-string format-args))
117 (defmethod stream-input-available ((fd fixnum))
118 (comm::socket-listen fd))
120 (defmethod stream-input-available ((stream stream::os-file-handle-stream))
121 (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
123 (defmethod stream-input-available ((stream comm:socket-stream))
124 (or (comm::socket-listen (comm:socket-stream-socket stream))
127 (defmethod stream-input-available ((stream passive-socket))
128 (comm::socket-listen (socket-os-fd stream)))
130 (defun %new-passive-socket (local-port)
131 (multiple-value-bind (socket error-location error-code)
132 (comm::create-tcp-socket-for-service local-port)
133 (cond (socket socket)
134 (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
139 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
140 "Create, bind and listen to an inet socket on *:PORT.
141 setsockopt SO_REUSEADDR if :reuse is not nil"
142 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
146 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
147 (sb-bsd-sockets:socket-bind
148 socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
149 (sb-bsd-sockets:socket-listen socket 15)
152 (defun create-inet-listener (port &key (format :text) (reuse-address t))
153 #+cmu (ext:create-inet-listener port)
155 (socket:make-socket :connect :passive :local-port port :format :binary
159 (if (or (null port) (integerp port))
161 (error "illegal value for port: ~s" port)))
162 :reuse-address reuse-address)
164 (listen-to-inet-port :port port :reuse reuse-address)
165 #+clisp (ext:socket-server port)
167 (let ((comm::*use_so_reuseaddr* reuse-address))
168 (make-instance 'passive-socket
170 :passive-socket (%new-passive-socket port)
171 :element-type format))
174 (defun make-fd-stream (socket &key input output element-type)
176 (sys:make-fd-stream socket :input input :output output
177 :element-type element-type)
179 (sb-bsd-sockets:socket-make-stream socket :input input :output output
180 :element-type element-type)
181 #-(or cmu sbcl) (declare (ignore input output element-type))
182 #-(or cmu sbcl) socket
186 (defun accept-tcp-connection (listener)
189 (mp:process-wait-until-fd-usable listener :input)
191 (nth-value 0 (ext:accept-tcp-connection listener))
194 (when (sb-sys:wait-until-fd-usable
195 (sb-bsd-sockets:socket-file-descriptor listener) :input)
196 (sb-bsd-sockets:socket-make-stream
197 (sb-bsd-sockets:socket-accept listener)
198 :element-type 'base-char
201 (socket:accept-connection listener)
203 (ext:socket-accept listener)
205 (when (stream-input-available listener)
206 (make-instance 'bidirectional-binary-socket-stream
207 :socket (comm::get-fd-from-socket
208 (socket-os-fd passive-socket))
210 :element-type (element-type listener)))
215 (defmacro errorset (form display)
219 (declare (ignorable e))
221 (format t "~&Error: ~A~%" e)))))
223 (defun close-passive-socket (socket)
224 #+allegro (close socket)
225 #+cmu (unix:unix-close socket)
226 #+sbcl (sb-unix:unix-close
227 (sb-bsd-sockets:socket-file-descriptor socket))
228 #+clisp (close socket)
229 #+lispworks (comm::close-socket (socket-os-fd socket))
233 (defun close-active-socket (socket)
237 (defun ipaddr-to-dotted (ipaddr &key values)
238 "Convert from 32-bit integer to dotted string."
239 (declare (type (unsigned-byte 32) ipaddr))
240 (let ((a (logand #xff (ash ipaddr -24)))
241 (b (logand #xff (ash ipaddr -16)))
242 (c (logand #xff (ash ipaddr -8)))
243 (d (logand #xff ipaddr)))
246 (format nil "~d.~d.~d.~d" a b c d))))
249 (defun dotted-to-ipaddr (dotted &key (errorp t))
250 "Convert from dotted string to 32-bit integer."
251 (declare (string dotted))
253 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
254 (+ (ash (first ll) 24) (ash (second ll) 16)
255 (ash (third ll) 8) (fourth ll)))
257 (let ((ll (string-tokens (substitute #\Space #\. dotted))))
258 (+ (ash (first ll) 24) (ash (second ll) 16)
259 (ash (third ll) 8) (fourth ll))))))
262 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
264 (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
265 (sb-bsd-sockets:host-ent-name
266 (sb-bsd-sockets:get-host-by-address
267 (sb-bsd-sockets:make-inet-address ipaddr))))
270 (defun lookup-hostname (host &key ignore-cache)
272 (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
274 (sb-bsd-sockets:host-ent-address
275 (sb-bsd-sockets:get-host-by-name host))
276 (dotted-to-ipaddr (ipaddr-to-dotted host))))
279 (defun make-active-socket (server port)
280 #+allegro (socket:make-socket :remote-host server
282 #+lispworks (comm:open-tcp-stream server port)
283 #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
286 (sb-bsd-sockets:socket-connect
287 socket (lookup-hostname server) port)
288 (sb-bsd-sockets:socket-make-stream socket
291 :element-type 'base-char))
293 (sys:make-fd-stream (ext:connect-to-inet-socket host port)
294 :input t :output t :element-type 'base-char)