extra/zeromq/zeromq.factor

   1 ! Copyright (C) 2011-2013 Eungju PARK, John Benediktsson.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   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 ;
   7
   8 IN: zeromq
   9
  10 TUPLE: zmq-error n string ;
  11
  12 : throw-zmq-error ( -- )
  13     zmq_errno dup zmq_strerror zmq-error boa throw ; inline
  14
  15 : check-zmq-error ( retval -- )
  16     [ zmq-error ] unless-zero ; inline
  17
  18 : zmq-version ( -- version )
  19     { int int int } [ zmq_version ] with-out-parameters 3array ;
  20
  21 GENERIC# zmq-setopt 2 ( obj name value -- )
  22 GENERIC# zmq-getopt 1 ( obj name -- value )
  23
  24 TUPLE: zmq-message underlying ;
  25
  26 : <zmq-message> ( -- msg )
  27     zmq_msg_t <struct>
  28     [ zmq_msg_init check-zmq-error ]
  29     [ zmq-message boa ] bi ;
  30
  31 M: zmq-message dispose
  32     underlying>> zmq_msg_close check-zmq-error ;
  33
  34 : byte-array>zmq-message ( byte-array -- msg )
  35     zmq_msg_t <struct>
  36     [ over length zmq_msg_init_size check-zmq-error ]
  37     [ zmq_msg_data swap dup length memcpy ]
  38     [ zmq-message boa ] tri ;
  39
  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 ;
  43
  44 TUPLE: zmq-context underlying ;
  45
  46 ! this uses the "New API" with version 3
  47 ! previous versions should use zmq_init and zmq_term
  48
  49 : <zmq-context> ( -- context )
  50     zmq_ctx_new zmq-context boa ;
  51
  52 M: zmq-context dispose
  53     underlying>> zmq_ctx_destroy check-zmq-error ;
  54
  55 M: zmq-context zmq-setopt
  56     [ underlying>> ] 2dip zmq_ctx_set check-zmq-error ;
  57
  58 M: zmq-context zmq-getopt
  59     [ underlying>> ] dip zmq_ctx_get ;
  60
  61 TUPLE: zmq-socket underlying ;
  62
  63 : <zmq-socket> ( context type -- socket )
  64     [ underlying>> ] dip zmq_socket
  65     dup [ zmq-error ] unless
  66     zmq-socket boa ;
  67
  68 M: zmq-socket dispose
  69     underlying>> zmq_close check-zmq-error ;
  70
  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 ;
  78
  79 : zmq-bind ( socket addr -- )
  80     [ underlying>> ] dip zmq_bind check-zmq-error ;
  81
  82 : zmq-unbind ( socket addr -- )
  83     [ underlying>> ] dip zmq_unbind check-zmq-error ;
  84
  85 : zmq-connect ( socket addr -- )
  86     [ underlying>> ] dip zmq_connect check-zmq-error ;
  87
  88 : zmq-disconnect ( socket addr -- )
  89     [ underlying>> ] dip zmq_disconnect check-zmq-error ;
  90
  91 : zmq-sendmsg ( socket msg flags -- )
  92     [ [ underlying>> ] bi@ ] dip zmq_sendmsg
  93     0 < [ zmq-error ] when ;
  94
  95 : zmq-recvmsg ( socket msg flags -- )
  96     [ [ underlying>> ] bi@ ] dip zmq_recvmsg
  97     0 < [ zmq-error ] when ;
  98
  99 : zmq-send ( socket byte-array flags -- )
 100     [ byte-array>zmq-message ] dip
 101     '[ _ zmq-sendmsg ] with-disposal ;
 102
 103 : zmq-recv ( socket flags -- byte-array )
 104     <zmq-message> [
 105         [ swap zmq-recvmsg ] [ zmq-message>byte-array ] bi
 106     ] with-disposal ;