diff options
Diffstat (limited to 'Tanja.pm')
-rw-r--r-- | Tanja.pm | 143 |
1 files changed, 143 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 + |