| … | |
… | |
| 31 | |
31 | |
| 32 | use base "Exporter"; |
32 | use base "Exporter"; |
| 33 | |
33 | |
| 34 | our $VERSION = '0.01'; |
34 | our $VERSION = '0.01'; |
| 35 | our @EXPORT = qw( |
35 | our @EXPORT = qw( |
|
|
36 | %NODE %PORT %PORT_DATA %REG $UNIQ $ID add_node |
|
|
37 | |
| 36 | NODE $NODE snd kil _any_ |
38 | NODE $NODE node_of snd kil _any_ |
| 37 | become_slave become_public |
39 | become_slave become_public |
| 38 | ); |
40 | ); |
| 39 | |
41 | |
| 40 | our $DEFAULT_SECRET; |
42 | our $DEFAULT_SECRET; |
| 41 | |
43 | |
| … | |
… | |
| 50 | The default simply logs the message to STDERR. |
52 | The default simply logs the message to STDERR. |
| 51 | |
53 | |
| 52 | =cut |
54 | =cut |
| 53 | |
55 | |
| 54 | our $WARN = sub { |
56 | our $WARN = sub { |
|
|
57 | my $msg = $_[0]; |
|
|
58 | $msg =~ s/\n$//; |
| 55 | warn "$_[0]\n"; |
59 | warn "$msg\n"; |
| 56 | }; |
60 | }; |
| 57 | |
61 | |
| 58 | sub nonce($) { |
62 | sub nonce($) { |
| 59 | my $nonce; |
63 | my $nonce; |
| 60 | |
64 | |
| … | |
… | |
| 94 | |
98 | |
| 95 | our $UNIQ = gen_uniq; # per-process/node unique cookie |
99 | our $UNIQ = gen_uniq; # per-process/node unique cookie |
| 96 | our $ID = "a"; |
100 | our $ID = "a"; |
| 97 | our $PUBLIC = 0; |
101 | our $PUBLIC = 0; |
| 98 | our $NODE = $$; |
102 | our $NODE = $$; |
| 99 | our $PORT; |
|
|
| 100 | |
103 | |
| 101 | our %NODE; # node id to transport mapping, or "undef", for local node |
104 | our %NODE; # node id to transport mapping, or "undef", for local node |
| 102 | our %PORT; # local ports |
105 | our (%PORT, %PORT_DATA); # local ports |
| 103 | |
106 | |
| 104 | our %RMON; # local ports monitored by remote nodes ($RMON{noderef}{portid} == cb) |
107 | our %RMON; # local ports monitored by remote nodes ($RMON{noderef}{portid} == cb) |
| 105 | our %LMON; # monitored _local_ ports |
108 | our %LMON; # monitored _local_ ports |
| 106 | |
109 | |
| 107 | our %WKP; |
110 | our %REG; # registered port names |
| 108 | our %LISTENER; # local transports |
111 | |
|
|
112 | our %LISTENER; |
| 109 | |
113 | |
| 110 | our $SRCNODE; # holds the sending node during _inject |
114 | our $SRCNODE; # holds the sending node during _inject |
| 111 | |
115 | |
| 112 | sub NODE() { $NODE } |
116 | sub NODE() { |
|
|
117 | $NODE |
|
|
118 | } |
|
|
119 | |
|
|
120 | sub node_of($) { |
|
|
121 | my ($noderef, undef) = split /#/, $_[0], 2; |
|
|
122 | |
|
|
123 | $noderef |
|
|
124 | } |
| 113 | |
125 | |
| 114 | sub _ANY_() { 1 } |
126 | sub _ANY_() { 1 } |
| 115 | sub _any_() { \&_ANY_ } |
127 | sub _any_() { \&_ANY_ } |
| 116 | |
128 | |
| 117 | sub _inject { |
129 | sub _inject { |
| … | |
… | |
| 143 | |
155 | |
| 144 | ($NODE{$noderef} || add_node $noderef) |
156 | ($NODE{$noderef} || add_node $noderef) |
| 145 | ->send ([$port, @_]); |
157 | ->send ([$port, @_]); |
| 146 | } |
158 | } |
| 147 | |
159 | |
| 148 | sub kil($) { |
160 | sub kil(@) { |
| 149 | my ($noderef, $port) = split /#/, shift, 2; |
161 | my ($noderef, $port) = split /#/, shift, 2; |
| 150 | |
162 | |
| 151 | ($NODE{$noderef} || add_node $noderef) |
163 | ($NODE{$noderef} || add_node $noderef) |
| 152 | ->kill ($port, @_); |
164 | ->kill ($port, @_); |
| 153 | } |
165 | } |
| … | |
… | |
| 192 | }, |
204 | }, |
| 193 | mon1 => sub { # enable monitoring |
205 | mon1 => sub { # enable monitoring |
| 194 | my $portid = shift; |
206 | my $portid = shift; |
| 195 | my $node = $SRCNODE; |
207 | my $node = $SRCNODE; |
| 196 | $NODE{""}->monitor ($portid, $node->{rmon}{$portid} = sub { |
208 | $NODE{""}->monitor ($portid, $node->{rmon}{$portid} = sub { |
| 197 | $node->send (["", kil => $portid]); |
209 | $node->send (["", kil => $portid, @_]); |
| 198 | }); |
210 | }); |
| 199 | }, |
211 | }, |
| 200 | kil => sub { |
212 | kil => sub { |
| 201 | my $cbs = delete $SRCNODE->{lmon}{$_[0]} |
213 | my $cbs = delete $SRCNODE->{lmon}{+shift} |
| 202 | or return; |
214 | or return; |
| 203 | |
215 | |
| 204 | $_->() for @$cbs; |
216 | $_->(@_) for @$cbs; |
| 205 | }, |
217 | }, |
| 206 | |
218 | |
| 207 | # well-known-port lookup |
219 | # well-known-port lookup |
| 208 | wkp => sub { |
220 | lookup => sub { |
| 209 | my $wkname = shift; |
221 | my $name = shift; |
| 210 | snd @_, $WKP{$wkname}; |
222 | my $port = $REG{$name}; |
|
|
223 | #TODO: check vailidity |
|
|
224 | snd @_, $port; |
| 211 | }, |
225 | }, |
| 212 | |
226 | |
| 213 | # relay message to another node / generic echo |
227 | # relay message to another node / generic echo |
| 214 | relay => sub { |
228 | relay => sub { |
| 215 | &snd; |
229 | &snd; |
