/usr/share/common-lisp/source/kmrcl/sockets.lisp is in cl-kmrcl 1.109-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: sockets.lisp
;;;; Purpose: Socket functions
;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve
;;;; Date Started: Jun 2003
;;;; *************************************************************************
(in-package #:kmrcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
#+sbcl (require :sb-bsd-sockets)
#+lispworks (require "comm")
#+allegro (require :socket))
#+sbcl
(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil))
"Create, bind and listen to an inet socket on *:PORT.
setsockopt SO_REUSEADDR if :reuse is not nil"
(declare (ignore kind))
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(if reuse
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
(sb-bsd-sockets:socket-bind
socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port)
(sb-bsd-sockets:socket-listen socket 15)
socket))
(defun create-inet-listener (port &key (format :text) (reuse-address t))
#+cmu (declare (ignore format reuse-address))
#+cmu (ext:create-inet-listener port)
#+allegro
(socket:make-socket :connect :passive :local-port port :format format
:address-family
(if (stringp port)
:file
(if (or (null port) (integerp port))
:internet
(error "illegal value for port: ~s" port)))
:reuse-address reuse-address)
#+sbcl (declare (ignore format))
#+sbcl (listen-to-inet-port :port port :reuse reuse-address)
#+clisp (declare (ignore format reuse-address))
#+clisp (ext:socket-server port)
#+openmcl
(declare (ignore format))
#+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)
#+cmu
(sys:make-fd-stream socket :input input :output output
:element-type element-type)
#+sbcl
(sb-bsd-sockets:socket-make-stream socket :input input :output output
:element-type element-type)
#-(or cmu sbcl) (declare (ignore input output element-type))
#-(or cmu sbcl) socket
)
(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)
(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)
(let ((sock (sb-bsd-sockets:socket-accept listener)))
(values
(sb-bsd-sockets:socket-make-stream
sock :element-type :default :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")
)
(defmacro errorset (form display)
`(handler-case
,form
(error (e)
(declare (ignorable e))
(when ,display
(format t "~&Error: ~A~%" e)))))
(defun close-passive-socket (socket)
#+allegro (close socket)
#+clisp (ext:socket-server-close socket)
#+cmu (unix:unix-close socket)
#+sbcl (sb-unix:unix-close
(sb-bsd-sockets:socket-file-descriptor socket))
#+openmcl (close socket)
#-(or allegro clisp cmu sbcl openmcl)
(warn "close-passive-socket not supported on this implementation")
)
(defun close-active-socket (socket)
#+sbcl (sb-bsd-sockets:socket-close socket)
#-sbcl (close socket))
(defun ipaddr-to-dotted (ipaddr &key values)
"Convert from 32-bit integer to dotted string."
(declare (type (unsigned-byte 32) ipaddr))
(let ((a (logand #xff (ash ipaddr -24)))
(b (logand #xff (ash ipaddr -16)))
(c (logand #xff (ash ipaddr -8)))
(d (logand #xff ipaddr)))
(if values
(values a b c d)
(format nil "~d.~d.~d.~d" a b c d))))
(defun dotted-to-ipaddr (dotted &key (errorp t))
"Convert from dotted string to 32-bit integer."
(declare (string dotted))
(if errorp
(let ((ll (delimited-string-to-list dotted #\.)))
(+ (ash (parse-integer (first ll)) 24)
(ash (parse-integer (second ll)) 16)
(ash (parse-integer (third ll)) 8)
(parse-integer (fourth ll))))
(ignore-errors
(let ((ll (delimited-string-to-list dotted #\.)))
(+ (ash (parse-integer (first ll)) 24)
(ash (parse-integer (second ll)) 16)
(ash (parse-integer (third ll)) 8)
(parse-integer (fourth ll)))))))
#+sbcl
(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
(when ignore-cache
(warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported."))
(sb-bsd-sockets:host-ent-name
(sb-bsd-sockets:get-host-by-address
(sb-bsd-sockets:make-inet-address ipaddr))))
#+sbcl
(defun lookup-hostname (host &key ignore-cache)
(when ignore-cache
(warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
(if (stringp host)
(sb-bsd-sockets:host-ent-address
(sb-bsd-sockets:get-host-by-name host))
(dotted-to-ipaddr (ipaddr-to-dotted host))))
(defun make-active-socket (server port)
"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 :default)
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))
#+clisp
(let ((sock (ext:socket-connect port server)))
(values sock 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))
#+clisp (let* ((peer (ext:socket-stream-peer socket t))
(stop (position #\Space peer)))
;; 2.37-2.39 had do-not-resolve-p backwards
(if stop (subseq peer 0 stop) peer))
#+openmcl (ccl:remote-host socket)
)
|