1 ! Copyright (C) 2011-2013 Eungju PARK, John Benediktsson.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors alien.c-types alien.data arrays byte-arrays
5 classes.struct combinators continuations destructors fry io
6 kernel libc math namespaces sequences zeromq.ffi ;
10 TUPLE: zmq-error n string ;
12 : throw-zmq-error ( -- )
13 zmq_errno dup zmq_strerror zmq-error boa throw ; inline
15 : check-zmq-error ( retval -- )
16 [ throw-zmq-error ] unless-zero ; inline
18 : zmq-version ( -- version )
19 { int int int } [ zmq_version ] with-out-parameters 3array ;
21 GENERIC# zmq-setopt 2 ( obj name value -- )
22 GENERIC# zmq-getopt 1 ( obj name -- value )
24 TUPLE: zmq-message underlying ;
26 : <zmq-message> ( -- msg )
28 [ zmq_msg_init check-zmq-error ]
29 [ zmq-message boa ] bi ;
31 M: zmq-message dispose
32 underlying>> zmq_msg_close check-zmq-error ;
34 : byte-array>zmq-message ( byte-array -- msg )
36 [ over length zmq_msg_init_size check-zmq-error ]
37 [ zmq_msg_data swap dup length memcpy ]
38 [ zmq-message boa ] tri ;
40 : zmq-message>byte-array ( msg -- byte-array )
41 underlying>> [ zmq_msg_data ] [ zmq_msg_size ] bi
42 [ drop B{ } ] [ memory>byte-array ] if-zero ;
44 TUPLE: zmq-context underlying ;
46 ! this uses the "New API" with version 3
47 ! previous versions should use zmq_init and zmq_term
49 : <zmq-context> ( -- context )
50 zmq_ctx_new zmq-context boa ;
52 M: zmq-context dispose
53 underlying>> zmq_ctx_destroy check-zmq-error ;
55 M: zmq-context zmq-setopt
56 [ underlying>> ] 2dip zmq_ctx_set check-zmq-error ;
58 M: zmq-context zmq-getopt
59 [ underlying>> ] dip zmq_ctx_get ;
61 TUPLE: zmq-socket underlying ;
63 : <zmq-socket> ( context type -- socket )
64 [ underlying>> ] dip zmq_socket
65 dup [ throw-zmq-error ] unless
69 underlying>> zmq_close check-zmq-error ;
71 M: zmq-socket zmq-setopt
72 [ underlying>> ] 2dip over {
73 { ZMQ_SUBSCRIBE [ dup length ] }
74 { ZMQ_UNSUBSCRIBE [ dup length ] }
75 { ZMQ_RCVTIMEO [ 4 ] }
76 { ZMQ_SNDTIMEO [ 4 ] }
77 } case zmq_setsockopt check-zmq-error ;
79 : zmq-bind ( socket addr -- )
80 [ underlying>> ] dip zmq_bind check-zmq-error ;
82 : zmq-unbind ( socket addr -- )
83 [ underlying>> ] dip zmq_unbind check-zmq-error ;
85 : zmq-connect ( socket addr -- )
86 [ underlying>> ] dip zmq_connect check-zmq-error ;
88 : zmq-disconnect ( socket addr -- )
89 [ underlying>> ] dip zmq_disconnect check-zmq-error ;
91 : zmq-sendmsg ( socket msg flags -- )
92 [ [ underlying>> ] bi@ ] dip zmq_sendmsg
93 0 < [ throw-zmq-error ] when ;
95 : zmq-recvmsg ( socket msg flags -- )
96 [ [ underlying>> ] bi@ ] dip zmq_recvmsg
97 0 < [ throw-zmq-error ] when ;
99 : zmq-send ( socket byte-array flags -- )
100 [ byte-array>zmq-message ] dip
101 '[ _ zmq-sendmsg ] with-disposal ;
103 : zmq-recv ( socket flags -- byte-array )
105 [ swap zmq-recvmsg ] [ zmq-message>byte-array ] bi