The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl

use strict;
use warnings;
use Test::More;

use Net::STOMP::Client;

#
# we try to connect to a real broker over STOMP so we need some information:
#  - PNSCT_URI: STOMP server URI (mandatory)
#  - PNSCT_AUTH: authentication to use (optional)
#  - PNSCT_LOGIN: user name to use (optional)
#  - PNSCT_PASSCODE: password to use (optional)
#  - PNSCT_DESTINATION: destination to send/receive messages (optional)
#
# FWIW: PNSCT = Perl Net-STOMP-Client Test
#

unless ($ENV{PNSCT_URI}) {
    plan skip_all => "A STOMP broker is required for this test, see $0";
}
if ($ENV{PNSCT_DESTINATION}) {
    plan tests => 18;
} else {
    plan tests => 10;
}

use constant TIMEOUT => 10;

our($stomp);

# test new+connect

sub test_connect () {
    my(%option);

    %option = ();
    $option{uri} = $ENV{PNSCT_URI};
    $option{auth} = $ENV{PNSCT_AUTH} if $ENV{PNSCT_AUTH};
    $stomp = Net::STOMP::Client->new(%option);
    ok($stomp, "new");
    ok(!$stomp->session(), "new -> no session");

    %option = ();
    $option{login}    = $ENV{PNSCT_LOGIN}    if defined($ENV{PNSCT_LOGIN});
    $option{passcode} = $ENV{PNSCT_PASSCODE} if defined($ENV{PNSCT_PASSCODE});
    $stomp->connect(%option);
    ok($stomp->session(), "connect");
    is(scalar($stomp->receipts()), 0, "connect -> no receipts");
}

# test disconnect

sub test_disconnect () {
    my(%option);

    %option = ();
    $stomp->disconnect(%option);
    ok(!$stomp->session(), "disconnect");
}

# test begin+abort, with receipts

sub test_noop () {
    my(%option, $tid);

    $tid = $stomp->uuid();
    ok($tid, "uuid");

    %option = ();
    $option{transaction} = $tid;
    $option{receipt} = $stomp->uuid();
    $stomp->begin(%option);
    is(scalar($stomp->receipts()), 1, "begin -> one receipt");

    %option = ();
    $option{timeout} = TIMEOUT;
    $stomp->wait_for_receipts(%option);
    is(scalar($stomp->receipts()), 0, "wait_for_receipts -> no receipts");

    %option = ();
    $option{transaction} = $tid;
    $option{receipt} = $stomp->uuid();
    $stomp->abort(%option);
    is(scalar($stomp->receipts()), 1, "abort -> one receipt");

    %option = ();
    $option{timeout} = TIMEOUT;
    $stomp->wait_for_receipts(%option);
    is(scalar($stomp->receipts()), 0, "wait_for_receipts -> no receipts");
}

# test subscribe+send+unsubscribe, without receipts

sub test_loopback () {
    my(%option, $count, $frame, $subid);

    # use a unique subscription id
    $subid = $stomp->uuid();

    # count the messages
    $count = 0;
    $stomp->message_callback(sub {
	my($self, $frame) = @_;

	$count++;
	return(1);
    });

    %option = ();
    $option{id} = $subid;
    $option{destination} = $ENV{PNSCT_DESTINATION};
    $stomp->subscribe(%option);
    ok(1, "subscribe");

    %option = ();
    $option{destination} = $ENV{PNSCT_DESTINATION};
    $option{foo} = "bar";
    $option{body} = "hello world";
    $stomp->send(%option);
    ok(1, "send");

    %option = ();
    $option{timeout} = TIMEOUT;
    $option{callback} = sub {
	my($self, $frame) = @_;

	return($frame) if $frame->command() eq "MESSAGE";
	return(0);
    };
    $frame = $stomp->wait_for_frames(%option);
    ok($frame, "receive");
  SKIP: {
      unless ($frame) {
	  diag("did not receive a frame back... skipping some tests...");
	  skip("", 3);
      }
      is($count, 1, "count");
      is($frame->header("foo"), "bar", "header");
      is($frame->body(), "hello world", "body");
    }

    %option = ();
    $option{id} = $subid;
    $stomp->unsubscribe(%option);
    ok(1, "unsubscribe");

    is(scalar($stomp->receipts()), 0, "loopback test -> no receipts");
}

#
# just do it
#

test_connect();
test_loopback() if $ENV{PNSCT_DESTINATION};
test_noop();
test_disconnect();