[usocket-cvs] r260 - in usocket/branches/0.3.x: . backend
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Tue Jun 5 15:23:23 UTC 2007
Author: ehuelsmann
Date: Tue Jun 5 11:23:20 2007
New Revision: 260
Modified:
usocket/branches/0.3.x/backend/allegro.lisp
usocket/branches/0.3.x/backend/armedbear.lisp
usocket/branches/0.3.x/backend/clisp.lisp
usocket/branches/0.3.x/backend/cmucl.lisp
usocket/branches/0.3.x/backend/lispworks.lisp
usocket/branches/0.3.x/backend/openmcl.lisp
usocket/branches/0.3.x/backend/sbcl.lisp
usocket/branches/0.3.x/backend/scl.lisp
usocket/branches/0.3.x/usocket.lisp
Log:
Merge r236:245 and r258 (cl-smtp support and minor crash fix).
Modified: usocket/branches/0.3.x/backend/allegro.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/allegro.lisp (original)
+++ usocket/branches/0.3.x/backend/allegro.lisp Tue Jun 5 11:23:20 2007
@@ -6,7 +6,13 @@
(in-package :usocket)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (require :sock))
+ (require :sock)
+ ;; note: the line below requires ACL 6.2+
+ (require :osi))
+
+(defun get-host-name ()
+ ;; note: the line below requires ACL 7.0+ to actually *work* on windows
+ (excl.osi:gethostname))
(defparameter +allegro-identifier-error-map+
'((:address-in-use . address-in-use-error)
Modified: usocket/branches/0.3.x/backend/armedbear.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/armedbear.lisp (original)
+++ usocket/branches/0.3.x/backend/armedbear.lisp Tue Jun 5 11:23:20 2007
@@ -17,6 +17,14 @@
`(java:jnew (java:jconstructor ,class , at arg-spec)
, at args))
+(defun get-host-name ()
+ (let ((localAddress (java:jstatic
+ (java:jmethod "java.net.InetAddress"
+ "getLocalHost")
+ (java:jclass "java.net.InetAddress"))))
+ (java:jcall (java:jmethod "java.net.InetAddress" "getHostName")
+ localAddress)))
+
(defun handle-condition (condition &optional socket)
(typecase condition
(error (error 'unknown-error :socket socket :real-error condition))))
Modified: usocket/branches/0.3.x/backend/clisp.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/clisp.lisp (original)
+++ usocket/branches/0.3.x/backend/clisp.lisp Tue Jun 5 11:23:20 2007
@@ -6,6 +6,23 @@
(in-package :usocket)
+;; utility routine for looking up the current host name
+(FFI:DEF-CALL-OUT get-host-name-internal
+ (:name "gethostname")
+ (:arguments (name (FFI:C-PTR (FFI:C-ARRAY-MAX ffi:character 256))
+ :OUT :ALLOCA)
+ (len ffi:int))
+ #+win32 (:library "WS2_32")
+ (:return-type ffi:int))
+
+
+(defun get-host-name ()
+ (multiple-value-bind (retcode name)
+ (get-host-name-internal)
+ (when (= retcode 0)
+ name)))
+
+
#+win32
(defun remap-maybe-for-win32 (z)
(mapcar #'(lambda (x)
Modified: usocket/branches/0.3.x/backend/cmucl.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/cmucl.lisp (original)
+++ usocket/branches/0.3.x/backend/cmucl.lisp Tue Jun 5 11:23:20 2007
@@ -160,3 +160,5 @@
(lookup-host-entry name)))
(condition (condition) (handle-condition condition))))
+(defun get-host-name ()
+ (unix:unix-gethostname))
Modified: usocket/branches/0.3.x/backend/lispworks.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/lispworks.lisp (original)
+++ usocket/branches/0.3.x/backend/lispworks.lisp Tue Jun 5 11:23:20 2007
@@ -9,6 +9,22 @@
(require "comm"))
#+win32
+(fli:register-module "ws2_32")
+
+(fli:define-foreign-function (get-host-name-internal "gethostname" :source)
+ ((return-string (:reference-return (:ef-mb-string :limit 257)))
+ (namelen :int))
+ :lambda-list (&aux (namelen 256) return-string)
+ :result-type :int
+ #+win32 :module #+win32 "ws2_32")
+
+(defun get-host-name ()
+ (multiple-value-bind (retcode name)
+ (get-host-name-internal)
+ (when (= 0 retcode)
+ name)))
+
+#+win32
(defun remap-maybe-for-win32 (z)
(mapcar #'(lambda (x)
(cons (mapcar #'(lambda (y)
Modified: usocket/branches/0.3.x/backend/openmcl.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/openmcl.lisp (original)
+++ usocket/branches/0.3.x/backend/openmcl.lisp Tue Jun 5 11:23:20 2007
@@ -5,7 +5,10 @@
(in-package :usocket)
-
+(defun get-host-name ()
+ (ccl::%stack-block ((resultbuf 256))
+ (when (zerop (#_gethostname resultbuf 256))
+ (ccl::%get-cstring resultbuf))))
(defparameter +openmcl-error-map+
'((:address-in-use . address-in-use-error)
@@ -23,6 +26,35 @@
(:access-denied . operation-not-permitted-error)))
+;; we need something which the openmcl implementors 'forgot' to do:
+;; wait for more than one socket-or-fd
+
+(defun input-available-p (sockets &optional ticks-to-wait)
+ (ccl::rletZ ((tv :timeval))
+ (ccl::ticks-to-timeval ticks-to-wait tv)
+ (ccl::%stack-block ((infds ccl::*fd-set-size*)
+ (errfds ccl::*fd-set-size*))
+ (ccl::fd-zero infds)
+ (ccl::fd-zero errfds)
+ (dolist (sock sockets)
+ (ccl::fd-set (socket-os-fd sock infds))
+ (ccl::fd-set (socket-os-fd sock errfds)))
+ (let* ((res (ccl::syscall syscalls::select
+ (1+ (apply #'max fds))
+ infds (ccl::%null-ptr) errfds
+ (if ticks-to-wait tv (ccl::%null-ptr)))))
+ (when (> res 0)
+ (remove-if #'(lambda (x)
+ (not (ccl::fd-is-set (socket-os-fd x) infds)))
+ sockets))))))
+
+(defun wait-for-input (sockets &optional ticks-to-wait)
+ (let ((wait-end (when ticks-to-wait (+ ticks-to-wait (ccl::get-tick-count)))))
+ (do ((res (input-available-p sockets ticks-to-wait)
+ (input-available-p sockets ticks-to-wait)))
+ ((or res (< wait-end (ccl::get-tick-count)))
+ res))))
+
(defun raise-error-from-id (condition-id socket real-condition)
(let ((usock-err (cdr (assoc condition-id +openmcl-error-map+))))
(if usock-err
Modified: usocket/branches/0.3.x/backend/sbcl.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/sbcl.lisp (original)
+++ usocket/branches/0.3.x/backend/sbcl.lisp Tue Jun 5 11:23:20 2007
@@ -13,6 +13,49 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sockets))
+#+sbcl
+(progn
+ #-win32
+ (defun get-host-name ()
+ (sb-unix:unix-gethostname))
+
+ ;; we assume winsock has already been loaded, after all,
+ ;; we already loaded sb-bsd-sockets and sb-alien
+ #+win32
+ (defun get-host-name ()
+ (sb-alien:with-alien ((buf (sb-alien:array sb-alien:char 256)))
+ (let ((result (sb-alien:alien-funcall
+ (sb-alien:extern-alien "gethostname"
+ (sb-alien:function sb-alien:int
+ (* sb-alien:char)
+ sb-alien:int))
+ (sb-alien:cast buf (* sb-alien:char))
+ 256)))
+ (when (= result 0)
+ (cast buf sb-alien:c-string))))))
+
+
+#+ecl
+(progn
+ (ffi:clines
+ #-:wsock
+ "#include <sys/socket.h>"
+ #+:wsock
+ "#include <winsock2.h>"
+ )
+
+ (defun get-host-name ()
+ (ffi:c-inline
+ () () t
+ "{ char buf[256];
+ int r = gethostname(&buf,256);
+
+ if (r == 0)
+ @(return) = make_simple_base_string(&buf);
+ else
+ @(return) = Cnil;
+ }")))
+
(defun map-socket-error (sock-err)
(map-errno-error (sb-bsd-sockets::socket-error-errno sock-err)))
Modified: usocket/branches/0.3.x/backend/scl.lisp
==============================================================================
--- usocket/branches/0.3.x/backend/scl.lisp (original)
+++ usocket/branches/0.3.x/backend/scl.lisp Tue Jun 5 11:23:20 2007
@@ -129,3 +129,6 @@
(t
(error 'ns-unknown-error :host-or-ip name
:real-error errno))))))))
+
+(defun get-host-name ()
+ (unix:unix-gethostname))
Modified: usocket/branches/0.3.x/usocket.lisp
==============================================================================
--- usocket/branches/0.3.x/usocket.lisp (original)
+++ usocket/branches/0.3.x/usocket.lisp Tue Jun 5 11:23:20 2007
@@ -248,7 +248,8 @@
(defun get-random-host-by-name (name)
(let ((hosts (get-hosts-by-name name)))
- (elt hosts (random (length hosts)))))
+ (when hosts
+ (elt hosts (random (length hosts))))))
(defun host-to-vector-quad (host)
"Translate a host specification (vector quad, dotted quad or domain name)
More information about the usocket-cvs
mailing list