| … | |
… | |
| 110 | |
110 | |
| 111 | Create a new C<Net::Knuddels::Protocol> object. |
111 | Create a new C<Net::Knuddels::Protocol> object. |
| 112 | |
112 | |
| 113 | =cut |
113 | =cut |
| 114 | |
114 | |
|
|
115 | sub handle_room { |
|
|
116 | my ($self, $room) = @_; |
|
|
117 | |
|
|
118 | if ($room eq "-") { |
|
|
119 | if (defined $self->{only_room}) { |
|
|
120 | return $self->{only_room}; |
|
|
121 | } else { |
|
|
122 | warn "Couldn't assign '-' room to a room!"; |
|
|
123 | return '-'; |
|
|
124 | } |
|
|
125 | } else { |
|
|
126 | return $room; |
|
|
127 | } |
|
|
128 | } |
|
|
129 | |
|
|
130 | sub calc_user_stats { |
|
|
131 | my ($self, $user) = @_; |
|
|
132 | |
|
|
133 | if ($user->{name} =~ s/\cJ(\d+)$//) { |
|
|
134 | $user->{age} = $1 |
|
|
135 | } |
|
|
136 | |
|
|
137 | if ($user->{picture} =~ m/\bmale/) { |
|
|
138 | $user->{gender} = 'm'; |
|
|
139 | } elsif ($user->{picture} =~ m/female/) { |
|
|
140 | $user->{gender} = 'f'; |
|
|
141 | } |
|
|
142 | return $user; |
|
|
143 | } |
|
|
144 | |
| 115 | sub new { |
145 | sub new { |
| 116 | my $class = shift; |
146 | my $class = shift; |
| 117 | |
147 | |
| 118 | my %data; |
148 | my %data; |
| 119 | |
149 | |
| … | |
… | |
| 125 | $self->{login_challenge} = $_[0]; |
155 | $self->{login_challenge} = $_[0]; |
| 126 | $self->{login_room} = $_[1]; |
156 | $self->{login_room} = $_[1]; |
| 127 | $self->feed_event ("login"); |
157 | $self->feed_event ("login"); |
| 128 | }); |
158 | }); |
| 129 | $self->register (r => sub { |
159 | $self->register (r => sub { |
| 130 | # TODO $room eq "-" |
|
|
| 131 | $self->feed_event (msg_priv => $_[2], $_[0], $_[1], $_[3]); |
160 | $self->feed_event (msg_priv => $self->handle_room ($_[2]), $_[0], $_[1], $_[3]); |
| 132 | }); |
161 | }); |
| 133 | $self->register (e => sub { |
162 | $self->register (e => sub { |
| 134 | # TODO $room eq "-" |
|
|
| 135 | $self->feed_event (msg_room => $_[1], $_[0], $_[2]); |
163 | $self->feed_event (msg_room => $self->handle_room ($_[1]), $_[0], $_[2]); |
|
|
164 | }); |
|
|
165 | $self->register (l => sub { |
|
|
166 | my $room = $self->handle_room ($_[0]); |
|
|
167 | return if $room eq "-"; # things that shouln't happen |
|
|
168 | |
|
|
169 | my $user = { |
|
|
170 | name => $_[1], |
|
|
171 | flag => $_[2], |
|
|
172 | color => $_[3], |
|
|
173 | picture => $_[4] |
|
|
174 | }; |
|
|
175 | |
|
|
176 | $self->calc_user_stats ($user); |
|
|
177 | |
|
|
178 | my $rl = $self->{user_lists}->{lc $room}->{lc $user->{name}} = $user; |
|
|
179 | |
|
|
180 | $self->feed_event (join_room => $room, $user); |
|
|
181 | }); |
|
|
182 | $self->register (w => sub { |
|
|
183 | my $room = $self->handle_room ($_[1]); |
|
|
184 | return if $room eq "-"; # things that shouln't happen |
|
|
185 | |
|
|
186 | my $username = $_[0]; |
|
|
187 | |
|
|
188 | my $u = delete $self->{user_lists}->{lc $room}->{lc $username}; |
|
|
189 | |
|
|
190 | if (not defined $u) { |
|
|
191 | warn "User $username wasn't in room $room, trying to fix... but be careful!!!\n"; |
|
|
192 | $u = { name => $username }; |
|
|
193 | } |
|
|
194 | |
|
|
195 | $self->feed_event (part_room => $room, $u); |
|
|
196 | }); |
|
|
197 | $self->register (a => sub { |
|
|
198 | # the only_room stuff is from java-code, which has naughy semantics |
|
|
199 | if (not defined $self->{only_room}) { |
|
|
200 | $self->{only_room} = $_[0]; |
|
|
201 | } else { |
|
|
202 | $self->{only_room} = "-"; |
|
|
203 | } |
|
|
204 | |
|
|
205 | $self->{my_nick} = $_[1]; # i'm really _not_ shure about this |
|
|
206 | |
|
|
207 | my $ri = $self->{room}->{lc $_[0]} = { |
|
|
208 | picture => $_[7], |
|
|
209 | }; |
|
|
210 | |
|
|
211 | $self->feed_event (room_info => $_[0], $ri); |
|
|
212 | }); |
|
|
213 | $self->register (u => sub { |
|
|
214 | my $room = shift; |
|
|
215 | my $rl = $self->{user_lists}->{lc $room} = {}; |
|
|
216 | my $cur_u = {}; |
|
|
217 | |
|
|
218 | while (@_) { |
|
|
219 | $cur_u->{name} = shift; |
|
|
220 | $cur_u->{flag} = shift; |
|
|
221 | $cur_u->{color} = shift; |
|
|
222 | |
|
|
223 | my $i = 0; |
|
|
224 | |
|
|
225 | while ((my $nxt = shift) ne "-") { |
|
|
226 | if ($i == 0) { |
|
|
227 | $cur_u->{picture} = $nxt; |
|
|
228 | } |
|
|
229 | $i++; |
|
|
230 | } |
|
|
231 | |
|
|
232 | $self->calc_user_stats ($cur_u); |
|
|
233 | $rl->{lc $cur_u->{name}} = $cur_u; |
|
|
234 | $cur_u = {}; |
|
|
235 | } |
|
|
236 | $self->feed_event (user_list => $room, $rl); |
| 136 | }); |
237 | }); |
| 137 | |
238 | |
| 138 | $self; |
239 | $self; |
| 139 | } |
240 | } |
| 140 | |
241 | |
| … | |
… | |
| 238 | produced when a public message is uttered :) |
339 | produced when a public message is uttered :) |
| 239 | |
340 | |
| 240 | msg_room => $room, $src, $dst, $msg |
341 | msg_room => $room, $src, $dst, $msg |
| 241 | personal message from $src to $dst |
342 | personal message from $src to $dst |
| 242 | |
343 | |
|
|
344 | user_list => $room, $list |
|
|
345 | the userlist of a channel named $room, a elmement of the list (a user) |
|
|
346 | looks like: |
|
|
347 | { |
|
|
348 | name => <name>, |
|
|
349 | flag => <some flag i don't know what it means>, |
|
|
350 | color => like /\d+.\d+.\d+/, |
|
|
351 | age => /\d+/, |
|
|
352 | gender => /(f|m)/, |
|
|
353 | picture => <the picture file to put behind the nick> |
|
|
354 | } |
|
|
355 | |
|
|
356 | room_info => $room, $room_info |
|
|
357 | some information about the $room: |
|
|
358 | $room_info = |
|
|
359 | { |
|
|
360 | picture => <some picturefile> |
|
|
361 | } |
|
|
362 | |
|
|
363 | join_room => $room, $user |
|
|
364 | join message of $user joined the room $room |
|
|
365 | $user contains the user structure (see user_list). |
|
|
366 | |
|
|
367 | part_room => $room, $user |
|
|
368 | part message of $user who left the room $room |
|
|
369 | $user contains the user structure (see user_list). |
| 243 | =cut |
370 | =cut |
| 244 | |
371 | |
| 245 | sub register { |
372 | sub register { |
| 246 | my ($self, $type, $cb) = @_; |
373 | my ($self, $type, $cb) = @_; |
| 247 | |
374 | |
