Net-Stomp-0.61000755001750001750 014035373335 13151 5ustar00dakkardakkar000000000000Net-Stomp-0.61/Build.PL000444001750001750 144314035373335 14604 0ustar00dakkardakkar000000000000#!perl use Module::Build; use strict; use warnings; my $build = Module::Build->new( create_makefile_pl => 'traditional', license => 'perl', module_name => 'Net::Stomp', requires => { 'IO::Socket::INET' => '0', 'IO::Select' => '0', 'Class::Accessor::Fast' => '0', 'Log::Any' => '1.707', }, test_requires => { 'Test::More' => '0', 'Test::Deep' => '0', 'Test::Fatal' => '0', 'Log::Any::Adapter::TAP' => '0.003003', 'Test::NiceDump' => '1.0.0', }, recommends => { 'IO::Socket::IP' => '0.20', 'IO::Socket::SSL' => '1.75', }, ); $build->create_build_script; Net-Stomp-0.61/CHANGES000444001750001750 1434614035373335 14331 0ustar00dakkardakkar000000000000Revision history for Perl module Net::Stomp: 0.61 2021-04-13 - Avoid referencing $frame if it's undefined (thanks Lee Burton N6UDP) 0.60 2019-07-17 - switch to Log::Any - add trace / debug logging - work sponsored by Broadbean Technology 0.57 2016-04-17 - fix reconnection problems when server dies (thanks dhnukem) - add NACK command (thanks Doug Henderson) 0.56 2015-06-27 - fix typo (thanks POLETTIX) - fix boundary condition when receiving frames with content-length, RT #105500 (thanks Dryapak Grigory) 0.55 2015-03-26 - drop "use Data::Printer" leftover from debugging 0.54 2015-03-25 - when reading times out in the middle of a frame, but the connection is still up, keep parsing the current frame instead of getting confused, fixes #103071 thanks to colddaylike for noticing the issue 0.53 2015-02-18 - add receipt_timeout attribute, to make sure we give up when no receipt comes (usually because of network problems) - test whan happens when timing out while waiting for the receipt - make sure to never modify the passed-in hashrefs 0.52 2015-02-16 - add socket_options attribute - add TCP keep-alive support 0.51 2015-01-26 - fix and document return values of all methods - add global read timeout attribute 0.50 2015-01-26 - extract send_with_receipt from inside send_transactional 0.49 2014-07-14 - allow setting SSL per-server - expose the currently connected host 0.48 2014-07-12 - fix dependency for Test::Deep RT #97167 - better diagnostics when test modules are missing 0.47 2014-07-11 - a test suite! we now have good test coverage - configurable reconnect delay (was fixed at 5 seconds) - configurable logger, instead of just warn/carp - handle partial writes, fixes RT #83047 - properly reconnect on write failure - more robust reconnecting on read failure - Net::Stomp::Frame::parse now actually exists (it was documented but not implemented) - fix RT #35194 'ack' now allow arbitrary headers - fix RT #80079 correctly pick the first value for repeated headers - from RT #68160, allow changing the maximum number of reconnect attempts - from RT #68160, ignore SIGPIPE while writing to the socket - more accessors on ::Frame, fix RT #90100 0.46 Tue Jan 14 12:21:43 GMT 2014 - Recommend modules required for IPv6 support (Dagfinn Ilmari Mannsåker) 0.45 Wed Mar 14 10:25:35 GMT 2012 - reconnect on fork() (Gianni Ceccarelli) 0.44 Wed Nov 23 23:26:39 GMT 2011 - Updated CHANGES to include recent changes (Jason Tang) 0.43 Mon Nov 21 10:46:58 GMT 2011 - rt#68583: "Use of uninitialized value" warning in as_string()(Chisel Wright) - rt#70670: Key using id rather than destination (Gianni Ceccarelli) 0.42 Sat Aug 20 07:37:31 GMT 2011 - Improve handling of disconnecting/reconnecting (Chisel Wright) 0.41 Thu Apr 28 14:56:49 GMT 2011 - Various small warning/error message fies: - Remove undef warning from substr (Squeeks) - rt#67160: IO::Socket::INET/SSL Error Variables (Stephen Fralich) - rt#65979: Fix bug in failover hosts (vigith maurice) 0.41 Fri Feb 4 09:16:39 GMT 2011 - Fix silly bug in _read_body (reported by Zulf Ahmed) - Remove uninitialized value in numeric gt warning (reported by Dave Krieger) 0.39 Fri Jan 14 15:59:27 GMT 2011 - Cope with EOF during receive_frame better 0.38_99 Fri Aug 27 00:11:08 BST 2010 - Reimplemented Net::Stomp::receive_frame() to properly handle STOMP frames that have extraneous line feed characters after the NULL terminator, before the next frame header (e.g., ActiveMQ). (Implemented by Michael S. Fischer) - Improve reading performace by reading large chunks and buffering - Read buffer size can now be specified in Net::Stomp->new() with the 'bufsize' key. - Possible incompatible change - Net::Stomp::Frame#parse method removed. Hopefully no one was using this. If you were, RTFS and look at Net::Stomp#receive_frame method. 0.38 Tue Aug 03 13:58:10 BST 2010 - Fix an issue with IO::Handle buffering interfering with IO::Select. This manifested as receive_frame hanging, or as if not all messages would get delivered to the client. (RT 44629) 0.37 Fri May 28 15:26:17 BST 2010 - Report a proper error if non-SSL STOMP server is not listening rather than "Can't use an undefined value as a symbol reference". - Fix regression in can_read: it now again defaults to waiting indefinitely. (RT 58502) 0.36 Fri May 28 16:20:15 BST 2010 - Fix behaviour regression on constructor - 0.35 would look at ->new time if no server could be reached. We now die after trying each server once. 0.35 Tue May 25 15:55:36 BST 2010 - add some examples - add support for SSL (thanks to Aleksandar Ivanisevic) - add send_transactional (based on Net::Stomp::Receipt, thanks to Hugo Salgado) - add some convenience methods for accessing headers in a frame (thanks to Claes Jakobsson) - receive_frame now accepts a {timeout=>1} option - failover support (thanks to Thom May and Ash Berlin) - reconnect and resubscribe when connection failes (Thom May) 0.34 Fri Jun 27 09:29:13 BST 2008 - revert to 0.32's code, as the last release broke things that I don't have time to fix right now 0.33 Wed Jun 25 08:45:59 BST 2008 - fixes from Paul Driver: can_read doesn't behave correctly. The docs say it returns true iff there's a frame waiting to be read, but it's just a select() call to see if there's data on the socket, which can return both false positives and false negatives. While investigating this, I noticed that Net::Stomp::Frame->parse was modified at some point to take a socket as its argument. This is inconsistent with docs and probably not what was wanted anyway. parse and as_string should be symmetrical. Attached is a patch that fixes both issues and adds tests for them. 0.32 Sun Oct 29 09:06:31 GMT 2006 - rewrote the parser to add support for BytesMessage, which should allow Java<->Perl messages (thanks to Hiram Chirino and Sileshi Kassa) - set binmode() on the socket so Windows should now work (thanks to Sileshi Kassa) 0.31 Wed Oct 11 17:28:31 BST 2006 - minor docpatch noticed by Leo Lapworth - tweak frame parser - add unsubscribe() method - add can_read() method 0.30 Sat Oct 7 09:47:57 BST 2006 - initial release Net-Stomp-0.61/MANIFEST000444001750001750 74214035373335 14422 0ustar00dakkardakkar000000000000Build.PL CHANGES examples/send.pl examples/subscribe.pl lib/Net/Stomp.pm lib/Net/Stomp/Frame.pm lib/Net/Stomp/StupidLogger.pm MANIFEST This list of files MANIFEST.SKIP README t/connect-disconnect.t t/constructor.t t/failover.t t/frame-accessors.t t/initial-connect.t t/lib/TestHelp.pm t/pod.t t/pod_coverage.t t/read-timeout.t t/receiving-frames.t t/reconnect.t t/send-transactional.t t/send-with-receipt.t t/sending-frames.t xt/consume_buffering.t Makefile.PL META.yml META.json Net-Stomp-0.61/MANIFEST.SKIP000444001750001750 20314035373335 15157 0ustar00dakkardakkar000000000000^MYMETA.yml$ ^MANIFEST.bak$ ^Build$ ^Makefile ~$ ^\.DS_Store ^Net-Stomp-.* \.tar\.gz$ ^\.git \.swp$ ^_build/ ^blib/ ^MYMETA\.json$ Net-Stomp-0.61/META.json000444001750001750 340014035373335 14724 0ustar00dakkardakkar000000000000{ "abstract" : "A Streaming Text Orientated Messaging Protocol Client", "author" : [ "Leon Brocard ,", "Thom May ,", "Michael S. Fischer ,", "Ash Berlin " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4231", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Net-Stomp", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "recommends" : { "IO::Socket::IP" : "0.20", "IO::Socket::SSL" : "1.75" }, "requires" : { "Class::Accessor::Fast" : "0", "IO::Select" : "0", "IO::Socket::INET" : "0", "Log::Any" : "1.707" } }, "test" : { "requires" : { "Log::Any::Adapter::TAP" : "0.003003", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::More" : "0", "Test::NiceDump" : "v1.0.0" } } }, "provides" : { "Net::Stomp" : { "file" : "lib/Net/Stomp.pm", "version" : "0.61" }, "Net::Stomp::Frame" : { "file" : "lib/Net/Stomp/Frame.pm", "version" : "0.61" }, "Net::Stomp::StupidLogger" : { "file" : "lib/Net/Stomp/StupidLogger.pm", "version" : "0.61" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.61", "x_serialization_backend" : "JSON::PP version 4.05" } Net-Stomp-0.61/META.yml000444001750001750 222514035373335 14560 0ustar00dakkardakkar000000000000--- abstract: 'A Streaming Text Orientated Messaging Protocol Client' author: - 'Leon Brocard ,' - 'Thom May ,' - 'Michael S. Fischer ,' - 'Ash Berlin ' build_requires: Log::Any::Adapter::TAP: '0.003003' Test::Deep: '0' Test::Fatal: '0' Test::More: '0' Test::NiceDump: v1.0.0 configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-Stomp provides: Net::Stomp: file: lib/Net/Stomp.pm version: '0.61' Net::Stomp::Frame: file: lib/Net/Stomp/Frame.pm version: '0.61' Net::Stomp::StupidLogger: file: lib/Net/Stomp/StupidLogger.pm version: '0.61' recommends: IO::Socket::IP: '0.20' IO::Socket::SSL: '1.75' requires: Class::Accessor::Fast: '0' IO::Select: '0' IO::Socket::INET: '0' Log::Any: '1.707' resources: license: http://dev.perl.org/licenses/ version: '0.61' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-Stomp-0.61/Makefile.PL000444001750001750 73014035373335 15240 0ustar00dakkardakkar000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4231 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Net::Stomp', 'VERSION_FROM' => 'lib/Net/Stomp.pm', 'PREREQ_PM' => { 'Class::Accessor::Fast' => '0', 'IO::Select' => '0', 'IO::Socket::INET' => '0', 'Log::Any' => '1.707' }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Net-Stomp-0.61/README000444001750001750 2012114035373335 14202 0ustar00dakkardakkar000000000000NAME Net::Stomp - A Streaming Text Orientated Messaging Protocol Client SYNOPSIS # send a message to the queue 'foo' use Net::Stomp; my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); $stomp->connect( { login => 'hello', passcode => 'there' } ); $stomp->send( { destination => '/queue/foo', body => 'test message' } ); $stomp->disconnect; # subscribe to messages from the queue 'foo' use Net::Stomp; my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); $stomp->connect( { login => 'hello', passcode => 'there' } ); $stomp->subscribe( { destination => '/queue/foo', 'ack' => 'client', 'activemq.prefetchSize' => 1 } ); while (1) { my $frame = $stomp->receive_frame; warn $frame->body; # do something here $stomp->ack( { frame => $frame } ); } $stomp->disconnect; # write your own frame my $frame = Net::Stomp::Frame->new( { command => $command, headers => $conf, body => $body } ); $self->send_frame($frame); DESCRIPTION This module allows you to write a Stomp client. Stomp is the Streaming Text Orientated Messaging Protocol (or the Protocol Briefly Known as TTMP and Represented by the symbol :ttmp). It's a simple and easy to implement protocol for working with Message Orientated Middleware from any language. Net::Stomp is useful for talking to Apache ActiveMQ, an open source (Apache 2.0 licensed) Java Message Service 1.1 (JMS) message broker packed with many enterprise features. A Stomp frame consists of a command, a series of headers and a body - see Net::Stomp::Frame for more details. For details on the protocol see . To enable the ActiveMQ Broker for Stomp add the following to the activemq.xml configuration inside the section: To enable the ActiveMQ Broker for Stomp and SSL add the following inside the section: For details on Stomp in ActiveMQ See . METHODS new The constructor creates a new object. You must pass in a hostname and a port: my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); If you want to use SSL, make sure you have IO::Socket::SSL and pass in the SSL flag: my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61612', ssl => 1, } ); If you want to pass in IO::Socket::SSL options: my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61612', ssl => 1, ssl_options => { SSL_cipher_list => 'ALL:!EXPORT' }, } ); connect This connects to the Stomp server. You must pass in a login and passcode. You may pass in 'client-id', which specifies the JMS Client ID which is used in combination to the activemqq.subscriptionName to denote a durable subscriber. $stomp->connect( { login => 'hello', passcode => 'there' } ); send This sends a message to a queue or topic. You must pass in a destination and a body. $stomp->send( { destination => '/queue/foo', body => 'test message' } ); To send a BytesMessage, you should set the field 'bytes_message' to 1. send_transactional This sends a message in transactional mode and fails if the receipt of the message is not acknowledged by the server: $stomp->send_transactional( { destination => '/queue/foo', body => 'test message' } ) or die "Couldn't send the message!"; If using ActiveMQ, you might also want to make the message persistent: $stomp->send_transactional( { destination => '/queue/foo', body => 'test message', persistent => 'true' } ) or die "Couldn't send the message!"; disconnect This disconnects from the Stomp server: $stomp->disconnect; subscribe This subscribes you to a queue or topic. You must pass in a destination. The acknowledge mode defaults to 'auto', which means that frames will be considered delivered after they have been sent to a client. The other option is 'client', which means that messages will only be considered delivered after the client specifically acknowledges them with an ACK frame. Other options: 'selector': which specifies a JMS Selector using SQL 92 syntax as specified in the JMS 1.1 specificiation. This allows a filter to be applied to each message as part of the subscription. 'activemq.dispatchAsync': should messages be dispatched synchronously or asynchronously from the producer thread for non-durable topics in the broker. For fast consumers set this to false. For slow consumers set it to true so that dispatching will not block fast consumers. 'activemq.exclusive': Would I like to be an Exclusive Consumer on a queue. 'activemq.maximumPendingMessageLimit': For Slow Consumer Handlingon non-durable topics by dropping old messages - we can set a maximum pending limit which once a slow consumer backs up to this high water mark we begin to discard old messages. 'activemq.noLocal': Specifies whether or not locally sent messages should be ignored for subscriptions. Set to true to filter out locally sent messages. 'activemq.prefetchSize': Specifies the maximum number of pending messages that will be dispatched to the client. Once this maximum is reached no more messages are dispatched until the client acknowledges a message. Set to 1 for very fair distribution of messages across consumers where processing messages can be slow. 'activemq.priority': Sets the priority of the consumer so that dispatching can be weighted in priority order. 'activemq.retroactive': For non-durable topics do you wish this subscription to the retroactive. 'activemq.subscriptionName': For durable topic subscriptions you must specify the same clientId on the connection and subscriberName on the subscribe. $stomp->subscribe( { destination => '/queue/foo', 'ack' => 'client', 'activemq.prefetchSize' => 1 } ); unsubscribe This unsubscribes you to a queue or topic. You must pass in a destination: $stomp->unsubcribe({ destination => '/queue/foo' }); receive_frame This blocks and returns you the next Stomp frame. my $frame = $stomp->receive_frame; warn $frame->body; # do something here The header bytes_message is 1 if the message was a BytesMessage. can_read This returns whether a frame is waiting to be read. Optionally takes a timeout in seconds: my $can_read = $stomp->can_read; my $can_read = $stomp->can_read({ timeout => '0.1' }); ack This acknowledges that you have received and processed a frame (if you are using client acknowledgements): $stomp->ack( { frame => $frame } ); nack This informs the remote end that you have been unable to process a received frame (if you are using client acknowledgements) (See individual stomp server documentation for information about additional fields that can be passed to alter NACK behavior): $stomp->nack( { frame => $frame } ); send_frame If this module does not provide enough help for sending frames, you may construct your own frame and send it: # write your own frame my $frame = Net::Stomp::Frame->new( { command => $command, headers => $conf, body => $body } ); $self->send_frame($frame); SEE ALSO Net::Stomp::Frame. AUTHOR Leon Brocard . COPYRIGHT Copyright (C) 2006-9, Leon Brocard This module is free software; you can redistribute it or modify it under the same terms as Perl itself. Net-Stomp-0.61/examples000755001750001750 014035373335 14767 5ustar00dakkardakkar000000000000Net-Stomp-0.61/examples/send.pl000444001750001750 73214035373335 16374 0ustar00dakkardakkar000000000000#!perl use strict; use warnings; use lib 'lib'; use DateTime; use Net::Stomp; my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); $stomp->connect( { login => 'hello', passcode => 'there' } ); my $count = shift || 1; foreach my $i ( 1 .. $count ) { warn $i; $stomp->send( { destination => '/queue/foo', body => DateTime->now . " $i", bytes_message => 1, } ); } $stomp->disconnect; Net-Stomp-0.61/examples/subscribe.pl000444001750001750 111714035373335 17442 0ustar00dakkardakkar000000000000#!perl use strict; use warnings; use lib 'lib'; use Net::Stomp; my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); $stomp->connect( { login => 'hello', passcode => 'there' } ); $stomp->subscribe( { destination => '/queue/foo', 'ack' => 'client', 'activemq.prefetchSize' => 1, } ); while ( $stomp->can_read( { timeout => 1 } ) ) { my $frame = $stomp->receive_frame; $stomp->ack( { frame => $frame } ); warn $frame->command . ': >' . substr( $frame->body, 0, 80 ) . "<\n"; } $stomp->disconnect; Net-Stomp-0.61/lib000755001750001750 014035373335 13717 5ustar00dakkardakkar000000000000Net-Stomp-0.61/lib/Net000755001750001750 014035373335 14445 5ustar00dakkardakkar000000000000Net-Stomp-0.61/lib/Net/Stomp.pm000444001750001750 10654314035373335 16313 0ustar00dakkardakkar000000000000package Net::Stomp; use strict; use warnings; use IO::Select; use Net::Stomp::Frame; use Carp qw(longmess); use base 'Class::Accessor::Fast'; use Log::Any; our $VERSION = '0.61'; __PACKAGE__->mk_accessors( qw( current_host failover hostname hosts port select serial session_id socket ssl ssl_options socket_options subscriptions _connect_headers bufsize reconnect_on_fork logger connect_delay reconnect_attempts initial_reconnect_attempts timeout receipt_timeout ) ); sub _logconfess { my ($self,@etc) = @_; my $m = longmess(@etc); $self->logger->fatal($m); die $m; } sub _logdie { my ($self,@etc) = @_; $self->logger->fatal(@etc); die "@etc"; } sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->bufsize(8192) unless $self->bufsize; $self->connect_delay(5) unless defined $self->connect_delay; $self->reconnect_on_fork(1) unless defined $self->reconnect_on_fork; $self->reconnect_attempts(0) unless defined $self->reconnect_attempts; $self->initial_reconnect_attempts(1) unless defined $self->initial_reconnect_attempts; $self->socket_options({}) unless defined $self->socket_options; $self->logger(Log::Any->get_logger) unless $self->logger; $self->{_framebuf} = ""; # We are not subscribed to anything at the start $self->subscriptions( {} ); $self->select( IO::Select->new ); my @hosts = (); # failover://tcp://primary:61616 # failover:(tcp://primary:61616,tcp://secondary:61616)?randomize=false if ($self->failover) { my ($uris, $opts) = $self->failover =~ m{^failover:(?://)? \(? (.*?) \)? (?: \? (.*?) ) ?$}ix; $self->_logconfess("Unable to parse failover uri: " . $self->failover) unless $uris; foreach my $host (split(/,/,$uris)) { $host =~ m{^\w+://([a-zA-Z0-9\-./]+):([0-9]+)$} || $self->_logconfess("Unable to parse failover component: '$host'"); my ($hostname, $port) = ($1, $2); push(@hosts, {hostname => $hostname, port => $port}); } } elsif ($self->hosts) { ## @hosts is used inside the while loop later to decide whether we have ## cycled through all setup hosts. @hosts = @{$self->hosts}; } $self->hosts(\@hosts) if @hosts; $self->_get_connection_retrying(1); return $self; } sub _get_connection_retrying { my ($self,$initial) = @_; my $tries=0; while(not eval { $self->_get_connection; 1 }) { my $err = $@;$err =~ s{\n\z}{}sm; ++$tries; if($self->_should_stop_trying($initial,$tries)) { # We've cycled enough. Die now. $self->_logdie("Failed to connect: $err; giving up"); } $self->logger->warn("Failed to connect: $err; retrying"); sleep($self->connect_delay); } } sub _should_stop_trying { my ($self,$initial,$tries) = @_; my $max_tries = $initial ? $self->initial_reconnect_attempts : $self->reconnect_attempts; return unless $max_tries > 0; # 0 means forever if (defined $self->hosts) { $max_tries *= @{$self->hosts}; # try at least once per host } return $tries >= $max_tries; } my $socket_class; sub _get_connection { my $self = shift; if (my $hosts = $self->hosts) { if (defined $self->current_host && ($self->current_host < $#{$hosts} ) ) { $self->current_host($self->current_host+1); } else { $self->current_host(0); } my $h = $hosts->[$self->current_host]; $self->hostname($h->{hostname}); $self->port($h->{port}); $self->ssl($h->{ssl}); $self->ssl_options($h->{ssl_options} || {}); } my $socket = $self->_get_socket; $self->_logdie("Error connecting to " . $self->hostname . ':' . $self->port . ": $!") unless $socket; $self->select->remove($self->socket); $self->select->add($socket); $self->socket($socket); $self->{_pid} = $$; } sub _get_socket { my ($self) = @_; my $socket; my $timeout = $self->timeout; $timeout = 5 unless defined $timeout; my %sockopts = ( Timeout => $timeout, %{ $self->socket_options }, PeerAddr => $self->hostname, PeerPort => $self->port, Proto => 'tcp', ); my $keep_alive = delete $sockopts{keep_alive}; if ( $self->ssl ) { eval { require IO::Socket::SSL }; $self->_logdie( "You should install the IO::Socket::SSL module for SSL support in Net::Stomp" ) if $@; %sockopts = ( %sockopts, %{ $self->ssl_options || {} } ); $self->logger->trace('opening IO::Socket::SSL',\%sockopts); $socket = IO::Socket::SSL->new(%sockopts); } else { $socket_class ||= eval { require IO::Socket::IP; IO::Socket::IP->VERSION('0.20'); "IO::Socket::IP" } || do { require IO::Socket::INET; "IO::Socket::INET" }; $self->logger->trace("opening $socket_class",\%sockopts); $socket = $socket_class->new(%sockopts); binmode($socket) if $socket; } if ($keep_alive) { require Socket; if (Socket->can('SO_KEEPALIVE')) { $socket->setsockopt(Socket::SOL_SOCKET(),Socket::SO_KEEPALIVE(),1); } else { $self->logger->warn(q{TCP keep-alive was requested, but the Socket module does not export the SO_KEEPALIVE constant, so we couldn't enable it}); } } return $socket; } sub connect { my ( $self, $conf ) = @_; $self->logger->trace('connecting'); my $frame = Net::Stomp::Frame->new( { command => 'CONNECT', headers => $conf } ); $self->send_frame($frame); $frame = $self->receive_frame; if ($frame && $frame->command eq 'CONNECTED') { $self->logger->trace('connected'); # Setting initial values for session id, as given from # the stomp server $self->session_id( $frame->headers->{session} ); $self->_connect_headers( $conf ); } else { $self->logger->warn('failed to connect',{ %{$frame // {}} }); } return $frame; } sub _close_socket { my ($self) = @_; return unless $self->socket; $self->logger->trace('closing socket'); $self->socket->close; $self->select->remove($self->socket); } sub disconnect { my $self = shift; $self->logger->trace('disconnecting'); my $frame = Net::Stomp::Frame->new( { command => 'DISCONNECT' } ); $self->send_frame($frame); $self->_close_socket; return 1; } sub _reconnect { my $self = shift; $self->_close_socket; $self->logger->warn("reconnecting"); $self->_get_connection_retrying(0); # Both ->connect and ->subscribe can call _reconnect. It *should* # work out fine in the end, worst scenario we send a few subscribe # frame more than once $self->connect( $self->_connect_headers ); for my $sub(keys %{$self->subscriptions}) { $self->subscribe($self->subscriptions->{$sub}); } } sub can_read { my ( $self, $conf ) = @_; # If there is any data left in the framebuffer that we haven't read, return # 'true'. But we don't want to spin endlessly, so only return true the # first time. (Anything touching the _framebuf should update this flag when # it does something. if ( $self->{_framebuf_changed} && length $self->{_framebuf} ) { $self->{_framebuf_changed} = 0; return 1; } $conf ||= {}; my $timeout = exists $conf->{timeout} ? $conf->{timeout} : $self->timeout; return $self->select->can_read($timeout) || 0; } sub send { my ( $self, $conf ) = @_; $conf = { %$conf }; $self->logger->trace('sending',$conf); my $body = $conf->{body}; delete $conf->{body}; my $frame = Net::Stomp::Frame->new( { command => 'SEND', headers => $conf, body => $body } ); $self->send_frame($frame); return 1; } sub send_with_receipt { my ( $self, $conf ) = @_; $conf = { %$conf }; # send the message my $receipt_id = $self->_get_next_transaction; $self->logger->debug('sending with receipt',{ receipt => $receipt_id }); $conf->{receipt} = $receipt_id; my $receipt_timeout = exists $conf->{timeout} ? delete $conf->{timeout} : $self->receipt_timeout; $self->send($conf); $self->logger->trace('waiting for receipt',$conf); # check the receipt my $receipt_frame = $self->receive_frame({ ( defined $receipt_timeout ? ( timeout => $receipt_timeout ) : () ), }); if (@_ > 2) { $_[2] = $receipt_frame; } if ( $receipt_frame && $receipt_frame->command eq 'RECEIPT' && $receipt_frame->headers->{'receipt-id'} eq $receipt_id ) { $self->logger->debug('got good receipt',{ %{$receipt_frame} }); return 1; } else { $self->logger->debug('got bad receipt',{ %{$receipt_frame || {} } }); return 0; } } sub send_transactional { my ( $self, $conf ) = @_; $conf = { %$conf }; # begin the transaction my $transaction_id = $self->_get_next_transaction; $self->logger->debug('starting transaction',{ transaction => $transaction_id }); my $begin_frame = Net::Stomp::Frame->new( { command => 'BEGIN', headers => { transaction => $transaction_id } } ); $self->send_frame($begin_frame); $conf->{transaction} = $transaction_id; my $receipt_frame; my $ret = $self->send_with_receipt($conf,$receipt_frame); if (@_ > 2) { $_[2] = $receipt_frame; } if ( $ret ) { # success, commit the transaction $self->logger->debug('committing transaction',{ transaction => $transaction_id }); my $frame_commit = Net::Stomp::Frame->new( { command => 'COMMIT', headers => { transaction => $transaction_id } } ); $self->send_frame($frame_commit); } else { $self->logger->debug('rolling back transaction',{ transaction => $transaction_id }); # some failure, abort transaction my $frame_abort = Net::Stomp::Frame->new( { command => 'ABORT', headers => { transaction => $transaction_id } } ); $self->send_frame($frame_abort); } return $ret; } sub _sub_key { my ($conf) = @_; if ($conf->{id}) { return "id-".$conf->{id} } return "dest-".$conf->{destination} } sub subscribe { my ( $self, $conf ) = @_; $self->logger->trace('subscribing',$conf); my $frame = Net::Stomp::Frame->new( { command => 'SUBSCRIBE', headers => $conf } ); $self->send_frame($frame); my $subs = $self->subscriptions; $subs->{_sub_key($conf)} = $conf; return 1; } sub unsubscribe { my ( $self, $conf ) = @_; $self->logger->trace('unsubscribing',$conf); my $frame = Net::Stomp::Frame->new( { command => 'UNSUBSCRIBE', headers => $conf } ); $self->send_frame($frame); my $subs = $self->subscriptions; delete $subs->{_sub_key($conf)}; return 1; } sub ack { my ( $self, $conf ) = @_; $conf = { %$conf }; my $id = $conf->{frame}->headers->{'message-id'}; delete $conf->{frame}; $self->logger->trace('acking',{ 'message-id' => $id, %$conf }); my $frame = Net::Stomp::Frame->new( { command => 'ACK', headers => { 'message-id' => $id, %$conf } } ); $self->send_frame($frame); return 1; } sub nack { my ( $self, $conf ) = @_; $conf = { %$conf }; my $id = $conf->{frame}->headers->{'message-id'}; $self->logger->trace('nacking',{ 'message-id' => $id, %$conf }); delete $conf->{frame}; my $frame = Net::Stomp::Frame->new( { command => 'NACK', headers => { 'message-id' => $id, %$conf } } ); $self->send_frame($frame); return 1; } sub send_frame { my ( $self, $frame ) = @_; # see if we're connected before we try to syswrite() if (not $self->_connected) { $self->_reconnect; if (not $self->_connected) { $self->_logdie(q{wasn't connected; couldn't _reconnect()}); } } # keep writing until we finish, or get an error my $to_write = my $frame_string = $frame->as_string; my $written; while (length($to_write)) { local $SIG{PIPE}='IGNORE'; # just in case writing to a closed # socket kills us $written = $self->socket->syswrite($to_write); last unless defined $written; substr($to_write,0,$written,''); } if (not defined $written) { $self->logger->warn("error writing frame <<$frame_string>>: $!"); } unless (defined $written && $self->_connected) { $self->_reconnect; $self->send_frame($frame); } return; } sub _read_data { my ($self, $timeout) = @_; return unless $self->select->can_read($timeout); my $len = $self->socket->sysread($self->{_framebuf}, $self->bufsize, length($self->{_framebuf} || '')); if (defined $len && $len>0) { $self->{_framebuf_changed} = 1; } else { if (!defined $len) { $self->logger->warn("error reading frame: $!"); } # EOF or error detected - connection is gone. We have to reset # the framebuf in case we had a partial frame in there that # will never arrive. $self->_close_socket; $self->{_framebuf} = ""; delete $self->{_command}; delete $self->{_headers}; } return $len; } sub _read_headers { my ($self) = @_; return 1 if $self->{_headers}; if ($self->{_framebuf} =~ s/^\n*([^\n].*?)\n\n//s) { $self->{_framebuf_changed} = 1; my $raw_headers = $1; if ($raw_headers =~ s/^(.+)\n//) { $self->{_command} = $1; } foreach my $line (split(/\n/, $raw_headers)) { my ($key, $value) = split(/\s*:\s*/, $line, 2); $self->{_headers}{$key} = $value unless defined $self->{_headers}{$key}; } return 1; } return 0; } sub _read_body { my ($self) = @_; my $h = $self->{_headers}; if ($h->{'content-length'}) { if (length($self->{_framebuf}) > $h->{'content-length'}) { $self->{_framebuf_changed} = 1; my $body = substr($self->{_framebuf}, 0, $h->{'content-length'}, '' ); # Trim the trailer off the frame. $self->{_framebuf} =~ s/^.*?\000\n*//s; return Net::Stomp::Frame->new({ command => delete $self->{_command}, headers => delete $self->{_headers}, body => $body }); } } elsif ($self->{_framebuf} =~ s/^(.*?)\000\n*//s) { # No content-length header. my $body = $1; $self->{_framebuf_changed} = 1; return Net::Stomp::Frame->new({ command => delete $self->{_command}, headers => delete $self->{_headers}, body => $body }); } return 0; } # this method is to stop the pointless warnings being thrown when trying to # call peername() on a closed socket, i.e. # getpeername() on closed socket GEN125 at # /opt/xt/xt-perl/lib/5.12.3/x86_64-linux/IO/Socket.pm line 258. # # solution taken from: # http://objectmix.com/perl/80545-warning-getpeername.html sub _connected { my $self = shift; return if $self->{_pid} != $$ and $self->reconnect_on_fork; my $connected; { local $^W = 0; $connected = $self->socket->connected; } return $connected; } sub receive_frame { my ($self, $conf) = @_; $self->logger->trace('waiting to receive frame',$conf); my $timeout = exists $conf->{timeout} ? $conf->{timeout} : $self->timeout; unless ($self->_connected) { $self->_reconnect; } my $done = 0; while ( not $done = $self->_read_headers ) { return undef unless $self->_read_data($timeout); } while ( not $done = $self->_read_body ) { return undef unless $self->_read_data($timeout); } return $done; } sub _get_next_transaction { my $self = shift; my $serial = $self->serial || 0; $serial++; $self->serial($serial); return ($self->session_id||'nosession') . '-' . $serial; } 1; __END__ =head1 NAME Net::Stomp - A Streaming Text Orientated Messaging Protocol Client =head1 SYNOPSIS # send a message to the queue 'foo' use Net::Stomp; my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); $stomp->connect( { login => 'hello', passcode => 'there' } ); $stomp->send( { destination => '/queue/foo', body => 'test message' } ); $stomp->disconnect; # subscribe to messages from the queue 'foo' use Net::Stomp; my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); $stomp->connect( { login => 'hello', passcode => 'there' } ); $stomp->subscribe( { destination => '/queue/foo', 'ack' => 'client', 'activemq.prefetchSize' => 1 } ); while (1) { my $frame = $stomp->receive_frame; if (!defined $frame) { # maybe log connection problems next; # will reconnect automatically } warn $frame->body; # do something here $stomp->ack( { frame => $frame } ); } $stomp->disconnect; # write your own frame my $frame = Net::Stomp::Frame->new( { command => $command, headers => $conf, body => $body } ); $self->send_frame($frame); # connect with failover supporting similar URI to ActiveMQ $stomp = Net::Stomp->new({ failover => "failover://tcp://primary:61616" }) # "?randomize=..." and other parameters are ignored currently $stomp = Net::Stomp->new({ failover => "failover:(tcp://primary:61616,tcp://secondary:61616)?randomize=false" }) # Or in a more natural perl way $stomp = Net::Stomp->new({ hosts => [ { hostname => 'primary', port => 61616 }, { hostname => 'secondary', port => 61616 }, ] }); =head1 DESCRIPTION This module allows you to write a Stomp client. Stomp is the Streaming Text Orientated Messaging Protocol (or the Protocol Briefly Known as TTMP and Represented by the symbol :ttmp). It's a simple and easy to implement protocol for working with Message Orientated Middleware from any language. L is useful for talking to Apache ActiveMQ, an open source (Apache 2.0 licensed) Java Message Service 1.1 (JMS) message broker packed with many enterprise features. A Stomp frame consists of a command, a series of headers and a body - see L for more details. For details on the protocol see L. In long-lived processes, you can use a new C object to send each message, but it's more polite to the broker to keep a single object around and re-use it for multiple messages; this reduce the number of TCP connections that have to be established. C tries very hard to re-connect whenever something goes wrong. =head2 ActiveMQ-specific suggestions To enable the ActiveMQ Broker for Stomp add the following to the activemq.xml configuration inside the section: To enable the ActiveMQ Broker for Stomp and SSL add the following inside the section: For details on Stomp in ActiveMQ See L. =head1 CONSTRUCTOR =head2 C The constructor creates a new object. You must pass in a hostname and a port or set a failover configuration: my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61613' } ); If you want to use SSL, make sure you have L and pass in the SSL flag: my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61612', ssl => 1, } ); If you want to pass in L options: my $stomp = Net::Stomp->new( { hostname => 'localhost', port => '61612', ssl => 1, ssl_options => { SSL_cipher_list => 'ALL:!EXPORT' }, } ); =head3 Failover There is some failover support in C. You can specify L<< /C >> in a similar manner to ActiveMQ (L) for similarity with Java configs or using a more natural method to Perl of passing in an array-of-hashrefs in the C parameter. When C connects the first time, upon construction, it will simply try each host in the list, stopping at the first one that accepts the connection, dying if no connection attempt is successful. You can set L<< /C >> to 0 to mean "keep looping forever", or to an integer value to mean "only go through the list of hosts this many times" (the default value is therefore 1). When C notices that the connection has been lost (inside L<< /C >> or L<< /C >>), it will try to re-connect. In this case, the number of connection attempts will be limited by L<< /C >>, which defaults to 0, meaning "keep trying forever". =head3 Reconnect on C By default Net::Stomp will reconnect, using a different socket, if the process Cs. This avoids problems when parent & child write to the socket at the same time. If, for whatever reason, you don't want this to happen, set L<< /C >> to C<0> (either as a constructor parameter, or by calling the method). =head1 ATTRIBUTES These can be passed as constructor parameters, or used as read/write accessors. =head2 C If you want to connect to a single broker, you can specify its hostname here. If you modify this value during the lifetime of the object, the new value will be used for the subsequent reconnect attempts. =head2 C If you want to connect to a single broker, you can specify its port here. If you modify this value during the lifetime of the object, the new value will be used for the subsequent reconnect attempts. =head2 C Optional hashref, it will be passed to the L, L, or L constructor every time we need to get a socket. In addition to the various options supported by those classes, you can set C to a true value, which will enable TCP-level keep-alive on the socket (see L for some information on that feature). =head2 C Boolean, defaults to false, whether we should use SSL to talk to the single broker. If you modify this value during the lifetime of the object, the new value will be used for the subsequent reconnect attempts. =head2 C Options to pass to L when connecting via SSL to the single broker. If you modify this value during the lifetime of the object, the new value will be used for the subsequent reconnect attempts. =head2 C Modifying this attribute after the object has been constructed has no effect. Pass this as a constructor parameter only. Its value must be a URL (as a string) in the form: failover://(tcp://$hostname1:$port1,tcp://$hostname2:$port,...) This is equivalent to setting L<< /C >> to: [ { hostname => $hostname1, port => $port1 }, { hostname => $hostname2, port => $port2 } ] =head2 C Arrayref of hashrefs, each having a C key and a C key, and optionall C and C. Connections will be attempted in order, looping around if necessary, depending on the values of L<< /C >> and L<< /C >>. =head2 C If using multiple hosts, this is the index (inside the L<< /C >> array) of the one we're currently connected to. =head2 C Optional logger object, the default one is a L logger. You can pass in any object with the same API, or configure L to route the messages to whatever logging system you need. =head2 C Boolean, defaults to true. Reconnect if a method is being invoked from a different process than the one that created the object. Don't change this unless you really know what you're doing. =head2 C Integer, how many times to loop through the L<< /C >> trying to connect, before giving up and throwing an exception, during the construction of the object. Defaults to 1. 0 means "keep trying forever". Between each connection attempt there will be a sleep of L<< /C >> seconds. =head2 C Integer, how many times to loop through the L<< /C >> trying to connect, before giving up and throwing an exception, during L<< /C >> or L<< /C >>. Defaults to 0, meaning "keep trying forever". Between each connection attempt there will be a sleep of L<< /C >> seconds. =head2 C Integer, defaults to 5. How many seconds to sleep between connection attempts to brokers. =head2 C Integer, in seconds, defaults to C. The default timeout for read operations. C means "wait forever". =head2 C Integer, in seconds, defaults to C. The default timeout while waiting for a receipt (in L<< /C >> and L<< /C >>). If C, the global L<< /C >> is used. =head1 METHODS =head2 C This starts the Stomp session with the Stomp server. You may pass in a C and C options, plus whatever other headers you may need (e.g. C, C). $stomp->connect( { login => 'hello', passcode => 'there' } ); Returns the frame that the server responded with (or C if the connection was lost). If that frame's command is not C, something went wrong. =head2 C This sends a message to a queue or topic. You must pass in a destination and a body (which must be a string of bytes). You can also pass whatever other headers you may need (e.g. C). $stomp->send( { destination => '/queue/foo', body => 'test message' } ); It's probably a good idea to pass a C corresponding to the byte length of the C; this is necessary if the C contains a byte 0. Always returns a true value. It automatically reconnects if writing to the socket fails. =head2 C This sends a message asking for a receipt, and returns false if the receipt of the message is not acknowledged by the server: $stomp->send_with_receipt( { destination => '/queue/foo', body => 'test message' } ) or die "Couldn't send the message!"; If using ActiveMQ, you might also want to make the message persistent: $stomp->send_transactional( { destination => '/queue/foo', body => 'test message', persistent => 'true' } ) or die "Couldn't send the message!"; The actual frame sequence for a successful sending is: -> SEND <- RECEIPT The actual frame sequence for a failed sending is: -> SEND <- anything but RECEIPT If you are using this connection only to send (i.e. you've never called L<< /C >>), the only thing that could be received instead of a C is an C frame, but if you subscribed, the broker may well send a C before sending the C. B use this method on a connection used for receiving. If you want to see the C or C frame, pass a scalar as a second parameter to the method, and it will be set to the received frame: my $success = $stomp->send_transactional( { destination => '/queue/foo', body => 'test message' }, $received_frame, ); if (not $success) { warn $received_frame->as_string } You can specify a C in the parametrs, just like for L<< /C >>. This function will wait for that timeout, or for L<< /C >>, or for L<< /C >>, whichever is defined, or forever, if none is defined. =head2 C This sends a message in transactional mode and returns false if the receipt of the message is not acknowledged by the server: $stomp->send_transactional( { destination => '/queue/foo', body => 'test message' } ) or die "Couldn't send the message!"; If using ActiveMQ, you might also want to make the message persistent: $stomp->send_transactional( { destination => '/queue/foo', body => 'test message', persistent => 'true' } ) or die "Couldn't send the message!"; C just wraps C in a STOMP transaction. The actual frame sequence for a successful sending is: -> BEGIN -> SEND <- RECEIPT -> COMMIT The actual frame sequence for a failed sending is: -> BEGIN -> SEND <- anything but RECEIPT -> ABORT If you are using this connection only to send (i.e. you've never called L<< /C >>), the only thing that could be received instead of a C is an C frame, but if you subscribed, the broker may well send a C before sending the C. B use this method on a connection used for receiving. If you want to see the C or C frame, pass a scalar as a second parameter to the method, and it will be set to the received frame: my $success = $stomp->send_transactional( { destination => '/queue/foo', body => 'test message' }, $received_frame, ); if (not $success) { warn $received_frame->as_string } You can specify a C in the parametrs, just like for L<< /C >>. This function will wait for that timeout, or for L<< /C >>, or for L<< /C >>, whichever is defined, or forever, if none is defined. =head2 C This disconnects from the Stomp server: $stomp->disconnect; If you call any other method after this, a new connection will be established automatically (to the next failover host, if there's more than one). Always returns a true value. =head2 C This subscribes you to a queue or topic. You must pass in a C. Always returns a true value. The acknowledge mode (header C) defaults to C, which means that frames will be considered delivered after they have been sent to a client. The other option is C, which means that messages will only be considered delivered after the client specifically acknowledges them with an ACK frame (see L<< /C >>). When C reconnects after a failure, all subscriptions will be re-instated, each with its own options. Other options: =over 4 =item C Specifies a JMS Selector using SQL 92 syntax as specified in the JMS 1.1 specification. This allows a filter to be applied to each message as part of the subscription. =item C A unique identifier for this subscription. Very useful if you subscribe to the same destination more than once (e.g. with different selectors), so that messages arriving will have a C header with this value if they arrived because of this subscription. =item C Should messages be dispatched synchronously or asynchronously from the producer thread for non-durable topics in the broker. For fast consumers set this to false. For slow consumers set it to true so that dispatching will not block fast consumers. =item C Would I like to be an Exclusive Consumer on a queue. =item C For Slow Consumer Handling on non-durable topics by dropping old messages - we can set a maximum pending limit which once a slow consumer backs up to this high water mark we begin to discard old messages. =item C Specifies whether or not locally sent messages should be ignored for subscriptions. Set to true to filter out locally sent messages. =item C Specifies the maximum number of pending messages that will be dispatched to the client. Once this maximum is reached no more messages are dispatched until the client acknowledges a message. Set to 1 for very fair distribution of messages across consumers where processing messages can be slow. =item C Sets the priority of the consumer so that dispatching can be weighted in priority order. =item C For non-durable topics do you wish this subscription to the retroactive. =item C For durable topic subscriptions you must specify the same L<< /C >> on the connection and L<< /C >> on the subscribe. =back $stomp->subscribe( { destination => '/queue/foo', 'ack' => 'client', 'activemq.prefetchSize' => 1 } ); =head2 C This unsubscribes you to a queue or topic. You must pass in a C or an C: $stomp->unsubcribe({ destination => '/queue/foo' }); Always returns a true value. =head2 C This blocks and returns you the next Stomp frame, or C if there was a connection problem. my $frame = $stomp->receive_frame; warn $frame->body; # do something here By default this method will block until a frame can be returned, or for however long the L attribue says. If you wish to wait for a specified time pass a C argument: # Wait half a second for a frame, else return undef $stomp->receive_frame({ timeout => 0.5 }) =head2 C This returns whether there is new data waiting to be read from the STOMP server. Optionally takes a timeout in seconds: my $can_read = $stomp->can_read; my $can_read = $stomp->can_read({ timeout => '0.1' }); C says block until something can be read, C<0> says to poll and return immediately. This method ignores the value of the L attribute. =head2 C This acknowledges that you have received and processed a frame I (if you are using client acknowledgements): $stomp->ack( { frame => $frame } ); Always returns a true value. =head2 C This informs the remote end that you have been unable to process a received frame (if you are using client acknowledgements) (See individual stomp server documentation for information about additional fields that can be passed to alter NACK behavior): $stomp->nack( { frame => $frame } ); Always returns a true value. =head2 C If this module does not provide enough help for sending frames, you may construct your own frame and send it: # write your own frame my $frame = Net::Stomp::Frame->new( { command => $command, headers => $conf, body => $body } ); $self->send_frame($frame); This is the method used by all the other methods that send frames. It will keep trying to send the frame as hard as it can, reconnecting if the connection breaks (limited by L<< /C >>). If no connection can be established, and L<< /C >> is not 0, this method will C. Always returns an empty list. =head1 SEE ALSO L. =head1 SOURCE REPOSITORY https://github.com/dakkar/Net-Stomp =head1 AUTHORS Leon Brocard , Thom May , Michael S. Fischer , Ash Berlin =head1 CONTRIBUTORS Paul Driver , Andreas Faafeng , Vigith Maurice , Stephen Fralich , Squeeks , Chisel Wright , Gianni Ceccarelli =head1 COPYRIGHT Copyright (C) 2006-9, Leon Brocard Copyright (C) 2009, Thom May, Betfair.com Copyright (C) 2010, Ash Berlin, Net-a-Porter.com Copyright (C) 2010, Michael S. Fischer This module is free software; you can redistribute it or modify it under the same terms as Perl itself. Net-Stomp-0.61/lib/Net/Stomp000755001750001750 014035373335 15547 5ustar00dakkardakkar000000000000Net-Stomp-0.61/lib/Net/Stomp/Frame.pm000444001750001750 1010714035373335 17313 0ustar00dakkardakkar000000000000package Net::Stomp::Frame; use strict; use warnings; our $VERSION='0.61'; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw(command headers body)); BEGIN { for my $header ( qw(destination exchange content-type content-length message-id reply-to)) { my $method = $header; $method =~ s/-/_/g; no strict 'refs'; *$method = sub { my $self = shift; $self->headers->{$header} = shift if @_; $self->headers->{$header}; }; } } sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->headers({}) unless defined $self->headers; return $self; } sub as_string { my $self = shift; my $command = $self->command; my $headers = $self->headers; my $body = $self->body; my $frame = $command . "\n"; # insert a content-length header my $bytes_message = 0; if ( $headers->{bytes_message} ) { $bytes_message = 1; delete $headers->{bytes_message}; $headers->{"content-length"} = length( $self->body ); } while ( my ( $key, $value ) = each %{ $headers || {} } ) { $frame .= $key . ':' . (defined $value ? $value : '') . "\n"; } $frame .= "\n"; $frame .= $body || ''; $frame .= "\0"; } sub parse { my ($class,$string) = @_; $string =~ s{ \A\s* ([A-Z]+)\n #command ((?:[^\n]+\n)*)\n # header block }{}smx; my ($command,$headers_block) = ($1,$2); return unless $command; my ($headers,$body); if ($headers_block) { foreach my $line (split(/\n/, $headers_block)) { my ($key, $value) = split(/\s*:\s*/, $line, 2); $headers->{$key} = $value; } } if ($headers && $headers->{'content-length'}) { if (length($string) >= $headers->{'content-length'}) { $body = substr($string, 0, $headers->{'content-length'}, '' ); } else { return } # not enough body } elsif ($string =~ s/\A(.*?)\0//s) { # No content-length header. $body = $1 if length($1); } else { return } # no body return $class->new({ command => $command, headers => $headers, body => $body, }); } 1; __END__ =head1 NAME Net::Stomp::Frame - A STOMP Frame =head1 SYNOPSIS use Net::Stomp::Frame; my $frame = Net::Stomp::Frame->new( { command => $command, headers => $headers, body => $body, } ); my $frame = Net::Stomp::Frame->parse($string); my $string = $frame->as_string; =head1 DESCRIPTION This module encapulates a Stomp frame. A Stomp frame consists of a command, a series of headers and a body. For details on the protocol see L. =head1 METHODS =head2 new Create a new L object: my $frame = Net::Stomp::Frame->new( { command => $command, headers => $headers, body => $body, } ); =head2 parse Create a new L given a string containing the serialised frame: my $frame = Net::Stomp::Frame->parse($string); =head2 as_string Create a string containing the serialised frame representing the frame: my $string = $frame->as_string; =head2 command Get or set the frame command. =head2 body Get or set the frame body. =head2 headers Get or set the frame headers, as a hashref. All following methods are just shortcuts into this hashref. =head2 destination Get or set the C header. =head2 content_type Get or set the C header. =head2 content_length Get or set the C header. =head2 exchange Get or set the C header. =head2 message_id Get or set the C header. =head2 reply_to Get or set the C header. =head1 SEE ALSO L. =head1 AUTHOR Leon Brocard . =head1 CONTRIBUTORS Gianni Ceccarelli =head1 COPYRIGHT Copyright (C) 2006, Leon Brocard This module is free software; you can redistribute it or modify it under the same terms as Perl itself. Net-Stomp-0.61/lib/Net/Stomp/StupidLogger.pm000444001750001750 327714035373335 20663 0ustar00dakkardakkar000000000000package Net::Stomp::StupidLogger; use strict; use warnings; use Carp; our $VERSION = '0.61'; sub new { my ($class,$levels) = @_; $levels||={}; for my $l (qw(warn error fatal)) { $levels->{$l}=1 unless defined $levels->{$l}; } return bless $levels,$class; } sub _log { my ($self,$level,@etc) = @_; return unless $self->{$level}; carp join '',@etc; } sub debug { my $self=shift;$self->_log(debug=>@_) } sub info { my $self=shift;$self->_log(info =>@_) } sub warn { my $self=shift;$self->_log(warn =>@_) } sub error { my $self=shift;$self->_log(error=>@_) } sub fatal { my $self=shift;$self->_log(fatal=>@_) } 1; __END__ =head1 NAME Net::Stomp::StupidLogger - stub logger =head1 DESCRIPTION This class implements a very simple logger-like object, that just delegates to L. By default, it logs at C and above. L used to use this, but now it just uses L, so this package is here just in case someone else was using it. =head1 METHODS =head2 new Constructor. You can pass a hashref with the log levels to enable / disable, like: Net::Stomp::StupidLogger->new({debug=>1}); # logs debug, warn, # error, fatal Net::Stomp::StupidLogger->new({warn=>0}); # logs error, fatal =head2 debug =head2 info =head2 warn =head2 error =head2 fatal $logger->warn('some',$message); If the corresponding level is enabled, joins the arguments in a single string (no spaces added) and calls L. =head1 AUTHORS Gianni Ceccarelli =head1 COPYRIGHT This module is free software; you can redistribute it or modify it under the same terms as Perl itself. Net-Stomp-0.61/t000755001750001750 014035373335 13414 5ustar00dakkardakkar000000000000Net-Stomp-0.61/t/connect-disconnect.t000444001750001750 270414035373335 17521 0ustar00dakkardakkar000000000000use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; my ($s,$fh)=mkstomp_testsocket(); my $frame;my $buffer=''; $fh->{written} = sub { $buffer .= $_[0]; $frame = Net::Stomp::Frame->parse($buffer); $buffer='' if $frame; return length($_[0]); }; subtest 'connect' => sub { $fh->{to_read} = sub { if ($frame) { return Net::Stomp::Frame->new({ command => 'CONNECTED', headers => {session=>'foo'}, })->as_string; } return ''; }; $s->connect({login=>'me'}); cmp_deeply( $frame, all( isa('Net::Stomp::Frame'), methods( command => 'CONNECT', headers => {login=>'me'}, body => undef, ), ), 'connect frame sent', ); cmp_deeply( $s, methods( session_id => 'foo', _connect_headers => { login => 'me' }, ), 'connection data received and stored', ); }; subtest 'disconnect' => sub { $frame=''; $s->disconnect; cmp_deeply( $frame, all( isa('Net::Stomp::Frame'), methods( command => 'DISCONNECT', headers => {}, body => undef, ), ), 'disconnect frame sent', ); ok(not(defined($s->select->{socket})),'socket was removed from select'); }; done_testing; Net-Stomp-0.61/t/constructor.t000444001750001750 371314035373335 16327 0ustar00dakkardakkar000000000000#!perl use lib 't/lib'; use TestHelp; use Test::Fatal; use Log::Any::Adapter::Test; {no warnings 'redefine'; sub Net::Stomp::_get_connection {} } subtest 'reconnect on fork' => sub { my $s = mkstomp(); is($s->reconnect_on_fork,1,'defaults to true'); $s = mkstomp(reconnect_on_fork => 0); is($s->reconnect_on_fork,0,'can be turned off'); }; subtest 'hosts' => sub { my $s = mkstomp(hosts=>[{foo=>'bar'}]); cmp_deeply($s->hosts,[{foo=>'bar'}],'one host ok'); $s = mkstomp(hosts=>[{foo=>'bar'},{one=>'two'}]); cmp_deeply($s->hosts,[{foo=>'bar'},{one=>'two'}],'two hosts ok'); }; subtest 'failover' => sub { my %cases = ( 'failover:tcp://one:1234' => [ {hostname=>'one',port=>1234}, ], 'failover:(tcp://one:1234)?opts' => [ {hostname=>'one',port=>1234}, ], 'failover:tcp://one:1234,tcp://two:3456' => [ {hostname=>'one',port=>1234}, {hostname=>'two',port=>3456}, ], 'failover:(tcp://one:1234,tcp://two:3456)?opts' => [ {hostname=>'one',port=>1234}, {hostname=>'two',port=>3456}, ], ); for my $case (sort keys %cases) { my $s = mkstomp( failover=>$case, ); cmp_deeply($s->hosts,$cases{$case},"$case parsed ok"); } }; subtest 'bad failover' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; like( exception { mkstomp(failover=>'bad') }, qr{Unable to parse failover uri}i, 'bad uri correct exception', ); like( exception { mkstomp(failover=>'failover://(a,b)') }, qr{Unable to parse failover component}i, 'bad component correct exception', ); Log::Any::Adapter::Test->category_contains_ok( 'Net::Stomp', qr{Unable to parse failover uri}, 'the problem should be logged', ); }; done_testing; Net-Stomp-0.61/t/failover.t000444001750001750 1070314035373335 15566 0ustar00dakkardakkar000000000000#!perl use lib 't/lib'; use TestHelp; use Test::Fatal; use Log::Any::Adapter::Test; subtest 'default reconnect attempts' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; my ($s,$fh) = mkstomp_testsocket( hosts => [ {hostname=>'one',port=>1}, {hostname=>'two',port=>2}, {hostname=>'three',port=>3}, ], ); my @connected_hosts; {no warnings 'redefine'; *Net::Stomp::_get_socket = sub { my ($self) = @_; push @connected_hosts,$self->current_host; if (@connected_hosts>4) { $fh->{connected}=1; return $fh; } else { return undef; } } }; $fh->{to_read} = sub { return Net::Stomp::Frame->new({ command => 'CONNECTED', headers => {session=>'foo'}, })->as_string; }; $fh->{connected}=undef; # fake a disconnect $s->send({destination=>'here',body=>'string'}); cmp_deeply( \@connected_hosts, [1,2,0,1,2], 'tried all hosts, round-robin, re-starting', ); cmp_deeply( Log::Any::Adapter::Test->msgs, [ superhashof({ message => re(qr{sending}) }), superhashof({ message => re(qr{closing}) }), superhashof({ message => re(qr{reconnecting}) }), superhashof({ message => re(qr{error connecting to two}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to three}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to one}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to two}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{connecting}i) }), superhashof({ message => re(qr{waiting}i) }), superhashof({ message => re(qr{connected}i) }), ], 'reconnecting should be logged', ); }; subtest 'limited reconnect attempts' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; my ($s,$fh) = mkstomp_testsocket( hosts => [ {hostname=>'one',port=>1}, {hostname=>'two',port=>2}, {hostname=>'three',port=>3}, ], reconnect_attempts => 2, ); my @connected_hosts; {no warnings 'redefine'; *Net::Stomp::_get_socket = sub { my ($self) = @_; push @connected_hosts,$self->current_host; return undef; } }; $fh->{to_read} = sub { return Net::Stomp::Frame->new({ command => 'CONNECTED', headers => {session=>'foo'}, })->as_string; }; $fh->{connected}=undef; # fake a disconnect my $e = exception { $s->send({destination=>'here',body=>'string'}) }; ok(defined $e,'died ok'); like($e,qr{giving up},'correct exception'); cmp_deeply( \@connected_hosts, [1,2,0,1,2,0], 'tried all hosts, round-robin, re-starting, then stopped', ); cmp_deeply( Log::Any::Adapter::Test->msgs, [ superhashof({ message => re(qr{sending}) }), superhashof({ message => re(qr{closing}) }), superhashof({ message => re(qr{reconnecting}) }), superhashof({ message => re(qr{error connecting to two}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to three}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to one}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to two}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to three}i) }), superhashof({ message => re(qr{failed to connect}i) }), superhashof({ message => re(qr{error connecting to one}i) }), superhashof({ message => re(qr{failed to connect}i) }), ], 'reconnecting should be logged', ); }; done_testing; Net-Stomp-0.61/t/frame-accessors.t000444001750001750 100314035373335 17005 0ustar00dakkardakkar000000000000#!perl use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; my $f = Net::Stomp::Frame->new(); for my $h (qw(destination exchange content-type content-length message-id reply-to)) { subtest $h => sub { my $a = $h;$a=~s{-}{_}g; ok(!defined $f->headers->{$h},'header undef'); ok(!defined $f->$a,'accessor returns undef'); $f->$a('something'); is($f->headers->{$h},'something','header set'); is($f->$a,'something','accessor returns value'); } } done_testing; Net-Stomp-0.61/t/initial-connect.t000444001750001750 1376714035373335 17054 0ustar00dakkardakkar000000000000#!perl use lib 't/lib'; use TestHelp; use Test::Fatal; use Log::Any::Adapter::Test; our @sockets; {no warnings 'redefine'; sub Net::Stomp::_get_socket { my $ret = shift @sockets; $!=1 unless $ret; return $ret; } } subtest 'simplest case' => sub { local @sockets=(\*STDIN); my $s = mkstomp(); cmp_deeply( $s, methods( hostname => 'localhost', port => 61613, current_host => 0, socket => \*STDIN, select => noclass(superhashof({socket=>\*STDIN})), ), 'correct', ); }; subtest 'simplest case, old style' => sub { local @sockets=(\*STDIN); my $s = mkstomp(hosts=>undef,hostname=>'localhost',port=>61613,); cmp_deeply( $s, methods( hostname => 'localhost', port => 61613, current_host => undef, socket => \*STDIN, select => noclass(superhashof({socket=>\*STDIN})), ), 'correct', ); }; subtest 'two host, first one' => sub { local @sockets=(\*STDIN); my $s = mkstomp(hosts=>[{hostname=>'one',port=>1234},{hostname=>'two',port=>3456,ssl=>1}]); cmp_deeply( $s, methods( hostname => 'one', port => 1234, ssl => bool(0), current_host => 0, socket => \*STDIN, ), 'correct', ); }; subtest 'two host, second one' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; local @sockets=(undef,\*STDIN); my $s = mkstomp(hosts=>[{hostname=>'one',port=>1234},{hostname=>'two',port=>3456,ssl=>1,ssl_options=>{a=>'b'}}]); cmp_deeply( $s, methods( hostname => 'two', port => 3456, ssl => 1, ssl_options => {a=>'b'}, current_host => 1, socket => \*STDIN, ), 'correct', ); cmp_deeply( Log::Any::Adapter::Test->msgs, [ superhashof({ message => re(qr{error connecting}i) }), superhashof({ message => re(qr{failed to connect}i) }), ], 'failure should be logged', ); }; subtest 'two host, second one, SSL on first' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; local @sockets=(undef,\*STDIN); my $s = mkstomp(hosts=>[{hostname=>'one',port=>1234,ssl=>1,ssl_options=>{a=>'b'}},{hostname=>'two',port=>3456}]); cmp_deeply( $s, methods( hostname => 'two', port => 3456, ssl => bool(0),, ssl_options => {}, current_host => 1, socket => \*STDIN, ), 'correct', ); cmp_deeply( Log::Any::Adapter::Test->msgs, [ superhashof({ message => re(qr{error connecting}i) }), superhashof({ message => re(qr{failed to connect}i) }), ], 'failure should be logged', ); }; subtest 'two host, none' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; local @sockets=(undef,undef); my $s; my $err = exception { $s=mkstomp(hosts=>[{hostname=>'one',port=>1234},{hostname=>'two',port=>3456}]) }; cmp_deeply($s,undef,'expected failure'); cmp_deeply($err,re(qr{Error connecting.*giving up}),'expected exception'); ok(@sockets==0,'two attempts'); cmp_deeply( Log::Any::Adapter::Test->msgs, [( superhashof({ message => re(qr{error connecting}i) }), superhashof({ message => re(qr{failed to connect}i) }), ) x 2], 'failure should be logged', ); }; subtest 'two host, none, keep trying' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; local @sockets=(undef,undef,undef,undef,undef,undef); my $s; my $err = exception { $s=mkstomp( hosts=>[{hostname=>'one',port=>1234},{hostname=>'two',port=>3456}], initial_reconnect_attempts => 2, ) }; cmp_deeply($s,undef,'expected failure'); cmp_deeply($err,re(qr{Error connecting}),'expected exception'); ok(@sockets==2,'four attempts'); cmp_deeply( Log::Any::Adapter::Test->msgs, [( superhashof({ message => re(qr{error connecting}i) }), superhashof({ message => re(qr{failed to connect}i) }), ) x 4], 'failure should be logged', ); }; subtest 'old style, failure' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; local @sockets=(undef); my $s; my $err = exception { $s=mkstomp(hosts=>undef,hostname=>'localhost',port=>61613,) }; cmp_deeply($s,undef,'expected failure'); cmp_deeply($err,re(qr{Error connecting}),'expected exception'); cmp_deeply( Log::Any::Adapter::Test->msgs, [ superhashof({ message => re(qr{error connecting}i) }), superhashof({ message => re(qr{failed to connect}i) }), ], 'failure should be logged', ); }; subtest 'old style, failure, keep trying' => sub { Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); Log::Any::Adapter::Test->clear; local @sockets=(undef,undef,undef); my $s; my $err = exception { $s=mkstomp( hosts=>undef,hostname=>'localhost',port=>61613, initial_reconnect_attempts => 2, ) }; cmp_deeply($s,undef,'expected failure'); cmp_deeply($err,re(qr{Error connecting}),'expected exception'); ok(@sockets==1,'two attempts'); cmp_deeply( Log::Any::Adapter::Test->msgs, [( superhashof({ message => re(qr{error connecting}i) }), superhashof({ message => re(qr{failed to connect}i) }), ) x 2], 'failure should be logged', ); }; done_testing; Net-Stomp-0.61/t/pod.t000444001750001750 21414035373335 14475 0ustar00dakkardakkar000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Net-Stomp-0.61/t/pod_coverage.t000444001750001750 25414035373335 16354 0ustar00dakkardakkar000000000000#!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); Net-Stomp-0.61/t/read-timeout.t000444001750001750 156414035373335 16343 0ustar00dakkardakkar000000000000use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; my ($s,$fh)=mkstomp_testsocket(timeout=>1); my $str = "string\0with\0zeroes\0"; my $frame = Net::Stomp::Frame->new({ command=>'MESSAGE', body=>$str, headers=>{ 'message-id'=>1, 'content-length'=>length($str), }, }); my $frame_string = $frame->as_string; my $time_out_next=0; $fh->{to_read} = sub { return if $time_out_next; my $ret = substr($frame_string,0,2,''); $time_out_next=1; return $ret; }; $s->select->{can_read} = sub { return 1 unless $time_out_next; $time_out_next=0; return; }; my $calls_needed = length($frame_string)/2; for (1..$calls_needed-1) { my $received = $s->receive_frame; ok(!defined($received),'frame not received yet, time out'); } my $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed'); done_testing; Net-Stomp-0.61/t/receiving-frames.t000444001750001750 700214035373335 17163 0ustar00dakkardakkar000000000000use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; my ($s,$fh)=mkstomp_testsocket(timeout=>1); subtest 'one frame' => sub { my $timeout_in_call; my $orig = \&Net::Stomp::_read_data; no warnings 'redefine'; local *Net::Stomp::_read_data = sub { my ($self,$timeout) = @_; $timeout_in_call=$timeout; $self->$orig($timeout); }; my $frame = Net::Stomp::Frame->new({ command=>'MESSAGE', headers=>{'message-id'=>1}, body=>'string', }); $fh->{to_read}=$frame->as_string; my $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed'); is($timeout_in_call,1,'correct timeout passed'); $fh->{to_read}=$frame->as_string; $received = $s->receive_frame({timeout=>3}); is($timeout_in_call,3,'correct timeout passed'); }; subtest 'two frames' => sub { my @frames = map {Net::Stomp::Frame->new({ command=>'MESSAGE', headers=>{'message-id'=>$_}, body=>'string', })} (1,2); $fh->{to_read}=join '',map {$_->as_string} @frames; my $received = $s->receive_frame; cmp_deeply($received,$frames[0],'received and parsed'); $received = $s->receive_frame; cmp_deeply($received,$frames[1],'received and parsed'); }; subtest 'a few bytes at a time' => sub { my $frame = Net::Stomp::Frame->new({ command=>'MESSAGE', headers=>{'message-id'=>1}, body=>'string', }); my $frame_string = $frame->as_string; $fh->{to_read} = sub { return substr($frame_string,0,2,''); }; my $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed'); }; subtest 'one frame, with content-length' => sub { my $str = "string\0with\0zeroes\0"; my $frame = Net::Stomp::Frame->new({ command=>'MESSAGE', body=>$str, headers=>{ 'message-id'=>1, 'content-length'=>length($str), }, }); $fh->{to_read}=$frame->as_string; my $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed'); }; subtest 'a few bytes at a time, with content-length' => sub { my $str = "string\0with\0zeroes\0"; my $frame = Net::Stomp::Frame->new({ command=>'MESSAGE', body=>$str, headers=>{ 'message-id'=>1, 'content-length'=>length($str), }, }); my $frame_string = $frame->as_string; $fh->{to_read} = sub { return substr($frame_string,0,2,''); }; my $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed'); }; subtest 'buffer boundary condition' => sub { # this is a regression test for RT #105500, thanks Dryapak Grigory # for reporting it my $str = "string\0with\0zeroes\0"; my $frame = Net::Stomp::Frame->new({ command=>'MESSAGE', body=>$str, headers=>{ 'message-id'=>1, 'content-length'=>length($str), }, }); my $frame_string = $frame->as_string; # the first read gets the entire frame *minus the terminating 0* # the second read gets the zero my $bufsize = length($frame_string)-1; $s->bufsize($bufsize); # let's add another frame $frame_string .= $frame_string; $fh->{to_read} = sub { return substr($frame_string,0,$bufsize,''); }; my $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed'); $received = $s->receive_frame; cmp_deeply($received,$frame,'received and parsed, twice'); }; done_testing; Net-Stomp-0.61/t/reconnect.t000444001750001750 1237414035373335 15745 0ustar00dakkardakkar000000000000#!perl use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; use Log::Any::Adapter::Test; Log::Any::Adapter->set( { lexically => \(my $guard) }, 'Test', ); my ($s,$fh) = mkstomp_testsocket; my $get_socket_called; {no warnings 'redefine'; *Net::Stomp::_get_socket = sub { ++$get_socket_called; if ($get_socket_called>1) { $fh->{connected}=1; return $fh; } else { return undef; } } }; $fh->{to_read} = sub { return Net::Stomp::Frame->new({ command => 'CONNECTED', headers => {session=>'foo'}, })->as_string; }; my @frames;our $written_inner; $fh->{written} = sub { my ($input)= @_; my $frame = Net::Stomp::Frame->parse($input); if ($frame) { push @frames,$frame; } else { push @frames,$input; } if ($written_inner) { return $written_inner->(@_); } return length($input); }; $s->connect({login=>'me'}); $s->subscribe({destination=>'/queue/my'}); my $expected_send_frame = methods( command=>'SEND', headers=>{destination=>'here'}, body => 'string', ); my $expected_connect_frame = methods( command=>'CONNECT', headers=>{login=>'me'}, ); my $expected_subscribe_frame = methods( command=>'SUBSCRIBE', headers=>{destination=>'/queue/my'}, ); sub _test_send { my (@different_expect) = @_; $get_socket_called=0;@frames=(); $s->send({destination=>'here',body=>'string'}); is($get_socket_called,2,'reconnected ok'); cmp_deeply( \@frames, (@different_expect ? \@different_expect : [ $expected_connect_frame, $expected_subscribe_frame, $expected_send_frame, ]), ); } sub _test_receive { my (@different_expect) = @_; $get_socket_called=0;@frames=(); my $f = $s->receive_frame; is($get_socket_called,2,'reconnected ok'); cmp_deeply( \@frames, (@different_expect ? \@different_expect : [ $expected_connect_frame, $expected_subscribe_frame, ]), ); } subtest 'reconnect on fork' => sub { ++$s->{_pid}; # fake a fork _test_send; }; subtest 'not-reconnect on fork' => sub { local $s->{reconnect_on_fork}=0; local $s->{_pid}=1; # fake a fork $get_socket_called=0; $s->send({some=>'stuff'}); is($get_socket_called,0,'reconnect_on_fork can be disabled'); }; subtest 'reconnect on disconnect before send' => sub { $fh->{connected}=undef; # fake a disconnect _test_send; }; subtest 'reconnect on disconnect before send (defined but false)' => sub { $fh->{connected}=0; # fake a different kind of disconnect _test_send; }; subtest 'reconnect on disconnect while sending' => sub { # fake a disconnect after the syswrite, only once my $called=0; local $written_inner = sub { $fh->{connected} = undef unless $called++; return length($_[0]); }; _test_send( $expected_send_frame, $expected_connect_frame, $expected_subscribe_frame, $expected_send_frame, ); }; subtest 'reconnect on write failure' => sub { # fake a disconnect after the syswrite, only once my $called=0; local $written_inner = sub { my $ret; if ($called) { $ret = $called -1; if ($ret > length($_[0])) { $ret=length($_[0]); } } else { $ret = undef; $!=1; } ++$called; return $ret; }; _test_send( $expected_send_frame, $expected_connect_frame, $expected_connect_frame, methods(command=>'ONNECT'), # partial writes! methods(command=>'NECT'), methods(command=>'T'), "gin:me\n\n\0", "e\n\n\0", $expected_subscribe_frame, methods(command=>'BE'), "nation:/queue/my\n\n\0", "ueue/my\n\n\0", $expected_send_frame, "ation:here\n\nstring\0", "string\0", ); }; subtest 'reconnect on disconnect before receive' => sub { $fh->{connected}=undef; # fake a disconnect _test_receive; }; subtest 'report failure if not can_read' => sub { my $ret = do { local $s->select->{can_read}=0; $s->receive_frame; }; ok(!defined($ret),'reported undef'); ok(defined($fh->{connected}),'socket still open'); $ret = $s->receive_frame; cmp_deeply( $ret, methods(command=>'CONNECTED'), 'receive recovered' ); }; subtest 'report failure if sysread fails' => sub { my $ret = do { local $fh->{to_read} = sub {$!=1;return}; $s->receive_frame; }; ok(!defined($ret),'reported undef'); ok(!defined($fh->{connected}),'socket closed'); _test_receive; }; subtest 'report failure if sysread EOF' => sub { my $ret = do { local $fh->{to_read} = sub {return ''}; $s->receive_frame; }; ok(!defined($ret),'reported undef'); ok(!defined($fh->{connected}),'socket closed'); _test_receive; }; subtest 'send_with_receipt report failure if receive_frame does' => sub { my $ret = do { local $fh->{to_read} = sub {$!=1;return}; $s->send_with_receipt({some=>'header',body=>'string'}); }; ok(!$ret,'reported false'); ok(!defined($fh->{connected}),'socket closed'); }; done_testing; Net-Stomp-0.61/t/send-transactional.t000444001750001750 457514035373335 17542 0ustar00dakkardakkar000000000000use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; my ($s,$fh)=mkstomp_testsocket(); my @frames;my $buffer=''; $fh->{written} = sub { $buffer .= $_[0]; my $frame = Net::Stomp::Frame->parse($buffer); if ($frame) { $buffer=''; push @frames,$frame; } return length($_[0]); }; # expected: # -> BEGIN # -> SEND # <- RECEIPT # -> COMMIT # # or # -> BEGIN # -> SEND # <- something else # -> COMMIT sub _testit { my ($response_frame,$expected_ret,$expected_command) = @_; $fh->{to_read} = sub { if ($frames[1]) { return $response_frame->($frames[1]->headers->{receipt}) ->as_string; } return ''; }; @frames=(); my $ret = $s->send_transactional({some=>'header',body=>'string'}); cmp_deeply($ret,bool($expected_ret),"expected return value"); is(scalar(@frames),3,'3 frames sent'); cmp_deeply( $frames[0], methods( command=>'BEGIN', headers => {transaction => ignore()}, ), 'begin ok', ); my $transaction = $frames[0]->headers->{transaction}; cmp_deeply( $frames[1], methods( command => 'SEND', headers => { some=>'header', transaction=>$transaction, receipt=>ignore(), }, body => 'string', ), 'send ok', ); cmp_deeply( $frames[2], methods( command => uc($expected_command), headers => { transaction=>$transaction, }, ), "\L$expected_command\E ok", ); } subtest 'successful' => sub { _testit(sub{ Net::Stomp::Frame->new({ command=>'RECEIPT', headers=>{'receipt-id'=>$_[0]}, body=>undef, }) },1,'COMMIT'); }; subtest 'failed' => sub { _testit(sub{ Net::Stomp::Frame->new({ command=>'ERROR', headers=>{some=>'header'}, body=>undef, }) },0,'ABORT'); }; subtest 'bad receipt' => sub { _testit(sub{ Net::Stomp::Frame->new({ command=>'RECEIPT', headers=>{'receipt-id'=>"not-$_[0]"}, body=>undef, }) },0,'ABORT'); }; subtest 'no receipt (timeout)' => sub { local $s->select->{can_read}=0; _testit(sub{ Net::Stomp::Frame->new({ command=>'BLARGH', body=>undef, }) },0,'ABORT'); }; done_testing; Net-Stomp-0.61/t/send-with-receipt.t000444001750001750 346014035373335 17274 0ustar00dakkardakkar000000000000use lib 't/lib'; use TestHelp; use Net::Stomp::Frame; my ($s,$fh)=mkstomp_testsocket( receipt_timeout => 5, ); my @frames;my $buffer=''; $fh->{written} = sub { $buffer .= $_[0]; my $frame = Net::Stomp::Frame->parse($buffer); if ($frame) { $buffer=''; push @frames,$frame; } return length($_[0]); }; # expected: # -> SEND # <- RECEIPT # # or # -> SEND # <- something else sub _testit { my ($response_frame,$expected) = @_; $fh->{to_read} = sub { if ($frames[0]) { return $response_frame->($frames[0]->headers->{receipt}) ->as_string; } return ''; }; @frames=(); my $ret = $s->send_with_receipt({some=>'header',body=>'string',timeout=>5}); is(scalar(@frames),1,'1 frame sent'); cmp_deeply( $frames[0], methods( command => 'SEND', headers => { some=>'header', receipt=>ignore(), }, body => 'string', ), 'send ok', ); is ($ret,$expected,'return value as expected'); } subtest 'successful' => sub { _testit(sub{ Net::Stomp::Frame->new({ command=>'RECEIPT', headers=>{'receipt-id'=>$_[0]}, body=>undef, }) },1); }; subtest 'failed' => sub { _testit(sub{ Net::Stomp::Frame->new({ command=>'ERROR', headers=>{some=>'header'}, body=>undef, }) },0); }; subtest 'bad receipt' => sub { _testit(sub{ Net::Stomp::Frame->new({ command=>'RECEIPT', headers=>{'receipt-id'=>"not-$_[0]"}, body=>undef, }) },0); }; subtest 'no receipt (timeout)' => sub { local $s->select->{can_read}=0; _testit(sub{ Net::Stomp::Frame->new({ command=>'BLARGH', body=>undef, }) },0); }; done_testing; Net-Stomp-0.61/t/sending-frames.t000444001750001750 530314035373335 16641 0ustar00dakkardakkar000000000000use lib 't/lib'; use TestHelp; my @frames; {no warnings 'redefine'; sub Net::Stomp::send_frame {push @frames,$_[1];return;} } my ($s,$fh)=mkstomp_testsocket(); sub _testit { my ($method,$arg,@tests) = @_; @frames=(); my $ret = $s->$method($arg); ok($ret,"$method returned true"); cmp_deeply( \@frames, [all( isa('Net::Stomp::Frame'), methods(@tests), )], "$method sent ok", ); } subtest 'send and ack' => sub { _testit( send => {'message-id'=>12,body=>'string'}, command=>'SEND', headers=>{'message-id'=>12}, body=>'string', ); my $message = $frames[0]; _testit( ack => {frame=>$message}, command=>'ACK', headers=>{'message-id'=>12}, body=>undef, ); _testit( ack => {frame=>$message,receipt=>'foo'}, command=>'ACK', headers=>{'message-id'=>12,receipt=>'foo'}, body=>undef, ); }; subtest 'send and nack' => sub { _testit( send => {'message-id'=>12,body=>'string'}, command=>'SEND', headers=>{'message-id'=>12}, body=>'string', ); my $message = $frames[0]; _testit( nack => {frame=>$message}, command=>'NACK', headers=>{'message-id'=>12}, body=>undef, ); _testit( nack => {frame=>$message,receipt=>'foo'}, command=>'NACK', headers=>{'message-id'=>12,receipt=>'foo'}, body=>undef, ); }; subtest '(un)subscribe by id' => sub { _testit( subscribe => {id=>1,destination=>'/queue/foo'}, command=>'SUBSCRIBE', headers=>{id=>1,destination=>'/queue/foo'}, body => undef, ); cmp_deeply( $s->subscriptions, {'id-1'=>{id=>1,destination=>'/queue/foo'}}, 'recorded ok', ); _testit( unsubscribe => {id=>1,destination=>'/queue/foo'}, command=>'UNSUBSCRIBE', headers=>{id=>1,destination=>'/queue/foo'}, body => undef, ); cmp_deeply( $s->subscriptions, {}, 'recorded ok', ); }; subtest 'subscribe without id' => sub { _testit( subscribe => {destination=>'/queue/foo'}, command=>'SUBSCRIBE', headers=>{destination=>'/queue/foo'}, body => undef, ); cmp_deeply( $s->subscriptions, {'dest-/queue/foo'=>{destination=>'/queue/foo'}}, 'recorded ok', ); _testit( unsubscribe => {destination=>'/queue/foo'}, command=>'UNSUBSCRIBE', headers=>{destination=>'/queue/foo'}, body => undef, ); cmp_deeply( $s->subscriptions, {}, 'recorded ok', ); }; done_testing; Net-Stomp-0.61/t/lib000755001750001750 014035373335 14162 5ustar00dakkardakkar000000000000Net-Stomp-0.61/t/lib/TestHelp.pm000444001750001750 435114035373335 16410 0ustar00dakkardakkar000000000000use strict; use warnings; BEGIN {$ENV{TAP_LOG_ORIGIN}=1; $ENV{TAP_LOG_SHOW_USAGE}=0 } use Log::Any::Adapter TAP => ( filter => 'debug' ); {package TestHelp; use strict; use warnings; BEGIN { $INC{'IO/Select.pm'}=__FILE__ } use Net::Stomp; use Test::NiceDump (); use Test::Deep (); sub mkstomp { return Net::Stomp->new({ hosts => [ {hostname=>'localhost',port=>61613} ], connect_delay => 0, @_, }) } sub mkstomp_testsocket { my $fh = TestHelp::Socket->new({ connected=>1, to_read=>'', }); no warnings 'redefine'; local *Net::Stomp::_get_socket = sub { return $fh }; my $s = mkstomp(@_); return ($s,$fh); } sub cmp { my ($got,$expected,$message) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; Test::Deep::cmp_deeply( $got, $expected, $message ) or Test::NiceDump::nice_explain($got,$expected); } sub import { my $caller = caller; eval "package $caller; strict->import; warnings->import; use Test::More; use Test::Deep '!cmp_deeply';1;" or die $@; no strict 'refs'; *{"${caller}::mkstomp"}=\&mkstomp; *{"${caller}::mkstomp_testsocket"}=\&mkstomp_testsocket; *{"${caller}::cmp_deeply"}=\&cmp; return; } } {package TestHelp::Socket; use strict; use warnings; sub new { bless $_[1],$_[0]; } sub connected { return $_[0]->{connected} } sub close { $_[0]->{connected} = undef; } sub syswrite { my ($self,$string) = @_; my $ret; if (ref($self->{written})) { return $self->{written}->($string); } else { $self->{written} .= $string; return length($string); } } sub sysread { my ($self,$dest,$length,$offset) = @_; my $string = ref($self->{to_read})?($self->{to_read}->()):($self->{to_read}); return if not defined $string; my $ret = substr($string,0,$length,''); substr($_[1],$offset) = $ret; return length $ret; } } {package IO::Select; use strict; use warnings; sub new { bless {can_read=>1},$_[0] } sub add { $_[0]->{socket}=$_[1] } sub remove { delete $_[0]->{socket} } sub can_read { my ($self) = @_; return unless $self->{socket}; my $can_read = ref($self->{can_read})?($self->{can_read}->()):($self->{can_read}); return $can_read; } } 1; Net-Stomp-0.61/xt000755001750001750 014035373335 13604 5ustar00dakkardakkar000000000000Net-Stomp-0.61/xt/consume_buffering.t000444001750001750 315314035373335 17630 0ustar00dakkardakkar000000000000# -*- Mode: Perl; tab-width: 2; indent-tabs-mode: nil; -*- use strict; use warnings; use Test::More; use Test::Exception; use Net::Stomp; my $amount_to_send = 32; my $broker_host = '0.0.0.0'; note "About to insert $amount_to_send messages - be patient"; lives_ok { local $SIG{ALRM} = sub { die "failed to send $amount_to_send messages\n" }; # NB: \n required alarm(10); my $connection = Net::Stomp->new({ hostname => $broker_host, port => 61613, }); $connection->connect; for my $n (1 .. $amount_to_send) { $connection->send({ destination => '/queue/consume.many', body => "Message $n - " . scalar localtime }) } } q{inserted multiple jobs without dying}; note "Inserted $amount_to_send messages - cheers"; # now try to peel off messages use Net::Stomp; my $connection; lives_ok { $connection = Net::Stomp->new({ hostname => $broker_host, debug => 1, port => 61613, }); $connection->connect; $connection->subscribe({ destination => '/queue/consume.many', ack => 'client', }); } q{connected using Net::Stomp}; note "About to consume $amount_to_send frames - be patient"; lives_ok { local $SIG{ALRM} = sub { die "failed to consume $amount_to_send messages\n" }; # NB: \n required alarm(10); for (1 .. $amount_to_send) { my $frame = $connection->receive_frame; note "read frame $_: " . $frame->body; $connection->ack({frame => $frame}); } } qq{read $amount_to_send frames}; note "Consumed $amount_to_send frames - cheers"; done_testing;