compat.lisp

   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 $
   3
   4 (in-package #:modlisp)
   5
   6 ;; Processes
   7
   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)
  14   )
  15
  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)
  21   )
  22
  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)
  28   )
  29
  30 (defmacro with-lock-held ((lock) &body body)
  31   #+allegro
  32   `(mp:with-process-lock (,lock) ,@body)
  33   #+cmu
  34   `(mp:with-lock-held (,lock) ,@body)
  35   #+lispworks
  36   `(mp:with-lock (,lock) ,@body)
  37   #+sbcl-thread
  38   `(sb-thread:with-recursive-lock (,lock) ,@body)
  39   )
  40
  41
  42 ;; Sockets
  43
  44 #+lispworks
  45 (progn
  46   (defclass socket ()
  47     ((passive-socket :type fixnum
  48                      :initarg :passive-socket
  49                      :reader socket-os-fd)))
  50
  51   (defclass passive-socket (socket)
  52     ((element-type :type (member signed-byte unsigned-byte base-char)
  53                    :initarg :element-type
  54                    :reader element-type)
  55      (port :type fixnum
  56            :initarg :port
  57            :reader local-port)))
  58
  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))))
  62
  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)())
  67
  68 #+unix
  69 (defun %socket-error-identifier (code)
  70   (case code
  71     (32 :x-broken-pipe)
  72     (98 :address-in-use)
  73     (99 :address-not-available)
  74     (100 :network-down)
  75     (102 :network-reset)
  76     (103 :connection-aborted)
  77     (104 :connection-reset)
  78     (105 :no-buffer-space)
  79     (108 :shutdown)
  80     (110 :connection-timed-out)
  81     (111 :connection-refused)
  82     (112 :host-down)
  83     (113 :host-unreachable)
  84     (otherwise :unknown)))
  85
  86 #+win32
  87 (defun %socket-error-identifier (code)
  88   (case code
  89     (10048 :address-in-use)
  90     (10049 :address-not-available)
  91     (10050 :network-down)
  92     (10052 :network-reset)
  93     (10053 :connection-aborted)
  94     (10054 :connection-reset)
  95     (10055 :no-buffer-space)
  96     (10058 :shutdown)
  97     (10060 :connection-timed-out)
  98     (10061 :connection-refused)
  99     (10064 :host-down)
 100     (10065 :host-unreachable)
 101     (otherwise :unknown)))
 102
 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)
 107                            error-code
 108                          (%socket-error-identifier error-code))
 109            :action action
 110            :format-control "~A occured while doing socket IO (~?)"
 111            :format-arguments (list 'socket-error format-string format-args))))
 112
 113
 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))
 116
 117 (defmethod stream-input-available ((fd fixnum))
 118   (comm::socket-listen fd))
 119
 120 (defmethod stream-input-available ((stream stream::os-file-handle-stream))
 121   (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
 122
 123 (defmethod stream-input-available ((stream comm:socket-stream))
 124   (or (comm::socket-listen (comm:socket-stream-socket stream))
 125       (listen stream)))
 126
 127 (defmethod stream-input-available ((stream passive-socket))
 128   (comm::socket-listen (socket-os-fd stream)))
 129
 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)))))
 135
 136 ) ;; lispworks
 137
 138 #+sbcl
 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
 143                                :type :stream
 144                                :protocol :tcp)))
 145     (if reuse
 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)
 150     socket))
 151
 152 (defun create-inet-listener (port &key (format :text) (reuse-address t))
 153   #+cmu (ext:create-inet-listener port)
 154   #+allegro
 155   (socket:make-socket :connect :passive :local-port port :format :binary
 156                       :address-family
 157                       (if (stringp port)
 158                           :file
 159                         (if (or (null port) (integerp port))
 160                             :internet
 161                           (error "illegal value for port: ~s" port)))
 162                       :reuse-address reuse-address)
 163   #+sbcl
 164   (listen-to-inet-port :port port :reuse reuse-address)
 165   #+clisp (ext:socket-server port)
 166   #+lispworks
 167   (let ((comm::*use_so_reuseaddr* reuse-address))
 168     (make-instance 'passive-socket
 169                    :port port
 170                    :passive-socket (%new-passive-socket port)
 171                    :element-type format))
 172   )
 173
 174 (defun make-fd-stream (socket &key input output element-type)
 175   #+cmu
 176   (sys:make-fd-stream socket :input input :output output
 177                       :element-type element-type)
 178   #+sbcl
 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
 183   )
 184
 185
 186 (defun accept-tcp-connection (listener)
 187   #+cmu
 188   (progn
 189     (mp:process-wait-until-fd-usable listener :input)
 190     (sys:make-fd-stream
 191      (nth-value 0 (ext:accept-tcp-connection listener))
 192      :input t :output t))
 193   #+sbcl
 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
 199      :input t :output t))
 200   #+allegro
 201   (socket:accept-connection listener)
 202   #+clisp
 203   (ext:socket-accept listener)
 204   #+lispworks
 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))
 209                    :direction :io
 210                    :element-type (element-type listener)))
 211
 212   )
 213
 214
 215 (defmacro errorset (form display)
 216   `(handler-case
 217     ,form
 218     (error (e)
 219      (declare (ignorable e))
 220      (when ,display
 221        (format t "~&Error: ~A~%" e)))))
 222
 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))
 230   )
 231
 232
 233 (defun close-active-socket (socket)
 234   (close socket))
 235
 236 #+sbcl
 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)))
 244     (if values
 245         (values a b c d)
 246       (format nil "~d.~d.~d.~d" a b c d))))
 247
 248 #+sbcl
 249 (defun dotted-to-ipaddr (dotted &key (errorp t))
 250   "Convert from dotted string to 32-bit integer."
 251   (declare (string dotted))
 252   (if errorp
 253       (let ((ll (string-tokens (substitute #\Space #\. dotted))))
 254         (+ (ash (first ll) 24) (ash (second ll) 16)
 255            (ash (third ll) 8) (fourth ll)))
 256     (ignore-errors
 257         (let ((ll (string-tokens (substitute #\Space #\. dotted))))
 258           (+ (ash (first ll) 24) (ash (second ll) 16)
 259              (ash (third ll) 8) (fourth ll))))))
 260
 261 #+sbcl
 262 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
 263   (when 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))))
 268
 269 #+sbcl
 270 (defun lookup-hostname (host &key ignore-cache)
 271   (when ignore-cache
 272     (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
 273   (if (stringp host)
 274       (sb-bsd-sockets:host-ent-address
 275        (sb-bsd-sockets:get-host-by-name host))
 276       (dotted-to-ipaddr (ipaddr-to-dotted host))))
 277
 278
 279 (defun make-active-socket (server port)
 280   #+allegro (socket:make-socket :remote-host server
 281                                 :remote-port port)
 282   #+lispworks (comm:open-tcp-stream server port)
 283   #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
 284                                       :type :stream
 285                                       :protocol :tcp)))
 286            (sb-bsd-sockets:socket-connect
 287             socket (lookup-hostname server) port)
 288            (sb-bsd-sockets:socket-make-stream socket
 289                                               :input t
 290                                               :output t
 291                                               :element-type 'base-char))
 292   #+cmu
 293   (sys:make-fd-stream (ext:connect-to-inet-socket host port)
 294                       :input t :output t :element-type 'base-char)
 295   )