Ignore:
Timestamp:
Sep 24, 2008, 2:19:49 PM (11 years ago)
Author:
gb
Message:

Get more of this working on windows, and use more modern/portable/reentrant
versions of host/address lookup functions.
(The latter changes haven't been tested on all platforms yet; easier
to do so after this is checked in.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-sockets.lisp

    r10787 r10865  
    227227
    228228#-windows-target
    229 (defun %hstrerror (h_errno)
    230   (with-macptrs ((p (#_hstrerror (abs h_errno))))
    231     (if p
    232       (%get-cstring p)
    233       (format nil "Nameserver error ~d" (abs h_errno)))))
     229(defun %gai-strerror (errno)
     230  (let* ((err (abs errno))
     231         (p (#_gai_strerror err)))
     232    (if (%null-ptr-p p)
     233      (format nil "Unknown nameserver error ~d" err)
     234      (%get-cstring p))))
    234235   
    235 
    236236
    237237
     
    256256                                              #-windows-target
    257257                                              (if nameserver-p
    258                                                 (%hstrerror errno)
     258                                                (%gai-strerror errno)
    259259                                                (%strerror errno))
    260260                                              errno where)))
     
    265265                           ;; TODO: this is a constant arg, there is a way to put this
    266266                           ;; in the class definition, just need to remember how...
    267                            :format-control "~a (error #~d) during socket creation in ~a"
     267                           :format-control "~a (error #~d) during socket creation or nameserver operation in ~a"
    268268                           :format-arguments (list
    269269                                              #+windows-target
     
    271271                                              #-windows-target
    272272                                              (if nameserver-p
    273                                                 (%hstrerror errno)
     273                                                (%gai-strerror errno)
    274274                                                (%strerror errno))
    275275                                              errno where)))))
     
    439439;;; entity when closing.
    440440
     441#-windows-target
    441442(defmethod close :before ((s file-listener-socket) &key abort)
    442443  (declare (ignore abort))
     
    542543  (local-socket-info (socket-device socket) :host socket))
    543544
     545#-windows-target
    544546(defmethod local-filename ((socket socket))
    545547  (local-socket-filename (socket-device socket) socket))
     
    561563  (remote-socket-info socket :port))
    562564
     565#-windows-target
    563566(defmethod remote-filename ((socket socket))
    564567  (remote-socket-filename socket))
     
    641644               (eq connect :passive)
    642645               local-filename)
    643       (bind-unix-socket fd local-filename))))
     646      #+windows-target (error "can't create file socket on Windows")
     647      #-windows-target (bind-unix-socket fd local-filename))))
    644648
    645649;; I hope the inline declaration makes the &rest/apply's go away...
     
    744748    (init-unix-sockaddr sockaddr remote-filename)
    745749    (%socket-connect fd sockaddr (record-length :sockaddr_un))))
    746          
     750
     751#+windows-target
     752(defun file-socket-connect (fd remote-filename)
     753  (declare (ignore fd))
     754  (error "Can't create file socket to ~s on Windows" remote-filename))
    747755 
    748756(defun make-tcp-stream-socket (fd &rest keys
     
    11021110      (c_setsockopt socket level optname valptr (record-length :signed)))))
    11031111
    1104 #+(or darwin-target linux-target)
    1105 (defloadvar *h-errno-variable-address* nil)
    1106 #+linux-target
    1107 (defloadvar *h-errno-function-address* nil)
    1108 
    1109 (defun h-errno-location ()
    1110   #+darwin-target
    1111   ;; As of Tiger, Darwin doesn't seem to have grasped the concept
    1112   ;; of thread-local storage for h_errno.
    1113   (or *h-errno-variable-address*
    1114       (setq *h-errno-variable-address* (foreign-symbol-address "_h_errno")))
    1115   ;; Supported versions of FreeBSD seem to have grasped that concept.
    1116   #+freebsd-target
    1117   (#_ __h_error)
    1118   #+linux-target
    1119   ;; Current versions of Linux support thread-specific h_errno,
    1120   ;; but older versions may not.
    1121   (if *h-errno-function-address*
    1122     (ff-call *h-errno-function-address* :address)
    1123     (or *h-errno-variable-address*
    1124         (let* ((entry (foreign-symbol-entry "__h_errno_location")))
    1125           (if entry
    1126             (ff-call (setq *h-errno-function-address* entry) :address)
    1127             (setq *h-errno-variable-address*
    1128                   (foreign-symbol-address  "h_errno")))))))
     1112
     1113
    11291114           
    1130 
    1131 #+(or darwin-target freebsd-target)
    1132 (defun c_gethostbyaddr (addr)
    1133   (rlet ((addrp :unsigned))
    1134     (setf (pref addrp :unsigned) addr)
    1135     (without-interrupts
    1136      (let* ((hp (#_gethostbyaddr addrp (record-length :unsigned) #$AF_INET)))
    1137        (declare (dynamic-extent hp))
    1138        (if (not (%null-ptr-p hp))
    1139          (%get-cstring (pref hp :hostent.h_name))
    1140          (values nil (pref (h-errno-location) :signed)))))))
    1141 
    1142 #+linux-target
    1143 (defun c_gethostbyaddr (addr)
    1144   (rlet ((hostent :hostent)
    1145          (hp (* (struct :hostent)))
    1146          (herr :signed)
    1147          (addrp :unsigned))
    1148     (setf (pref addrp :unsigned) addr)
    1149     (do* ((buflen 1024 (+ buflen buflen))) ()
    1150       (declare (fixnum buflen))
    1151       (%stack-block ((buf buflen))
    1152         (let* ((res (#_gethostbyaddr_r addrp (record-length :unsigned) #$AF_INET
    1153                                        hostent buf buflen hp herr)))
    1154           (declare (fixnum res))
    1155           (unless (eql res #$ERANGE)
    1156             (return
    1157              (if (and (eql res 0) (not (%null-ptr-p (%get-ptr hp))))
    1158                  (%get-cstring (pref (%get-ptr hp) :hostent.h_name))
    1159                (values nil (- (pref herr :signed)))))))))))
    1160 
    1161 #+solaris-target
    1162 (defun c_gethostbyaddr (addr)
    1163   (rlet ((hostent :hostent)
    1164          (herr :signed)
    1165          (addrp :unsigned))
    1166     (setf (pref addrp :unsigned) addr)
    1167     (do* ((buflen 1024 (+ buflen buflen))) ()
    1168       (declare (fixnum buflen))
    1169       (%stack-block ((buf buflen))
    1170         (let* ((res (#_gethostbyaddr_r addrp (record-length :unsigned) #$AF_INET
    1171                                        hostent buf buflen herr)))
    1172           (if (%null-ptr-p res)
    1173             (unless (eql (%get-errno) (- #$ERANGE))
    1174               (return (values nil (- (pref herr :signed)))))
    1175             (return (%get-cstring (pref res :hostent.h_name)))))))))
    1176 
    1177 #+(or darwin-target freebsd-target windows-target)
     1115(defun c_gethostbyaddr (addr-in-net-byte-order)
     1116  (rletZ ((sin #>sockaddr_in))
     1117    (setf (pref sin :sockaddr_in.sin_family) #$AF_INET
     1118          (pref sin
     1119                #+(or windows-target solaris-target) #>sockaddr_in.sin_addr.S_un.S_addr
     1120                #-(or windows-target solaris-target) #>sockaddr_in.sin_addr.s_addr) addr-in-net-byte-order)
     1121    #+darwin-target (setf (pref sin :sockaddr_in.sin_len) (record-length :sockaddr_in))
     1122    (%stack-block ((namep #$NI_MAXHOST))
     1123      (let* ((err (#_getnameinfo sin (record-length #>sockaddr_in) namep #$NI_MAXHOST (%null-ptr) 0 #$NI_NAMEREQD)))
     1124        (if (eql 0 err)
     1125          (%get-cstring namep)
     1126          (values nil err))))))
     1127               
    11781128(defun c_gethostbyname (name)
    11791129  (with-cstrs ((name (string name)))
    1180     (without-interrupts
    1181      (let* ((hp (#_gethostbyname  name)))
    1182        (declare (dynamic-extent hp))
    1183        (if (not (%null-ptr-p hp))
    1184          (%get-unsigned-long
    1185           (%get-ptr (pref hp :hostent.h_addr_list)))
    1186          (values nil (pref (h-errno-location) :signed)))))))
    1187 
    1188 #+linux-target
    1189 (defun c_gethostbyname (name)
    1190   (with-cstrs ((name (string name)))
    1191     (rlet ((hostent :hostent)
    1192            (hp (* (struct :hostent)))
    1193            (herr :signed 0))
    1194        (do* ((buflen 1024 (+ buflen buflen))) ()
    1195          (declare (fixnum buflen))
    1196          (%stack-block ((buf buflen))
    1197            (let* ((res (#_gethostbyname_r name hostent buf buflen hp herr)))
    1198              (declare (fixnum res))
    1199              (unless (eql res #$ERANGE)
    1200                (return
    1201                  (let* ((err (pref herr :signed)))
    1202                  (if (and (eql res 0) (eql err 0))
    1203                    (%get-unsigned-long
    1204                     (%get-ptr (pref (%get-ptr hp) :hostent.h_addr_list)))
    1205                    (values nil (- err))))))))))))
    1206 
    1207 #+solaris-target
    1208 (defun c_gethostbyname (name)
    1209   (with-cstrs ((name (string name)))
    1210     (rlet ((hostent :hostent)
    1211            (herr :signed 0))
    1212        (do* ((buflen 1024 (+ buflen buflen))) ()
    1213          (declare (fixnum buflen))
    1214          (%stack-block ((buf buflen))
    1215            (setf (pref herr :signed) 0)
    1216            (let* ((res (#_gethostbyname_r name hostent buf buflen herr)))
    1217              (if (%null-ptr-p res)
    1218                (unless (eql (%get-errno) (- #$ERANGE))
    1219                  (return (values nil (- (pref herr :signed)))))
    1220                (return
    1221                  (%get-unsigned-long
    1222                   (%get-ptr (pref res :hostent.h_addr_list)))))))))))
     1130    (rletZ ((hints #>addrinfo)
     1131            (results :address))
     1132      (setf (pref hints #>addrinfo.ai_family) #$AF_INET)
     1133      (let* ((err (#_getaddrinfo name (%null-ptr) hints results)))
     1134        (if (eql 0 err)
     1135          (let* ((info (pref results :address))
     1136                 (sin (pref info #>addrinfo.ai_addr)))
     1137            (prog1
     1138                #+(or windows-target solaris-target)
     1139                (pref sin #>sockaddr_in.sin_addr.S_un.S_addr)
     1140                #-(or windows-target solaris-target)
     1141                (pref sin #>sockaddr_in.sin_addr.s_addr)
     1142                (#_freeaddrinfo info)))
     1143          (values nil err))))))
     1144     
     1145 
     1146
    12231147 
    12241148
     
    12441168;;; seems to lose the :struct, so just using #_ doesn't work (that
    12451169;;; sounds like a bug in the FFI translator.)
    1246 #+(or darwin-target linuxx86-target freebsd-target solaris-target)
     1170#-linuxppc-target
    12471171(defun _inet_ntoa (addr)
    12481172  (with-macptrs ((p))
    12491173    (%setf-macptr p (external-call #+darwin-target "_inet_ntoa"
    12501174                                   #-darwin-target "inet_ntoa"
    1251                                    :unsigned-fullword addr
     1175                                   :unsigned-fullword (htonl addr)
    12521176                                   :address))
    12531177    (unless (%null-ptr-p p) (%get-cstring p))))                           
     
    14491373                        :name (%get-cstring (pref q :ifaddrs.ifa_name))
    14501374                        :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr))
    1451                         :netmask (pref (pref q :ifaddrs.ifa_netmask)
    1452                                        :sockaddr_in.sin_addr.s_addr)
     1375                        :netmask (ntohl
     1376                                  (pref (pref q :ifaddrs.ifa_netmask)
     1377                                       :sockaddr_in.sin_addr.s_addr))
    14531378                        :flags (pref q :ifaddrs.ifa_flags)
    14541379                        :address-family #$AF_INET)
     
    15151440                                  :name name
    15161441                                  :addr (ntohl address)
    1517                                   :netmask netmask
     1442                                  :netmask (ntohl netmask)
    15181443                                  :flags if-flags
    15191444                                  :address-family address-family)
     
    15231448)
    15241449
    1525              
     1450
     1451
     1452
     1453#+windows-target
     1454(defun %get-ip-interfaces ()
     1455  (let* ((handle (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
     1456    (unwind-protect
     1457    (rlet ((realoutlen #>DWORD 0))
     1458      (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
     1459                         (* 2 reservedlen)))
     1460           ()
     1461        (%stack-block ((buf reservedlen))
     1462          (unless (eql 0 (#_WSAIoctl
     1463                          handle
     1464                          #$SIO_GET_INTERFACE_LIST
     1465                          (%null-ptr)
     1466                          0
     1467                          buf
     1468                          reservedlen
     1469                          realoutlen
     1470                          (%null-ptr)
     1471                          (%null-ptr)))
     1472            (return))
     1473          (let* ((noutbytes (pref realoutlen #>DWORD)))
     1474            (when (< noutbytes reservedlen)
     1475              (let* ((interfaces nil))
     1476                (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO)))
     1477                      (nameidx 0 (1+ nameidx)))
     1478                     ((>= offset noutbytes))
     1479                  (with-macptrs ((p (%inc-ptr buf offset)))
     1480                    (push (make-ip-interface
     1481                           :name (format nil "ip~d" nameidx)
     1482                           :addr (ntohl
     1483                                  (pref (pref p #>INTERFACE_INFO.iiAddress)
     1484                                        #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
     1485                           :netmask (ntohl
     1486                                     (pref (pref p #>INTERFACE_INFO.iiNetmask)
     1487                                        #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
     1488                           :flags (pref p #>INTERFACE_INFO.iiFlags)
     1489                           :address-family #$AF_INET)
     1490                          interfaces)))
     1491                (return interfaces)))))))
     1492      (#_CloseHandle (%int-to-ptr handle)))))
    15261493
    15271494     
Note: See TracChangeset for help on using the changeset viewer.