├── weaver.ini ├── docker-run ├── .gitignore ├── scripts ├── print_zmq_msg_size.c ├── docker-push ├── Dockerfile.perl-zmq-base ├── docker-test-install ├── docker-release-shell ├── docker-build ├── gen_modules.pl └── gen_zmq_constants.pl ├── .travis.yml ├── inc ├── ZMQ4_1 │ ├── SocketWrappers.pm │ └── ContextWrappers.pm ├── ZMQ4 │ ├── SocketWrappers.pm │ └── ContextWrappers.pm ├── ContextWrapperRole.pm ├── SocketWrapperRole.pm ├── ZmqSocket.pm.tt ├── ZmqContext.pm.tt ├── ZMQ3 │ ├── ContextWrappers.pm │ └── SocketWrappers.pm └── ZMQ2 │ ├── ContextWrappers.pm │ └── SocketWrappers.pm ├── docker-shell ├── lib └── ZMQ │ ├── FFI │ ├── Versioner.pm │ ├── ContextRole.pm │ ├── Custom │ │ └── Raw.pm │ ├── ErrorHelper.pm │ ├── SocketRole.pm │ ├── Util.pm │ ├── ZMQ2 │ │ └── Raw.pm │ ├── ZMQ3 │ │ └── Raw.pm │ ├── ZMQ4 │ │ └── Raw.pm │ └── ZMQ4_1 │ │ └── Raw.pm │ └── FFI.pm ├── t ├── close.t ├── closed_socket.t ├── send_recv.t ├── linger.t ├── unbind.t ├── fd.t ├── pubsub.t ├── router-req.t ├── proxy.t ├── multipart.t ├── lib │ └── ZMQTest.pm ├── threads.t ├── z85_encoding.t ├── unicode.t ├── device.t ├── curve_keypair.t ├── gc.t ├── options.t ├── fork-01.t ├── errors.t ├── monitor.t └── fork-02.t ├── bench ├── zmq-bench.c ├── zmq-bench-subcriber.pl └── zmq-bench.pl ├── .github └── workflows │ ├── docker-test.yml │ └── ci.yml ├── xt ├── gc_global_destruction.pl ├── test_versions.sh └── sonames.pl ├── dist.ini ├── Dockerfile ├── README.md ├── Changes └── COPYING /weaver.ini: -------------------------------------------------------------------------------- 1 | [@Default] 2 | 3 | [-Transformer] 4 | transformer = List 5 | -------------------------------------------------------------------------------- /docker-run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | docker run --rm \ 3 | -v $(pwd):/zmq-ffi \ 4 | -w /zmq-ffi \ 5 | calid/zmq-ffi-testenv:ubuntu "$@" 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ZMQ-FFI-*.tar.gz 2 | ZMQ-FFI-*/ 3 | .build/ 4 | lib/ZMQ/FFI/*/Context.pm 5 | lib/ZMQ/FFI/*/Socket.pm 6 | lib/ZMQ/FFI/Constants.pm 7 | -------------------------------------------------------------------------------- /scripts/print_zmq_msg_size.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | int main(void) 5 | { 6 | printf("%zu\n", sizeof(zmq_msg_t)); 7 | } 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | services: 3 | - docker 4 | 5 | script: 6 | - ./docker-run dzil test 7 | - ./scripts/docker-test-install 8 | -------------------------------------------------------------------------------- /inc/ZMQ4_1/SocketWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ4_1::SocketWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | extends 'inc::ZMQ4::SocketWrappers'; 7 | 8 | 1; 9 | -------------------------------------------------------------------------------- /docker-shell: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | docker run --rm -i -t \ 3 | -e SHELL=/bin/bash \ 4 | -v $(pwd):/zmq-ffi \ 5 | -w /zmq-ffi \ 6 | calid/zmq-ffi-testenv:ubuntu /bin/bash 7 | -------------------------------------------------------------------------------- /scripts/docker-push: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | version=$1 4 | 5 | if [ -z "$version" ]; then 6 | echo "docker-push " 7 | exit 1 8 | fi 9 | 10 | for t in $version latest ubuntu; do 11 | docker push calid/perl-zmq-base:$t 12 | docker push calid/zmq-ffi-testenv:$t 13 | done 14 | -------------------------------------------------------------------------------- /scripts/Dockerfile.perl-zmq-base: -------------------------------------------------------------------------------- 1 | FROM ubuntu:latest 2 | ENV DEBIAN_FRONTEND=noninteractive 3 | RUN apt-get update \ 4 | && apt-get install -y gcc make libzmq5 openssl libssl-dev zlib1g-dev \ 5 | cpanminus \ 6 | && apt-get clean \ 7 | && rm -rf /var/lib/apt/lists/* /usr/local/share/man/* /usr/share/doc/* 8 | -------------------------------------------------------------------------------- /inc/ZMQ4_1/ContextWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ4_1::ContextWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | extends 'inc::ZMQ4::ContextWrappers'; 7 | 8 | sub has_capability_tt {q( 9 | sub has_capability { 10 | my ($self, $capability) = @_; 11 | return zmq_has($capability); 12 | } 13 | )} 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /scripts/docker-test-install: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | docker run --rm \ 3 | -v $(pwd):/zmq-ffi \ 4 | -w /zmq-ffi \ 5 | calid/zmq-ffi-testenv:ubuntu sh -c "dzil clean && dzil build" 6 | 7 | docker run --rm \ 8 | -v $(pwd):/zmq-ffi \ 9 | -w /zmq-ffi \ 10 | calid/perl-zmq-base:ubuntu sh -c "cpanm -v ZMQ-FFI-*.tar.gz" 11 | -------------------------------------------------------------------------------- /scripts/docker-release-shell: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | docker run --rm -i -t \ 3 | -e SHELL=/bin/bash \ 4 | -v $(pwd):/zmq-ffi \ 5 | -v $HOME/.ssh:/root/.ssh \ 6 | -v $HOME/.pause:/root/.pause \ 7 | -v $HOME/.gitconfig:/root/.gitconfig \ 8 | -v $HOME/.gitignore:/root/.gitignore \ 9 | -w /zmq-ffi \ 10 | calid/zmq-ffi-testenv:ubuntu /bin/bash 11 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/Versioner.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::Versioner; 2 | 3 | use Moo::Role; 4 | 5 | use ZMQ::FFI::Util qw(zmq_version); 6 | 7 | requires q(soname); 8 | 9 | has _version_parts => ( 10 | is => 'ro', 11 | lazy => 1, 12 | default => sub { [zmq_version($_[0]->soname)] } 13 | ); 14 | 15 | sub version { 16 | return @{$_[0]->_version_parts}; 17 | } 18 | 19 | sub verstr { 20 | return join('.', $_[0]->version); 21 | } 22 | 23 | 1; 24 | -------------------------------------------------------------------------------- /inc/ZMQ4/SocketWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ4::SocketWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | extends 'inc::ZMQ3::SocketWrappers'; 7 | 8 | sub recv_event_tt {q( 9 | sub recv_event { 10 | my ($self, $flags) = @_; 11 | 12 | [% closed_socket_check %] 13 | 14 | my ($event, $endpoint) = $self->recv_multipart($flags); 15 | 16 | my ($id, $value) = unpack('S L', $event); 17 | 18 | return ($id, $value, $endpoint); 19 | } 20 | )} 21 | 22 | 1; 23 | -------------------------------------------------------------------------------- /scripts/docker-build: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | version=$1 4 | 5 | if [ -z "$version" ]; then 6 | echo "docker-build " 7 | exit 1 8 | fi 9 | 10 | docker build scripts -f scripts/Dockerfile.perl-zmq-base \ 11 | -t calid/perl-zmq-base:$version \ 12 | -t calid/perl-zmq-base:latest \ 13 | -t calid/perl-zmq-base:ubuntu 14 | 15 | docker build . \ 16 | -t calid/zmq-ffi-testenv:$version \ 17 | -t calid/zmq-ffi-testenv:latest \ 18 | -t calid/zmq-ffi-testenv:ubuntu 19 | 20 | -------------------------------------------------------------------------------- /t/close.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | if( ZMQTest->platform_can_sigaction ) { 10 | require Sys::SigAction; 11 | Sys::SigAction->import(qw(timeout_call)); 12 | } else { 13 | plan skip_all => 'No Sys::SigAction'; 14 | } 15 | 16 | use ZMQ::FFI qw(ZMQ_REQ); 17 | 18 | subtest 'close with unsent messages', sub { 19 | my $timed_out = timeout_call(5, sub { 20 | my $ctx = ZMQ::FFI->new(); 21 | my $s = $ctx->socket(ZMQ_REQ); 22 | 23 | $s->connect(ZMQTest->endpoint("test-zmq-ffi-$$")); 24 | $s->send('ohhai'); 25 | }); 26 | 27 | ok !$timed_out, 28 | 'implicit Socket close done correctly (ctx destruction does not hang)'; 29 | }; 30 | 31 | done_testing; 32 | -------------------------------------------------------------------------------- /bench/zmq-bench.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | int main(void) 9 | { 10 | void *ctx = zmq_ctx_new(); 11 | assert(ctx); 12 | 13 | void *socket = zmq_socket(ctx, ZMQ_PUB); 14 | assert(socket); 15 | 16 | assert( -1 != zmq_bind(socket, "ipc:///tmp/zmq-bench-c") ); 17 | 18 | int major, minor, patch; 19 | zmq_version(&major, &minor, &patch); 20 | 21 | printf("C ZMQ Version: %d.%d.%d\n", major, minor, patch); 22 | 23 | int i; 24 | for ( i = 0; i < (10 * 1000 * 1000); i++ ) { 25 | assert( -1 != zmq_send(socket, "c", 1, 0) ); 26 | } 27 | 28 | printf("Sent %d messages\n", i); 29 | 30 | zmq_close(socket); 31 | zmq_ctx_destroy(ctx); 32 | } 33 | -------------------------------------------------------------------------------- /t/closed_socket.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use Test::Warnings qw(warnings); 7 | 8 | use ZMQ::FFI qw(ZMQ_REQ); 9 | use ZMQ::FFI::SocketRole; 10 | 11 | my @socket_methods = @{$Moo::Role::INFO{'ZMQ::FFI::SocketRole'}->{requires}}; 12 | 13 | my @expected_warnings; 14 | push @expected_warnings, re('Operation on closed socket') 15 | for (@socket_methods); 16 | 17 | sub f { 18 | my $c = ZMQ::FFI->new(); 19 | return $c->socket(ZMQ_REQ); 20 | } 21 | 22 | my @actual_warnings = warnings { 23 | my $s = f(); 24 | 25 | for my $method (@socket_methods) { 26 | $s->$method() 27 | } 28 | }; 29 | 30 | cmp_deeply( 31 | \@actual_warnings, 32 | \@expected_warnings, 33 | 'got warnings for operations on closed socket' 34 | ); 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /bench/zmq-bench-subcriber.pl: -------------------------------------------------------------------------------- 1 | use 5.012; 2 | use warnings; 3 | 4 | use ZMQ::FFI qw(ZMQ_SUB); 5 | use Try::Tiny; 6 | 7 | my $count = 0; 8 | 9 | $SIG{USR1} = sub { 10 | say "received $count messages"; 11 | }; 12 | 13 | $SIG{USR2} = sub { 14 | say "resetting message count"; 15 | $count = 0; 16 | }; 17 | 18 | say "'kill -USR1 $$' to print current message count"; 19 | say "'kill -USR2 $$' to reset message count"; 20 | 21 | my $ctx = ZMQ::FFI->new(); 22 | my $s = $ctx->socket(ZMQ_SUB); 23 | $s->connect('ipc:///tmp/zmq-bench-c'); 24 | $s->connect('ipc:///tmp/zmq-bench-xs'); 25 | $s->connect('ipc:///tmp/zmq-bench-ffi'); 26 | $s->subscribe(''); 27 | 28 | my $r; 29 | while (1) { 30 | try { 31 | $r = $s->recv(); 32 | $count++; 33 | } 34 | catch { 35 | croak $_ unless $_ =~ m/Interrupted system call/; 36 | }; 37 | } 38 | -------------------------------------------------------------------------------- /t/send_recv.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Warnings; 5 | use lib 't/lib'; 6 | use ZMQTest; 7 | 8 | use ZMQ::FFI qw(ZMQ_REQ ZMQ_REP); 9 | 10 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 11 | my $ctx = ZMQ::FFI->new( threads => 1 ); 12 | 13 | my $s1 = $ctx->socket(ZMQ_REQ); 14 | $s1->connect($endpoint); 15 | 16 | my $s2 = $ctx->socket(ZMQ_REP); 17 | $s2->bind($endpoint); 18 | 19 | $s1->send('ohhai'); 20 | 21 | is 22 | $s2->recv(), 23 | 'ohhai', 24 | 'received message'; 25 | 26 | $s1->close(); 27 | is $s1->socket_ptr, -1, 's1 socket ptr set to -1 after explicit close'; 28 | 29 | $s2->close(); 30 | is $s2->socket_ptr, -1, 's2 socket ptr set to -1 after explicit close'; 31 | 32 | $ctx->destroy(); 33 | is $ctx->context_ptr, -1, 'ctx ptr set to -1 after explicit destroy'; 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /.github/workflows/docker-test.yml: -------------------------------------------------------------------------------- 1 | name: Run Tests via Docker 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | pull_request: 8 | 9 | jobs: 10 | docker-test: 11 | name: Test using Docker 12 | runs-on: ubuntu-latest 13 | steps: 14 | - name: Checkout code 15 | uses: actions/checkout@v3 16 | - name: dzil test 17 | run: | 18 | ./docker-run sh -c " 19 | dzil authordeps --missing | cpanm -n; 20 | cpanm -nq Sys::SigAction; # temporary until release of new test image 21 | dzil test" 22 | - name: docker-test-install 23 | run: | 24 | ./docker-run sh -c " 25 | dzil authordeps --missing | cpanm -n; 26 | cpanm -nq Sys::SigAction; # temporary until release of new test image 27 | dzil clean && dzil build; 28 | cpanm -v ZMQ-FFI-*.tar.gz" 29 | -------------------------------------------------------------------------------- /t/linger.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | 7 | use ZMQ::FFI qw(ZMQ_REQ); 8 | 9 | my $ctx = ZMQ::FFI->new(); 10 | my $s = $ctx->socket(ZMQ_REQ); 11 | 12 | no strict qw/refs/; 13 | no warnings qw/redefine once/; 14 | 15 | my $fake_close = sub { 16 | my ($self) = @_; 17 | is $self->get_linger, 42, "user linger value honored during socket close"; 18 | 19 | # need to manually set linger & close 20 | # since we clobbered the real method 21 | $self->set_linger(0); 22 | 23 | my $class = ref $self; 24 | &{"$class\::zmq_close"}($self->socket_ptr); 25 | }; 26 | 27 | local *ZMQ::FFI::ZMQ2::Socket::close = $fake_close; 28 | local *ZMQ::FFI::ZMQ3::Socket::close = $fake_close; 29 | 30 | use strict; 31 | use warnings; 32 | 33 | is $s->get_linger, 0, "got default linger"; 34 | 35 | $s->set_linger(42); 36 | is $s->get_linger, 42, "linger is 42 after set"; 37 | 38 | undef $s; 39 | 40 | done_testing; 41 | -------------------------------------------------------------------------------- /t/unbind.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Warnings; 5 | use Test::Exception; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_REQ ZMQ_REP ZMQ_LAST_ENDPOINT); 10 | 11 | my $e = ZMQTest->endpoint("test-zmq-ffi-$$"); 12 | 13 | my $c = ZMQ::FFI->new(); 14 | 15 | my $s1 = $c->socket(ZMQ_REQ); 16 | $s1->connect($e); 17 | 18 | my $s2 = $c->socket(ZMQ_REP); 19 | $s2->bind($e); 20 | 21 | my ($major) = $c->version(); 22 | 23 | if ( $major == 2 ) { 24 | throws_ok { $s1->disconnect($e) } 25 | qr'not available in zmq 2.x', 26 | 'threw unimplemented error for 2.x'; 27 | 28 | throws_ok { $s2->unbind($e) } 29 | qr'not available in zmq 2.x', 30 | 'threw unimplemented error for 2.x'; 31 | } 32 | else { 33 | lives_ok { $s1->disconnect($e) } 'first disconnect lives'; 34 | lives_ok { $s2->unbind($e) } 'first unbind lives'; 35 | 36 | dies_ok { $s1->disconnect($e) } 'second disconnect dies'; 37 | dies_ok { $s2->unbind($e) } 'second unbind dies'; 38 | } 39 | 40 | done_testing; 41 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/ContextRole.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::ContextRole; 2 | 3 | use Moo::Role; 4 | 5 | use ZMQ::FFI::Util qw(current_tid); 6 | 7 | # real underlying zmq context pointer 8 | has context_ptr => ( 9 | is => 'rw', 10 | default => -1, 11 | ); 12 | 13 | # used to make sure we handle fork situations correctly 14 | has _pid => ( 15 | is => 'ro', 16 | default => sub { $$ }, 17 | ); 18 | 19 | # used to make sure we handle thread situations correctly 20 | has _tid => ( 21 | is => 'ro', 22 | default => sub { current_tid() }, 23 | ); 24 | 25 | has soname => ( 26 | is => 'ro', 27 | required => 1, 28 | ); 29 | 30 | has threads => ( 31 | is => 'ro', 32 | predicate => 'has_threads', 33 | ); 34 | 35 | has max_sockets => ( 36 | is => 'ro', 37 | predicate => 'has_max_sockets', 38 | ); 39 | 40 | has sockets => ( 41 | is => 'rw', 42 | lazy => 1, 43 | default => sub { {} }, 44 | ); 45 | 46 | requires qw( 47 | init 48 | get 49 | set 50 | socket 51 | proxy 52 | device 53 | destroy 54 | curve_keypair 55 | z85_encode 56 | z85_decode 57 | has_capability 58 | ); 59 | 60 | 1; 61 | -------------------------------------------------------------------------------- /inc/ContextWrapperRole.pm: -------------------------------------------------------------------------------- 1 | package inc::ContextWrapperRole; 2 | 3 | use Moo::Role; 4 | use namespace::clean; 5 | 6 | use Path::Class qw(file); 7 | 8 | use ZMQ::FFI::ContextRole; 9 | 10 | my @ctx_methods = @{$Moo::Role::INFO{'ZMQ::FFI::ContextRole'}->{requires}}; 11 | 12 | requires $_."_tt" for @ctx_methods; 13 | 14 | has zmqver => ( 15 | is => 'ro', 16 | required => 1, 17 | ); 18 | 19 | has api_methods => ( 20 | is => 'ro', 21 | default => sub { \@ctx_methods }, 22 | ); 23 | 24 | has template => ( 25 | is => 'ro', 26 | default => sub { file('inc/ZmqContext.pm.tt') }, 27 | ); 28 | 29 | has target => ( 30 | is => 'lazy', 31 | ); 32 | 33 | has lib_imports => ( 34 | is => 'ro', 35 | default => '', 36 | ); 37 | 38 | sub _build_target { 39 | my ($self) = @_; 40 | 41 | my $zmqver = $self->zmqver; 42 | return file("lib/ZMQ/FFI/$zmqver/Context.pm"), 43 | } 44 | 45 | sub wrappers { 46 | my ($self) = @_; 47 | 48 | my %wrappers; 49 | 50 | for my $ctx_method (@ctx_methods) { 51 | my $template_method = $ctx_method."_tt"; 52 | $wrappers{$ctx_method} = $self->$template_method; 53 | } 54 | 55 | return \%wrappers; 56 | } 57 | 58 | 1; 59 | -------------------------------------------------------------------------------- /t/fd.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | if( ! ZMQTest->platform_zmq_fd_sockopt_is_fd ) { 10 | plan skip_all => 'Method get_fd() not implemented for platform'; 11 | } 12 | 13 | use AnyEvent; 14 | use ZMQ::FFI qw(ZMQ_PUSH ZMQ_PULL); 15 | 16 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 17 | my @expected = qw(foo bar baz); 18 | my $ctx = ZMQ::FFI->new(); 19 | 20 | my $pull = $ctx->socket(ZMQ_PULL); 21 | $pull->bind($endpoint); 22 | 23 | my $fd = $pull->get_fd(); 24 | 25 | my $cv = AE::cv; 26 | 27 | my $recv = 0; 28 | my $w = AE::io $fd, 0, sub { 29 | while ($pull->has_pollin) { 30 | my $msg = $pull->recv(); 31 | is $msg, $expected[$recv], "got message $recv"; 32 | 33 | $recv++; 34 | if ($recv == 3) { 35 | $cv->send; 36 | } 37 | } 38 | }; 39 | 40 | 41 | my $push = $ctx->socket(ZMQ_PUSH); 42 | $push->connect($endpoint); 43 | 44 | my $t; 45 | my $sent = 0; 46 | $t = AE::timer 0, .1, sub { 47 | $push->send($expected[$sent]); 48 | 49 | $sent++; 50 | if ($sent == 3) { 51 | undef $t; 52 | } 53 | }; 54 | 55 | $cv->recv; 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /inc/SocketWrapperRole.pm: -------------------------------------------------------------------------------- 1 | package inc::SocketWrapperRole; 2 | 3 | use Moo::Role; 4 | use namespace::clean; 5 | 6 | use Path::Class qw(file); 7 | 8 | use ZMQ::FFI::SocketRole; 9 | 10 | my @socket_methods = @{$Moo::Role::INFO{'ZMQ::FFI::SocketRole'}->{requires}}; 11 | 12 | requires $_."_tt" for @socket_methods; 13 | 14 | has zmqver => ( 15 | is => 'ro', 16 | required => 1, 17 | ); 18 | 19 | has api_methods => ( 20 | is => 'ro', 21 | default => sub { \@socket_methods }, 22 | ); 23 | 24 | has template => ( 25 | is => 'ro', 26 | default => sub { file('inc/ZmqSocket.pm.tt') }, 27 | ); 28 | 29 | has target => ( 30 | is => 'lazy', 31 | ); 32 | 33 | has lib_imports => ( 34 | is => 'ro', 35 | default => '', 36 | ); 37 | 38 | sub _build_target { 39 | my ($self) = @_; 40 | 41 | my $zmqver = $self->zmqver; 42 | return file("lib/ZMQ/FFI/$zmqver/Socket.pm"), 43 | } 44 | 45 | sub wrappers { 46 | my ($self) = @_; 47 | 48 | my %wrappers; 49 | 50 | for my $socket_method (@socket_methods) { 51 | my $template_method = $socket_method."_tt"; 52 | $wrappers{$socket_method} = $self->$template_method; 53 | } 54 | 55 | return \%wrappers; 56 | } 57 | 58 | 1; 59 | -------------------------------------------------------------------------------- /t/pubsub.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_PUB ZMQ_SUB ZMQ_DONTWAIT); 10 | 11 | use Time::HiRes q(usleep); 12 | 13 | subtest 'pubsub', 14 | sub { 15 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 16 | 17 | my $ctx = ZMQ::FFI->new(); 18 | 19 | my $s = $ctx->socket(ZMQ_SUB); 20 | my $p = $ctx->socket(ZMQ_PUB); 21 | 22 | $s->connect($endpoint); 23 | $p->bind($endpoint); 24 | 25 | { 26 | $s->subscribe(''); 27 | 28 | until ($s->has_pollin) { 29 | # sleep for a 100ms to compensate for slow subscriber problem 30 | usleep 100_000; 31 | $p->send('ohhai'); 32 | } 33 | 34 | my $msg = $s->recv(); 35 | is $msg, 'ohhai', 'got msg sent to all topics'; 36 | 37 | $s->unsubscribe(''); 38 | } 39 | 40 | { 41 | $s->subscribe('mytopic'); 42 | 43 | until ($s->has_pollin) { 44 | usleep 100_000; 45 | $p->send('mytopic ohhai'); 46 | } 47 | 48 | my $msg = $s->recv(); 49 | is $msg, 'mytopic ohhai', 'got msg sent to mytopic'; 50 | } 51 | }; 52 | 53 | done_testing; 54 | 55 | -------------------------------------------------------------------------------- /t/router-req.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_ROUTER ZMQ_REQ); 10 | 11 | use Time::HiRes q(usleep); 12 | 13 | subtest 'router-req', sub { 14 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 15 | 16 | my $ctx = ZMQ::FFI->new(); 17 | 18 | my $req = $ctx->socket(ZMQ_REQ); 19 | my $rtr = $ctx->socket(ZMQ_ROUTER); 20 | 21 | $req->connect($endpoint); 22 | $rtr->bind($endpoint); 23 | 24 | my $message = 'ohhai'; 25 | 26 | { 27 | $req->send($message); 28 | 29 | until ($rtr->has_pollin) { 30 | 31 | # sleep for a 100ms to compensate for slow subscriber problem 32 | usleep 100_000; 33 | } 34 | 35 | my ($identifier, $null, $payload) = $rtr->recv_multipart(); 36 | is $null, '', "Null is really null"; 37 | is $payload, $message, "Message received"; 38 | 39 | $rtr->send_multipart([$identifier, '', '' . reverse($payload)]); 40 | 41 | until ($req->has_pollin) { 42 | usleep 100_000; 43 | } 44 | 45 | my @result = $req->recv(); 46 | is reverse($result[0]), $message, "Message received by client"; 47 | } 48 | }; 49 | 50 | done_testing; 51 | 52 | -------------------------------------------------------------------------------- /xt/gc_global_destruction.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use ZMQ::FFI qw(ZMQ_REQ); 5 | 6 | my $context = ZMQ::FFI->new(); 7 | my $socket = $context->socket(ZMQ_REQ); 8 | 9 | sub closure { $socket } 10 | 11 | # Suprisingly, the above can cause this script to hang. Closing over $socket 12 | # may result in $context getting cleaned up before $socket during global 13 | # destruction. This is despite the fact that $socket has a reference to 14 | # $context, and therefore would be expected to get cleaned up first (and 15 | # always does during normal destruction). 16 | # 17 | # This triggers a hang as zmq contexts block during cleanup until close has 18 | # been called on all sockets. So for single threaded applications you _must_ 19 | # close all sockets before attempting to destroy the context. 20 | # 21 | # Remove the closure and global destruction cleanup happens in the expected 22 | # order. However the lesson of course is to not assume _any_ particular 23 | # cleanup order during GD. The ordering may change with different perl 24 | # versions, different arrangements of the code, different directions of the 25 | # wind, etc. 26 | # 27 | # The old adage "all bets are off during global destruction" is still true 28 | # and code that assumes a particular cleanup order during GD will fail 29 | # eventually. 30 | -------------------------------------------------------------------------------- /t/proxy.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_PUSH ZMQ_PULL); 10 | 11 | use Time::HiRes q(usleep); 12 | use POSIX ":sys_wait_h"; 13 | 14 | if( ! ZMQTest->platform_can_fork ) { 15 | plan skip_all => 'fork(2) unavailable'; 16 | } 17 | 18 | my $server_address = ZMQTest->endpoint("test-zmq-ffi-$$-front"); 19 | my $worker_address = ZMQTest->endpoint("test-zmq-ffi-$$-back"); 20 | 21 | # Set up the proxy in its own process 22 | my $proxy = fork; 23 | die "fork failed: $!" unless defined $proxy; 24 | 25 | if ( $proxy == 0 ) { 26 | my $ctx = ZMQ::FFI->new(); 27 | 28 | my $front = $ctx->socket(ZMQ_PULL); 29 | $front->bind($server_address); 30 | 31 | my $back = $ctx->socket(ZMQ_PUSH); 32 | $back->bind($worker_address); 33 | 34 | $ctx->proxy($front, $back); 35 | warn "proxy exited: $!"; 36 | 37 | exit 0; 38 | } 39 | 40 | subtest 'proxy', sub { 41 | my $ctx = ZMQ::FFI->new(); 42 | 43 | my $server = $ctx->socket(ZMQ_PUSH); 44 | $server->connect($server_address); 45 | 46 | my $worker = $ctx->socket(ZMQ_PULL); 47 | $worker->connect($worker_address); 48 | 49 | my $message = 'ohhai'; 50 | $server->send($message); 51 | 52 | until ($worker->has_pollin) { 53 | 54 | # sleep for a 100ms to compensate for slow subscriber problem 55 | usleep 100_000; 56 | } 57 | 58 | my $payload = $worker->recv; 59 | is $payload, $message, "Message received"; 60 | 61 | kill TERM => $proxy; 62 | waitpid($proxy,0); 63 | }; 64 | 65 | 66 | done_testing; 67 | 68 | -------------------------------------------------------------------------------- /inc/ZmqSocket.pm.tt: -------------------------------------------------------------------------------- 1 | # 2 | # Module Generated by Template::Tiny on [% date %] 3 | # 4 | 5 | package ZMQ::FFI::[% zmqver %]::Socket; 6 | 7 | use FFI::Platypus; 8 | use FFI::Platypus::Buffer; 9 | use FFI::Platypus::Memory qw(malloc free memcpy); 10 | 11 | use Carp qw(croak carp); 12 | use Try::Tiny; 13 | 14 | use ZMQ::FFI::[% zmqver %]::Raw; 15 | use ZMQ::FFI::Custom::Raw; 16 | use ZMQ::FFI::Constants qw(:all); 17 | use ZMQ::FFI::Util qw(current_tid); 18 | [% lib_imports %] 19 | use Moo; 20 | use namespace::clean; 21 | 22 | no if $] >= 5.018, warnings => "experimental"; 23 | use feature 'switch'; 24 | 25 | with qw( 26 | ZMQ::FFI::SocketRole 27 | ZMQ::FFI::ErrorHelper 28 | ZMQ::FFI::Versioner 29 | ); 30 | 31 | my $FFI_LOADED; 32 | 33 | sub BUILD { 34 | my ($self) = @_; 35 | 36 | unless ($FFI_LOADED) { 37 | ZMQ::FFI::Custom::Raw::load($self->soname); 38 | ZMQ::FFI::[% zmqver %]::Raw::load($self->soname); 39 | $FFI_LOADED = 1; 40 | } 41 | 42 | # force init zmq_msg_t 43 | $self->_zmq_msg_t; 44 | 45 | # ensure clean edge state 46 | while ( $self->has_pollin ) { 47 | $self->recv(); 48 | } 49 | 50 | # set default linger 51 | $self->set_linger(0); 52 | } 53 | 54 | [% FOREACH method IN api_methods %] 55 | [%- [%- method -%] -%] 56 | [% END %] 57 | 58 | sub DEMOLISH { 59 | my ($self) = @_; 60 | 61 | # remove ourselves from the context object so that we dont leak 62 | $self->context->_remove_socket($self) if (defined $self->context); 63 | 64 | return if $self->socket_ptr == -1; 65 | 66 | $self->close(); 67 | } 68 | 69 | 1; 70 | 71 | # vim:ft=perl 72 | -------------------------------------------------------------------------------- /t/multipart.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_DEALER ZMQ_ROUTER ZMQ_DONTWAIT ZMQ_SNDMORE); 10 | 11 | use Scalar::Util qw(blessed); 12 | use Sub::Override; 13 | 14 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 15 | my $ctx = ZMQ::FFI->new(); 16 | 17 | my $d = $ctx->socket(ZMQ_DEALER); 18 | $d->set_identity('mydealer'); 19 | 20 | my $r = $ctx->socket(ZMQ_ROUTER); 21 | 22 | $d->connect($endpoint); 23 | $r->bind($endpoint); 24 | 25 | 26 | subtest 'multipart send/recv', 27 | sub { 28 | $d->send_multipart([qw(ABC DEF GHI)]); 29 | 30 | my @recvd = $r->recv_multipart; 31 | is_deeply 32 | \@recvd, 33 | [qw(mydealer ABC DEF GHI)], 34 | 'got dealer ident and message'; 35 | }; 36 | 37 | 38 | subtest 'multipart flags', 39 | sub { 40 | my $sock_class = blessed($d); 41 | 42 | my @expected_flags = ( 43 | ZMQ_SNDMORE | ZMQ_DONTWAIT, 44 | ZMQ_SNDMORE | ZMQ_DONTWAIT, 45 | ZMQ_DONTWAIT, 46 | ); 47 | 48 | my @expected_flags_strs = ( 49 | 'ZMQ_SNDMORE | ZMQ_DONTWAIT', 50 | 'ZMQ_SNDMORE | ZMQ_DONTWAIT', 51 | 'ZMQ_DONTWAIT', 52 | ); 53 | 54 | my $verify_flags = sub { 55 | my ($self, $msg, $flags) = @_; 56 | 57 | ok $flags == (shift @expected_flags), 58 | q($flags == ).(shift @expected_flags_strs); 59 | }; 60 | 61 | my $ov = Sub::Override->new( 62 | "${sock_class}::send", 63 | $verify_flags 64 | ); 65 | 66 | $d->send_multipart([qw(ABC DEF GHI)], ZMQ_DONTWAIT); 67 | }; 68 | 69 | 70 | done_testing; 71 | -------------------------------------------------------------------------------- /t/lib/ZMQTest.pm: -------------------------------------------------------------------------------- 1 | package ZMQTest; 2 | # ABSTRACT: Test helper library 3 | 4 | =head1 CLASS METHODS 5 | 6 | =head2 platform_can_fork 7 | 8 | Returns true if platform can use L syscall. 9 | 10 | Returns false on C which does not have a real L. 11 | 12 | =cut 13 | sub platform_can_fork { 14 | return $^O ne 'MSWin32'; 15 | } 16 | 17 | =head2 platform_can_sigaction 18 | 19 | Returns true if platform can use L. 20 | 21 | Returns false on C which does not have L. 22 | 23 | =cut 24 | sub platform_can_sigaction { 25 | return $^O ne 'MSWin32'; 26 | } 27 | 28 | =head2 platform_zmq_fd_sockopt_is_fd 29 | 30 | Returns true if the ZeroMQ socket option C is a C runtime file 31 | descriptor (which is an C). 32 | 33 | Returns false on C where C is of type C 34 | (which is a C). 35 | 36 | =cut 37 | sub platform_zmq_fd_sockopt_is_fd { 38 | return $^O ne 'MSWin32'; 39 | } 40 | 41 | =head2 platform_can_transport_zmq_ipc 42 | 43 | Returns true if platform can use L transport. 44 | 45 | This is currently false on systems such as C because they do not 46 | support Unix domain sockets. 47 | 48 | =cut 49 | sub platform_can_transport_zmq_ipc { 50 | return $^O ne 'MSWin32'; 51 | } 52 | 53 | =head2 endpoint 54 | 55 | ZMQTest->endpoint($name) 56 | 57 | Returns an appropriate endpoint string that is supported on the current 58 | platform. 59 | 60 | =cut 61 | sub endpoint { 62 | my ($class, $name) = @_; 63 | if( $class->platform_can_transport_zmq_ipc ) { 64 | return "ipc:///tmp/$name"; 65 | } else { 66 | return "inproc://$name"; 67 | } 68 | } 69 | 70 | 1; 71 | -------------------------------------------------------------------------------- /t/threads.t: -------------------------------------------------------------------------------- 1 | 2 | use strict; 3 | use warnings; 4 | 5 | use Test::More; 6 | 7 | use Time::HiRes qw(usleep); 8 | 9 | use ZMQ::FFI qw(ZMQ_REQ ZMQ_ROUTER); 10 | 11 | my $THREAD_COUNT = 10; 12 | 13 | my $can_use_threads = eval 'use threads; 1'; 14 | if (!$can_use_threads) { 15 | plan skip_all => 'This Perl not built to support threads'; 16 | } 17 | else { 18 | # three tests per thread plus NoWarnings test 19 | plan tests => $THREAD_COUNT * 3 + 1; 20 | require Test::NoWarnings; 21 | Test::NoWarnings->import(); 22 | } 23 | 24 | sub worker_task { 25 | my $id = shift; 26 | 27 | my $context = ZMQ::FFI->new(); 28 | my $worker = $context->socket(ZMQ_REQ); 29 | 30 | $worker->set_identity("worker-$id"); 31 | $worker->connect('tcp://localhost:5671'); 32 | 33 | $worker->send("ohhai from worker-$id"); 34 | 35 | my $reply = $worker->recv(); 36 | return ($reply, "worker-$id"); 37 | } 38 | 39 | my $context = ZMQ::FFI->new(); 40 | my $broker = $context->socket(ZMQ_ROUTER); 41 | 42 | $broker->bind('tcp://*:5671'); 43 | 44 | my @thr; 45 | for (1..$THREAD_COUNT) { 46 | push @thr, threads->create('worker_task', $_); 47 | } 48 | 49 | for (1..$THREAD_COUNT) { 50 | my ($identity, undef, $msg) = $broker->recv_multipart(); 51 | 52 | like $identity, qr/^worker-\d\d?$/, 53 | "got child thread identity '$identity'"; 54 | 55 | is $msg, "ohhai from $identity", 56 | "got child thread '$identity' hello message"; 57 | 58 | $broker->send_multipart([$identity, '', "goodbye $identity"]); 59 | } 60 | 61 | for my $thr (@thr) { 62 | my ($reply, $identity) = $thr->join(); 63 | is $reply, "goodbye $identity", 64 | "'$identity' got parent thread goodbye message"; 65 | } 66 | -------------------------------------------------------------------------------- /inc/ZmqContext.pm.tt: -------------------------------------------------------------------------------- 1 | # 2 | # Module Generated by Template::Tiny on [% date %] 3 | # 4 | 5 | package ZMQ::FFI::[% zmqver %]::Context; 6 | 7 | use FFI::Platypus; 8 | use ZMQ::FFI::Util qw(zmq_soname current_tid); 9 | use ZMQ::FFI::Constants qw(:all); 10 | use ZMQ::FFI::[% zmqver %]::Socket; 11 | use ZMQ::FFI::[% zmqver %]::Raw; 12 | use ZMQ::FFI::Custom::Raw; 13 | use Try::Tiny; 14 | use Scalar::Util qw(weaken); 15 | [% lib_imports %] 16 | use Moo; 17 | use namespace::clean; 18 | 19 | with qw( 20 | ZMQ::FFI::ContextRole 21 | ZMQ::FFI::ErrorHelper 22 | ZMQ::FFI::Versioner 23 | ); 24 | 25 | my $FFI_LOADED; 26 | 27 | sub BUILD { 28 | my ($self) = @_; 29 | 30 | unless ($FFI_LOADED) { 31 | ZMQ::FFI::Custom::Raw::load($self->soname); 32 | ZMQ::FFI::[% zmqver %]::Raw::load($self->soname); 33 | $FFI_LOADED = 1; 34 | } 35 | 36 | $self->init() 37 | } 38 | 39 | [% FOREACH method IN api_methods %] 40 | [%- [%- method -%] -%] 41 | [% END %] 42 | 43 | sub _add_socket { 44 | my ($self, $socket) = @_; 45 | weaken($self->sockets->{$socket} = $socket); 46 | } 47 | 48 | sub _remove_socket { 49 | my ($self, $socket) = @_; 50 | delete($self->sockets->{$socket}); 51 | } 52 | 53 | sub DEMOLISH { 54 | my ($self) = @_; 55 | 56 | return if $self->context_ptr == -1; 57 | 58 | # check defined to guard against 59 | # undef objects during global destruction 60 | if (defined $self->sockets) { 61 | for my $socket_k (keys %{$self->sockets}) { 62 | my $socket = $self->_remove_socket($socket_k); 63 | $socket->close() 64 | if defined $socket && $socket->socket_ptr != -1; 65 | } 66 | } 67 | 68 | $self->destroy(); 69 | } 70 | 71 | 1; 72 | 73 | # vim:ft=perl 74 | -------------------------------------------------------------------------------- /t/z85_encoding.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Warnings; 5 | use Test::Exception; 6 | 7 | use ZMQ::FFI; 8 | use ZMQ::FFI::Constants qw(ZMQ_REQ ZMQ_REP ZMQ_CURVE_SERVER ZMQ_CURVE_SECRETKEY 9 | ZMQ_CURVE_PUBLICKEY ZMQ_CURVE_SERVERKEY); 10 | 11 | my $c = ZMQ::FFI->new(); 12 | 13 | my ($major, $minor) = $c->version(); 14 | 15 | if ($major == 4) { 16 | if ($minor >= 1) { 17 | if ($c->has_capability("curve")) { 18 | my ($encoded, $priv) = $c->curve_keypair; 19 | 20 | my $decoded = $c->z85_decode( $encoded ); 21 | my $recoded = $c->z85_encode( $decoded ); 22 | 23 | is 24 | $recoded, 25 | $encoded; 26 | 27 | } else { 28 | # zmq >= 4.1 - libsodium is not installed, do nothing 29 | } 30 | } else { 31 | # zmq == 4.0 - can't assume libsodium is installed or uninstalled 32 | # so we can't run the z85_encode() method 33 | 34 | # verify that has capability is not implemented before 4.1 35 | throws_ok { $c->has_capability() } 36 | qr'has_capability not available', 37 | 'threw unimplemented error for < 4.1'; 38 | } 39 | } 40 | else { 41 | # zmq < 4.x - z85_encode / z85_decode and has capability are not implemented 42 | throws_ok { $c->z85_encode() } 43 | qr'z85_encode not available', 44 | 'threw unimplemented error in < 4.x'; 45 | 46 | throws_ok { $c->z85_decode() } 47 | qr'z85_decode not available', 48 | 'threw unimplemented error in < 4.x'; 49 | 50 | throws_ok { $c->has_capability() } 51 | qr'has_capability not available', 52 | 'threw unimplemented error for < 4.1'; 53 | } 54 | 55 | done_testing; 56 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/Custom/Raw.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::Custom::Raw; 2 | 3 | sub load { 4 | my ($soname) = @_; 5 | 6 | my $ffi = FFI::Platypus->new( lib => $soname // 'libzmq.so' ); 7 | my $target = caller; 8 | 9 | # 10 | # for get/set sockopt create ffi functions for each possible opt type 11 | # 12 | 13 | # int zmq_getsockopt(void *sock, int opt, void *val, size_t *len) 14 | 15 | $ffi->attach( 16 | ['zmq_getsockopt' => "${target}::zmq_getsockopt_binary"] 17 | => ['pointer', 'int', 'pointer', 'size_t*'] => 'int' 18 | ); 19 | 20 | $ffi->attach( 21 | ['zmq_getsockopt' => "${target}::zmq_getsockopt_int"] 22 | => ['pointer', 'int', 'int*', 'size_t*'] => 'int' 23 | ); 24 | 25 | $ffi->attach( 26 | ['zmq_getsockopt' => "${target}::zmq_getsockopt_int64"] 27 | => ['pointer', 'int', 'sint64*', 'size_t*'] => 'int' 28 | ); 29 | 30 | $ffi->attach( 31 | ['zmq_getsockopt' => "${target}::zmq_getsockopt_uint64"] 32 | => ['pointer', 'int', 'uint64*', 'size_t*'] => 'int' 33 | ); 34 | 35 | # int zmq_setsockopt(void *sock, int opt, const void *val, size_t len) 36 | 37 | $ffi->attach( 38 | ['zmq_setsockopt' => "${target}::zmq_setsockopt_binary"] 39 | => ['pointer', 'int', 'pointer', 'size_t'] => 'int' 40 | ); 41 | 42 | $ffi->attach( 43 | ['zmq_setsockopt' => "${target}::zmq_setsockopt_int"] 44 | => ['pointer', 'int', 'int*', 'size_t'] => 'int' 45 | ); 46 | 47 | $ffi->attach( 48 | ['zmq_setsockopt' => "${target}::zmq_setsockopt_int64"] 49 | => ['pointer', 'int', 'sint64*', 'size_t'] => 'int' 50 | ); 51 | 52 | $ffi->attach( 53 | ['zmq_setsockopt' => "${target}::zmq_setsockopt_uint64"] 54 | => ['pointer', 'int', 'uint64*', 'size_t'] => 'int' 55 | ); 56 | } 57 | 58 | 1; 59 | -------------------------------------------------------------------------------- /scripts/gen_modules.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use warnings; 4 | use 5.012; 5 | 6 | use Template::Tiny; 7 | use Path::Class qw(file); 8 | 9 | use inc::ZMQ2::ContextWrappers; 10 | use inc::ZMQ2::SocketWrappers; 11 | 12 | use inc::ZMQ3::ContextWrappers; 13 | use inc::ZMQ3::SocketWrappers; 14 | 15 | use inc::ZMQ4::ContextWrappers; 16 | use inc::ZMQ4::SocketWrappers; 17 | 18 | use inc::ZMQ4_1::ContextWrappers; 19 | use inc::ZMQ4_1::SocketWrappers; 20 | 21 | my @wrappers; 22 | 23 | for my $zmqver (qw(ZMQ2 ZMQ3 ZMQ4 ZMQ4_1)) { 24 | my $context_wrapper = "inc::${zmqver}::ContextWrappers"; 25 | my $socket_wrapper = "inc::${zmqver}::SocketWrappers"; 26 | 27 | push @wrappers, $context_wrapper->new( zmqver => $zmqver ); 28 | push @wrappers, $socket_wrapper->new( zmqver => $zmqver ); 29 | } 30 | 31 | gen_module($_) for @wrappers; 32 | 33 | sub gen_module { 34 | my ($wrapper) = @_; 35 | 36 | my $socket_check = 37 | q(if ($_[0]->socket_ptr == -1) { 38 | carp "Operation on closed socket"; 39 | return; 40 | }); 41 | 42 | my $api_wrappers = $wrapper->wrappers; 43 | 44 | my %tt_vars = ( 45 | date => split("\n", scalar(qx{date -u})), 46 | zmqver => $wrapper->zmqver, 47 | closed_socket_check => $socket_check, 48 | api_methods => $wrapper->api_methods, 49 | lib_imports => $wrapper->lib_imports, 50 | %$api_wrappers, 51 | ); 52 | 53 | my $input = $wrapper->template->slurp(); 54 | 55 | # Processing twice so template tokens used in 56 | # zmq function wrappers also get interoplated 57 | my $output; 58 | Template::Tiny->new->process(\$input, \%tt_vars, \$output); 59 | Template::Tiny->new->process(\$output, \%tt_vars, \$output); 60 | 61 | my $target = $wrapper->target; 62 | say "Generating '$target'"; 63 | $target->spew($output) 64 | } 65 | 66 | -------------------------------------------------------------------------------- /xt/test_versions.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | function zmq_version { 6 | echo $(\ 7 | PERL5LIB=lib:$PERL5LIB \ 8 | perl -M'ZMQ::FFI::Util q(zmq_version)' \ 9 | -E 'print join " ",zmq_version'\ 10 | ) 11 | } 12 | 13 | # This assumes libzmqs have been installed to 14 | # ~/.zmq-ffi/usr//lib/libzmq.so, e.g. 15 | # ~/.zmq-ffi/usr/zeromq2-x/lib/libzmq.so. A docker testing environment is 16 | # provided that sets this up according, see the BUILD section in the readme 17 | function get_ld_dir { 18 | libzmq_dir="$HOME/.zmq-ffi/usr/$1/lib" 19 | 20 | if test -z "$libzmq_dir/libzmq.so"; then 21 | echo "No libzmq.so found in $libzmq_dir" >&2 22 | exit 1 23 | fi 24 | 25 | echo "$libzmq_dir" 26 | } 27 | 28 | function local_test { 29 | test_version=$1 30 | 31 | if [[ "$test_version" == "libzmq" ]]; then 32 | export LD_LIBRARY_PATH="$(get_ld_dir libzmq)" 33 | else 34 | export LD_LIBRARY_PATH="$(get_ld_dir zeromq$test_version)" 35 | fi 36 | 37 | echo -e "\nTesting zeromq" \ 38 | "$(zmq_version | tr ' ' '.')" 39 | 40 | run_prove 41 | 42 | # extra test to check that out-of-order cleanup during global destruction 43 | # is handled and doesn't cause a program hang 44 | PERL5LIB=lib:$PERL5LIB timeout 1 perl xt/gc_global_destruction.pl \ 45 | || (\ 46 | echo "xt/gc_global_destruction.pl timed out during cleanup" >&2 \ 47 | && exit 1 \ 48 | ) 49 | } 50 | 51 | function run_prove { 52 | prove -lvr t 53 | 54 | # test with different locale 55 | LANG=fr_FR.utf8 prove -lvr t 56 | } 57 | 58 | for v in "2-x" "3-x" "4-x" "4-1" "libzmq" 59 | do 60 | local_test $v 61 | done 62 | 63 | # extra test to verify sonames arg is honored 64 | LD_LIBRARY_PATH="$(get_ld_dir zeromq2-x)" 65 | LD_LIBRARY_PATH+=":$(get_ld_dir zeromq3-x)" 66 | export LD_LIBRARY_PATH 67 | 68 | PERL5LIB=lib:$PERL5LIB perl xt/sonames.pl 69 | 70 | -------------------------------------------------------------------------------- /t/unicode.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use utf8; 5 | use Test::More; 6 | use Test::Warnings; 7 | use List::Util qw(sum); 8 | use lib 't/lib'; 9 | use ZMQTest; 10 | 11 | use ZMQ::FFI qw(ZMQ_PUSH ZMQ_PULL); 12 | 13 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 14 | my $ctx = ZMQ::FFI->new(); 15 | 16 | my $s1 = $ctx->socket(ZMQ_PUSH); 17 | $s1->connect($endpoint); 18 | 19 | my $s2 = $ctx->socket(ZMQ_PULL); 20 | $s2->bind($endpoint); 21 | 22 | my $pack_template = 'U*'; 23 | my $msg = 'werde ich von Dir hören?'; 24 | 25 | subtest 'send_unicode_bytes' => sub { 26 | ok utf8::is_utf8($msg), "created unicode message"; 27 | $s1->send($msg); 28 | 29 | my $recvd = $s2->recv(); 30 | 31 | { 32 | use bytes; 33 | 34 | is length($recvd), length($msg), "byte length matches"; 35 | 36 | my @sent_bytes = unpack($pack_template, $msg); 37 | my @recvd_bytes = unpack($pack_template, $recvd); 38 | 39 | is_deeply 40 | \@recvd_bytes, 41 | \@sent_bytes, 42 | "bytes match" 43 | ; 44 | } 45 | }; 46 | 47 | subtest 'send_multipart_unicode_bytes' => sub { 48 | my $multipart = [ ($msg) x 3 ]; 49 | 50 | my $is_unicode = 1; 51 | $is_unicode &&= utf8::is_utf8($_) for (@$multipart); 52 | 53 | ok $is_unicode, "created unicode message parts"; 54 | 55 | $s1->send_multipart($multipart); 56 | 57 | my @recvd = $s2->recv_multipart(); 58 | 59 | { 60 | use bytes; 61 | 62 | my $sent_len = sum(map { length($_) } @$multipart); 63 | my $recvd_len = sum(map { length($_) } @recvd); 64 | 65 | is $recvd_len, $sent_len, "byte length matches"; 66 | 67 | my @sent_bytes = map { unpack( $pack_template, $_ ) } @$multipart; 68 | my @recvd_bytes = map { unpack( $pack_template, $_ ) } @recvd; 69 | 70 | is_deeply 71 | \@recvd_bytes, 72 | \@sent_bytes, 73 | "bytes match" 74 | ; 75 | } 76 | }; 77 | 78 | done_testing(); 79 | -------------------------------------------------------------------------------- /bench/zmq-bench.pl: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use 5.012; 3 | 4 | use FFI::Platypus::Declare; 5 | use ZMQ::LibZMQ3; 6 | 7 | use ZMQ::FFI::Constants qw(:all); 8 | 9 | use Benchmark qw(:all); 10 | 11 | lib 'libzmq.so'; 12 | 13 | attach( 14 | ['zmq_ctx_new' => 'zmqffi_ctx_new'] 15 | => [] => 'pointer' 16 | ); 17 | 18 | attach( 19 | ['zmq_socket' => 'zmqffi_socket'] 20 | => ['pointer', 'int'] => 'pointer' 21 | ); 22 | 23 | attach( 24 | ['zmq_bind' => 'zmqffi_bind'] 25 | => ['pointer', 'string'] => 'int' 26 | ); 27 | 28 | attach( 29 | ['zmq_send' => 'zmqffi_send'] 30 | => ['pointer', 'string', 'size_t', 'int'] => 'int' 31 | ); 32 | 33 | attach( 34 | ['zmq_version' => 'zmqffi_version'] 35 | => ['int*', 'int*', 'int*'] => 'void' 36 | ); 37 | 38 | my $ffi_ctx = zmqffi_ctx_new(); 39 | die 'ffi ctx error' unless $ffi_ctx; 40 | 41 | my $ffi_socket = zmqffi_socket($ffi_ctx, ZMQ_PUB); 42 | die 'ffi socket error' unless $ffi_socket; 43 | 44 | my $rv; 45 | 46 | $rv = zmqffi_bind($ffi_socket, "ipc:///tmp/zmq-bench-ffi"); 47 | die 'ffi bind error' if $rv == -1; 48 | 49 | my $xs_ctx = zmq_ctx_new(); 50 | die 'xs ctx error' unless $xs_ctx; 51 | 52 | my $xs_socket = zmq_socket($xs_ctx, ZMQ_PUB); 53 | die 'xs socket error' unless $xs_socket; 54 | 55 | $rv = zmq_bind($xs_socket, "ipc:///tmp/zmq-bench-xs"); 56 | die 'xs bind error' if $rv == -1; 57 | 58 | 59 | my ($major, $minor, $patch); 60 | zmqffi_version(\$major, \$minor, \$patch); 61 | 62 | say "FFI ZMQ Version: " . join(".", $major, $minor, $patch); 63 | say "XS ZMQ Version: " . join(".", ZMQ::LibZMQ3::zmq_version()); 64 | 65 | # for (1..10_000_000) { 66 | # # die 'xs send error ' if -1 == zmq_send($xs_socket, 'xs', 2, 0); 67 | # die 'ffi send error' if -1 == zmqffi_send($ffi_socket, 'ffi', 3, 0); 68 | # } 69 | 70 | my $r = timethese 1_000_000, { 71 | 'XS' => sub { 72 | die 'xs send error ' if -1 == zmq_send($xs_socket, 'xs', 2, 0); 73 | }, 74 | 75 | 'FFI' => sub { 76 | die 'ffi send error' if -1 == zmqffi_send($ffi_socket, 'ffi', 3, 0); 77 | }, 78 | }; 79 | 80 | cmpthese($r); 81 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/ErrorHelper.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::ErrorHelper; 2 | 3 | use Carp; 4 | use FFI::Platypus; 5 | use ZMQ::FFI::Util qw(zmq_version); 6 | 7 | use Moo::Role; 8 | 9 | has die_on_error => ( 10 | is => 'rw', 11 | default => 1, 12 | ); 13 | 14 | has last_errno => ( 15 | is => 'rw', 16 | lazy => 1, 17 | default => 0, 18 | ); 19 | 20 | sub last_strerror { 21 | my ($self) = @_; 22 | 23 | my $strerr; 24 | { 25 | no strict q/refs/; 26 | my $class = ref $self; 27 | $strerr = &{"$class\::zmq_strerror"}($self->last_errno); 28 | } 29 | 30 | return $strerr; 31 | } 32 | 33 | sub has_error { 34 | return $_[0]->last_errno; 35 | } 36 | 37 | sub check_error { 38 | my ($self, $func, $rc) = @_; 39 | 40 | $self->{last_errno} = 0; 41 | 42 | my $errno; 43 | { 44 | no strict q/refs/; 45 | my $class = ref $self; 46 | $errno = &{"$class\::zmq_errno"}(); 47 | } 48 | 49 | if ( $rc == -1 ) { 50 | $self->{last_errno} = $errno; 51 | 52 | if ($self->die_on_error) { 53 | $self->fatal($func) 54 | } 55 | } 56 | } 57 | 58 | sub check_null { 59 | my ($self, $func, $obj) = @_; 60 | 61 | $self->{last_errno} = 0; 62 | 63 | my $errno; 64 | { 65 | no strict q/refs/; 66 | my $class = ref $self; 67 | $errno = &{"$class\::zmq_errno"}(); 68 | } 69 | 70 | unless ($obj) { 71 | $self->{last_errno} = $errno; 72 | 73 | if ($self->die_on_error) { 74 | $self->fatal($func) 75 | } 76 | } 77 | } 78 | 79 | sub fatal { 80 | my ($self, $func) = @_; 81 | 82 | my $strerr = $self->last_strerror; 83 | confess "$func: $strerr"; 84 | } 85 | 86 | sub bad_version { 87 | my ($self, $verstr, $msg, $use_die) = @_; 88 | 89 | if ($use_die) { 90 | die "$msg\n" 91 | . "your version: $verstr"; 92 | } 93 | else { 94 | croak "$msg\n" 95 | . "your version: $verstr"; 96 | } 97 | } 98 | 99 | 1; 100 | -------------------------------------------------------------------------------- /t/device.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use Test::Exception; 7 | use lib 't/lib'; 8 | use ZMQTest; 9 | 10 | use ZMQ::FFI qw(ZMQ_STREAMER ZMQ_PUSH ZMQ_PULL); 11 | use ZMQ::FFI::Util qw(zmq_version); 12 | 13 | use Time::HiRes q(usleep); 14 | use POSIX ":sys_wait_h"; 15 | 16 | if( ! ZMQTest->platform_can_fork ) { 17 | plan skip_all => 'fork(2) unavailable'; 18 | } 19 | 20 | my $server_address = ZMQTest->endpoint("test-zmq-ffi-$$-front"); 21 | my $worker_address = ZMQTest->endpoint("test-zmq-ffi-$$-back"); 22 | 23 | my $device; 24 | 25 | sub mkdevice { 26 | my $ctx = ZMQ::FFI->new(); 27 | 28 | my $front = $ctx->socket(ZMQ_PULL); 29 | $front->bind($server_address); 30 | 31 | my $back = $ctx->socket(ZMQ_PUSH); 32 | $back->bind($worker_address); 33 | 34 | $ctx->device(ZMQ_STREAMER, $front, $back); 35 | warn "device exited: $!"; 36 | 37 | exit 0; 38 | } 39 | 40 | my ($major) = zmq_version(); 41 | if ($major > 2) { 42 | throws_ok { mkdevice() } 43 | qr/zmq_device not available in zmq >= 3\.x/, 44 | 'zmq_device version error for zmq >= 3.x'; 45 | } 46 | else { 47 | # Set up the streamer device in its own process 48 | $device = fork; 49 | die "fork failed: $!" unless defined $device; 50 | 51 | if ( $device == 0 ) { 52 | mkdevice(); 53 | } 54 | } 55 | 56 | subtest 'device', sub { 57 | my $ctx = ZMQ::FFI->new(); 58 | 59 | if ($major > 2) { 60 | plan skip_all => 'zmq_device not available in zmq >= 3.x'; 61 | } 62 | 63 | my $server = $ctx->socket(ZMQ_PUSH); 64 | $server->connect($server_address); 65 | 66 | my $worker = $ctx->socket(ZMQ_PULL); 67 | $worker->connect($worker_address); 68 | 69 | my $message = 'ohhai'; 70 | $server->send($message); 71 | 72 | until ($worker->has_pollin) { 73 | 74 | # sleep for a 100ms to compensate for slow subscriber problem 75 | usleep 100_000; 76 | } 77 | 78 | my $payload = $worker->recv; 79 | is $payload, $message, "Message received"; 80 | 81 | kill TERM => $device; 82 | waitpid($device,0); 83 | }; 84 | 85 | 86 | done_testing; 87 | 88 | -------------------------------------------------------------------------------- /xt/sonames.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Exception; 6 | 7 | use ZMQ::FFI::Util qw(zmq_version); 8 | use ZMQ::FFI qw(:all); 9 | 10 | subtest 'util zmq_version different sonames', 11 | sub { 12 | 13 | ok 14 | join('.', zmq_version('libzmq.so.1')) 15 | =~ m/^2(\.\d+){2}$/, 16 | 'libzmq.so.1 soname gives 2.x version'; 17 | 18 | ok 19 | join('.', zmq_version('libzmq.so.3')) 20 | =~ m/^[34](\.\d+){2}$/, 21 | 'libzmq.so.3 soname gives 3.x/4.x version'; 22 | 23 | throws_ok { zmq_version('libzmq.so.X') } 24 | qr/Could not find zmq_version in 'libzmq\.so\.X'/, 25 | 'bad soname throws error'; 26 | 27 | }; 28 | 29 | subtest 'parallel version contexts', 30 | sub 31 | { 32 | 33 | my $ctx_v2 = ZMQ::FFI->new(soname => 'libzmq.so.1'); 34 | my $ctx_v3 = ZMQ::FFI->new(soname => 'libzmq.so.3'); 35 | 36 | ok 37 | join('.', $ctx_v2->version) 38 | =~ m/^2(\.\d+){2}$/, 39 | 'libzmq.so.1 soname gives 2.x version'; 40 | 41 | ok 42 | join('.', $ctx_v3->version) 43 | =~ m/^[34](\.\d+){2}$/, 44 | 'libzmq.so.3 soname gives 3.x/4.x version'; 45 | 46 | throws_ok { ZMQ::FFI->new(soname => 'libzmq.so.X') } 47 | qr/Failed to load 'libzmq\.so\.X'/, 48 | 'bad soname throws error'; 49 | 50 | 51 | my $v2_endpoint = "ipc:///tmp/zmq-ffi-ctx2-$$"; 52 | my $v3_endpoint = "ipc:///tmp/zmq-ffi-ctx3-$$"; 53 | 54 | my $s_v2_req = $ctx_v2->socket(ZMQ_REQ); 55 | $s_v2_req->connect($v2_endpoint); 56 | 57 | my $s_v3_req = $ctx_v3->socket(ZMQ_REQ); 58 | $s_v3_req->connect($v3_endpoint); 59 | 60 | my $s_v2_rep = $ctx_v2->socket(ZMQ_REP); 61 | $s_v2_rep->bind($v2_endpoint); 62 | 63 | my $s_v3_rep = $ctx_v3->socket(ZMQ_REP); 64 | $s_v3_rep->bind($v3_endpoint); 65 | 66 | $s_v2_req->send(join('.', $ctx_v2->version)); 67 | $s_v3_req->send(join('.', $ctx_v3->version)); 68 | 69 | ok 70 | $s_v2_rep->recv() 71 | =~ m/^2(\.\d+){2}$/, 72 | 'got zmq 2.x message'; 73 | 74 | ok 75 | $s_v3_rep->recv() 76 | =~ m/^[34](\.\d+){2}$/, 77 | 'got zmq 3.x/4.x message'; 78 | }; 79 | 80 | done_testing; 81 | 82 | -------------------------------------------------------------------------------- /inc/ZMQ4/ContextWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ4::ContextWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | extends 'inc::ZMQ3::ContextWrappers'; 7 | 8 | has +lib_imports => ( 9 | is => 'ro', 10 | default => q( 11 | use FFI::Platypus::Memory qw(free malloc); 12 | use FFI::Platypus::Buffer qw(buffer_to_scalar); 13 | ), 14 | ); 15 | 16 | sub destroy_tt {q( 17 | sub destroy { 18 | my ($self) = @_; 19 | 20 | return if $self->context_ptr == -1; 21 | 22 | # don't try to cleanup context cloned from another thread 23 | return unless $self->_tid == current_tid(); 24 | 25 | # don't try to cleanup context copied from another process (fork) 26 | return unless $self->_pid == $$; 27 | 28 | $self->check_error( 29 | 'zmq_ctx_term', 30 | zmq_ctx_term($self->context_ptr) 31 | ); 32 | 33 | $self->context_ptr(-1); 34 | } 35 | )} 36 | 37 | sub curve_keypair_tt {q( 38 | sub curve_keypair { 39 | my ($self) = @_; 40 | 41 | my $public_key_buf = malloc(41); 42 | my $secret_key_buf = malloc(41); 43 | 44 | $self->check_error( 45 | 'zmq_curve_keypair', 46 | zmq_curve_keypair($public_key_buf, $secret_key_buf) 47 | ); 48 | 49 | my $public_key = buffer_to_scalar($public_key_buf, 41); 50 | my $secret_key = buffer_to_scalar($secret_key_buf, 41); 51 | free($public_key_buf); 52 | free($secret_key_buf); 53 | 54 | return ($public_key, $secret_key); 55 | } 56 | )} 57 | 58 | sub z85_encode_tt {q( 59 | sub z85_encode { 60 | my ($self, $data) = @_; 61 | 62 | my $dest_buf = malloc(41); 63 | 64 | my $checked_data = substr($data, 0, 32); 65 | 66 | $self->check_null( 67 | 'zmq_z85_encode', 68 | zmq_z85_encode( $dest_buf, $checked_data, length($checked_data) ) 69 | ); 70 | 71 | my $dest = buffer_to_scalar($dest_buf, 41); 72 | free($dest_buf); 73 | 74 | return $dest; 75 | } 76 | )} 77 | 78 | sub z85_decode_tt {q( 79 | sub z85_decode { 80 | my ($self, $string) = @_; 81 | 82 | my $dest_buf = malloc(32); 83 | 84 | $self->check_null( 85 | 'zmq_z86_decode', 86 | zmq_z85_decode($dest_buf, $string) 87 | ); 88 | 89 | my $dest = buffer_to_scalar($dest_buf, 32); 90 | free($dest_buf); 91 | 92 | return $dest; 93 | } 94 | )} 95 | 96 | 97 | 1; 98 | -------------------------------------------------------------------------------- /inc/ZMQ3/ContextWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ3::ContextWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | extends 'inc::ZMQ2::ContextWrappers'; 7 | 8 | sub init_tt {q( 9 | sub init { 10 | my ($self) = @_; 11 | 12 | try { 13 | $self->context_ptr( zmq_ctx_new() ); 14 | $self->check_null('zmq_ctx_new', $self->context_ptr); 15 | } 16 | catch { 17 | $self->context_ptr(-1); 18 | die $_; 19 | }; 20 | 21 | if ( $self->has_threads ) { 22 | $self->set(ZMQ_IO_THREADS, $self->threads); 23 | } 24 | 25 | if ( $self->has_max_sockets ) { 26 | $self->set(ZMQ_MAX_SOCKETS, $self->max_sockets); 27 | } 28 | } 29 | )} 30 | 31 | sub get_tt {q( 32 | sub get { 33 | my ($self, $option) = @_; 34 | 35 | my $option_val = zmq_ctx_get($self->context_ptr, $option); 36 | $self->check_error('zmq_ctx_get', $option_val); 37 | 38 | return $option_val; 39 | } 40 | )} 41 | 42 | sub set_tt {q( 43 | sub set { 44 | my ($self, $option, $option_val) = @_; 45 | 46 | $self->check_error( 47 | 'zmq_ctx_set', 48 | zmq_ctx_set($self->context_ptr, $option, $option_val) 49 | ); 50 | } 51 | )} 52 | 53 | sub proxy_tt {q( 54 | sub proxy { 55 | my ($self, $frontend, $backend, $capture) = @_; 56 | 57 | $self->check_error( 58 | 'zmq_proxy', 59 | zmq_proxy( 60 | $frontend->socket_ptr, 61 | $backend->socket_ptr, 62 | defined $capture ? $capture->socket_ptr : undef, 63 | ) 64 | ); 65 | } 66 | )} 67 | 68 | sub device_tt {q( 69 | sub device { 70 | my ($self, $type, $frontend, $backend) = @_; 71 | 72 | $self->bad_version( 73 | $self->verstr, 74 | "zmq_device not available in zmq >= 3.x", 75 | ); 76 | } 77 | )} 78 | 79 | sub destroy_tt {q( 80 | sub destroy { 81 | my ($self) = @_; 82 | 83 | return if $self->context_ptr == -1; 84 | 85 | # don't try to cleanup context cloned from another thread 86 | return unless $self->_tid == current_tid(); 87 | 88 | # don't try to cleanup context copied from another process (fork) 89 | return unless $self->_pid == $$; 90 | 91 | $self->check_error( 92 | 'zmq_ctx_destroy', 93 | zmq_ctx_destroy($self->context_ptr) 94 | ); 95 | 96 | $self->context_ptr(-1); 97 | } 98 | )} 99 | 100 | 1; 101 | -------------------------------------------------------------------------------- /t/curve_keypair.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Test::Warnings; 5 | use Test::Exception; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI; 10 | use ZMQ::FFI::Constants qw(ZMQ_REQ ZMQ_REP ZMQ_CURVE_SERVER ZMQ_CURVE_SECRETKEY 11 | ZMQ_CURVE_PUBLICKEY ZMQ_CURVE_SERVERKEY); 12 | 13 | my $c = ZMQ::FFI->new(); 14 | 15 | my ($major, $minor) = $c->version(); 16 | 17 | my $e = ZMQTest->endpoint("test-zmq-ffi-$$"); 18 | 19 | if ($major == 4) { 20 | if ($minor >= 1) { 21 | if ($c->has_capability("curve")) { 22 | my ($srv_public, $srv_secret); 23 | lives_ok { ($srv_public, $srv_secret) = $c->curve_keypair() } 24 | 'Generated curve keypair'; 25 | 26 | my $s1 = $c->socket(ZMQ_REP); 27 | 28 | $s1->set(ZMQ_CURVE_SERVER, 'int', '1'); 29 | $s1->set(ZMQ_CURVE_SECRETKEY, 'string', $srv_secret); 30 | 31 | $s1->bind($e); 32 | 33 | my ($cli_public, $cli_secret); 34 | lives_ok { ($cli_public, $cli_secret) = $c->curve_keypair() } 35 | 'Generated curve keypair'; 36 | 37 | my $s2 = $c->socket(ZMQ_REQ); 38 | 39 | $s2->set(ZMQ_CURVE_SERVERKEY, 'string', $srv_public); 40 | $s2->set(ZMQ_CURVE_PUBLICKEY, 'string', $cli_public); 41 | $s2->set(ZMQ_CURVE_SECRETKEY, 'string', $cli_secret); 42 | 43 | $s2->connect($e); 44 | $s2->send("psst"); 45 | 46 | is 47 | $s1->recv(), 48 | 'psst', 49 | 'received message'; 50 | 51 | } else { 52 | # zmq >= 4.1 - libsodium is not installed, do nothing 53 | } 54 | } else { 55 | # zmq == 4.0 - can't assume libsodium is installed or uninstalled 56 | # so we can't run the curve_keypair() method 57 | 58 | # verify that has capability is not implemented before 4.1 59 | throws_ok { $c->has_capability() } 60 | qr'has_capability not available', 61 | 'threw unimplemented error for < 4.1'; 62 | } 63 | } 64 | else { 65 | # zmq < 4.x - curve keypair and has capability are not implemented 66 | throws_ok { $c->curve_keypair() } 67 | qr'curve_keypair not available', 68 | 'threw unimplemented error for < 4.x'; 69 | 70 | throws_ok { $c->has_capability() } 71 | qr'has_capability not available', 72 | 'threw unimplemented error for < 4.1'; 73 | } 74 | 75 | done_testing; 76 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/SocketRole.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::SocketRole; 2 | 3 | use FFI::Platypus; 4 | use FFI::Platypus::Memory qw(malloc); 5 | 6 | use ZMQ::FFI::Constants qw(zmq_msg_t_size); 7 | use ZMQ::FFI::Util qw(current_tid zmq_version); 8 | 9 | use Moo::Role; 10 | 11 | has soname => ( 12 | is => 'ro', 13 | required => 1, 14 | ); 15 | 16 | # zmq constant socket type, e.g. ZMQ_REQ 17 | has type => ( 18 | is => 'ro', 19 | required => 1, 20 | ); 21 | 22 | # real underlying zmq socket pointer 23 | has socket_ptr => ( 24 | is => 'rw', 25 | default => -1, 26 | ); 27 | 28 | # a weak reference to the context object 29 | has context => ( 30 | is => 'ro', 31 | required => 1, 32 | weak_ref => 1, 33 | ); 34 | 35 | # message struct to reuse when sending/receiving 36 | has _zmq_msg_t => ( 37 | is => 'ro', 38 | lazy => 1, 39 | builder => '_build_zmq_msg_t', 40 | ); 41 | 42 | # used to make sure we handle fork situations correctly 43 | has _pid => ( 44 | is => 'ro', 45 | default => sub { $$ }, 46 | ); 47 | 48 | # used to make sure we handle thread situations correctly 49 | has _tid => ( 50 | is => 'ro', 51 | default => sub { current_tid() }, 52 | ); 53 | 54 | has sockopt_sizes => ( 55 | is => 'ro', 56 | lazy => 1, 57 | builder => '_build_sockopt_sizes' 58 | ); 59 | 60 | has event_size => ( 61 | is => 'ro', 62 | lazy => 1, 63 | builder => '_build_event_size' 64 | ); 65 | 66 | sub _build_zmq_msg_t { 67 | my ($self) = @_; 68 | 69 | my $msg_ptr; 70 | { 71 | no strict q/refs/; 72 | my $class = ref $self; 73 | $msg_ptr = malloc(zmq_msg_t_size); 74 | &{"$class\::zmq_msg_init"}($msg_ptr); 75 | } 76 | 77 | return $msg_ptr; 78 | } 79 | 80 | sub _build_sockopt_sizes { 81 | my $ffi = FFI::Platypus->new(); 82 | 83 | return { 84 | int => $ffi->sizeof('int'), 85 | sint64 => $ffi->sizeof('sint64'), 86 | uint64 => $ffi->sizeof('uint64'), 87 | }; 88 | } 89 | 90 | sub _build_event_size { 91 | my $ffi = FFI::Platypus->new(); 92 | 93 | my ($major, $minor, $patch) = zmq_version(); 94 | 95 | my $size; 96 | 97 | if ($major == 3) { 98 | $size = $ffi->sizeof('int') * 2 + $ffi->sizeof('opaque'); 99 | } 100 | elsif ($major > 3) { 101 | $size = $ffi->sizeof('uint16', 'sint32'); 102 | } 103 | 104 | return $size; 105 | } 106 | 107 | requires qw( 108 | connect 109 | disconnect 110 | bind 111 | unbind 112 | send 113 | send_multipart 114 | recv 115 | recv_multipart 116 | get_fd 117 | get_linger 118 | set_linger 119 | get_identity 120 | set_identity 121 | subscribe 122 | unsubscribe 123 | has_pollin 124 | has_pollout 125 | get 126 | set 127 | close 128 | monitor 129 | recv_event 130 | ); 131 | 132 | 1; 133 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Run Tests 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | pull_request: 8 | 9 | jobs: 10 | dist: 11 | name: Make distribution using Dist::Zilla 12 | runs-on: ubuntu-latest 13 | steps: 14 | - name: Checkout code 15 | uses: actions/checkout@v3 16 | - name: Make distribution 17 | shell: bash 18 | run: | 19 | ./docker-run sh -c " 20 | dzil authordeps --missing | cpanm -n; 21 | dzil clean && dzil build --in build-dir" 22 | - name: Upload artifact 23 | uses: actions/upload-artifact@v3 24 | with: 25 | name: dist 26 | path: ./build-dir 27 | test: 28 | needs: dist 29 | runs-on: ${{ matrix.os }} 30 | strategy: 31 | fail-fast: false 32 | matrix: 33 | os: [macos-latest, windows-latest, ubuntu-latest] 34 | perl: ['5'] 35 | perl-threaded: [false] 36 | alien: [false, true] 37 | include: 38 | - { os: 'ubuntu-latest', perl: "5.14" } 39 | - { os: 'ubuntu-latest', perl: "5.16" } 40 | - { os: 'ubuntu-latest', perl: "5.20" } 41 | - { os: 'ubuntu-latest', perl: "5.30" } 42 | - { os: 'ubuntu-latest', perl: "5.32" } 43 | - { os: 'ubuntu-latest', perl: "5.34" } 44 | - { os: 'ubuntu-latest', perl: "5.36" } 45 | - { os: 'ubuntu-latest', perl: "5" , perl-threaded: true } 46 | name: Perl ${{ matrix.perl }} on ${{ matrix.os }}, ${{ matrix.alien }} 47 | 48 | steps: 49 | - name: Get dist artifact 50 | uses: actions/download-artifact@v3 51 | with: 52 | name: dist 53 | 54 | - name: Set up perl 55 | uses: shogo82148/actions-setup-perl@v1 56 | if: matrix.os != 'windows-latest' 57 | with: 58 | perl-version: ${{ matrix.perl }} 59 | multi-thread: ${{ matrix.perl-threaded }} 60 | - name: Set up perl (Strawberry) 61 | uses: shogo82148/actions-setup-perl@v1 62 | if: matrix.os == 'windows-latest' 63 | with: 64 | distribution: 'strawberry' 65 | 66 | - run: perl -V 67 | 68 | - name: Set up ZeroMQ (homebrew) 69 | if: matrix.os == 'macos-latest' && ! matrix.alien 70 | run: | 71 | brew install zeromq 72 | 73 | - name: Set up ZeroMQ (vcpkg) 74 | if: matrix.os == 'windows-latest' && ! matrix.alien 75 | run: | 76 | vcpkg install zeromq:x64-windows 77 | copy C:/vcpkg/packages/zeromq_x64-windows/bin/libzmq*.dll libzmq.dll 78 | echo $pwd.Path | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 79 | 80 | - name: Install Alien::ZMQ::latest 81 | if: matrix.alien 82 | run: | 83 | cpanm -nq Alien::ZMQ::latest 84 | 85 | - name: Install Perl deps 86 | run: | 87 | cpanm --notest --installdeps . 88 | 89 | - name: Run tests 90 | run: | 91 | cpanm --verbose --test-only . 92 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/Util.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::Util; 2 | 3 | # ABSTRACT: zmq convenience functions 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use FFI::Platypus; 9 | use FFI::CheckLib qw(find_lib); 10 | use Carp; 11 | 12 | use Sub::Exporter -setup => { 13 | exports => [qw( 14 | zmq_soname 15 | zmq_version 16 | valid_soname 17 | current_tid 18 | )], 19 | }; 20 | 21 | sub zmq_soname { 22 | my %args = @_; 23 | 24 | my $die = $args{die}; 25 | 26 | my ($soname) = find_lib( 27 | lib => 'zmq', 28 | alien => 'Alien::ZMQ::latest', 29 | verify => sub { 30 | my($name, $libpath) = @_; 31 | return valid_soname($libpath); 32 | }, 33 | ); 34 | 35 | if ( !$soname && $die ) { 36 | croak 37 | qq(Could not load libzmq:\n), 38 | q(Is libzmq on your loader path?); 39 | } 40 | 41 | return $soname; 42 | } 43 | 44 | sub zmq_version { 45 | my ($soname) = @_; 46 | 47 | $soname //= zmq_soname(); 48 | 49 | return unless $soname; 50 | 51 | my $ffi = FFI::Platypus->new( lib => $soname, ignore_not_found => 1 ); 52 | my $zmq_version = $ffi->function( 53 | 'zmq_version', 54 | ['int*', 'int*', 'int*'], 55 | 'void' 56 | ); 57 | 58 | unless (defined $zmq_version) { 59 | croak "Could not find zmq_version in '$soname'\n" 60 | . "Is '$soname' on your loader path?"; 61 | } 62 | 63 | my ($major, $minor, $patch); 64 | $zmq_version->call(\$major, \$minor, \$patch); 65 | 66 | return $major, $minor, $patch; 67 | } 68 | 69 | sub valid_soname { 70 | my ($soname) = @_; 71 | 72 | my $ffi = FFI::Platypus->new( lib => $soname, ignore_not_found => 1 ); 73 | my $zmq_version = $ffi->function( 74 | 'zmq_version', 75 | ['int*', 'int*', 'int*'], 76 | 'void' 77 | ); 78 | 79 | return defined $zmq_version; 80 | } 81 | 82 | sub current_tid { 83 | if (eval 'use threads; 1') { 84 | require threads; 85 | threads->import(); 86 | return threads->tid; 87 | } 88 | else { 89 | return -1; 90 | } 91 | } 92 | 93 | 1; 94 | 95 | __END__ 96 | 97 | =head1 SYNOPSIS 98 | 99 | use ZMQ::FFI::Util q(zmq_soname zmq_version) 100 | 101 | my $soname = zmq_soname(); 102 | my ($major, $minor, $patch) = zmq_version($soname); 103 | 104 | =head1 FUNCTIONS 105 | 106 | =head2 zmq_soname([die => 0|1]) 107 | 108 | Tries to load C by looking for platform-specific shared library file 109 | using L with a fallback to L. 110 | 111 | Returns the name of the first one that was successful or undef. If you would 112 | prefer exceptional behavior pass C 1> 113 | 114 | =head2 ($major, $minor, $patch) = zmq_version([$soname]) 115 | 116 | return the libzmq version as the list C<($major, $minor, $patch)>. C<$soname> 117 | can either be a filename available in the ld cache or the path to a library 118 | file. If C<$soname> is not specified it is resolved using C above 119 | 120 | If C<$soname> cannot be resolved undef is returned 121 | 122 | =head1 SEE ALSO 123 | 124 | =for :list 125 | * L 126 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/ZMQ2/Raw.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::ZMQ2::Raw; 2 | 3 | use FFI::Platypus; 4 | 5 | sub load { 6 | my ($soname) = @_; 7 | 8 | my $ffi = FFI::Platypus->new( lib => $soname // 'libzmq.so' ); 9 | my $target = caller; 10 | 11 | $ffi->attach( 12 | # void *zmq_init(int io_threads) 13 | ['zmq_init' => "${target}::zmq_init"] 14 | => ['int'] => 'pointer' 15 | ); 16 | 17 | $ffi->attach( 18 | # void *zmq_socket(void *context, int type) 19 | ['zmq_socket' => "${target}::zmq_socket"] 20 | => ['pointer', 'int'] => 'pointer' 21 | ); 22 | 23 | $ffi->attach( 24 | # int zmq_device(int device, const void *front, const void *back) 25 | ['zmq_device' => "${target}::zmq_device"] 26 | => ['int', 'pointer', 'pointer'] => 'int' 27 | ); 28 | 29 | $ffi->attach( 30 | # int zmq_term(void *context) 31 | ['zmq_term' => "${target}::zmq_term"] 32 | => ['pointer'] => 'int' 33 | ); 34 | 35 | $ffi->attach( 36 | # int zmq_send(void *socket, zmq_msg_t *msg, int flags) 37 | ['zmq_send' => "${target}::zmq_send"] 38 | => ['pointer', 'pointer', 'int'] => 'int' 39 | ); 40 | 41 | $ffi->attach( 42 | # int zmq_recv(void *socket, zmq_msg_t *msg, int flags) 43 | ['zmq_recv' => "${target}::zmq_recv"] 44 | => ['pointer', 'pointer', 'int'] => 'int' 45 | ); 46 | 47 | $ffi->attach( 48 | # int zmq_connect(void *socket, const char *endpoint) 49 | ['zmq_connect' => "${target}::zmq_connect"] 50 | => ['pointer', 'string'] => 'int' 51 | ); 52 | 53 | $ffi->attach( 54 | # int zmq_bind(void *socket, const char *endpoint) 55 | ['zmq_bind' => "${target}::zmq_bind"] 56 | => ['pointer', 'string'] => 'int' 57 | ); 58 | 59 | $ffi->attach( 60 | # int zmq_msg_init(zmq_msg_t *msg) 61 | ['zmq_msg_init' => "${target}::zmq_msg_init"] 62 | => ['pointer'] => 'int' 63 | ); 64 | 65 | $ffi->attach( 66 | # int zmq_msg_init_size(zmq_msg_t *msg, size_t size) 67 | ['zmq_msg_init_size' => "${target}::zmq_msg_init_size"] 68 | => ['pointer', 'int'] => 'int' 69 | ); 70 | 71 | $ffi->attach( 72 | # size_t zmq_msg_size(zmq_msg_t *msg) 73 | ['zmq_msg_size' => "${target}::zmq_msg_size"] 74 | => ['pointer'] => 'int' 75 | ); 76 | 77 | $ffi->attach( 78 | # void *zmq_msg_data(zmq_msg_t *msg) 79 | ['zmq_msg_data' => "${target}::zmq_msg_data"] 80 | => ['pointer'] => 'pointer' 81 | ); 82 | 83 | $ffi->attach( 84 | # int zmq_msg_close(zmq_msg_t *msg) 85 | ['zmq_msg_close' => "${target}::zmq_msg_close"] 86 | => ['pointer'] => 'int' 87 | ); 88 | 89 | $ffi->attach( 90 | # int zmq_close(void *socket) 91 | ['zmq_close' => "${target}::zmq_close"] 92 | => ['pointer'] => 'int' 93 | ); 94 | 95 | $ffi->attach( 96 | # const char *zmq_strerror(int errnum) 97 | ['zmq_strerror' => "${target}::zmq_strerror"] 98 | => ['int'] => 'string' 99 | ); 100 | 101 | $ffi->attach( 102 | # int zmq_errno(void) 103 | ['zmq_errno' => "${target}::zmq_errno"] 104 | => [] => 'int' 105 | ); 106 | } 107 | 108 | 1; 109 | -------------------------------------------------------------------------------- /t/gc.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use Test::Warnings; 3 | use strict; 4 | use warnings; 5 | 6 | use ZMQ::FFI; 7 | use ZMQ::FFI::ZMQ2::Context; 8 | use ZMQ::FFI::ZMQ2::Socket; 9 | use ZMQ::FFI::ZMQ3::Context; 10 | use ZMQ::FFI::ZMQ3::Socket; 11 | use ZMQ::FFI::ZMQ4::Context; 12 | use ZMQ::FFI::ZMQ4::Socket; 13 | use ZMQ::FFI::ZMQ4_1::Context; 14 | use ZMQ::FFI::ZMQ4_1::Socket; 15 | 16 | use ZMQ::FFI::Constants qw(ZMQ_REQ); 17 | use ZMQ::FFI::Util qw(zmq_version); 18 | 19 | my @gc_stack; 20 | 21 | my ($major, $minor) = zmq_version; 22 | if ($major == 2) { 23 | no warnings q/redefine/; 24 | 25 | local *ZMQ::FFI::ZMQ2::Context::destroy = sub { 26 | my ($self) = @_; 27 | $self->context_ptr(-1); 28 | push @gc_stack, 'destroy' 29 | }; 30 | 31 | local *ZMQ::FFI::ZMQ2::Socket::close = sub { 32 | my ($self) = @_; 33 | $self->socket_ptr(-1); 34 | push @gc_stack, 'close' 35 | }; 36 | 37 | use warnings; 38 | 39 | mkcontext(); 40 | 41 | is_deeply 42 | \@gc_stack, 43 | ['close', 'close', 'close', 'destroy'], 44 | q(socket reaped before context); 45 | } 46 | elsif ($major == 3) { 47 | no warnings q/redefine/; 48 | 49 | local *ZMQ::FFI::ZMQ3::Context::destroy = sub { 50 | my ($self) = @_; 51 | $self->context_ptr(-1); 52 | push @gc_stack, 'destroy' 53 | }; 54 | 55 | local *ZMQ::FFI::ZMQ3::Socket::close = sub { 56 | my ($self) = @_; 57 | $self->socket_ptr(-1); 58 | push @gc_stack, 'close' 59 | }; 60 | 61 | use warnings; 62 | 63 | mkcontext(); 64 | 65 | is_deeply 66 | \@gc_stack, 67 | ['close', 'close', 'close', 'destroy'], 68 | q(sockets closed before context destroyed); 69 | } 70 | else { 71 | if ($major == 4 and $minor == 0) { 72 | no warnings q/redefine/; 73 | 74 | local *ZMQ::FFI::ZMQ4::Context::destroy = sub { 75 | my ($self) = @_; 76 | $self->context_ptr(-1); 77 | push @gc_stack, 'destroy' 78 | }; 79 | 80 | local *ZMQ::FFI::ZMQ4::Socket::close = sub { 81 | my ($self) = @_; 82 | $self->socket_ptr(-1); 83 | push @gc_stack, 'close' 84 | }; 85 | 86 | use warnings; 87 | 88 | mkcontext(); 89 | 90 | is_deeply 91 | \@gc_stack, 92 | ['close', 'close', 'close', 'destroy'], 93 | q(sockets closed before context destroyed); 94 | } 95 | else { 96 | no warnings q/redefine/; 97 | 98 | local *ZMQ::FFI::ZMQ4_1::Context::destroy = sub { 99 | my ($self) = @_; 100 | $self->context_ptr(-1); 101 | push @gc_stack, 'destroy' 102 | }; 103 | 104 | local *ZMQ::FFI::ZMQ4_1::Socket::close = sub { 105 | my ($self) = @_; 106 | $self->socket_ptr(-1); 107 | push @gc_stack, 'close' 108 | }; 109 | 110 | use warnings; 111 | 112 | mkcontext(); 113 | 114 | is_deeply 115 | \@gc_stack, 116 | ['close', 'close', 'close', 'destroy'], 117 | q(sockets closed before context destroyed); 118 | } 119 | } 120 | 121 | sub mkcontext { 122 | my $context = ZMQ::FFI->new(); 123 | 124 | mksockets($context); 125 | return; 126 | } 127 | 128 | sub mksockets { 129 | my ($context) = @_; 130 | 131 | my $s1 = $context->socket(ZMQ_REQ); 132 | my $s2 = $context->socket(ZMQ_REQ); 133 | my $s3 = $context->socket(ZMQ_REQ); 134 | 135 | return; 136 | } 137 | 138 | done_testing; 139 | -------------------------------------------------------------------------------- /inc/ZMQ3/SocketWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ3::SocketWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | extends 'inc::ZMQ2::SocketWrappers'; 7 | 8 | # 9 | # for zmq wrappers below that are hot spots (e.g. send/recv) we sacrifice 10 | # readability for performance (by for example not assigning method params 11 | # to local variables) 12 | # 13 | 14 | sub disconnect_tt {q( 15 | sub disconnect { 16 | my ($self, $endpoint) = @_; 17 | 18 | [% closed_socket_check %] 19 | 20 | unless ($endpoint) { 21 | croak 'usage: $socket->disconnect($endpoint)'; 22 | } 23 | 24 | $self->check_error( 25 | 'zmq_disconnect', 26 | zmq_disconnect($self->socket_ptr, $endpoint) 27 | ); 28 | } 29 | )} 30 | 31 | sub unbind_tt {q( 32 | sub unbind { 33 | my ($self, $endpoint) = @_; 34 | 35 | [% closed_socket_check %] 36 | 37 | unless ($endpoint) { 38 | croak 'usage: $socket->unbind($endpoint)'; 39 | } 40 | 41 | $self->check_error( 42 | 'zmq_unbind', 43 | zmq_unbind($self->socket_ptr, $endpoint) 44 | ); 45 | } 46 | )} 47 | 48 | sub send_tt {q( 49 | sub send { 50 | # 0: self 51 | # 1: data 52 | # 2: flags 53 | 54 | [% closed_socket_check %] 55 | 56 | $_[0]->{last_errno} = 0; 57 | 58 | use bytes; 59 | my $length = length($_[1]); 60 | no bytes; 61 | 62 | if ( -1 == zmq_send($_[0]->socket_ptr, $_[1], $length, ($_[2] // 0)) ) { 63 | $_[0]->{last_errno} = zmq_errno(); 64 | 65 | if ($_[0]->die_on_error) { 66 | $_[0]->fatal('zmq_send'); 67 | } 68 | 69 | return; 70 | } 71 | } 72 | )} 73 | 74 | sub recv_tt {q( 75 | sub recv { 76 | # 0: self 77 | # 1: flags 78 | 79 | [% closed_socket_check %] 80 | 81 | $_[0]->{last_errno} = 0; 82 | 83 | # retval = msg size 84 | my $retval = zmq_msg_recv($_[0]->{"_zmq_msg_t"}, $_[0]->socket_ptr, $_[1] // 0); 85 | 86 | if ( $retval == -1 ) { 87 | $_[0]->{last_errno} = zmq_errno(); 88 | 89 | if ($_[0]->die_on_error) { 90 | $_[0]->fatal('zmq_msg_recv'); 91 | } 92 | 93 | 94 | return; 95 | } 96 | 97 | if ($retval) { 98 | return buffer_to_scalar(zmq_msg_data($_[0]->{"_zmq_msg_t"}), $retval); 99 | } 100 | 101 | return ''; 102 | } 103 | )} 104 | 105 | sub monitor_tt {q( 106 | sub monitor { 107 | my ($self, $endpoint, $event) = @_; 108 | 109 | [% closed_socket_check %] 110 | 111 | unless ($endpoint) { 112 | croak 'usage: $socket->monitor($endpoint, $events)'; 113 | } 114 | 115 | $self->check_error( 116 | 'zmq_socket_monitor', 117 | zmq_socket_monitor($self->socket_ptr, $endpoint, $event) 118 | ); 119 | } 120 | )} 121 | 122 | sub recv_event_tt {q( 123 | sub recv_event { 124 | my ($self, $flags) = @_; 125 | 126 | [% closed_socket_check %] 127 | 128 | my $msg = $self->recv($flags); 129 | my $len = length($msg); 130 | 131 | my ($id, $data, $value); 132 | 133 | if ($len == $self->event_size) { 134 | ($id, $data, $value) = unpack('i p i', $msg); 135 | } 136 | elsif ($len > $self->event_size) { 137 | my $padding = ($len - $self->event_size) / 2; 138 | ($id, $data, $value) = unpack("i x$padding p i x$padding", $msg); 139 | } 140 | 141 | return ($id, $value, $data); 142 | } 143 | )} 144 | 145 | 1; 146 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = ZMQ-FFI 2 | author = Dylan Cali 3 | license = Perl_5 4 | copyright_holder = Dylan Cali 5 | 6 | [@Filter] 7 | -bundle = @Basic 8 | -remove = MakeMaker 9 | 10 | ; authordep Dist::Zilla::Plugin::FFI::CheckLib = 1.05 11 | [FFI::CheckLib] 12 | lib = zmq 13 | alien = Alien::ZMQ::latest 14 | 15 | [MakeMaker::Awesome] 16 | delimiter = | 17 | header = |use FFI::Platypus; 18 | header = |# Can't currently support unthreaded BSD perls 19 | header = |# See GH #13 20 | header = |my $badbsd; 21 | header = |if ($^O eq 'freebsd') { 22 | header = | (!grep /libthr/, `procstat -v $$`) && ($badbsd = 1); 23 | header = |} elsif ($^O =~ m/bsd/i) { 24 | header = | !FFI::Platypus->new(lib => [undef]) 25 | header = | ->find_symbol('pthread_self') 26 | header = | && ($badbsd = 1); 27 | header = |} 28 | header = |if ($badbsd) { 29 | header = | print "On BSD ZMQ::FFI requires a perl built to support threads."; 30 | header = | print " Can't continue\n"; 31 | header = | exit; 32 | header = |} 33 | 34 | [Git::NextVersion] 35 | version_regexp = ^(.+)$ 36 | 37 | [PkgVersion] 38 | 39 | [PodWeaver] 40 | 41 | [AutoPrereqs] 42 | skip = ^Sys::SigAction 43 | skip = ^Alien::ZMQ::latest 44 | [Prereqs / ConfigureRequires] 45 | FFI::Platypus = 0.86 46 | 47 | [Prereqs / ConfigureSuggests] 48 | Alien::ZMQ::latest = 0.007 49 | 50 | [Prereqs / RuntimeRequires] 51 | perl = 5.010 52 | Moo = 1.004005 53 | Class::XSAccessor = 1.18 54 | Math::BigInt = 1.997 55 | FFI::Platypus = 0.86 56 | Import::Into = 1.002005 57 | 58 | [Prereqs / RuntimeSuggests] 59 | Alien::ZMQ::latest = 0.007 60 | 61 | [DynamicPrereqs / Sys::SigAction] 62 | -condition = isnt_os('MSWin32') 63 | -body = test_requires('Sys::SigAction', '0') 64 | 65 | [Run::BeforeBuild] 66 | run = perl scripts/gen_zmq_constants.pl 67 | run = perl -Ilib -I. scripts/gen_modules.pl 68 | 69 | [Run::Test] 70 | run = xt/test_versions.sh 71 | 72 | [Run::Clean] 73 | run = rm -f lib/ZMQ/FFI/Constants.pm 74 | run = rm -f lib/ZMQ/FFI/*/Context.pm 75 | run = rm -f lib/ZMQ/FFI/*/Socket.pm 76 | 77 | [NextRelease] 78 | 79 | [GitHub::Meta] 80 | repo = zeromq/perlzmq 81 | 82 | [MetaJSON] 83 | 84 | [MetaNoIndex] 85 | directory = t 86 | 87 | [Meta::Contributors] 88 | contributor = Dave Lambley 89 | contributor = Graham Ollis 90 | contributor = Klaus Ita 91 | contributor = Marc Mims 92 | contributor = Parth Gandhi 93 | contributor = Pawel Pabian 94 | contributor = Robert Hunter 95 | contributor = Sergey KHripchenko 96 | contributor = Slaven Rezic 97 | contributor = Whitney Jackson 98 | contributor = pipcet 99 | contributor = Judd Taylor 100 | contributor = Ji-Hyeon Gim 101 | contributor = Zaki Mughal 102 | contributor = Gavin Henry 103 | 104 | [Git::Commit] 105 | allow_dirty = Changes 106 | commit_msg = version => %v 107 | 108 | [Git::Tag] 109 | tag_format = %v 110 | tag_message = %v 111 | 112 | [Git::Check] 113 | allow_dirty = 114 | 115 | [Git::Push] 116 | 117 | [Clean] 118 | 119 | ; authordep Pod::Elemental::Transformer::List 120 | ; authordep Template::Tiny 121 | ; authordep Path::Class 122 | ; authordep FFI::Platypus 123 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM calid/perl-zmq-base:ubuntu as base 2 | ENV DEBIAN_FRONTEND=noninteractive 3 | ENV PREFIX=/root/.zmq-ffi/usr 4 | RUN apt-get update \ 5 | && apt-get install -y git g++ autoconf automake libtool-bin pkg-config \ 6 | uuid-dev tzdata locales \ 7 | && locale-gen fr_FR.utf8 && update-locale \ 8 | && apt-get clean 9 | WORKDIR /root/.zmq-ffi 10 | RUN git clone https://github.com/zeromq/zeromq2-x.git \ 11 | && cd zeromq2-x \ 12 | && ./autogen.sh \ 13 | && ./configure --prefix=$PREFIX/zeromq2-x --disable-static \ 14 | && make install \ 15 | && strip --strip-unneeded $PREFIX/zeromq2-x/lib/libzmq.so \ 16 | && git clean -dfx && git gc --aggressive --prune 17 | RUN git clone https://github.com/zeromq/zeromq3-x.git \ 18 | && cd zeromq3-x \ 19 | && ./autogen.sh \ 20 | && ./configure --prefix=$PREFIX/zeromq3-x --disable-static \ 21 | && make install \ 22 | && strip --strip-unneeded $PREFIX/zeromq3-x/lib/libzmq.so \ 23 | && git clean -dfx && git gc --aggressive --prune 24 | RUN git clone https://github.com/zeromq/zeromq4-1.git \ 25 | && cd zeromq4-1 \ 26 | && ./autogen.sh \ 27 | && ./configure --prefix=$PREFIX/zeromq4-1 --disable-static \ 28 | && make install \ 29 | && strip --strip-unneeded $PREFIX/zeromq4-1/lib/libzmq.so \ 30 | && git clean -dfx && git gc --aggressive --prune 31 | RUN git clone https://github.com/zeromq/zeromq4-x.git \ 32 | && cd zeromq4-x \ 33 | && ./autogen.sh \ 34 | && ./configure --prefix=$PREFIX/zeromq4-x --disable-static \ 35 | && make install \ 36 | && strip --strip-unneeded $PREFIX/zeromq4-x/lib/libzmq.so \ 37 | && git clean -dfx && git gc --aggressive --prune 38 | RUN git clone https://github.com/zeromq/libzmq.git \ 39 | && cd libzmq \ 40 | && ./autogen.sh \ 41 | && ./configure --prefix=$PREFIX/libzmq --disable-static \ 42 | && make install \ 43 | && strip --strip-unneeded $PREFIX/libzmq/lib/libzmq.so \ 44 | && git clean -dfx && git gc --aggressive --prune 45 | 46 | FROM base as zmq-base 47 | COPY scripts/print_zmq_msg_size.c zmq_msg_size/ 48 | RUN cd zmq_msg_size \ 49 | && \ 50 | gcc -I$PREFIX/zeromq2-x/include print_zmq_msg_size.c \ 51 | -o print_zeromq2-x_msg_size \ 52 | -Wl,-rpath=$PREFIX/zeromq2-x/lib -L$PREFIX/zeromq2-x/lib -lzmq \ 53 | && ./print_zeromq2-x_msg_size >> zmq_msg_sizes \ 54 | && \ 55 | gcc -I$PREFIX/zeromq3-x/include print_zmq_msg_size.c \ 56 | -o print_zeromq3-x_msg_size \ 57 | -Wl,-rpath=$PREFIX/zeromq3-x/lib -L$PREFIX/zeromq3-x/lib -lzmq \ 58 | && ./print_zeromq3-x_msg_size >> zmq_msg_sizes \ 59 | && \ 60 | gcc -I$PREFIX/zeromq4-1/include print_zmq_msg_size.c \ 61 | -o print_zeromq4-1_msg_size \ 62 | -Wl,-rpath=$PREFIX/zeromq4-1/lib -L$PREFIX/zeromq4-1/lib -lzmq \ 63 | && ./print_zeromq4-1_msg_size >> zmq_msg_sizes \ 64 | && \ 65 | gcc -I$PREFIX/zeromq4-x/include print_zmq_msg_size.c \ 66 | -o print_zeromq4-x_msg_size \ 67 | -Wl,-rpath=$PREFIX/zeromq4-x/lib -L$PREFIX/zeromq4-x/lib -lzmq \ 68 | && ./print_zeromq4-x_msg_size >> zmq_msg_sizes \ 69 | && \ 70 | gcc -I$PREFIX/libzmq/include print_zmq_msg_size.c \ 71 | -o print_libzmq_msg_size \ 72 | -Wl,-rpath=$PREFIX/libzmq/lib -L$PREFIX/libzmq/lib -lzmq \ 73 | && ./print_libzmq_msg_size >> zmq_msg_sizes 74 | 75 | FROM zmq-base as dzil-base 76 | RUN apt-get install -y libdist-zilla-perl libterm-ui-perl libanyevent-perl \ 77 | && apt-get clean 78 | 79 | FROM dzil-base as zmq-ffi-base 80 | COPY . /zmq-ffi/ 81 | RUN cd /zmq-ffi && dzil authordeps --missing | cpanm -v 82 | RUN cd /zmq-ffi && dzil listdeps --missing | cpanm -v && cpanm -v Sys::SigAction 83 | RUN apt-get -y purge gcc g++ autoconf automake libtool-bin pkg-config \ 84 | libssl-dev zlib1g-dev uuid-dev \ 85 | && apt -y autoremove \ 86 | && rm -r /var/lib/apt/lists/* ~/.cpanm /zmq-ffi /usr/local/share/man/* \ 87 | /usr/share/doc/* 88 | 89 | FROM scratch 90 | COPY --from=zmq-ffi-base / / 91 | -------------------------------------------------------------------------------- /t/options.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use Math::BigInt; 7 | use lib 't/lib'; 8 | use ZMQTest; 9 | 10 | use ZMQ::FFI qw(:all); 11 | use ZMQ::FFI::Util qw(zmq_version); 12 | 13 | subtest 'ctx version', 14 | sub { 15 | my $ctx = ZMQ::FFI->new(); 16 | 17 | is_deeply 18 | [zmq_version()], 19 | [$ctx->version()], 20 | 'util version and ctx version match'; 21 | }; 22 | 23 | subtest 'ctx options', 24 | sub { 25 | 26 | plan skip_all => 27 | "libzmq 2.x found, don't test 3.x style ctx options" 28 | if (zmq_version())[0] == 2; 29 | 30 | my $ctx = ZMQ::FFI->new( threads => 42, max_sockets => 42 ); 31 | 32 | is $ctx->get(ZMQ_IO_THREADS), 42, 'threads set to 42'; 33 | is $ctx->get(ZMQ_MAX_SOCKETS), 42, 'max sockets set to 42'; 34 | 35 | $ctx->set(ZMQ_IO_THREADS, 1); 36 | $ctx->set(ZMQ_MAX_SOCKETS, 1024); 37 | 38 | is $ctx->get(ZMQ_IO_THREADS), 1, 'threads set to 1'; 39 | is $ctx->get(ZMQ_MAX_SOCKETS), 1024, 'max sockets set to 1024'; 40 | }; 41 | 42 | subtest 'convenience options', 43 | sub { 44 | my $ctx = ZMQ::FFI->new(); 45 | my $s = $ctx->socket(ZMQ_DEALER); 46 | 47 | is $s->get_linger(), 0, 'got default linger'; 48 | 49 | $s->set_linger(42); 50 | is $s->get_linger(), 42, 'set linger'; 51 | 52 | is $s->get_identity(), undef, 'got default identity'; 53 | 54 | $s->set_identity('foo'); 55 | is $s->get_identity(), 'foo', 'set identity'; 56 | }; 57 | 58 | subtest 'string options', 59 | sub { 60 | my ($major) = zmq_version; 61 | plan skip_all => 62 | "no string options exist for libzmq 2.x" 63 | if $major == 2; 64 | 65 | my $ctx = ZMQ::FFI->new(); 66 | my $s = $ctx->socket(ZMQ_DEALER); 67 | 68 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 69 | $s->bind($endpoint); 70 | 71 | is $s->get(ZMQ_LAST_ENDPOINT, 'string'), $endpoint, 'got last endpoint'; 72 | 73 | if ($major >= 4) { 74 | $s->set(ZMQ_PLAIN_USERNAME, 'string', 'foo'); 75 | is $s->get(ZMQ_PLAIN_USERNAME, 'string'), 'foo', 76 | 'setting/getting zmq4 string opt works' 77 | } 78 | }; 79 | 80 | subtest 'binary options', 81 | sub { 82 | my $ctx = ZMQ::FFI->new(); 83 | my $s = $ctx->socket(ZMQ_DEALER); 84 | 85 | # 255 characters long 86 | my $long_ident = 'ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'; 87 | 88 | $s->set(ZMQ_IDENTITY, 'binary', $long_ident); 89 | is $s->get(ZMQ_IDENTITY, 'binary'), $long_ident, 'set long identity'; 90 | }; 91 | 92 | subtest 'uint64_t options', 93 | sub { 94 | my $max_uint64 = Math::BigInt->new('18446744073709551615'); 95 | my $ctx = ZMQ::FFI->new(); 96 | 97 | my $s = $ctx->socket(ZMQ_REQ); 98 | 99 | $s->set(ZMQ_AFFINITY, 'uint64_t', $max_uint64); 100 | is $s->get(ZMQ_AFFINITY, 'uint64_t'), $max_uint64->bstr(), 101 | 'set/got max unsigned 64 bit int option value'; 102 | }; 103 | 104 | subtest 'int64_t options', 105 | sub { 106 | # max negative 64bit values don't currently make 107 | # sense with any zmq opts, so we'll stick with positive 108 | my $max_int64 = Math::BigInt->new('9223372036854775807'); 109 | my $ctx = ZMQ::FFI->new(); 110 | 111 | my ($major) = $ctx->version; 112 | 113 | # no int64 opts exist in both versions 114 | my $opt; 115 | if ($major == 2) { 116 | $opt = ZMQ_SWAP; 117 | } 118 | elsif ($major == 3 || $major == 4) { 119 | $opt = ZMQ_MAXMSGSIZE; 120 | } 121 | else { 122 | die "Unsupported zmq version $major"; 123 | } 124 | 125 | my $s = $ctx->socket(ZMQ_REQ); 126 | 127 | $s->set($opt, 'int64_t', $max_int64); 128 | is $s->get($opt, 'int64_t'), $max_int64->bstr(), 129 | 'set/got max signed 64 bit int option value'; 130 | }; 131 | 132 | done_testing; 133 | -------------------------------------------------------------------------------- /t/fork-01.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_REQ); 10 | 11 | if( ! ZMQTest->platform_can_fork ) { 12 | plan skip_all => 'fork(2) unavailable'; 13 | } 14 | 15 | # 16 | # Test that we guard against trying to clean up context/sockets 17 | # created in a parent process in forked children 18 | # 19 | 20 | my $parent_c = ZMQ::FFI->new(); 21 | my $parent_s = $parent_c->socket(ZMQ_REQ); 22 | 23 | my $parent_s_closed; 24 | my $parent_c_destroyed; 25 | 26 | my ($major, $minor) = $parent_c->version; 27 | if ($major == 2) { 28 | no warnings qw/redefine once/; 29 | 30 | local *ZMQ::FFI::ZMQ2::Socket::zmq_close = sub { 31 | $parent_s_closed = 1; 32 | }; 33 | 34 | local *ZMQ::FFI::ZMQ2::Context::zmq_term = sub { 35 | $parent_c_destroyed = 1; 36 | }; 37 | 38 | use warnings; 39 | 40 | pid_test(); 41 | } 42 | elsif ($major == 3) { 43 | no warnings qw/redefine once/; 44 | 45 | local *ZMQ::FFI::ZMQ3::Socket::zmq_close = sub { 46 | $parent_s_closed = 1; 47 | }; 48 | 49 | local *ZMQ::FFI::ZMQ3::Context::zmq_ctx_destroy = sub { 50 | $parent_c_destroyed = 1; 51 | }; 52 | 53 | use warnings; 54 | 55 | pid_test(); 56 | } 57 | else { 58 | if ($major == 4 and $minor == 0) { 59 | no warnings qw/redefine once/; 60 | 61 | local *ZMQ::FFI::ZMQ4::Socket::zmq_close = sub { 62 | $parent_s_closed = 1; 63 | }; 64 | 65 | local *ZMQ::FFI::ZMQ4::Context::zmq_ctx_term = sub { 66 | $parent_c_destroyed = 1; 67 | }; 68 | 69 | use warnings; 70 | 71 | pid_test(); 72 | } 73 | else { 74 | no warnings qw/redefine once/; 75 | 76 | local *ZMQ::FFI::ZMQ4_1::Socket::zmq_close = sub { 77 | $parent_s_closed = 1; 78 | }; 79 | 80 | local *ZMQ::FFI::ZMQ4_1::Context::zmq_ctx_term = sub { 81 | $parent_c_destroyed = 1; 82 | }; 83 | 84 | use warnings; 85 | 86 | pid_test(); 87 | } 88 | } 89 | 90 | sub pid_test { 91 | my $child_pid = open(FROM_CHILDTEST, '-|') // die "fork failed $!"; 92 | 93 | if ($child_pid) { 94 | # parent process, do test assertions here 95 | 96 | my $result; 97 | read(FROM_CHILDTEST, $result, 128); 98 | 99 | waitpid $child_pid, 0; 100 | 101 | is $result, 'ok', 102 | 'child process skipped parent ctx/socket cleanup'; 103 | 104 | 105 | ok $parent_c->_pid == $$, "parent context pid _should_ match parent pid"; 106 | ok $parent_s->_pid == $$, "parent socket pid _should_ match parent pid"; 107 | 108 | # explicitly undef ctx/socket created in parent to trigger DEMOLISH/ 109 | # cleanup logic.. then verify that close/destroy _was_ called 110 | # for ctx/socket created in parent 111 | 112 | undef $parent_s; 113 | undef $parent_c; 114 | 115 | ok $parent_s_closed, "parent socket closed in parent"; 116 | ok $parent_c_destroyed, "parent context destroyed in parent"; 117 | } 118 | else { 119 | # check test expectataions and print 'ok' if successful 120 | 121 | if ( $parent_c->_pid == $$ ) { 122 | print "parent context pid _should not_ match child pid"; exit; 123 | } 124 | 125 | if ( $parent_s->_pid == $$ ) { 126 | print "parent socket pid _should not_ match child pid"; exit; 127 | } 128 | 129 | # explicitly undef ctx/socket cloned from parent to trigger DEMOLISH/ 130 | # cleanup logic.. then verify that close/destroy _was not_ called 131 | # for ctx/socket created in parent 132 | 133 | undef $parent_s; 134 | undef $parent_c; 135 | 136 | if ( $parent_s_closed ) { 137 | print "parent socket closed in child!"; exit; 138 | } 139 | 140 | if ( $parent_c_destroyed) { 141 | print "parent context destroyed in child!"; exit; 142 | } 143 | 144 | print 'ok'; 145 | exit; 146 | } 147 | } 148 | 149 | done_testing; 150 | -------------------------------------------------------------------------------- /inc/ZMQ2/ContextWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ2::ContextWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | with 'inc::ContextWrapperRole'; 7 | 8 | sub init_tt {q( 9 | has '+threads' => ( 10 | default => 1, 11 | ); 12 | 13 | sub init { 14 | my ($self) = @_; 15 | 16 | if ($self->has_max_sockets) { 17 | $self->bad_version( 18 | $self->verstr, 19 | 'max_sockets option not available in zmq 2.x', 20 | 'use_die', 21 | ) 22 | } 23 | 24 | try { 25 | $self->context_ptr( zmq_init($self->threads) ); 26 | $self->check_null('zmq_init', $self->context_ptr); 27 | } 28 | catch { 29 | $self->context_ptr(-1); 30 | die $_; 31 | }; 32 | } 33 | )} 34 | 35 | sub get_tt {q( 36 | sub get { 37 | my ($self) = @_; 38 | 39 | $self->bad_version( 40 | $self->verstr, 41 | "getting ctx options not available in zmq 2.x" 42 | ); 43 | } 44 | )} 45 | 46 | sub set_tt {q( 47 | sub set { 48 | my ($self) = @_; 49 | 50 | $self->bad_version( 51 | $self->verstr, 52 | "setting ctx options not available in zmq 2.x" 53 | ); 54 | } 55 | )} 56 | 57 | sub socket_tt {q( 58 | sub socket { 59 | my ($self, $type) = @_; 60 | 61 | my $socket; 62 | 63 | try { 64 | my $socket_ptr = zmq_socket($self->context_ptr, $type); 65 | 66 | $self->check_null('zmq_socket', $socket_ptr); 67 | 68 | $socket = ZMQ::FFI::[% zmqver %]::Socket->new( 69 | socket_ptr => $socket_ptr, 70 | context => $self, # this will become a weak ref 71 | type => $type, 72 | soname => $self->soname, 73 | ); 74 | } 75 | catch { 76 | die $_; 77 | }; 78 | 79 | # add the socket to the socket hash 80 | $self->_add_socket($socket); 81 | 82 | return $socket; 83 | } 84 | )} 85 | 86 | # zeromq v2 does not provide zmq_proxy 87 | # implemented here in terms of zmq_device 88 | sub proxy_tt {q( 89 | sub proxy { 90 | my ($self, $frontend, $backend, $capture) = @_; 91 | 92 | if ($capture){ 93 | $self->bad_version( 94 | $self->verstr, 95 | "capture socket not supported in zmq 2.x" 96 | ); 97 | } 98 | 99 | $self->check_error( 100 | 'zmq_device', 101 | zmq_device(ZMQ_STREAMER, $frontend->socket_ptr, $backend->socket_ptr) 102 | ); 103 | } 104 | )} 105 | 106 | sub device_tt {q( 107 | sub device { 108 | my ($self, $type, $frontend, $backend) = @_; 109 | 110 | $self->check_error( 111 | 'zmq_device', 112 | zmq_device($type, $frontend->socket_ptr, $backend->socket_ptr) 113 | ); 114 | } 115 | )} 116 | 117 | sub destroy_tt {q( 118 | sub destroy { 119 | my ($self) = @_; 120 | 121 | return if $self->context_ptr == -1; 122 | 123 | # don't try to cleanup context cloned from another thread 124 | return unless $self->_tid == current_tid(); 125 | 126 | # don't try to cleanup context copied from another process (fork) 127 | return unless $self->_pid == $$; 128 | 129 | $self->check_error( 130 | 'zmq_term', 131 | zmq_term($self->context_ptr) 132 | ); 133 | 134 | $self->context_ptr(-1); 135 | } 136 | )} 137 | 138 | sub curve_keypair_tt {q( 139 | sub curve_keypair { 140 | my ($self) = @_; 141 | $self->bad_version( 142 | $self->verstr, 143 | "curve_keypair not available in < zmq 4.x" 144 | ); 145 | } 146 | )} 147 | 148 | sub z85_encode_tt {q( 149 | sub z85_encode { 150 | my ($self) = @_; 151 | $self->bad_version( 152 | $self->verstr, 153 | "z85_encode not available in < zmq 4.x" 154 | ); 155 | } 156 | )} 157 | 158 | sub z85_decode_tt {q( 159 | sub z85_decode { 160 | my ($self) = @_; 161 | $self->bad_version( 162 | $self->verstr, 163 | "z85_decode not available in < zmq 4.x" 164 | ); 165 | } 166 | )} 167 | 168 | sub has_capability_tt {q( 169 | sub has_capability { 170 | my ($self) = @_; 171 | $self->bad_version( 172 | $self->verstr, 173 | "has_capability not available in < zmq 4.1" 174 | ); 175 | } 176 | )} 177 | 178 | 1; 179 | -------------------------------------------------------------------------------- /t/errors.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use Test::Exception; 7 | use lib 't/lib'; 8 | use ZMQTest; 9 | 10 | use FFI::Platypus; 11 | use Errno qw(EINVAL EAGAIN); 12 | 13 | use ZMQ::FFI qw(:all); 14 | use ZMQ::FFI::Util qw(zmq_soname); 15 | 16 | subtest 'socket errors' => sub { 17 | $! = EINVAL; 18 | my $einval_str; 19 | 20 | { 21 | # get the EINVAL error string in a locale aware way 22 | use locale; 23 | use bytes; 24 | $einval_str = "$!"; 25 | } 26 | 27 | my $ctx = ZMQ::FFI->new(); 28 | 29 | throws_ok { $ctx->socket(-1) } qr/$einval_str/i, 30 | q(invalid socket type dies with EINVAL); 31 | 32 | 33 | my $socket = $ctx->socket(ZMQ_REQ); 34 | 35 | throws_ok { $socket->connect('foo') } qr/$einval_str/i, 36 | q(invalid endpoint dies with EINVAL); 37 | }; 38 | 39 | subtest 'util errors' => sub { 40 | no warnings q/redefine/; 41 | 42 | local *FFI::Platypus::function = sub { return; }; 43 | 44 | throws_ok { zmq_soname(die => 1) } qr/Could not load libzmq/, 45 | q(zmq_soname dies when die => 1 and FFI::Platypus->function fails); 46 | 47 | lives_ok { 48 | ok !zmq_soname(); 49 | } q(zmq_soname lives and returns undef when die => 0) 50 | . q( and FFI::Platypus->function fails); 51 | }; 52 | 53 | subtest 'fatal socket error' => sub { 54 | no warnings qw/redefine once/; 55 | 56 | local *ZMQ::FFI::ZMQ2::Socket::zmq_send = sub { return -1; }; 57 | local *ZMQ::FFI::ZMQ3::Socket::zmq_send = sub { return -1; }; 58 | local *ZMQ::FFI::ZMQ4::Socket::zmq_send = sub { return -1; }; 59 | local *ZMQ::FFI::ZMQ4_1::Socket::zmq_send = sub { return -1; }; 60 | 61 | my $ctx = ZMQ::FFI->new(); 62 | my $socket = $ctx->socket(ZMQ_REQ); 63 | 64 | throws_ok { $socket->send('ohhai'); } qr/^zmq_send:/, 65 | q(socket error on send dies with zmq_send error message); 66 | }; 67 | 68 | subtest 'socket recv error && die_on_error => false' => sub { 69 | my $ctx = ZMQ::FFI->new(); 70 | my $socket = $ctx->socket(ZMQ_REP); 71 | $socket->bind(ZMQTest->endpoint("test-zmq-ffi-$$")); 72 | 73 | check_nonfatal_eagain($socket, 'recv', ZMQ_DONTWAIT); 74 | }; 75 | 76 | subtest 'socket send error && die_on_error => false' => sub { 77 | my $ctx = ZMQ::FFI->new(); 78 | my $socket = $ctx->socket(ZMQ_DEALER); 79 | $socket->bind(ZMQTest->endpoint("test-zmq-ffi-$$")); 80 | 81 | check_nonfatal_eagain($socket, 'send', 'ohhai', ZMQ_DONTWAIT); 82 | }; 83 | 84 | subtest 'socket recv_multipart error && die_on_error => false' => sub { 85 | my $ctx = ZMQ::FFI->new(); 86 | my $socket = $ctx->socket(ZMQ_REP); 87 | $socket->bind(ZMQTest->endpoint("test-zmq-ffi-$$")); 88 | 89 | check_nonfatal_eagain($socket, 'recv_multipart', ZMQ_DONTWAIT); 90 | }; 91 | 92 | subtest 'socket send_multipart error && die_on_error => false' => sub { 93 | my $ctx = ZMQ::FFI->new(); 94 | my $socket = $ctx->socket(ZMQ_DEALER); 95 | $socket->bind(ZMQTest->endpoint("test-zmq-ffi-$$")); 96 | 97 | check_nonfatal_eagain( 98 | $socket, 'send_multipart', [qw(foo bar baz)], ZMQ_DONTWAIT 99 | ); 100 | }; 101 | 102 | sub check_nonfatal_eagain { 103 | my ($socket, $method, @method_args) = @_; 104 | 105 | $! = EAGAIN; 106 | my $eagain_str; 107 | 108 | { 109 | # get the EAGAIN error string in a locale aware way 110 | use locale; 111 | use bytes; 112 | $eagain_str = "$!"; 113 | } 114 | 115 | $socket->die_on_error(0); 116 | 117 | ok !$socket->has_error, 118 | qq(has_error false before $method error); 119 | 120 | lives_ok { 121 | $socket->$method(@method_args); 122 | } qq($method error isn't fatal if die_on_error false); 123 | 124 | ok $socket->has_error, 125 | 'has_error true after error'; 126 | 127 | is $socket->last_errno, EAGAIN, 128 | 'last_errno set to error code of last error'; 129 | 130 | is $socket->last_strerror, $eagain_str, 131 | 'last_strerror set to error string of last error'; 132 | 133 | $socket->die_on_error(1); 134 | 135 | throws_ok { $socket->$method(@method_args) } qr/$eagain_str/i, 136 | qq($method error fatal again after die_on_error set back to true); 137 | } 138 | 139 | done_testing; 140 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/ZMQ3/Raw.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::ZMQ3::Raw; 2 | 3 | use FFI::Platypus; 4 | 5 | sub load { 6 | my ($soname) = @_; 7 | 8 | my $ffi = FFI::Platypus->new( lib => $soname // 'libzmq.so' ); 9 | my $target = caller; 10 | 11 | $ffi->attach( 12 | # void *zmq_ctx_new() 13 | ['zmq_ctx_new' => "${target}::zmq_ctx_new"] 14 | => [] => 'pointer' 15 | ); 16 | 17 | $ffi->attach( 18 | # int zmq_ctx_get(void *context, int option_name) 19 | ['zmq_ctx_get' => "${target}::zmq_ctx_get"] 20 | => ['pointer', 'int'] => 'int' 21 | ); 22 | 23 | $ffi->attach( 24 | # int zmq_ctx_set(void *context, int option_name, int option_value) 25 | ['zmq_ctx_set' => "${target}::zmq_ctx_set"] 26 | => ['pointer', 'int', 'int'] => 'int' 27 | ); 28 | 29 | $ffi->attach( 30 | # void *zmq_socket(void *context, int type) 31 | ['zmq_socket' => "${target}::zmq_socket"] 32 | => ['pointer', 'int'] => 'pointer' 33 | ); 34 | 35 | $ffi->attach( 36 | # int zmq_proxy(const void *front, const void *back, const void *cap) 37 | ['zmq_proxy' => "${target}::zmq_proxy"] 38 | => ['pointer', 'pointer', 'pointer'] => 'int' 39 | ); 40 | 41 | $ffi->attach( 42 | # int zmq_ctx_destroy (void *context) 43 | ['zmq_ctx_destroy' => "${target}::zmq_ctx_destroy"] 44 | => ['pointer'] => 'int' 45 | ); 46 | 47 | $ffi->attach( 48 | # int zmq_send(void *socket, void *buf, size_t len, int flags) 49 | ['zmq_send' => "${target}::zmq_send"] 50 | => ['pointer', 'string', 'size_t', 'int'] => 'int' 51 | ); 52 | 53 | $ffi->attach( 54 | # int zmq_msg_recv(zmq_msg_t *msg, void *socket, int flags) 55 | ['zmq_msg_recv' => "${target}::zmq_msg_recv"] 56 | => ['pointer', 'pointer', 'int'] => 'int' 57 | ); 58 | 59 | $ffi->attach( 60 | # int zmq_unbind(void *socket, const char *endpoint) 61 | ['zmq_unbind' => "${target}::zmq_unbind"] 62 | => ['pointer', 'string'] => 'int' 63 | ); 64 | 65 | $ffi->attach( 66 | # int zmq_disconnect(void *socket, const char *endpoint) 67 | ['zmq_disconnect' => "${target}::zmq_disconnect"] 68 | => ['pointer', 'string'] => 'int' 69 | ); 70 | 71 | $ffi->attach( 72 | # int zmq_connect(void *socket, const char *endpoint) 73 | ['zmq_connect' => "${target}::zmq_connect"] 74 | => ['pointer', 'string'] => 'int' 75 | ); 76 | 77 | $ffi->attach( 78 | # int zmq_bind(void *socket, const char *endpoint) 79 | ['zmq_bind' => "${target}::zmq_bind"] 80 | => ['pointer', 'string'] => 'int' 81 | ); 82 | 83 | $ffi->attach( 84 | # int zmq_msg_init(zmq_msg_t *msg) 85 | ['zmq_msg_init' => "${target}::zmq_msg_init"] 86 | => ['pointer'] => 'int' 87 | ); 88 | 89 | $ffi->attach( 90 | # int zmq_msg_init_size(zmq_msg_t *msg, size_t size) 91 | ['zmq_msg_init_size' => "${target}::zmq_msg_init_size"] 92 | => ['pointer', 'int'] => 'int' 93 | ); 94 | 95 | $ffi->attach( 96 | # size_t zmq_msg_size(zmq_msg_t *msg) 97 | ['zmq_msg_size' => "${target}::zmq_msg_size"] 98 | => ['pointer'] => 'int' 99 | ); 100 | 101 | $ffi->attach( 102 | # void *zmq_msg_data(zmq_msg_t *msg) 103 | ['zmq_msg_data' => "${target}::zmq_msg_data"] 104 | => ['pointer'] => 'pointer' 105 | ); 106 | 107 | $ffi->attach( 108 | # int zmq_msg_close(zmq_msg_t *msg) 109 | ['zmq_msg_close' => "${target}::zmq_msg_close"] 110 | => ['pointer'] => 'int' 111 | ); 112 | 113 | $ffi->attach( 114 | # int zmq_close(void *socket) 115 | ['zmq_close' => "${target}::zmq_close"] 116 | => ['pointer'] => 'int' 117 | ); 118 | 119 | $ffi->attach( 120 | # const char *zmq_strerror(int errnum) 121 | ['zmq_strerror' => "${target}::zmq_strerror"] 122 | => ['int'] => 'string' 123 | ); 124 | 125 | $ffi->attach( 126 | # int zmq_errno(void) 127 | ['zmq_errno' => "${target}::zmq_errno"] 128 | => [] => 'int' 129 | ); 130 | 131 | $ffi->attach( 132 | # int zmq_socket_monitor (void *socket, char *addr, int events); 133 | ['zmq_socket_monitor' => "${target}::zmq_socket_monitor"] 134 | => ['pointer', 'string', 'int'] => 'int' 135 | ); 136 | } 137 | 138 | 1; 139 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ZMQ::FFI [![Build Status](https://api.travis-ci.org/zeromq/perlzmq.svg?branch=master)](https://travis-ci.org/zeromq/perlzmq) 2 | 3 | ## version agnostic Perl bindings for ØMQ using ffi ## 4 | 5 | ZMQ::FFI exposes a high level, transparent, OO interface to zeromq independent of the underlying libzmq version. Where semantics differ, it will dispatch to the appropriate backend for you. As it uses ffi, there is no dependency on XS or compilation. 6 | 7 | ZMQ::FFI is implemented using [FFI::Platypus](https://github.com/plicease/FFI-Platypus). 8 | 9 | ### EXAMPLES ### 10 | 11 | #### send/recv #### 12 | ```perl 13 | use 5.012; 14 | use ZMQ::FFI qw(ZMQ_REQ ZMQ_REP); 15 | 16 | my $endpoint = "ipc://zmq-ffi-$$"; 17 | my $ctx = ZMQ::FFI->new(); 18 | 19 | my $s1 = $ctx->socket(ZMQ_REQ); 20 | $s1->connect($endpoint); 21 | 22 | my $s2 = $ctx->socket(ZMQ_REP); 23 | $s2->bind($endpoint); 24 | 25 | $s1->send('ohhai'); 26 | 27 | say $s2->recv(); 28 | # ohhai 29 | ``` 30 | 31 | #### pub/sub #### 32 | ```perl 33 | use 5.012; 34 | use ZMQ::FFI qw(ZMQ_PUB ZMQ_SUB); 35 | use Time::HiRes q(usleep); 36 | 37 | my $endpoint = "ipc://zmq-ffi-$$"; 38 | my $ctx = ZMQ::FFI->new(); 39 | 40 | my $s = $ctx->socket(ZMQ_SUB); 41 | my $p = $ctx->socket(ZMQ_PUB); 42 | 43 | $s->connect($endpoint); 44 | $p->bind($endpoint); 45 | 46 | # all topics 47 | { 48 | $s->subscribe(''); 49 | 50 | until ($s->has_pollin) { 51 | # compensate for slow subscriber 52 | usleep 100_000; 53 | $p->send('ohhai'); 54 | } 55 | 56 | say $s->recv(); 57 | # ohhai 58 | 59 | $s->unsubscribe(''); 60 | } 61 | 62 | # specific topics 63 | { 64 | $s->subscribe('topic1'); 65 | $s->subscribe('topic2'); 66 | 67 | until ($s->has_pollin) { 68 | usleep 100_000; 69 | $p->send('topic1 ohhai'); 70 | $p->send('topic2 ohhai'); 71 | } 72 | 73 | while ($s->has_pollin) { 74 | say join ' ', $s->recv(); 75 | # topic1 ohhai 76 | # topic2 ohhai 77 | } 78 | } 79 | ``` 80 | 81 | #### multipart #### 82 | ```perl 83 | use 5.012; 84 | use ZMQ::FFI qw(ZMQ_DEALER ZMQ_ROUTER); 85 | 86 | my $endpoint = "ipc://zmq-ffi-$$"; 87 | my $ctx = ZMQ::FFI->new(); 88 | 89 | my $d = $ctx->socket(ZMQ_DEALER); 90 | $d->set_identity('dealer'); 91 | 92 | my $r = $ctx->socket(ZMQ_ROUTER); 93 | 94 | $d->connect($endpoint); 95 | $r->bind($endpoint); 96 | 97 | $d->send_multipart([qw(ABC DEF GHI)]); 98 | 99 | say join ' ', $r->recv_multipart; 100 | # dealer ABC DEF GHI 101 | ``` 102 | 103 | #### nonblocking #### 104 | ```perl 105 | use 5.012; 106 | use ZMQ::FFI qw(ZMQ_PUSH ZMQ_PULL); 107 | use AnyEvent; 108 | use EV; 109 | 110 | my $endpoint = "ipc://zmq-ffi-$$"; 111 | my $ctx = ZMQ::FFI->new(); 112 | my @messages = qw(foo bar baz); 113 | 114 | 115 | my $pull = $ctx->socket(ZMQ_PULL); 116 | $pull->bind($endpoint); 117 | 118 | my $fd = $pull->get_fd(); 119 | 120 | my $recv = 0; 121 | my $w = AE::io $fd, 0, sub { 122 | while ( $pull->has_pollin ) { 123 | say $pull->recv(); 124 | # foo, bar, baz 125 | 126 | $recv++; 127 | if ($recv == 3) { 128 | EV::break(); 129 | } 130 | } 131 | }; 132 | 133 | 134 | my $push = $ctx->socket(ZMQ_PUSH); 135 | $push->connect($endpoint); 136 | 137 | my $sent = 0; 138 | my $t; 139 | $t = AE::timer 0, .1, sub { 140 | $push->send($messages[$sent]); 141 | 142 | $sent++; 143 | if ($sent == 3) { 144 | undef $t; 145 | } 146 | }; 147 | 148 | EV::run(); 149 | ``` 150 | 151 | #### specifying versions #### 152 | ```perl 153 | use ZMQ::FFI; 154 | 155 | # 2.x context 156 | my $ctx = ZMQ::FFI->new( soname => 'libzmq.so.1' ); 157 | my ($major, $minor, $patch) = $ctx->version; 158 | 159 | # 3.x context 160 | my $ctx = ZMQ::FFI->new( soname => 'libzmq.so.3' ); 161 | my ($major, $minor, $patch) = $ctx->version; 162 | ``` 163 | 164 | ### INSTALL ### 165 | 166 | cpanm -v ZMQ::FFI 167 | 168 | ### BUILD ### 169 | 170 | A docker image is provided with a pre-configured testing environment. To test the module: 171 | 172 | ./docker-run dzil test 173 | 174 | To build a dist tarball: 175 | 176 | ./docker-run dzil build 177 | 178 | To clean build artifacts: 179 | 180 | ./docker-run dzil clean 181 | 182 | Tests will run against every stable version of zeromq as well as master. If you would like an interactive shell inside the container run `./docker-shell` 183 | 184 | If you would prefer a native local setup refer to the Dockerfile and translate the setup steps accordingly for your distribution/platform (I personally use the docker container, and this is also how tests run under Travis). 185 | 186 | ### DOCUMENTATION ### 187 | 188 | https://metacpan.org/module/ZMQ::FFI 189 | 190 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/ZMQ4/Raw.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::ZMQ4::Raw; 2 | 3 | use FFI::Platypus; 4 | 5 | sub load { 6 | my ($soname) = @_; 7 | 8 | my $ffi = FFI::Platypus->new( lib => $soname // 'libzmq.so' ); 9 | my $target = caller; 10 | 11 | $ffi->attach( 12 | # void *zmq_ctx_new() 13 | ['zmq_ctx_new' => "${target}::zmq_ctx_new"] 14 | => [] => 'pointer' 15 | ); 16 | 17 | $ffi->attach( 18 | # int zmq_ctx_get(void *context, int option_name) 19 | ['zmq_ctx_get' => "${target}::zmq_ctx_get"] 20 | => ['pointer', 'int'] => 'int' 21 | ); 22 | 23 | $ffi->attach( 24 | # int zmq_ctx_set(void *context, int option_name, int option_value) 25 | ['zmq_ctx_set' => "${target}::zmq_ctx_set"] 26 | => ['pointer', 'int', 'int'] => 'int' 27 | ); 28 | 29 | $ffi->attach( 30 | # void *zmq_socket(void *context, int type) 31 | ['zmq_socket' => "${target}::zmq_socket"] 32 | => ['pointer', 'int'] => 'pointer' 33 | ); 34 | 35 | $ffi->attach( 36 | # int zmq_proxy(const void *front, const void *back, const void *cap) 37 | ['zmq_proxy' => "${target}::zmq_proxy"] 38 | => ['pointer', 'pointer', 'pointer'] => 'int' 39 | ); 40 | 41 | $ffi->attach( 42 | # int zmq_ctx_term (void *context) 43 | ['zmq_ctx_term' => "${target}::zmq_ctx_term"] 44 | => ['pointer'] => 'int' 45 | ); 46 | 47 | $ffi->attach( 48 | # int zmq_send(void *socket, void *buf, size_t len, int flags) 49 | ['zmq_send' => "${target}::zmq_send"] 50 | => ['pointer', 'string', 'size_t', 'int'] => 'int' 51 | ); 52 | 53 | $ffi->attach( 54 | # int zmq_msg_recv(zmq_msg_t *msg, void *socket, int flags) 55 | ['zmq_msg_recv' => "${target}::zmq_msg_recv"] 56 | => ['pointer', 'pointer', 'int'] => 'int' 57 | ); 58 | 59 | $ffi->attach( 60 | # int zmq_unbind(void *socket, const char *endpoint) 61 | ['zmq_unbind' => "${target}::zmq_unbind"] 62 | => ['pointer', 'string'] => 'int' 63 | ); 64 | 65 | $ffi->attach( 66 | # int zmq_disconnect(void *socket, const char *endpoint) 67 | ['zmq_disconnect' => "${target}::zmq_disconnect"] 68 | => ['pointer', 'string'] => 'int' 69 | ); 70 | 71 | $ffi->attach( 72 | # int zmq_connect(void *socket, const char *endpoint) 73 | ['zmq_connect' => "${target}::zmq_connect"] 74 | => ['pointer', 'string'] => 'int' 75 | ); 76 | 77 | $ffi->attach( 78 | # int zmq_bind(void *socket, const char *endpoint) 79 | ['zmq_bind' => "${target}::zmq_bind"] 80 | => ['pointer', 'string'] => 'int' 81 | ); 82 | 83 | $ffi->attach( 84 | # int zmq_msg_init(zmq_msg_t *msg) 85 | ['zmq_msg_init' => "${target}::zmq_msg_init"] 86 | => ['pointer'] => 'int' 87 | ); 88 | 89 | $ffi->attach( 90 | # int zmq_msg_init_size(zmq_msg_t *msg, size_t size) 91 | ['zmq_msg_init_size' => "${target}::zmq_msg_init_size"] 92 | => ['pointer', 'int'] => 'int' 93 | ); 94 | 95 | $ffi->attach( 96 | # size_t zmq_msg_size(zmq_msg_t *msg) 97 | ['zmq_msg_size' => "${target}::zmq_msg_size"] 98 | => ['pointer'] => 'int' 99 | ); 100 | 101 | $ffi->attach( 102 | # void *zmq_msg_data(zmq_msg_t *msg) 103 | ['zmq_msg_data' => "${target}::zmq_msg_data"] 104 | => ['pointer'] => 'pointer' 105 | ); 106 | 107 | $ffi->attach( 108 | # int zmq_msg_close(zmq_msg_t *msg) 109 | ['zmq_msg_close' => "${target}::zmq_msg_close"] 110 | => ['pointer'] => 'int' 111 | ); 112 | 113 | $ffi->attach( 114 | # int zmq_close(void *socket) 115 | ['zmq_close' => "${target}::zmq_close"] 116 | => ['pointer'] => 'int' 117 | ); 118 | 119 | $ffi->attach( 120 | # const char *zmq_strerror(int errnum) 121 | ['zmq_strerror' => "${target}::zmq_strerror"] 122 | => ['int'] => 'string' 123 | ); 124 | 125 | $ffi->attach( 126 | # int zmq_errno(void) 127 | ['zmq_errno' => "${target}::zmq_errno"] 128 | => [] => 'int' 129 | ); 130 | 131 | $ffi->attach( 132 | # int zmq_curve_keypair (char *z85_public_key, char *z85_secret_key); 133 | ['zmq_curve_keypair' => "${target}::zmq_curve_keypair"] 134 | => ['opaque', 'opaque'] => 'int' 135 | ); 136 | 137 | $ffi->attach( 138 | # char *zmq_z85_encode (char *dest, const uint8_t *data, size_t size); 139 | ['zmq_z85_encode' => "${target}::zmq_z85_encode"] 140 | => ['opaque', 'string', 'size_t'] => 'pointer' 141 | ); 142 | 143 | $ffi->attach( 144 | # uint8_t *zmq_z85_decode (uint8_t *dest, const char *string); 145 | ['zmq_z85_decode' => "${target}::zmq_z85_decode"] 146 | => ['opaque', 'string'] => 'pointer' 147 | ); 148 | 149 | $ffi->attach( 150 | # int zmq_socket_monitor (void *socket, char *endpoint, int events); 151 | ['zmq_socket_monitor' => "${target}::zmq_socket_monitor"] 152 | => ['pointer', 'string', 'int'] => 'int' 153 | ); 154 | } 155 | 156 | 1; 157 | -------------------------------------------------------------------------------- /scripts/gen_zmq_constants.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use feature 'say'; 6 | 7 | use Path::Class qw(file dir); 8 | use List::Util q(max); 9 | use autodie qw(system); 10 | 11 | my $constants_pm = 'lib/ZMQ/FFI/Constants.pm'; 12 | say "Generating '$constants_pm'"; 13 | $constants_pm = file($constants_pm)->absolute; 14 | 15 | my @versions; 16 | my %zmq_constants; 17 | my $builddir = dir("$ENV{HOME}/.zmq-ffi"); 18 | my @repos = map { "zeromq$_" } qw(2-x 3-x 4-x 4-1); 19 | push @repos, 'libzmq'; 20 | 21 | # We need to iterate each stable version of each zmq mainline to get the 22 | # complete set of all zeromq constants across versions. Some sanity checking 23 | # is also done to verify constants weren't redefined in subsequent versions 24 | for my $r (@repos) { 25 | say "\nGetting releases for $r"; 26 | 27 | my $repo_dir = $builddir->subdir("$r"); 28 | 29 | if ( ! -d "$repo_dir" ) { 30 | say "$repo_dir doesn't exist"; 31 | my $repo_url = "https://github.com/zeromq/$r.git"; 32 | say "Cloning $repo_url to $repo_dir"; 33 | system("git clone -q $repo_url $repo_dir"); 34 | } 35 | 36 | chdir "$repo_dir"; 37 | 38 | for my $version (qx(git tag)) { 39 | chomp $version; 40 | say "Getting constants for $version"; 41 | push @versions, $version; 42 | 43 | my %constants = 44 | map { split '\s+' } 45 | grep { !/ZMQ_VERSION/ } 46 | # Skip ZMQ_GROUP_MAX_LENGTH. 47 | # 48 | # The value for ZMQ_GROUP_MAX_LENGTH changed from 15 to 255 between 49 | # libzmq versions v4.3.2 and v4.3.3. 50 | # 51 | # - , 52 | # - . 53 | # 54 | # This is for the RADIO-DISH protocol that was introduced as a 55 | # draft in v4.2.0 . 56 | grep { !/ZMQ_GROUP_MAX_LENGTH/ } 57 | grep { /\b(ZMQ_[^ ]+\s+(0x)?[0-9A-F]+)/; $_ = $1; } 58 | qx(git show $version:include/zmq.h); 59 | 60 | if ($version =~ m/^v3\./ && !defined($constants{ZMQ_EVENT_ALL})) { 61 | $constants{ZMQ_EVENT_ALL} = 65535; 62 | } 63 | 64 | while ( my ($constant,$value) = each %constants ) { 65 | # handle hex values 66 | if ( $value =~ m/^0x/ ) { 67 | $value = hex($value); 68 | } 69 | 70 | if ( exists $zmq_constants{$constant} && $constant !~ m/DFLT/ ) { 71 | my $oldvalue = $zmq_constants{$constant}->[0]; 72 | my $oldversion = $zmq_constants{$constant}->[1]; 73 | 74 | if ( $value != $oldvalue ) { 75 | die "$constant redefined in $version: " 76 | ."was $oldvalue since $oldversion, now $value"; 77 | } 78 | } 79 | else { 80 | $zmq_constants{$constant} = [$value, $version]; 81 | } 82 | } 83 | } 84 | 85 | chdir '..' 86 | } 87 | 88 | my @exports; 89 | my @subs; 90 | 91 | while ( my ($constant,$data) = each %zmq_constants ) { 92 | my $value = $data->[0]; 93 | 94 | push @exports, $constant; 95 | push @subs, "sub $constant { $value }"; 96 | } 97 | 98 | 99 | # Also add dynamically generated zmq_msg_t size. we use 2x the largest 100 | # size of zmq_msg_t among all zeromq versions, including dev. This 101 | # should hopefully be large enough to accomodate fluctuations in size 102 | # between releases. Note this assumes the generated zmq_msg_sizes file exists 103 | my @zmq_msg_sizes = file("$builddir/zmq_msg_size/zmq_msg_sizes") 104 | ->slurp(chomp => 1); 105 | my $zmq_msg_size = 2 * max(@zmq_msg_sizes); 106 | push @exports, 'zmq_msg_t_size'; 107 | push @subs, "sub zmq_msg_t_size { $zmq_msg_size }"; 108 | 109 | my $exports = join "\n", sort @exports; 110 | my $subs = join "\n", sort @subs; 111 | 112 | my $date = localtime; 113 | my $first = $versions[0]; 114 | my $latest = $versions[$#versions]; 115 | 116 | my $module = <<"END"; 117 | package ZMQ::FFI::Constants; 118 | 119 | # ABSTRACT: Generated module of zmq constants. All constants, all versions. 120 | 121 | # Generated using ZMQ versions $first-$latest 122 | 123 | use strict; 124 | use warnings; 125 | 126 | use Exporter 'import'; 127 | 128 | our \@EXPORT_OK = qw( 129 | $exports 130 | ); 131 | 132 | our %EXPORT_TAGS = (all => [\@EXPORT_OK]); 133 | 134 | $subs 135 | 136 | 1; 137 | 138 | __END__ 139 | 140 | =head1 SYNOPSIS 141 | 142 | use ZMQ::FFI::Constants qw(ZMQ_LINGER ZMQ_FD); 143 | 144 | # or 145 | 146 | use ZMQ::FFI::Constants q(:all) 147 | 148 | =head1 DESCRIPTION 149 | 150 | This module includes every zmq constant from every stable version of zeromq. 151 | Currently that is $first-$latest. It was generated using the zeromq2-x, 152 | zeromq3-x, zeromq4-x, zeromq4-1, and libzmq git repos at 153 | L. 154 | 155 | =head1 SEE ALSO 156 | 157 | =for :list 158 | * L 159 | 160 | END 161 | 162 | say "\nWriting module file"; 163 | $constants_pm->spew($module); 164 | say "Done!\n"; 165 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI/ZMQ4_1/Raw.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI::ZMQ4_1::Raw; 2 | 3 | use FFI::Platypus; 4 | 5 | sub load { 6 | my ($soname) = @_; 7 | 8 | my $ffi = FFI::Platypus->new( lib => $soname // 'libzmq.so' ); 9 | my $target = caller; 10 | 11 | $ffi->attach( 12 | # void *zmq_ctx_new() 13 | ['zmq_ctx_new' => "${target}::zmq_ctx_new"] 14 | => [] => 'pointer' 15 | ); 16 | 17 | $ffi->attach( 18 | # int zmq_ctx_get(void *context, int option_name) 19 | ['zmq_ctx_get' => "${target}::zmq_ctx_get"] 20 | => ['pointer', 'int'] => 'int' 21 | ); 22 | 23 | $ffi->attach( 24 | # int zmq_ctx_set(void *context, int option_name, int option_value) 25 | ['zmq_ctx_set' => "${target}::zmq_ctx_set"] 26 | => ['pointer', 'int', 'int'] => 'int' 27 | ); 28 | 29 | $ffi->attach( 30 | # void *zmq_socket(void *context, int type) 31 | ['zmq_socket' => "${target}::zmq_socket"] 32 | => ['pointer', 'int'] => 'pointer' 33 | ); 34 | 35 | $ffi->attach( 36 | # int zmq_proxy(const void *front, const void *back, const void *cap) 37 | ['zmq_proxy' => "${target}::zmq_proxy"] 38 | => ['pointer', 'pointer', 'pointer'] => 'int' 39 | ); 40 | 41 | $ffi->attach( 42 | # int zmq_ctx_term (void *context) 43 | ['zmq_ctx_term' => "${target}::zmq_ctx_term"] 44 | => ['pointer'] => 'int' 45 | ); 46 | 47 | $ffi->attach( 48 | # int zmq_send(void *socket, void *buf, size_t len, int flags) 49 | ['zmq_send' => "${target}::zmq_send"] 50 | => ['pointer', 'string', 'size_t', 'int'] => 'int' 51 | ); 52 | 53 | $ffi->attach( 54 | # int zmq_msg_recv(zmq_msg_t *msg, void *socket, int flags) 55 | ['zmq_msg_recv' => "${target}::zmq_msg_recv"] 56 | => ['pointer', 'pointer', 'int'] => 'int' 57 | ); 58 | 59 | $ffi->attach( 60 | # int zmq_unbind(void *socket, const char *endpoint) 61 | ['zmq_unbind' => "${target}::zmq_unbind"] 62 | => ['pointer', 'string'] => 'int' 63 | ); 64 | 65 | $ffi->attach( 66 | # int zmq_disconnect(void *socket, const char *endpoint) 67 | ['zmq_disconnect' => "${target}::zmq_disconnect"] 68 | => ['pointer', 'string'] => 'int' 69 | ); 70 | 71 | $ffi->attach( 72 | # int zmq_connect(void *socket, const char *endpoint) 73 | ['zmq_connect' => "${target}::zmq_connect"] 74 | => ['pointer', 'string'] => 'int' 75 | ); 76 | 77 | $ffi->attach( 78 | # int zmq_bind(void *socket, const char *endpoint) 79 | ['zmq_bind' => "${target}::zmq_bind"] 80 | => ['pointer', 'string'] => 'int' 81 | ); 82 | 83 | $ffi->attach( 84 | # int zmq_msg_init(zmq_msg_t *msg) 85 | ['zmq_msg_init' => "${target}::zmq_msg_init"] 86 | => ['pointer'] => 'int' 87 | ); 88 | 89 | $ffi->attach( 90 | # int zmq_msg_init_size(zmq_msg_t *msg, size_t size) 91 | ['zmq_msg_init_size' => "${target}::zmq_msg_init_size"] 92 | => ['pointer', 'int'] => 'int' 93 | ); 94 | 95 | $ffi->attach( 96 | # size_t zmq_msg_size(zmq_msg_t *msg) 97 | ['zmq_msg_size' => "${target}::zmq_msg_size"] 98 | => ['pointer'] => 'int' 99 | ); 100 | 101 | $ffi->attach( 102 | # void *zmq_msg_data(zmq_msg_t *msg) 103 | ['zmq_msg_data' => "${target}::zmq_msg_data"] 104 | => ['pointer'] => 'pointer' 105 | ); 106 | 107 | $ffi->attach( 108 | # int zmq_msg_close(zmq_msg_t *msg) 109 | ['zmq_msg_close' => "${target}::zmq_msg_close"] 110 | => ['pointer'] => 'int' 111 | ); 112 | 113 | $ffi->attach( 114 | # int zmq_close(void *socket) 115 | ['zmq_close' => "${target}::zmq_close"] 116 | => ['pointer'] => 'int' 117 | ); 118 | 119 | $ffi->attach( 120 | # const char *zmq_strerror(int errnum) 121 | ['zmq_strerror' => "${target}::zmq_strerror"] 122 | => ['int'] => 'string' 123 | ); 124 | 125 | $ffi->attach( 126 | # int zmq_errno(void) 127 | ['zmq_errno' => "${target}::zmq_errno"] 128 | => [] => 'int' 129 | ); 130 | 131 | $ffi->attach( 132 | # int zmq_curve_keypair (char *z85_public_key, char *z85_secret_key); 133 | ['zmq_curve_keypair' => "${target}::zmq_curve_keypair"] 134 | => ['opaque', 'opaque'] => 'int' 135 | ); 136 | 137 | $ffi->attach( 138 | # char *zmq_z85_encode (char *dest, const uint8_t *data, size_t size); 139 | ['zmq_z85_encode' => "${target}::zmq_z85_encode"] 140 | => ['opaque', 'string', 'size_t'] => 'pointer' 141 | ); 142 | 143 | $ffi->attach( 144 | # uint8_t *zmq_z85_decode (uint8_t *dest, const char *string); 145 | ['zmq_z85_decode' => "${target}::zmq_z85_decode"] 146 | => ['opaque', 'string'] => 'pointer' 147 | ); 148 | 149 | $ffi->attach( 150 | # int zmq_has (const char *capability); 151 | ['zmq_has' => "${target}::zmq_has"] 152 | => ['string'] => 'int' 153 | ); 154 | 155 | $ffi->attach( 156 | # int zmq_socket_monitor (void *socket, char *endpoint, int events); 157 | ['zmq_socket_monitor' => "${target}::zmq_socket_monitor"] 158 | => ['pointer', 'string', 'int'] => 'int' 159 | ); 160 | } 161 | 162 | 1; 163 | -------------------------------------------------------------------------------- /t/monitor.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use v5.10; 5 | 6 | use Test::More; 7 | use Test::Warnings; 8 | use lib 't/lib'; 9 | use ZMQTest; 10 | 11 | if( ZMQTest->platform_can_sigaction ) { 12 | require Sys::SigAction; 13 | Sys::SigAction->import(qw(timeout_call)); 14 | } else { 15 | plan skip_all => 'No Sys::SigAction'; 16 | } 17 | 18 | use ZMQ::FFI qw( 19 | ZMQ_DEALER ZMQ_PAIR 20 | 21 | ZMQ_EVENT_ALL 22 | ZMQ_EVENT_CONNECTED 23 | ZMQ_EVENT_CONNECT_DELAYED 24 | ZMQ_EVENT_CONNECT_RETRIED 25 | ZMQ_EVENT_LISTENING 26 | ZMQ_EVENT_BIND_FAILED 27 | ZMQ_EVENT_ACCEPTED 28 | ZMQ_EVENT_ACCEPT_FAILED 29 | ZMQ_EVENT_CLOSED 30 | ZMQ_EVENT_CLOSE_FAILED 31 | ZMQ_EVENT_DISCONNECTED 32 | ZMQ_EVENT_MONITOR_STOPPED 33 | ZMQ_EVENT_HANDSHAKE_SUCCEEDED 34 | ); 35 | 36 | sub dump_event { 37 | my ($socket) = @_; 38 | 39 | my ($major, $minor, $patch) = $socket->version; 40 | 41 | say "----------------------------------------"; 42 | 43 | for my $message ($socket->recv_multipart()) { 44 | my $msg_len = length($message); 45 | 46 | my $is_text = 1; 47 | 48 | CHECK_TEXT: 49 | for (my $i = 0; $i < $msg_len; $i++) { 50 | my $c = ord(substr($message, $i, 1)); 51 | 52 | if ($c < 32 || $c > 126) { 53 | $is_text = 0; 54 | last CHECK_TEXT; 55 | } 56 | } 57 | 58 | printf "[%03d] ", $msg_len; 59 | 60 | if ($is_text) { 61 | say $message; 62 | } 63 | else { 64 | if ($major == 3) { 65 | say unpack('H*', $message); 66 | my ($event, $ptr, $fd) = unpack('i x4 p i x4', $message); 67 | say "$event / $ptr / $fd"; 68 | } 69 | else { 70 | my ($event, $data) = unpack('S L', $message); 71 | say "$event / $data"; 72 | } 73 | } 74 | } 75 | } 76 | 77 | subtest 'monitor', sub { 78 | my $timed_out = timeout_call(5, sub { 79 | my $ctx = ZMQ::FFI->new(); 80 | 81 | my ($major, $minor, $patch) = $ctx->version(); 82 | 83 | if ($major < 3) { 84 | pass('ZMQ2 does not support zmq_socket_monitor'); 85 | return; 86 | } 87 | 88 | my $s = $ctx->socket(ZMQ_DEALER); 89 | my $c = $ctx->socket(ZMQ_DEALER); 90 | 91 | $s->monitor('inproc://monitor-server', ZMQ_EVENT_ALL); 92 | $c->monitor('inproc://monitor-client', ZMQ_EVENT_ALL); 93 | 94 | my $ms = $ctx->socket(ZMQ_PAIR); 95 | my $mc = $ctx->socket(ZMQ_PAIR); 96 | my $ts = $ctx->socket(ZMQ_PAIR); 97 | 98 | $ms->connect('inproc://monitor-server'); 99 | $mc->connect('inproc://monitor-client'); 100 | 101 | my $endpoint = ZMQTest->endpoint("test-zmq-ffi-$$"); 102 | 103 | $s->bind($endpoint); 104 | 105 | my ($id, $value, $data) = $ms->recv_event(); 106 | 107 | cmp_ok $id, '==', ZMQ_EVENT_LISTENING, 108 | 'Received ZMQ_EVENT_LISTENING event from server socket'; 109 | 110 | cmp_ok $data, 'eq', $endpoint, 111 | "Received endpoint is $endpoint"; 112 | 113 | $c->connect($endpoint); 114 | 115 | ($id, $value, $data) = $ms->recv_event(); 116 | 117 | cmp_ok $id, '==', ZMQ_EVENT_ACCEPTED, 118 | 'Received ZMQ_EVENT_ACCEPTED event from server socket'; 119 | 120 | cmp_ok $data, 'eq', $endpoint, 121 | "Received endpoint is $endpoint"; 122 | 123 | ($id, $value, $data) = $mc->recv_event(); 124 | 125 | cmp_ok $id, '==', ZMQ_EVENT_CONNECTED, 126 | 'Received ZMQ_EVENT_CONNECTED event from client socket'; 127 | 128 | cmp_ok $data, 'eq', $endpoint, 129 | "Received endpoint is $endpoint"; 130 | 131 | $s->close(); 132 | 133 | # WARNING: 134 | # ZMQ_EVENT_HANDSHAKE_SUCCEEDED event is happend from ZMQ 4.3.2 135 | # with unknown reason and this situation seems like a bug so we need 136 | # to change below test code after fixing this bug. 137 | if ($major >= 4 && $minor >= 3 && $patch >= 2) 138 | { 139 | ($id, $value, $data) = $ms->recv_event(); 140 | 141 | cmp_ok $id, '==', ZMQ_EVENT_HANDSHAKE_SUCCEEDED 142 | 'Received ZMQ_EVENT_HANDSHAKE_SUCCEEDED event from server socket'; 143 | 144 | cmp_ok $data, 'eq', $endpoint, 145 | "Received endpoint is $endpoint"; 146 | 147 | ($id, $value, $data) = $mc->recv_event(); 148 | 149 | cmp_ok $id, '==', ZMQ_EVENT_HANDSHAKE_SUCCEEDED 150 | 'Received ZMQ_EVENT_HANDSHAKE_SUCCEEDED event from client socket'; 151 | 152 | cmp_ok $data, 'eq', $endpoint, 153 | "Received endpoint is $endpoint"; 154 | } 155 | 156 | ($id, $value, $data) = $ms->recv_event(); 157 | 158 | cmp_ok $id, '==', ZMQ_EVENT_CLOSED, 159 | 'Received ZMQ_EVENT_CLOSED event from server socket'; 160 | 161 | cmp_ok $data, 'eq', $endpoint, 162 | "Received endpoint is $endpoint"; 163 | 164 | ($id, $value, $data) = $mc->recv_event(); 165 | 166 | cmp_ok $id, '==', ZMQ_EVENT_DISCONNECTED, 167 | 'Received ZMQ_EVENT_DISCONNECTED event from client socket'; 168 | 169 | cmp_ok $data, 'eq', $endpoint, 170 | "Received endpoint is $endpoint"; 171 | }); 172 | 173 | ok !$timed_out, 174 | 'implicit Socket close done correctly (ctx destruction does not hang)'; 175 | }; 176 | 177 | done_testing; 178 | -------------------------------------------------------------------------------- /t/fork-02.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warnings; 6 | use lib 't/lib'; 7 | use ZMQTest; 8 | 9 | use ZMQ::FFI qw(ZMQ_REQ); 10 | 11 | if( ! ZMQTest->platform_can_fork ) { 12 | plan skip_all => 'fork(2) unavailable'; 13 | } 14 | 15 | # 16 | # Test that we _do_ clean up contexts/sockets created in forked children 17 | # 18 | 19 | my $parent_c = ZMQ::FFI->new(); 20 | my $parent_s = $parent_c->socket(ZMQ_REQ); 21 | 22 | my $child_pid = open(FROM_CHILDTEST, '-|') // die "fork failed $!"; 23 | 24 | if ($child_pid) { 25 | # parent process, do test assertions here 26 | 27 | my $result; 28 | read(FROM_CHILDTEST, $result, 128); 29 | 30 | waitpid $child_pid, 0; 31 | 32 | is $result, 'ok', 33 | 'child process did child ctx/socket cleanup'; 34 | 35 | 36 | my $parent_s_closed; 37 | my $parent_c_destroyed; 38 | 39 | my $parent_pid_check = sub { 40 | ok $parent_c->_pid == $$, "parent context pid _should_ match parent pid"; 41 | ok $parent_s->_pid == $$, "parent socket pid _should_ match parent pid"; 42 | 43 | # explicitly undef ctx/socket created in parent to trigger DEMOLISH/ 44 | # cleanup logic.. then verify that close/destroy _was_ called 45 | # for ctx/socket created in parent 46 | 47 | undef $parent_s; 48 | undef $parent_c; 49 | 50 | ok $parent_s_closed, "parent socket closed in parent"; 51 | ok $parent_c_destroyed, "parent context destroyed in parent"; 52 | }; 53 | 54 | my ($major, $minor) = $parent_c->version; 55 | if ($major == 2) { 56 | no warnings qw/redefine once/; 57 | 58 | local *ZMQ::FFI::ZMQ2::Socket::zmq_close = sub { 59 | $parent_s_closed = 1; 60 | }; 61 | 62 | local *ZMQ::FFI::ZMQ2::Context::zmq_term = sub { 63 | $parent_c_destroyed = 1; 64 | }; 65 | 66 | use warnings; 67 | 68 | $parent_pid_check->(); 69 | } 70 | elsif ($major == 3) { 71 | no warnings qw/redefine once/; 72 | 73 | local *ZMQ::FFI::ZMQ3::Socket::zmq_close = sub { 74 | $parent_s_closed = 1; 75 | }; 76 | 77 | local *ZMQ::FFI::ZMQ3::Context::zmq_ctx_destroy = sub { 78 | $parent_c_destroyed = 1; 79 | }; 80 | 81 | use warnings; 82 | 83 | $parent_pid_check->(); 84 | } 85 | else { 86 | if ($major == 4 and $minor == 0) { 87 | no warnings qw/redefine once/; 88 | 89 | local *ZMQ::FFI::ZMQ4::Socket::zmq_close = sub { 90 | $parent_s_closed = 1; 91 | }; 92 | 93 | local *ZMQ::FFI::ZMQ4::Context::zmq_ctx_term = sub { 94 | $parent_c_destroyed = 1; 95 | }; 96 | 97 | use warnings; 98 | 99 | $parent_pid_check->(); 100 | } 101 | else { 102 | no warnings qw/redefine once/; 103 | 104 | local *ZMQ::FFI::ZMQ4_1::Socket::zmq_close = sub { 105 | $parent_s_closed = 1; 106 | }; 107 | 108 | local *ZMQ::FFI::ZMQ4_1::Context::zmq_ctx_term = sub { 109 | $parent_c_destroyed = 1; 110 | }; 111 | 112 | use warnings; 113 | 114 | $parent_pid_check->(); 115 | } 116 | } 117 | } 118 | else { 119 | # check test expectataions and print 'ok' if successful 120 | 121 | my $child_c = ZMQ::FFI->new(); 122 | my $child_s = $child_c->socket(ZMQ_REQ); 123 | 124 | my $child_s_closed; 125 | my $child_c_destroyed; 126 | 127 | my $child_pid_check = sub { 128 | if ( $child_c->_pid != $$ ) { 129 | print "child context pid _should_ match child pid"; exit; 130 | } 131 | 132 | if ( $child_s->_pid != $$ ) { 133 | print "child socket pid _should_ match child pid"; exit; 134 | } 135 | 136 | # explicitly undef ctx/socket created in child to trigger DEMOLISH/ 137 | # cleanup logic.. then verify that close/destroy _was_ called 138 | # for ctx/socket created in child 139 | 140 | undef $child_s; 141 | undef $child_c; 142 | 143 | if ( !$child_s_closed ) { 144 | print "child socket not closed in child!"; exit; 145 | } 146 | 147 | if ( !$child_c_destroyed) { 148 | print "child context not destroyed in child!"; exit; 149 | } 150 | 151 | print 'ok'; 152 | }; 153 | 154 | my ($major, $minor) = $child_c->version; 155 | if ($major == 2) { 156 | no warnings qw/redefine once/; 157 | 158 | local *ZMQ::FFI::ZMQ2::Socket::zmq_close = sub { 159 | $child_s_closed = 1; 160 | }; 161 | 162 | local *ZMQ::FFI::ZMQ2::Context::zmq_term = sub { 163 | $child_c_destroyed = 1; 164 | }; 165 | 166 | use warnings; 167 | 168 | $child_pid_check->(); 169 | } 170 | elsif ($major == 3) { 171 | no warnings qw/redefine once/; 172 | 173 | local *ZMQ::FFI::ZMQ3::Socket::zmq_close = sub { 174 | $child_s_closed = 1; 175 | }; 176 | 177 | local *ZMQ::FFI::ZMQ3::Context::zmq_ctx_destroy = sub { 178 | $child_c_destroyed = 1; 179 | }; 180 | 181 | use warnings; 182 | 183 | $child_pid_check->(); 184 | } 185 | else { 186 | if ($major == 4 and $minor == 0) { 187 | no warnings qw/redefine once/; 188 | 189 | local *ZMQ::FFI::ZMQ4::Socket::zmq_close = sub { 190 | $child_s_closed = 1; 191 | }; 192 | 193 | local *ZMQ::FFI::ZMQ4::Context::zmq_ctx_term = sub { 194 | $child_c_destroyed = 1; 195 | }; 196 | 197 | use warnings; 198 | 199 | $child_pid_check->(); 200 | } 201 | else { 202 | no warnings qw/redefine once/; 203 | 204 | local *ZMQ::FFI::ZMQ4_1::Socket::zmq_close = sub { 205 | $child_s_closed = 1; 206 | }; 207 | 208 | local *ZMQ::FFI::ZMQ4_1::Context::zmq_ctx_term = sub { 209 | $child_c_destroyed = 1; 210 | }; 211 | 212 | use warnings; 213 | 214 | $child_pid_check->(); 215 | } 216 | } 217 | 218 | exit; 219 | } 220 | 221 | done_testing; 222 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 2 | {{$NEXT}} 3 | 4 | 1.19 2023-08-04 11:16:25+00:00 UTC 5 | 6 | 1.18 2022-03-21 10:48:44+00:00 UTC 7 | 8 | - New maintainer @ghenry - welcome and thank you! 9 | - Add MSWin32 support (GH#47 - thanks @zmughal!) 10 | - Add zmq_socket_monitor support (GH#46 - thanks @potatogim!) 11 | - Add z85_encoding support (GH#43 - thanks @juddtaylor!) 12 | - Document contributors 13 | - Update repository info. Now officially part of the zeromq project at 14 | https://github.com/zeromq/perlzmq 15 | - Have examples and scripts use 5.12 as minimum version, which enables 16 | strict by default 17 | 18 | 1.17 2019-03-14 04:05:15+00:00 UTC 19 | 20 | 1.16_01 2019-03-13 03:40:02+00:00 UTC (TRIAL RELEASE) 21 | 22 | - Need FFI::Platypus specified as a configure dependency 23 | (GH#42 - thanks @eserte) 24 | 25 | 1.15 2019-03-03 10:14:00+00:00 UTC 26 | 27 | - Bump FFI::Platypus dependency version to 0.86 28 | https://github.com/Perl5-FFI/FFI-Platypus/issues/117 29 | - Fix t/device.t hang, seems to be same cause/fix as GH#37 30 | - Update ZMQ::FFI::Constants pod to also list libzmq as one of the repos 31 | used 32 | - Don't prune constants generation script from release tarball 33 | 34 | 1.14 2019-02-28 18:49:49+00:00 UTC 35 | 36 | - The ZMQ::FFI::Constants generation script wasn't using stable releases 37 | tagged in the libzmq main repo, this is fixed 38 | - FFI::TinyCC is no longer an author dep and has been replaced by a docker 39 | based solution for generating ZMQ::FFI::Constants, including calculating 40 | zmq_msg_t sizes 41 | - Fix potential memleak around socket cleanup (GH#33 - thanks @rhrhunter!) 42 | - Use string literals for matching option types (GH#30 - thanks @bbkr) 43 | 44 | 1.12 2019-02-26 05:16:15-05:00 America/New_York 45 | 46 | - Fix t/proxy.t hang (GH#37) 47 | 48 | 1.11 2016-01-10 19:27:05-05:00 America/New_York 49 | 50 | - Fix bareword error in closed_socket.t (GH#27 - thanks @rhrhunter) 51 | 52 | 1.10 2016-01-09 15:50:59-05:00 America/New_York 53 | 54 | - support importing zmq constants directly through ZMQ::FFI (GH#24) 55 | - don't execute operations on closed sockets and emit appropriate warnings 56 | (GH#23) 57 | 58 | 1.09 2015-12-09 04:55:20-06:00 America/Chicago 59 | 60 | - add more robust cleanup handling for ooo global destruction scenarios. 61 | 62 | 1.08 2015-11-07 10:47:10-06:00 America/Chicago 63 | 64 | - Fix cleanup handling when using Perl threads 65 | 66 | 1.07 2015-09-19 12:38:32-05:00 America/Chicago 67 | 68 | - Add 4.1 to xt/test_versions.sh 69 | - Add missing 4.1 stable constants. Update constants generation script 70 | to handle hex constant values. 71 | - Add workaround for hang in device.t and proxy.t 72 | 73 | 1.06 2015-03-28 11:30:15-05:00 America/Chicago 74 | 75 | - Update FreeBSD check 76 | 77 | 1.05_02 2015-03-28 03:31:38-05:00 America/Chicago 78 | 79 | 1.05_01 2015-03-28 02:52:01-05:00 America/Chicago 80 | 81 | 1.04 2015-03-24 03:02:20-05:00 America/Chicago 82 | 83 | - require FFI::Platypus 0.33 which fixes potential segfaults during global 84 | destruction (GH#19) 85 | - don't install on unthreaded BSD perls (GH#13) 86 | - more performance improvements, incl. 30% faster recv rate in some tests 87 | see 83f0013, f834fe9, and 394e164 88 | - use a default linger of 0 (default used by czmq/jzmq) 89 | - don't clobber user linger value (GH#18) 90 | - properly localize redefines in tests 91 | - fix cleanup of ctx/sockets created in forked children 92 | 93 | 1.03 2015-03-16 04:47:24-05:00 America/Chicago 94 | 95 | - add alternative (non-exceptional) error handling semantics 96 | - fix socket files being left around after device.t and proxy.t 97 | - misc doc reformatting and rewording 98 | - don't use EV in fd.t 99 | 100 | 1.02 2015-03-12 04:51:14-05:00 America/Chicago 101 | 102 | - fix cleanup handling of inherited contexts/sockets in forked childen 103 | - don't include datetime in generated Constants module 104 | - fix pointer pack warning in ZMQ2 backend 105 | 106 | 1.01 2015-03-11 00:50:39-05:00 America/Chicago 107 | 108 | - Require Math::BigInt 1.997 or newer to resolve integer overflow bug 109 | (GH#14 - thanks @plicease!) 110 | - Perl v5.10 is now the official minimum version supported 111 | 112 | 1.00 2015-03-09 00:54:41-05:00 America/Chicago 113 | 114 | - switch to FFI::Platypus on the backend. FFI::Platypus provides the 115 | ability to bind ffi functions as first class Perl xsubs, resulting in 116 | dramatic performance gains. 117 | - optimize the Perl code in general, especially the send/recv hot spots 118 | - require Class::XSAccessor, which substantially improves Moo accessor 119 | performance 120 | - don't test against dev Perl on travis for now, seems to be busted 121 | 122 | 0.19 2015-03-04 01:42:16-06:00 America/Chicago 123 | 124 | - use dzil FFI::CheckLib plugin to properly report NA on CPAN tester boxes 125 | without libzmq 126 | - test against dev perl in addition to stable on travis 127 | 128 | 0.18 2015-02-25 07:30:20-06:00 America/Chicago 129 | 130 | - linger default has changed back to -1 for libzmq all versions 131 | - add travis tests for Perl 5.20 132 | - $! will not be localized by default when stringified in Perl 5.22 and 133 | beyond, and needs to be explicitly localized in the tests (GH#12) 134 | 135 | 0.17 2014-11-08 22:31:25-06:00 America/Chicago 136 | 137 | - add zmq_device and zmq_proxy functionality 138 | (GH#10, GH#11 - thanks @semifor) 139 | - add libzmq.so.4 to list of sonames checked 140 | - linger default is 2000 circa libzmq 4.2 141 | 142 | 0.16 2014-09-13 17:20:05-05:00 America/Chicago 143 | 144 | - generate zmq_msg_t size, don't hardcode it 145 | (GH#9 - thanks @parth-j-gandhi!) 146 | - test against libzmq dev repo in addition to stable 147 | 148 | 0.15 2014-08-15 20:39:39 America/Chicago 149 | 150 | - Apply flags correctly in multipart sends (GH#8 - thanks @shripchenko) 151 | 152 | 0.14 2014-07-06 00:39:20 America/Chicago 153 | 154 | - add disconnect POD 155 | 156 | 0.13 2014-07-05 17:03:08 America/Chicago 157 | 158 | - add zmq_disconnect and zmq_unbind bindings (GH#7) 159 | 160 | 0.12 2014-03-29 17:48:45 America/Chicago 161 | 162 | - fix binary/string option handling (e.g. ZMQ_LAST_ENDPOINT) 163 | 164 | 0.11 2014-02-17 19:50:14 America/Chicago 165 | 166 | - works on OS X now (GH#6 - thanks @wjackson!) 167 | - mucho refactor and code reorg 168 | 169 | 0.10 2014-02-14 20:27:36 America/Chicago 170 | 171 | - Implicitly use system libc by passing undef as soname to FFI::Raw 172 | Requires FFI::Raw >= 0.26 173 | 174 | 0.09 2014-01-29 08:07:12 America/Chicago 175 | 176 | - use correct pack type for zmq_version 177 | - use appropriate error function depending on the context 178 | - don't ship zmq constants generation script, which confuses CPAN 179 | 180 | 0.08 2014-01-19 01:19:49 America/Chicago 181 | 182 | - ZMQ_DONTWAIT is not necessary in examples & tests 183 | - Fix unicode bytes handling (GH#5) 184 | Thanks @klaus for test and code 185 | - Generate constants through 4.0.3 186 | - ZMQ4 support added (GH#4) 187 | Thanks @klaus for test, code, and suggestions 188 | 189 | 0.07 2013-11-10 15:38:14 America/Chicago 190 | 191 | - Support 32bit Perls (GH#1) 192 | - Make tests locale aware (GH#2) 193 | 194 | 0.06 2013-10-08 07:53:53 America/Chicago 195 | 196 | - Fix socket/context DEMOLISH order bug 197 | 198 | 0.05 2013-10-07 01:47:00 America/Chicago 199 | 200 | - Minimum required Moo version is 1.003001 201 | 202 | 0.04 2013-10-06 22:29:35 America/Chicago 203 | 204 | - Use Moo instead of Moose 205 | - Support specifying soname at object creation 206 | - Add zmq_soname and zmq_version Util functions 207 | - If soname unspecified try all libzmq sonames before failing 208 | - Major code and doc refactor 209 | - add .travis.yml for Travis CI builds 210 | 211 | 0.03 2013-10-03 14:32:50 America/Chicago 212 | 213 | - Doc additions 214 | 215 | 0.02 2013-10-03 12:32:16 America/Chicago 216 | 217 | - Doc tweaks 218 | - Don't try to close/destroy sockets/contexts if creation failed 219 | 220 | 0.01 2013-10-03 10:10:05 America/Chicago 221 | 222 | - Initial release 223 | -------------------------------------------------------------------------------- /inc/ZMQ2/SocketWrappers.pm: -------------------------------------------------------------------------------- 1 | package inc::ZMQ2::SocketWrappers; 2 | 3 | use Moo; 4 | use namespace::clean; 5 | 6 | with 'inc::SocketWrapperRole'; 7 | 8 | # 9 | # for zmq wrappers below that are hot spots (e.g. send/recv) we sacrifice 10 | # readability for performance (by for example not assigning method params 11 | # to local variables) 12 | # 13 | 14 | sub connect_tt {q( 15 | sub connect { 16 | my ($self, $endpoint) = @_; 17 | 18 | [% closed_socket_check %] 19 | 20 | unless ($endpoint) { 21 | croak 'usage: $socket->connect($endpoint)'; 22 | } 23 | 24 | $self->check_error( 25 | 'zmq_connect', 26 | zmq_connect($self->socket_ptr, $endpoint) 27 | ); 28 | } 29 | )} 30 | 31 | sub disconnect_tt {q( 32 | sub disconnect { 33 | my ($self) = @_; 34 | 35 | [% closed_socket_check %] 36 | 37 | $self->bad_version( 38 | $self->verstr, 39 | "disconnect not available in zmq 2.x" 40 | ); 41 | } 42 | )} 43 | 44 | sub bind_tt {q( 45 | sub bind { 46 | my ($self, $endpoint) = @_; 47 | 48 | [% closed_socket_check %] 49 | 50 | unless ($endpoint) { 51 | croak 'usage: $socket->bind($endpoint)' 52 | } 53 | 54 | $self->check_error( 55 | 'zmq_bind', 56 | zmq_bind($self->socket_ptr, $endpoint) 57 | ); 58 | } 59 | )} 60 | 61 | sub unbind_tt {q( 62 | sub unbind { 63 | my ($self) = @_; 64 | 65 | [% closed_socket_check %] 66 | 67 | $self->bad_version( 68 | $self->verstr, 69 | "unbind not available in zmq 2.x" 70 | ); 71 | } 72 | )} 73 | 74 | sub send_tt {q( 75 | sub send { 76 | # 0: self 77 | # 1: data 78 | # 2: flags 79 | 80 | [% closed_socket_check %] 81 | 82 | my $data_ptr; 83 | my $data_size; 84 | my $data = $_[1]; 85 | 86 | $_[0]->{last_errno} = 0; 87 | 88 | use bytes; 89 | ($data_ptr, $data_size) = scalar_to_buffer($data); 90 | no bytes; 91 | 92 | if ( -1 == zmq_msg_init_size($_[0]->{"_zmq_msg_t"}, $data_size) ) { 93 | $_[0]->{last_errno} = zmq_errno(); 94 | 95 | if ($_[0]->die_on_error) { 96 | $_[0]->fatal('zmq_msg_init_size'); 97 | } 98 | 99 | return; 100 | } 101 | 102 | my $msg_data_ptr = zmq_msg_data($_[0]->{"_zmq_msg_t"}); 103 | memcpy($msg_data_ptr, $data_ptr, $data_size); 104 | 105 | if ( -1 == zmq_send($_[0]->socket_ptr, $_[0]->{"_zmq_msg_t"}, $_[2] // 0) ) { 106 | $_[0]->{last_errno} = zmq_errno(); 107 | 108 | if ($_[0]->die_on_error) { 109 | $_[0]->fatal('zmq_send'); 110 | } 111 | 112 | return; 113 | } 114 | } 115 | )} 116 | 117 | sub send_multipart_tt {q( 118 | sub send_multipart { 119 | # 0: self 120 | # 1: partsref 121 | # 2: flags 122 | 123 | [% closed_socket_check %] 124 | 125 | my @parts = @{$_[1] // []}; 126 | unless (@parts) { 127 | croak 'usage: send_multipart($parts, $flags)'; 128 | } 129 | 130 | for my $i (0..$#parts-1) { 131 | $_[0]->send($parts[$i], ($_[2] // 0) | ZMQ_SNDMORE); 132 | 133 | # don't need to explicitly check die_on_error 134 | # since send would have exploded if it was true 135 | if ($_[0]->has_error) { 136 | return; 137 | } 138 | } 139 | 140 | $_[0]->send($parts[$#parts], $_[2] // 0); 141 | } 142 | )} 143 | 144 | sub recv_tt {q( 145 | sub recv { 146 | # 0: self 147 | # 1: flags 148 | 149 | [% closed_socket_check %] 150 | 151 | $_[0]->{last_errno} = 0; 152 | 153 | if ( -1 == zmq_recv($_[0]->socket_ptr, $_[0]->{"_zmq_msg_t"}, $_[1] // 0) ) { 154 | $_[0]->{last_errno} = zmq_errno(); 155 | 156 | if ($_[0]->die_on_error) { 157 | $_[0]->fatal('zmq_recv'); 158 | } 159 | 160 | return; 161 | } 162 | 163 | # retval = msg size 164 | my $retval = zmq_msg_size($_[0]->{"_zmq_msg_t"}); 165 | 166 | if ($retval) { 167 | return buffer_to_scalar(zmq_msg_data($_[0]->{"_zmq_msg_t"}), $retval); 168 | } 169 | 170 | return ''; 171 | } 172 | )} 173 | 174 | sub recv_multipart_tt {q( 175 | sub recv_multipart { 176 | # 0: self 177 | # 1: flags 178 | 179 | [% closed_socket_check %] 180 | 181 | my @parts = ( $_[0]->recv($_[1]) ); 182 | 183 | if ($_[0]->has_error) { 184 | return; 185 | } 186 | 187 | my $type = ($_[0]->version)[0] == 2 ? 'int64_t' : 'int'; 188 | 189 | while ( $_[0]->get(ZMQ_RCVMORE, $type) ){ 190 | push @parts, $_[0]->recv($_[1] // 0); 191 | 192 | # don't need to explicitly check die_on_error 193 | # since recv would have exploded if it was true 194 | if ($_[0]->has_error) { 195 | return; 196 | } 197 | } 198 | 199 | return @parts; 200 | } 201 | )} 202 | 203 | sub get_fd_tt {q( 204 | sub get_fd { 205 | [% closed_socket_check %] 206 | 207 | return $_[0]->get(ZMQ_FD, 'int'); 208 | } 209 | )} 210 | 211 | sub get_linger_tt {q( 212 | sub get_linger { 213 | [% closed_socket_check %] 214 | 215 | return $_[0]->get(ZMQ_LINGER, 'int'); 216 | } 217 | )} 218 | 219 | sub set_linger_tt {q( 220 | sub set_linger { 221 | my ($self, $linger) = @_; 222 | 223 | [% closed_socket_check %] 224 | 225 | $self->set(ZMQ_LINGER, 'int', $linger); 226 | } 227 | )} 228 | 229 | sub get_identity_tt {q( 230 | sub get_identity { 231 | [% closed_socket_check %] 232 | 233 | return $_[0]->get(ZMQ_IDENTITY, 'binary'); 234 | } 235 | )} 236 | 237 | sub set_identity_tt {q( 238 | sub set_identity { 239 | my ($self, $id) = @_; 240 | 241 | [% closed_socket_check %] 242 | 243 | $self->set(ZMQ_IDENTITY, 'binary', $id); 244 | } 245 | )} 246 | 247 | sub subscribe_tt {q( 248 | sub subscribe { 249 | my ($self, $topic) = @_; 250 | 251 | [% closed_socket_check %] 252 | 253 | $self->set(ZMQ_SUBSCRIBE, 'binary', $topic); 254 | } 255 | )} 256 | 257 | sub unsubscribe_tt {q( 258 | sub unsubscribe { 259 | my ($self, $topic) = @_; 260 | 261 | [% closed_socket_check %] 262 | 263 | $self->set(ZMQ_UNSUBSCRIBE, 'binary', $topic); 264 | } 265 | )} 266 | 267 | sub has_pollin_tt {q( 268 | sub has_pollin { 269 | [% closed_socket_check %] 270 | 271 | return $_[0]->get(ZMQ_EVENTS, 'int') & ZMQ_POLLIN; 272 | } 273 | )} 274 | 275 | sub has_pollout_tt {q( 276 | sub has_pollout { 277 | [% closed_socket_check %] 278 | 279 | return $_[0]->get(ZMQ_EVENTS, 'int') & ZMQ_POLLOUT; 280 | } 281 | )} 282 | 283 | sub get_tt {q( 284 | sub get { 285 | my ($self, $opt, $opt_type) = @_; 286 | 287 | [% closed_socket_check %] 288 | 289 | my $optval; 290 | my $optval_len; 291 | 292 | for ($opt_type) { 293 | if ($_ =~ /^(binary|string)$/) { 294 | # ZMQ_IDENTITY uses binary type and can be at most 255 bytes long 295 | # 296 | # ZMQ_LAST_ENDPOINT uses string type and expects a buffer large 297 | # enough to hold an endpoint string 298 | # 299 | # So for these cases 256 should be sufficient (including \0). 300 | # Other binary/string opts are being added all the time, and 301 | # hopefully this value scales, but we can always increase it if 302 | # necessary 303 | my $optval_ptr = malloc(256); 304 | $optval_len = 256; 305 | 306 | $self->check_error( 307 | 'zmq_getsockopt', 308 | zmq_getsockopt_binary( 309 | $self->socket_ptr, 310 | $opt, 311 | $optval_ptr, 312 | \$optval_len 313 | ) 314 | ); 315 | 316 | if ($self->has_error) { 317 | free($optval_ptr); 318 | return; 319 | } 320 | 321 | if ($opt_type eq 'binary') { 322 | $optval = buffer_to_scalar($optval_ptr, $optval_len); 323 | free($optval_ptr); 324 | } 325 | else { # string 326 | # FFI::Platypus already appends a null terminating byte for 327 | # strings, so strip the one included by zeromq (otherwise test 328 | # comparisons fail due to the extra NUL) 329 | $optval = buffer_to_scalar($optval_ptr, $optval_len-1); 330 | free($optval_ptr); 331 | } 332 | } 333 | 334 | elsif ($_ eq 'int') { 335 | $optval_len = $self->sockopt_sizes->{'int'}; 336 | $self->check_error( 337 | 'zmq_getsockopt', 338 | zmq_getsockopt_int( 339 | $self->socket_ptr, 340 | $opt, 341 | \$optval, 342 | \$optval_len 343 | ) 344 | ); 345 | } 346 | 347 | elsif ($_ eq 'int64_t') { 348 | $optval_len = $self->sockopt_sizes->{'sint64'}; 349 | $self->check_error( 350 | 'zmq_getsockopt', 351 | zmq_getsockopt_int64( 352 | $self->socket_ptr, 353 | $opt, 354 | \$optval, 355 | \$optval_len 356 | ) 357 | ); 358 | } 359 | 360 | elsif ($_ eq 'uint64_t') { 361 | $optval_len = $self->sockopt_sizes->{'uint64'}; 362 | $self->check_error( 363 | 'zmq_getsockopt', 364 | zmq_getsockopt_uint64( 365 | $self->socket_ptr, 366 | $opt, 367 | \$optval, 368 | \$optval_len 369 | ) 370 | ); 371 | } 372 | 373 | else { 374 | croak "unknown type $opt_type"; 375 | } 376 | } 377 | 378 | if ($optval ne '') { 379 | return $optval; 380 | } 381 | 382 | return; 383 | } 384 | )} 385 | 386 | sub set_tt {q( 387 | sub set { 388 | my ($self, $opt, $opt_type, $optval) = @_; 389 | 390 | [% closed_socket_check %] 391 | 392 | for ($opt_type) { 393 | if ($_ =~ /^(binary|string)$/) { 394 | my ($optval_ptr, $optval_len) = scalar_to_buffer($optval); 395 | $self->check_error( 396 | 'zmq_setsockopt', 397 | zmq_setsockopt_binary( 398 | $self->socket_ptr, 399 | $opt, 400 | $optval_ptr, 401 | $optval_len 402 | ) 403 | ); 404 | } 405 | 406 | elsif ($_ eq 'int') { 407 | $self->check_error( 408 | 'zmq_setsockopt', 409 | zmq_setsockopt_int( 410 | $self->socket_ptr, 411 | $opt, 412 | \$optval, 413 | $self->sockopt_sizes->{'int'} 414 | ) 415 | ); 416 | } 417 | 418 | elsif ($_ eq 'int64_t') { 419 | $self->check_error( 420 | 'zmq_setsockopt', 421 | zmq_setsockopt_int64( 422 | $self->socket_ptr, 423 | $opt, 424 | \$optval, 425 | $self->sockopt_sizes->{'sint64'} 426 | ) 427 | ); 428 | } 429 | 430 | elsif ($_ eq 'uint64_t') { 431 | $self->check_error( 432 | 'zmq_setsockopt', 433 | zmq_setsockopt_uint64( 434 | $self->socket_ptr, 435 | $opt, 436 | \$optval, 437 | $self->sockopt_sizes->{'uint64'} 438 | ) 439 | ); 440 | } 441 | 442 | else { 443 | croak "unknown type $opt_type"; 444 | } 445 | } 446 | 447 | return; 448 | } 449 | )} 450 | 451 | sub close_tt {q( 452 | sub close { 453 | my ($self) = @_; 454 | 455 | [% closed_socket_check %] 456 | 457 | # don't try to cleanup socket cloned from another thread 458 | return unless $self->_tid == current_tid(); 459 | 460 | # don't try to cleanup socket copied from another process (fork) 461 | return unless $self->_pid == $$; 462 | 463 | $self->check_error( 464 | 'zmq_msg_close', 465 | zmq_msg_close($self->_zmq_msg_t) 466 | ); 467 | 468 | $self->check_error( 469 | 'zmq_close', 470 | zmq_close($self->socket_ptr) 471 | ); 472 | 473 | $self->socket_ptr(-1); 474 | } 475 | )} 476 | 477 | sub monitor_tt {q( 478 | sub monitor { 479 | my ($self) = @_; 480 | 481 | [% closed_socket_check %] 482 | 483 | $self->bad_version( 484 | $self->verstr, 485 | "monitor not available in zmq 2.x" 486 | ); 487 | } 488 | )} 489 | 490 | sub recv_event_tt {q( 491 | sub recv_event { 492 | my ($self) = @_; 493 | 494 | [% closed_socket_check %] 495 | 496 | $self->bad_version( 497 | $self->verstr, 498 | "recv_event not available in zmq 2.x" 499 | ); 500 | } 501 | )} 502 | 503 | 1; 504 | -------------------------------------------------------------------------------- /lib/ZMQ/FFI.pm: -------------------------------------------------------------------------------- 1 | package ZMQ::FFI; 2 | 3 | # ABSTRACT: version agnostic Perl bindings for zeromq using ffi 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use ZMQ::FFI::Util qw(zmq_soname zmq_version valid_soname); 9 | use Carp; 10 | 11 | use Import::Into; 12 | 13 | sub import { 14 | my ($pkg, @import_args) = @_; 15 | 16 | my $target = caller; 17 | ZMQ::FFI::Constants->import::into($target, @import_args); 18 | } 19 | 20 | sub new { 21 | my ($self, %args) = @_; 22 | 23 | if ($args{soname}) { 24 | unless ( valid_soname($args{soname}) ) { 25 | die "Failed to load '$args{soname}', is it on your loader path?"; 26 | } 27 | } 28 | else { 29 | $args{soname} = zmq_soname( die => 1 ); 30 | } 31 | 32 | my ($major, $minor) = zmq_version($args{soname}); 33 | 34 | if ($major == 2) { 35 | require ZMQ::FFI::ZMQ2::Context; 36 | return ZMQ::FFI::ZMQ2::Context->new(%args); 37 | } 38 | elsif ($major == 3) { 39 | require ZMQ::FFI::ZMQ3::Context; 40 | return ZMQ::FFI::ZMQ3::Context->new(%args); 41 | } 42 | else { 43 | if ($major == 4 and $minor == 0) { 44 | require ZMQ::FFI::ZMQ4::Context; 45 | return ZMQ::FFI::ZMQ4::Context->new(%args); 46 | } 47 | else { 48 | require ZMQ::FFI::ZMQ4_1::Context; 49 | return ZMQ::FFI::ZMQ4_1::Context->new(%args); 50 | } 51 | } 52 | } 53 | 54 | 1; 55 | 56 | __END__ 57 | 58 | =head1 SYNOPSIS 59 | 60 | #### send/recv #### 61 | 62 | use 5.012; 63 | use ZMQ::FFI qw(ZMQ_REQ ZMQ_REP); 64 | 65 | my $endpoint = "ipc://zmq-ffi-$$"; 66 | my $ctx = ZMQ::FFI->new(); 67 | 68 | my $s1 = $ctx->socket(ZMQ_REQ); 69 | $s1->connect($endpoint); 70 | 71 | my $s2 = $ctx->socket(ZMQ_REP); 72 | $s2->bind($endpoint); 73 | 74 | $s1->send('ohhai'); 75 | 76 | say $s2->recv(); 77 | # ohhai 78 | 79 | 80 | #### pub/sub #### 81 | 82 | use 5.012; 83 | use ZMQ::FFI qw(ZMQ_PUB ZMQ_SUB); 84 | use Time::HiRes q(usleep); 85 | 86 | my $endpoint = "ipc://zmq-ffi-$$"; 87 | my $ctx = ZMQ::FFI->new(); 88 | 89 | my $s = $ctx->socket(ZMQ_SUB); 90 | my $p = $ctx->socket(ZMQ_PUB); 91 | 92 | $s->connect($endpoint); 93 | $p->bind($endpoint); 94 | 95 | # all topics 96 | { 97 | $s->subscribe(''); 98 | 99 | until ($s->has_pollin) { 100 | # compensate for slow subscriber 101 | usleep 100_000; 102 | $p->send('ohhai'); 103 | } 104 | 105 | say $s->recv(); 106 | # ohhai 107 | 108 | $s->unsubscribe(''); 109 | } 110 | 111 | # specific topics 112 | { 113 | $s->subscribe('topic1'); 114 | $s->subscribe('topic2'); 115 | 116 | until ($s->has_pollin) { 117 | usleep 100_000; 118 | $p->send('topic1 ohhai'); 119 | $p->send('topic2 ohhai'); 120 | } 121 | 122 | while ($s->has_pollin) { 123 | say join ' ', $s->recv(); 124 | # topic1 ohhai 125 | # topic2 ohhai 126 | } 127 | } 128 | 129 | 130 | #### multipart #### 131 | 132 | use 5.012; 133 | use ZMQ::FFI qw(ZMQ_DEALER ZMQ_ROUTER); 134 | 135 | my $endpoint = "ipc://zmq-ffi-$$"; 136 | my $ctx = ZMQ::FFI->new(); 137 | 138 | my $d = $ctx->socket(ZMQ_DEALER); 139 | $d->set_identity('dealer'); 140 | 141 | my $r = $ctx->socket(ZMQ_ROUTER); 142 | 143 | $d->connect($endpoint); 144 | $r->bind($endpoint); 145 | 146 | $d->send_multipart([qw(ABC DEF GHI)]); 147 | 148 | say join ' ', $r->recv_multipart; 149 | # dealer ABC DEF GHI 150 | 151 | 152 | #### nonblocking #### 153 | 154 | use 5.012; 155 | use ZMQ::FFI qw(ZMQ_PUSH ZMQ_PULL); 156 | use AnyEvent; 157 | use EV; 158 | 159 | my $endpoint = "ipc://zmq-ffi-$$"; 160 | my $ctx = ZMQ::FFI->new(); 161 | my @messages = qw(foo bar baz); 162 | 163 | 164 | my $pull = $ctx->socket(ZMQ_PULL); 165 | $pull->bind($endpoint); 166 | 167 | my $fd = $pull->get_fd(); 168 | 169 | my $recv = 0; 170 | my $w = AE::io $fd, 0, sub { 171 | while ( $pull->has_pollin ) { 172 | say $pull->recv(); 173 | # foo, bar, baz 174 | 175 | $recv++; 176 | if ($recv == 3) { 177 | EV::break(); 178 | } 179 | } 180 | }; 181 | 182 | 183 | my $push = $ctx->socket(ZMQ_PUSH); 184 | $push->connect($endpoint); 185 | 186 | my $sent = 0; 187 | my $t; 188 | $t = AE::timer 0, .1, sub { 189 | $push->send($messages[$sent]); 190 | 191 | $sent++; 192 | if ($sent == 3) { 193 | undef $t; 194 | } 195 | }; 196 | 197 | EV::run(); 198 | 199 | 200 | #### specifying versions #### 201 | 202 | use ZMQ::FFI; 203 | 204 | # 2.x context 205 | my $ctx = ZMQ::FFI->new( soname => 'libzmq.so.1' ); 206 | my ($major, $minor, $patch) = $ctx->version; 207 | 208 | # 3.x context 209 | my $ctx = ZMQ::FFI->new( soname => 'libzmq.so.3' ); 210 | my ($major, $minor, $patch) = $ctx->version; 211 | 212 | 213 | =head1 DESCRIPTION 214 | 215 | ZMQ::FFI exposes a high level, transparent, OO interface to zeromq independent 216 | of the underlying libzmq version. Where semantics differ, it will dispatch to 217 | the appropriate backend for you. As it uses ffi, there is no dependency on XS 218 | or compilation. 219 | 220 | As of 1.00 ZMQ::FFI is implemented using L. This version has 221 | substantial performance improvements and you are encouraged to use 1.00 or 222 | newer. 223 | 224 | =head1 CONTEXT API 225 | 226 | =head2 new 227 | 228 | my $ctx = ZMQ::FFI->new(%options); 229 | 230 | returns a new context object, appropriate for the version of 231 | libzmq found on your system. It accepts the following optional attributes: 232 | 233 | =head3 options 234 | 235 | =over 4 236 | 237 | =item threads 238 | 239 | zeromq thread pool size. Default: 1 240 | 241 | =item max_sockets 242 | 243 | I= 3.x> 244 | 245 | max number of sockets allowed for context. Default: 1024 246 | 247 | =item soname 248 | 249 | ZMQ::FFI->new( soname => '/path/to/libzmq.so' ); 250 | ZMQ::FFI->new( soname => 'libzmq.so.3' ); 251 | 252 | specify the libzmq library name to load. By default ZMQ::FFI will first try 253 | the generic soname for the system, then the soname for each version of zeromq 254 | (e.g. libzmq.so.3). C can also be the path to a particular libzmq so 255 | file 256 | 257 | It is technically possible to have multiple contexts of different versions in 258 | the same process, though the utility of doing such a thing is dubious 259 | 260 | =back 261 | 262 | =head2 version 263 | 264 | my ($major, $minor, $patch) = $ctx->version(); 265 | 266 | return the libzmq version as the list C<($major, $minor, $patch)> 267 | 268 | =head2 get 269 | 270 | I= 3.x> 271 | 272 | my $threads = $ctx->get(ZMQ_IO_THREADS) 273 | 274 | get a context option value 275 | 276 | =head2 set 277 | 278 | I= 3.x> 279 | 280 | $ctx->set(ZMQ_MAX_SOCKETS, 42) 281 | 282 | set a context option value 283 | 284 | =head2 socket 285 | 286 | my $socket = $ctx->socket(ZMQ_REQ) 287 | 288 | returns a socket of the specified type. See L below 289 | 290 | =head2 proxy 291 | 292 | $ctx->proxy($frontend, $backend); 293 | 294 | $ctx->proxy($frontend, $backend, $capture); 295 | 296 | sets up and runs a C. For zmq 2.x this will use a C 297 | device to simulate the proxy. The optional C<$capture> is only supported for 298 | zmq E= 3.x however 299 | 300 | =head2 device 301 | 302 | I 303 | 304 | $ctx->device($type, $frontend, $backend); 305 | 306 | sets up and runs a C with specified frontend and backend sockets 307 | 308 | =head2 destroy 309 | 310 | destroy the underlying zmq context. In general you shouldn't have to call this 311 | directly as it is called automatically for you when the object gets reaped 312 | 313 | See L below 314 | 315 | =head1 SOCKET API 316 | 317 | The following API is available on socket objects created by C<$ctx-Esocket>. 318 | 319 | For core attributes and functions, common across all versions of zeromq, 320 | convenience methods are provided. Otherwise, generic get/set methods are 321 | provided that will work independent of version. 322 | 323 | As attributes are constantly being added/removed from zeromq, it is unlikely 324 | the 'static' accessors will grow much beyond the current set. 325 | 326 | =head2 version 327 | 328 | my ($major, $minor, $patch) = $socket->version(); 329 | 330 | same as Context C above 331 | 332 | =head2 connect 333 | 334 | $socket->connect($endpoint); 335 | 336 | does socket connect on the specified endpoint 337 | 338 | =head2 disconnect 339 | 340 | I= 3.x> 341 | 342 | $socket->disconnect($endpoint); 343 | 344 | does socket disconnect on the specified endpoint 345 | 346 | =head2 bind 347 | 348 | $socket->bind($endpoint); 349 | 350 | does socket bind on the specified endpoint 351 | 352 | =head2 unbind 353 | 354 | I= 3.x> 355 | 356 | $socket->unbind($endpoint); 357 | 358 | does socket unbind on the specified endpoint 359 | 360 | =head2 get_linger, set_linger 361 | 362 | my $linger = $socket->get_linger(); 363 | 364 | $socket->set_linger($millis); 365 | 366 | get or set the socket linger period. Default: 0 (no linger) 367 | 368 | See L below 369 | 370 | =head2 get_identity, set_identity 371 | 372 | my $ident = $socket->get_identity(); 373 | 374 | $socket->set_identity($ident); 375 | 376 | get or set the socket identity for request/reply patterns 377 | 378 | =head2 get_fd 379 | 380 | my $fd = $socket->get_fd(); 381 | 382 | get the file descriptor associated with the socket 383 | 384 | =head2 get 385 | 386 | my $option_value = $socket->get($option_name, $option_type); 387 | 388 | my $linger = $socket->get(ZMQ_LINGER, 'int'); 389 | 390 | generic method to get the value for any socket option. C<$option_type> is the 391 | type associated with C<$option_value> in the zeromq API (C man 392 | page) 393 | 394 | =head2 set 395 | 396 | $socket->set($option_name, $option_type, $option_value); 397 | 398 | $socket->set(ZMQ_IDENTITY, 'binary', 'foo'); 399 | 400 | generic method to set the value for any socket option. C<$option_type> is the 401 | type associated with C<$option_value> in the zeromq API (C man 402 | page) 403 | 404 | =head2 subscribe 405 | 406 | $socket->subscribe($topic); 407 | 408 | add C<$topic> to the subscription list 409 | 410 | =head2 unsubscribe 411 | 412 | $socket->unsubscribe($topic); 413 | 414 | remove C<$topic> from the subscription list 415 | 416 | =head2 send 417 | 418 | $socket->send($msg); 419 | 420 | $socket->send($msg, $flags); 421 | 422 | sends a message using the optional flags 423 | 424 | =head2 send_multipart 425 | 426 | $socket->send($parts_aref); 427 | 428 | $socket->send($parts_aref, $flags); 429 | 430 | given an array ref of message parts, sends the multipart message using the 431 | optional flags. ZMQ_SNDMORE semantics are handled for you 432 | 433 | =head2 recv 434 | 435 | my $msg = $socket->recv(); 436 | 437 | my $msg = $socket->recv($flags); 438 | 439 | receives a message using the optional flags 440 | 441 | =head2 recv_multipart 442 | 443 | my @parts = $socket->recv_multipart(); 444 | 445 | my @parts = $socket->recv_multipart($flags); 446 | 447 | receives a multipart message, returning an array of parts. ZMQ_RCVMORE 448 | semantics are handled for you 449 | 450 | =head2 has_pollin, has_pollout 451 | 452 | while ( $socket->has_pollin ) { ... } 453 | 454 | checks ZMQ_EVENTS for ZMQ_POLLIN and ZMQ_POLLOUT respectively, and returns 455 | true/false depending on the state 456 | 457 | =head2 close 458 | 459 | close the underlying zmq socket. In general you shouldn't have to call this 460 | directly as it is called automatically for you when the object gets reaped 461 | 462 | See L below 463 | 464 | =head2 die_on_error 465 | 466 | $socket->die_on_error(0); 467 | 468 | $socket->die_on_error(1); 469 | 470 | controls whether error handling should be exceptional or not. This is set to 471 | true by default. See L below 472 | 473 | =head2 has_error 474 | 475 | returns true or false depending on whether the last socket operation had an 476 | error. This is really just an alias for C 477 | 478 | =head2 last_errno 479 | 480 | returns the system C set by the last socket operation, or 0 if there 481 | was no error 482 | 483 | =head2 last_strerror 484 | 485 | returns the human readable system error message associated with the socket 486 | C 487 | 488 | =head1 CLEANUP 489 | 490 | With respect to cleanup C follows either the L 491 | recommendations or the behavior of other zmq bindings. 492 | That is: 493 | 494 | =over 4 495 | 496 | =item * it uses 0 linger by default (this is the default used by L and L) 497 | 498 | =item * during object destruction it will call close/destroy for you 499 | 500 | =item * it arranges the reference hierarchy such that sockets will be properly 501 | cleaned up before their associated contexts 502 | 503 | =item * it detects fork/thread situations and ensures sockets/contexts are only 504 | cleaned up in their originating process/thread 505 | 506 | =item * it guards against double closes/destroys 507 | 508 | =back 509 | 510 | Given the above you're probably better off letting C handle cleanup 511 | for you. But if for some reason you want to do explicit cleanup yourself you 512 | can. All the below will accomplish the same thing: 513 | 514 | # implicit cleanup 515 | { 516 | my $context = ZMQ::FFI->new(); 517 | my $socket = $ctx->socket($type); 518 | ... 519 | # close/destroy called in destructors at end of scope 520 | } 521 | 522 | # explicit cleanup 523 | $socket->close(); 524 | $context->destroy(); 525 | 526 | # ditto 527 | undef $socket; 528 | undef $context; 529 | 530 | Regarding C, you can always set this to a value you prefer if 531 | you don't like the default. Once set the new value will be used when the 532 | socket is subsequently closed (either implicitly or explicitly): 533 | 534 | $socket->set_linger(-1); # infinite linger 535 | # $context->destroy will block forever 536 | # (or until all pending messages have been sent) 537 | 538 | =head1 ERROR HANDLING 539 | 540 | By default, ZMQ::FFI checks the return codes of underlying zmq functions for 541 | you, and in the case of an error it will die with the human readable system 542 | error message. 543 | 544 | $ctx->socket(-1); 545 | # dies with 'zmq_socket: Invalid argument' 546 | 547 | Usually this is what you want, but not always. Some zmq operations can return 548 | errors that are not fatal and should be handled. For example using 549 | C with send/recv can return C and simply means try 550 | again, not die. 551 | 552 | For situations such as this you can turn off exceptional error handling by 553 | setting C to 0. It is then for you to check and manage any zmq 554 | errors by checking C: 555 | 556 | use Errno qw(EAGAIN); 557 | 558 | my $ctx = ZMQ::FFI->new(); 559 | my $s = $ctx->socket(ZMQ_DEALER); 560 | $s->bind('tcp://*:7200'); 561 | 562 | $s->die_on_error(0); # turn off exceptional error handling 563 | 564 | while (1) { 565 | my $msg = $s->recv(ZMQ_DONTWAIT); 566 | 567 | if ($s->last_errno == EAGAIN) { 568 | sleep 1; 569 | } 570 | elsif ($s->last_errno) { 571 | die $s->last_strerror; 572 | } 573 | else { 574 | warn "recvd: $msg"; 575 | last; 576 | } 577 | } 578 | 579 | $s->die_on_error(1); # turn back on exceptional error handling 580 | 581 | =head1 FFI VS XS PERFORMANCE 582 | 583 | ZMQ::FFI uses L on the backend. In addition to a friendly, 584 | usable interface, FFI::Platypus's killer feature is C. C makes 585 | it possible to bind ffi functions in memory as first class Perl xsubs. This 586 | results in dramatic performance gains and gives you the flexibility of ffi 587 | with performance approaching that of XS. 588 | 589 | Testing indicates FFI::Platypus xsubs are around 30% slower than "real" XS 590 | xsubs. That may sound like a lot, but to put it in perspective that means, for 591 | zeromq, the XS bindings can send 10 million messages 1-2 seconds faster than 592 | the ffi ones. 593 | 594 | If you really care about 1-2 seconds over 10 million messages you should be 595 | writing your solution in C anyways. An equivalent C implementation will be 596 | several I percent faster or more. 597 | 598 | Keep in mind also that the small speed bump you get using XS can easily be 599 | wiped out by crappy and poorly optimized Perl code. 600 | 601 | Now that Perl finally has a great ffi interface, it is hard to make the case 602 | to continue using XS. The slight speed bump just isn't worth giving up the 603 | convenience, flexibility, and portability of ffi. 604 | 605 | You can find the detailed performance results that informed this section at: 606 | L 607 | 608 | =head1 BUGS 609 | 610 | C is free as in beer in addition to being free as in speech. While 611 | I've done my best to ensure it's tasty, high quality beer, it probably isn't perfect. 612 | If you encounter problems, or otherwise see room for improvement, please open 613 | an issue (or even better a pull request!) on L 614 | 615 | =head1 SEE ALSO 616 | 617 | =for :list 618 | * L 619 | * L 620 | * L 621 | * L 622 | * L 623 | 624 | =head1 CREDITS 625 | 626 | Thank you to the following for patches, bug reports, feedback, or suggestions: 627 | 628 | Dave Lambley, Graham Ollis, Klaus Ita, Marc Mims, Parth Gandhi, Pawel Pabian, 629 | Robert Hunter, Sergey KHripchenko, Slaven Rezic, Whitney Jackson, pipcet 630 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | This software is copyright (c) 2013 by Dylan Cali. 2 | 3 | This is free software; you can redistribute it and/or modify it under 4 | the same terms as the Perl 5 programming language system itself. 5 | 6 | Terms of the Perl programming language system itself 7 | 8 | a) the GNU General Public License as published by the Free 9 | Software Foundation; either version 1, or (at your option) any 10 | later version, or 11 | b) the "Artistic License" 12 | 13 | --- The GNU General Public License, Version 1, February 1989 --- 14 | 15 | This software is Copyright (c) 2013 by Dylan Cali. 16 | 17 | This is free software, licensed under: 18 | 19 | The GNU General Public License, Version 1, February 1989 20 | 21 | GNU GENERAL PUBLIC LICENSE 22 | Version 1, February 1989 23 | 24 | Copyright (C) 1989 Free Software Foundation, Inc. 25 | 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA 26 | 27 | Everyone is permitted to copy and distribute verbatim copies 28 | of this license document, but changing it is not allowed. 29 | 30 | Preamble 31 | 32 | The license agreements of most software companies try to keep users 33 | at the mercy of those companies. By contrast, our General Public 34 | License is intended to guarantee your freedom to share and change free 35 | software--to make sure the software is free for all its users. The 36 | General Public License applies to the Free Software Foundation's 37 | software and to any other program whose authors commit to using it. 38 | You can use it for your programs, too. 39 | 40 | When we speak of free software, we are referring to freedom, not 41 | price. Specifically, the General Public License is designed to make 42 | sure that you have the freedom to give away or sell copies of free 43 | software, that you receive source code or can get it if you want it, 44 | that you can change the software or use pieces of it in new free 45 | programs; and that you know you can do these things. 46 | 47 | To protect your rights, we need to make restrictions that forbid 48 | anyone to deny you these rights or to ask you to surrender the rights. 49 | These restrictions translate to certain responsibilities for you if you 50 | distribute copies of the software, or if you modify it. 51 | 52 | For example, if you distribute copies of a such a program, whether 53 | gratis or for a fee, you must give the recipients all the rights that 54 | you have. You must make sure that they, too, receive or can get the 55 | source code. And you must tell them their rights. 56 | 57 | We protect your rights with two steps: (1) copyright the software, and 58 | (2) offer you this license which gives you legal permission to copy, 59 | distribute and/or modify the software. 60 | 61 | Also, for each author's protection and ours, we want to make certain 62 | that everyone understands that there is no warranty for this free 63 | software. If the software is modified by someone else and passed on, we 64 | want its recipients to know that what they have is not the original, so 65 | that any problems introduced by others will not reflect on the original 66 | authors' reputations. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | GNU GENERAL PUBLIC LICENSE 72 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 73 | 74 | 0. This License Agreement applies to any program or other work which 75 | contains a notice placed by the copyright holder saying it may be 76 | distributed under the terms of this General Public License. The 77 | "Program", below, refers to any such program or work, and a "work based 78 | on the Program" means either the Program or any work containing the 79 | Program or a portion of it, either verbatim or with modifications. Each 80 | licensee is addressed as "you". 81 | 82 | 1. You may copy and distribute verbatim copies of the Program's source 83 | code as you receive it, in any medium, provided that you conspicuously and 84 | appropriately publish on each copy an appropriate copyright notice and 85 | disclaimer of warranty; keep intact all the notices that refer to this 86 | General Public License and to the absence of any warranty; and give any 87 | other recipients of the Program a copy of this General Public License 88 | along with the Program. You may charge a fee for the physical act of 89 | transferring a copy. 90 | 91 | 2. You may modify your copy or copies of the Program or any portion of 92 | it, and copy and distribute such modifications under the terms of Paragraph 93 | 1 above, provided that you also do the following: 94 | 95 | a) cause the modified files to carry prominent notices stating that 96 | you changed the files and the date of any change; and 97 | 98 | b) cause the whole of any work that you distribute or publish, that 99 | in whole or in part contains the Program or any part thereof, either 100 | with or without modifications, to be licensed at no charge to all 101 | third parties under the terms of this General Public License (except 102 | that you may choose to grant warranty protection to some or all 103 | third parties, at your option). 104 | 105 | c) If the modified program normally reads commands interactively when 106 | run, you must cause it, when started running for such interactive use 107 | in the simplest and most usual way, to print or display an 108 | announcement including an appropriate copyright notice and a notice 109 | that there is no warranty (or else, saying that you provide a 110 | warranty) and that users may redistribute the program under these 111 | conditions, and telling the user how to view a copy of this General 112 | Public License. 113 | 114 | d) You may charge a fee for the physical act of transferring a 115 | copy, and you may at your option offer warranty protection in 116 | exchange for a fee. 117 | 118 | Mere aggregation of another independent work with the Program (or its 119 | derivative) on a volume of a storage or distribution medium does not bring 120 | the other work under the scope of these terms. 121 | 122 | 3. You may copy and distribute the Program (or a portion or derivative of 123 | it, under Paragraph 2) in object code or executable form under the terms of 124 | Paragraphs 1 and 2 above provided that you also do one of the following: 125 | 126 | a) accompany it with the complete corresponding machine-readable 127 | source code, which must be distributed under the terms of 128 | Paragraphs 1 and 2 above; or, 129 | 130 | b) accompany it with a written offer, valid for at least three 131 | years, to give any third party free (except for a nominal charge 132 | for the cost of distribution) a complete machine-readable copy of the 133 | corresponding source code, to be distributed under the terms of 134 | Paragraphs 1 and 2 above; or, 135 | 136 | c) accompany it with the information you received as to where the 137 | corresponding source code may be obtained. (This alternative is 138 | allowed only for noncommercial distribution and only if you 139 | received the program in object code or executable form alone.) 140 | 141 | Source code for a work means the preferred form of the work for making 142 | modifications to it. For an executable file, complete source code means 143 | all the source code for all modules it contains; but, as a special 144 | exception, it need not include source code for modules which are standard 145 | libraries that accompany the operating system on which the executable 146 | file runs, or for standard header files or definitions files that 147 | accompany that operating system. 148 | 149 | 4. You may not copy, modify, sublicense, distribute or transfer the 150 | Program except as expressly provided under this General Public License. 151 | Any attempt otherwise to copy, modify, sublicense, distribute or transfer 152 | the Program is void, and will automatically terminate your rights to use 153 | the Program under this License. However, parties who have received 154 | copies, or rights to use copies, from you under this General Public 155 | License will not have their licenses terminated so long as such parties 156 | remain in full compliance. 157 | 158 | 5. By copying, distributing or modifying the Program (or any work based 159 | on the Program) you indicate your acceptance of this license to do so, 160 | and all its terms and conditions. 161 | 162 | 6. Each time you redistribute the Program (or any work based on the 163 | Program), the recipient automatically receives a license from the original 164 | licensor to copy, distribute or modify the Program subject to these 165 | terms and conditions. You may not impose any further restrictions on the 166 | recipients' exercise of the rights granted herein. 167 | 168 | 7. The Free Software Foundation may publish revised and/or new versions 169 | of the General Public License from time to time. Such new versions will 170 | be similar in spirit to the present version, but may differ in detail to 171 | address new problems or concerns. 172 | 173 | Each version is given a distinguishing version number. If the Program 174 | specifies a version number of the license which applies to it and "any 175 | later version", you have the option of following the terms and conditions 176 | either of that version or of any later version published by the Free 177 | Software Foundation. If the Program does not specify a version number of 178 | the license, you may choose any version ever published by the Free Software 179 | Foundation. 180 | 181 | 8. If you wish to incorporate parts of the Program into other free 182 | programs whose distribution conditions are different, write to the author 183 | to ask for permission. For software which is copyrighted by the Free 184 | Software Foundation, write to the Free Software Foundation; we sometimes 185 | make exceptions for this. Our decision will be guided by the two goals 186 | of preserving the free status of all derivatives of our free software and 187 | of promoting the sharing and reuse of software generally. 188 | 189 | NO WARRANTY 190 | 191 | 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 192 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 193 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 194 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 195 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 196 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 197 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 198 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 199 | REPAIR OR CORRECTION. 200 | 201 | 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 202 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 203 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 204 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 205 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 206 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 207 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 208 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 209 | POSSIBILITY OF SUCH DAMAGES. 210 | 211 | END OF TERMS AND CONDITIONS 212 | 213 | Appendix: How to Apply These Terms to Your New Programs 214 | 215 | If you develop a new program, and you want it to be of the greatest 216 | possible use to humanity, the best way to achieve this is to make it 217 | free software which everyone can redistribute and change under these 218 | terms. 219 | 220 | To do so, attach the following notices to the program. It is safest to 221 | attach them to the start of each source file to most effectively convey 222 | the exclusion of warranty; and each file should have at least the 223 | "copyright" line and a pointer to where the full notice is found. 224 | 225 | 226 | Copyright (C) 19yy 227 | 228 | This program is free software; you can redistribute it and/or modify 229 | it under the terms of the GNU General Public License as published by 230 | the Free Software Foundation; either version 1, or (at your option) 231 | any later version. 232 | 233 | This program is distributed in the hope that it will be useful, 234 | but WITHOUT ANY WARRANTY; without even the implied warranty of 235 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 236 | GNU General Public License for more details. 237 | 238 | You should have received a copy of the GNU General Public License 239 | along with this program; if not, write to the Free Software 240 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA 241 | 242 | 243 | Also add information on how to contact you by electronic and paper mail. 244 | 245 | If the program is interactive, make it output a short notice like this 246 | when it starts in an interactive mode: 247 | 248 | Gnomovision version 69, Copyright (C) 19xx name of author 249 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 250 | This is free software, and you are welcome to redistribute it 251 | under certain conditions; type `show c' for details. 252 | 253 | The hypothetical commands `show w' and `show c' should show the 254 | appropriate parts of the General Public License. Of course, the 255 | commands you use may be called something other than `show w' and `show 256 | c'; they could even be mouse-clicks or menu items--whatever suits your 257 | program. 258 | 259 | You should also get your employer (if you work as a programmer) or your 260 | school, if any, to sign a "copyright disclaimer" for the program, if 261 | necessary. Here a sample; alter the names: 262 | 263 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 264 | program `Gnomovision' (a program to direct compilers to make passes 265 | at assemblers) written by James Hacker. 266 | 267 | , 1 April 1989 268 | Ty Coon, President of Vice 269 | 270 | That's all there is to it! 271 | 272 | 273 | --- The Artistic License 1.0 --- 274 | 275 | This software is Copyright (c) 2013 by Dylan Cali. 276 | 277 | This is free software, licensed under: 278 | 279 | The Artistic License 1.0 280 | 281 | The Artistic License 282 | 283 | Preamble 284 | 285 | The intent of this document is to state the conditions under which a Package 286 | may be copied, such that the Copyright Holder maintains some semblance of 287 | artistic control over the development of the package, while giving the users of 288 | the package the right to use and distribute the Package in a more-or-less 289 | customary fashion, plus the right to make reasonable modifications. 290 | 291 | Definitions: 292 | 293 | - "Package" refers to the collection of files distributed by the Copyright 294 | Holder, and derivatives of that collection of files created through 295 | textual modification. 296 | - "Standard Version" refers to such a Package if it has not been modified, 297 | or has been modified in accordance with the wishes of the Copyright 298 | Holder. 299 | - "Copyright Holder" is whoever is named in the copyright or copyrights for 300 | the package. 301 | - "You" is you, if you're thinking about copying or distributing this Package. 302 | - "Reasonable copying fee" is whatever you can justify on the basis of media 303 | cost, duplication charges, time of people involved, and so on. (You will 304 | not be required to justify it to the Copyright Holder, but only to the 305 | computing community at large as a market that must bear the fee.) 306 | - "Freely Available" means that no fee is charged for the item itself, though 307 | there may be fees involved in handling the item. It also means that 308 | recipients of the item may redistribute it under the same conditions they 309 | received it. 310 | 311 | 1. You may make and give away verbatim copies of the source form of the 312 | Standard Version of this Package without restriction, provided that you 313 | duplicate all of the original copyright notices and associated disclaimers. 314 | 315 | 2. You may apply bug fixes, portability fixes and other modifications derived 316 | from the Public Domain or from the Copyright Holder. A Package modified in such 317 | a way shall still be considered the Standard Version. 318 | 319 | 3. You may otherwise modify your copy of this Package in any way, provided that 320 | you insert a prominent notice in each changed file stating how and when you 321 | changed that file, and provided that you do at least ONE of the following: 322 | 323 | a) place your modifications in the Public Domain or otherwise make them 324 | Freely Available, such as by posting said modifications to Usenet or an 325 | equivalent medium, or placing the modifications on a major archive site 326 | such as ftp.uu.net, or by allowing the Copyright Holder to include your 327 | modifications in the Standard Version of the Package. 328 | 329 | b) use the modified Package only within your corporation or organization. 330 | 331 | c) rename any non-standard executables so the names do not conflict with 332 | standard executables, which must also be provided, and provide a separate 333 | manual page for each non-standard executable that clearly documents how it 334 | differs from the Standard Version. 335 | 336 | d) make other distribution arrangements with the Copyright Holder. 337 | 338 | 4. You may distribute the programs of this Package in object code or executable 339 | form, provided that you do at least ONE of the following: 340 | 341 | a) distribute a Standard Version of the executables and library files, 342 | together with instructions (in the manual page or equivalent) on where to 343 | get the Standard Version. 344 | 345 | b) accompany the distribution with the machine-readable source of the Package 346 | with your modifications. 347 | 348 | c) accompany any non-standard executables with their corresponding Standard 349 | Version executables, giving the non-standard executables non-standard 350 | names, and clearly documenting the differences in manual pages (or 351 | equivalent), together with instructions on where to get the Standard 352 | Version. 353 | 354 | d) make other distribution arrangements with the Copyright Holder. 355 | 356 | 5. You may charge a reasonable copying fee for any distribution of this 357 | Package. You may charge any fee you choose for support of this Package. You 358 | may not charge a fee for this Package itself. However, you may distribute this 359 | Package in aggregate with other (possibly commercial) programs as part of a 360 | larger (possibly commercial) software distribution provided that you do not 361 | advertise this Package as a product of your own. 362 | 363 | 6. The scripts and library files supplied as input to or produced as output 364 | from the programs of this Package do not automatically fall under the copyright 365 | of this Package, but belong to whomever generated them, and may be sold 366 | commercially, and may be aggregated with this Package. 367 | 368 | 7. C or perl subroutines supplied by you and linked into this Package shall not 369 | be considered part of this Package. 370 | 371 | 8. The name of the Copyright Holder may not be used to endorse or promote 372 | products derived from this software without specific prior written permission. 373 | 374 | 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 375 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 376 | MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 377 | 378 | The End 379 | 380 | --------------------------------------------------------------------------------