extra/zeromq/zeromq.factor

   1 ! Copyright (C) 2011-2013 Eungju PARK, John Benediktsson.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data arrays byte-arrays
   4 classes.struct combinators destructors fry kernel libc math math.order
   5 memoize sequences zeromq.ffi ;
   6
   7 IN: zeromq
   8
   9 TUPLE: zmq-error n string ;
  10
  11 : throw-zmq-error ( -- )
  12     zmq_errno dup zmq_strerror zmq-error boa throw ; inline
  13
  14 : check-zmq-error ( retval -- )
  15     [ throw-zmq-error ] unless-zero ; inline
  16
  17 : zmq-version ( -- version )
  18     { int int int } [ zmq_version ] with-out-parameters 3array ;
  19
  20 : zmq-version-numeric ( -- n )
  21     zmq-version first3 [ 100 * ] [ 10 * ] [ 1 * ] tri* + + ;
  22
  23 ! See
  24 ! https://github.com/chuckremes/ffi-rzmq-core/blob/master/lib/ffi-rzmq-core/structures.rb
  25 MEMO: zmq-msg-size ( -- x )
  26     zmq-version-numeric 410 <=> {
  27         { +lt+ [ 32 ] }
  28         { +eq+ [ 48 ] }
  29         { +gt+ [ 64 ] }
  30     } case ;
  31
  32 ! This word should be used to allocate the zmq_msg_t struct because
  33 ! the size of it varies between versions.
  34 : <zmq_msg_t> ( -- byte-array )
  35     zmq-msg-size (byte-array) ;
  36
  37 GENERIC#: zmq-setopt 2 ( obj name value -- )
  38 GENERIC#: zmq-getopt 1 ( obj name -- value )
  39
  40 TUPLE: zmq-message underlying ;
  41
  42 : <zmq-message> ( -- msg )
  43     <zmq_msg_t>
  44     [ zmq_msg_init check-zmq-error ]
  45     [ zmq-message boa ] bi ;
  46
  47 M: zmq-message dispose
  48     underlying>> zmq_msg_close check-zmq-error ;
  49
  50 : byte-array>zmq-message ( byte-array -- msg )
  51     <zmq_msg_t>
  52     [ over length zmq_msg_init_size check-zmq-error ]
  53     [ zmq_msg_data swap dup length memcpy ]
  54     [ zmq-message boa ] tri ;
  55
  56 : zmq-message>byte-array ( msg -- byte-array )
  57     underlying>> [ zmq_msg_data ] [ zmq_msg_size ] bi
  58     [ drop B{ } ] [ memory>byte-array ] if-zero ;
  59
  60 TUPLE: zmq-context underlying ;
  61
  62 ! this uses the "New API" with version 3
  63 ! previous versions should use zmq_init and zmq_term
  64
  65 : <zmq-context> ( -- context )
  66     zmq_ctx_new zmq-context boa ;
  67
  68 M: zmq-context dispose
  69     underlying>> zmq_ctx_destroy check-zmq-error ;
  70
  71 M: zmq-context zmq-setopt
  72     [ underlying>> ] 2dip zmq_ctx_set check-zmq-error ;
  73
  74 M: zmq-context zmq-getopt
  75     [ underlying>> ] dip zmq_ctx_get ;
  76
  77 TUPLE: zmq-socket underlying ;
  78
  79 : <zmq-socket> ( context type -- socket )
  80     [ underlying>> ] dip zmq_socket
  81     dup [ throw-zmq-error ] unless
  82     zmq-socket boa ;
  83
  84 M: zmq-socket dispose
  85     underlying>> zmq_close check-zmq-error ;
  86
  87 M: zmq-socket zmq-setopt
  88     [ underlying>> ] 2dip over {
  89         { ZMQ_SUBSCRIBE [ dup length ] }
  90         { ZMQ_UNSUBSCRIBE [ dup length ] }
  91         { ZMQ_RCVTIMEO [ 4 ] }
  92         { ZMQ_SNDTIMEO [ 4 ] }
  93     } case zmq_setsockopt check-zmq-error ;
  94
  95 : zmq-bind ( socket addr -- )
  96     [ underlying>> ] dip zmq_bind check-zmq-error ;
  97
  98 : zmq-unbind ( socket addr -- )
  99     [ underlying>> ] dip zmq_unbind check-zmq-error ;
 100
 101 : zmq-connect ( socket addr -- )
 102     [ underlying>> ] dip zmq_connect check-zmq-error ;
 103
 104 : zmq-disconnect ( socket addr -- )
 105     [ underlying>> ] dip zmq_disconnect check-zmq-error ;
 106
 107 : zmq-sendmsg ( socket msg flags -- )
 108     [ [ underlying>> ] bi@ ] dip zmq_sendmsg
 109     0 < [ throw-zmq-error ] when ;
 110
 111 : zmq-recvmsg ( socket msg flags -- )
 112     [ [ underlying>> ] bi@ ] dip zmq_recvmsg
 113     0 < [ throw-zmq-error ] when ;
 114
 115 : zmq-send ( socket byte-array flags -- )
 116     [ byte-array>zmq-message ] dip
 117     '[ _ zmq-sendmsg ] with-disposal ;
 118
 119 : zmq-recv ( socket flags -- byte-array )
 120     <zmq-message> [
 121         [ swap zmq-recvmsg ] [ zmq-message>byte-array ] bi
 122     ] with-disposal ;