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 ,@arg-spec) ,@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)