OpenTransportUDP.lisp - clic - Clic is an command line interactive client for g… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
OpenTransportUDP.lisp (6398B) | |
--- | |
1 ;;;-*-Mode: LISP; Package: CCL -*- | |
2 ;; | |
3 ;;; OpenTransportUDP.lisp | |
4 ;;; Copyright 2012 Chun Tian (binghe) <[email protected]> | |
5 | |
6 ;;; UDP extension to OpenTransport.lisp (with some TCP patches) | |
7 | |
8 (in-package "CCL") | |
9 | |
10 (eval-when (:compile-toplevel :load-toplevel :execute) | |
11 (require :opentransport)) | |
12 | |
13 ;; MCL Issue 28: Passive TCP streams should be able to listen to the loo… | |
14 ;; see http://code.google.com/p/mcl/issues/detail?id=28 for details | |
15 | |
16 (defparameter *passive-interface-address* NIL | |
17 "Address to use for passive connections - optionally bind to loopback … | |
18 | |
19 (advise local-interface-ip-address | |
20 (or *passive-interface-address* (:do-it)) | |
21 :when :around :name 'override-local-interface-ip-address) | |
22 | |
23 ;; MCL Issue 29: Passive TCP connections on OS assigned ports | |
24 ;; see http://code.google.com/p/mcl/issues/detail?id=29 for details | |
25 (advise ot-conn-tcp-passive-connect | |
26 (destructuring-bind (conn port &optional (allow-reuse t)) arglist | |
27 (declare (ignore allow-reuse)) | |
28 (if (eql port #$kOTAnyInetAddress) | |
29 ;; Avoids registering a proxy for port 0 but instead registers o… | |
30 (multiple-value-bind (proxy result) | |
31 (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-p… | |
32 (result (:do-it)) ;; pushes onto *opentransport-class… | |
33 (proxy (prog1 | |
34 (pop *opentransport-class-proxies*) | |
35 (assert (not *opentransport-class-proxies*))… | |
36 (context (cdr proxy)) | |
37 (tmpconn (make-ot-conn :context context | |
38 :endpoint (pref context :ot-co… | |
39 (localaddress (ot-conn-tcp-get-addresses tmpconn))) | |
40 (declare (dynamic-extent tmpconn)) | |
41 ;; replace original set in body of function | |
42 (setf (ot-conn-local-address conn) localaddress) | |
43 (values | |
44 (cons localaddress context) | |
45 result)) | |
46 ;; need to be outside local binding of *opentransport-class-pr… | |
47 (without-interrupts | |
48 (push proxy *opentransport-class-proxies*)) | |
49 result) | |
50 (:do-it))) | |
51 :when :around :name 'ot-conn-tcp-passive-connect-any-address) | |
52 | |
53 (defun open-udp-socket (&key local-address local-port) | |
54 (init-opentransport) | |
55 (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist | |
56 (err #$kOTNoError) | |
57 (configptr (ot-cloned-configuration traps::$kUDPName))) | |
58 (rlet ((errP :osstatus)) | |
59 (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configpt… | |
60 #-carbon-compat (#_OTOpenEndpoint configptr 0 (%nul… | |
61 err (pref errP :osstatus)) | |
62 (if (eql err #$kOTNoError) | |
63 (let* ((context (ot-make-endpoint-context endpoint nil nil)) ;… | |
64 (conn (make-ot-conn :context context :endpoint endpoint… | |
65 (macrolet ((check-ot-error-return (error-context) | |
66 `(unless (eql (setq err (pref errP :osstatus)) … | |
67 (values (ot-error err ,error-context))))) | |
68 (setf (ot-conn-bindreq conn) | |
69 #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADD… | |
70 #+carbon-compat (#_OTAllocInContext endpoint #$T_BIN… | |
71 ) | |
72 (check-ot-error-return :alloc) | |
73 (setf (ot-conn-bindret conn) | |
74 #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADD… | |
75 #+carbon-compat (#_OTAllocInContext endpoint #$T_BIN… | |
76 ) | |
77 (check-ot-error-return :alloc) | |
78 (setf (ot-conn-options conn) | |
79 #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_… | |
80 #+carbon-compat (#_OTAllocInContext endpoint #$T_OPT… | |
81 ) | |
82 (check-ot-error-return :alloc)) | |
83 ;; BIND to local address (for UDP server) | |
84 (when local-port ; local-address | |
85 (let* ((host (or local-address (local-interface-ip-address… | |
86 (port (tcp-service-port-number local-port)) | |
87 (localaddress `(:tcp ,host ,port)) | |
88 (bindreq (ot-conn-bindreq conn)) | |
89 (bindret (ot-conn-bindret conn))) | |
90 (let* ((netbuf (pref bindreq :tbind.addr))) | |
91 (declare (dynamic-extent netbuf)) | |
92 (setf (pref netbuf :tnetbuf.len) (record-length :ineta… | |
93 (pref bindreq :tbind.qlen) 5) ; arbitrary … | |
94 (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port h… | |
95 (setf (pref context :ot-context.completed) nil) | |
96 (unless (= (setq err (#_OTBind endpoint bindreq bindre… | |
97 (ot-error err :bind))) | |
98 (setf (ot-conn-local-address conn) localaddress))) | |
99 conn) | |
100 (ot-error err :create))))) | |
101 | |
102 (defun make-TUnitData (endpoint) | |
103 "create the send/recv buffer for UDP sockets" | |
104 (let ((err #$kOTNoError)) | |
105 (rlet ((errP :osstatus)) | |
106 (macrolet ((check-ot-error-return (error-context) | |
107 `(unless (eql (setq err (pref errP :osstatus)) #$kOTN… | |
108 (values (ot-error err ,error-context))))) | |
109 (let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$… | |
110 #+carbon-compat (#_OTAllocInContext endpoint #$T_UN… | |
111 (check-ot-error-return :alloc) | |
112 udata))))) | |
113 | |
114 (defun send-message (conn data buffer size host port &optional (offset 0… | |
115 ;; prepare dest address | |
116 (let ((addr (pref data :tunitdata.addr))) | |
117 (declare (dynamic-extent addr)) | |
118 (setf (pref addr :tnetbuf.len) (record-length :inetaddress)) | |
119 (#_OTInitInetAddress (pref addr :tnetbuf.buf) port host)) | |
120 ;; prepare data buffer | |
121 (let* ((udata (pref data :tunitdata.udata)) | |
122 (outptr (pref udata :tnetbuf.buf))) | |
123 (declare (dynamic-extent udata)) | |
124 (%copy-ivector-to-ptr buffer offset outptr 0 size) | |
125 (setf (pref udata :tnetbuf.len) size)) | |
126 ;; send the packet | |
127 (let* ((endpoint (ot-conn-endpoint conn)) | |
128 (result (#_OTSndUData endpoint data))) | |
129 (the fixnum result))) | |
130 | |
131 (defun receive-message (conn data buffer length) | |
132 (let* ((endpoint (ot-conn-endpoint conn)) | |
133 (err (#_OTRcvUData endpoint data *null-ptr*))) | |
134 (if (eql err #$kOTNoError) | |
135 (let* (;(addr (pref data :tunitdata.addr)) | |
136 (udata (pref data :tunitdata.udata)) | |
137 (inptr (pref udata :tnetbuf.buf)) | |
138 (read-bytes (pref udata :tnetbuf.len)) | |
139 (buffer (or buffer (make-array read-bytes :element-type '… | |
140 (length (or length (length buffer))) | |
141 (actual-size (min read-bytes length))) | |
142 (%copy-ptr-to-ivector inptr 0 buffer 0 actual-size) | |
143 (values buffer | |
144 actual-size | |
145 0 0)) ; TODO: retrieve address and port | |
146 (ot-error err :receive)))) ; TODO: use OTRcvUDErr instead |