123 lines
3.4 KiB
Factor
123 lines
3.4 KiB
Factor
! Copyright (C) 2011-2013 Eungju PARK, John Benediktsson.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors alien.c-types alien.data arrays byte-arrays
|
|
classes.struct combinators destructors fry kernel libc math math.order
|
|
memoize sequences zeromq.ffi ;
|
|
|
|
IN: zeromq
|
|
|
|
TUPLE: zmq-error n string ;
|
|
|
|
: throw-zmq-error ( -- )
|
|
zmq_errno dup zmq_strerror zmq-error boa throw ; inline
|
|
|
|
: check-zmq-error ( retval -- )
|
|
[ throw-zmq-error ] unless-zero ; inline
|
|
|
|
: zmq-version ( -- version )
|
|
{ int int int } [ zmq_version ] with-out-parameters 3array ;
|
|
|
|
: zmq-version-numeric ( -- n )
|
|
zmq-version first3 [ 100 * ] [ 10 * ] [ 1 * ] tri* + + ;
|
|
|
|
! See
|
|
! https://github.com/chuckremes/ffi-rzmq-core/blob/master/lib/ffi-rzmq-core/structures.rb
|
|
MEMO: zmq-msg-size ( -- x )
|
|
zmq-version-numeric 410 <=> {
|
|
{ +lt+ [ 32 ] }
|
|
{ +eq+ [ 48 ] }
|
|
{ +gt+ [ 64 ] }
|
|
} case ;
|
|
|
|
! This word should be used to allocate the zmq_msg_t struct because
|
|
! the size of it varies between versions.
|
|
: <zmq_msg_t> ( -- byte-array )
|
|
zmq-msg-size (byte-array) ;
|
|
|
|
GENERIC#: zmq-setopt 2 ( obj name value -- )
|
|
GENERIC#: zmq-getopt 1 ( obj name -- value )
|
|
|
|
TUPLE: zmq-message underlying ;
|
|
|
|
: <zmq-message> ( -- msg )
|
|
<zmq_msg_t>
|
|
[ zmq_msg_init check-zmq-error ]
|
|
[ zmq-message boa ] bi ;
|
|
|
|
M: zmq-message dispose
|
|
underlying>> zmq_msg_close check-zmq-error ;
|
|
|
|
: byte-array>zmq-message ( byte-array -- msg )
|
|
<zmq_msg_t>
|
|
[ over length zmq_msg_init_size check-zmq-error ]
|
|
[ zmq_msg_data swap dup length memcpy ]
|
|
[ zmq-message boa ] tri ;
|
|
|
|
: zmq-message>byte-array ( msg -- byte-array )
|
|
underlying>> [ zmq_msg_data ] [ zmq_msg_size ] bi
|
|
[ drop B{ } ] [ memory>byte-array ] if-zero ;
|
|
|
|
TUPLE: zmq-context underlying ;
|
|
|
|
! this uses the "New API" with version 3
|
|
! previous versions should use zmq_init and zmq_term
|
|
|
|
: <zmq-context> ( -- context )
|
|
zmq_ctx_new zmq-context boa ;
|
|
|
|
M: zmq-context dispose
|
|
underlying>> zmq_ctx_destroy check-zmq-error ;
|
|
|
|
M: zmq-context zmq-setopt
|
|
[ underlying>> ] 2dip zmq_ctx_set check-zmq-error ;
|
|
|
|
M: zmq-context zmq-getopt
|
|
[ underlying>> ] dip zmq_ctx_get ;
|
|
|
|
TUPLE: zmq-socket underlying ;
|
|
|
|
: <zmq-socket> ( context type -- socket )
|
|
[ underlying>> ] dip zmq_socket
|
|
dup [ throw-zmq-error ] unless
|
|
zmq-socket boa ;
|
|
|
|
M: zmq-socket dispose
|
|
underlying>> zmq_close check-zmq-error ;
|
|
|
|
M: zmq-socket zmq-setopt
|
|
[ underlying>> ] 2dip over {
|
|
{ ZMQ_SUBSCRIBE [ dup length ] }
|
|
{ ZMQ_UNSUBSCRIBE [ dup length ] }
|
|
{ ZMQ_RCVTIMEO [ 4 ] }
|
|
{ ZMQ_SNDTIMEO [ 4 ] }
|
|
} case zmq_setsockopt check-zmq-error ;
|
|
|
|
: zmq-bind ( socket addr -- )
|
|
[ underlying>> ] dip zmq_bind check-zmq-error ;
|
|
|
|
: zmq-unbind ( socket addr -- )
|
|
[ underlying>> ] dip zmq_unbind check-zmq-error ;
|
|
|
|
: zmq-connect ( socket addr -- )
|
|
[ underlying>> ] dip zmq_connect check-zmq-error ;
|
|
|
|
: zmq-disconnect ( socket addr -- )
|
|
[ underlying>> ] dip zmq_disconnect check-zmq-error ;
|
|
|
|
: zmq-sendmsg ( socket msg flags -- )
|
|
[ [ underlying>> ] bi@ ] dip zmq_sendmsg
|
|
0 < [ throw-zmq-error ] when ;
|
|
|
|
: zmq-recvmsg ( socket msg flags -- )
|
|
[ [ underlying>> ] bi@ ] dip zmq_recvmsg
|
|
0 < [ throw-zmq-error ] when ;
|
|
|
|
: zmq-send ( socket byte-array flags -- )
|
|
[ byte-array>zmq-message ] dip
|
|
'[ _ zmq-sendmsg ] with-disposal ;
|
|
|
|
: zmq-recv ( socket flags -- byte-array )
|
|
<zmq-message> [
|
|
[ swap zmq-recvmsg ] [ zmq-message>byte-array ] bi
|
|
] with-disposal ;
|