summaryrefslogtreecommitdiff
path: root/Tanja.pm
blob: d62a30d2e3d8e55b738109f62c4ca8636f9bd325 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
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->([tuple] or ())
# TODO: Some way to indicate that the session isn't interested in replies anymore?
sub send {
	my($s, $t, $cb) = @_;
	my $ret = Tanja::ReturnPath->_new($cb);
	for my $reg (grep Tanja::match($_->[0], $t), values %{$s->{pat}}) {
		AnyEvent::postpone {
			$reg->[1]->($t, $ret);
		}
	}
}


sub _register {
	my($s, $pat, $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, $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 ], callback
#   Returns: $id, for use with unreg()
# Callback:
#   Args: [ tuple ], $return_path
sub reg {
	my($s, $pat, $cb) = @_;
	my $id;
	$id = $s->{server}->_register($pat, sub { $s->{pat}{$id} && $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, $cb) = @_;
	my $id;
	$id = $s->reg($pat, 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} = {};
}


package Tanja::ReturnPath;

use strict;
use warnings;
use AnyEvent;

sub _new {
	my($own, $cb) = @_;
	return bless \$cb, $own;
}

sub null {
	my $cb = shift;
	return !$$cb;
}

sub reply {
	my($cb, $t) = @_;
	$$cb && AnyEvent::postpone { $$cb->($t); };
}

sub DESTROY {
	my $cb = shift;
	my $c = $$cb;
	$c && AnyEvent::postpone { $c->() };
	undef $$cb;
}

1;

# vim:noet:sw=4:ts=4