GopherProxy

	tcmucl.lisp - clic - Clic is an command line interactive client for gopher writ…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tcmucl.lisp (11174B)
	---
	1 ;;;; See LICENSE for licensing information.
	2
	3 (in-package :usocket)
	4
	5 #+win32
	6 (defun remap-for-win32 (z)
	7 (mapcar #'(lambda (x)
	8 (cons (mapcar #'(lambda (y)
	9 (+ 10000 y))
	10 (car x))
	11 (cdr x)))
	12 z))
	13
	14 (defparameter +cmucl-error-map+
	15 #+win32
	16 (append (remap-for-win32 +unix-errno-condition-map+)
	17 (remap-for-win32 +unix-errno-error-map+))
	18 #-win32
	19 (append +unix-errno-condition-map+
	20 +unix-errno-error-map+))
	21
	22 (defun cmucl-map-socket-error (err &key condition socket)
	23 (let ((usock-err
	24 (cdr (assoc err +cmucl-error-map+ :test #'member))))
	25 (if usock-err
	26 (if (subtypep usock-err 'error)
	27 (error usock-err :socket socket)
	28 (signal usock-err :socket socket))
	29 (error 'unknown-error
	30 :socket socket
	31 :real-error condition))))
	32
	33 ;; CMUCL error handling is brain-dead: it doesn't preserve any
	34 ;; information other than the OS error string from which the
	35 ;; error can be determined. The OS error string isn't good enough
	36 ;; given that it may have been localized (l10n).
	37 ;;
	38 ;; The above applies to versions pre 19b; 19d and newer are expected to
	39 ;; contain even better error reporting.
	40 ;;
	41 ;;
	42 ;; Just catch the errors and encapsulate them in an unknown-error
	43 (defun handle-condition (condition &optional (socket nil))
	44 "Dispatch correct usocket condition."
	45 (typecase condition
	46 (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condit…
	47 :socket socket
	48 :condition condition))))
	49
	50 (defun socket-connect (host port &key (protocol :stream) (element-type '…
	51 timeout deadline (nodelay t nodelay-specified)
	52 (local-host nil local-host-p)
	53 (local-port nil local-port-p)
	54 &aux
	55 (local-bind-p (fboundp 'ext::bind-inet-socket)))
	56 (when timeout (unsupported 'timeout 'socket-connect))
	57 (when deadline (unsupported 'deadline 'socket-connect))
	58 (when (and nodelay-specified
	59 (not (eq nodelay :if-supported)))
	60 (unsupported 'nodelay 'socket-connect))
	61 (when (and local-host-p (not local-bind-p))
	62 (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08…
	63 (when (and local-port-p (not local-bind-p))
	64 (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08…
	65
	66 (let ((socket))
	67 (ecase protocol
	68 (:stream
	69 (setf socket
	70 (let ((args (list (host-to-hbo host) port protocol)))
	71 (when (and local-bind-p (or local-host-p local-port-p))
	72 (nconc args (list :local-host (when local-host
	73 (host-to-hbo local-host…
	74 :local-port local-port)))
	75 (with-mapped-conditions (socket)
	76 (apply #'ext:connect-to-inet-socket args))))
	77 (if socket
	78 (let* ((stream (sys:make-fd-stream socket :input t :output t
	79 :element-type element-type
	80 :buffering :full))
	81 ;;###FIXME the above line probably needs an :external-…
	82 (usocket (make-stream-socket :socket socket
	83 :stream stream)))
	84 usocket)
	85 (let ((err (unix:unix-errno)))
	86 (when err (cmucl-map-socket-error err)))))
	87 (:datagram
	88 (setf socket
	89 (if (and host port)
	90 (let ((args (list (host-to-hbo host) port protocol)))
	91 (when (and local-bind-p (or local-host-p local-port-p…
	92 (nconc args (list :local-host (when local-host
	93 (host-to-hbo local-…
	94 :local-port local-port)))
	95 (with-mapped-conditions (socket)
	96 (apply #'ext:connect-to-inet-socket args)))
	97 (if (or local-host-p local-port-p)
	98 (with-mapped-conditions (socket)
	99 (apply #'ext:create-inet-listener
	100 (nconc (list (or local-port 0) protocol)
	101 (when (and local-host-p
	102 (ip/= local-host *wildca…
	103 (list :host (host-to-hbo local-ho…
	104 (with-mapped-conditions (socket)
	105 (ext:create-inet-socket protocol)))))
	106 (if socket
	107 (let ((usocket (make-datagram-socket socket :connected-p (and…
	108 (ext:finalize usocket #'(lambda () (when (%open-p usocket)
	109 (ext:close-socket sock…
	110 usocket)
	111 (let ((err (unix:unix-errno)))
	112 (when err (cmucl-map-socket-error err))))))))
	113
	114 (defun socket-listen (host port
	115 &key reuseaddress
	116 (reuse-address nil reuse-address-supplied-p)
	117 (backlog 5)
	118 (element-type 'character))
	119 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reusead…
	120 (server-sock
	121 (with-mapped-conditions ()
	122 (apply #'ext:create-inet-listener
	123 (nconc (list port :stream
	124 :backlog backlog
	125 :reuse-address reuseaddress)
	126 (when (ip/= host wildcard-host)
	127 (list :host
	128 (host-to-hbo host))))))))
	129 (make-stream-server-socket server-sock :element-type element-type)))
	130
	131 (defmethod socket-accept ((usocket stream-server-usocket) &key element-t…
	132 (with-mapped-conditions (usocket)
	133 (let* ((sock (ext:accept-tcp-connection (socket usocket)))
	134 (stream (sys:make-fd-stream sock :input t :output t
	135 :element-type (or element-type
	136 (element-type u…
	137 :buffering :full)))
	138 (make-stream-socket :socket sock :stream stream))))
	139
	140 ;; Sockets and socket streams are represented
	141 ;; by different objects. Be sure to close the
	142 ;; socket stream when closing a stream socket.
	143 (defmethod socket-close ((usocket stream-usocket))
	144 "Close socket."
	145 (when (wait-list usocket)
	146 (remove-waiter (wait-list usocket) usocket))
	147 (with-mapped-conditions (usocket)
	148 (close (socket-stream usocket))))
	149
	150 (defmethod socket-close ((usocket usocket))
	151 "Close socket."
	152 (when (wait-list usocket)
	153 (remove-waiter (wait-list usocket) usocket))
	154 (with-mapped-conditions (usocket)
	155 (ext:close-socket (socket usocket))))
	156
	157 (defmethod socket-close :after ((socket datagram-usocket))
	158 (setf (%open-p socket) nil))
	159
	160 #+unicode
	161 (defun %unix-send (fd buffer length flags)
	162 (alien:alien-funcall
	163 (alien:extern-alien "send"
	164 (function c-call:int
	165 c-call:int
	166 system:system-area-pointer
	167 c-call:int
	168 c-call:int))
	169 fd
	170 (system:vector-sap buffer)
	171 length
	172 flags))
	173
	174 (defmethod socket-shutdown ((usocket usocket) direction)
	175 (with-mapped-conditions (usocket)
	176 (ext:inet-shutdown (socket usocket) (ecase direction
	177 (:input ext:shut-rd)
	178 (:output ext:shut-wr)))))
	179
	180 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host…
	181 &aux (real-buffer (if (zerop offset)
	182 buffer
	183 (subseq buffer offset (+ o…
	184 (with-mapped-conditions (usocket)
	185 (if (and host port)
	186 (ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo …
	187 #-unicode
	188 (unix:unix-send (socket usocket) real-buffer size 0)
	189 #+unicode
	190 (%unix-send (socket usocket) real-buffer size 0))))
	191
	192 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
	193 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
	194 (integer 0) ; size
	195 (unsigned-byte 32) ; host
	196 (unsigned-byte 16))) ; port
	197 (let ((real-buffer (or buffer
	198 (make-array length :element-type '(unsigned-byt…
	199 (real-length (or length
	200 (length buffer))))
	201 (multiple-value-bind (nbytes remote-host remote-port)
	202 (with-mapped-conditions (usocket)
	203 (ext:inet-recvfrom (socket usocket) real-buffer real-length))
	204 (values real-buffer nbytes remote-host remote-port))))
	205
	206 (defmethod get-local-name ((usocket usocket))
	207 (multiple-value-bind
	208 (address port)
	209 (ext:get-socket-host-and-port (socket usocket))
	210 (values (hbo-to-vector-quad address) port)))
	211
	212 (defmethod get-peer-name ((usocket stream-usocket))
	213 (multiple-value-bind
	214 (address port)
	215 (ext:get-peer-host-and-port (socket usocket))
	216 (values (hbo-to-vector-quad address) port)))
	217
	218 (defmethod get-local-address ((usocket usocket))
	219 (nth-value 0 (get-local-name usocket)))
	220
	221 (defmethod get-peer-address ((usocket stream-usocket))
	222 (nth-value 0 (get-peer-name usocket)))
	223
	224 (defmethod get-local-port ((usocket usocket))
	225 (nth-value 1 (get-local-name usocket)))
	226
	227 (defmethod get-peer-port ((usocket stream-usocket))
	228 (nth-value 1 (get-peer-name usocket)))
	229
	230
	231 (defun lookup-host-entry (host)
	232 (multiple-value-bind
	233 (entry errno)
	234 (ext:lookup-host-entry host)
	235 (if entry
	236 entry
	237 ;;###The constants below work on most OSes, but are defined as t…
	238 ;; constants mentioned in C
	239 (let ((exception
	240 (second (assoc errno
	241 '((1 ns-host-not-found-error) ;; HOST_NO…
	242 (2 ns-no-recovery-error) ;; NO_DATA
	243 (3 ns-no-recovery-error) ;; NO_RECO…
	244 (4 ns-try-again-condition)))))) ;; TRY_AGA…
	245 (when exception
	246 (error exception))))))
	247
	248
	249 (defun get-host-by-address (address)
	250 (handler-case (ext:host-entry-name
	251 (lookup-host-entry (host-byte-order address)))
	252 (condition (condition) (handle-condition condition))))
	253
	254 (defun get-hosts-by-name (name)
	255 (handler-case (mapcar #'hbo-to-vector-quad
	256 (ext:host-entry-addr-list
	257 (lookup-host-entry name)))
	258 (condition (condition) (handle-condition condition))))
	259
	260 (defun get-host-name ()
	261 (unix:unix-gethostname))
	262
	263 (defun %setup-wait-list (wait-list)
	264 (declare (ignore wait-list)))
	265
	266 (defun %add-waiter (wait-list waiter)
	267 (push (socket waiter) (wait-list-%wait wait-list)))
	268
	269 (defun %remove-waiter (wait-list waiter)
	270 (setf (wait-list-%wait wait-list)
	271 (remove (socket waiter) (wait-list-%wait wait-list))))
	272
	273 (defun wait-for-input-internal (wait-list &key timeout)
	274 (with-mapped-conditions ()
	275 (alien:with-alien ((rfds (alien:struct unix:fd-set)))
	276 (unix:fd-zero rfds)
	277 (dolist (socket (wait-list-%wait wait-list))
	278 (unix:fd-set socket rfds))
	279 (multiple-value-bind
	280 (secs musecs)
	281 (split-timeout (or timeout 1))
	282 (multiple-value-bind (count err)
	283 (unix:unix-fast-select (1+ (reduce #'max
	284 (wait-list-%wait wait-li…
	285 (alien:addr rfds) nil nil
	286 (when timeout secs) musecs)
	287 (declare (ignore err))
	288 (if (<= 0 count)
	289 ;; process the result...
	290 (dolist (x (wait-list-waiters wait-list))
	291 (when (unix:fd-isset (socket x) rfds)
	292 (setf (state x) :READ)))
	293 (progn
	294 ;;###FIXME generate an error, except for EINTR
	295 )))))))