contrib/sb-bsd-sockets/inet.lisp

   1 (in-package :sb-bsd-sockets)
   2
   3 ;;;
   4
   5 (define-condition unknown-protocol ()
   6   ((name :initarg :name
   7          :reader unknown-protocol-name))
   8   (:report (lambda (c s)
   9              (format s "Protocol not found: ~a" (prin1-to-string
  10                                                  (unknown-protocol-name c))))))
  11 (defvar *protocols*
  12   `((:tcp ,sockint::ipproto_tcp "tcp" "TCP")
  13     (:udp ,sockint::ipproto_udp "udp" "UDP")
  14     (:ip ,sockint::ipproto_ip "ip" "IP")
  15     (:ipv6 ,sockint::ipproto_ipv6 "ipv6" "IPV6")
  16     (:icmp ,sockint::ipproto_icmp "icmp" "ICMP")
  17     (:igmp ,sockint::ipproto_igmp "igmp" "IGMP")
  18     (:raw ,sockint::ipproto_raw "raw" "RAW")))
  19
  20 ;;; Try to get to a protocol quickly, falling back to calling
  21 ;;; getprotobyname if it's available.
  22 (defun get-protocol-by-name (name)
  23   "Given a protocol name, return the protocol number, the protocol name, and
  24 a list of protocol aliases"
  25   (let ((result (cdr (if (keywordp name)
  26                          (assoc name *protocols*)
  27                          (assoc name *protocols* :test #'string-equal)))))
  28     (if result
  29         (values (first result) (second result) (third result))
  30         #-android
  31         (getprotobyname (string-downcase name))
  32         #+android (error 'unknown-protocol :name name))))
  33
  34 #+(and sb-thread (not os-provides-getprotoby-r) (not android) (not netbsd))
  35 ;; Since getprotobyname is not thread-safe, we need a lock.
  36 (sb-ext:defglobal **getprotoby-lock** (sb-thread:make-mutex :name "getprotoby lock"))
  37
  38 ;;; getprotobyname only works in the internet domain, which is why this
  39 ;;; is here
  40 #-android
  41 (defun getprotobyname (name)
  42   ;; Brownie Points.  Hopefully there's one person out there using
  43   ;; RSPF sockets and SBCL who will appreciate the extra info
  44   (labels ((protoent-to-values (protoent)
  45              (values
  46               (sockint::protoent-proto protoent)
  47               (sockint::protoent-name protoent)
  48               (let ((index 0))
  49                 (loop
  50                   for alias = (sb-alien:deref
  51                                (sockint::protoent-aliases protoent) index)
  52                   while (not (sb-alien:null-alien alias))
  53                   do (incf index)
  54                   collect (sb-alien::c-string-to-string
  55                            (sb-alien:alien-sap alias)
  56                            (sb-impl::default-external-format)
  57                            'character))))))
  58     #+(and sb-thread os-provides-getprotoby-r (not netbsd))
  59     (let ((buffer-length 1024)
  60           (max-buffer 10000)
  61           (result-buf nil)
  62           (buffer nil)
  63           #-solaris
  64           (result nil))
  65       (declare (type fixnum buffer-length)
  66                (type fixnum max-buffer))
  67       (loop
  68         (unwind-protect
  69              (progn
  70                (setf result-buf (sb-alien:make-alien sockint::protoent)
  71                      buffer (sb-alien:make-alien sb-alien:char buffer-length))
  72                #-solaris
  73                (setf result (sb-alien:make-alien (* sockint::protoent)))
  74                (when (or (sb-alien:null-alien result-buf)
  75                          (sb-alien:null-alien buffer)
  76                          (sb-alien:null-alien result))
  77                  (error "Could not allocate foreign memory."))
  78                (let ((res (sockint::getprotobyname-r
  79                            name result-buf buffer buffer-length #-solaris result)))
  80                  (cond ((eql res 0)
  81                         #-solaris
  82                         (when (sb-alien:null-alien (sb-alien:deref result 0))
  83                           (error 'unknown-protocol :name name))
  84                         (return-from getprotobyname
  85                           (protoent-to-values result-buf)))
  86                        (t
  87                         (let ((errno (sb-alien:get-errno)))
  88                           (cond ((eql errno sb-unix:enoent)
  89                                  ;; Usually caused by missing /etc/protocols
  90                                  (error 'unknown-protocol :name name))
  91                                 ((eql errno sockint::erange)
  92                                  (incf buffer-length 1024)
  93                                  (when (> buffer-length max-buffer)
  94                                    (error "Exceeded max-buffer of ~d" max-buffer)))
  95                                 (t
  96                                  (error "Unexpected errno ~d" errno))))))))
  97           (when result-buf
  98             (sb-alien:free-alien result-buf))
  99           (when buffer
 100             (sb-alien:free-alien buffer))
 101           #-solaris
 102           (when result
 103             (sb-alien:free-alien result)))))
 104     #+(or (not sb-thread) (not os-provides-getprotoby-r) netbsd)
 105     (tagbody
 106        (flet ((get-it ()
 107                 (let ((ent (sockint::getprotobyname name)))
 108                   (if (sb-alien::null-alien ent)
 109                       (go :error)
 110                       (return-from getprotobyname (protoent-to-values ent))))))
 111          #+(and sb-thread (not netbsd))
 112          (sb-thread::with-system-mutex (**getprotoby-lock**)
 113            (get-it))
 114          #+(or (not sb-thread) netbsd)
 115          (get-it))
 116      :error
 117        (error 'unknown-protocol :name name))))