├── COPYING.BSD ├── COPYING.LESSER ├── README ├── TODO ├── build.tcl ├── doc ├── build.tcl ├── zmq.man ├── zmq_context.inc ├── zmq_device.inc ├── zmq_examples.inc ├── zmq_message.inc ├── zmq_misc.inc ├── zmq_multipart.inc ├── zmq_polling.inc └── zmq_socket.inc ├── examples ├── asyncsrv.tcl ├── bstar.tcl ├── bstarcli.tcl ├── bstarsrv.tcl ├── bstarsrv2.tcl ├── clonecli1.tcl ├── clonecli2.tcl ├── clonecli3.tcl ├── clonecli4.tcl ├── clonecli5.tcl ├── clonesrv1.tcl ├── clonesrv2.tcl ├── clonesrv3.tcl ├── clonesrv4.tcl ├── clonesrv5.tcl ├── durapub.tcl ├── durapub2.tcl ├── durasub.tcl ├── flcliapi.tcl ├── flclient1.tcl ├── flclient2.tcl ├── flclient3.tcl ├── flserver1.tcl ├── flserver2.tcl ├── flserver3.tcl ├── hwclient.tcl ├── hwserver.tcl ├── identity.tcl ├── kvmsg.tcl ├── kvsimple.tcl ├── lpclient.tcl ├── lpserver.tcl ├── lruqueue.tcl ├── mdbroker.tcl ├── mdcliapi.tcl ├── mdcliapi2.tcl ├── mdclient.tcl ├── mdclient2.tcl ├── mdp.tcl ├── mdworker.tcl ├── mdwrkapi.tcl ├── mmiecho.tcl ├── msgqueue.tcl ├── mspoller.tcl ├── msreader.tcl ├── peering1.tcl ├── peering2.tcl ├── peering3.tcl ├── pkgIndex.tcl ├── ppqueue.tcl ├── ppworker.tcl ├── psenvpub.tcl ├── psenvsub.tcl ├── rrbroker.tcl ├── rrbroker_callback.tcl ├── rrclient.tcl ├── rrserver.tcl ├── rtdealer.tcl ├── rtmama.tcl ├── rtpapa.tcl ├── spqueue.tcl ├── spworker.tcl ├── suisnail.tcl ├── syncpub.tcl ├── syncsub.tcl ├── syncsub_callback.tcl ├── tasksink.tcl ├── tasksink2.tcl ├── taskvent.tcl ├── taskvent_callback.tcl ├── taskwork.tcl ├── taskwork2.tcl ├── taskwork2_callback.tcl ├── ticlient.tcl ├── titanic.tcl ├── tripping.tcl ├── version.tcl ├── wuasyncclient.tcl ├── wuclient.tcl ├── wuproxy.tcl ├── wuproxyclient.tcl ├── wuserver.tcl └── wuserver_monitored.tcl ├── regression ├── cget.tcl ├── look_for_failed_tests.tcl ├── regression.csh ├── win32.bat └── win64.bat ├── test ├── all.tcl ├── context.test ├── device.test ├── message.test ├── poll.test ├── proxy.test ├── socket.test ├── utils.test └── zmsg.test ├── zmq.tcl ├── zmq_helper.tcl └── zmq_nMakefiles └── Makefile /COPYING.BSD: -------------------------------------------------------------------------------- 1 | zmq is licensed under the terms of the Modified BSD License (also known as 2 | New or Revised BSD), as follows: 3 | 4 | Copyright (c) 2012, Jos Decoster (jos.decoster@gmail.com) 5 | 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without modification, 9 | are permitted provided that the following conditions are met: 10 | 11 | Redistributions of source code must retain the above copyright notice, this list 12 | of conditions and the following disclaimer. 13 | 14 | Redistributions in binary form must reproduce the above copyright notice, this 15 | list of conditions and the following disclaimer in the documentation and/or 16 | other materials provided with the distribution. 17 | 18 | Neither the name of zmq nor the names of its contributors may be used to 19 | endorse or promote products derived from this software without specific prior 20 | written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 23 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 26 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 27 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 29 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - examples from ZMQ Guide: 2 | 3 | - flserver3, flclien3, flcliapi: with same problem as C version 4 | - clonesrv6, clonecli6, clone 5 | 6 | - memory leak checks 7 | 8 | - multi threading 9 | 10 | - 4.0.1 11 | 12 | zmq_ctx_shutdown (not yet in zeromq docs?) 13 | zmq_send_const (won't add) 14 | 15 | #define ZMQ_POLLITEMS_DFLT 16 (internal array size) 16 | 17 | zmq_z85_encode (later, can't get libsodium to work for now) 18 | zmq_z85_decode (later, can't get libsodium to work for now) 19 | -------------------------------------------------------------------------------- /doc/build.tcl: -------------------------------------------------------------------------------- 1 | package require doctools 2 | 3 | if {[llength $argv]} { 4 | lassign $argv format 5 | } else { 6 | set format html 7 | } 8 | 9 | set on [doctools::new on -format $format] 10 | set f [open zmq.html w] 11 | puts $f [$on format {[include zmq.man]}] 12 | close $f 13 | 14 | $on destroy 15 | -------------------------------------------------------------------------------- /doc/zmq.man: -------------------------------------------------------------------------------- 1 | [comment {-*- tcl -*- doctools manpage}] 2 | [manpage_begin zmq n 4.0.1] 3 | [copyright {Jos Decoster }] 4 | [moddesc {A Tcl wrapper for the ZeroMQ messaging library}] 5 | [category {Messaging}] 6 | [keywords {messaging}] 7 | [keywords {inter process communication}] 8 | [keywords {RPC}] 9 | [keywords {message queue}] 10 | [keywords {queue}] 11 | [keywords {broadcast}] 12 | [keywords {communication}] 13 | [keywords {producer - consumer}] 14 | [keywords {publish - subscribe}] 15 | [titledesc {Zmq Package Reference}] 16 | [require Tcl 8.5] 17 | [require zmq [opt 4.0.1]] 18 | [description] 19 | 20 | The [term zmq] package is a wrapper for the ZeroMQ library. ZeroMQ can be found 21 | at [uri http://www.zeromq.org]. 22 | 23 | [para] 24 | 25 | The wrapper is based on version 4.0.1 of the ZeroMQ library. The package is 26 | written using [term critcl] 3. 27 | 28 | [para] 29 | 30 | Use this documentation in combination with the ZeroMQ documentation for more 31 | details. 32 | 33 | [para] 34 | 35 | All sockets in this documentation refer to ZeroMQ sockets. 36 | 37 | [para] 38 | 39 | The ZeroMQ API use [term set] and [term get] functions to set or get context, 40 | socket and message options. This wrapper provides [term set] and [term get] 41 | methods for contexts, sockets and message for compatibility with the ZeroMQ API 42 | but also provides the more Tcl style [term cget] and [term configure] methods. 43 | 44 | [para] 45 | 46 | The ZeroMQ API uses [term destroy] for contexts and [term close] for sockets and 47 | messages. This wrapper provides the same methods for compatibility with the 48 | ZeroMQ API but also provides a [term destroy] method for sockets and messages. 49 | 50 | 51 | [include zmq_context.inc] 52 | [include zmq_socket.inc] 53 | [include zmq_message.inc] 54 | [include zmq_multipart.inc] 55 | [include zmq_polling.inc] 56 | [include zmq_device.inc] 57 | [include zmq_misc.inc] 58 | [include zmq_examples.inc] 59 | 60 | [section "Bugs, ideas, feedback"] 61 | 62 | This document, and the package it describes, will undoubtedly contain 63 | bugs and other problems. 64 | 65 | Please report such at the [uri {https://github.com/jdc8/tclzmq/issues} {Github tracker}]. 66 | 67 | Please also report any ideas for enhancements you may have for either 68 | package and/or documentation. 69 | 70 | [section "License"] 71 | 72 | [term zmq] uses different licenses for different parts of the code. 73 | 74 | The 'core' of [term zmq] (located in [term zmq.tcl]) is licensed under 75 | LGPLv3. This just means that if you make any changes to how that code works, you 76 | must release those changes under the LGPL. If you just use [term zmq], then you 77 | can use any license you want for your own code. Check [term COPYING.LESSER] for 78 | more info. 79 | [para] 80 | The restrictions imposed by the LGPL make no sense for the 'non-core' 81 | functionality in [term zmq] (derivative code must also be LGPL or GPL), 82 | especially for examples, so all 'non-core' code is relicensed under the more 83 | permissive BSD license (specifically Modified BSD aka New BSD aka 3-clause BSD), where 84 | possible. This means that you can copy this code and build your own apps without 85 | needing to license your own code with the LGPL or GPL. Check [term COPYING.BSD] 86 | for more info. 87 | 88 | [manpage_end] 89 | -------------------------------------------------------------------------------- /doc/zmq_context.inc: -------------------------------------------------------------------------------- 1 | [section "Contexts"] 2 | 3 | [subsection {Context PACKAGE COMMANDS}] 4 | 5 | [list_begin definitions] 6 | 7 | [call [cmd {zmq context}] [opt [arg contextName]] [opt [arg {-io_threads }]]] 8 | 9 | This command creates a new ZeroMQ context object and associated Tcl object 10 | command whose name is [arg contextName] if specified or auto generated if not 11 | specified. The object command will be created under the current namespace if the 12 | [arg contextName] is not fully qualified, and in the specified namespace 13 | otherwise. The object command name is returned by this command. The object 14 | command methods are explained in section [sectref {Context OBJECT METHODS}]. 15 | 16 | [list_end] 17 | 18 | [subsection {Context OBJECT METHODS}] 19 | 20 | [list_begin definitions] 21 | 22 | [call [arg contextName] [method cget] [arg optionName]] 23 | 24 | Get context option. See [cmd configure] method for list of supported 25 | options. 26 | 27 | [call [arg contextName] [method configure] [opt [arg optionName]] [opt [arg "optionValue optionName optionValue ..."]]] 28 | 29 | Query or modify context options. If no option is specified, returns a list 30 | describing all of the available options. If option is specified with no value, 31 | then the command returns the value for the specified option. If one or more 32 | option-value pairs are specified, then the command modifies the given context 33 | option(s) to have the given value(s); in this case the command returns an empty 34 | string. Supported options with associated data type are: 35 | 36 | [list_begin options] 37 | [opt_def IO_THREADS] integer 38 | [opt_def MAX_SOCKETS] integer 39 | [list_end] 40 | 41 | [call [arg contextName] [method destroy]] 42 | 43 | Destroy the ZeroMQ context and delete the associated Tcl object command. 44 | 45 | [call [arg contextName] [method get] [arg optionName]] 46 | 47 | Get context option. See [cmd configure] method for list of supported options. 48 | 49 | [call [arg contextName] [method set] [arg optionName] [arg optionValue]] 50 | 51 | Set context option. See [cmd configure] method for list of supported options. 52 | 53 | [list_end] 54 | -------------------------------------------------------------------------------- /doc/zmq_device.inc: -------------------------------------------------------------------------------- 1 | [section {Devices}] 2 | 3 | [list_begin definitions] 4 | 5 | [call [cmd {zmq device}] [arg deviceType] [arg inputSocketName] [arg outputSocketName]] 6 | 7 | Start a built-in ZeroMQ device. Known devices are: 8 | 9 | [list_begin options] 10 | [opt_def FORWARDER] 11 | [opt_def QUEUE] 12 | [opt_def STREAMER] 13 | [list_end] 14 | 15 | [list_end] 16 | -------------------------------------------------------------------------------- /doc/zmq_examples.inc: -------------------------------------------------------------------------------- 1 | 2 | [section Examples] 3 | 4 | A weather data publishing server, also found in the [uri {http://zguide.zeromq.org/page:all#Getting-the-Message-Out} {ZeroMQ Guide}]: 5 | 6 | [example {# 7 | # Weather update server 8 | # Binds PUB socket to tcp:#*:5556 9 | # Publishes random weather updates 10 | # 11 | 12 | package require zmq 13 | 14 | # Prepare our context and publisher 15 | zmq context context 16 | 17 | zmq socket publisher context PUB 18 | publisher bind "tcp://*:5556" 19 | if {$::tcl_platform(platform) ne "windows"} { 20 | publisher bind "ipc://weather.ipc" 21 | } 22 | 23 | # Initialize random number generator 24 | expr {srand([clock seconds])} 25 | 26 | while {1} { 27 | # Get values that will fool the boss 28 | set zipcode [expr {int(rand()*100000)}] 29 | set temperature [expr {int(rand()*215)-80}] 30 | set relhumidity [expr {int(rand()*50)+50}] 31 | # Send message to all subscribers 32 | set data [format "%05d %d %d" $zipcode $temperature $relhumidity] 33 | if {$zipcode eq "10001"} { 34 | puts $data 35 | } 36 | zmq message msg -data $data 37 | publisher send_msg msg 38 | msg destroy 39 | update idletasks 40 | } 41 | 42 | publisher destroy 43 | context destroy}] 44 | 45 | And the corresponding client: 46 | 47 | [example {# 48 | # Weather update client 49 | # Connects SUB socket to tcp:#localhost:5556 50 | # Collects weather updates and finds avg temp in zipcode 51 | # 52 | 53 | package require zmq 54 | 55 | # Socket to talk to server 56 | zmq context context 57 | zmq socket subscriber context SUB 58 | subscriber connect "tcp://localhost:5556" 59 | 60 | # Subscribe to zipcode, default is NYC, 10001 61 | if {[llength $argv]} { 62 | set filter [lindex $argv 0] 63 | } else { 64 | set filter "10001" 65 | } 66 | 67 | subscriber setsockopt SUBSCRIBE $filter 68 | 69 | # Process updates 70 | set total_temp 0 71 | for {set update_nbr 0} {$update_nbr < 10} {incr update_nbr} { 72 | zmq message msg 73 | subscriber recv_msg msg 74 | lassign [msg data] zipcode temperature relhumidity 75 | puts [msg data] 76 | msg close 77 | incr total_temp $temperature 78 | } 79 | 80 | puts "Averate temperatur for zipcode $filter was [expr {$total_temp/$update_nbr}]F" 81 | 82 | subscriber destroy 83 | context destroy}] 84 | 85 | Or the client rewritten to process the messages from the publisher asynchronously: 86 | 87 | [example {# 88 | # Weather update client 89 | # Connects SUB socket to tcp:#localhost:5556 90 | # Collects weather updates and finds avg temp in zipcode 91 | # 92 | 93 | package require zmq 94 | 95 | # Socket to talk to server 96 | zmq context context 97 | zmq socket subscriber context SUB 98 | subscriber connect "tcp://localhost:5556" 99 | 100 | # Subscribe to zipcode, default is NYC, 10001 101 | if {[llength $argv]} { 102 | set filter [lindex $argv 0] 103 | } else { 104 | set filter "10001" 105 | } 106 | 107 | proc get_weather {} { 108 | global total_temp cnt done 109 | set data [subscriber recv] 110 | puts $data 111 | lassign $data zipcode temperature relhumidity 112 | incr total_temp $temperature 113 | incr cnt 114 | if {$cnt >= 10} { 115 | set done 1 116 | } 117 | } 118 | 119 | subscriber setsockopt SUBSCRIBE $filter 120 | set total_temp 0 121 | set cnt 0 122 | subscriber readable get_weather 123 | 124 | # Process updates 125 | vwait done 126 | 127 | puts "Averate temperatur for zipcode $filter was [expr {$total_temp/$cnt}]F" 128 | 129 | subscriber destroy 130 | context destroy}] 131 | 132 | More Tcl example can be found in the [uri {http://zguide.zeromq.org/page:all} {ZeroMQ Guide}]. 133 | -------------------------------------------------------------------------------- /doc/zmq_message.inc: -------------------------------------------------------------------------------- 1 | [section {Messages}] 2 | 3 | [subsection {Message PACKAGE COMMANDS}] 4 | 5 | [list_begin definitions] 6 | 7 | [call [cmd {zmq message}] [opt [arg messageName]] [opt [arg {-size }]] [opt [arg {-data }]]] 8 | 9 | This command creates a new ZeroMQ message object and associated Tcl object 10 | command whose name is [arg messageName] if specified or auto generated if not 11 | specified with specified size and data. The object command will be created under 12 | the current namespace if the [arg messageName] is not fully qualified, and in the 13 | specified namespace otherwise. The object command name is returned by this 14 | command. The object command methods are explained in section [sectref {Message OBJECT METHODS}]. 15 | 16 | [para] 17 | The use of this message type is not needed with the wrapper. Check the 18 | [sectref {Socket OBJECT METHODS}] for socket commands directly reading and writing string 19 | and [sectref {Message helper functions}] for utility functions to read and write 20 | strings. 21 | 22 | [list_end] 23 | 24 | [subsection {Message OBJECT METHODS}] 25 | 26 | [list_begin definitions] 27 | 28 | [call [arg messageName] [method cget] [arg optionName]] 29 | 30 | Get message option. See [cmd configure] method for list of supported options. 31 | 32 | [call [arg messageName] [method close]] 33 | 34 | See [cmd destroy] method. 35 | 36 | [call [arg messageName] [method configure] [opt [arg optionName]] [opt [arg "optionValue optionName optionValue ..."]]] 37 | 38 | Query or modify message options. If no option is specified, returns a list 39 | describing all of the available options. If option is specified with no value, 40 | then the command returns the value for the specified option. If one or more 41 | option-value pairs are specified, then the command modifies the given message 42 | option(s) to have the given value(s); in this case the command returns an empty 43 | string. Supported options with associated data type are: 44 | 45 | [list_begin options] 46 | [opt_def MORE] integer, read-only 47 | [list_end] 48 | 49 | [call [arg messageName] [method copy] [arg destinationMessageName]] 50 | 51 | Copy the message to the specified message. 52 | 53 | [call [arg messageName] [method data]] 54 | 55 | Get the message data as a (binary) string. 56 | 57 | [call [arg messageName] [method destroy]] 58 | 59 | Close the ZeroMQ message and delete the associated Tcl object command. 60 | 61 | [call [arg messageName] [method dump]] 62 | 63 | Get the message as a human readable string. 64 | 65 | [call [arg messageName] [method get] [arg optionName]] 66 | 67 | Get message option. See [cmd configure] method for list of supported options. 68 | 69 | [call [arg messageName] [method more]] 70 | 71 | Get indication if more messages are to be received as part of a multi part 72 | message. 73 | 74 | [call [arg messageName] [method move] [arg destinationMessageName]] 75 | 76 | Move contents to the specified message. 77 | 78 | [call [arg messageName] [method recv] [arg socketName] [opt [arg flagsList]]] 79 | 80 | Receive a message on the specified socket. Only the [term DONTWAIT] flag is supported. 81 | 82 | [call [arg messageName] [method send] [arg socketName] [opt [arg flagsList]]] 83 | 84 | Send a message to the specified socket as message part. Supported flags are 85 | [term DONTWAIT] and [term SNDMORE]. 86 | 87 | [call [arg messageName] [method sendmore] [arg socketName] [opt [arg flagsList]]] 88 | 89 | Send a message to the specified socket as message part and indicate there are 90 | more parts to come as part of a multi part message. Supported flags are 91 | [term DONTWAIT] and [term SNDMORE]. 92 | 93 | [call [arg messageName] [method set] [arg optionName] [arg optionValue]] 94 | 95 | Set message option. See [cmd configure] method for list of supported options. 96 | 97 | [call [arg messageName] [method size]] 98 | 99 | Return the size of the message data part. 100 | 101 | [list_end] 102 | -------------------------------------------------------------------------------- /doc/zmq_misc.inc: -------------------------------------------------------------------------------- 1 | [section {Socket monitoring}] 2 | 3 | [list_begin definitions] 4 | 5 | [call [cmd zmq] [method monitor] [arg contextName] [arg socketName] [arg callbackCommand] [opt [arg eventsList]]] 6 | 7 | Helper function for monitoring socket events. This function is a wrapper for the 8 | [term {socket monitor}] and [term {socket recv_monitor_event}] commands. The 9 | event dictionary as read with the [term {socket recv_monitor_event}] is 10 | lappended to the callback-command and the callback command is executed each time 11 | one of the specified events is triggered for the specified socket. The 12 | event-loop must be executed in order to be able to receive monitoring callback 13 | in this way. 14 | 15 | [list_end] 16 | 17 | Supported events for monitoring are: 18 | 19 | [list_begin options] 20 | [opt_def ACCEPTED] 21 | [opt_def ACCEPT_FAILED] 22 | [opt_def ALL] 23 | [opt_def BIND_FAILED] 24 | [opt_def CLOSED] 25 | [opt_def CLOSE_FAILED] 26 | [opt_def CONNECTED] 27 | [opt_def CONNECT_DELAYED] 28 | [opt_def CONNECT_RETRIED] 29 | [opt_def DISCONNECTED] 30 | [opt_def LISTENING] 31 | [list_end] 32 | 33 | [section {Miscellaneous}] 34 | 35 | [list_begin definitions] 36 | 37 | [call [cmd {zmq version}]] 38 | 39 | Return the ZeroMQ version used by the Tcl wrapper. 40 | 41 | [call [cmd {zmq errno}]] 42 | 43 | Return the last returned ZeroMQ error code. 44 | 45 | [call [cmd {zmq strerror}] [arg errorNumber]] 46 | 47 | Return the human readable string for a ZeroMQ error code. 48 | 49 | [call [cmd {zmq max_block_time}] [arg blockTime]] 50 | 51 | Set maximum blocking time for the Tcl event loop waiting for ZeroMQ event in 52 | micro seconds. Default is 1000 micro seconds. 53 | 54 | [list_end] 55 | -------------------------------------------------------------------------------- /doc/zmq_multipart.inc: -------------------------------------------------------------------------------- 1 | [section {Multi-part message helper functions}] 2 | 3 | ZeroMQ sends multi-part messages (e.g. when using envelopes). These helper 4 | functions can be used to make it easier to handle those. Data is specified as a 5 | (binary) string. A multi-part message is specified a a list of (binary) strings. 6 | 7 | [list_begin definitions] 8 | 9 | [call [cmd {zmsg add}] [arg messageList] [arg data]] 10 | 11 | Add a message part to a multi-part message. The updated multi-part message is 12 | returned. 13 | 14 | [call [cmd {zmsg dump}] [arg messageList]] 15 | 16 | Return the multi-part message in a human readable form. 17 | 18 | [call [cmd {zmsg pop}] [arg messageListName]] 19 | 20 | Pop a message part from the beginning of the specified multi-part message. The 21 | popped message part is returned and the specified multi-part message is modified. 22 | 23 | [call [cmd {zmsg push}] [arg messageList] [arg data]] 24 | 25 | Push a message part to the beginning of a multi-part message. The modified 26 | multi-part message is returned. 27 | 28 | [call [cmd {zmsg recv}] [arg socketName]] 29 | 30 | Receive a multi-part message on the specified socket. The received message is 31 | returned. 32 | 33 | [call [cmd {zmsg send}] [arg socketName] [arg messageList]] 34 | 35 | Send a multi-part message to the specified socket. 36 | 37 | [call [cmd {zmsg unwrap}] [arg messageListName]] 38 | 39 | Unwrap multi-part message. The unwrapped message part is returned. An empty 40 | message-part following the unwrapped message part (e.g as part of an envelope) 41 | is also removed. 42 | 43 | [call [cmd {zmsg wrap}] [arg messageList] [arg data]] 44 | 45 | Wrap the multi-part message with the specified data. An empty message part is 46 | inserted between the specified data and the spoecified multi-part message. 47 | 48 | [list_end] 49 | -------------------------------------------------------------------------------- /doc/zmq_polling.inc: -------------------------------------------------------------------------------- 1 | [section {Polling}] 2 | 3 | [list_begin definitions] 4 | 5 | [call [cmd {zmq poll}] [arg pollList] [arg timeout] [opt [arg timeoutUnit]]] 6 | 7 | Poll the specified sockets for the specifed events. A maximum timeout must be 8 | specified. If the value of timeout is 0, the command returns immediately. If the 9 | value of timeout is -1, the command will block indefinitely until a specified 10 | event occurs. The polling list if specified as a list of poll requests. Such a poll request is a list of: 11 | 12 | [list_begin enumerated] 13 | [enum] socket 14 | [enum] list of event flags 15 | [list_end] 16 | 17 | Supported event flags are: 18 | 19 | [list_begin options] 20 | [opt_def POLLIN] 21 | [opt_def POLLOUT] 22 | [list_end] 23 | 24 | The poll command will return a list in the same format as the input polling list 25 | with list items for each item in the original list for which an event occured 26 | and in the list of event flags the events which occured. 27 | 28 | [list_end] 29 | -------------------------------------------------------------------------------- /doc/zmq_socket.inc: -------------------------------------------------------------------------------- 1 | [section {Sockets}] 2 | 3 | [subsection {Socket PACKAGE COMMANDS}] 4 | 5 | [list_begin definitions] 6 | 7 | [call [cmd {zmq socket}] [opt [arg socketName]] [arg contextName] [arg socketType]] 8 | 9 | This command creates a new ZeroMQ socket object and associated Tcl object 10 | command whose name is [arg socketName] if specified or auto generated if not 11 | specified within the specified context and of the specified type. The object 12 | command will be created under the current namespace if the [arg socketName] is 13 | not fully qualified, and in the specified namespace otherwise. The object 14 | command name is returned by this command. The object command methods are 15 | explained in section [sectref {Socket OBJECT METHODS}]. 16 | 17 | Valid values for [arg socketType] are: 18 | 19 | [list_begin options] 20 | [opt_def DEALER] 21 | [opt_def PAIR] 22 | [opt_def PUB] 23 | [opt_def PULL] 24 | [opt_def PUSH] 25 | [opt_def REP] 26 | [opt_def REQ] 27 | [opt_def ROUTER] 28 | [opt_def STREAM] 29 | [opt_def SUB] 30 | [opt_def XPUB] 31 | [opt_def XSUB] 32 | [list_end] 33 | 34 | [list_end] 35 | 36 | [subsection {Socket OBJECT METHODS}] 37 | 38 | [list_begin definitions] 39 | 40 | [call [arg socketName] [method bind] [arg endPoint]] 41 | 42 | Accept connections on a socket for specified endpoint. 43 | 44 | [call [arg socketName] [method cget] [arg optionName]] 45 | 46 | Get socket option. See [cmd configure] method for list of supported options. 47 | 48 | [call [arg socketName] [method close]] 49 | 50 | See [cmd destroy] method. 51 | 52 | [call [arg socketName] [method configure] [opt [arg optionName]] [opt [arg "optionValue optionName optionValue ..."]]] 53 | 54 | Query or modify socket options. If no option is specified, returns a list 55 | describing all of the available options. If option is specified with no value, 56 | then the command returns the value for the specified option. If one or more 57 | option-value pairs are specified, then the command modifies the given socket 58 | option(s) to have the given value(s); in this case the command returns an empty 59 | string. Supported options with associated data type are: 60 | 61 | [list_begin options] 62 | [opt_def AFFINITY] unsigned wide integer 63 | [opt_def BACKLOG] integer 64 | [opt_def EVENTS] list of poll flags: [term POLLIN], [term POLLOUT] or [term POLLERR] 65 | [opt_def ROUTER_MANDATORY] integer, write-only 66 | [opt_def IDENTITY] binary 67 | [opt_def IMMEDIATE] integer 68 | [opt_def LAST_ENDPOINT] binary, read-only 69 | [opt_def LINGER] integer 70 | [opt_def MAXMSGSIZE] wide integer 71 | [opt_def MECHANISM] enum: [term NULL], [term PLAIN], or [term CURVE], read-only 72 | [opt_def MULTICAST_HOPS] integer 73 | [opt_def RATE] integer 74 | [opt_def RCVBUF] integer 75 | [opt_def RCVHWM] integer 76 | [opt_def RCVMORE] integer, read-only 77 | [opt_def RCVTIMEO] integer 78 | [opt_def RECONNECT_IVL] integer 79 | [opt_def RECONNECT_IVL_MAX] integer 80 | [opt_def RECOVERY_IVL] integer 81 | [opt_def ROUTER_MANDATORY] integer, write-only 82 | [opt_def SNDBUF] integer 83 | [opt_def SNDHWM] integer 84 | [opt_def SNDTIMEO] integer 85 | [opt_def SUBSCRIBE] binary, write-only 86 | [opt_def TCP_ACCEPT_FILTER] string, write-only 87 | [opt_def TCP_KEEPALIVE] integer 88 | [opt_def TCP_KEEPALIVE_CNT] integer 89 | [opt_def TCP_KEEPALIVE_IDLE] integer 90 | [opt_def TCP_KEEPALIVE_INTVL] integer 91 | [opt_def TYPE] integer 92 | [opt_def UNSUBSCRIBE] binary, write-only 93 | [opt_def XPUB_VERBOSE] integer, write-only 94 | [opt_def PLAIN_SERVER] integer 95 | [opt_def PLAIN_USERNAME] string 96 | [opt_def PLAIN_PASSWORD] string 97 | [opt_def CURVE_SERVER] integer 98 | [opt_def CURVE_PUBLICKEY] string 99 | [opt_def CURVE_SECRETKEY] string 100 | [opt_def CURVE_SERVERKEY] string 101 | [opt_def PROBE_ROUTER] integer 102 | [opt_def REQ_CORRELATE] integer 103 | [opt_def REQ_RELAXED] integer 104 | [opt_def CONFLATE] integer, write-only 105 | [opt_def ZAP_DOMAIN] string 106 | [opt_def IPV6] integer 107 | [list_end] 108 | 109 | [call [arg socketName] [method connect] [arg endPoint]] 110 | 111 | Connect to a socket on the specified endpoint. 112 | 113 | [call [arg socketName] [method destroy]] 114 | 115 | Close the ZeroMQ socket and delete the associated Tcl object command. 116 | 117 | [call [arg socketName] [method disconnect] [arg endPoint]] 118 | 119 | Disconnect from a socket on the specified endpoint. 120 | 121 | [call [arg socketName] [method dump]] 122 | 123 | Read message from the socket and return it in human readable debug format. 124 | 125 | [call [arg socketName] [method get] [arg optionName]] 126 | 127 | Get socket option. See [cmd configure] method for list of supported options. 128 | 129 | [call [arg socketName] [method monitor] [arg endPoint] [opt [arg eventsList]]] 130 | 131 | Arrange for monitoring the specified events. If no events are specified, all 132 | events are monitored. Monitoring information is available on a socket of type 133 | [term PAIR] on the specified end-point. Known events can be found in [sectref {Socket monitoring}] 134 | 135 | [call [arg socketName] [method readable] [opt [arg command]]] 136 | 137 | If specified set, or if not specified get, the socket readable callback command. 138 | 139 | [call [arg socketName] [method recv] [opt [arg flagsList]]] 140 | 141 | Read a message part from the socket and return it as a string. Only the 142 | [term DONTWAIT] flag is supported. 143 | 144 | [call [arg socketName] [method recv_monitor_event]] 145 | 146 | Read a monitor event part from the monitor socket and return it as a 147 | dictionary. The socket must be of type [term PAIR] and must be connected to the 148 | end-point passed to the [term {socket monitor}] command. The dictionary will 149 | contain the triggered event and extra information depending on the triggered 150 | event (e.g address, error code, ...). More infomation about monitoring and 151 | possible events can be found in [sectref {Socket monitoring}]. 152 | 153 | [call [arg socketName] [method recv_msg] [arg message] [opt [arg flagsList]]] 154 | 155 | Read a message part from the socket and place it in the specified message 156 | object. Only the [term DONTWAIT] flag is supported. 157 | 158 | [call [arg socketName] [method send] [arg data] [opt [arg flagsList]]] 159 | 160 | Send the specified data to the socket as message part. Supported flags are 161 | [term DONTWAIT] and [term SNDMORE]. 162 | 163 | [call [arg socketName] [method send_msg] [arg message] [opt [arg flagsList]]] 164 | 165 | Send the message part in the specified message object to the socket. Supported 166 | flags are [term DONTWAIT] and [term SNDMORE]. 167 | 168 | [call [arg socketName] [method sendmore] [arg data] [opt [arg flagsList]]] 169 | 170 | Send the specified data to the socket as message part and indicate there are more 171 | message parts to come. Supported flags are [term DONTWAIT] and [term SNDMORE]. 172 | 173 | [call [arg socketName] [method set] [arg optionName] [arg optionValue] [opt [arg optionSize]]] 174 | 175 | Set socket option. See [cmd configure] method for list of supported options. 176 | 177 | [call [arg socketName] [method unbind] [arg endPoint]] 178 | 179 | Stop accepting connections on a socket for the specified endpoint. 180 | 181 | [call [arg socketName] [method writable] [opt [arg command]]] 182 | 183 | If specified set, or if not specified get, the socket writable callback command. 184 | 185 | [list_end] 186 | -------------------------------------------------------------------------------- /examples/asyncsrv.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Asynchronous client-to-server (DEALER to ROUTER) 3 | # 4 | 5 | if {[llength $argv] == 0} { 6 | set argv [list driver 3 5] 7 | } elseif {[llength $argv] != 3} { 8 | puts "Usage: asyncsrv.tcl ? ?" 9 | exit 1 10 | } 11 | 12 | set tclsh [info nameofexecutable] 13 | lassign $argv what NBR_CLIENTS NBR_WORKERS 14 | expr {srand([pid])} 15 | 16 | switch -exact -- $what { 17 | client { 18 | # This is our client task 19 | # It connects to the server, and then sends a request once per second 20 | # It collects responses as they arrive, and it prints them out. We will 21 | # run several client tasks in parallel, each with a different random ID. 22 | 23 | package require zmq 24 | 25 | zmq context context 26 | zmq socket client context DEALER 27 | 28 | # Set random identity to make tracing easier 29 | set identity [format "%04X-%04X" [expr {int(rand()*0x10000)}] [expr {int(rand()*0x10000)}]] 30 | client setsockopt IDENTITY $identity 31 | client connect "tcp://localhost:5570" 32 | 33 | proc receive {} { 34 | global identity 35 | puts "Client $identity received [client recv]" 36 | } 37 | 38 | proc request {} { 39 | global request_nbr identity 40 | incr request_nbr 41 | puts "Client $identity sent request \#$request_nbr" 42 | client send "request \#$request_nbr" 43 | after 1000 "request" 44 | } 45 | 46 | # Process responses 47 | client readable receive 48 | 49 | # Send a request every second 50 | set request_nbr 0 51 | after 1000 request 52 | 53 | vwait forever 54 | 55 | client close 56 | context term 57 | } 58 | worker { 59 | # This is our worker task 60 | # Accept a request and reply with the same text a random number of 61 | # times, with random delays between replies. 62 | 63 | package require zmq 64 | 65 | zmq context context 66 | zmq socket worker context DEALER 67 | worker connect "ipc://backend" 68 | 69 | while {1} { 70 | # The DEALER socket gives us the address envelope and message 71 | set address [worker recv] 72 | set content [worker recv] 73 | 74 | puts "worker received $content from $address" 75 | 76 | # Send 0..4 replies back 77 | set replies [expr {int(rand()*5)}] 78 | for {set reply 0} {$reply < $replies} {incr reply} { 79 | # Sleep for some fraction of a second 80 | after [expr {int(rand()*1000) + 1}] 81 | puts "worker send $content to $address" 82 | worker sendmore $address 83 | worker send $content 84 | } 85 | } 86 | } 87 | server { 88 | # This is our server task It uses the multithreaded server model to deal 89 | # requests out to a pool of workers and route replies back to clients. One 90 | # worker can handle one request at a time but one client can talk to multiple 91 | # workers at once. 92 | 93 | package require zmq 94 | 95 | zmq context context 96 | 97 | # Frontend socket talks to clients over TCP 98 | zmq socket frontend context ROUTER 99 | frontend bind "tcp://*:5570" 100 | 101 | # Backend socket talks to workers over inproc 102 | zmq socket backend context DEALER 103 | backend bind "ipc://backend" 104 | 105 | # Launch pool of worker threads, precise number is not critical 106 | for {set thread_nbr 0} {$thread_nbr < $NBR_WORKERS} {incr thread_nbr} { 107 | exec $tclsh asyncsrv.tcl worker $NBR_CLIENTS $NBR_WORKERS > worker$thread_nbr.log 2>@1 & 108 | } 109 | 110 | # Connect backend to frontend via a queue device 111 | # We could do this: 112 | # zmq_device (ZMQ_QUEUE, frontend, backend); 113 | # But doing it ourselves means we can debug this more easily 114 | 115 | proc do_frontend {} { 116 | set address [frontend recv] 117 | set data [frontend recv] 118 | 119 | backend sendmore $address 120 | backend send $data 121 | } 122 | 123 | proc do_backend {} { 124 | set address [backend recv] 125 | set data [backend recv] 126 | 127 | frontend sendmore $address 128 | frontend send $data 129 | } 130 | 131 | backend readable do_backend 132 | frontend readable do_frontend 133 | vwait forever 134 | 135 | frontend close 136 | backend close 137 | context term 138 | } 139 | driver { 140 | puts "Start server, output redirected to server.log" 141 | exec $tclsh asyncsrv.tcl server $NBR_CLIENTS $NBR_WORKERS > server.log 2>@1 & 142 | 143 | after 1000 144 | 145 | for {set i 0} {$i < $NBR_CLIENTS} {incr i} { 146 | puts "Start client $i, output redirect to client$i.log" 147 | exec $tclsh asyncsrv.tcl client $NBR_CLIENTS $NBR_WORKERS > client$i.log 2>@1 & 148 | } 149 | } 150 | } 151 | -------------------------------------------------------------------------------- /examples/bstar.tcl: -------------------------------------------------------------------------------- 1 | # ===================================================================== 2 | # bstar - Binary Star reactor 3 | 4 | # --------------------------------------------------------------------- 5 | # Copyright (c) 1991-2011 iMatix Corporation 6 | # Copyright other contributors as noted in the AUTHORS file. 7 | 8 | # Tcl port by Jos Decoster 9 | 10 | # This file is part of the ZeroMQ Guide: http://zguide.zeromq.org 11 | 12 | # This is free software; you can redistribute it and/or modify it under 13 | # the terms of the GNU Lesser General Public License as published by 14 | # the Free Software Foundation; either version 3 of the License, or (at 15 | # your option) any later version. 16 | 17 | # This software is distributed in the hope that it will be useful, but 18 | # WITHOUT ANY WARRANTY; without even the implied warranty of 19 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 20 | # Lesser General Public License for more details. 21 | 22 | # You should have received a copy of the GNU Lesser General Public 23 | # License along with this program. If not, see 24 | # . 25 | # ===================================================================== 26 | 27 | package require TclOO 28 | package require mdp 29 | package require zmq 30 | 31 | package provide BStar 1.0 32 | 33 | # We send state information every this often 34 | # If peer doesn't respond in two heartbeats, it is 'dead' 35 | set BSTAR_HEARTBEAT 1000 ;# In msecs 36 | 37 | # States we can be in at any point in time 38 | # STATE(NONE) 0 39 | # STATE(PRIMARY) 1 ;# Primary, waiting for peer to connect 40 | # STATE(BACKUP) 2 ;# Backup, waiting for peer to connect 41 | # STATE(ACTIVE) 3 ;# Active - accepting connections 42 | # STATE(PASSIVE) 4 ;# Passive - not accepting connections 43 | 44 | # Events, which start with the states our peer can be in 45 | # EVENT(NONE) 0 46 | # EVENT(PRIMARY) 1 ;# HA peer is pending primary 47 | # EVENT(BACKUP) 2 ;# HA peer is pending backup 48 | # EVENT(ACTIVE) 3 ;# HA peer is active 49 | # EVENT(PASSIVE) 4 ;# HA peer is passive 50 | # EVENT(REQUEST) 5 ;# Client makes request 51 | 52 | oo::class create BStar { 53 | 54 | variable verbose ctx statepub statesub voter state event peer_expiry voterfn masterfn slavefn 55 | 56 | constructor {istate local remote iverbose} { 57 | # Initialize the Binary Star 58 | set verbose $iverbose 59 | set ctx [zmq context] 60 | set state $istate 61 | set event NONE 62 | set peer_expiry 0 63 | set voterfn {} 64 | set masterfn {} 65 | set slavefn {} 66 | # Create publisher for state going to peer 67 | set statepub [zmq socket $ctx PUB] 68 | $statepub bind $local 69 | # Create subscriber for state coming from peer 70 | set statesub [zmq socket $ctx SUB] 71 | $statesub setsockopt SUBSCRIBE "" 72 | $statesub connect $remote 73 | } 74 | 75 | destructor { 76 | $statesub close 77 | $statepub close 78 | $ctx term 79 | } 80 | 81 | method voter_callback {} { 82 | if {[llength $voterfn]} { 83 | {*}$voterfn $voter 84 | } 85 | } 86 | 87 | method master_callback {} { 88 | if {[llength $masterfn]} { 89 | {*}$masterfn 90 | } 91 | } 92 | 93 | method slave_callback {} { 94 | if {[llength $slavefn]} { 95 | {*}$slavefn 96 | } 97 | } 98 | 99 | method log {msg} { 100 | if {$verbose} { 101 | puts "[clock format [clock seconds]] $msg" 102 | } 103 | } 104 | 105 | method execute_fsm {} { 106 | set rc 0 107 | if {$state eq "PRIMARY"} { 108 | # Primary server is waiting for peer to connect 109 | # Accepts CLIENT_REQUEST events in this state 110 | if {$event eq "BACKUP"} { 111 | my log "I: connected to backup (slave), ready as master" 112 | set state ACTIVE 113 | my master_callback 114 | } elseif {$event eq "ACTIVE"} { 115 | my log "I: connected to backup (master), ready as slave" 116 | set state PASSIVE 117 | my slave_callback 118 | } elseif {$event eq "REQUEST"} { 119 | # Allow client requests to turn us into the master if we've 120 | # waited sufficiently long to believe the backup is not 121 | # currently acting as master (i.e., after a failover) 122 | if {$peer_expiry <= 0} { 123 | error "expecte peer_expiry > 0" 124 | } 125 | if {[clock milliseconds] >= $peer_expiry} { 126 | my log "I: request from client, ready as master" 127 | set state ACTIVE 128 | my master_callback 129 | } else { 130 | # Don't respond to clients yet - it's possible we're 131 | # performing a failback and the backup is currently master 132 | set rc -1 133 | } 134 | } 135 | } elseif {$state eq "BACKUP"} { 136 | # Backup server is waiting for peer to connect 137 | # Rejects CLIENT_REQUEST events in this state 138 | if {$event eq "ACTIVE"} { 139 | my log "I: connected to primary (master), ready as slave" 140 | set state PASSIVE 141 | my slave_callback 142 | } elseif {$event eq "REQUEST"} { 143 | set rc -1 144 | } 145 | } elseif {$state eq "ACTIVE"} { 146 | # Server is active 147 | # Accepts CLIENT_REQUEST events in this state 148 | # The only way out of ACTIVE is death 149 | if {$event eq "ACTIVE"} { 150 | my log "E: fatal error - dual masters, aborting" 151 | set rc -1 152 | } 153 | } elseif {$state eq "PASSIVE"} { 154 | # Server is passive 155 | # CLIENT_REQUEST events can trigger failover if peer looks dead 156 | if {$event eq "PRIMARY"} { 157 | # Peer is restarting - become active, peer will go passive 158 | my log "I: primary (slave) is restarting, ready as master" 159 | set state ACTIVE 160 | } elseif {$event eq "BACKUP"} { 161 | # Peer is restarting - become active, peer will go passive 162 | my log "I: backup (slave) is restarting, ready as master" 163 | set state ACTIVE 164 | } elseif {$event eq "PASSIVE"} { 165 | # Two passives would mean cluster would be non-responsive 166 | my log "E: fatal error - dual slaves, aborting" 167 | set rc -1 168 | } elseif {$event eq "REQUEST"} { 169 | # Peer becomes master if timeout has passed 170 | # It's the client request that triggers the failover 171 | if {$peer_expiry < 0} { 172 | error "expecte peer_expiry >= 0" 173 | } 174 | if {[clock milliseconds] >= $peer_expiry} { 175 | # If peer is dead, switch to the active state 176 | my log "I: failover successful, ready as master" 177 | set state ACTIVE 178 | } else { 179 | # If peer is alive, reject connections 180 | set rc -1 181 | } 182 | } 183 | if {$state eq "ACTIVE"} { 184 | my master_callback 185 | } 186 | } 187 | return $rc 188 | } 189 | 190 | method update_peer_expiry {} { 191 | set peer_expiry [expr {[clock milliseconds] + 2 * $::BSTAR_HEARTBEAT}] 192 | } 193 | 194 | # Reactor event handlers... 195 | 196 | # Publish our state to peer 197 | method send_state {} { 198 | my log "I: send state $state to peer" 199 | $statepub send $state 200 | after $::BSTAR_HEARTBEAT [list [self] send_state] 201 | } 202 | 203 | # Receive state from peer, execute finite state machine 204 | method recv_state {} { 205 | set nstate [$statesub recv] 206 | my log "I: got state $nstate from peer" 207 | set event $nstate 208 | my update_peer_expiry 209 | my execute_fsm 210 | } 211 | 212 | # Application wants to speak to us, see if it's possible 213 | method voter_ready {} { 214 | # If server can accept input now, call appl handler 215 | set event REQUEST 216 | if {[my execute_fsm] == 0} { 217 | puts "CLIENT REQUEST" 218 | my voter_callback 219 | } else { 220 | # Destroy waiting message, no-one to read it 221 | zmsg recv $voter 222 | } 223 | } 224 | 225 | # Create socket, bind to local endpoint, and register as reader for 226 | # voting. The socket will only be available if the Binary Star state 227 | # machine allows it. Input on the socket will act as a "vote" in the 228 | # Binary Star scheme. We require exactly one voter per bstar instance. 229 | method voter {endpoint type handler} { 230 | # Hold actual handler+arg so we can call this later 231 | set voter [zmq socket $ctx $type] 232 | $voter bind $endpoint 233 | set voterfn $handler 234 | } 235 | 236 | # Register state change handlers 237 | method new_master {handler} { 238 | set masterfn $handler 239 | } 240 | 241 | method new_slave {handler} { 242 | set slavefn $handler 243 | } 244 | 245 | # Enable/disable verbose tracing 246 | method set_verbose {iverbose} { 247 | set verbose $iverbose 248 | } 249 | 250 | # Start the reactor, ends if a callback function returns -1 251 | method start {} { 252 | my update_peer_expiry 253 | # Set-up reactor events 254 | $statesub readable [list [self] recv_state] 255 | $voter readable [list [self] voter_ready] 256 | after $::BSTAR_HEARTBEAT [list [self] send_state] 257 | } 258 | } 259 | -------------------------------------------------------------------------------- /examples/bstarcli.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Binary Star client 3 | # 4 | 5 | package require zmq 6 | 7 | set REQUEST_TIMEOUT 1000 ;# msecs 8 | set SETTLE_DELAY 2000 ;# Before failing over, msecs 9 | 10 | zmq context context 11 | set server [list "tcp://localhost:5001" "tcp://localhost:5002"] 12 | set server_nbr 0 13 | 14 | puts "I: connecting to server at [lindex $server $server_nbr]..." 15 | zmq socket client context REQ 16 | client connect [lindex $server $server_nbr] 17 | 18 | set sequence 0 19 | while {1} { 20 | # We send a request, then we work to get a reply 21 | set request [incr sequence] 22 | client send $request 23 | 24 | set expect_reply 1 25 | while {$expect_reply} { 26 | # Poll socket for a reply, with timeout 27 | set rpoll_set [zmq poll {{client {POLLIN}}} $REQUEST_TIMEOUT] 28 | 29 | # If we got a reply, process it 30 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 31 | set reply [client recv] 32 | if {$reply eq $request} { 33 | puts "I: server replied OK ($reply)" 34 | set expect_reply 0 35 | after 1000 ;# One request per second 36 | } else { 37 | puts "E: malformed reply from server: $reply" 38 | } 39 | } else { 40 | puts "W: no response from server, failing over" 41 | # Old socket is confused; close it and open a new one 42 | client close 43 | set server_nbr [expr {($server_nbr + 1) % 2}] 44 | after $SETTLE_DELAY 45 | puts "I: connecting to server at [lindex $server $server_nbr]..." 46 | zmq socket client context REQ 47 | client connect [lindex $server $server_nbr] 48 | 49 | # Send request again, on new socket 50 | client send $request 51 | } 52 | } 53 | } 54 | 55 | client close 56 | context term 57 | -------------------------------------------------------------------------------- /examples/bstarsrv.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Binary Star server 3 | # 4 | 5 | package require TclOO 6 | package require zmq 7 | 8 | # Arguments can be either of: 9 | # -p primary server, at tcp://localhost:5001 10 | # -b backup server, at tcp://localhost:5002 11 | if {[llength $argv] != 1 || [lindex $argv 0] ni {-p -b}} { 12 | puts "Usage: bstarsrv.tcl <-p|-b>" 13 | exit 1 14 | } 15 | 16 | # We send state information every this often 17 | # If peer doesn't respond in two heartbeats, it is 'dead' 18 | set HEARTBEAT 1000 ;# In msecs 19 | 20 | # States we can be in at any point in time 21 | set STATE(NONE) 0 22 | set STATE(PRIMARY) 1 ;# Primary, waiting for peer to connect 23 | set STATE(BACKUP) 2 ;# Backup, waiting for peer to connect 24 | set STATE(ACTIVE) 3 ;# Active - accepting connections 25 | set STATE(PASSIVE) 4 ;# Passive - not accepting connections 26 | 27 | # Events, which start with the states our peer can be in 28 | set EVENT(NONE) 0 29 | set EVENT(PRIMARY) 1 ;# HA peer is pending primary 30 | set EVENT(BACKUP) 2 ;# HA peer is pending backup 31 | set EVENT(ACTIVE) 3 ;# HA peer is active 32 | set EVENT(PASSIVE) 4 ;# HA peer is passive 33 | set EVENT(REQUEST) 5 ;# Client makes request 34 | 35 | # Our finite state machine 36 | oo::class create BStar { 37 | 38 | variable state event peer_expiry 39 | 40 | constructor {} { 41 | set state NONE 42 | set event NONE 43 | set peer_expiry 0 44 | } 45 | 46 | destructor { 47 | } 48 | 49 | method state_machine {} { 50 | set exception 0 51 | if {$state eq "PRIMARY"} { 52 | # Primary server is waiting for peer to connect 53 | # Accepts CLIENT_REQUEST events in this state 54 | if {$event eq "BACKUP"} { 55 | puts "I: connected to backup (slave), ready as master" 56 | set state ACTIVE 57 | } elseif {$event eq "ACTIVE"} { 58 | puts "I: connected to backup (master), ready as slave" 59 | set state PASSIVE 60 | } 61 | } elseif {$state eq "BACKUP"} { 62 | # Backup server is waiting for peer to connect 63 | # Rejects CLIENT_REQUEST events in this state 64 | if {$event eq "ACTIVE"} { 65 | puts "I: connected to primary (master), ready as slave" 66 | set state PASSIVE 67 | } elseif {$event eq "REQUEST"} { 68 | set exception 1 69 | } 70 | } elseif {$state eq "ACTIVE"} { 71 | # Server is active 72 | # Accepts CLIENT_REQUEST events in this state 73 | if {$event eq "ACTIVE"} { 74 | # Two masters would mean split-brain 75 | puts "E: fatal error - dual masters, aborting" 76 | set exception 1 77 | } 78 | } elseif {$state eq "PASSIVE"} { 79 | # Server is passive 80 | # CLIENT_REQUEST events can trigger failover if peer looks dead 81 | if {$event eq "PRIMARY"} { 82 | # Peer is restarting - become active, peer will go passive 83 | puts "I: primary (slave) is restarting, ready as master" 84 | set state ACTIVE 85 | } elseif {$event eq "BACKUP"} { 86 | # Peer is restarting - become active, peer will go passive 87 | puts "I: backup (slave) is restarting, ready as master" 88 | set state ACTIVE 89 | } elseif {$event eq "PASSIVE"} { 90 | # Two passives would mean cluster would be non-responsive 91 | puts "E: fatal error - dual slaves, aborting" 92 | set exception 1 93 | } elseif {$event eq "REQUEST"} { 94 | # Peer becomes master if timeout has passed 95 | # It's the client request that triggers the failover 96 | if {$peer_expiry <= 0} { 97 | error "peer_expiry must be > 0" 98 | } 99 | if {[clock milliseconds] >= $peer_expiry} { 100 | # If peer is dead, switch to the active state 101 | puts "I: failover successful, ready as master" 102 | set state ACTIVE 103 | } else { 104 | # If peer is alive, reject connections 105 | set exception 1 106 | } 107 | } 108 | } 109 | return $exception 110 | } 111 | 112 | method set_state {istate} { 113 | set state $istate 114 | } 115 | 116 | method set_event {ievent} { 117 | set event $ievent 118 | } 119 | 120 | method state {} { 121 | return $state 122 | } 123 | 124 | method update_peer_expiry {} { 125 | set peer_expiry [expr {[clock milliseconds] + 2 * $::HEARTBEAT}] 126 | } 127 | } 128 | 129 | zmq context context 130 | zmq socket statepub context PUB 131 | zmq socket statesub context SUB 132 | statesub setsockopt SUBSCRIBE "" 133 | zmq socket frontend context ROUTER 134 | 135 | set fsm [BStar new] 136 | 137 | if {[lindex $argv 0] eq "-p"} { 138 | puts "I: Primary master, waiting for backup (slave)" 139 | frontend bind "tcp://*:5001" 140 | statepub bind "tcp://*:5003" 141 | statesub connect "tcp://localhost:5004" 142 | $fsm set_state PRIMARY 143 | } elseif {[lindex $argv 0] eq "-b"} { 144 | puts "I: Backup slave, waiting for primary (master)" 145 | frontend bind "tcp://*:5002" 146 | statepub bind "tcp://*:5004" 147 | statesub connect "tcp://localhost:5003" 148 | $fsm set_state BACKUP 149 | } 150 | 151 | # Set timer for next outgoing state message 152 | set send_state_at [expr {[clock milliseconds] + $HEARTBEAT}] 153 | 154 | while {1} { 155 | set timeleft [expr {$send_state_at - [clock milliseconds]}] 156 | if {$timeleft < 0} { 157 | set timeleft 0 158 | } 159 | foreach rpoll [zmq poll {{frontend {POLLIN}} {statesub {POLLIN}}} $timeleft] { 160 | switch -exact -- [lindex $rpoll 0] { 161 | frontend { 162 | # Have a client request 163 | set msg [zmsg recv frontend] 164 | $fsm set_event REQUEST 165 | if {[$fsm state_machine] == 0} { 166 | zmsg send frontend $msg 167 | } 168 | } 169 | statesub { 170 | # Have state from our peer, execute as event 171 | set state [statesub recv] 172 | $fsm set_event $state 173 | if {[$fsm state_machine]} { 174 | break ;# Error, so exit 175 | } 176 | $fsm update_peer_expiry 177 | } 178 | } 179 | } 180 | # If we timed-out, send state to peer 181 | if {[clock milliseconds] >= $send_state_at} { 182 | statepub send [$fsm state] 183 | set send_state_at [expr {[clock milliseconds] + $HEARTBEAT}] 184 | } 185 | } 186 | 187 | statepub close 188 | statesub close 189 | frontend close 190 | context term 191 | -------------------------------------------------------------------------------- /examples/bstarsrv2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Binary Star server, using bstar reactor 3 | # 4 | 5 | lappend auto_path . 6 | package require BStar 7 | 8 | # Echo service 9 | proc echo {s} { 10 | set msg [zmsg recv $s] 11 | zmsg send $s $msg 12 | return 0 13 | } 14 | 15 | # Arguments can be either of: 16 | # -p primary server, at tcp://localhost:5001 17 | # -b backup server, at tcp://localhost:5002 18 | 19 | if {[lindex $argv 0] eq "-p"} { 20 | set bstar [BStar new PRIMARY "tcp://*:5003" "tcp://localhost:5004" [expr {[lindex $argv 1] eq "-v"}]] 21 | $bstar voter "tcp://*:5001" ROUTER echo 22 | } elseif {[lindex $argv 0] eq "-b"} { 23 | set bstar [BStar new BACKUP "tcp://*:5004" "tcp://localhost:5003" [expr {[lindex $argv 1] eq "-v"}]] 24 | $bstar voter "tcp://*:5002" ROUTER echo 25 | } else { 26 | puts "Usage: bstarsrv2.tcl <-p|-b> ?-v?" 27 | exit 1 28 | } 29 | 30 | $bstar start 31 | vwait forever 32 | $bstar destroy 33 | -------------------------------------------------------------------------------- /examples/clonecli1.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone client Model One 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | zmq context context 9 | set upd [zmq socket updates context SUB] 10 | $upd setsockopt SUBSCRIBE "" 11 | $upd connect "tcp://localhost:5556" 12 | after 200 13 | 14 | while {1} { 15 | set kvmsg [KVSimple new] 16 | $kvmsg recv $upd 17 | $kvmsg store kvmap 18 | puts [$kvmsg dump] 19 | } 20 | 21 | $upd close 22 | context term 23 | -------------------------------------------------------------------------------- /examples/clonecli2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone client Model Two 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | # Prepare our context and subscriber 9 | zmq context context 10 | set snp [zmq socket snapshot context DEALER] 11 | $snp connect "tcp://localhost:5556" 12 | set sub [zmq socket subscriber context SUB] 13 | $sub setsockopt SUBSCRIBE "" 14 | $sub connect "tcp://localhost:5557" 15 | 16 | # Get state snapshot 17 | set sequence 0 18 | $snp send "ICANHAZ?" 19 | while {1} { 20 | set kvmsg [KVSimple new] 21 | $kvmsg recv $snp 22 | if {[$kvmsg key] eq "KTHXBAI"} { 23 | set sequence [$kvmsg sequence] 24 | puts "Received snapshot=$sequence" 25 | $kvmsg destroy 26 | break 27 | } 28 | $kvmsg store kvmap 29 | } 30 | 31 | # Now apply pending updates, discard out-of-sequence messages 32 | while {1} { 33 | set kvmsg [KVSimple new] 34 | $kvmsg recv $sub 35 | puts [$kvmsg dump] 36 | if {[$kvmsg sequence] > $sequence} { 37 | puts " store" 38 | $kvmsg store kvmap 39 | } else { 40 | puts " ignore" 41 | $kvmsg destroy 42 | } 43 | } 44 | 45 | $snp close 46 | $sub close 47 | context term 48 | -------------------------------------------------------------------------------- /examples/clonecli3.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone client Model Three 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | # Prepare our context and subscriber 9 | zmq context context 10 | set snp [zmq socket snapshot context DEALER] 11 | $snp connect "tcp://localhost:5556" 12 | set sub [zmq socket subscriber context SUB] 13 | $sub setsockopt SUBSCRIBE "" 14 | $sub connect "tcp://localhost:5557" 15 | set pub [zmq socket publisher context PUSH] 16 | $pub connect "tcp://localhost:5558" 17 | 18 | expr srand([pid]) 19 | 20 | # Get state snapshot 21 | set sequence 0 22 | $snp send "ICANHAZ?" 23 | while {1} { 24 | set kvmsg [KVSimple new] 25 | $kvmsg recv $snp 26 | if {[$kvmsg key] eq "KTHXBAI"} { 27 | set sequence [$kvmsg sequence] 28 | puts "I: received snapshot=$sequence" 29 | $kvmsg destroy 30 | break 31 | } 32 | $kvmsg store kvmap 33 | } 34 | 35 | proc recv_kvmsg {pub sub} { 36 | global after_id sequence kvmap alarm 37 | after cancel $after_id 38 | $sub readable {} 39 | 40 | set kvmsg [KVSimple new] 41 | $kvmsg recv $sub 42 | 43 | if {[$kvmsg sequence] > $sequence} { 44 | set sequence [$kvmsg sequence] 45 | $kvmsg store kvmap 46 | puts "I: received update=$sequence" 47 | } else { 48 | $kvmsg destroy 49 | } 50 | 51 | $sub readable [list recv_kvmsg $pub $sub] 52 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 53 | } 54 | 55 | proc send_kvmsg {pub sub} { 56 | global after_id sequence kvmap alarm 57 | $sub readable {} 58 | 59 | set kvmsg [KVSimple new 0] 60 | $kvmsg set_key [expr {int(rand()*10000)}] 61 | $kvmsg set_body [expr {int(rand()*1000000)}] 62 | $kvmsg send $pub 63 | $kvmsg destroy 64 | set alarm [expr {[clock milliseconds] + 1000}] 65 | 66 | $sub readable [list recv_kvmsg $pub $sub] 67 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 68 | } 69 | 70 | proc tickless {} { 71 | global alarm 72 | set t [expr {[clock milliseconds] - $alarm}] 73 | if {$t < 0} { 74 | set t 0 75 | } 76 | return $t 77 | } 78 | 79 | set alarm [expr {[clock milliseconds] + 1000}] 80 | $sub readable [list recv_kvmsg $pub $sub] 81 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 82 | 83 | vwait forever 84 | 85 | $pub close 86 | $sub close 87 | $snp close 88 | context term 89 | -------------------------------------------------------------------------------- /examples/clonecli4.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone client Model Four 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | set SUBTREE "/client/" 9 | 10 | # Prepare our context and subscriber 11 | zmq context context 12 | set snp [zmq socket snapshot context DEALER] 13 | $snp connect "tcp://localhost:5556" 14 | set sub [zmq socket subscriber context SUB] 15 | $sub setsockopt SUBSCRIBE "" 16 | $sub connect "tcp://localhost:5557" 17 | $sub setsockopt SUBSCRIBE $SUBTREE 18 | set pub [zmq socket publisher context PUSH] 19 | $pub connect "tcp://localhost:5558" 20 | 21 | expr srand([pid]) 22 | 23 | # Get state snapshot 24 | set sequence 0 25 | $snp sendmore "ICANHAZ?" 26 | $snp send $SUBTREE 27 | while {1} { 28 | set kvmsg [KVSimple new] 29 | $kvmsg recv $snp 30 | if {[$kvmsg key] eq "KTHXBAI"} { 31 | set sequence [$kvmsg sequence] 32 | puts "I: received snapshot=$sequence" 33 | $kvmsg destroy 34 | break 35 | } 36 | $kvmsg store kvmap 37 | } 38 | 39 | proc recv_kvmsg {pub sub} { 40 | global after_id sequence kvmap alarm 41 | after cancel $after_id 42 | $sub readable {} 43 | 44 | set kvmsg [KVSimple new] 45 | $kvmsg recv $sub 46 | 47 | if {[$kvmsg sequence] > $sequence} { 48 | set sequence [$kvmsg sequence] 49 | $kvmsg store kvmap 50 | puts "I: received update=$sequence" 51 | } else { 52 | $kvmsg destroy 53 | } 54 | 55 | $sub readable [list recv_kvmsg $pub $sub] 56 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 57 | } 58 | 59 | proc send_kvmsg {pub sub} { 60 | global after_id sequence kvmap alarm SUBTREE 61 | $sub readable {} 62 | 63 | set kvmsg [KVSimple new 0] 64 | $kvmsg set_key $SUBTREE[expr {int(rand()*10000)}] 65 | $kvmsg set_body [expr {int(rand()*1000000)}] 66 | $kvmsg send $pub 67 | $kvmsg destroy 68 | set alarm [expr {[clock milliseconds] + 1000}] 69 | 70 | $sub readable [list recv_kvmsg $pub $sub] 71 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 72 | } 73 | 74 | proc tickless {} { 75 | global alarm 76 | set t [expr {[clock milliseconds] - $alarm}] 77 | if {$t < 0} { 78 | set t 0 79 | } 80 | return $t 81 | } 82 | 83 | set alarm [expr {[clock milliseconds] + 1000}] 84 | $sub readable [list recv_kvmsg $pub $sub] 85 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 86 | 87 | vwait forever 88 | 89 | $pub close 90 | $sub close 91 | $snp close 92 | context term 93 | -------------------------------------------------------------------------------- /examples/clonecli5.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone client Model Five 3 | # 4 | 5 | lappend auto_path . 6 | package require KVMsg 7 | 8 | set SUBTREE "/client/" 9 | 10 | # Prepare our context and subscriber 11 | zmq context context 12 | set snp [zmq socket snapshot context DEALER] 13 | $snp connect "tcp://localhost:5556" 14 | set sub [zmq socket subscriber context SUB] 15 | $sub setsockopt SUBSCRIBE "" 16 | $sub connect "tcp://localhost:5557" 17 | $sub setsockopt SUBSCRIBE $SUBTREE 18 | set pub [zmq socket publisher context PUSH] 19 | $pub connect "tcp://localhost:5558" 20 | 21 | expr srand([pid]) 22 | 23 | # Get state snapshot 24 | set sequence 0 25 | $snp sendmore "ICANHAZ?" 26 | $snp send $SUBTREE 27 | while {1} { 28 | set kvmsg [KVMsg new] 29 | $kvmsg recv $snp 30 | if {[$kvmsg key] eq "KTHXBAI"} { 31 | set sequence [$kvmsg sequence] 32 | puts "I: received snapshot=$sequence" 33 | $kvmsg destroy 34 | break 35 | } 36 | $kvmsg store kvmap 37 | } 38 | 39 | proc recv_kvmsg {pub sub} { 40 | global after_id sequence kvmap alarm 41 | after cancel $after_id 42 | $sub readable {} 43 | 44 | set kvmsg [KVMsg new] 45 | $kvmsg recv $sub 46 | 47 | if {[$kvmsg sequence] > $sequence} { 48 | set sequence [$kvmsg sequence] 49 | $kvmsg store kvmap 50 | puts "I: received update=$sequence" 51 | } else { 52 | $kvmsg destroy 53 | } 54 | 55 | $sub readable [list recv_kvmsg $pub $sub] 56 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 57 | } 58 | 59 | proc send_kvmsg {pub sub} { 60 | global after_id sequence kvmap alarm SUBTREE 61 | $sub readable {} 62 | 63 | set kvmsg [KVMsg new 0] 64 | $kvmsg set_key $SUBTREE[expr {int(rand()*10000)}] 65 | $kvmsg set_body [expr {int(rand()*1000000)}] 66 | $kvmsg set_prop "ttl" [expr {int(rand()*1000000)}] 67 | $kvmsg send $pub 68 | $kvmsg destroy 69 | set alarm [expr {[clock milliseconds] + 1000}] 70 | 71 | $sub readable [list recv_kvmsg $pub $sub] 72 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 73 | } 74 | 75 | proc tickless {} { 76 | global alarm 77 | set t [expr {[clock milliseconds] - $alarm}] 78 | if {$t < 0} { 79 | set t 0 80 | } 81 | return $t 82 | } 83 | 84 | set alarm [expr {[clock milliseconds] + 1000}] 85 | $sub readable [list recv_kvmsg $pub $sub] 86 | set after_id [after [tickless] [list send_kvmsg $pub $sub]] 87 | 88 | vwait forever 89 | 90 | $pub close 91 | $sub close 92 | $snp close 93 | context term 94 | -------------------------------------------------------------------------------- /examples/clonesrv1.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone server Model One 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | # Prepare our context and publisher socket 9 | zmq context context 10 | set pub [zmq socket publisher context PUB] 11 | $pub bind "tcp://*:5556" 12 | after 200 13 | 14 | set sequence 0 15 | expr srand([pid]) 16 | 17 | while {1} { 18 | # Distribute as key-value message 19 | set kvmsg [KVSimple new [incr sequence]] 20 | $kvmsg set_key [expr {int(rand()*10000)}] 21 | $kvmsg set_body [expr {int(rand()*1000000)}] 22 | $kvmsg send $pub 23 | $kvmsg store kvmap 24 | puts [$kvmsg dump] 25 | after 500 26 | } 27 | 28 | $pub close 29 | context term 30 | -------------------------------------------------------------------------------- /examples/clonesrv2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone server Model Two 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | if {[llength $argv] == 0} { 9 | set argv "pub" 10 | } elseif {[llength $argv] != 1} { 11 | puts "Usage: clonesrv2.tcl " 12 | exit 1 13 | } 14 | 15 | lassign $argv what 16 | 17 | set tclsh [info nameofexecutable] 18 | expr srand([pid]) 19 | 20 | switch -exact -- $what { 21 | pub { 22 | # Prepare our context and publisher socket 23 | zmq context context 24 | set pub [zmq socket publisher context PUB] 25 | $pub bind "tcp://*:5557" 26 | set upd [zmq socket updates context PAIR] 27 | $upd bind "ipc://updates.ipc" 28 | 29 | set sequence 0 30 | 31 | # Start state manager and wait for synchronization signal 32 | exec $tclsh clonesrv2.tcl upd > upd.log 2>@1 & 33 | $upd recv 34 | 35 | while {1} { 36 | # Distribute as key-value message 37 | set kvmsg [KVSimple new [incr sequence]] 38 | $kvmsg set_key [expr {int(rand()*10000)}] 39 | $kvmsg set_body [expr {int(rand()*1000000)}] 40 | $kvmsg send $pub 41 | $kvmsg send $upd 42 | puts [$kvmsg dump] 43 | after 500 44 | } 45 | 46 | $pub close 47 | $upd close 48 | context term 49 | } 50 | upd { 51 | zmq context context 52 | set upd [zmq socket updates context PAIR] 53 | $upd connect "ipc://updates.ipc" 54 | $upd send "READY" 55 | 56 | set snp [zmq socket snapshot context ROUTER] 57 | $snp bind "tcp://*:5556" 58 | 59 | set sequence 0 ;# Current snapshot version number 60 | 61 | # Apply state update from main thread 62 | proc apply_state_update {upd} { 63 | global kvmap sequence 64 | set kvmsg [KVSimple new] 65 | $kvmsg recv $upd 66 | set sequence [$kvmsg sequence] 67 | $kvmsg store kvmap 68 | } 69 | 70 | # Execute state snapshot request 71 | proc execute_state_snapshot_request {snp} { 72 | global kvmap sequence 73 | 74 | set identity [$snp recv] 75 | 76 | # Request is in second frame of message 77 | set request [$snp recv] 78 | if {$request ne "ICANHAZ?"} { 79 | puts "E: bad request, aborting" 80 | exit 1 81 | } 82 | # Send state snapshot to client 83 | # For each entry in kvmap, send kvmsg to client 84 | foreach {key value} [array get kvmap] { 85 | # Send one state snapshot key-value pair to a socket 86 | # Hash item data is our kvmsg object, ready to send 87 | $snp sendmore $identity 88 | $value send $snp 89 | } 90 | 91 | # Now send END message with sequence number 92 | puts "Sending state snapshot=$sequence" 93 | $snp sendmore $identity 94 | set kvmsg [KVSimple new $sequence] 95 | $kvmsg set_key "KTHXBAI" 96 | $kvmsg set_body "" 97 | $kvmsg send $snp 98 | $kvmsg destroy 99 | } 100 | 101 | $upd readable [list apply_state_update $upd] 102 | $snp readable [list execute_state_snapshot_request $snp] 103 | vwait forever 104 | 105 | $upd close 106 | $snp close 107 | context term 108 | } 109 | } 110 | -------------------------------------------------------------------------------- /examples/clonesrv3.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone server Model Three 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | # Prepare our context and sockets 9 | zmq context context 10 | set snp [zmq socket snapshot context ROUTER] 11 | $snp bind "tcp://*:5556" 12 | set pub [zmq socket publisher context PUB] 13 | $pub bind "tcp://*:5557" 14 | set col [zmq socket collector context PULL] 15 | $col bind "tcp://*:5558" 16 | 17 | set sequence 0 18 | 19 | # Apply state update sent from client 20 | proc apply_state_update {col pub} { 21 | global sequence kvmap 22 | set kvmsg [KVSimple new] 23 | $kvmsg recv $col 24 | $kvmsg set_sequence [incr sequence] 25 | $kvmsg send $pub 26 | $kvmsg store kvmap 27 | puts "Publishing update $sequence" 28 | } 29 | 30 | # Execute state snapshot request 31 | proc execute_state_snapshot_request {snp} { 32 | global sequence 33 | set identity [$snp recv] 34 | # Request is in second frame of message 35 | set request [$snp recv] 36 | if {$request ne "ICANHAZ?"} { 37 | puts "E: bad request, aborting" 38 | exit 1 39 | } 40 | 41 | # Send state snapshot to client 42 | # For each entry in kvmap, send kvmsg to client 43 | foreach {key value} [array get kvmap] { 44 | # Send one state snapshot key-value pair to a socket 45 | # Hash item data is our kvmsg object, ready to send 46 | $snp sendmore $identity 47 | $value send $snp 48 | } 49 | 50 | # Now send END message with sequence number 51 | puts "I: sending snapshot=$sequence" 52 | $snp sendmore $identity 53 | set kvmsg [KVSimple new $sequence] 54 | $kvmsg set_key "KTHXBAI" 55 | $kvmsg set_body "" 56 | $kvmsg send $snp 57 | $kvmsg destroy 58 | } 59 | 60 | $col readable [list apply_state_update $col $pub] 61 | $snp readable [list execute_state_snapshot_request $snp] 62 | 63 | vwait forever 64 | 65 | $col close 66 | $pub close 67 | $snp close 68 | context term 69 | -------------------------------------------------------------------------------- /examples/clonesrv4.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone server Model Four 3 | # 4 | 5 | lappend auto_path . 6 | package require KVSimple 7 | 8 | # Prepare our context and sockets 9 | zmq context context 10 | set snp [zmq socket snapshot context ROUTER] 11 | $snp bind "tcp://*:5556" 12 | set pub [zmq socket publisher context PUB] 13 | $pub bind "tcp://*:5557" 14 | set col [zmq socket collector context PULL] 15 | $col bind "tcp://*:5558" 16 | 17 | set sequence 0 18 | 19 | # Apply state update sent from client 20 | proc apply_state_update {col pub} { 21 | global sequence kvmap 22 | set kvmsg [KVSimple new] 23 | $kvmsg recv $col 24 | $kvmsg set_sequence [incr sequence] 25 | $kvmsg send $pub 26 | $kvmsg store kvmap 27 | puts "I: publishing update $sequence" 28 | } 29 | 30 | # Execute state snapshot request 31 | proc execute_state_snapshot_request {snp} { 32 | global sequence 33 | set identity [$snp recv] 34 | # Request is in second frame of message 35 | set request [$snp recv] 36 | if {$request ne "ICANHAZ?"} { 37 | puts "E: bad request, aborting" 38 | exit 1 39 | } 40 | 41 | set subtree [$snp recv] 42 | 43 | # Send state snapshot to client 44 | # For each entry in kvmap, send kvmsg to client 45 | foreach {key value} [array get kvmap] { 46 | # Send one state snapshot key-value pair to a socket 47 | # Hash item data is our kvmsg object, ready to send 48 | if {[string match $subtree* [$value key]]} { 49 | $snp sendmore $identity 50 | $value send $snp 51 | } 52 | } 53 | 54 | # Now send END message with sequence number 55 | puts "I: sending snapshot=$sequence" 56 | $snp sendmore $identity 57 | set kvmsg [KVSimple new $sequence] 58 | $kvmsg set_key "KTHXBAI" 59 | $kvmsg set_body $subtree 60 | $kvmsg send $snp 61 | $kvmsg destroy 62 | } 63 | 64 | $col readable [list apply_state_update $col $pub] 65 | $snp readable [list execute_state_snapshot_request $snp] 66 | 67 | vwait forever 68 | 69 | $col close 70 | $pub close 71 | $snp close 72 | context term 73 | -------------------------------------------------------------------------------- /examples/clonesrv5.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Clone server Model Five 3 | # 4 | 5 | lappend auto_path . 6 | package require TclOO 7 | package require KVMsg 8 | 9 | oo::class create CloneServer { 10 | 11 | variable ctx kvmap sequence snapshot publisher collector afterid 12 | 13 | constructor {port} { 14 | # Set up our clone server sockets 15 | set sequence 0 16 | set ctx [zmq context] 17 | set snapshot [zmq socket $ctx ROUTER] 18 | set publisher [zmq socket $ctx PUB] 19 | set collector [zmq socket $ctx PULL] 20 | $snapshot bind "tcp://*:$port" 21 | $publisher bind "tcp://*:[expr {$port+1}]" 22 | $collector bind "tcp://*:[expr {$port+2}]" 23 | 24 | # Register our handlers with reactor 25 | my register 26 | } 27 | 28 | destructor { 29 | $snapshot close 30 | $publisher close 31 | $collector close 32 | $ctx term 33 | } 34 | 35 | method register {} { 36 | $snapshot readable [list [self] s_snapshot] 37 | $collector readable [list [self] s_collector] 38 | set afterid [after 1000 [list [self] s_flush_ttl]] 39 | } 40 | 41 | method unregister {} { 42 | $snapshot readable {} 43 | $collector readable {} 44 | catch {after cancel $afterid} 45 | } 46 | 47 | # Send snapshots to clients who ask for them 48 | method s_snapshot {} { 49 | set identity [$snapshot recv] 50 | if {[string length $identity]} { 51 | set request [$snapshot recv] 52 | if {$request eq "ICANHAZ?"} { 53 | set subtree [$snapshot recv] 54 | } else { 55 | puts "E: bad request, aborting" 56 | } 57 | if {[info exists subtree]} { 58 | # Send state to client 59 | foreach {key value} [array get kvmap] { 60 | # Send one state snapshot key-value pair to a socket 61 | # Hash item data is our kvmsg object, ready to send 62 | if {[string match $subtree* [$value key]]} { 63 | $snapshot sendmore $identity 64 | $value send $snapshot 65 | } 66 | } 67 | 68 | # Now send END message with sequence number 69 | puts "I: sending snapshot=$sequence" 70 | $snapshot sendmore $identity 71 | set kvmsg [KVMsg new $sequence] 72 | $kvmsg set_key "KTHXBAI" 73 | $kvmsg set_body $subtree 74 | $kvmsg send $snapshot 75 | $kvmsg destroy 76 | } 77 | } 78 | } 79 | 80 | # Collect updates from clients 81 | method s_collector {} { 82 | set kvmsg [KVMsg new] 83 | $kvmsg recv $collector 84 | $kvmsg set_sequence [incr sequence] 85 | $kvmsg send $publisher 86 | set ttl [$kvmsg get_prop "ttl"] 87 | if {$ttl} { 88 | $kvmsg set_prop "ttl" [expr {[clock milliseconds] + $ttl * 1000}] 89 | $kvmsg store kvmap 90 | puts "I: publishing update=$sequence" 91 | } 92 | } 93 | 94 | # Purge ephemeral values that have expired 95 | method s_flush_ttl {} { 96 | foreach {key value} [array names kvmap] { 97 | # If key-value pair has expired, delete it and publish the 98 | # fact to listening clients. 99 | if {[clock milliseconds] >= [$value get_prop "ttl"]} { 100 | $value set_sequence [incr sequence] 101 | $value set_body "" 102 | $value send $publisher 103 | $value stor kvmap 104 | puts "I: publishing delete=$sequence" 105 | } 106 | } 107 | } 108 | } 109 | 110 | set server [CloneServer new 5556] 111 | 112 | # Run reactor until process interrupted 113 | vwait forever 114 | 115 | $server destroy 116 | 117 | -------------------------------------------------------------------------------- /examples/durapub.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Publisher for durable subscriber 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # Subscriber tells us when it's ready here 10 | zmq socket sync context PULL 11 | sync bind "tcp://*:5564" 12 | 13 | # We send updates via this socket 14 | zmq socket publisher context PUB 15 | publisher bind "tcp://*:5565" 16 | 17 | # Wait for synchronization request 18 | sync recv 19 | 20 | # Now broadcast exactly 10 updates with pause 21 | for {set update_nbr 0} {$update_nbr < 10} {incr update_nbr} { 22 | puts $update_nbr 23 | publisher send "Update $update_nbr" 24 | after 1000 25 | } 26 | publisher send "END" 27 | 28 | sync close 29 | publisher close 30 | context term 31 | 32 | -------------------------------------------------------------------------------- /examples/durapub2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Publisher for durable subscriber 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # Subscriber tells us when it's ready here 10 | zmq socket sync context PULL 11 | sync bind "tcp://*:5564" 12 | 13 | # We send updates via this socket 14 | zmq socket publisher context PUB 15 | publisher setsockopt HWM 2 16 | publisher setsockopt SWAP 25000000 17 | publisher bind "tcp://*:5565" 18 | 19 | # Wait for synchronization request 20 | sync recv 21 | 22 | # Now broadcast exactly 10 updates with pause 23 | for {set update_nbr 0} {$update_nbr < 10} {incr update_nbr} { 24 | puts $update_nbr 25 | publisher send "Update $update_nbr" 26 | after 1000 27 | } 28 | publisher send "END" 29 | 30 | sync close 31 | publisher close 32 | context term 33 | 34 | -------------------------------------------------------------------------------- /examples/durasub.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Durable subscriber 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # Connect our subscriber socket 10 | zmq socket subscriber context SUB 11 | subscriber setsockopt IDENTITY "Hello" 12 | subscriber setsockopt SUBSCRIBE "" 13 | subscriber connect "tcp://localhost:5565" 14 | 15 | # Synchronize with publisher 16 | zmq socket sync context PUSH 17 | sync connect "tcp://localhost:5564" 18 | sync send "" 19 | 20 | # Get updates, exit when told to do so 21 | while {1} { 22 | set string [subscriber recv] 23 | puts $string 24 | if {$string eq "END"} { 25 | break; 26 | } 27 | } 28 | 29 | sync close 30 | subscriber close 31 | context term 32 | -------------------------------------------------------------------------------- /examples/flclient1.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Freelance client - Model 1 3 | # Uses REQ socket to query one or more services 4 | # 5 | 6 | package require zmq 7 | 8 | set REQUEST_TIMEOUT 1000 9 | set MAX_RETRIES 3 ;# Before we abandon 10 | 11 | if {[llength $argv] == 0} { 12 | puts "Usage: flclient1.tcl ..." 13 | exit 1 14 | } 15 | 16 | proc s_try_request {ctx endpoint request} { 17 | puts "I: trying echo service at $endpoint..." 18 | zmq socket client $ctx REQ 19 | client connect $endpoint 20 | 21 | # Send request, wait safely for reply 22 | zmsg send client $request 23 | set reply {} 24 | set rpoll_set [zmq poll {{client {POLLIN}}} $::REQUEST_TIMEOUT] 25 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 26 | set reply [zmsg recv client] 27 | } 28 | 29 | # Close socket in any case, we're done with it now 30 | client setsockopt LINGER 0 31 | client close 32 | return $reply 33 | } 34 | 35 | zmq context context 36 | 37 | set request {} 38 | set request [zmsg add $request "Hello World"] 39 | set reply {} 40 | 41 | if {[llength $argv] == 1} { 42 | # For one endpoint, we retry N times 43 | set endpoint [lindex $argv 0] 44 | for {set retries 0} {$retries < $MAX_RETRIES} {incr retries} { 45 | set reply [s_try_request context $endpoint $request] 46 | if {[llength $reply]} { 47 | break ;# Successful 48 | } 49 | puts "W: no response from $endpoint, retrying..." 50 | } 51 | } else { 52 | # For multiple endpoints, try each at most once 53 | foreach endpoint $argv { 54 | set reply [s_try_request context $endpoint $request] 55 | if {[llength $reply]} { 56 | break ;# Successful 57 | } 58 | puts "W: no response from $endpoint" 59 | } 60 | } 61 | 62 | if {[llength $reply]} { 63 | puts "Service is running OK" 64 | } 65 | 66 | context term 67 | -------------------------------------------------------------------------------- /examples/flclient2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Freelance client - Model 2 3 | # Uses DEALER socket to blast one or more services 4 | # 5 | 6 | lappend auto_path . 7 | package require TclOO 8 | package require zmq 9 | 10 | if {[llength $argv] == 0} { 11 | puts "Usage: flclient2.tcl ..." 12 | exit 1 13 | } 14 | 15 | # If not a single service replies within this time, give up 16 | set GLOBAL_TIMEOUT 2500 17 | 18 | oo::class create FLClient { 19 | 20 | variable ctx socket servers sequence 21 | 22 | constructor {} { 23 | set ctx [zmq context] 24 | set socket [zmq socket $ctx DEALER] 25 | set servers 0 26 | set sequence 0 27 | } 28 | 29 | destructor { 30 | $socket setsockopt LINGER 0 31 | $socket close 32 | $ctx term 33 | } 34 | 35 | method connect {endpoint} { 36 | $socket connect $endpoint 37 | incr servers 38 | } 39 | 40 | # Send request, get reply 41 | method request {request} { 42 | # Prefix request with sequence number and empty envelope 43 | set request [zmsg push $request [incr sequence]] 44 | set request [zmsg push $request ""] 45 | 46 | # Blast the request to all connected servers 47 | for {set server 0} {$server < $servers} {incr server} { 48 | zmsg send $socket $request 49 | } 50 | 51 | # Wait for a matching reply to arrive from anywhere 52 | # Since we can poll several times, calculate each one 53 | set reply {} 54 | set endtime [expr {[clock milliseconds] + $::GLOBAL_TIMEOUT}] 55 | while {[clock milliseconds] < $endtime} { 56 | set rpoll_set [zmq poll [list [list $socket {POLLIN}]] [expr {($endtime - [clock milliseconds])}]] 57 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 58 | # Reply is [empty][sequence][OK] 59 | set reply [zmsg recv $socket] 60 | if {[llength $reply] != 3} { 61 | error "expected reply with length 3" 62 | } 63 | zmsg pop reply 64 | set rsequence [zmsg pop reply] 65 | if {$rsequence == $sequence} { 66 | break 67 | } 68 | } 69 | } 70 | return $reply 71 | } 72 | } 73 | 74 | # Create new freelance client object 75 | set client [FLClient new] 76 | 77 | # Connect to each endpoint 78 | foreach endpoint $argv { 79 | $client connect $endpoint 80 | } 81 | 82 | # Send a bunch of name resolution 'requests', measure time 83 | set requests 100 84 | set start [clock microseconds] 85 | for {set i 0} {$i < $requests} {incr i} { 86 | set request {} 87 | set request [zmsg add $request "random name"] 88 | set reply [$client request $request] 89 | if {[llength $reply] == 0} { 90 | puts "E: name service not available, aborting" 91 | break 92 | } 93 | } 94 | puts "Average round trip cost: [expr {([clock microseconds] - $start) / $requests}] usec" 95 | 96 | $client destroy 97 | -------------------------------------------------------------------------------- /examples/flclient3.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Freelance client - Model 3 3 | # Uses flcliapi class to encapsulate Freelance pattern 4 | # 5 | 6 | lappend auto_path . 7 | package require FLClient 8 | 9 | # Create new freelance client object 10 | set client [FLClient new] 11 | 12 | # Connect to several endpoints 13 | puts connect 14 | $client connect "tcp://localhost:5555" 15 | $client connect "tcp://localhost:5556" 16 | $client connect "tcp://localhost:5557" 17 | 18 | set requests 100 19 | set start [clock microseconds] 20 | for {set i 0} {$i < $requests} {incr i} { 21 | puts "request $i --------------------------------------------------" 22 | set request {} 23 | set request [zmsg add $request "random name"] 24 | set reply [$client request $request] 25 | puts "reply $i --------------------------------------------------" 26 | if {[llength $reply] == 0} { 27 | puts "E: name service not available, aborting" 28 | break 29 | } else { 30 | puts [join [zmsg dump $reply] \n] 31 | } 32 | } 33 | puts "Average round trip cost: [expr {([clock microseconds] - $start) / $requests}] usec" 34 | 35 | $client destroy 36 | 37 | -------------------------------------------------------------------------------- /examples/flserver1.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Freelance server - Model 1 3 | # Trivial echo service 4 | # 5 | 6 | package require zmq 7 | 8 | if {[llength $argv] != 1} { 9 | puts "Usage: flserver1.tcl " 10 | exit 1 11 | } 12 | 13 | zmq context context 14 | zmq socket server context REP 15 | server bind [lindex $argv 0] 16 | 17 | puts "I: echo service is ready at [lindex $argv 0]" 18 | while {1} { 19 | set msg [zmsg recv server] 20 | if {[llength $msg] == 0} { 21 | break 22 | } 23 | zmsg send server $msg 24 | } 25 | 26 | server close 27 | context term 28 | -------------------------------------------------------------------------------- /examples/flserver2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Freelance server - Model 2 3 | # Does some work, replies OK, with message sequencing 4 | # 5 | 6 | package require zmq 7 | 8 | if {[llength $argv] != 1} { 9 | puts "Usage: flserver2.tcl " 10 | exit 1 11 | } 12 | 13 | zmq context context 14 | zmq socket server context REP 15 | server bind [lindex $argv 0] 16 | 17 | puts "I: echo service is ready at [lindex $argv 0]" 18 | while {1} { 19 | set request [zmsg recv server] 20 | if {[llength $request] == 0} { 21 | break 22 | } 23 | # Fail nastily if run against wrong client 24 | if {[llength $request] != 2} { 25 | error "request with length 2 expected" 26 | } 27 | 28 | set address [zmsg pop request] 29 | 30 | set reply {} 31 | set reply [zmsg add $reply $address] 32 | set reply [zmsg add $reply "OK"] 33 | zmsg send server $reply 34 | } 35 | 36 | server close 37 | context term 38 | -------------------------------------------------------------------------------- /examples/flserver3.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Freelance server - Model 2 3 | # Does some work, replies OK, with message sequencing 4 | # 5 | 6 | package require zmq 7 | 8 | if {[llength $argv] != 1} { 9 | puts "Usage: flserver3.tcl ?-v?" 10 | exit 1 11 | } 12 | 13 | set connect_endpoint [lindex $argv 0] 14 | set bind_endpoint [regsub {tcp\://[^\:]+} $connect_endpoint "tcp://*"] 15 | set verbose 0 16 | 17 | zmq context context 18 | zmq socket server context ROUTER 19 | server setsockopt IDENTITY $connect_endpoint 20 | server bind $bind_endpoint 21 | puts "I: service is ready at $bind_endpoint" 22 | 23 | while {1} { 24 | set request [zmsg recv server] 25 | if {$verbose} { 26 | puts "Request:" 27 | puts [join [zmsg dump $request] \n] 28 | } 29 | if {[llength $request] == 0} { 30 | break 31 | } 32 | 33 | set address [zmsg pop request] 34 | set control [zmsg pop request] 35 | set reply {} 36 | if {$control eq "PING"} { 37 | puts "PING" 38 | set reply [zmsg add $reply "PONG"] 39 | } else { 40 | puts "REQUEST $control" 41 | set reply [zmsg add $reply $control] 42 | set reply [zmsg add $reply "OK"] 43 | set reply [zmsg add $reply "payload"] 44 | } 45 | set reply [zmsg push $reply $address] 46 | if {$verbose} { 47 | puts "Reply:" 48 | puts [join [zmsg dump $reply] \n] 49 | } 50 | zmsg send server $reply 51 | } 52 | 53 | server close 54 | context term 55 | -------------------------------------------------------------------------------- /examples/hwclient.tcl: -------------------------------------------------------------------------------- 1 | package require zmq 2 | 3 | zmq context context 4 | zmq socket client context REQ 5 | client connect "tcp://*:5555" 6 | 7 | for {set i 0} {$i < 10} {incr i} { 8 | zmq message msg -data "Hello @ [clock format [clock seconds]]" 9 | client send_msg msg 10 | msg close 11 | 12 | zmq message msg 13 | client recv_msg msg 14 | puts "Received [msg data]/[msg size]" 15 | msg close 16 | } 17 | 18 | client close 19 | context term 20 | 21 | -------------------------------------------------------------------------------- /examples/hwserver.tcl: -------------------------------------------------------------------------------- 1 | package require zmq 2 | 3 | zmq context context 4 | zmq socket responder context REP 5 | responder bind "tcp://*:5555" 6 | 7 | while {1} { 8 | zmq message request 9 | responder recv_msg request 10 | puts "Received [request data]" 11 | request close 12 | 13 | zmq message reply -data "World @ [clock format [clock seconds]]" 14 | responder send_msg reply 15 | reply close 16 | } 17 | responder close 18 | context term 19 | 20 | -------------------------------------------------------------------------------- /examples/identity.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Demonstrate identities as used by the request-reply pattern. Run this 3 | # program by itself. 4 | # 5 | 6 | package require zmq 7 | 8 | zmq context context 9 | 10 | zmq socket sink context ROUTER 11 | sink bind "inproc://example" 12 | 13 | # First allow 0MQ to set the identity 14 | zmq socket anonymous context REQ 15 | anonymous connect "inproc://example" 16 | anonymous send "ROUTER uses a generated UUID" 17 | puts "--------------------------------------------------" 18 | puts [join [sink dump] \n] 19 | 20 | # Then set the identity ourself 21 | zmq socket identified context REQ 22 | identified setsockopt IDENTITY "Hello" 23 | identified connect "inproc://example" 24 | identified send "ROUTER socket uses REQ's socket identity" 25 | puts "--------------------------------------------------" 26 | puts [join [sink dump] \n] 27 | 28 | sink close 29 | anonymous close 30 | identified close 31 | context term 32 | 33 | -------------------------------------------------------------------------------- /examples/kvsimple.tcl: -------------------------------------------------------------------------------- 1 | # ===================================================================== 2 | # kvsimple - simple key-value message class for example applications 3 | 4 | # --------------------------------------------------------------------- 5 | # Copyright (c) 1991-2011 iMatix Corporation 6 | # Copyright other contributors as noted in the AUTHORS file. 7 | 8 | # Tcl port by Jos Decoster 9 | 10 | # This file is part of the ZeroMQ Guide: http://zguide.zeromq.org 11 | 12 | # This is free software; you can redistribute it and/or modify it under 13 | # the terms of the GNU Lesser General Public License as published by 14 | # the Free Software Foundation; either version 3 of the License, or (at 15 | # your option) any later version. 16 | 17 | # This software is distributed in the hope that it will be useful, but 18 | # WITHOUT ANY WARRANTY; without even the implied warranty of 19 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 20 | # Lesser General Public License for more details. 21 | 22 | # You should have received a copy of the GNU Lesser General Public 23 | # License along with this program. If not, see 24 | # . 25 | # ===================================================================== 26 | 27 | lappend auto_path . 28 | 29 | package require TclOO 30 | package require zmq 31 | package require mdp 32 | 33 | package provide KVSimple 1.0 34 | 35 | # Keys are short strings 36 | set KVMSG_KEY_MAX 255 37 | 38 | # Message is formatted on wire as 4 frames: 39 | # frame 0: key (0MQ string) 40 | # frame 1: sequence (8 bytes, network order) 41 | # frame 2: body (blob) 42 | set FRAME_KEY 0 43 | set FRAME_SEQ 1 44 | set FRAME_BODY 2 45 | set KVMSG_FRAMES 3 46 | 47 | oo::class create KVSimple { 48 | 49 | variable frame key 50 | 51 | # Constructor, sets sequence as provided 52 | constructor {{isequence 0}} { 53 | set frame [list] 54 | my set_sequence $isequence 55 | } 56 | 57 | destructor { 58 | } 59 | 60 | # Reads key-value message from socket 61 | method recv {socket} { 62 | set frame [list] 63 | # Read all frames off the wire 64 | for {set frame_nbr 0} {$frame_nbr < $::KVMSG_FRAMES} {incr frame_nbr} { 65 | lappend frame [$socket recv] 66 | # Verify multipart framing 67 | if {![$socket getsockopt RCVMORE]} { 68 | break 69 | } 70 | } 71 | } 72 | 73 | # Send key-value message to socket; any empty frames are sent as such. 74 | method send {socket} { 75 | for {set frame_nbr 0} {$frame_nbr < $::KVMSG_FRAMES} {incr frame_nbr} { 76 | if {$frame_nbr == ($::KVMSG_FRAMES - 1)} { 77 | $socket send [lindex $frame $frame_nbr] 78 | } else { 79 | $socket sendmore [lindex $frame $frame_nbr] 80 | } 81 | } 82 | } 83 | 84 | # Return key from last read message, if any, else NULL 85 | method key {} { 86 | if {[llength $frame] > $::FRAME_KEY} { 87 | if {![info exists key]} { 88 | set size [string length [lindex $frame $::FRAME_KEY]] 89 | if {$size > $::KVMSG_KEY_MAX} { 90 | set size $::KVMSG_KEY_MAX 91 | } 92 | set key [string range [lindex $frame $::FRAME_KEY] 0 [expr {$size - 1}]] 93 | } 94 | return $key 95 | } else { 96 | return {} 97 | } 98 | } 99 | 100 | # Return sequence nbr from last read message, if any 101 | method sequence {} { 102 | if {[llength $frame] > $::FRAME_SEQ} { 103 | set s [lindex $frame $::FRAME_SEQ] 104 | if {[string length $s] != 8} { 105 | error "sequence frame must have length 8" 106 | } 107 | binary scan [lindex $frame $::FRAME_SEQ] W r 108 | return $r 109 | } else { 110 | return 0 111 | } 112 | } 113 | 114 | # Return body from last read message, if any, else NULL 115 | method body {} { 116 | if {[llength $frame] > $::FRAME_BODY} { 117 | return [lindex $frame $::FRAME_BODY] 118 | } else { 119 | return {} 120 | } 121 | } 122 | 123 | # Return body size from last read message, if any, else zero 124 | method size {} { 125 | if {[llength $frame] > $::FRAME_BODY} { 126 | return [string length [lindex $frame $::FRAME_BODY]] 127 | } else { 128 | return {} 129 | } 130 | } 131 | 132 | # Set message key as provided 133 | method set_key {ikey} { 134 | while {[llength $frame] <= $::FRAME_KEY} { 135 | lappend frame {} 136 | } 137 | lset frame $::FRAME_KEY $ikey 138 | } 139 | 140 | # Set message sequence number 141 | method set_sequence {isequence} { 142 | while {[llength $frame] <= $::FRAME_SEQ} { 143 | lappend frame {} 144 | } 145 | set sequence [binary format W $isequence] 146 | lset frame $::FRAME_SEQ $sequence 147 | } 148 | 149 | # Set message body 150 | method set_body {ibody} { 151 | while {[llength $frame] <= $::FRAME_KEY} { 152 | lappend frame {} 153 | } 154 | lset frame $::FRAME_BODY $ibody 155 | } 156 | 157 | # Set message key using printf format 158 | method fmt_key {format args} { 159 | my set_key [format $format {*}$args] 160 | } 161 | 162 | # Set message body using printf format 163 | method fmt_body {format args} { 164 | my set_body [format $format {*}$args] 165 | } 166 | 167 | # Store entire kvmsg into hash map, if key/value are set 168 | # Nullifies kvmsg reference, and destroys automatically when no longer 169 | # needed. 170 | method store {hashnm} { 171 | upvar $hashnm hash 172 | if {[info exists hash([my key])]} { 173 | $hash([my key]) destroy 174 | } 175 | set hash([my key]) [self] 176 | } 177 | 178 | # Dump message to stderr, for debugging and tracing 179 | method dump {} { 180 | set rt "" 181 | append rt [format {[seq:%lld]} [my sequence]] 182 | append rt [format {[key:%s]} [my key]] 183 | append rt [format {[size:%d] } [my size]] 184 | set size [my size] 185 | set body [my body] 186 | for {set i 0} {$i < $size} {incr i} { 187 | set c [lindex $body $i] 188 | if {[string is ascii $c]} { 189 | append rt $c 190 | } else { 191 | append rt [binary scan H2 $c] 192 | } 193 | } 194 | return $rt 195 | } 196 | } 197 | 198 | namespace eval ::KVSimpleTest { 199 | proc test {verbose} { 200 | 201 | puts -nonewline " * kvmsg: " 202 | 203 | # Prepare our context and sockets 204 | zmq context context 205 | set os [zmq socket output context DEALER] 206 | output bind "ipc://kvmsg_selftest.ipc" 207 | set is [zmq socket input context DEALER] 208 | input connect "ipc://kvmsg_selftest.ipc" 209 | 210 | # Test send and receive of simple message 211 | set kvmsg [KVSimple new 1] 212 | $kvmsg set_key "key" 213 | $kvmsg set_body "body" 214 | if {$verbose} { 215 | puts [$kvmsg dump] 216 | } 217 | 218 | $kvmsg send $os 219 | $kvmsg store kvmap 220 | 221 | $kvmsg recv $is 222 | if {$verbose} { 223 | puts [$kvmsg dump] 224 | } 225 | if {[$kvmsg key] ne "key"} { 226 | error "Unexpected key: [$kvmsg key]" 227 | } 228 | $kvmsg store kvmap 229 | 230 | # Shutdown and destroy all objects 231 | input close 232 | output close 233 | context term 234 | 235 | puts "OK" 236 | } 237 | } 238 | 239 | 240 | #::KVSimpleTest::test 1 241 | -------------------------------------------------------------------------------- /examples/lpclient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Lazy Pirate client 3 | # Use zmq_poll to do a safe request-reply 4 | # To run, start lpserver and then randomly kill/restart it 5 | # 6 | 7 | package require zmq 8 | 9 | set REQUEST_TIMEOUT 2500 ;# msecs, (> 1000!) 10 | set REQUEST_RETRIES 3 ;# Before we abandon 11 | set SERVER_ENDPOINT "tcp://localhost:5555" 12 | 13 | zmq context context 14 | puts "I: connecting to server..." 15 | zmq socket client context REQ 16 | client connect $SERVER_ENDPOINT 17 | 18 | set sequence 0 19 | set retries_left $REQUEST_RETRIES 20 | 21 | while {$retries_left} { 22 | # We send a request, then we work to get a reply 23 | client send [incr sequence] 24 | 25 | set expect_reply 1 26 | while {$expect_reply} { 27 | # Poll socket for a reply, with timeout 28 | set rpoll_set [zmq poll {{client {POLLIN}}} $REQUEST_TIMEOUT] 29 | 30 | # If we got a reply, process it 31 | if {[llength $rpoll_set] && [lindex $rpoll_set 0 0] eq "client"} { 32 | # We got a reply from the server, must match sequence 33 | set reply [client recv] 34 | if {$reply eq $sequence} { 35 | puts "I: server replied OK ($reply)" 36 | set retries_left $REQUEST_RETRIES 37 | set expect_reply 0 38 | } else { 39 | puts "E: malformed reply from server: $reply" 40 | } 41 | } elseif {[incr retries_left -1] <= 0} { 42 | puts "E: server seems to be offline, abandoning" 43 | set retries_left 0 44 | break 45 | } else { 46 | puts "W: no response from server, retrying..." 47 | # Old socket is confused; close it and open a new one 48 | client close 49 | puts "I: connecting to server..." 50 | zmq socket client context REQ 51 | client connect $SERVER_ENDPOINT 52 | # Send request again, on new socket 53 | client send $sequence 54 | } 55 | } 56 | } 57 | 58 | client close 59 | context term 60 | -------------------------------------------------------------------------------- /examples/lpserver.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Lazy Pirate server 3 | # Binds REQ socket to tcp://*:5555 4 | # Like hwserver except: 5 | # - echoes request as-is 6 | # - randomly runs slowly, or exits to simulate a crash. 7 | # 8 | 9 | package require zmq 10 | 11 | expr {srand([pid])} 12 | 13 | zmq context context 14 | zmq socket server context REP 15 | server bind "tcp://*:5555" 16 | 17 | set cycles 0 18 | while {1} { 19 | set request [server recv] 20 | incr cycles 21 | 22 | # Simulate various problems, after a few cycles 23 | if {$cycles > 3 && int(rand()*3) == 0} { 24 | puts "I: simulating a crash" 25 | break; 26 | } elseif {$cycles > 3 && int(rand()*3) == 0} { 27 | puts "I: simulating CPU overload" 28 | after 2000 29 | } 30 | puts "I: normal request ($request)" 31 | after 1000 ;# Do some heavy work 32 | server send $request 33 | } 34 | 35 | server close 36 | context term 37 | 38 | -------------------------------------------------------------------------------- /examples/lruqueue.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Least-recently used (LRU) queue device 3 | # 4 | package require zmq 5 | 6 | if {[llength $argv] == 0} { 7 | set argv [list driver 0 3 5] 8 | } elseif {[llength $argv] != 4} { 9 | puts "Usage: lruqueue.tcl " 10 | exit 1 11 | } 12 | 13 | set tclsh [info nameofexecutable] 14 | lassign $argv what asynchronous NBR_CLIENTS NBR_WORKERS 15 | expr {srand([pid])} 16 | 17 | switch -exact -- $what { 18 | client { 19 | # Basic request-reply client using REQ socket 20 | # Since send and recv can't handle 0MQ binary identities we 21 | # set a printable text identity to allow routing. 22 | 23 | package require zmq 24 | 25 | zmq context context 26 | 27 | zmq socket client context REQ 28 | set id [format "%04X-%04X" [expr {int(rand()*0x10000)}] [expr {int(rand()*0x10000)}]] 29 | client setsockopt IDENTITY $id 30 | client connect "ipc://frontend.ipc" 31 | 32 | # Send request, get reply 33 | client send "HELLO" 34 | set reply [client recv] 35 | puts "Client $id: $reply" 36 | 37 | client close 38 | context term 39 | } 40 | worker { 41 | # Worker using REQ socket to do LRU routing 42 | # Since send and recv can't handle 0MQ binary identities we 43 | # set a printable text identity to allow routing. 44 | 45 | zmq context context 46 | 47 | zmq socket worker context REQ 48 | set id [format "%04X-%04X" [expr {int(rand()*0x10000)}] [expr {int(rand()*0x10000)}]] 49 | worker setsockopt IDENTITY $id 50 | worker connect "ipc://backend.ipc" 51 | 52 | # Tell broker we're ready for work 53 | worker send "READY" 54 | 55 | while {1} { 56 | # Read and save all frames until we get an empty frame 57 | # In this example there is only 1 but it could be more 58 | set address [worker recv] 59 | set empty [worker recv] 60 | 61 | # Get request, send reply 62 | set request [worker recv] 63 | puts "Worker $id: $request" 64 | 65 | worker sendmore $address 66 | worker sendmore "" 67 | worker send "OK" 68 | } 69 | 70 | worker close 71 | context term 72 | } 73 | main_sync { 74 | zmq context context 75 | 76 | zmq socket frontend context ROUTER 77 | zmq socket backend context ROUTER 78 | frontend bind "ipc://frontend.ipc" 79 | backend bind "ipc://backend.ipc" 80 | 81 | # Logic of LRU loop 82 | # - Poll backend always, frontend only if 1+ worker ready 83 | # - If worker replies, queue worker as ready and forward reply 84 | # to client if necessary 85 | # - If client requests, pop next worker and send request to it 86 | 87 | # Queue of available workers 88 | set client_nbr $NBR_CLIENTS 89 | set worker_queue {} 90 | 91 | set done 0 92 | while {!$done} { 93 | if {[llength $worker_queue]} { 94 | set poll_set [list [list backend [list POLLIN]] [list frontend [list POLLIN]]] 95 | } else { 96 | set poll_set [list [list backend [list POLLIN]]] 97 | } 98 | set rpoll_set [zmq poll $poll_set -1] 99 | foreach rpoll $rpoll_set { 100 | switch [lindex $rpoll 0] { 101 | backend { 102 | # Queue worker address for LRU routing 103 | set worker_addr [backend recv] 104 | if {!([llength $worker_queue] < $NBR_WORKERS)} { 105 | error "available_workers < NBR_WORKERS" 106 | } 107 | lappend worker_queue $worker_addr 108 | 109 | # Second frame is empty 110 | set empty [backend recv] 111 | 112 | # Third frame is READY or else a client reply address 113 | set client_addr [backend recv] 114 | 115 | # If client reply, send rest back to frontend 116 | if {$client_addr ne "READY"} { 117 | set empty [backend recv] 118 | set reply [backend recv] 119 | 120 | frontend sendmore $client_addr 121 | frontend sendmore "" 122 | frontend send $reply 123 | incr client_nbr -1 124 | if {$client_nbr == 0} { 125 | set done 1 126 | break 127 | } 128 | } 129 | } 130 | frontend { 131 | # Now get next client request, route to LRU worker 132 | # Client request is [address][empty][request] 133 | set client_addr [frontend recv] 134 | set empty [frontend recv] 135 | set request [frontend recv] 136 | 137 | backend sendmore [lindex $worker_queue 0] 138 | backend sendmore "" 139 | backend sendmore $client_addr 140 | backend sendmore "" 141 | backend send $request 142 | 143 | # Dequeue and drop the next worker address 144 | set worker_queue [lrange $worker_queue 1 end] 145 | } 146 | } 147 | } 148 | } 149 | 150 | frontend close 151 | backend close 152 | context term 153 | } 154 | main_async { 155 | zmq context context 156 | 157 | zmq socket frontend context ROUTER 158 | zmq socket backend context ROUTER 159 | frontend bind "ipc://frontend.ipc" 160 | backend bind "ipc://backend.ipc" 161 | 162 | # Logic of LRU loop 163 | # - Poll backend always, frontend only if 1+ worker ready 164 | # - If worker replies, queue worker as ready and forward reply 165 | # to client if necessary 166 | # - If client requests, pop next worker and send request to it 167 | 168 | # Queue of available workers 169 | set client_nbr $NBR_CLIENTS 170 | set worker_queue {} 171 | 172 | set done 0 173 | 174 | proc process_backend {fe be} { 175 | global done worker_queue client_nbr NBR_WORKERS 176 | # Queue worker address for LRU routing 177 | set worker_addr [$be recv] 178 | if {!([llength $worker_queue] < $NBR_WORKERS)} { 179 | error "available_workers < NBR_WORKERS" 180 | } 181 | lappend worker_queue $worker_addr 182 | 183 | # Second frame is empty 184 | set empty [$be recv] 185 | 186 | # Third frame is READY or else a client reply address 187 | set client_addr [$be recv] 188 | 189 | # If client reply, send rest back to frontend 190 | if {$client_addr ne "READY"} { 191 | set empty [$be recv] 192 | set reply [$be recv] 193 | 194 | $fe sendmore $client_addr 195 | $fe sendmore "" 196 | $fe send $reply 197 | incr client_nbr -1 198 | if {$client_nbr == 0} { 199 | set ::done 1 200 | break 201 | } 202 | } 203 | } 204 | 205 | proc process_frontend {fe be} { 206 | global done worker_queue client_nbr 207 | if {[llength $worker_queue]} { 208 | # Now get next client request, route to LRU worker 209 | # Client request is [address][empty][request] 210 | set client_addr [$fe recv] 211 | set empty [$fe recv] 212 | set request [$fe recv] 213 | 214 | $be sendmore [lindex $worker_queue 0] 215 | $be sendmore "" 216 | $be sendmore $client_addr 217 | $be sendmore "" 218 | $be send $request 219 | 220 | # Dequeue and drop the next worker address 221 | set worker_queue [lrange $worker_queue 1 end] 222 | } 223 | } 224 | 225 | frontend readable [list process_frontend ::frontend ::backend] 226 | backend readable [list process_backend ::frontend ::backend] 227 | 228 | vwait done 229 | 230 | frontend close 231 | backend close 232 | context term 233 | } 234 | driver { 235 | puts "Start main, output redirect to main.log" 236 | exec $tclsh lruqueue.tcl [expr {$asynchronous?"main_async":"main_sync"}] $asynchronous $NBR_CLIENTS $NBR_WORKERS > main.log 2>@1 & 237 | 238 | after 1000 239 | 240 | for {set i 0} {$i < $NBR_WORKERS} {incr i} { 241 | puts "Start worker $i, output redirect to worker$i.log" 242 | exec $tclsh lruqueue.tcl worker $asynchronous $NBR_CLIENTS $NBR_WORKERS > worker$i.log 2>@1 & 243 | } 244 | 245 | after 1000 246 | 247 | for {set i 0} {$i < $NBR_CLIENTS} {incr i} { 248 | puts "Start client $i, output redirect to client$i.log" 249 | exec $tclsh lruqueue.tcl client $asynchronous $NBR_CLIENTS $NBR_WORKERS > client$i.log 2>@1 & 250 | } 251 | } 252 | } 253 | -------------------------------------------------------------------------------- /examples/mdcliapi.tcl: -------------------------------------------------------------------------------- 1 | # Majordomo Protocol Client API, Tcl version. 2 | # Implements the MDP/Worker spec at http:#rfc.zeromq.org/spec:7. 3 | 4 | package require TclOO 5 | package require zmq 6 | package require mdp 7 | 8 | package provide MDClient 1.0 9 | 10 | oo::class create MDClient { 11 | 12 | variable context broker verbose timeout retries client 13 | 14 | constructor {ibroker {iverbose 0}} { 15 | set context [zmq context] 16 | set broker $ibroker 17 | set verbose $iverbose 18 | set timeout 2500 19 | set retries 3 20 | set client "" 21 | my connect_to_broker 22 | } 23 | 24 | destructor { 25 | $client close 26 | $context term 27 | } 28 | 29 | method connect_to_broker {} { 30 | if {[string length $client]} { 31 | $client close 32 | } 33 | set client [zmq socket $context REQ] 34 | $client connect $broker 35 | if {$verbose} { 36 | puts "I: connecting to broker at $broker..." 37 | } 38 | } 39 | 40 | method set_timeout {itimeout} { 41 | set timeout $itimeout 42 | } 43 | 44 | method set_retries {iretries} { 45 | set retries $iretries 46 | } 47 | 48 | # Send request to broker and get reply by hook or crook 49 | # Takes ownership of request message and destroys it when sent. 50 | # Returns the reply message or NULL if there was no reply. 51 | method send {service request} { 52 | # Prefix request with protocol frames 53 | # Frame 1: "MDPCxy" (six bytes, MDP/Client x.y) 54 | # Frame 2: Service name (printable string) 55 | set request [zmsg push $request $service] 56 | set request [zmsg push $request $mdp::MDPC_CLIENT] 57 | if {$verbose} { 58 | puts "I: send request to '$service' service:" 59 | puts [join [zmsg dump $request] \n] 60 | } 61 | 62 | set retries_left $retries 63 | while {$retries_left} { 64 | set msg $request 65 | zmsg send $client $msg 66 | 67 | # Poll socket for a reply, with timeout 68 | set poll_set [list [list $client [list POLLIN]]] 69 | set rpoll_set [zmq poll $poll_set $timeout] 70 | # If we got a reply, process it 71 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 72 | set msg [zmsg recv $client] 73 | if {$verbose} { 74 | puts "I: received reply:" 75 | puts [join [zmsg dump $msg] \n] 76 | } 77 | # Don't try to handle errors, just assert noisily 78 | if {[llength $msg] < 3} { 79 | error "message size < 3" 80 | } 81 | set header [zmsg pop msg] 82 | if {$header ne $mdp::MDPC_CLIENT} { 83 | error "unexpected header" 84 | } 85 | set reply_service [zmsg pop msg] 86 | if {$reply_service ne $service} { 87 | error "unexpected service" 88 | } 89 | return $msg 90 | } elseif {[incr retries_left -1]} { 91 | if {$verbose} { 92 | puts "W: no reply, reconnecting..." 93 | } 94 | # Reconnect socket 95 | my connect_to_broker 96 | } else { 97 | if {$verbose} { 98 | puts "W: permanent error, abandoning" 99 | } 100 | break ;# Give up 101 | } 102 | } 103 | return {} 104 | } 105 | } 106 | -------------------------------------------------------------------------------- /examples/mdcliapi2.tcl: -------------------------------------------------------------------------------- 1 | # Majordomo Protocol Client API, Tcl version. 2 | # Implements the MDP/Worker spec at http:#rfc.zeromq.org/spec:7. 3 | 4 | package require TclOO 5 | package require zmq 6 | package require mdp 7 | 8 | package provide MDClient 2.0 9 | 10 | oo::class create MDClient { 11 | 12 | variable context broker verbose timeout retries client 13 | 14 | constructor {ibroker {iverbose 0}} { 15 | set context [zmq context] 16 | set broker $ibroker 17 | set verbose $iverbose 18 | set timeout 2500 19 | set client "" 20 | my connect_to_broker 21 | } 22 | 23 | destructor { 24 | $client close 25 | $context term 26 | } 27 | 28 | method connect_to_broker {} { 29 | if {[string length $client]} { 30 | $client close 31 | } 32 | set client [zmq socket $context DEALER] 33 | $client connect $broker 34 | if {$verbose} { 35 | puts "I: connecting to broker at $broker..." 36 | } 37 | } 38 | 39 | method set_timeout {itimeout} { 40 | set timeout $itimeout 41 | } 42 | 43 | # Send request to broker 44 | # Takes ownership of request message and destroys it when sent. 45 | method send {service request} { 46 | # Prefix request with protocol frames 47 | # Frame 0: empty (REQ emulation) 48 | # Frame 1: "MDPCxy" (six bytes, MDP/Client x.y) 49 | # Frame 2: Service name (printable string) 50 | set request [zmsg push $request $service] 51 | set request [zmsg push $request $mdp::MDPC_CLIENT] 52 | set request [zmsg push $request ""] 53 | if {$verbose} { 54 | puts "I: send request to '$service' service:" 55 | puts [join [zmsg dump $request] \n] 56 | } 57 | zmsg send $client $request 58 | } 59 | 60 | # Returns the reply message or NULL if there was no reply. Does not 61 | # attempt to recover from a broker failure, this is not possible 62 | # without storing all unanswered requests and resending them all... 63 | method recv {} { 64 | # Poll socket for a reply, with timeout 65 | set poll_set [list [list $client [list POLLIN]]] 66 | set rpoll_set [zmq poll $poll_set $timeout] 67 | # If we got a reply, process it 68 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 69 | set msg [zmsg recv $client] 70 | if {$verbose} { 71 | puts "I: received reply:" 72 | puts [join [zmsg dump $msg] \n] 73 | } 74 | # Don't try to handle errors, just assert noisily 75 | if {[llength $msg] < 4} { 76 | error "message size < 4" 77 | } 78 | set empty [zmsg pop msg] 79 | if {[string length $empty]} { 80 | error "expected empty frame" 81 | } 82 | set header [zmsg pop msg] 83 | if {$header ne $mdp::MDPC_CLIENT} { 84 | error "unexpected header" 85 | } 86 | set service [zmsg pop msg] 87 | 88 | return $msg ;# Success 89 | } 90 | if {$verbose} { 91 | puts "W: permanent error, abandoning" 92 | } 93 | return {} 94 | } 95 | } 96 | -------------------------------------------------------------------------------- /examples/mdclient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Majordomo Protocol client example 3 | # Uses the mdcli API to hide all MDP aspects 4 | # 5 | 6 | lappend auto_path . 7 | package require MDClient 1.0 8 | 9 | set verbose 0 10 | foreach {k v} $argv { 11 | if {$k eq "-v"} { set verbose 1 } 12 | } 13 | 14 | set session [MDClient new "tcp://localhost:5555" $verbose] 15 | 16 | for {set count 0} {$count < 10000} {incr count} { 17 | set request [list "Hello world"] 18 | set reply [$session send "echo" $request] 19 | if {[llength $reply] == 0} { 20 | break ;# Interrupt or failure 21 | } 22 | } 23 | 24 | puts "$count requests/replies processed" 25 | 26 | $session destroy 27 | -------------------------------------------------------------------------------- /examples/mdclient2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Majordomo Protocol client example 3 | # Uses the mdcli API to hide all MDP aspects 4 | # 5 | 6 | lappend auto_path . 7 | package require MDClient 2.0 8 | 9 | set verbose 0 10 | foreach {k v} $argv { 11 | if {$k eq "-v"} { set verbose 1 } 12 | } 13 | 14 | set session [MDClient new "tcp://localhost:5555" $verbose] 15 | 16 | for {set count 0} {$count < 10000} {incr count} { 17 | set request [list "Hello world"] 18 | set reply [$session send "echo" $request] 19 | } 20 | 21 | for {set count 0} {$count < 10000} {incr count} { 22 | set reply [$session recv] 23 | if {[llength $reply] == 0} { 24 | break ;# Interrupt or failure 25 | } 26 | } 27 | 28 | puts "$count requests received" 29 | 30 | $session destroy 31 | -------------------------------------------------------------------------------- /examples/mdp.tcl: -------------------------------------------------------------------------------- 1 | # Majordomo Protocol definitions 2 | 3 | package provide mdp 1.0 4 | 5 | namespace eval ::mdp { 6 | # This is the version of MDP/Client we implement 7 | variable MDPC_CLIENT "MDPC01" 8 | # This is the version of MDP/Worker we implement 9 | variable MDPW_WORKER "MDPW01" 10 | # MDP/Server commands, as strings 11 | variable MDPW_COMMAND 12 | set MDPW_COMMAND(READY) "\001" 13 | set MDPW_COMMAND(REQUEST) "\002" 14 | set MDPW_COMMAND(REPLY) "\003" 15 | set MDPW_COMMAND(HEARTBEAT) "\004" 16 | set MDPW_COMMAND(DISCONNECT) "\005" 17 | 18 | variable HEARTBEAT_LIVENESS 3 ;# 3-5 is reasonable 19 | variable HEARTBEAT_INTERVAL 2500 ;# msecs 20 | variable HEARTBEAT_EXPIRY [expr {$HEARTBEAT_INTERVAL * $HEARTBEAT_LIVENESS}] 21 | } 22 | -------------------------------------------------------------------------------- /examples/mdworker.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Majordomo Protocol worker example 3 | # Uses the mdwrk API to hide all MDP aspects 4 | # 5 | 6 | lappend auto_path . 7 | package require MDWorker 1.0 8 | 9 | set verbose 0 10 | foreach {k v} $argv { 11 | if {$k eq "-v"} { set verbose 1 } 12 | } 13 | 14 | set session [MDWorker new "tcp://localhost:5555" "echo" $verbose] 15 | 16 | set reply {} 17 | while {1} { 18 | set request [$session recv $reply] 19 | if {[llength $request] == 0} { 20 | break ;# Worker was interrupted 21 | } 22 | set reply [list "$request @ [clock format [clock seconds]] from $session"] ;# Echo is complex… :-) 23 | } 24 | 25 | $session destroy 26 | -------------------------------------------------------------------------------- /examples/mdwrkapi.tcl: -------------------------------------------------------------------------------- 1 | # Majordomo Protocol Worker API, Tcl version. 2 | # Implements the MDP/Worker spec at http://rfc.zeromq.org/spec:7. 3 | 4 | package require TclOO 5 | package require zmq 6 | package require mdp 7 | 8 | package provide MDWorker 1.0 9 | 10 | oo::class create MDWorker { 11 | 12 | variable context broker service worker verbose heartbeat_at liveness heartbeat reconnect expect_reply reply_to 13 | 14 | constructor {ibroker iservice {iverbose}} { 15 | set context [zmq context] 16 | set broker $ibroker 17 | set service $iservice 18 | set verbose $iverbose 19 | set heartbeat 2500 20 | set reconnect 2500 21 | set expect_reply 0 22 | set reply_to "" 23 | set worker "" 24 | my connect_to_broker 25 | } 26 | 27 | destructor { 28 | $worker close 29 | $context term 30 | } 31 | 32 | # Send message to broker 33 | method send_to_broker {command option msg} { 34 | # Stack protocol envelope to start of message 35 | if {[string length $option]} { 36 | set msg [zmsg push $msg $option] 37 | } 38 | set msg [zmsg push $msg $::mdp::MDPW_COMMAND($command)] 39 | set msg [zmsg push $msg $::mdp::MDPW_WORKER] 40 | set msg [zmsg push $msg ""] 41 | 42 | if {$verbose} { 43 | puts "I: sending $command to broker" 44 | puts [join [zmsg dump $msg] \n] 45 | } 46 | 47 | zmsg send $worker $msg 48 | } 49 | 50 | # Connect or reconnect to broker 51 | method connect_to_broker {} { 52 | if {[string length $worker]} { 53 | $worker close 54 | } 55 | set worker [zmq socket $context DEALER] 56 | $worker connect $broker 57 | if {$verbose} { 58 | puts "I: connecting to broker at $broker..." 59 | } 60 | # Register service with broker 61 | my send_to_broker READY $service {} 62 | # If liveness hits zero, queue is considered disconnected 63 | set liveness $::mdp::HEARTBEAT_LIVENESS 64 | set heartbeat_at [expr {[clock milliseconds] + $heartbeat}] 65 | } 66 | 67 | # Set heartbeat delay 68 | method set_heartbeat {iheartbeat} { 69 | set heartbeat $iheartbeat 70 | } 71 | 72 | # Set reconnect delay 73 | method set_reconnect {ireconnect} { 74 | set reconnect $ireconnect 75 | } 76 | 77 | # Send reply, if any, to broker and wait for next request. 78 | method recv {reply} { 79 | # Format and send the reply if we were provided one 80 | if {!([string length $reply] || !$expect_reply)} { 81 | error "reply expected" 82 | } 83 | if {[string length $reply]} { 84 | if {![string length $reply_to]} { 85 | error "no reply_to found" 86 | } 87 | set reply [zmsg wrap $reply $reply_to] 88 | my send_to_broker REPLY {} $reply 89 | } 90 | set expect_reply 1 91 | 92 | while {1} { 93 | set poll_set [list [list $worker [list POLLIN]]] 94 | set rpoll_set [zmq poll $poll_set $heartbeat] 95 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 96 | set msg [zmsg recv $worker] 97 | if {$verbose} { 98 | puts "I: received message from broker:" 99 | puts [join [zmsg dump $msg] \n] 100 | } 101 | set liveness $::mdp::HEARTBEAT_LIVENESS 102 | 103 | # Don't try to handle errors, just assert noisily 104 | if {[llength $msg] < 3} { 105 | error "invalid message size" 106 | } 107 | set empty [zmsg pop msg] 108 | if {[string length $empty]} { 109 | error "expected empty frame" 110 | } 111 | set header [zmsg pop msg] 112 | if {$header ne $mdp::MDPW_WORKER} { 113 | error "unexpected header" 114 | } 115 | 116 | set command [zmsg pop msg] 117 | if {$command eq $::mdp::MDPW_COMMAND(REQUEST)} { 118 | # We should pop and save as many addresses as there are 119 | # up to a null part, but for now, just save one… 120 | set reply_to [zmsg unwrap msg] 121 | return $msg ;# We have a request to process 122 | } elseif {$command eq $mdp::MDPW_COMMAND(HEARTBEAT)} { 123 | ;# Do nothing for heartbeats 124 | } elseif {$command eq $mdp::MDPW_COMMAND(DISCONNECT)} { 125 | my connect_to_broker 126 | } else { 127 | puts "E: invalid input message" 128 | puts [join [zmsg dump $msg] \n] 129 | } 130 | } elseif {[incr liveness -1] == 0} { 131 | if {$verbose} { 132 | puts "W: disconnected from broker - retrying..." 133 | } 134 | after $reconnect 135 | my connect_to_broker 136 | } 137 | # Send HEARTBEAT if it's time 138 | if {[clock milliseconds] > $heartbeat_at} { 139 | my send_to_broker HEARTBEAT {} {} 140 | set heartbeat_at [expr {[clock milliseconds] + $heartbeat}] 141 | } 142 | } 143 | } 144 | } 145 | -------------------------------------------------------------------------------- /examples/mmiecho.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # MMI echo query example 3 | # 4 | 5 | lappend auto_path . 6 | package require MDClient 1.0 7 | 8 | set verbose 0 9 | foreach {k v} $argv { 10 | if {$k eq "-v"} { set verbose 1 } 11 | } 12 | 13 | set session [MDClient new "tcp://localhost:5555" $verbose] 14 | 15 | foreach service {echo nonexisting} { 16 | 17 | set reply [$session send "mmi.service" $service] 18 | 19 | if {[llength $reply]} { 20 | puts "Lookup '$service' service: [lindex $reply 0]" 21 | } else { 22 | puts "E: no response from broker, make sure it's running" 23 | break 24 | } 25 | } 26 | 27 | $session destroy 28 | -------------------------------------------------------------------------------- /examples/msgqueue.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Simple message queuing broker 3 | # Same as request-reply broker but using QUEUE device 4 | # 5 | 6 | package require zmq 7 | 8 | zmq context context 9 | 10 | # Socket facing clients 11 | zmq socket frontend context ROUTER 12 | frontend bind "tcp://*:5559" 13 | 14 | # Socket facing services 15 | zmq socket backend context DEALER 16 | backend bind "tcp://*:5560" 17 | 18 | # Start built-in device 19 | zmq device QUEUE frontend backend 20 | 21 | # We never get here… 22 | frontend close 23 | backend close 24 | context term 25 | 26 | -------------------------------------------------------------------------------- /examples/mspoller.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Reading from multiple sockets 3 | # This version uses a simple recv loop 4 | # 5 | 6 | package require zmq 7 | 8 | # Prepare our context and sockets 9 | zmq context context 10 | 11 | # Connect to task ventilator 12 | zmq socket receiver context PULL 13 | receiver connect "tcp://localhost:5557" 14 | 15 | # Connect to weather server 16 | zmq socket subscriber context SUB 17 | subscriber connect "tcp://*:5556" 18 | subscriber setsockopt SUBSCRIBE "10001" 19 | 20 | # Socket to send messages to 21 | zmq socket sender context PUSH 22 | sender connect "tcp://localhost:5558" 23 | 24 | # Initialise poll set 25 | set poll_set [list [list receiver [list POLLIN]] [list subscriber [list POLLIN]]] 26 | 27 | # Process message from both sockets 28 | while {1} { 29 | set rpoll_set [zmq poll $poll_set -1] 30 | foreach rpoll $rpoll_set { 31 | switch [lindex $rpoll 0] { 32 | receiver { 33 | if {"POLLIN" in [lindex $rpoll 1]} { 34 | set string [receiver recv] 35 | # Do the work 36 | puts "Process task: $string" 37 | after $string 38 | # Send result to sink 39 | sender send "$string" 40 | } 41 | } 42 | subscriber { 43 | if {"POLLIN" in [lindex $rpoll 1]} { 44 | set string [subscriber recv] 45 | puts "Weather update: $string" 46 | } 47 | } 48 | } 49 | } 50 | # No activity, sleep for 1 msec 51 | after 1 52 | } 53 | 54 | # We never get here but clean up anyhow 55 | sender close 56 | receiver close 57 | subscriber close 58 | context term 59 | -------------------------------------------------------------------------------- /examples/msreader.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Reading from multiple sockets 3 | # This version uses a simple recv loop 4 | # 5 | 6 | package require zmq 7 | 8 | # Prepare our context and sockets 9 | zmq context context 10 | 11 | # Connect to task ventilator 12 | zmq socket receiver context PULL 13 | receiver connect "tcp://localhost:5557" 14 | 15 | # Connect to weather server 16 | zmq socket subscriber context SUB 17 | subscriber connect "tcp://*:5556" 18 | subscriber setsockopt SUBSCRIBE "10001" 19 | 20 | # Socket to send messages to 21 | zmq socket sender context PUSH 22 | sender connect "tcp://localhost:5558" 23 | 24 | # Process messages from both sockets 25 | # We prioritize traffic from the task ventilator 26 | while {1} { 27 | # Process any waiting task 28 | for {set rc 0} {!$rc} {} { 29 | zmq message task 30 | if {[set rc [receiver recv_msg task NOBLOCK]] == 0} { 31 | # Do the work 32 | set string [task data] 33 | puts "Process task: $string" 34 | after $string 35 | # Send result to sink 36 | sender send "$string" 37 | } 38 | task close 39 | } 40 | # Process any waiting weather update 41 | for {set rc 0} {!$rc} {} { 42 | zmq message msg 43 | if {[set rc [subscriber recv_msg msg NOBLOCK]] == 0} { 44 | puts "Weather update: [msg data]" 45 | } 46 | msg close 47 | } 48 | # No activity, sleep for 1 msec 49 | after 1 50 | } 51 | 52 | # We never get here but clean up anyhow 53 | sender close 54 | receiver close 55 | subscriber close 56 | context term 57 | -------------------------------------------------------------------------------- /examples/peering1.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Broker peering simulation (part 1) 3 | # Prototypes the state flow 4 | # 5 | 6 | package require zmq 7 | 8 | # First argument is this broker's name 9 | # Other arguments are our peers' names 10 | # 11 | if {[llength $argv] < 1} { 12 | puts "Usage: peering1.tcl me ?you ...?\n" 13 | exit 1 14 | } 15 | 16 | set self [lindex $argv 0] 17 | puts "I: preparing broker at $self" 18 | expr {srand([pid])} 19 | 20 | # Prepare our context and sockets 21 | zmq context context 22 | zmq socket statebe context PUB 23 | statebe bind "ipc://$self-state.ipc" 24 | 25 | # Connect statefe to all peers 26 | zmq socket statefe context SUB 27 | statefe setsockopt SUBSCRIBE "" 28 | 29 | foreach peer [lrange $argv 1 end] { 30 | puts "I: connecting to state backend at '$peer'" 31 | statefe connect "ipc://$peer-state.ipc" 32 | } 33 | 34 | # Send out status messages to peers, and collect from peers 35 | # 36 | 37 | proc handle_incoming {} { 38 | set peer_name [statefe recv] 39 | set available [statefe recv] 40 | puts "$peer_name - $available workers free" 41 | } 42 | 43 | proc send_random {} { 44 | global self 45 | set data [expr {int(rand()*10)}] 46 | statebe sendmore $self 47 | statebe send $data 48 | after 1000 send_random 49 | } 50 | 51 | statefe readable handle_incoming 52 | send_random 53 | 54 | vwait forever 55 | 56 | statebe close 57 | statefe close 58 | context term 59 | -------------------------------------------------------------------------------- /examples/peering2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Broker peering simulation (part 2) 3 | # Prototypes the request-reply flow 4 | # 5 | 6 | package require zmq 7 | 8 | if {[llength $argv] < 2} { 9 | puts "Usage: peering2.tcl " 10 | exit 1 11 | } 12 | 13 | set NBR_CLIENTS 10 14 | set NBR_WORKERS 3 15 | set LRU_READY "READY" ; # Signals worker is ready 16 | 17 | set peers [lassign $argv what self] 18 | set tclsh [info nameofexecutable] 19 | expr {srand([pid])} 20 | 21 | switch -exact -- $what { 22 | client { 23 | # Request-reply client using REQ socket 24 | # 25 | zmq context context 26 | zmq socket client context REQ 27 | client connect "ipc://$self-localfe.ipc" 28 | 29 | while {1} { 30 | # Send request, get reply 31 | puts "Client: HELLO" 32 | client send "HELLO" 33 | set reply [client recv] 34 | puts "Client: $reply" 35 | after 1000 36 | } 37 | client close 38 | context term 39 | } 40 | worker { 41 | # Worker using REQ socket to do LRU routing 42 | # 43 | zmq context context 44 | zmq socket worker context REQ 45 | worker connect "ipc://$self-localbe.ipc" 46 | 47 | # Tell broker we're ready for work 48 | worker send $LRU_READY 49 | 50 | # Process messages as they arrive 51 | while {1} { 52 | set msg [zmsg recv worker] 53 | puts "Worker: [lindex $msg end]" 54 | lset msg end "OK" 55 | zmsg send worker $msg 56 | } 57 | 58 | worker close 59 | context term 60 | } 61 | main { 62 | puts "I: preparing broker at $self..." 63 | 64 | # Prepare our context and sockets 65 | zmq context context 66 | 67 | # Bind cloud frontend to endpoint 68 | zmq socket cloudfe context ROUTER 69 | cloudfe setsockopt IDENTITY $self 70 | cloudfe bind "ipc://$self-cloud.ipc" 71 | 72 | # Connect cloud backend to all peers 73 | zmq socket cloudbe context ROUTER 74 | cloudbe setsockopt IDENTITY $self 75 | 76 | foreach peer $peers { 77 | puts "I: connecting to cloud frontend at '$peer'" 78 | cloudbe connect "ipc://$peer-cloud.ipc" 79 | } 80 | 81 | # Prepare local frontend and backend 82 | zmq socket localfe context ROUTER 83 | localfe bind "ipc://$self-localfe.ipc" 84 | 85 | zmq socket localbe context ROUTER 86 | localbe bind "ipc://$self-localbe.ipc" 87 | 88 | # Get user to tell us when we can start… 89 | puts -nonewline "Press Enter when all brokers are started: " 90 | flush stdout 91 | gets stdin c 92 | 93 | # Start local workers 94 | for {set worker_nbr 0} {$worker_nbr < $NBR_WORKERS} {incr worker_nbr} { 95 | puts "Starting worker $worker_nbr, output redirected to worker-$self-$worker_nbr.log" 96 | exec $tclsh peering2.tcl worker $self {*}$peers > worker-$self-$worker_nbr.log 2>@1 & 97 | } 98 | 99 | # Start local clients 100 | for {set client_nbr 0} {$client_nbr < $NBR_CLIENTS} {incr client_nbr} { 101 | puts "Starting client $client_nbr, output redirected to client-$self-$client_nbr.log" 102 | exec $tclsh peering2.tcl client $self {*}$peers > client-$self-$client_nbr.log 2>@1 & 103 | } 104 | 105 | # Interesting part 106 | # ------------------------------------------------------------- 107 | # Request-reply flow 108 | # - Poll backends and process local/cloud replies 109 | # - While worker available, route localfe to local or cloud 110 | 111 | # Queue of available workers 112 | set workers {} 113 | 114 | proc route_to_cloud_or_local {msg} { 115 | global peers 116 | # Route reply to cloud if it's addressed to a broker 117 | foreach peer $peers { 118 | if {$peer eq [lindex $msg 0]} { 119 | zmsg send cloudfe $msg 120 | return 121 | } 122 | } 123 | # Route reply to client if we still need to 124 | zmsg send localfe $msg 125 | } 126 | 127 | proc handle_localbe {} { 128 | global workers 129 | # Handle reply from local worker 130 | set msg [zmsg recv localbe] 131 | set address [zmsg unwrap msg] 132 | lappend workers $address 133 | # If it's READY, don't route the message any further 134 | if {[lindex $msg 0] ne "READY"} { 135 | route_to_cloud_or_local $msg 136 | } 137 | } 138 | 139 | proc handle_cloudbe {} { 140 | # Or handle reply from peer broker 141 | set msg [zmsg recv cloudbe] 142 | # We don't use peer broker address for anything 143 | zmsg unwrap msg 144 | route_to_cloud_or_local $msg 145 | } 146 | 147 | proc handle_client {s reroutable} { 148 | global peers workers 149 | if {[llength $workers]} { 150 | set msg [zmsg recv $s] 151 | # If reroutable, send to cloud 20% of the time 152 | # Here we'd normally use cloud status information 153 | # 154 | if {$reroutable && [llength $peers] && [expr {int(rand()*5)}] == 0} { 155 | set peer [lindex $peers [expr {int(rand()*[llength $peers])}]] 156 | set msg [zmsg push $msg $peer] 157 | zmsg send cloudbe $msg 158 | } else { 159 | set frame [lindex $workers 0] 160 | set workers [lrange $workers 1 end] 161 | set msg [zmsg wrap $msg $frame] 162 | zmsg send localbe $msg 163 | } 164 | } 165 | } 166 | 167 | proc handle_clients {} { 168 | # We'll do peer brokers first, to prevent starvation 169 | if {"POLLIN" in [cloudfe getsockopt EVENTS]} { 170 | handle_client cloudfe 0 171 | } 172 | if {"POLLIN" in [localfe getsockopt EVENTS]} { 173 | handle_client localfe 1 174 | } 175 | } 176 | 177 | localbe readable handle_localbe 178 | cloudbe readable handle_cloudbe 179 | localfe readable handle_clients 180 | cloudfe readable handle_clients 181 | 182 | vwait forever 183 | 184 | # When we're done, clean up properly 185 | localbe close 186 | localfe close 187 | cloudbe close 188 | cloudfe close 189 | context term 190 | } 191 | } 192 | -------------------------------------------------------------------------------- /examples/peering3.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Broker peering simulation (part 3) 3 | # Prototypes the full flow of status and tasks 4 | # 5 | 6 | package require zmq 7 | 8 | if {[llength $argv] < 2} { 9 | puts "Usage: peering2.tcl " 10 | exit 1 11 | } 12 | 13 | set NBR_CLIENTS 10 14 | set NBR_WORKERS 3 15 | set LRU_READY "READY" ; # Signals worker is ready 16 | 17 | set peers [lassign $argv what self] 18 | set tclsh [info nameofexecutable] 19 | expr {srand([pid])} 20 | 21 | switch -exact -- $what { 22 | client { 23 | # Request-reply client using REQ socket 24 | # To simulate load, clients issue a burst of requests and then 25 | # sleep for a random period. 26 | # 27 | zmq context context 28 | zmq socket client context REQ 29 | client connect "ipc://$self-localfe.ipc" 30 | zmq socket monitor context PUSH 31 | monitor connect "ipc://$self-monitor.ipc" 32 | 33 | proc process_client {} { 34 | global task_id done self 35 | client readable {} 36 | set reply [client recv] 37 | if {$task_id ne [lindex $reply 0]} { 38 | monitor send "E [clock seconds]: CLIENT EXIT - reply '$reply' not equal to task-id '$task_id'" 39 | exit 1 40 | } 41 | monitor send "OK [clock seconds]: CLIENT REPLY - $reply" 42 | set_done 1 43 | } 44 | 45 | proc set_done {v} { 46 | global done 47 | if {$done < 0} { 48 | set done $v 49 | } 50 | } 51 | 52 | while {1} { 53 | after [expr {int(rand()*5)*1000}] 54 | set burst [expr {int(rand()*15)}] 55 | while {$burst} { 56 | set task_id [format "%04X" [expr {int(rand()*0x10000)}]] 57 | 58 | # Send request with random hex ID 59 | client send $task_id 60 | 61 | # Wait max ten seconds for a reply, then complain 62 | set done -1 63 | client readable process_client 64 | set aid [after 10000 [list set_done 0]] 65 | 66 | vwait done 67 | catch {after cancel $aid} 68 | 69 | if {$done == 0} { 70 | monitor send "E [clock seconds]: CLIENT EXIT - lost task '$task_id'" 71 | exit 1 72 | } 73 | 74 | incr burst -1 75 | } 76 | } 77 | 78 | client close 79 | control close 80 | context term 81 | } 82 | worker { 83 | # Worker using REQ socket to do LRU routing 84 | # 85 | zmq context context 86 | zmq socket worker context REQ 87 | worker connect "ipc://$self-localbe.ipc" 88 | 89 | # Tell broker we're ready for work 90 | worker send $LRU_READY 91 | 92 | # Process messages as they arrive 93 | while {1} { 94 | # Workers are busy for 0/1 seconds 95 | set msg [zmsg recv worker] 96 | set payload [list [lindex $msg end] $self] 97 | lset msg end $payload 98 | after [expr {int(rand()*2)*1000}] 99 | zmsg send worker $msg 100 | } 101 | 102 | worker close 103 | context term 104 | } 105 | main { 106 | puts "I: preparing broker at $self..." 107 | 108 | # Prepare our context and sockets 109 | zmq context context 110 | 111 | # Bind cloud frontend to endpoint 112 | zmq socket cloudfe context ROUTER 113 | cloudfe setsockopt IDENTITY $self 114 | cloudfe bind "ipc://$self-cloud.ipc" 115 | 116 | # Bind state backend / publisher to endpoint 117 | zmq socket statebe context PUB 118 | statebe bind "ipc://$self-state.ipc" 119 | 120 | # Connect cloud backend to all peers 121 | zmq socket cloudbe context ROUTER 122 | cloudbe setsockopt IDENTITY $self 123 | foreach peer $peers { 124 | puts "I: connecting to cloud frontend at '$peer'" 125 | cloudbe connect "ipc://$peer-cloud.ipc" 126 | } 127 | 128 | # Connect statefe to all peers 129 | zmq socket statefe context SUB 130 | statefe setsockopt SUBSCRIBE "" 131 | foreach peer $peers { 132 | puts "I: connecting to state backend at '$peer'" 133 | statefe connect "ipc://$peer-state.ipc" 134 | } 135 | 136 | # Prepare local frontend and backend 137 | zmq socket localfe context ROUTER 138 | localfe bind "ipc://$self-localfe.ipc" 139 | 140 | zmq socket localbe context ROUTER 141 | localbe bind "ipc://$self-localbe.ipc" 142 | 143 | # Prepare monitor socket 144 | zmq socket monitor context PULL 145 | monitor bind "ipc://$self-monitor.ipc" 146 | 147 | # Start local workers 148 | for {set worker_nbr 0} {$worker_nbr < $NBR_WORKERS} {incr worker_nbr} { 149 | puts "Starting worker $worker_nbr, output redirected to worker-$self-$worker_nbr.log" 150 | exec $tclsh peering3.tcl worker $self {*}$peers > worker-$self-$worker_nbr.log 2>@1 & 151 | } 152 | 153 | # Start local clients 154 | for {set client_nbr 0} {$client_nbr < $NBR_CLIENTS} {incr client_nbr} { 155 | puts "Starting client $client_nbr, output redirected to client-$self-$client_nbr.log" 156 | exec $tclsh peering3.tcl client $self {*}$peers > client-$self-$client_nbr.log 2>@1 & 157 | } 158 | 159 | # Interesting part 160 | # ------------------------------------------------------------- 161 | # Publish-subscribe flow 162 | # - Poll statefe and process capacity updates 163 | # - Each time capacity changes, broadcast new value 164 | # Request-reply flow 165 | # - Poll primary and process local/cloud replies 166 | # - While worker available, route localfe to local or cloud 167 | 168 | # Queue of available workers 169 | set local_capacity 0 170 | set cloud_capacity 0 171 | set old_cloud_capacity -1 172 | set workers {} 173 | 174 | proc route_to_cloud_or_local {msg} { 175 | global peers 176 | # Route reply to cloud if it's addressed to a broker 177 | foreach peer $peers { 178 | if {$peer eq [lindex $msg 0]} { 179 | zmsg send cloudfe $msg 180 | return 181 | } 182 | } 183 | # Route reply to client if we still need to 184 | zmsg send localfe $msg 185 | } 186 | 187 | proc handle_localbe {} { 188 | global workers 189 | # Handle reply from local worker 190 | set msg [zmsg recv localbe] 191 | set address [zmsg unwrap msg] 192 | lappend workers $address 193 | # If it's READY, don't route the message any further 194 | if {[lindex $msg 0] ne "READY"} { 195 | route_to_cloud_or_local $msg 196 | } 197 | } 198 | 199 | proc handle_cloudbe {} { 200 | # Or handle reply from peer broker 201 | set msg [zmsg recv cloudbe] 202 | # We don't use peer broker address for anything 203 | zmsg unwrap msg 204 | route_to_cloud_or_local $msg 205 | } 206 | 207 | proc handle_statefe {} { 208 | global cloud_capacity 209 | # Handle capacity updates 210 | set peer [statefe recv] 211 | set cloud_capacity [statefe recv] 212 | } 213 | 214 | proc handle_monitor {} { 215 | # Handle monitor message 216 | puts [monitor recv] 217 | } 218 | 219 | # Now route as many clients requests as we can handle 220 | # - If we have local capacity we poll both localfe and cloudfe 221 | # - If we have cloud capacity only, we poll just localfe 222 | # - Route any request locally if we can, else to cloud 223 | # 224 | proc handle_client {s} { 225 | global peers workers workers cloud_capacity self 226 | set msg [zmsg recv $s] 227 | if {[llength $workers]} { 228 | set workers [lassign $workers frame] 229 | set msg [zmsg wrap $msg $frame] 230 | zmsg send localbe $msg 231 | } else { 232 | set peer [lindex $peers [expr {int(rand()*[llength $peers])}]] 233 | set msg [zmsg push $msg $peer] 234 | zmsg send cloudbe $msg 235 | } 236 | } 237 | 238 | proc handle_clients {} { 239 | if {[catch { 240 | global workers cloud_capacity 241 | if {[llength $workers] && ("POLLIN" in [cloudfe getsockopt EVENTS])} { 242 | handle_client cloudfe 243 | } 244 | if {([llength $workers] || $cloud_capacity) && ("POLLIN" in [localfe getsockopt EVENTS])} { 245 | handle_client localfe 246 | } 247 | } msg]} { 248 | puts $msg 249 | } 250 | } 251 | 252 | proc publish_capacity {} { 253 | global self workers old_cloud_capacity 254 | if {[llength $workers] != $old_cloud_capacity} { 255 | puts "OK [clock seconds] : PUBLISH CAPACITY [llength $workers]" 256 | # We stick our own address onto the envelope 257 | statebe sendmore $self 258 | # Broadcast new capacity 259 | statebe send [llength $workers] 260 | set old_cloud_capacity [llength $workers] 261 | } 262 | # Repeat 263 | after 1000 publish_capacity 264 | } 265 | 266 | localbe readable handle_localbe 267 | cloudbe readable handle_cloudbe 268 | statefe readable handle_statefe 269 | monitor readable handle_monitor 270 | 271 | localfe readable handle_clients 272 | cloudfe readable handle_clients 273 | 274 | publish_capacity 275 | 276 | vwait forever 277 | 278 | # When we're done, clean up properly 279 | localbe close 280 | localfe close 281 | cloudbe close 282 | cloudfe close 283 | monitor close 284 | statefe close 285 | context term 286 | } 287 | } 288 | -------------------------------------------------------------------------------- /examples/pkgIndex.tcl: -------------------------------------------------------------------------------- 1 | package ifneeded mdp 1.0 [list source [file join $dir mdp.tcl]] 2 | package ifneeded MDClient 1.0 [list source [file join $dir mdcliapi.tcl]] 3 | package ifneeded MDClient 2.0 [list source [file join $dir mdcliapi2.tcl]] 4 | package ifneeded MDWorker 1.0 [list source [file join $dir mdwrkapi.tcl]] 5 | package ifneeded BStar 1.0 [list source [file join $dir bstar.tcl]] 6 | package ifneeded FLClient 1.0 [list source [file join $dir flcliapi.tcl]] 7 | package ifneeded KVSimple 1.0 [list source [file join $dir kvsimple.tcl]] 8 | package ifneeded KVMsg 1.0 [list source [file join $dir kvmsg.tcl]] 9 | -------------------------------------------------------------------------------- /examples/ppqueue.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Paranoid Pirate queue 3 | # 4 | 5 | package require zmq 6 | 7 | set HEARTBEAT_LIVENESS 3 ;# 3-5 is reasonable 8 | set HEARTBEAT_INTERVAL 1 ;# secs 9 | 10 | # Paranoid Pirate Protocol constants 11 | set PPP_READY "READY" ;# Signals worker is ready 12 | set PPP_HEARTBEAT "HEARTBEAT" ;# Signals worker heartbeat 13 | 14 | # This defines one active worker in our worker list 15 | # dict with keys address, identity and expiry 16 | 17 | # Construct new worker 18 | proc s_worker_new {address} { 19 | global HEARTBEAT_LIVENESS HEARTBEAT_INTERVAL 20 | return [dict create address $address identity $address expiry [expr {[clock seconds] + $HEARTBEAT_INTERVAL * $HEARTBEAT_LIVENESS}]] 21 | } 22 | 23 | # Worker is ready, remove if on list and move to end 24 | proc s_worker_ready {self workersnm} { 25 | upvar $workersnm workers 26 | set nworkers {} 27 | foreach worker $workers { 28 | if {[dict get $self identity] ne [dict get $worker identity]} { 29 | lappend nworkers $worker 30 | } 31 | } 32 | lappend nworkers $self 33 | set workers $nworkers 34 | } 35 | 36 | # Return next available worker address 37 | proc s_workers_next {workersnm} { 38 | upvar $workersnm workers 39 | set workers [lassign $workers worker] 40 | return [dict get $worker address] 41 | } 42 | 43 | # Look for & kill expired workers. Workers are oldest to most recent, 44 | # so we stop at the first alive worker. 45 | proc s_workers_purge {workersnm} { 46 | upvar $workersnm workers 47 | set nworkers {} 48 | foreach worker $workers { 49 | if {[clock seconds] < [dict get $worker expiry]} { 50 | # Worker is alive 51 | lappend nworkers $worker 52 | } 53 | } 54 | set workers $nworkers 55 | } 56 | 57 | set ctx [zmq context context] 58 | zmq socket frontend $ctx ROUTER 59 | zmq socket backend $ctx ROUTER 60 | frontend bind "tcp://*:5555" ;# For clients 61 | backend bind "tcp://*:5556";# For workers 62 | 63 | # List of available workers 64 | set workers {} 65 | 66 | # Send out heartbeats at regular intervals 67 | set heartbeat_at [expr {[clock seconds] + $HEARTBEAT_INTERVAL}] 68 | 69 | while {1} { 70 | if {[llength $workers]} { 71 | set poll_set [list [list backend [list POLLIN]] [list frontend [list POLLIN]]] 72 | } else { 73 | set poll_set [list [list backend [list POLLIN]]] 74 | } 75 | set rpoll_set [zmq poll $poll_set $HEARTBEAT_INTERVAL] 76 | foreach rpoll $rpoll_set { 77 | switch [lindex $rpoll 0] { 78 | backend { 79 | # Handle worker activity on backend 80 | # Use worker address for LRU routing 81 | set msg [zmsg recv backend] 82 | 83 | # Any sign of life from worker means it's ready 84 | set address [zmsg unwrap msg] 85 | set worker [s_worker_new $address] 86 | s_worker_ready $worker workers 87 | 88 | # Validate control message, or return reply to client 89 | if {[llength $msg] == 1} { 90 | if {[lindex $msg 0] ne $PPP_READY && [lindex $msg 0] ne $PPP_HEARTBEAT} { 91 | puts "E: invalid message from worker" 92 | zmsg dump $msg 93 | } 94 | } else { 95 | zmsg send frontend $msg 96 | } 97 | } 98 | frontend { 99 | # Now get next client request, route to next worker 100 | set msg [zmsg recv frontend] 101 | set msg [zmsg push $msg [s_workers_next workers]] 102 | zmsg send backend $msg 103 | } 104 | } 105 | } 106 | 107 | # Send heartbeats to idle workers if it's time 108 | if {[clock seconds] >= $heartbeat_at} { 109 | puts "I: heartbeat ([llength $workers])" 110 | foreach worker $workers { 111 | backend sendmore [dict get $worker address] 112 | backend send $PPP_HEARTBEAT 113 | } 114 | set heartbeat_at [expr {[clock seconds] + $HEARTBEAT_INTERVAL}] 115 | } 116 | s_workers_purge workers 117 | } 118 | 119 | frontend close 120 | backend close 121 | $ctx term 122 | -------------------------------------------------------------------------------- /examples/ppworker.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Paranoid Pirate worker 3 | # 4 | 5 | package require zmq 6 | 7 | set HEARTBEAT_LIVENESS 3 ;# 3-5 is reasonable 8 | set HEARTBEAT_INTERVAL 1000 ;# msecs 9 | set INTERVAL_INIT 1000 ;# Initial reconnect 10 | set INTERVAL_MAX 32000 ;# After exponential backoff 11 | 12 | # Paranoid Pirate Protocol constants 13 | set PPP_READY "READY" ;# Signals worker is ready 14 | set PPP_HEARTBEAT "HEARTBEAT" ;# Signals worker heartbeat 15 | 16 | expr {srand([pid])} 17 | 18 | # Helper function that returns a new configured socket 19 | # connected to the Paranoid Pirate queue 20 | 21 | proc s_worker_socket {ctx} { 22 | global PPP_READY 23 | 24 | set worker [zmq socket worker $ctx DEALER] 25 | $worker connect "tcp://localhost:5556" 26 | 27 | # Tell queue we're ready for work 28 | puts "I: worker ready" 29 | $worker send $PPP_READY 30 | 31 | return $worker 32 | } 33 | 34 | set ctx [zmq context context] 35 | set worker [s_worker_socket $ctx] 36 | 37 | # If liveness hits zero, queue is considered disconnected 38 | set liveness $HEARTBEAT_LIVENESS 39 | set interval $INTERVAL_INIT 40 | 41 | # Send out heartbeats at regular intervals 42 | set heartbeat_at [expr {[clock seconds] + $HEARTBEAT_INTERVAL}] 43 | 44 | set cycles 0 45 | while {1} { 46 | set poll_set [list [list $worker [list POLLIN]]] 47 | set rpoll_set [zmq poll $poll_set $HEARTBEAT_INTERVAL] 48 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 49 | # Get message 50 | # - 3-part envelope + content -> request 51 | # - 1-part HEARTBEAT -> heartbeat 52 | set msg [zmsg recv $worker] 53 | 54 | if {[llength $msg] == 3} { 55 | # Simulate various problems, after a few cycles 56 | incr cycles 57 | if {$cycles > 3 && [expr {int(rand()*5)}] == 0} { 58 | puts "I: simulating a crash" 59 | break 60 | } elseif {$cycles > 3 && [expr {int(rand()*5)}] == 0} { 61 | puts "I: simulating CPU overload" 62 | after 3000 63 | } 64 | puts "I: normal reply" 65 | zmsg send $worker $msg 66 | set liveness $HEARTBEAT_LIVENESS 67 | after 1000 ;# Do some heavy work 68 | } elseif {[llength $msg] == 1} { 69 | if {[lindex $msg 0] eq $PPP_HEARTBEAT} { 70 | puts "I: heartbeat" 71 | set liveness $HEARTBEAT_LIVENESS 72 | } else { 73 | puts "E: invalid message" 74 | zmsg dump $msg 75 | } 76 | } else { 77 | puts "E: invalid message" 78 | zmsg dump $msg 79 | } 80 | set interval $INTERVAL_INIT 81 | } elseif {[incr liveness -1] == 0} { 82 | puts "W: heartbeat failure, can't reach queue" 83 | puts "W: reconnecting in $interval msec..." 84 | after $interval 85 | 86 | if {$interval < $INTERVAL_MAX} { 87 | set interval [expr {$interval * 2}] 88 | } 89 | $worker close 90 | set worker [s_worker_socket $ctx] 91 | set liveness $HEARTBEAT_LIVENESS 92 | } 93 | # Send heartbeat to queue if it's time 94 | if {[clock seconds] > $heartbeat_at} { 95 | set heartbeat_at [expr {[clock seconds] + $HEARTBEAT_INTERVAL}] 96 | puts "I: worker heartbeat" 97 | 98 | $worker send $PPP_HEARTBEAT 99 | } 100 | } 101 | 102 | $worker close 103 | $ctx term 104 | -------------------------------------------------------------------------------- /examples/psenvpub.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Pubsub envelope publisher 3 | # Note that the zhelpers.h file also provides sendmore 4 | # 5 | 6 | package require zmq 7 | 8 | # Prepare our context and publisher 9 | zmq context context 10 | zmq socket publisher context PUB 11 | publisher bind "tcp://*:5563" 12 | 13 | while {1} { 14 | # Write two messages, each with an envelope and content 15 | publisher sendmore "A" 16 | publisher send "We don't want to see this" 17 | publisher sendmore "B" 18 | publisher send "We would like to see this" 19 | after 1000 20 | } 21 | 22 | # We never get here but clean up anyhow 23 | publisher close 24 | context term 25 | -------------------------------------------------------------------------------- /examples/psenvsub.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Pubsub envelope subscriber 3 | # 4 | 5 | package require zmq 6 | 7 | # Prepare our context and subscriber 8 | zmq context context 9 | zmq socket subscriber context SUB 10 | subscriber connect "tcp://localhost:5563" 11 | subscriber setsockopt SUBSCRIBE "B" 12 | 13 | while {1} { 14 | # Read envelope with address 15 | set address [subscriber recv] 16 | # Read message contents 17 | set contents [subscriber recv] 18 | puts "\[$address\] $contents" 19 | } 20 | 21 | # We never get here but clean up anyhow 22 | subscriber close 23 | context term 24 | -------------------------------------------------------------------------------- /examples/rrbroker.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Simple request-reply broker 3 | # 4 | 5 | package require zmq 6 | 7 | # Prepare our context and sockets 8 | zmq context context 9 | zmq socket frontend context ROUTER 10 | zmq socket backend context DEALER 11 | frontend bind "tcp://*:5559" 12 | backend bind "tcp://*:5560" 13 | 14 | # Initialize poll set 15 | set poll_set [list [list frontend [list POLLIN]] [list backend [list POLLIN]]] 16 | 17 | # Switch messages between sockets 18 | while {1} { 19 | set rpoll_set [zmq poll $poll_set -1] 20 | foreach rpoll $rpoll_set { 21 | switch [lindex $rpoll 0] { 22 | frontend { 23 | if {"POLLIN" in [lindex $rpoll 1]} { 24 | while {1} { 25 | # Process all parts of the message 26 | zmq message message 27 | frontend recv_msg message 28 | set more [frontend getsockopt RCVMORE] 29 | backend send_msg message [expr {$more?"SNDMORE":""}] 30 | message close 31 | if {!$more} { 32 | break ; # Last message part 33 | } 34 | } 35 | } 36 | } 37 | backend { 38 | if {"POLLIN" in [lindex $rpoll 1]} { 39 | while {1} { 40 | # Process all parts of the message 41 | zmq message message 42 | backend recv_msg message 43 | set more [backend getsockopt RCVMORE] 44 | frontend send_msg message [expr {$more?"SNDMORE":""}] 45 | message close 46 | if {!$more} { 47 | break ; # Last message part 48 | } 49 | } 50 | } 51 | } 52 | } 53 | } 54 | } 55 | 56 | # We never get here but clean up anyhow 57 | frontend close 58 | backend close 59 | context term 60 | -------------------------------------------------------------------------------- /examples/rrbroker_callback.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Simple request-reply broker 3 | # 4 | 5 | package require zmq 6 | 7 | # Prepare our context and sockets 8 | zmq context context 9 | zmq socket frontend context ROUTER 10 | zmq socket backend context DEALER 11 | frontend bind "tcp://*:5559" 12 | backend bind "tcp://*:5560" 13 | 14 | # Worker procs 15 | proc process_frontend {} { 16 | while {1} { 17 | # Process all parts of the message 18 | zmq message message 19 | ::frontend recv_msg message 20 | set more [::frontend getsockopt RCVMORE] 21 | ::backend send_msg message [expr {$more?"SNDMORE":""}] 22 | message close 23 | if {!$more} { 24 | break ; # Last message part 25 | } 26 | } 27 | } 28 | 29 | proc process_backend {} { 30 | while {1} { 31 | # Process all parts of the message 32 | zmq message message 33 | ::backend recv_msg message 34 | set more [::backend getsockopt RCVMORE] 35 | ::frontend send_msg message [expr {$more?"SNDMORE":""}] 36 | message close 37 | if {!$more} { 38 | break ; # Last message part 39 | } 40 | } 41 | } 42 | 43 | # Switch messages between sockets 44 | frontend readable [list process_frontend] 45 | backend readable [list process_backend] 46 | 47 | vwait forever 48 | 49 | # We never get here but clean up anyhow 50 | frontend close 51 | backend close 52 | context term 53 | -------------------------------------------------------------------------------- /examples/rrclient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Hello World client 3 | # Connects REQ socket to tcp://localhost:5559 4 | # Sends "Hello" to server, expects "World" back 5 | # 6 | 7 | package require zmq 8 | 9 | zmq context context 10 | 11 | # Socket to talk to server 12 | zmq socket requester context REQ 13 | requester connect "tcp://localhost:5559" 14 | 15 | for {set request_nbr 0} {$request_nbr < 10} { incr request_nbr} { 16 | requester send "Hello" 17 | set string [requester recv] 18 | puts "Received reply $request_nbr \[$string\]" 19 | } 20 | 21 | requester close 22 | context term 23 | -------------------------------------------------------------------------------- /examples/rrserver.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Hello World server 3 | # Connects REP socket to tcp://*:5560 4 | # Expects "Hello" from client, replies with "World" 5 | # 6 | 7 | package require zmq 8 | 9 | zmq context context 10 | 11 | # Socket to talk to clients 12 | zmq socket responder context REP 13 | responder connect "tcp://localhost:5560" 14 | 15 | while {1} { 16 | # Wait for next request from client 17 | set string [responder recv] 18 | puts "Received request: \[$string\]" 19 | 20 | # Do some 'work' 21 | after 1000; 22 | 23 | # Send reply back to client 24 | responder send "World" 25 | } 26 | 27 | # We never get here but clean up anyhow 28 | responder close 29 | context term 30 | 31 | -------------------------------------------------------------------------------- /examples/rtdealer.tcl: -------------------------------------------------------------------------------- 1 | # Custom routing Router to Dealer 2 | package require zmq 3 | 4 | if {[llength $argv] == 0} { 5 | set argv [list main {}] 6 | } elseif {[llength $argv] != 2} { 7 | puts "Usage: rtdelaer.tcl " 8 | exit 1 9 | } 10 | 11 | set tclsh [info nameofexecutable] 12 | lassign $argv what identity 13 | expr {srand([pid])} 14 | 15 | switch -exact -- $what { 16 | worker { 17 | zmq context context 18 | 19 | zmq socket worker context DEALER 20 | worker setsockopt IDENTITY $identity 21 | worker connect "ipc://routing.ipc" 22 | 23 | set total 0 24 | while {1} { 25 | # We receive one part, with the workload 26 | set request [worker recv] 27 | if {$request eq "END"} { 28 | puts "$identity received: $total" 29 | break; 30 | } 31 | incr total 32 | } 33 | 34 | worker close 35 | context term 36 | } 37 | main { 38 | zmq context context 39 | 40 | zmq socket client context ROUTER 41 | client bind "ipc://routing.ipc" 42 | 43 | foreach c {A B} { 44 | puts "Start worker $c, output redirected to worker$c.log" 45 | exec $tclsh rtdealer.tcl worker $c > worker$c.log 2>@1 & 46 | } 47 | 48 | # Wait for threads to connect, since otherwise the messages 49 | # we send won't be routable. 50 | after 1000 51 | 52 | # Send 10 tasks scattered to A twice as often as B 53 | for {set task_nbr 0} {$task_nbr < 10} {incr task_nbr} { 54 | # Send two message parts, first the address… 55 | set id [expr {int(rand() * 3) > 0?"A":"B"}] 56 | client sendmore $id 57 | 58 | # And then the workload 59 | client send "This is the workload" 60 | } 61 | 62 | client sendmore "A" 63 | client send "END" 64 | 65 | client sendmore "B" 66 | client send "END" 67 | 68 | client close 69 | context term 70 | } 71 | } 72 | -------------------------------------------------------------------------------- /examples/rtmama.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Custom routing Router to Mama (ROUTER to REQ) 3 | # 4 | 5 | package require zmq 6 | 7 | if {[llength $argv] == 0} { 8 | set argv [list driver 3] 9 | } elseif {[llength $argv] != 2} { 10 | puts "Usage: rtmama.tcl " 11 | exit 1 12 | } 13 | 14 | lassign $argv what NBR_WORKERS 15 | 16 | set tclsh [info nameofexecutable] 17 | set nbr_of_workers [lindex $argv 0] 18 | expr {srand([pid])} 19 | 20 | switch -exact -- $what { 21 | worker { 22 | zmq context context 23 | 24 | zmq socket worker context REQ 25 | 26 | # We use a string identity for ease here 27 | set id [format "%04X-%04X" [expr {int(rand()*0x10000)}] [expr {int(rand()*0x10000)}]] 28 | worker setsockopt IDENTITY $id 29 | worker connect "ipc://routing.ipc" 30 | 31 | set total 0 32 | while {1} { 33 | # Tell the router we're ready for work 34 | worker send "ready" 35 | 36 | # Get workload from router, until finished 37 | set workload [worker recv] 38 | if {$workload eq "END"} { 39 | puts "Processed: $total tasks" 40 | break 41 | } 42 | incr total 43 | 44 | # Do some random work 45 | after [expr {int(rand()*1000)}] 46 | } 47 | 48 | worker close 49 | context term 50 | } 51 | main { 52 | zmq context context 53 | 54 | zmq socket client context ROUTER 55 | client bind "ipc://routing.ipc" 56 | 57 | for {set task_nbr 0} {$task_nbr < $NBR_WORKERS * 10} {incr task_nbr} { 58 | # LRU worker is next waiting in queue 59 | set address [client recv] 60 | set empty [client recv] 61 | set ready [client recv] 62 | client sendmore $address 63 | client sendmore "" 64 | client send "This is the workload" 65 | } 66 | 67 | # Now ask mamas to shut down and report their results 68 | for {set worker_nbr 0} {$worker_nbr < $NBR_WORKERS} {incr worker_nbr} { 69 | set address [client recv] 70 | set empty [client recv] 71 | set ready [client recv] 72 | client sendmore $address 73 | client sendmore "" 74 | client send "END" 75 | } 76 | 77 | client close 78 | context term 79 | } 80 | driver { 81 | puts "Start main, output redirected to main.log" 82 | exec $tclsh rtmama.tcl main $NBR_WORKERS > main.log 2>@1 & 83 | 84 | after 1000 85 | 86 | for {set i 0} {$i < $NBR_WORKERS} {incr i} { 87 | puts "Start worker $i, output redirected to worker$i.log" 88 | exec $tclsh rtmama.tcl worker $NBR_WORKERS > worker$i.log 2>@1 & 89 | } 90 | } 91 | } 92 | -------------------------------------------------------------------------------- /examples/rtpapa.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Custom routing Router to Papa (ROUTER to REP) 3 | # 4 | 5 | package require zmq 6 | 7 | # We will do this all in one thread to emphasize the sequence 8 | # of events… 9 | 10 | zmq context context 11 | 12 | zmq socket client context ROUTER 13 | client bind "ipc://routing.ipc" 14 | 15 | zmq socket worker context REP 16 | worker setsockopt IDENTITY "A" 17 | worker connect "ipc://routing.ipc" 18 | 19 | # Wait for the worker to connect so that when we send a message 20 | # with routing envelope, it will actually match the worker… 21 | after 1000 22 | 23 | # Send papa address, address stack, empty part, and request 24 | client sendmore "A" 25 | client sendmore "address 3" 26 | client sendmore "address 2" 27 | client sendmore "address 1" 28 | client sendmore "" 29 | client send "This is the workload" 30 | 31 | # Worker should get just the workload 32 | puts "--------------------------------------------------" 33 | puts [join [worker dump] \n] 34 | 35 | # We don't play with envelopes in the worker 36 | worker send "This is the reply" 37 | 38 | # Now dump what we got off the ROUTER socket… 39 | puts "--------------------------------------------------" 40 | puts [join [client dump] \n] 41 | 42 | client close 43 | worker close 44 | context term 45 | 46 | -------------------------------------------------------------------------------- /examples/spqueue.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Simple Pirate queue 3 | # This is identical to the LRU pattern, with no reliability mechanisms 4 | # at all. It depends on the client for recovery. Runs forever. 5 | # 6 | 7 | package require zmq 8 | 9 | set LRU_READY "READY" ;# Signals worker is ready 10 | 11 | # Prepare our context and sockets 12 | zmq context context 13 | zmq socket frontend context ROUTER 14 | zmq socket backend context ROUTER 15 | frontend bind "tcp://*:5555" ;# For clients 16 | backend bind "tcp://*:5556" ;# For workers 17 | 18 | # Queue of available workers 19 | set workers {} 20 | 21 | while {1} { 22 | if {[llength $workers]} { 23 | set poll_set [list [list backend [list POLLIN]] [list frontend [list POLLIN]]] 24 | } else { 25 | set poll_set [list [list backend [list POLLIN]]] 26 | } 27 | set rpoll_set [zmq poll $poll_set -1] 28 | foreach rpoll $rpoll_set { 29 | switch [lindex $rpoll 0] { 30 | backend { 31 | # Use worker address for LRU routing 32 | set msg [zmsg recv backend] 33 | set address [zmsg unwrap msg] 34 | lappend workers $address 35 | 36 | # Forward message to client if it's not a READY 37 | if {[lindex $msg 0] ne $LRU_READY} { 38 | zmsg send frontend $msg 39 | } 40 | } 41 | frontend { 42 | # Get client request, route to first available worker 43 | set msg [zmsg recv frontend] 44 | set workers [lassign $workers worker] 45 | set msg [zmsg wrap $msg $worker] 46 | zmsg send backend $msg 47 | } 48 | } 49 | } 50 | } 51 | 52 | frontend close 53 | backend close 54 | context term 55 | -------------------------------------------------------------------------------- /examples/spworker.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Simple Pirate worker 3 | # Connects REQ socket to tcp://*:5556 4 | # Implements worker part of LRU queueing 5 | # 6 | 7 | package require zmq 8 | 9 | set LRU_READY "READY" ;# Signals worker is ready 10 | expr {srand([pid])} 11 | 12 | zmq context context 13 | zmq socket worker context REQ 14 | 15 | # Set random identity to make tracing easier 16 | set identity [format "%04X-%04X" [expr {int(rand()*0x10000)}] [expr {int(rand()*0x10000)}]] 17 | worker setsockopt IDENTITY $identity 18 | worker connect "tcp://localhost:5556" 19 | 20 | # Tell broker we're ready for work 21 | puts "I: ($identity) worker ready" 22 | worker send $LRU_READY 23 | 24 | set cycles 0 25 | while {1} { 26 | set msg [zmsg recv worker] 27 | 28 | # Simulate various problems, after a few cycles 29 | incr cycles 30 | if {$cycles > 3 && [expr {int(rand()*5)}] == 0} { 31 | puts "I: ($identity) simulating a crash" 32 | break 33 | } elseif {$cycles > 3 && [expr {int(rand()*5)}] == 0} { 34 | puts "I: ($identity) simulating CPU overload" 35 | after 3000 36 | } 37 | puts "I: ($identity) normal reply" 38 | after 1000 ;# Do some heavy work 39 | zmsg send worker $msg 40 | } 41 | 42 | worker close 43 | context term 44 | 45 | -------------------------------------------------------------------------------- /examples/suisnail.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Suicidal Snail 3 | # 4 | 5 | package require zmq 6 | 7 | if {[llength $argv] == 0} { 8 | set argv [list driver] 9 | } elseif {[llength $argv] != 1} { 10 | puts "Usage: suisnail.tcl " 11 | exit 1 12 | } 13 | 14 | lassign $argv what 15 | set MAX_ALLOWED_DELAY 1000 ;# msecs 16 | 17 | set tclsh [info nameofexecutable] 18 | expr {srand([pid])} 19 | 20 | switch -exact -- $what { 21 | sub { 22 | # This is our subscriber 23 | # It connects to the publisher and subscribes to everything. It 24 | # sleeps for a short time between messages to simulate doing too 25 | # much work. If a message is more than 1 second late, it croaks. 26 | zmq context context 27 | zmq socket subpipe context PAIR 28 | subpipe connect "ipc://subpipe.ipc" 29 | # Subscribe to everything 30 | zmq socket subscriber context SUB 31 | subscriber setsockopt SUBSCRIBE "" 32 | subscriber connect "tcp://localhost:5556" 33 | 34 | # Get and process messages 35 | while {1} { 36 | set string [subscriber recv] 37 | puts "$string (delay = [expr {[clock milliseconds] - $string}])" 38 | 39 | if {[clock milliseconds] - $string > $::MAX_ALLOWED_DELAY} { 40 | puts stderr "E: subscriber cannot keep up, aborting" 41 | break 42 | } 43 | 44 | after [expr {1+int(rand()*2)}] 45 | } 46 | 47 | subpipe send "gone and died" 48 | 49 | subscriber close 50 | subpipe close 51 | context term 52 | } 53 | pub { 54 | # This is our server task 55 | # It publishes a time-stamped message to its pub socket every 1ms. 56 | zmq context context 57 | zmq socket pubpipe context PAIR 58 | pubpipe connect "ipc://pubpipe.ipc" 59 | 60 | # Prepare publisher 61 | zmq socket publisher context PUB 62 | publisher bind "tcp://*:5556" 63 | 64 | while {1} { 65 | # Send current clock (msecs) to subscribers 66 | publisher send [clock milliseconds] 67 | 68 | if {"POLLIN" in [pubpipe getsockopt EVENTS]} { 69 | break 70 | } 71 | 72 | after 1 ;# 1msec wait 73 | } 74 | 75 | publisher close 76 | pubpipe close 77 | context term 78 | } 79 | driver { 80 | zmq context context 81 | zmq socket pubpipe context PAIR 82 | pubpipe bind "ipc://pubpipe.ipc" 83 | zmq socket subpipe context PAIR 84 | subpipe bind "ipc://subpipe.ipc" 85 | puts "Start publisher, output redirected to publisher.log" 86 | exec $tclsh suisnail.tcl pub > publisher.log 2>@1 & 87 | puts "Start subscriber, output redirected to subscriber.log" 88 | exec $tclsh suisnail.tcl sub > subscriber.log 2>@1 & 89 | subpipe recv 90 | pubpipe send "break" 91 | after 100 92 | pubpipe close 93 | subpipe close 94 | context term 95 | } 96 | } 97 | -------------------------------------------------------------------------------- /examples/syncpub.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Synchronized publisher 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # We wait for 10 subscribers 10 | set SUBSCRIBERS_EXPECTED 10 11 | 12 | # Socket to talk to clients 13 | zmq socket publisher context PUB 14 | publisher bind "tcp://*:5561" 15 | 16 | # Socket to receive signals 17 | zmq socket syncservice context REP 18 | syncservice bind "tcp://*:5562" 19 | 20 | # Get synchronization from subscribers 21 | puts "Waiting for subscribers" 22 | set subscribers 0 23 | while {$subscribers < $SUBSCRIBERS_EXPECTED} { 24 | # - wait for synchronization request 25 | syncservice recv 26 | # - send synchronization reply 27 | syncservice send "" 28 | incr subscribers 29 | } 30 | 31 | # Now broadcast exactly 1M updates followed by END 32 | puts "Broadcasting messages" 33 | for {set update_nbr 0} {$update_nbr < 1000000} {incr update_nbr} { 34 | publisher send "Rhubarb" 35 | } 36 | 37 | publisher send "END" 38 | 39 | publisher close 40 | syncservice close 41 | context term 42 | -------------------------------------------------------------------------------- /examples/syncsub.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Synchronized subscriber 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # First, connect our subscriber socket 10 | zmq socket subscriber context SUB 11 | subscriber connect "tcp://localhost:5561" 12 | subscriber setsockopt SUBSCRIBE "" 13 | 14 | # 0MQ is so fast, we need to wait a while… 15 | after 1000 16 | 17 | # Second, synchronize with publisher 18 | zmq socket syncclient context REQ 19 | syncclient connect "tcp://localhost:5562" 20 | 21 | # - send a synchronization request 22 | syncclient send "" 23 | 24 | # - wait for synchronization reply 25 | syncclient recv 26 | 27 | # Third, get our updates and report how many we got 28 | set update_nbr 0 29 | while {1} { 30 | set string [subscriber recv] 31 | if {$string eq "END"} { 32 | break; 33 | } 34 | incr update_nbr 35 | } 36 | puts "Received $update_nbr updates" 37 | 38 | subscriber close 39 | syncclient close 40 | context term 41 | -------------------------------------------------------------------------------- /examples/syncsub_callback.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Synchronized subscriber 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # First, connect our subscriber socket 10 | zmq socket subscriber context SUB 11 | subscriber connect "tcp://localhost:5561" 12 | subscriber setsockopt SUBSCRIBE "" 13 | 14 | # 0MQ is so fast, we need to wait a while… 15 | after 1000 16 | 17 | # Second, synchronize with publisher 18 | zmq socket syncclient context REQ 19 | syncclient connect "tcp://localhost:5562" 20 | 21 | # - send a synchronization request 22 | syncclient send "" 23 | 24 | # - wait for synchronization reply 25 | syncclient recv 26 | 27 | # Third, get our updates and report how many we got 28 | proc work {s} { 29 | global update_nbr done 30 | set string [$s recv] 31 | if {$string eq "END"} { 32 | set done 1 33 | return 34 | } 35 | incr update_nbr 36 | } 37 | 38 | set update_nbr 0 39 | set done 0 40 | 41 | subscriber readable [list work subscriber] 42 | 43 | vwait done 44 | 45 | puts "Received $update_nbr updates" 46 | 47 | subscriber close 48 | syncclient close 49 | context term 50 | -------------------------------------------------------------------------------- /examples/tasksink.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task sink 3 | # Binds PULL socket to tcp://localhost:5558 4 | # Collects results from workers via that socket 5 | # 6 | 7 | package require zmq 8 | 9 | # Prepare our context and socket 10 | zmq context context 11 | zmq socket receiver context PULL 12 | receiver bind "tcp://*:5558" 13 | 14 | # Wait for start of batch 15 | set string [receiver recv] 16 | 17 | # Start our clock now 18 | set start_time [clock milliseconds] 19 | 20 | # Process 100 confirmations 21 | for {set task_nbr 0} {$task_nbr < 100} {incr task_nbr} { 22 | set string [receiver recv] 23 | if {($task_nbr/10)*10 == $task_nbr} { 24 | puts -nonewline ":" 25 | } else { 26 | puts -nonewline "." 27 | } 28 | flush stdout 29 | } 30 | # Calculate and report duration of batch 31 | puts "Total elapsed time: [expr {[clock milliseconds]-$start_time}]msec" 32 | 33 | receiver close 34 | context term 35 | -------------------------------------------------------------------------------- /examples/tasksink2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task sink - design 2 3 | # Adds pub-sub flow to send kill signal to workers 4 | # 5 | 6 | package require zmq 7 | 8 | zmq context context 9 | 10 | # Socket to receive messages on 11 | zmq socket receiver context PULL 12 | receiver bind "tcp://*:5558" 13 | 14 | # Socket to worker control 15 | zmq socket controller context PUB 16 | controller bind "tcp://*:5559" 17 | 18 | # Wait for start of batch 19 | set string [receiver recv] 20 | 21 | # Start our clock now 22 | set start_time [clock milliseconds] 23 | 24 | # Process 100 confirmations 25 | for {set task_nbr 0} {$task_nbr < 100} {incr task_nbr} { 26 | set string [receiver recv] 27 | if {($task_nbr/10)*10 == $task_nbr} { 28 | puts -nonewline ":" 29 | } else { 30 | puts -nonewline "." 31 | } 32 | flush stdout 33 | } 34 | # Calculate and report duration of batch 35 | puts "Total elapsed time: [expr {[clock milliseconds]-$start_time}]msec" 36 | 37 | controller send "KILL" 38 | 39 | receiver close 40 | controller close 41 | context term 42 | -------------------------------------------------------------------------------- /examples/taskvent.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task ventilator 3 | # Binds PUSH socket to tcp://localhost:5557 4 | # Sends batch of tasks to workers via that socket 5 | # 6 | 7 | package require zmq 8 | 9 | zmq context context 10 | 11 | zmq socket sender context PUSH 12 | sender bind "tcp://*:5557" 13 | 14 | zmq socket sink context PUSH 15 | sink connect "tcp://localhost:5558" 16 | 17 | puts -nonewline "Press Enter when the workers are ready: " 18 | flush stdout 19 | gets stdin c 20 | puts "Sending tasks to workers..." 21 | 22 | # The first message is "0" and signals start of batch 23 | sink send "0" 24 | 25 | # Initialize random number generator 26 | expr {srand([clock seconds])} 27 | 28 | # Send 100 tasks 29 | set total_msec 0 30 | for {set task_nbr 0} {$task_nbr < 100} {incr task_nbr} { 31 | set workload [expr {int(rand()*100)+1}] 32 | puts -nonewline "$workload." 33 | incr total_msec $workload 34 | sender send $workload 35 | } 36 | puts "Total expected cost: $total_msec msec" 37 | after 1000 38 | 39 | sink close 40 | sender close 41 | context term 42 | -------------------------------------------------------------------------------- /examples/taskvent_callback.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task ventilator 3 | # Binds PUSH socket to tcp://localhost:5557 4 | # Sends batch of tasks to workers via that socket 5 | # 6 | 7 | package require zmq 8 | 9 | zmq context context 10 | 11 | zmq socket sender context PUSH 12 | sender bind "tcp://*:5557" 13 | 14 | zmq socket sink context PUSH 15 | sink connect "tcp://localhost:5558" 16 | 17 | puts -nonewline "Press Enter when the workers are ready: " 18 | flush stdout 19 | gets stdin c 20 | puts "Sending tasks to workers..." 21 | 22 | # The first message is "0" and signals start of batch 23 | sink send "0" 24 | 25 | # Initialize random number generator 26 | expr {srand([clock seconds])} 27 | set task_nbr 0 28 | set total_msec 0 29 | set done 0 30 | 31 | # Worker proc 32 | proc send_task {s} { 33 | global task_nbr total_msec done 34 | set workload [expr {int(rand()*100)+1}] 35 | puts -nonewline "$workload." 36 | incr total_msec $workload 37 | $s send $workload 38 | incr task_nbr 39 | } 40 | 41 | # Send 100 tasks 42 | 43 | sender writable [list send_task ::sender] 44 | 45 | while {$task_nbr < 100} { 46 | vwait task_nbr 47 | } 48 | 49 | puts "Total expected cost: $total_msec msec" 50 | after 1000 51 | sink close 52 | sender close 53 | context term 54 | -------------------------------------------------------------------------------- /examples/taskwork.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task worker 3 | # Connects PULL socket to tcp://localhost:5557 4 | # Collects workloads from ventilator via that socket 5 | # Connects PUSH socket to tcp://localhost:5558 6 | # Sends results to sink via that socket 7 | # 8 | 9 | package require zmq 10 | 11 | zmq context context 12 | 13 | # Socket to receive messages on 14 | zmq socket receiver context PULL 15 | receiver connect "tcp://localhost:5557" 16 | 17 | # Socket to send messages to 18 | zmq socket sender context PUSH 19 | sender connect "tcp://localhost:5558" 20 | 21 | # Process tasks forever 22 | while {1} { 23 | set string [receiver recv] 24 | # Simple progress indicator for the viewer 25 | puts -nonewline "$string." 26 | flush stdout 27 | # Do the work 28 | after $string 29 | # Send result to sink 30 | sender send "$string" 31 | } 32 | 33 | receiver close 34 | sender close 35 | context term 36 | -------------------------------------------------------------------------------- /examples/taskwork2.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task worker - design 2 3 | # Adds pub-sub flow to receive and respond to kill signal 4 | # 5 | 6 | package require zmq 7 | 8 | zmq context context 9 | 10 | # Socket to receive messages on 11 | zmq socket receiver context PULL 12 | receiver connect "tcp://localhost:5557" 13 | 14 | # Socket to send messages to 15 | zmq socket sender context PUSH 16 | sender connect "tcp://localhost:5558" 17 | 18 | # Socket for control input 19 | zmq socket controller context SUB 20 | controller connect "tcp://localhost:5559" 21 | controller setsockopt SUBSCRIBE "" 22 | 23 | # Process messages from receiver and controller 24 | set poll_set [list [list receiver [list POLLIN]] [list controller [list POLLIN]]] 25 | 26 | # Process tasks forever 27 | set poll 1 28 | while {$poll} { 29 | set rpoll_set [zmq poll $poll_set -1] 30 | foreach rpoll $rpoll_set { 31 | switch [lindex $rpoll 0] { 32 | receiver { 33 | if {"POLLIN" in [lindex $rpoll 1]} { 34 | set string [receiver recv] 35 | # Simple progress indicator for the viewer 36 | puts -nonewline "$string." 37 | flush stdout 38 | # Do the work 39 | after $string 40 | # Send result to sink 41 | sender send "$string" 42 | } 43 | } 44 | controller { 45 | if {"POLLIN" in [lindex $rpoll 1]} { 46 | puts "" 47 | set poll 0 48 | } 49 | } 50 | } 51 | } 52 | } 53 | 54 | receiver close 55 | sender close 56 | controller close 57 | context term 58 | -------------------------------------------------------------------------------- /examples/taskwork2_callback.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Task worker - design 2 3 | # Adds pub-sub flow to receive and respond to kill signal 4 | # 5 | 6 | package require zmq 7 | 8 | zmq context context 9 | 10 | # Socket to receive messages on 11 | zmq socket receiver context PULL 12 | receiver connect "tcp://localhost:5557" 13 | 14 | # Socket to send messages to 15 | zmq socket sender context PUSH 16 | sender connect "tcp://localhost:5558" 17 | 18 | # Socket for control input 19 | zmq socket controller context SUB 20 | controller connect "tcp://localhost:5559" 21 | controller setsockopt SUBSCRIBE "" 22 | 23 | # Functions to process messages 24 | proc work {s} { 25 | set string [$s recv] 26 | # Simple progress indicator for the viewer 27 | puts -nonewline "$string." 28 | flush stdout 29 | # Do the work 30 | after $string 31 | # Send result to sink 32 | ::sender send "$string" 33 | } 34 | 35 | proc done {s} { 36 | puts "" 37 | ::receiver close 38 | ::sender close 39 | ::controller close 40 | ::context term 41 | exit 42 | } 43 | 44 | proc do_something {} { 45 | puts [clock format [clock seconds]] 46 | after 1000 do_something 47 | } 48 | 49 | # Register callbacks 50 | receiver readable [list work ::receiver] 51 | controller readable [list done ::controller] 52 | 53 | do_something 54 | 55 | vwait forever 56 | 57 | -------------------------------------------------------------------------------- /examples/ticlient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Titanic client example 3 | # Implements client side of http://rfc.zeromq.org/spec:9 4 | 5 | lappend auto_path . 6 | package require MDClient 1.0 7 | 8 | set verbose 0 9 | foreach {k v} $argv { 10 | if {$k eq "-v"} { set verbose 1 } 11 | } 12 | 13 | # Calls a TSP service 14 | # Returns reponse if successful (status code 200 OK), else NULL 15 | # 16 | proc s_service_call {session service request} { 17 | set reply [$session send $service $request] 18 | if {[llength $reply]} { 19 | set status [zmsg pop reply] 20 | switch -exact -- $status { 21 | 200 { 22 | return $reply 23 | } 24 | 400 { 25 | puts "E: client fatal error, aborting" 26 | exit 1 27 | } 28 | 500 { 29 | puts "E: server fatal error, aborting" 30 | exit 1 31 | } 32 | } 33 | } else { 34 | puts "I: Interrupted or failed" 35 | exit 0 ;# Interrupted or failed 36 | } 37 | 38 | return {} ;# Didn't succeed, don't care why not 39 | } 40 | 41 | set session [MDClient new "tcp://localhost:5555" $verbose] 42 | 43 | # 1. Send 'echo' request to Titanic 44 | set request [list "echo" "Hello world"] 45 | set reply [s_service_call $session "titanic.request" $request] 46 | 47 | set uuid "" 48 | if {[llength $reply]} { 49 | set uuid [zmsg pop reply] 50 | puts "I: request UUID [zmsg dump [list $uuid]]" 51 | } 52 | 53 | # 2. Wait until we get a reply 54 | while {1} { 55 | after 100 56 | set request [list $uuid] 57 | set reply [s_service_call $session "titanic.reply" $request] 58 | 59 | if {[llength $reply]} { 60 | set reply_string [lindex $reply end] 61 | puts "Reply: $reply_string" 62 | 63 | # 3. Close request 64 | s_service_call $session "titanic.close" $request 65 | break 66 | } else { 67 | puts "I: no reply yet, trying again..." 68 | after 5000 69 | } 70 | } 71 | 72 | $session destroy 73 | -------------------------------------------------------------------------------- /examples/titanic.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Titanic service 3 | # 4 | # Implements server side of http://rfc.zeromq.org/spec:9 5 | 6 | lappend auto_path . 7 | package require MDClient 1.0 8 | package require MDWorker 1.0 9 | package require uuid 10 | 11 | if {[llength $argv] == 0} { 12 | set argv [list driver] 13 | } elseif {[llength $argv] != 1} { 14 | puts "Usage: titanic.tcl " 15 | exit 1 16 | } 17 | 18 | set tclsh [info nameofexecutable] 19 | expr {srand([pid])} 20 | set verbose 0 21 | 22 | lassign $argv what 23 | 24 | set TITANIC_DIR ".titanic" 25 | 26 | # Return a new UUID as a printable character string 27 | proc s_generate_uuid {} { 28 | return [uuid::uuid generate] 29 | } 30 | 31 | # Returns freshly allocated request filename for given UUID 32 | proc s_request_filename {uuid} { 33 | return [file join $::TITANIC_DIR $uuid.req] 34 | } 35 | 36 | # Returns freshly allocated reply filename for given UUID 37 | proc s_reply_filename {uuid} { 38 | return [file join $::TITANIC_DIR $uuid.rep] 39 | } 40 | 41 | # Titanic request service 42 | proc titanic_request {} { 43 | 44 | zmq context context 45 | set pipe [zmq socket pipe context PAIR] 46 | pipe connect "ipc://titanicpipe.ipc" 47 | 48 | set worker [MDWorker new "tcp://localhost:5555" "titanic.request" $::verbose] 49 | set reply {} 50 | 51 | while {1} { 52 | # Send reply if it's not null 53 | # And then get next request from broker 54 | set request [$worker recv $reply] 55 | if {[llength $request] == 0} { 56 | break ;# Interrupted, exit 57 | } 58 | 59 | # Ensure message directory exists 60 | file mkdir $::TITANIC_DIR 61 | 62 | # Generate UUID and save message to disk 63 | set uuid [s_generate_uuid] 64 | set filename [s_request_filename $uuid] 65 | set file [open $filename "w"] 66 | puts -nonewline $file [join $request \n] 67 | close $file 68 | 69 | # Send UUID through to message queue 70 | set reply [list] 71 | set reply [zmsg add $reply $uuid] 72 | zmsg send $pipe $reply 73 | 74 | # Now send UUID back to client 75 | # Done by the mdwrk_recv() at the top of the loop 76 | set reply [list] 77 | puts "I: titanic.request to $uuid / $reply" 78 | set reply [zmsg add $reply "200"] 79 | puts "I: titanic.request to $uuid / $reply" 80 | set reply [zmsg add $reply $uuid] 81 | puts "I: titanic.request to $uuid / $reply" 82 | puts [join [zmsg dump $reply] \n] 83 | } 84 | $worker destroy 85 | } 86 | 87 | # Titanic reply service 88 | proc titanic_reply {} { 89 | set worker [MDWorker new "tcp://localhost:5555" "titanic.reply" $::verbose] 90 | set reply {} 91 | 92 | while {1} { 93 | set request [$worker recv $reply] 94 | if {[llength $request] == 0} { 95 | break 96 | } 97 | set uuid [zmsg pop request] 98 | set req_filename [s_request_filename $uuid] 99 | set rep_filename [s_reply_filename $uuid] 100 | if {[file exists $rep_filename]} { 101 | set file [open $rep_filename r] 102 | set reply [split [read $file] \n] 103 | set reply [zmsg push $reply "200"] 104 | puts "I: titanic.reply to $uuid" 105 | puts [join [zmsg dump $reply] \n] 106 | close $file 107 | } else { 108 | if {[file exists $req_filename]} { 109 | set reply "300" 110 | } else { 111 | set reply "400" 112 | } 113 | } 114 | } 115 | $worker destroy 116 | return 0 117 | } 118 | 119 | # Titanic close service 120 | proc titanic_close {} { 121 | set worker [MDWorker new "tcp://localhost:5555" "titanic.close" $::verbose] 122 | set reply "" 123 | 124 | while {1} { 125 | set request [$worker recv $reply] 126 | if {[llength $request] == 0} { 127 | break 128 | } 129 | set uuid [zmsg pop request] 130 | set req_filename [s_request_filename $uuid] 131 | set rep_filename [s_reply_filename $uuid] 132 | file delete -force $req_filename 133 | file delete -force $rep_filename 134 | 135 | set reply "200" 136 | } 137 | $worker destroy 138 | return 0 139 | } 140 | 141 | # Attempt to process a single request, return 1 if successful 142 | proc s_service_success {uuid} { 143 | # Load request message, service will be first frame 144 | set filename [s_request_filename $uuid] 145 | # If the client already closed request, treat as successful 146 | if {![file exists $filename]} { 147 | return 1 148 | } 149 | set file [open $filename "r"] 150 | 151 | set request [split [read $file] \n] 152 | set service [zmsg pop request] 153 | 154 | # Create MDP client session with short timeout 155 | set client [MDClient new "tcp://localhost:5555" $::verbose] 156 | $client set_timeout 1000 157 | $client set_retries 1 158 | 159 | # Use MMI protocol to check if service is available 160 | set mmi_request {} 161 | set mmi_request [zmsg add $mmi_request $service] 162 | set mmi_reply [$client send "mmi.service" $mmi_request] 163 | 164 | if {[lindex $mmi_reply 0] eq "200"} { 165 | set reply [$client send $service $request] 166 | if {[llength $reply]} { 167 | set filename [s_reply_filename $uuid] 168 | set file [open $filename "w"] 169 | puts -nonewline $file [join $reply \n] 170 | close $file 171 | return 1 172 | } 173 | } 174 | 175 | $client destroy 176 | return 0 177 | } 178 | 179 | switch -exact -- $what { 180 | request { titanic_request } 181 | reply { titanic_reply } 182 | close { titanic_close } 183 | driver { 184 | exec $tclsh titanic.tcl request > request.log 2>@1 & 185 | exec $tclsh titanic.tcl reply > reply.log 2>@1 & 186 | exec $tclsh titanic.tcl close > close.log 2>@1 & 187 | 188 | after 1000 ;# Wait for other parts to start 189 | 190 | zmq context context 191 | zmq socket request_pipe context PAIR 192 | request_pipe bind "ipc://titanicpipe.ipc" 193 | set queuefnm [file join $::TITANIC_DIR queue] 194 | 195 | # Main dispatcher loop 196 | while {1} { 197 | # We'll dispatch once per second, if there's no activity 198 | set poll_set [list [list request_pipe [list POLLIN]]] 199 | set rpoll_set [zmq poll $poll_set 1000] 200 | if {[llength $rpoll_set] && "POLLIN" in [lindex $rpoll_set 0 1]} { 201 | # Ensure message directory exists 202 | file mkdir $::TITANIC_DIR 203 | 204 | # Append UUID to queue, prefixed with '-' for pending 205 | set msg [zmsg recv request_pipe] 206 | if {[llength $msg] == 0} { 207 | break 208 | } 209 | set file [open $queuefnm "a"] 210 | set uuid [zmsg pop msg] 211 | puts $file "-$uuid" 212 | close $file 213 | } 214 | # Brute-force dispatcher 215 | if {[file exists $queuefnm]} { 216 | set file [open $queuefnm "r"] 217 | set queue_list [split [read $file] \n] 218 | close $file 219 | for {set i 0} {$i < [llength $queue_list]} {incr i} { 220 | set entry [lindex $queue_list $i] 221 | if {[string match "-*" $entry]} { 222 | set entry [string range $entry 1 end] 223 | puts "I: processing request $entry" 224 | if {[s_service_success $entry]} { 225 | lset queue_list $i "+$entry" 226 | } 227 | } 228 | } 229 | set file [open $queuefnm "w"] 230 | puts -nonewline $file [join $queue_list \n] 231 | close $file 232 | } 233 | } 234 | 235 | return 0 236 | } 237 | } 238 | -------------------------------------------------------------------------------- /examples/tripping.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Round-trip demonstrator 3 | # 4 | 5 | package require zmq 6 | 7 | if {[llength $argv] == 0} { 8 | set argv [list driver] 9 | } elseif {[llength $argv] != 1} { 10 | puts "Usage: tripping.tcl " 11 | exit 1 12 | } 13 | 14 | set tclsh [info nameofexecutable] 15 | expr {srand([pid])} 16 | 17 | lassign $argv what 18 | 19 | switch -exact -- $what { 20 | client { 21 | zmq context context 22 | zmq socket client context DEALER 23 | client setsockopt IDENTITY "C" 24 | client connect "tcp://localhost:5555" 25 | 26 | puts "Setting up test..." 27 | after 1000 28 | 29 | puts "Synchronous round-trip test..." 30 | set start [clock milliseconds] 31 | for {set requests 0} {$requests < 10000} {incr requests} { 32 | client send "hello" 33 | client recv 34 | } 35 | puts "[expr {1000.0*10000/([clock milliseconds] - $start)}] calls/second" 36 | 37 | puts "Asynchronous round-trip test..." 38 | set start [clock milliseconds] 39 | for {set requests 0} {$requests < 10000} {incr requests} { 40 | client send "hello" 41 | } 42 | for {set requests 0} {$requests < 10000} {incr requests} { 43 | client recv 44 | } 45 | puts "[expr {1000.0*10000/([clock milliseconds] - $start)}] calls/second" 46 | 47 | puts "Callback round-trip test..." 48 | 49 | proc recv_client {} { 50 | client recv 51 | incr ::cnt 52 | if {$::cnt == 10000} { 53 | set ::done 1 54 | } 55 | } 56 | 57 | 58 | set start [clock milliseconds] 59 | client readable recv_client 60 | for {set requests 0} {$requests < 10000} {incr requests} { 61 | client send "hello" 62 | } 63 | vwait done 64 | puts "[expr {1000.0*10000/([clock milliseconds] - $start)}] calls/second" 65 | } 66 | worker { 67 | zmq context context 68 | zmq socket worker context DEALER 69 | worker setsockopt IDENTITY "W" 70 | worker connect "tcp://localhost:5556" 71 | 72 | while {1} { 73 | zmsg send worker [zmsg recv worker] 74 | } 75 | 76 | worker close 77 | context term 78 | } 79 | broker { 80 | zmq context context 81 | zmq socket frontend context ROUTER 82 | zmq socket backend context ROUTER 83 | frontend bind "tcp://*:5555" 84 | backend bind "tcp://*:5556" 85 | 86 | while {1} { 87 | set poll_set [list [list backend [list POLLIN]] [list frontend [list POLLIN]]] 88 | set rpoll_set [zmq poll $poll_set -1] 89 | foreach rpoll $rpoll_set { 90 | switch [lindex $rpoll 0] { 91 | backend { 92 | set msg [zmsg recv backend] 93 | set address [zmsg pop msg] 94 | set msg [zmsg push $msg "C"] 95 | zmsg send frontend $msg 96 | } 97 | frontend { 98 | set msg [zmsg recv frontend] 99 | set address [zmsg pop msg] 100 | set msg [zmsg push $msg "W"] 101 | zmsg send backend $msg 102 | } 103 | } 104 | } 105 | } 106 | 107 | frontend close 108 | backend close 109 | context term 110 | } 111 | driver { 112 | exec $tclsh tripping.tcl client > client.log 2>@1 & 113 | exec $tclsh tripping.tcl worker > worker.log 2>@1 & 114 | exec $tclsh tripping.tcl broker > broker.log 2>@1 & 115 | } 116 | } 117 | -------------------------------------------------------------------------------- /examples/version.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Report 0MQ version 3 | # 4 | 5 | package require zmq 6 | 7 | puts [zmq version] 8 | -------------------------------------------------------------------------------- /examples/wuasyncclient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Weather update client 3 | # Connects SUB socket to tcp:#localhost:5556 4 | # Collects weather updates and finds avg temp in zipcode 5 | # 6 | 7 | package require zmq 8 | 9 | # Socket to talk to server 10 | zmq context context 11 | zmq socket subscriber context SUB 12 | subscriber connect "tcp://localhost:5556" 13 | 14 | # Subscribe to zipcode, default is NYC, 10001 15 | if {[llength $argv]} { 16 | set filter [lindex $argv 0] 17 | } else { 18 | set filter "10001" 19 | } 20 | 21 | proc get_weather {} { 22 | global total_temp cnt done 23 | set data [subscriber recv] 24 | puts $data 25 | lassign $data zipcode temperature relhumidity 26 | incr total_temp $temperature 27 | incr cnt 28 | if {$cnt >= 10} { 29 | set done 1 30 | } 31 | } 32 | 33 | subscriber setsockopt SUBSCRIBE $filter 34 | set total_temp 0 35 | set cnt 0 36 | subscriber readable get_weather 37 | 38 | # Process updates 39 | vwait done 40 | 41 | puts "Averate temperatur for zipcode $filter was [expr {$total_temp/$cnt}]F" 42 | 43 | subscriber destroy 44 | context destroy 45 | -------------------------------------------------------------------------------- /examples/wuclient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Weather update client 3 | # Connects SUB socket to tcp:#localhost:5556 4 | # Collects weather updates and finds avg temp in zipcode 5 | # 6 | 7 | package require zmq 8 | 9 | # Socket to talk to server 10 | zmq context context 11 | zmq socket subscriber context SUB 12 | subscriber connect "tcp://localhost:5556" 13 | 14 | # Subscribe to zipcode, default is NYC, 10001 15 | if {[llength $argv]} { 16 | set filter [format {%05d} [lindex $argv 0]] 17 | } else { 18 | set filter "10001" 19 | } 20 | 21 | subscriber setsockopt SUBSCRIBE $filter 22 | 23 | # Process updates 24 | set total_temp 0 25 | for {set update_nbr 0} {$update_nbr < 5} {incr update_nbr} { 26 | zmq message msg 27 | subscriber recv_msg msg 28 | lassign [msg data] zipcode temperature relhumidity 29 | puts [msg data] 30 | msg close 31 | incr total_temp $temperature 32 | } 33 | 34 | puts "Averate temperatur for zipcode $filter was [expr {$total_temp/$update_nbr}]F" 35 | 36 | subscriber destroy 37 | context destroy 38 | -------------------------------------------------------------------------------- /examples/wuproxy.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Weather proxy device 3 | # 4 | 5 | package require zmq 6 | 7 | zmq context context 8 | 9 | # This is where the weather server sits 10 | zmq socket frontend context SUB 11 | frontend connect "tcp://localhost:5556" 12 | 13 | # This is our public endpoint for subscribers 14 | zmq socket backend context PUB 15 | backend bind "tcp://*:8100" 16 | 17 | # Subscribe on everything 18 | frontend setsockopt SUBSCRIBE "" 19 | 20 | # Shunt messages out to our own subscribers 21 | while {1} { 22 | while {1} { 23 | # Process all parts of the message 24 | zmq message msg 25 | frontend recv_msg msg 26 | set more [frontend getsockopt RCVMORE] 27 | backend send_msg msg [expr {$more?{SNDMORE}:{}}] 28 | msg close 29 | if {!$more} { 30 | break ;# Last message part 31 | } 32 | } 33 | } 34 | 35 | # We don't actually get here but if we did, we'd shut down neatly 36 | frontend close 37 | backend close 38 | context term 39 | -------------------------------------------------------------------------------- /examples/wuproxyclient.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Weather update client 3 | # Connects SUB socket to tcp:#localhost:5556 4 | # Collects weather updates and finds avg temp in zipcode 5 | # 6 | 7 | package require zmq 8 | 9 | # Socket to talk to server 10 | zmq context context 11 | zmq socket subscriber context SUB 12 | subscriber connect "tcp://*:8100" 13 | 14 | # Subscribe to zipcode, default is NYC, 10001 15 | if {[llength $argv]} { 16 | set filter [lindex $argv 0] 17 | } else { 18 | set filter "10001" 19 | } 20 | 21 | subscriber setsockopt SUBSCRIBE $filter 22 | 23 | # Process 100 updates 24 | set total_temp 0 25 | for {set update_nbr 0} {$update_nbr < 100} {incr update_nbr} { 26 | zmq message msg 27 | subscriber recv_msg msg 28 | lassign [msg data] zipcode temperature relhumidity 29 | puts [msg data] 30 | msg close 31 | incr total_temp $temperature 32 | } 33 | 34 | puts "Averate temperatur for zipcode $filter was [expr {$total_temp/$update_nbr}]F" 35 | 36 | subscriber close 37 | context term 38 | -------------------------------------------------------------------------------- /examples/wuserver.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Weather update server 3 | # Binds PUB socket to tcp:#*:5556 4 | # Publishes random weather updates 5 | # 6 | 7 | package require zmq 8 | 9 | # Prepare our context and publisher 10 | zmq context context 11 | 12 | zmq socket publisher context PUB 13 | publisher bind "tcp://*:5556" 14 | if {$::tcl_platform(platform) ne "windows"} { 15 | publisher bind "ipc://weather.ipc" 16 | } 17 | 18 | # Initialize random number generator 19 | expr {srand([clock seconds])} 20 | 21 | while {1} { 22 | # Get values that will fool the boss 23 | set zipcode [expr {int(rand()*100000)}] 24 | set temperature [expr {int(rand()*215)-80}] 25 | set relhumidity [expr {int(rand()*50)+50}] 26 | # Send message to all subscribers 27 | set data [format "%05d %d %d" $zipcode $temperature $relhumidity] 28 | if {$zipcode eq "10001"} { 29 | puts $data 30 | } 31 | zmq message msg -data $data 32 | publisher send_msg msg 33 | msg destroy 34 | update idletasks 35 | } 36 | 37 | publisher destroy 38 | context destroy 39 | -------------------------------------------------------------------------------- /examples/wuserver_monitored.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # Weather update server 3 | # Binds PUB socket to tcp:#*:5556 4 | # Publishes random weather updates 5 | # 6 | 7 | package require zmq 8 | 9 | # Log zipcode for debugging, default is NYC, 10001 10 | if {[llength $argv]} { 11 | set filter $argv 12 | } else { 13 | set filter {10001} 14 | } 15 | 16 | # Prepare our context and publisher 17 | set ctx [zmq context context] 18 | 19 | set pub [zmq socket publisher context PUB] 20 | 21 | publisher bind "tcp://*:5556" 22 | if {$::tcl_platform(platform) ne "windows"} { 23 | publisher bind "ipc://weather.ipc" 24 | } 25 | 26 | proc monitor_callback {args} { 27 | puts "Monitor: $args" 28 | } 29 | 30 | zmq monitor $ctx $pub monitor_callback 31 | 32 | # Initialize random number generator 33 | expr {srand([clock seconds])} 34 | 35 | while {1} { 36 | # Get values that will fool the boss 37 | set zipcode [expr {int(rand()*100000)}] 38 | set temperature [expr {int(rand()*215)-80}] 39 | set relhumidity [expr {int(rand()*50)+50}] 40 | # Send message to all subscribers 41 | set data [format "%05d %d %d" $zipcode $temperature $relhumidity] 42 | if {$zipcode in $filter} { 43 | puts $data 44 | } 45 | zmq message msg -data $data 46 | publisher send_msg msg 47 | msg destroy 48 | # Make sure the monitor callback can get called 49 | update idletasks 50 | } 51 | 52 | publisher destroy 53 | context destroy 54 | -------------------------------------------------------------------------------- /regression/cget.tcl: -------------------------------------------------------------------------------- 1 | package require http 2 | 3 | set tkn [http::geturl [lindex $argv 0]] 4 | if {[http::status $tkn] eq "ok"} { 5 | set f [open [lindex $argv 1] w] 6 | fconfigure $f -translation binary 7 | puts -nonewline $f [http::data $tkn] 8 | close $f 9 | } 10 | http::cleanup $tkn 11 | -------------------------------------------------------------------------------- /regression/look_for_failed_tests.tcl: -------------------------------------------------------------------------------- 1 | set fnm [lindex $argv 0] 2 | set f [open $fnm] 3 | set ll [split [read $f] \n] 4 | close $f 5 | 6 | set fails 0 7 | 8 | foreach l $ll { 9 | if {[regexp {^==== .* FAILED$} $l]} { 10 | puts "$l" 11 | incr fails 12 | } 13 | } 14 | 15 | exit [expr {$fails != 0}] 16 | -------------------------------------------------------------------------------- /regression/regression.csh: -------------------------------------------------------------------------------- 1 | #!/bin/csh -x 2 | 3 | if ($#argv == 1) then 4 | set TCLSH = `which tclsh` 5 | else if ($#argv == 2) then 6 | set TCLSH = $2 7 | else 8 | echo "Usage: regression.csh ??" 9 | exit 1 10 | endif 11 | 12 | set V = $1 13 | set failed = 0 14 | 15 | if ($V == "2.1") then 16 | $TCLSH cget.tcl http://download.zeromq.org/zeromq-2.1.11.tar.gz zeromq-2.1.11.tar.gz 17 | if ($status) then 18 | set failed = 1 19 | goto done 20 | endif 21 | tar -xzf zeromq-2.1.11.tar.gz 22 | if ($status) then 23 | set failed = 1 24 | goto done 25 | endif 26 | mv zeromq-2.1.11 libzmq$V 27 | if ($status) then 28 | set failed = 1 29 | goto done 30 | endif 31 | rm -f zeromq-2.1.11.tar.gz 32 | if ($status) then 33 | set failed = 1 34 | goto done 35 | endif 36 | else if ($V == "2.2") then 37 | git clone git://github.com/zeromq/zeromq2-x.git libzmq$V 38 | if ($status) then 39 | set failed = 1 40 | goto done 41 | endif 42 | else if ($V == "3.2") then 43 | $TCLSH cget.tcl http://download.zeromq.org/zeromq-3.2.3.tar.gz zeromq-3.2.3.tar.gz 44 | if ($status) then 45 | set failed = 1 46 | goto done 47 | endif 48 | tar -xzf zeromq-3.2.3.tar.gz 49 | if ($status) then 50 | set failed = 1 51 | goto done 52 | endif 53 | mv zeromq-3.2.3 libzmq$V 54 | if ($status) then 55 | set failed = 1 56 | goto done 57 | endif 58 | rm -f zeromq-3.2.3.tar.gz 59 | if ($status) then 60 | set failed = 1 61 | goto done 62 | endif 63 | else if ($V == "3.2.4") then 64 | $TCLSH cget.tcl http://download.zeromq.org/zeromq-3.2.4.tar.gz zeromq-3.2.4.tar.gz 65 | if ($status) then 66 | set failed = 1 67 | goto done 68 | endif 69 | tar -xzf zeromq-3.2.4.tar.gz 70 | if ($status) then 71 | set failed = 1 72 | goto done 73 | endif 74 | mv zeromq-3.2.4 libzmq$V 75 | if ($status) then 76 | set failed = 1 77 | goto done 78 | endif 79 | rm -f zeromq-3.2.4.tar.gz 80 | if ($status) then 81 | set failed = 1 82 | goto done 83 | endif 84 | else if ($V == "4.0.1") then 85 | $TCLSH cget.tcl http://download.zeromq.org/zeromq-4.0.1.tar.gz zeromq-4.0.1.tar.gz 86 | if ($status) then 87 | set failed = 1 88 | goto done 89 | endif 90 | tar -xzf zeromq-4.0.1.tar.gz 91 | if ($status) then 92 | set failed = 1 93 | goto done 94 | endif 95 | mv zeromq-4.0.1 libzmq$V 96 | if ($status) then 97 | set failed = 1 98 | goto done 99 | endif 100 | rm -f zeromq-4.0.1.tar.gz 101 | if ($status) then 102 | set failed = 1 103 | goto done 104 | endif 105 | else if ($V == "4.0") then 106 | git clone git://github.com/zeromq/libzmq.git libzmq$V 107 | if ($status) then 108 | set failed = 1 109 | goto done 110 | endif 111 | else 112 | echo "Unknown version '$V'" 113 | exit 1 114 | endif 115 | 116 | cd libzmq$V 117 | 118 | ./autogen.sh 119 | if ($status) then 120 | set failed = 1 121 | goto cddone 122 | endif 123 | 124 | setenv CXXFLAGS -fPIC 125 | setenv CFLAGS -fPIC 126 | ./configure --prefix=/tmp/libzmq$V 127 | if ($status) then 128 | set failed = 1 129 | goto cddone 130 | endif 131 | 132 | make 133 | if ($status) then 134 | set failed = 1 135 | goto cddone 136 | endif 137 | 138 | make install 139 | if ($status) then 140 | set failed = 1 141 | goto cddone 142 | endif 143 | 144 | cd .. 145 | 146 | 147 | 148 | git clone git://github.com/jdc8/tclzmq.git tclzmq$V 149 | if ($status) then 150 | set failed = 1 151 | goto done 152 | endif 153 | 154 | cd tclzmq$V 155 | 156 | if ($V != "4.0") then 157 | git checkout --track origin/$V 158 | if ($status) then 159 | set failed = 1 160 | goto cddone 161 | endif 162 | endif 163 | 164 | $TCLSH build.tcl install lib -zmq /tmp/libzmq$V -static 165 | if ($status) then 166 | set failed = 1 167 | goto cddone 168 | endif 169 | 170 | cd test 171 | $TCLSH all.tcl >& test.log 172 | if ($status) then 173 | set failed = 1 174 | goto cdcddone 175 | endif 176 | 177 | cat test.log 178 | 179 | $TCLSH ../regression/look_for_failed_tests.tcl test.log 180 | if ($status) then 181 | set failed = 1 182 | goto cdcddone 183 | endif 184 | 185 | cdcddone: 186 | cd .. 187 | 188 | cddone: 189 | cd .. 190 | 191 | done: 192 | rm -Rf libzmq$V /tmp/libzmq$V tclzmq$V /tmp/libzmq$V 193 | 194 | exit $failed 195 | -------------------------------------------------------------------------------- /regression/win32.bat: -------------------------------------------------------------------------------- 1 | set TCLSH=c:\Tcl32\bin\tclsh.exe 2 | 3 | git clone git://github.com/zeromq/libzmq.git libzmq31 4 | git clone git://github.com/jdc8/tclzmq.git 5 | cd tclzmq 6 | cd zmq_nMakefiles 7 | nmake ZMQDIR=..\..\libzmq31 all32 8 | cd .. 9 | %TCLSH% build.tcl install -zmq zmq_nMakefiles -static 10 | cd test 11 | %TCLSH% all.tcl 12 | cd .. 13 | cd .. 14 | rmdir /s /q libzmq31 15 | rmdir /s /q tclzmq 16 | -------------------------------------------------------------------------------- /regression/win64.bat: -------------------------------------------------------------------------------- 1 | set TCLSH=c:\Tcl\bin\tclsh.exe 2 | 3 | git clone git://github.com/zeromq/libzmq.git libzmq31 4 | git clone git://github.com/jdc8/tclzmq.git 5 | cd tclzmq 6 | cd zmq_nMakefiles 7 | nmake ZMQDIR=..\..\libzmq31 all64 8 | cd .. 9 | %TCLSH% build.tcl install -zmq zmq_nMakefiles -static 10 | cd test 11 | %TCLSH% all.tcl 12 | cd .. 13 | cd .. 14 | rmdir /s /q libzmq31 15 | rmdir /s /q tclzmq 16 | -------------------------------------------------------------------------------- /test/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the Tcl 4 | # tests. Execute it by invoking "source all.test" when running tcltest 5 | # in this directory. 6 | # 7 | # Copyright (c) 1998-1999 by Scriptics Corporation. 8 | # Copyright (c) 2000 by Ajuba Solutions 9 | # 10 | # See the file "license.terms" for information on usage and redistribution 11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | 13 | package require Tcl 8.5 14 | package require tcltest 2.2 15 | 16 | tcltest::configure {*}$argv -testdir [file dir [info script]] 17 | tcltest::runAllTests 18 | -------------------------------------------------------------------------------- /test/context.test: -------------------------------------------------------------------------------- 1 | package require tcltest 2 | set auto_path [list ../lib {*}$auto_path] 3 | package require -exact zmq 4.0.1 4 | 5 | tcltest::test context-2 {zmq context} -body { 6 | zmq context ctx -1 7 | } -returnCodes {error} -result {bad parameter "ctx": must be -io_threads} 8 | 9 | tcltest::test context-3.1 {zmq context} -body { 10 | zmq context ctx 11 | } -cleanup { 12 | ctx term 13 | } -returnCodes {ok} -result {::ctx} 14 | 15 | tcltest::test context-3.2 {zmq context} -body { 16 | zmq context ctx -io_threads qwerty 17 | } -returnCodes {error} -result {Wrong io_threads argument, expected integer} 18 | 19 | tcltest::test context-3.3 {zmq context} -body { 20 | zmq context ctx -io_threads -1 21 | } -returnCodes {error} -result {Invalid argument} 22 | 23 | tcltest::test context-3.4 {zmq context} -body { 24 | zmq context ctx -io_threads 1 25 | } -cleanup { 26 | ctx term 27 | } -returnCodes {ok} -result {::ctx} 28 | 29 | tcltest::test context-3.5 {zmq context} -body { 30 | set c [zmq context] 31 | string match "::zmq*" $c 32 | } -cleanup { 33 | $c term 34 | } -returnCodes {ok} -result {1} 35 | 36 | tcltest::test context-3.6 {zmq context} -body { 37 | set c [zmq context -io_threads qwerty] 38 | } -returnCodes {error} -result {Wrong io_threads argument, expected integer} 39 | 40 | tcltest::test context-3.7 {zmq context} -body { 41 | set c [zmq context -io_threads -1] 42 | } -returnCodes {error} -result {Invalid argument} 43 | 44 | tcltest::test context-3.8 {zmq context} -body { 45 | set c [zmq context -io_threads 1] 46 | string match "::zmq*" $c 47 | } -cleanup { 48 | $c term 49 | } -returnCodes {ok} -result {1} 50 | 51 | tcltest::test context-4 {zmq context} -setup { 52 | zmq context ctx 53 | } -body { 54 | ctx 55 | } -cleanup { 56 | ctx term 57 | } -returnCodes {error} -result {wrong # args: should be "ctx method ?argument ...?"} 58 | 59 | tcltest::test context-5 {zmq context} -setup { 60 | zmq context ctx 61 | } -body { 62 | ctx qwerty 63 | } -cleanup { 64 | ctx term 65 | } -returnCodes {error} -result {bad method "qwerty": must be cget, configure, destroy, get, set, or term} 66 | 67 | tcltest::test context-6 {zmq context} -setup { 68 | zmq context ctx 69 | } -body { 70 | ctx term 71 | } -returnCodes {ok} -result {} 72 | 73 | tcltest::test context-7 {zmq context} -setup { 74 | zmq context ctx 75 | } -body { 76 | zmq context ctx 77 | } -cleanup { 78 | ctx term 79 | } -returnCodes {error} -result {command "::ctx" already exists, unable to create object} 80 | 81 | tcltest::test context-8 {zmq context} -setup { 82 | zmq context ctx 83 | } -body { 84 | ctx set 85 | } -cleanup { 86 | ctx term 87 | } -returnCodes {error} -result {wrong # args: should be "ctx set name value"} 88 | 89 | tcltest::test context-9 {zmq context} -setup { 90 | zmq context ctx 91 | } -body { 92 | ctx set QWERTY AZERTY 93 | } -cleanup { 94 | ctx term 95 | } -returnCodes {error} -result {bad name "QWERTY": must be IO_THREADS or MAX_SOCKETS} 96 | 97 | tcltest::test context-10 {zmq context} -setup { 98 | zmq context ctx 99 | } -body { 100 | ctx set IO_THREADS AZERTY 101 | } -cleanup { 102 | ctx term 103 | } -returnCodes {error} -result {Wrong option value, expected integer} 104 | 105 | tcltest::test context-11 {zmq context} -setup { 106 | zmq context ctx 107 | } -body { 108 | ctx set IO_THREADS 1 109 | } -cleanup { 110 | ctx term 111 | } -returnCodes {ok} 112 | 113 | tcltest::test context-12 {zmq context} -setup { 114 | zmq context ctx 115 | } -body { 116 | ctx get 117 | } -cleanup { 118 | ctx term 119 | } -returnCodes {error} -result {wrong # args: should be "ctx get name"} 120 | 121 | tcltest::test context-12 {zmq context} -setup { 122 | zmq context ctx 123 | } -body { 124 | ctx cget 125 | } -cleanup { 126 | ctx term 127 | } -returnCodes {error} -result {wrong # args: should be "ctx cget name"} 128 | 129 | tcltest::test context-13.1 {zmq context} -setup { 130 | zmq context ctx 131 | } -body { 132 | ctx get QWERTY 133 | } -cleanup { 134 | ctx term 135 | } -returnCodes {error} -result {bad name "QWERTY": must be IO_THREADS or MAX_SOCKETS} 136 | 137 | tcltest::test context-13.1 {zmq context} -setup { 138 | zmq context ctx 139 | } -body { 140 | ctx cget QWERTY 141 | } -cleanup { 142 | ctx term 143 | } -returnCodes {error} -result {bad name "QWERTY": must be IO_THREADS or MAX_SOCKETS} 144 | 145 | tcltest::test context-13.2 {zmq context} -setup { 146 | zmq context ctx 147 | } -body { 148 | ctx configure QWERTY 149 | } -cleanup { 150 | ctx term 151 | } -returnCodes {error} -result {bad name "QWERTY": must be IO_THREADS or MAX_SOCKETS} 152 | 153 | tcltest::test context-14.1 {zmq context} -setup { 154 | zmq context ctx 155 | } -body { 156 | ctx get IO_THREADS 157 | } -cleanup { 158 | ctx term 159 | } -returnCodes {ok} -result {1} 160 | 161 | tcltest::test context-14.1 {zmq context} -setup { 162 | zmq context ctx 163 | } -body { 164 | ctx cget IO_THREADS 165 | } -cleanup { 166 | ctx term 167 | } -returnCodes {ok} -result {1} 168 | 169 | tcltest::test context-14.2 {zmq context} -setup { 170 | zmq context ctx 171 | } -body { 172 | ctx configure IO_THREADS 173 | } -cleanup { 174 | ctx term 175 | } -returnCodes {ok} -result {IO_THREADS 1} 176 | 177 | tcltest::test context-16.1 {zmq context} -setup { 178 | zmq context ctx 179 | } -body { 180 | ctx configure 181 | } -cleanup { 182 | ctx term 183 | } -returnCodes {ok} -result {{IO_THREADS 1} {MAX_SOCKETS 1024}} 184 | 185 | tcltest::test context-16.2 {zmq context} -setup { 186 | zmq context ctx 187 | } -body { 188 | ctx configure IO_THREADS 189 | } -cleanup { 190 | ctx term 191 | } -returnCodes {ok} -result {IO_THREADS 1} 192 | 193 | tcltest::test context-16.3 {zmq context} -setup { 194 | zmq context ctx 195 | ctx configure IO_THREADS 22 196 | } -body { 197 | ctx configure IO_THREADS 198 | } -cleanup { 199 | ctx term 200 | } -returnCodes {ok} -result {IO_THREADS 22} 201 | 202 | tcltest::test context-16.4 {zmq context} -setup { 203 | zmq context ctx 204 | } -body { 205 | ctx configure QWERTY 1 AZERTY 206 | } -cleanup { 207 | ctx term 208 | } -returnCodes {error} -result {wrong # args: should be "ctx configure ?name? ?value option value ...?"} 209 | 210 | tcltest::test context-16.5 {zmq context} -setup { 211 | zmq context ctx 212 | } -body { 213 | ctx configure IO_THREADS 22 MAX_SOCKETS 2 214 | ctx configure 215 | } -cleanup { 216 | ctx term 217 | } -returnCodes {ok} -result {{IO_THREADS 22} {MAX_SOCKETS 2}} 218 | 219 | 220 | # cleanup 221 | ::tcltest::cleanupTests 222 | return 223 | 224 | 225 | -------------------------------------------------------------------------------- /test/device.test: -------------------------------------------------------------------------------- 1 | package require tcltest 2 | set auto_path [list ../lib {*}$auto_path] 3 | package require -exact zmq 4.0.1 4 | 5 | tcltest::test device-1 {zmq device} -body { 6 | zmq device 7 | } -returnCodes {error} -result {wrong # args: should be "zmq device device_type insocket outsocket"} 8 | 9 | tcltest::test device-2 {zmq device} -setup { 10 | zmq context ctx 11 | } -body { 12 | zmq device a b c 13 | } -cleanup { 14 | ctx term 15 | } -returnCodes {error} -result {bad device "a": must be STREAMER, FORWARDER, or QUEUE} 16 | 17 | tcltest::test device-3 {zmq device} -setup { 18 | zmq context ctx 19 | } -body { 20 | zmq device STREAMER b c 21 | } -cleanup { 22 | ctx term 23 | } -returnCodes {error} -result {socket "b" does not exists} 24 | 25 | tcltest::test device-4 {zmq device} -setup { 26 | zmq context ctx 27 | zmq socket b ctx REQ 28 | } -body { 29 | zmq device FORWARDER b c 30 | } -cleanup { 31 | b close 32 | ctx term 33 | } -returnCodes {error} -result {socket "c" does not exists} 34 | 35 | tcltest::test device-5 {zmq device} -setup { 36 | zmq context ctx 37 | zmq socket b ctx REQ 38 | zmq socket c ctx REP 39 | } -body { 40 | # Can't do this test, call will not return 41 | # zmq device QUEUE b c 42 | } -cleanup { 43 | b close 44 | c close 45 | ctx term 46 | } -returnCodes {ok} 47 | 48 | # cleanup 49 | ::tcltest::cleanupTests 50 | return 51 | 52 | -------------------------------------------------------------------------------- /test/poll.test: -------------------------------------------------------------------------------- 1 | package require tcltest 2 | set auto_path [list ../lib {*}$auto_path] 3 | package require -exact zmq 4.0.1 4 | 5 | tcltest::test poll-1 {zmq poll} -body { 6 | zmq poll 7 | } -returnCodes {error} -result {wrong # args: should be "zmq poll socket_list timeout ?timeout_unit?"} 8 | 9 | tcltest::test poll-2.1 {zmq poll} -body { 10 | zmq poll {} brol 11 | } -returnCodes {error} -result {Wrong timeout argument, expected integer} 12 | 13 | tcltest::test poll-2.2 {zmq poll} -body { 14 | zmq poll {} 1 qwerty 15 | } -returnCodes {error} -result {bad timeout_unit "qwerty": must be s or ms} 16 | 17 | tcltest::test poll-2.3 {zmq poll} -body { 18 | zmq poll {} 1 ms 19 | } -returnCodes {ok} 20 | 21 | tcltest::test poll-3 {zmq poll} -body { 22 | zmq poll {} 0 23 | } -returnCodes {ok} 24 | 25 | tcltest::test poll-4 {zmq poll} -body { 26 | zmq poll {a b} 0 27 | } -returnCodes {error} -result {socket not specified as list of } 28 | 29 | tcltest::test poll-5 {zmq poll} -body { 30 | zmq poll {{a f} {b f}} 0 31 | } -returnCodes {error} -result {socket "a" does not exists} 32 | 33 | tcltest::test poll-6 {zmq poll} -setup { 34 | zmq context ctx 35 | zmq socket a ctx REP 36 | } -body { 37 | zmq poll {{a f} {b f}} 0 38 | } -cleanup { 39 | a close 40 | ctx term 41 | } -returnCodes {error} -result {bad event_flag "f": must be POLLIN, POLLOUT, or POLLERR} 42 | 43 | tcltest::test poll-7 {zmq poll} -setup { 44 | zmq context ctx 45 | zmq socket a ctx REP 46 | } -body { 47 | zmq poll {{a POLLIN} {b f}} 0 48 | } -cleanup { 49 | a close 50 | ctx term 51 | } -returnCodes {error} -result {socket "b" does not exists} 52 | 53 | tcltest::test poll-8 {zmq poll} -setup { 54 | zmq context ctx 55 | zmq socket a ctx REP 56 | zmq socket b ctx REQ 57 | } -body { 58 | zmq poll {{a POLLIN} {b ff}} 0 59 | } -cleanup { 60 | a close 61 | b close 62 | ctx term 63 | } -returnCodes {error} -result {bad event_flag "ff": must be POLLIN, POLLOUT, or POLLERR} 64 | 65 | tcltest::test poll-9 {zmq poll} -setup { 66 | zmq context ctx 67 | zmq socket a ctx REP 68 | zmq socket b ctx REQ 69 | } -body { 70 | zmq poll {{a POLLIN} {b {POLLOUT fff}}} 0 71 | } -cleanup { 72 | a close 73 | b close 74 | ctx term 75 | } -returnCodes {error} -result {bad event_flag "fff": must be POLLIN, POLLOUT, or POLLERR} 76 | 77 | tcltest::test poll-10 {zmq poll} -setup { 78 | zmq context ctx 79 | zmq socket a ctx REP 80 | zmq socket b ctx REQ 81 | } -body { 82 | zmq poll {{a POLLIN} {b POLLOUT}} 0 83 | } -cleanup { 84 | a close 85 | b close 86 | ctx term 87 | } -returnCodes {ok} -result {} 88 | 89 | tcltest::test poll-11 {zmq socket} -setup { 90 | zmq context ctx 91 | zmq socket rep ctx REP 92 | rep bind "tcp://*:10003" 93 | zmq socket req ctx REQ 94 | req connect "tcp://localhost:10003" 95 | zmq message mrep 96 | } -body { 97 | set rt {} 98 | after 10 99 | lappend rt 1 {*}[zmq poll {{rep POLLIN} {req POLLOUT}} 0] 100 | req send "message" 101 | after 10 102 | lappend rt 2 {*}[zmq poll {{rep POLLIN} {req POLLOUT}} 0] 103 | rep recv_msg mrep 104 | after 10 105 | lappend rt 3 {*}[zmq poll {{rep POLLIN} {req POLLOUT}} 0] 106 | } -cleanup { 107 | mrep close 108 | req close 109 | rep close 110 | ctx term 111 | } -returnCodes {ok} -result {1 {req POLLOUT} 2 {rep POLLIN} 3} 112 | 113 | # cleanup 114 | ::tcltest::cleanupTests 115 | return 116 | 117 | -------------------------------------------------------------------------------- /test/proxy.test: -------------------------------------------------------------------------------- 1 | package require tcltest 2 | set auto_path [list ../lib {*}$auto_path] 3 | package require -exact zmq 4.0.1 4 | 5 | tcltest::test proxy-1 {zmq proxy} -body { 6 | zmq proxy 7 | } -returnCodes {error} -result {wrong # args: should be "zmq proxy frontend backend ?capture?"} 8 | 9 | tcltest::test proxy-2 {zmq proxy} -setup { 10 | zmq context ctx 11 | } -body { 12 | zmq proxy b c d 13 | } -cleanup { 14 | ctx term 15 | } -returnCodes {error} -result {socket "b" does not exists} 16 | 17 | tcltest::test proxy-3 {zmq proxy} -setup { 18 | zmq context ctx 19 | zmq socket b ctx REQ 20 | } -body { 21 | zmq proxy b c d 22 | } -cleanup { 23 | b close 24 | ctx term 25 | } -returnCodes {error} -result {socket "c" does not exists} 26 | 27 | tcltest::test proxy-4 {zmq proxy} -setup { 28 | zmq context ctx 29 | zmq socket b ctx REQ 30 | zmq socket c ctx REP 31 | } -body { 32 | zmq proxy b c d 33 | } -cleanup { 34 | b close 35 | c close 36 | ctx term 37 | } -returnCodes {error} -result {socket "d" does not exists} 38 | 39 | tcltest::test proxy-5 {zmq proxy} -setup { 40 | zmq context ctx 41 | zmq socket b ctx REQ 42 | zmq socket c ctx REP 43 | zmq socket d ctx PUB 44 | } -body { 45 | # Can't do this test, call will not return 46 | # zmq proxy b c d 47 | } -cleanup { 48 | b close 49 | c close 50 | d close 51 | ctx term 52 | } -returnCodes {ok} -result {} 53 | -------------------------------------------------------------------------------- /test/utils.test: -------------------------------------------------------------------------------- 1 | package require tcltest 2 | set auto_path [list ../lib {*}$auto_path] 3 | package require -exact zmq 4.0.1 4 | 5 | tcltest::test version-1 {zmq version} -body { 6 | puts [zmq version] 7 | } -returnCodes {ok} 8 | 9 | 10 | tcltest::test errno-1 {zmq errno} -body { 11 | puts [zmq errno] 12 | } -returnCodes {ok} 13 | 14 | tcltest::test errno-2 {zmq errno} -body { 15 | puts [zmq errno qwerty] 16 | } -returnCodes {error} -result {wrong # args: should be "zmq errno"} 17 | 18 | 19 | tcltest::test strerror-1 {zmq strerror} -body { 20 | zmq strerror 21 | } -returnCodes {error} -result {wrong # args: should be "zmq strerror errnum"} 22 | 23 | tcltest::test strerror-2 {zmq strerror} -body { 24 | zmq strerror qwerty 25 | } -returnCodes {error} -result {Wrong errnum argument, expected integer} 26 | 27 | tcltest::test strerror-3-unix {zmq strerror} -constraints {unix} -body { 28 | zmq strerror 0 29 | } -returnCodes {ok} -result {Success} 30 | 31 | tcltest::test strerror-3-win {zmq strerror} -constraints {win} -body { 32 | zmq strerror 0 33 | } -returnCodes {ok} -result {No error} 34 | 35 | 36 | tcltest::test max_block_time-1 {zmq max_block_time} -body { 37 | zmq max_block_time 38 | } -returnCodes {error} -result {wrong # args: should be "zmq max_block_time block_time"} 39 | 40 | tcltest::test max_block_time-2 {zmq max_block_time} -body { 41 | zmq max_block_time qwerty 42 | } -returnCodes {error} -result {Wrong block_time argument, expected integer} 43 | 44 | tcltest::test max_block_time-3 {zmq max_block_time} -body { 45 | zmq max_block_time 0 46 | } -returnCodes {ok} 47 | 48 | 49 | tcltest::test zframe_strhex-1 {zmq zframe_strhex} -body { 50 | zmq zframe_strhex 51 | } -returnCodes {error} -result {wrong # args: should be "zmq zframe_strhex string"} 52 | 53 | tcltest::test zframe_strhex-2 {zmq zframe_strhex} -body { 54 | zmq zframe_strhex abcdefg 55 | } -returnCodes {ok} -result {61626364656667} 56 | 57 | # cleanup 58 | ::tcltest::cleanupTests 59 | return 60 | 61 | -------------------------------------------------------------------------------- /test/zmsg.test: -------------------------------------------------------------------------------- 1 | package require tcltest 2 | set auto_path [list ../lib {*}$auto_path] 3 | package require -exact zmq 4.0.1 4 | 5 | tcltest::test zmsg-recv-1 {zmsg} -body { 6 | zmsg recv 7 | } -returnCodes {error} -result {wrong # args: should be "zmsg recv socket"} 8 | 9 | tcltest::test zmsg-recv-2 {zmsg} -body { 10 | zmsg recv s 11 | } -returnCodes {error} -result {invalid command name "s"} 12 | 13 | tcltest::test zmsg-recv-3 {zmsg} -setup { 14 | zmq context ctx 15 | zmq socket rep ctx REP 16 | rep bind "tcp://*:10003" 17 | zmq socket req ctx REQ 18 | req connect "tcp://localhost:10003" 19 | req sendmore "message" 20 | req send "more" 21 | } -body { 22 | zmsg recv rep 23 | } -cleanup { 24 | req close 25 | rep close 26 | ctx term 27 | } -returnCodes {ok} -result {message more} 28 | 29 | 30 | 31 | tcltest::test zmsg-send-1 {zmsg} -body { 32 | zmsg send 33 | } -returnCodes {error} -result {wrong # args: should be "zmsg send socket msgl"} 34 | 35 | tcltest::test zmsg-send-2 {zmsg} -body { 36 | zmsg send s msgl 37 | } -returnCodes {error} -result {invalid command name "s"} 38 | 39 | tcltest::test zmsg-send-3 {zmsg} -setup { 40 | zmq context ctx 41 | zmq socket rep ctx REP 42 | rep bind "tcp://*:10003" 43 | zmq socket req ctx REQ 44 | req connect "tcp://localhost:10003" 45 | } -body { 46 | zmsg send req {a b c d e} 47 | zmsg recv rep 48 | } -cleanup { 49 | req close 50 | rep close 51 | ctx term 52 | } -returnCodes {ok} -result {a b c d e} 53 | 54 | 55 | 56 | tcltest::test zmsg-unwrap-1 {zmsg} -body { 57 | zmsg unwrap 58 | } -returnCodes {error} -result {wrong # args: should be "zmsg unwrap msglnm"} 59 | 60 | tcltest::test zmsg-unwrap-2 {zmsg} -body { 61 | set msgl {a b c d e} 62 | set val [zmsg unwrap msgl] 63 | list $msgl $val 64 | } -returnCodes {ok} -result {{b c d e} a} 65 | 66 | tcltest::test zmsg-unwrap-3 {zmsg} -body { 67 | set msgl {a {} b {} c d e} 68 | set val1 [zmsg unwrap msgl] 69 | set val2 [zmsg unwrap msgl] 70 | set val3 [zmsg unwrap msgl] 71 | list $msgl $val3 $val2 $val1 72 | } -returnCodes {ok} -result {{d e} c b a} 73 | 74 | 75 | 76 | tcltest::test zmsg-wrap-1 {zmsg} -body { 77 | zmsg wrap 78 | } -returnCodes {error} -result {wrong # args: should be "zmsg wrap msgl data"} 79 | 80 | tcltest::test zmsg-wrap-2 {zmsg} -body { 81 | zmsg wrap a b 82 | } -returnCodes {ok} -result {b {} a} 83 | 84 | 85 | 86 | tcltest::test zmsg-push-1 {zmsg} -body { 87 | zmsg push 88 | } -returnCodes {error} -result {wrong # args: should be "zmsg push msgl data"} 89 | 90 | tcltest::test zmsg-push-2 {zmsg} -body { 91 | zmsg push a b 92 | } -returnCodes {ok} -result {b a} 93 | 94 | 95 | 96 | tcltest::test zmsg-pop-1 {zmsg} -body { 97 | zmsg pop 98 | } -returnCodes {error} -result {wrong # args: should be "zmsg pop msglnm"} 99 | 100 | tcltest::test zmsg-pop-2 {zmsg} -body { 101 | set msgl {a b c d e} 102 | set val [zmsg pop msgl] 103 | list $msgl $val 104 | } -returnCodes {ok} -result {{b c d e} a} 105 | 106 | tcltest::test zmsg-pop-3 {zmsg} -body { 107 | set msgl {a {} b {} c d e} 108 | set val1 [zmsg pop msgl] 109 | set val2 [zmsg pop msgl] 110 | set val3 [zmsg pop msgl] 111 | list $msgl $val3 $val2 $val1 112 | } -returnCodes {ok} -result {{{} c d e} b {} a} 113 | 114 | 115 | 116 | tcltest::test zmsg-add-1 {zmsg} -body { 117 | zmsg add 118 | } -returnCodes {error} -result {wrong # args: should be "zmsg add msgl data"} 119 | 120 | tcltest::test zmsg-add-2 {zmsg} -body { 121 | zmsg add {a b} c 122 | } -returnCodes {ok} -result {a b c} 123 | 124 | 125 | 126 | tcltest::test zmsg-dump-1 {zmsg} -body { 127 | zmsg dump 128 | } -returnCodes {error} -result {wrong # args: should be "zmsg dump msgl"} 129 | 130 | tcltest::test zmsg-dump-2 {zmsg} -body { 131 | zmsg dump {a b c d} 132 | } -returnCodes {ok} -result {{[001] a} {[001] b} {[001] c} {[001] d}} 133 | 134 | 135 | 136 | tcltest::test zmmq-monitor-1 {zmsg} -body { 137 | zmq monitor 138 | } -returnCodes {error} -result {wrong # args: should be "zmq monitor context sock callback ?events?"} 139 | 140 | # cleanup 141 | ::tcltest::cleanupTests 142 | return 143 | 144 | -------------------------------------------------------------------------------- /zmq_helper.tcl: -------------------------------------------------------------------------------- 1 | namespace eval ::zmq { 2 | namespace export * 3 | namespace ensemble create 4 | 5 | variable monitorid 0 6 | 7 | proc monitor_callback {socket callback} { 8 | if {[catch {$socket recv_monitor_event} d]} { 9 | error $d 10 | } else { 11 | uplevel #0 [list $callback $d] 12 | } 13 | } 14 | 15 | proc monitor {context sock callback {events ALL}} { 16 | variable monitorid 17 | set id monitor[incr monitorid] 18 | $sock monitor "inproc://$id" $events 19 | set socket [zmq socket $id $context PAIR] 20 | $socket connect "inproc://$id" 21 | $socket readable [list ::zmq::monitor_callback $socket $callback] 22 | return $id 23 | } 24 | 25 | proc have_libsodium {} { 26 | zmq context ctx 27 | zmq socket s ctx PUB 28 | if {[catch {s getsockopt CURVE_SERVER} msg]} { 29 | set have_libsodium 0 30 | } else { 31 | set have_libsodium 1 32 | } 33 | s close 34 | ctx term 35 | return $have_libsodium 36 | } 37 | } 38 | 39 | namespace eval ::zmsg { 40 | namespace export * 41 | namespace ensemble create 42 | 43 | proc recv {socket} { 44 | set rt [list] 45 | lappend rt [$socket recv] 46 | while {[$socket getsockopt RCVMORE]} { 47 | lappend rt [$socket recv] 48 | } 49 | return $rt 50 | } 51 | 52 | proc send {socket msgl} { 53 | foreach m [lrange $msgl 0 end-1] { 54 | $socket sendmore $m 55 | } 56 | $socket send [lindex $msgl end] 57 | } 58 | 59 | proc unwrap {msglnm} { 60 | upvar $msglnm msgl 61 | set data "" 62 | if {[llength $msgl]} { 63 | set msgl [lassign $msgl data] 64 | } 65 | if {[llength $msgl] && [string length [lindex $msgl 0]] == 0} { 66 | set msgl [lassign $msgl empty] 67 | } 68 | return $data 69 | } 70 | 71 | proc wrap {msgl data} { 72 | return [list $data "" {*}$msgl] 73 | } 74 | 75 | proc push {msgl data} { 76 | return [list $data {*}$msgl] 77 | } 78 | 79 | proc pop {msglnm} { 80 | upvar $msglnm msgl 81 | set msgl [lassign $msgl first] 82 | return $first 83 | } 84 | 85 | proc add {msgl data} { 86 | return [list {*}$msgl $data] 87 | } 88 | 89 | proc dump {msgl} { 90 | set rt [list] 91 | if {[llength $msgl]} { 92 | set m .#[pid] 93 | foreach data $msgl { 94 | zmq message $m -data $data 95 | lappend rt [$m dump] 96 | $m close 97 | } 98 | } else { 99 | lappend rt "NULL" 100 | } 101 | return $rt 102 | } 103 | } 104 | -------------------------------------------------------------------------------- /zmq_nMakefiles/Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Build zmq for static linking with the Tcl wrapper, 32 or 64 bit. 3 | # 4 | # Specify the ZMQDIR= and INSTALLDIR= on the nmake command 5 | # line 6 | # 7 | # Use the following commands to build and install the zmq library for 32 or 64 bit: 8 | # 9 | # % nmake ZMQDIR=../../libzmq INSTALLDIR=. all32 10 | # 11 | # % nmake ZMQDIR=../../libzmq INSTALLDIR=. all64 12 | # 13 | 14 | ZMQDIR = ..\..\libzmq 15 | INSTALLDIR = . 16 | 17 | include_HEADERS = $(ZMQDIR)\include\zmq.h $(ZMQDIR)\include\zmq_utils.h 18 | 19 | CFLAGS = /c /I $(ZMQDIR)\include /I $(ZMQDIR)\builds\msvc /EHsc /MD /TP /D NDEBUG /D _CRT_SECURE_NO_WARNINGS /D DLL_EXPORT /D FD_SETSIZE=1024 /D _WINDOWS /D _USRDLL /D _BIND_TO_CURRENT_VCLIBS_VERSION=1 /D _MBCS /D NOMINMAX /Fo"work/" 20 | 21 | SOURCES = \ 22 | $(ZMQDIR)\src\address.cpp \ 23 | $(ZMQDIR)\src\clock.cpp \ 24 | $(ZMQDIR)\src\ctx.cpp \ 25 | $(ZMQDIR)\src\decoder.cpp \ 26 | $(ZMQDIR)\src\device.cpp \ 27 | $(ZMQDIR)\src\devpoll.cpp \ 28 | $(ZMQDIR)\src\dist.cpp \ 29 | $(ZMQDIR)\src\encoder.cpp \ 30 | $(ZMQDIR)\src\epoll.cpp \ 31 | $(ZMQDIR)\src\err.cpp \ 32 | $(ZMQDIR)\src\fq.cpp \ 33 | $(ZMQDIR)\src\io_object.cpp \ 34 | $(ZMQDIR)\src\io_thread.cpp \ 35 | $(ZMQDIR)\src\ip.cpp \ 36 | $(ZMQDIR)\src\ipc_address.cpp \ 37 | $(ZMQDIR)\src\ipc_connecter.cpp \ 38 | $(ZMQDIR)\src\ipc_listener.cpp \ 39 | $(ZMQDIR)\src\kqueue.cpp \ 40 | $(ZMQDIR)\src\lb.cpp \ 41 | $(ZMQDIR)\src\mailbox.cpp \ 42 | $(ZMQDIR)\src\msg.cpp \ 43 | $(ZMQDIR)\src\mtrie.cpp \ 44 | $(ZMQDIR)\src\object.cpp \ 45 | $(ZMQDIR)\src\options.cpp \ 46 | $(ZMQDIR)\src\own.cpp \ 47 | $(ZMQDIR)\src\pair.cpp \ 48 | $(ZMQDIR)\src\pgm_receiver.cpp \ 49 | $(ZMQDIR)\src\pgm_sender.cpp \ 50 | $(ZMQDIR)\src\pgm_socket.cpp \ 51 | $(ZMQDIR)\src\pipe.cpp \ 52 | $(ZMQDIR)\src\poll.cpp \ 53 | $(ZMQDIR)\src\poller_base.cpp \ 54 | $(ZMQDIR)\src\pull.cpp \ 55 | $(ZMQDIR)\src\push.cpp \ 56 | $(ZMQDIR)\src\reaper.cpp \ 57 | $(ZMQDIR)\src\pub.cpp \ 58 | $(ZMQDIR)\src\random.cpp \ 59 | $(ZMQDIR)\src\rep.cpp \ 60 | $(ZMQDIR)\src\req.cpp \ 61 | $(ZMQDIR)\src\select.cpp \ 62 | $(ZMQDIR)\src\session_base.cpp \ 63 | $(ZMQDIR)\src\signaler.cpp \ 64 | $(ZMQDIR)\src\socket_base.cpp \ 65 | $(ZMQDIR)\src\stream_engine.cpp \ 66 | $(ZMQDIR)\src\sub.cpp \ 67 | $(ZMQDIR)\src\tcp_address.cpp \ 68 | $(ZMQDIR)\src\tcp_connecter.cpp \ 69 | $(ZMQDIR)\src\tcp_listener.cpp \ 70 | $(ZMQDIR)\src\thread.cpp \ 71 | $(ZMQDIR)\src\trie.cpp \ 72 | $(ZMQDIR)\src\xpub.cpp \ 73 | $(ZMQDIR)\src\router.cpp \ 74 | $(ZMQDIR)\src\dealer.cpp \ 75 | $(ZMQDIR)\src\xsub.cpp \ 76 | $(ZMQDIR)\src\zmq.cpp 77 | 78 | all64: lib64 install headers 79 | 80 | all32: lib32 install headers 81 | 82 | install: 83 | -mkdir $(INSTALLDIR) 84 | -mkdir $(INSTALLDIR)\lib 85 | copy work\libzmq.lib $(INSTALLDIR)\lib\libzmq.lib 86 | 87 | headers: $(include_HEADERS) 88 | - mkdir $(INSTALLDIR) 89 | - mkdir $(INSTALLDIR)\include 90 | copy /Y $(ZMQDIR)\include\* $(INSTALLDIR)\include 91 | 92 | lib64: objs64 93 | lib work\*.obj /out:work\libzmq.lib /LTCG 94 | 95 | lib32: objs32 96 | lib work\*.obj /out:work\libzmq.lib /LTCG 97 | 98 | objs64: $(SOURCES) 99 | - mkdir work 100 | cl $(SOURCES) $(CFLAGS) /D _WIN64 101 | 102 | objs32: $(SOURCES) 103 | - mkdir work 104 | cl $(SOURCES) $(CFLAGS) 105 | 106 | clean: 107 | rmdir /S /Q work 108 | --------------------------------------------------------------------------------