X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=sockets.lisp;h=f105501777be5e122c3cdf012c5c44ff6ca0b1e9;hp=a0d4472de2a8d6c334d3389fe0d7e5284e0ca59a;hb=ea921dd2ce51a46bb3ca92a07df095d5ace99dcf;hpb=0ddc73d14e764eeaede64f92b620a0c6de46cfd3

diff --git a/sockets.lisp b/sockets.lisp
index a0d4472..f105501 100644
--- a/sockets.lisp
+++ b/sockets.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg with excerpts from portableaserve
 ;;;; Date Started:  Jun 2003
 ;;;;
-;;;; $Id: sockets.lisp,v 1.2 2003/07/09 22:12:52 kevin Exp $
+;;;; $Id$
 ;;;; *************************************************************************
 
 (in-package #:kmrcl)
@@ -18,126 +18,6 @@
   #+allegro (require :socket))
 
 
-#+lispworks
-(progn
-  
-(define-condition lw-stream-error (error)
-  ((stream :initarg :stream
-           :reader stream-error-stream)
-   (action :initarg :action
-           :reader stream-error-action)
-   (code :initarg :code
-         :reader stream-error-code)
-   (identifier :initarg :identifier
-               :reader stream-error-identifier))
-  (:report (lambda (condition stream)
-             (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
-                     (stream-error-action condition)
-                     (stream-error-identifier condition)
-                     (stream-error-code condition)
-                     (stream-error-stream condition)))))
-
-(define-condition socket-error (lw-stream-error)
-  ()
-  (:report (lambda (condition stream)
-             (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
-                     (stream-error-action condition)
-                     (stream-error-identifier condition)
-                     (stream-error-code condition)
-                     (stream-error-stream condition)))))
-
-(defclass socket ()
-    ((passive-socket :type fixnum
-		     :initarg :passive-socket
-		     :reader socket-os-fd)))
-  
-  (defclass passive-socket (socket)
-    ((element-type :type (member signed-byte unsigned-byte base-char)
-		   :initarg :element-type
-		   :reader element-type)
-     (port :type fixnum
-	   :initarg :port
-	   :reader local-port)))
-
-  (defmethod print-object ((passive-socket passive-socket) stream)
-    (print-unreadable-object (passive-socket stream :type t :identity nil)
-      (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))
-
-  (defclass binary-socket-stream (comm:socket-stream) ())
-(defclass input-binary-socket-stream (binary-socket-stream)())
-(defclass output-binary-socket-stream (binary-socket-stream)())
-(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())
-
-#+unix
-(defun %socket-error-identifier (code)
-  (case code
-    (32 :x-broken-pipe)
-    (98 :address-in-use)
-    (99 :address-not-available)
-    (100 :network-down)
-    (102 :network-reset)
-    (103 :connection-aborted)
-    (104 :connection-reset)
-    (105 :no-buffer-space)
-    (108 :shutdown)
-    (110 :connection-timed-out)
-    (111 :connection-refused)
-    (112 :host-down)
-    (113 :host-unreachable)
-    (otherwise :unknown)))
-
-#+win32
-(defun %socket-error-identifier (code)
-  (case code
-    (10048 :address-in-use)
-    (10049 :address-not-available)
-    (10050 :network-down)
-    (10052 :network-reset)
-    (10053 :connection-aborted)
-    (10054 :connection-reset)
-    (10055 :no-buffer-space)
-    (10058 :shutdown)
-    (10060 :connection-timed-out)
-    (10061 :connection-refused)
-    (10064 :host-down)
-    (10065 :host-unreachable)
-    (otherwise :unknown)))
-
-(defun socket-error (stream error-code action format-string &rest format-args)
-  (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
-    (error 'socket-error :stream stream :code code
-           :identifier (if (keywordp error-code)
-                           error-code
-                         (%socket-error-identifier error-code))
-           :action action
-           :format-control "~A occured while doing socket IO (~?)"
-           :format-arguments (list 'socket-error format-string format-args))))
-
-
-(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
-  (apply #'socket-error stream error-code :IO format-string format-args))
-
-(defmethod stream-input-available ((fd fixnum))
-  (comm::socket-listen fd))
-
-(defmethod stream-input-available ((stream stream::os-file-handle-stream))
-  (stream-input-available (stream::os-file-handle-stream-file-handle stream)))
-
-(defmethod stream-input-available ((stream comm:socket-stream))
-  (or (comm::socket-listen (comm:socket-stream-socket stream))
-      (listen stream)))
-
-(defmethod stream-input-available ((stream passive-socket))
-  (comm::socket-listen (socket-os-fd stream)))
-
-(defun %new-passive-socket (local-port)
-  (multiple-value-bind (socket error-location error-code)
-      (comm::create-tcp-socket-for-service local-port)
-    (cond (socket socket)
-	  (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))
-
-) ;; lispworks
-
 #+sbcl
 (defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
   "Create, bind and listen to an inet socket on *:PORT.
@@ -155,7 +35,7 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 (defun create-inet-listener (port &key (format :text) (reuse-address t))
   #+cmu (ext:create-inet-listener port)
   #+allegro
-  (socket:make-socket :connect :passive :local-port port :format :binary
+  (socket:make-socket :connect :passive :local-port port :format format
 		      :address-family 
 		      (if (stringp port)
 			  :file
@@ -166,13 +46,11 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
   #+sbcl
   (listen-to-inet-port :port port :reuse reuse-address)
   #+clisp (ext:socket-server port)
-  #+lispworks
-  (let ((comm::*use_so_reuseaddr* reuse-address))
-    (make-instance 'passive-socket
-		   :port port
-		   :passive-socket (%new-passive-socket port)
-		   :element-type (case format
-				   (:text 'base-char))))
+  #+openmcl 
+  (ccl:make-socket :connect :passive :local-port port
+		   :reuse-address reuse-address)
+  #-(or allegro clisp cmu sbcl openmcl)
+  (warn "create-inet-listener not supported on this implementation")
   )
 
 (defun make-fd-stream (socket &key input output element-type)
@@ -188,33 +66,31 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 
 (defun accept-tcp-connection (listener)
+  "Returns (VALUES stream socket)"
+  #+allegro
+  (let ((sock (socket:accept-connection listener)))
+    (values sock sock))
+  #+clisp
+  (let ((sock (ext:socket-accept listener)))
+    (values sock sock))
   #+cmu
   (progn
     (mp:process-wait-until-fd-usable listener :input)
-    (sys:make-fd-stream
-     (nth-value 0 (ext:accept-tcp-connection listener))
-     :input t :output t))
+    (let ((sock (nth-value 0 (ext:accept-tcp-connection listener))))
+      (values (sys:make-fd-stream sock :input t :output t) sock)))
   #+sbcl
   (when (sb-sys:wait-until-fd-usable
 	 (sb-bsd-sockets:socket-file-descriptor listener) :input)
-    (sb-bsd-sockets:socket-make-stream 
-     (sb-bsd-sockets:socket-accept listener)
-     :element-type 'base-char
-     :input t :output t))
-  #+allegro
-  (socket:accept-connection listener)
-  #+clisp
-  (ext:socket-accept listener)
-  #+lispworks
-  (progn
-    (loop while (not (stream-input-available listener))
-	  do (sleep 1))
-    (make-instance 'bidirectional-binary-socket-stream
-		   :socket (comm::get-fd-from-socket
-			    (socket-os-fd listener))
-		   :direction :io
-		   :element-type (element-type listener)))
-    
+    (let ((sock (sb-bsd-sockets:socket-accept listener)))
+      (values
+       (sb-bsd-sockets:socket-make-stream
+	sock :element-type 'base-char :input t :output t)
+       sock)))
+  #+openmcl 
+  (let ((sock (ccl:accept-connection listener :wait t)))
+    (values sock sock))
+  #-(or allegro clisp cmu sbcl openmcl)
+  (warn "accept-tcp-connection not supported on this implementation")
   )
 
 
@@ -228,18 +104,19 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 (defun close-passive-socket (socket)
   #+allegro (close socket)
+  #+clisp (close socket)
   #+cmu (unix:unix-close socket)
   #+sbcl (sb-unix:unix-close
 	  (sb-bsd-sockets:socket-file-descriptor socket))
-  #+clisp (close socket)
-  #+lispworks (comm::close-socket (socket-os-fd socket))
+  #+openmcl (close socket)
+  #-(or allegro clisp cmu sbcl openmcl)
+  (warn "close-passive-socket not supported on this implementation")
   )
 
 
 (defun close-active-socket (socket)
   (close socket))
 
-#+sbcl
 (defun ipaddr-to-dotted (ipaddr &key values)
   "Convert from 32-bit integer to dotted string."
   (declare (type (unsigned-byte 32) ipaddr))
@@ -251,18 +128,17 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 	(values a b c d)
       (format nil "~d.~d.~d.~d" a b c d))))
 
-#+sbcl
 (defun dotted-to-ipaddr (dotted &key (errorp t))
   "Convert from dotted string to 32-bit integer."
   (declare (string dotted))
   (if errorp
-      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
+      (let ((ll (delimited-string-to-list dotted #\.)))
 	(+ (ash (first ll) 24) (ash (second ll) 16)
 	   (ash (third ll) 8) (fourth ll)))
     (ignore-errors
-	(let ((ll (string-tokens (substitute #\Space #\. dotted))))
-	  (+ (ash (first ll) 24) (ash (second ll) 16)
-	     (ash (third ll) 8) (fourth ll))))))
+      (let ((ll (delimited-string-to-list dotted #\.)))
+	(+ (ash (first ll) 24) (ash (second ll) 16)
+	   (ash (third ll) 8) (fourth ll))))))
 
 #+sbcl
 (defun ipaddr-to-hostname (ipaddr &key ignore-cache)
@@ -283,19 +159,45 @@ setsockopt SO_REUSEADDR if :reuse is not nil"
 
 
 (defun make-active-socket (server port)
-  #+allegro (socket:make-socket :remote-host server
-				:remote-port port)
-  #+lispworks (comm:open-tcp-stream server port)
-  #+sbcl (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
-				      :type :stream
-				      :protocol :tcp)))
-	   (sb-bsd-sockets:socket-connect
-	    socket (lookup-hostname server) port)
-	   (sb-bsd-sockets:socket-make-stream socket
-					      :input t
-					      :output t
-					      :element-type 'base-char))
-  #+cmu 
-  (sys:make-fd-stream (ext:connect-to-inet-socket host port)
-		      :input t :output t :element-type 'base-char)
+  "Returns (VALUES STREAM SOCKET)"
+  #+allegro
+  (let ((sock (socket:make-socket :remote-host server
+				  :remote-port port)))
+    (values sock sock))
+  #+lispworks
+  (let ((sock (comm:open-tcp-stream server port)))
+    (values sock sock))
+  #+sbcl
+  (let ((sock (make-instance 'sb-bsd-sockets:inet-socket
+			     :type :stream
+			     :protocol :tcp)))
+    (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
+    (values
+     (sb-bsd-sockets:socket-make-stream
+      sock :input t :output t :element-type 'base-char)
+     sock))
+  #+cmu
+  (let ((sock (ext:connect-to-inet-socket server port)))
+    (values
+     (sys:make-fd-stream sock :input t :output t :element-type 'base-char)
+     sock))
+  #+openmcl
+  (let ((sock (ccl:make-socket :remote-host server :remote-port port )))
+    (values sock sock))
+  )
+
+(defun ipaddr-array-to-dotted (array)
+  (format nil "~{~D~^.~}" (coerce array 'list))
+  #+ignore
+  (format nil "~D.~D.~D.~D" 
+	  (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
+
+(defun remote-host (socket)
+  #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
+  #+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
+  #+sbcl (ipaddr-array-to-dotted 
+	  (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
+  #+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
+  #+openmcl (ccl:remote-host socket)
   )
+