compat.lisp

   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 $
   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
  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)
  52    (code :initarg :code
  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)))))
  62
  63 (define-condition socket-error (lw-stream-error)
  64   ()
  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)))))
  71
  72 (defclass socket ()
  73     ((passive-socket :type fixnum
  74                      :initarg :passive-socket
  75                      :reader socket-os-fd)))
  76
  77   (defclass passive-socket (socket)
  78     ((element-type :type (member signed-byte unsigned-byte base-char)
  79                    :initarg :element-type
  80                    :reader element-type)
  81      (port :type fixnum
  82            :initarg :port
  83            :reader local-port)))
  84
  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))))
  88
  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)())
  93
  94 #+unix
  95 (defun %socket-error-identifier (code)
  96   (case code
  97     (32 :x-broken-pipe)
  98     (98 :address-in-use)
  99     (99 :address-not-available)
 100     (100 :network-down)
 101     (102 :network-reset)
 102     (103 :connection-aborted)
 103     (104 :connection-reset)
 104     (105 :no-buffer-space)
 105     (108 :shutdown)
 106     (110 :connection-timed-out)
 107     (111 :connection-refused)
 108     (112 :host-down)
 109     (113 :host-unreachable)
 110     (otherwise :unknown)))
 111
 112 #+win32
 113 (defun %socket-error-identifier (code)
 114   (case 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)
 122     (10058 :shutdown)
 123     (10060 :connection-timed-out)
 124     (10061 :connection-refused)
 125     (10064 :host-down)
 126     (10065 :host-unreachable)
 127     (otherwise :unknown)))
 128
 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)
 133                            error-code
 134                          (%socket-error-identifier error-code))
 135            :action action
 136            :format-control "~A occured while doing socket IO (~?)"
 137            :format-arguments (list 'socket-error format-string format-args))))
 138
 139
 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))
 142
 143 (defmethod stream-input-available ((fd fixnum))
 144   (comm::socket-listen fd))
 145
 146 (defmethod stream-input-available ((stream stream::os-file-handle-stream))
 147   (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
 148
 149 (defmethod stream-input-available ((stream comm:socket-stream))
 150   (or (comm::socket-listen (comm:socket-stream-socket stream))
 151       (listen stream)))
 152
 153 (defmethod stream-input-available ((stream passive-socket))
 154   (comm::socket-listen (socket-os-fd stream)))
 155
 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)))))
 161
 162 ) ;; lispworks
 163
 164 #+sbcl
 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
 169                                :type :stream
 170                                :protocol :tcp)))
 171     (if reuse
 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)
 176     socket))
 177
 178 (defun create-inet-listener (port &key (format :text) (reuse-address t))
 179   #+cmu (ext:create-inet-listener port)
 180   #+allegro
 181   (socket:make-socket :connect :passive :local-port port :format :binary
 182                       :address-family
 183                       (if (stringp port)
 184                           :file
 185                         (if (or (null port) (integerp port))
 186                             :internet
 187                           (error "illegal value for port: ~s" port)))
 188                       :reuse-address reuse-address)
 189   #+sbcl
 190   (listen-to-inet-port :port port :reuse reuse-address)
 191   #+clisp (ext:socket-server port)
 192   #+lispworks
 193   (let ((comm::*use_so_reuseaddr* reuse-address))
 194     (make-instance 'passive-socket
 195                    :port port
 196                    :passive-socket (%new-passive-socket port)
 197                    :element-type (case format
 198                                    (:text 'base-char))))
 199   )
 200
 201 (defun make-fd-stream (socket &key input output element-type)
 202   #+cmu
 203   (sys:make-fd-stream socket :input input :output output
 204                       :element-type element-type)
 205   #+sbcl
 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
 210   )
 211
 212
 213 (defun accept-tcp-connection (listener)
 214   #+cmu
 215   (progn
 216     (mp:process-wait-until-fd-usable listener :input)
 217     (sys:make-fd-stream
 218      (nth-value 0 (ext:accept-tcp-connection listener))
 219      :input t :output t))
 220   #+sbcl
 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
 226      :input t :output t))
 227   #+allegro
 228   (socket:accept-connection listener)
 229   #+clisp
 230   (ext:socket-accept listener)
 231   #+lispworks
 232   (progn
 233     (loop while (not (stream-input-available listener))
 234           do (sleep 1))
 235     (make-instance 'bidirectional-binary-socket-stream
 236                    :socket (comm::get-fd-from-socket
 237                             (socket-os-fd listener))
 238                    :direction :io
 239                    :element-type (element-type listener)))
 240
 241   )
 242
 243
 244 (defmacro errorset (form display)
 245   `(handler-case
 246     ,form
 247     (error (e)
 248      (declare (ignorable e))
 249      (when ,display
 250        (format t "~&Error: ~A~%" e)))))
 251
 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))
 259   )
 260
 261
 262 (defun close-active-socket (socket)
 263   (close socket))
 264
 265 #+sbcl
 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)))
 273     (if values
 274         (values a b c d)
 275       (format nil "~d.~d.~d.~d" a b c d))))
 276
 277 #+sbcl
 278 (defun dotted-to-ipaddr (dotted &key (errorp t))
 279   "Convert from dotted string to 32-bit integer."
 280   (declare (string dotted))
 281   (if errorp
 282       (let ((ll (string-tokens (substitute #\Space #\. dotted))))
 283         (+ (ash (first ll) 24) (ash (second ll) 16)
 284            (ash (third ll) 8) (fourth ll)))
 285     (ignore-errors
 286         (let ((ll (string-tokens (substitute #\Space #\. dotted))))
 287           (+ (ash (first ll) 24) (ash (second ll) 16)
 288              (ash (third ll) 8) (fourth ll))))))
 289
 290 #+sbcl
 291 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
 292   (when 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))))
 297
 298 #+sbcl
 299 (defun lookup-hostname (host &key ignore-cache)
 300   (when ignore-cache
 301     (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
 302   (if (stringp host)
 303       (sb-bsd-sockets:host-ent-address
 304        (sb-bsd-sockets:get-host-by-name host))
 305       (dotted-to-ipaddr (ipaddr-to-dotted host))))
 306
 307
 308 (defun make-active-socket (server port)
 309   #+allegro (socket:make-socket :remote-host server
 310                                 :remote-port port)
 311   #+lispworks (comm:open-tcp-stream server port)
 312   #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
 313                                       :type :stream
 314                                       :protocol :tcp)))
 315            (sb-bsd-sockets:socket-connect
 316             socket (lookup-hostname server) port)
 317            (sb-bsd-sockets:socket-make-stream socket
 318                                               :input t
 319                                               :output t
 320                                               :element-type 'base-char))
 321   #+cmu
 322   (sys:make-fd-stream (ext:connect-to-inet-socket host port)
 323                       :input t :output t :element-type 'base-char)
 324   )