Started on a simple Perl implementation (using AnyEvent)

Note that I'm not even actually using AnyEvent functionality at the
moment. But no doubt I'm going to need it anyway.

2 files changed, 221 insertions, 0 deletions

diff --git a/Tanja.pm b/Tanja.pm
new file mode 100644
index 0000000..6827cd8
--- /dev/null
+++ b/Tanja.pm
@@ -0,0 +1,143 @@
+# Note: this implementation isn't really asynchronous for communication between
+# local sessions. Not sure yet whether this is a problem. (Can be fixed easily
+# by using single-fire idle events to dispatch tuples. Comes at a performance
+# cost, though).
+
+package Tanja;
+
+use strict;
+use warnings;
+
+# Args: [ pattern ], [ tuple ]
+# Returns: a true value on match, a false value otherwise
+# TODO: this match() implementation is for experimental purposes only, it
+# should actually follow some established semantics to interoperate properly.
+# undef is used as wildcard (in either the tuple or the pattern).
+sub match {
+	my($p, $t) = @_;
+	return 0 if @$p > @$t;
+	for my $i (keys @$p) {
+		next if !defined $p->[$i] or !defined $t->[$i];
+		return 0 if $p->[$i] ne $t->[$i];
+	}
+	return 1;
+}
+
+
+package Tanja::Server;
+
+use strict;
+use warnings;
+use AnyEvent;
+
+
+# Create a new server (representing a "network")
+sub new {
+	return bless({
+		lastid => 1,
+		pat => {},
+	}, shift);
+}
+
+
+# Create a new session
+sub session {
+	return Tanja::Session->new(shift);
+}
+
+
+# Link with another server via an AnyEvent::Handle stream
+sub link {
+}
+
+
+# Send a tuple to the network.
+# Arguments: [ tuple ], $return_cb
+sub send {
+	my($s, $t, $cb) = @_;
+	# TODO: fix return path
+	$_->[2]->($t, undef) for(grep Tanja::match($_->[0], $t), values %{$s->{pat}});
+}
+
+
+sub _register {
+	my($s, $pat, $reply, $cb) = @_;
+	my $id = $s->{lastid};
+	# Explicitely wrap around long before 2^31, to avoid having Perl turn the ID into a float.
+	++$id >= 1<<30 and $id = 1 while $s->{pat}{$id};
+	$s->{pat}{$id} = [ $pat, $reply, $cb ];
+	$s->{lastid} = $id;
+	return $id;
+}
+
+
+sub _unregister {
+	my($s, $id) = @_;
+	delete $s->{pat}{$id};
+}
+
+
+package Tanja::Session;
+
+use strict;
+use warnings;
+use AnyEvent;
+
+
+# Create a new session (usually called by $serv->session)
+sub new {
+	my($own, $serv) = @_;
+	return bless({
+		server => $serv,
+		pat => {},
+	}, $own);
+}
+
+
+# Register for a pattern
+#   Args: [ pattern ], willreply, callback
+#   Returns: $id, for use with unreg()
+# Callback:
+#   Args: [ tuple ], $return_path
+#   Returns: (ignored)
+sub reg {
+	my($s, $pat, $reply, $cb) = @_;
+	my $id = $s->{server}->_register($pat, $reply, $cb);
+	$s->{pat}{$id} = 1;
+	return $id;
+}
+
+
+# Unregister a single pattern
+sub unreg {
+	my($s, $id) = @_;
+	$s->{server}->_unregister($id);
+	delete $s->{pat}{$id};
+}
+
+
+# For convenience. Same as ->reg(), but unregisters automatically after one call.
+sub reg_once {
+	my($s, $pat, $reply, $cb) = @_;
+	my $id;
+	$id = $s->reg($pat, $reply, sub { $s->unreg($id); $cb->(@_) });
+	return $id;
+}
+
+
+sub send {
+	my $s = shift;
+	$s->{server}->send(@_);
+}
+
+
+# "Close" the session (simply unregisters all its patterns)
+sub close {
+	my $s = shift;
+	$s->{server}->_unregister($_) for (keys %{$s->{pat}});
+	$s->{pat} = {};
+}
+
+1;
+# vim:noet:sw=4:ts=4
+
diff --git a/test.pl b/test.pl
new file mode 100755
index 0000000..870435c
--- /dev/null
+++ b/test.pl
@@ -0,0 +1,78 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use AnyEvent;
+
+use_ok 'Tanja';
+
+
+# Simple matching tests.
+# (Doesn't test a whole lot, since the semantics aren't final yet anyway).
+ok  Tanja::match([], []);
+ok  Tanja::match([], [1, 2, 3]);
+ok  Tanja::match([], [undef]);
+ok !Tanja::match([undef], []);
+ok  Tanja::match([undef], [1]);
+ok  Tanja::match([1], [1]);
+ok  Tanja::match([1], [1, "b"]);
+ok  Tanja::match([1], [undef, 3]);
+ok !Tanja::match([2], [1]);
+
+
+# Simple single-session test
+{
+	my $serv = Tanja::Server->new;
+	isa_ok $serv, 'Tanja::Server';
+	my $ses = $serv->session;
+	isa_ok $ses, 'Tanja::Session';
+	my $done = AnyEvent->condvar;
+	my $n = 0;
+	$ses->reg([], 0, sub {
+		my($t, $r) = @_;
+		is $r, undef;
+		is_deeply $t, [$n];
+		ok $n <= 5;
+		if(++$n == 5) {
+			$ses->close;
+			$done->send;
+		}
+	});
+	$ses->reg_once([undef], 0, sub {
+		my($t, $r) = @_;
+		is $r, undef;
+		is_deeply $t, [0];
+	});
+	$ses->send([$_]) for (0..10);
+	$done->recv;
+	is $n, 5;
+}
+
+
+# Simple double-session test
+{
+	my $serv = Tanja::Server->new;
+	my $a = $serv->session;
+	my $b = $serv->session;
+	my $done = AnyEvent->condvar;
+	$a->reg(["msg"], 0, sub {
+		my($t, $r) = @_;
+		is $r, undef;
+		is_deeply $t, ["msg", 'a'];
+		$a->send(["b"]);
+	});
+	$b->reg(["b"], 0, sub {
+		my($t, $r) = @_;
+		is $r, undef;
+		is_deeply $t, ["b"];
+		$done->send;
+	});
+	$b->send(["msg", 'a']);
+	$done->recv;
+}
+
+
+done_testing();
+
+# vim:noet:sw=4:ts=4