1 | package CFPlus::Protocol; |
1 | package CFPlus::Protocol; |
2 | |
2 | |
3 | use utf8; |
3 | use utf8; |
4 | use strict; |
4 | use strict; |
5 | |
5 | |
6 | use Crossfire::Protocol::Constants; |
6 | use Deliantra::Protocol::Constants; |
7 | |
7 | |
8 | use CFPlus; |
8 | use CFPlus; |
9 | use CFPlus::DB; |
9 | use CFPlus::DB; |
10 | use CFPlus::UI; |
10 | use CFPlus::UI; |
11 | use CFPlus::Pod; |
11 | use CFPlus::Pod; |
12 | use CFPlus::Macro; |
12 | use CFPlus::Macro; |
13 | use CFPlus::Item; |
13 | use CFPlus::Item; |
14 | |
14 | |
15 | use Crossfire::Protocol::Base 0.95; |
|
|
16 | |
|
|
17 | use base 'Crossfire::Protocol::Base'; |
15 | use base 'Deliantra::Protocol::Base'; |
18 | |
16 | |
19 | sub new { |
17 | sub new { |
20 | my ($class, %arg) = @_; |
18 | my ($class, %arg) = @_; |
21 | |
19 | |
22 | my $self = $class->SUPER::new (%arg, |
20 | my $self = $class->SUPER::new (%arg, |
23 | setup_req => { |
21 | setup_req => { |
24 | extmap => 1, |
22 | extmap => 1, |
25 | excmd => 1, |
23 | excmd => 1, |
26 | xwidget1 => 1,#d# |
24 | widget => 1, |
27 | %{$arg{setup_req} || {}}, |
25 | %{$arg{setup_req} || {}}, |
28 | }, |
26 | }, |
29 | ); |
27 | ); |
30 | |
28 | |
31 | $self->{map_widget}->clr_commands; |
29 | $self->{map_widget}->clr_commands; |
… | |
… | |
50 | } sort { $a->{par} <=> $b->{par} } |
48 | } sort { $a->{par} <=> $b->{par} } |
51 | CFPlus::Pod::find command => "*"; |
49 | CFPlus::Pod::find command => "*"; |
52 | |
50 | |
53 | $self->{json_coder} |
51 | $self->{json_coder} |
54 | ->convert_blessed |
52 | ->convert_blessed |
55 | ->filter_json_single_key_object (__w_ => sub { |
53 | ->filter_json_single_key_object ("\fw" => sub { |
56 | $self->{widget}{$_[0]} |
54 | $self->{widget}{$_[0]} |
|
|
55 | }) |
|
|
56 | ->filter_json_single_key_object ("\fc" => sub { |
|
|
57 | my ($id) = @_; |
|
|
58 | sub { |
|
|
59 | $self->send_exti_msg (w_e => $id, @_); |
|
|
60 | } |
57 | }); |
61 | }); |
58 | |
62 | |
59 | # destroy widgets on logout |
63 | # destroy widgets on logout |
60 | $self->{on_stop_game_guard} = $self->{map_widget}{root}->connect (stop_game => sub { |
64 | $self->{on_stop_game_guard} = $self->{map_widget}{root}->connect (stop_game => sub { |
61 | for my $ws (values %{delete $self->{widgetset} || {}}) { |
65 | for my $ws (values %{delete $self->{widgetset} || {}}) { |
… | |
… | |
138 | ############################################################################# |
142 | ############################################################################# |
139 | |
143 | |
140 | sub widget_associate { |
144 | sub widget_associate { |
141 | my ($self, $ws, $id, $widget) = @_; |
145 | my ($self, $ws, $id, $widget) = @_; |
142 | |
146 | |
143 | if ($widget) { |
147 | $widget ||= new CFPlus::UI::Bin; |
|
|
148 | |
144 | $widget->{s_id} = $id; |
149 | $widget->{s_id} = $id; |
145 | $self->{widget}{$id} = $widget; |
150 | $self->{widget}{$id} = $widget; |
146 | |
151 | |
147 | if ($ws) { |
152 | if ($ws) { |
148 | $widget->{s_ws} = $ws; |
153 | $widget->{s_ws} = $ws; |
149 | $self->{widgetset}{$ws}{w}{$id} = $widget; |
154 | $self->{widgetset}{$ws}{w}{$id} = $widget; |
150 | } |
155 | } |
151 | |
156 | |
152 | $widget->connect (on_destroy => sub { |
157 | $widget->connect (on_destroy => sub { |
153 | my ($widget) = @_; |
158 | my ($widget) = @_; |
154 | |
159 | |
155 | delete $self->{widget}{$widget->{s_id}}; |
160 | delete $self->{widget}{$widget->{s_id}}; |
156 | delete $self->{widgetset}{$widget->{s_ws}}{$widget->{s_id}} |
161 | delete $self->{widgetset}{$widget->{s_ws}}{$widget->{s_id}} |
157 | if exists $widget->{s_ws}; |
162 | if exists $widget->{s_ws}; |
158 | }); |
163 | }); |
159 | |
|
|
160 | 1 |
|
|
161 | } else { |
|
|
162 | $self->send_exti_msg (w_e => $id, undef); |
|
|
163 | |
|
|
164 | 0 |
|
|
165 | } |
|
|
166 | } |
164 | } |
167 | |
165 | |
168 | # widgetset new |
166 | # widgetset new |
169 | sub ext_ws_n { |
167 | sub ext_ws_n { |
170 | my ($self, $id) = @_; |
168 | my ($self, $id) = @_; |
… | |
… | |
186 | } |
184 | } |
187 | |
185 | |
188 | # widgetset create |
186 | # widgetset create |
189 | sub ext_ws_c { |
187 | sub ext_ws_c { |
190 | my ($self, $ws, $id, $class, $args) = @_; |
188 | my ($self, $ws, $id, $class, $args) = @_; |
191 | |
|
|
192 | for my $ev (grep /^on_/, keys %$args) { |
|
|
193 | my $rid = $args->{$ev}; |
|
|
194 | $args->{$ev} = sub { |
|
|
195 | my $id = shift->{s_id}; |
|
|
196 | $self->send_exti_msg (w_e => $id, $rid, @_); |
|
|
197 | |
|
|
198 | 1 |
|
|
199 | }; |
|
|
200 | } |
|
|
201 | |
189 | |
202 | $self->widget_associate ( |
190 | $self->widget_associate ( |
203 | $ws, $id => scalar eval { |
191 | $ws, $id => scalar eval { |
204 | local $SIG{__DIE__}; |
192 | local $SIG{__DIE__}; |
205 | "CFPlus::UI::$class"->new (%$args) |
193 | "CFPlus::UI::$class"->new (%$args) |
206 | } |
194 | } |
207 | ) or warn "server failed creating client-side widget " . (CFPlus::to_json $class) . ": $@\n"; |
195 | ); |
208 | } |
196 | } |
209 | |
197 | |
210 | # widgetset associate |
198 | # widgetset associate |
211 | sub ext_ws_a { |
199 | sub ext_ws_a { |
212 | my ($self, %ass) = @_; |
200 | my ($self, %ass) = @_; |
… | |
… | |
248 | invr => $::INVR, |
236 | invr => $::INVR, |
249 | invr_hb => $::INVR_HB, |
237 | invr_hb => $::INVR_HB, |
250 | ); |
238 | ); |
251 | |
239 | |
252 | while (my ($id, $name) = each %ass) { |
240 | while (my ($id, $name) = each %ass) { |
253 | $self->widget_associate (undef, $id => $wkw{$name}) |
241 | $self->widget_associate (undef, $id => $wkw{$name}); |
254 | or warn "server failed to associate non-existent well-known widget $name\n"; |
|
|
255 | } |
242 | } |
256 | } |
243 | } |
257 | |
244 | |
258 | # widget call |
245 | # widget call |
259 | sub ext_w_c { |
246 | sub ext_w_c { |
260 | my ($self, $id, $rid, $method, @args) = @_; |
247 | my ($self, $id, $rcb, $method, @args) = @_; |
261 | |
248 | |
262 | my $w = $self->{widget}{$id} |
249 | my $w = $self->{widget}{$id} |
263 | or return; |
250 | or return; |
264 | |
251 | |
265 | if ($rid) { |
252 | if ($rcb) { |
266 | $self->send_exti_msg (w_r => $rid, $w->$method (@args)); |
253 | $rcb->($w->$method (@args)); |
267 | } else { |
254 | } else { |
268 | $w->$method (@args); |
255 | $w->$method (@args); |
269 | } |
256 | } |
270 | } |
257 | } |
271 | |
258 | |
… | |
… | |
287 | } |
274 | } |
288 | } |
275 | } |
289 | |
276 | |
290 | # widget get |
277 | # widget get |
291 | sub ext_w_g { |
278 | sub ext_w_g { |
292 | my ($self, $id, $rid, $attr) = @_; |
279 | my ($self, $id, $rid, @attr) = @_; |
293 | |
280 | |
294 | my $w = $self->{widget}{$id} |
281 | my $w = $self->{widget}{$id} |
295 | or return; |
282 | or return; |
296 | |
283 | |
297 | $self->send_exti_msg (w_r => $rid, [map $w->{$_}, @$attr]); |
284 | $self->send_exti_msg (w_e => $rid, map $w->{$_}, @attr); |
298 | } |
285 | } |
299 | |
286 | |
300 | # message window |
287 | # message window |
301 | sub ext_channel_info { |
288 | sub ext_channel_info { |
302 | my ($self, $info) = @_; |
289 | my ($self, $info) = @_; |
… | |
… | |
307 | ############################################################################# |
294 | ############################################################################# |
308 | |
295 | |
309 | sub logprint { |
296 | sub logprint { |
310 | my ($self, @a) = @_; |
297 | my ($self, @a) = @_; |
311 | |
298 | |
312 | CFPlus::DB::logprint "$Crossfire::VARDIR/log.$self->{host}" => (join "", @a), sub { }; |
299 | CFPlus::DB::logprint "$Deliantra::VARDIR/log.$self->{host}" => (join "", @a), sub { }; |
313 | } |
300 | } |
314 | |
301 | |
315 | sub _stat_numdiff { |
302 | sub _stat_numdiff { |
316 | my ($self, $name, $old, $new) = @_; |
303 | my ($self, $name, $old, $new) = @_; |
317 | |
304 | |
… | |
… | |
401 | |
388 | |
402 | if ( |
389 | if ( |
403 | my @diffs = map $_->[1]->($self, $_->[2], $prev->{$_->[0]}, $stats->{$_->[0]}), @statchange |
390 | my @diffs = map $_->[1]->($self, $_->[2], $prev->{$_->[0]}, $stats->{$_->[0]}), @statchange |
404 | ) { |
391 | ) { |
405 | my $msg = "<b>stat change</b>: " . (join " ", @diffs); |
392 | my $msg = "<b>stat change</b>: " . (join " ", @diffs); |
406 | $self->{statusbox}->add ($msg, group => "stat $msg", fg => [0.8, 1, 0.2, 1], timeout => 10); |
393 | $self->{statusbox}->add ($msg, group => "stat $msg", fg => [0.8, 1, 0.2, 1], timeout => 20); |
407 | } |
394 | } |
408 | |
395 | |
409 | $self->update_stats_window ($stats, $prev); |
396 | $self->update_stats_window ($stats, $prev); |
410 | |
397 | |
411 | $self->{prev_stats} = { %$stats }; |
398 | $self->{prev_stats} = { %$stats }; |
… | |
… | |
566 | |
553 | |
567 | for (@order) { |
554 | for (@order) { |
568 | my ($idx, $name) = @$_; |
555 | my ($idx, $name) = @$_; |
569 | my $val = $stats->{$idx}; |
556 | my $val = $stats->{$idx}; |
570 | |
557 | |
571 | next if $prev->{$idx}[1] == $val->[1]; |
558 | next if $prev->{$idx}[1] eq $val->[1]; |
572 | |
559 | |
573 | my $sw = $self->{skillwid}{$idx}; |
560 | my $sw = $self->{skillwid}{$idx}; |
574 | $sw->[0]->set_text (::formsep ($val->[1])); |
561 | $sw->[0]->set_text (::formsep ($val->[1])); |
575 | $sw->[1]->set_text ($val->[0] * 1); |
562 | $sw->[1]->set_text ($val->[0] * 1); |
576 | $sw->[2]->set_value (@$val); |
563 | $sw->[2]->set_value (@$val); |
577 | |
564 | |
578 | #$::GAUGES->{sklprg}->set_label ($name); |
565 | $::GAUGES->{sklprg}->set_label ("$name %d%%"); |
579 | $::GAUGES->{sklprg}->set_value (@$val); |
566 | $::GAUGES->{sklprg}->set_value (@$val); |
580 | } |
|
|
581 | } |
|
|
582 | |
|
|
583 | sub macro_send { |
|
|
584 | my ($self, $macro) = @_; |
|
|
585 | |
|
|
586 | for my $cmd (@{ $macro->{action} }) { |
|
|
587 | $self->send_command ($cmd); |
|
|
588 | } |
567 | } |
589 | } |
568 | } |
590 | |
569 | |
591 | sub user_send { |
570 | sub user_send { |
592 | my ($self, $command) = @_; |
571 | my ($self, $command) = @_; |
… | |
… | |
594 | $self->{record}->($command) |
573 | $self->{record}->($command) |
595 | if $self->{record}; |
574 | if $self->{record}; |
596 | |
575 | |
597 | $self->logprint ("send: ", $command); |
576 | $self->logprint ("send: ", $command); |
598 | $self->send_command ($command); |
577 | $self->send_command ($command); |
599 | ::status ($command); |
|
|
600 | } |
578 | } |
601 | |
579 | |
602 | sub record { |
580 | sub record { |
603 | my ($self, $cb) = @_; |
581 | my ($self, $cb) = @_; |
604 | |
582 | |
… | |
… | |
635 | } |
613 | } |
636 | } |
614 | } |
637 | |
615 | |
638 | if ($delay) { |
616 | if ($delay) { |
639 | # delay the map drawing a tiny bit in the hope of getting the missing fetched |
617 | # delay the map drawing a tiny bit in the hope of getting the missing fetched |
640 | Event->timer (after => 0.03, cb => sub { |
618 | EV::once undef, 0, 0.03, sub { |
641 | $_[0]->w->cancel; |
|
|
642 | $self->{map_widget}->update |
619 | $self->{map_widget}->update |
643 | if $self->{map_widget}; |
620 | if $self->{map_widget}; |
644 | }); |
621 | }; |
645 | } else { |
622 | } else { |
646 | $self->{map_widget}->update; |
623 | $self->{map_widget}->update; |
647 | } |
624 | } |
648 | } |
625 | } |
649 | |
626 | |
… | |
… | |
887 | # split metadata case, FT_MUSIC, FT_SOUND |
864 | # split metadata case, FT_MUSIC, FT_SOUND |
888 | if ($changed) { # new data |
865 | if ($changed) { # new data |
889 | my ($meta, $data) = unpack "(w/a*)*", $face->{data}; |
866 | my ($meta, $data) = unpack "(w/a*)*", $face->{data}; |
890 | $face->{data} = $meta; |
867 | $face->{data} = $meta; |
891 | |
868 | |
|
|
869 | # rely on strict ordering here and also on later fetch |
892 | CFPlus::DB::put res_data => $face->{name} => $data, sub { }; |
870 | CFPlus::DB::put res_data => $face->{name} => $data, sub { }; |
893 | CFPlus::DB::put res_meta => $face->{name} => $meta, sub { }; |
871 | CFPlus::DB::put res_meta => $face->{name} => $meta, sub { }; |
894 | } |
872 | } |
895 | |
873 | |
896 | $face->{data} = $self->{json_coder}->decode ($face->{data}); |
874 | $face->{data} = $self->{json_coder}->decode ($face->{data}); |
897 | |
|
|
898 | ::add_license ($face); |
875 | ::add_license ($face); |
|
|
876 | ::message ({ markup => CFPlus::asxml "downloaded resource '$face->{data}{name}', type $face->{type}." }) |
|
|
877 | if $changed; |
899 | |
878 | |
900 | if ($face->{type} == 3) { # FT_MUSIC |
879 | if ($face->{type} == 3) { # FT_MUSIC |
901 | ::message ({ markup => "downloaded song #$facenum" }) |
|
|
902 | if $changed; |
|
|
903 | |
|
|
904 | &::audio_music_push ($facenum); |
880 | &::audio_music_push ($facenum); |
905 | } elsif ($face->{type} == 5) { # FT_SOUND |
881 | } elsif ($face->{type} == 5) { # FT_SOUND |
906 | ::message ({ markup => "downloaded sound #$facenum" }) |
|
|
907 | if $changed; |
|
|
908 | |
|
|
909 | &::audio_sound_push ($facenum); |
882 | &::audio_sound_push ($facenum); |
910 | } |
883 | } |
911 | |
884 | |
912 | } else { |
885 | } else { |
913 | # flat resource case, FT_RSRC |
886 | # flat resource case, FT_RSRC |
… | |
… | |
993 | |
966 | |
994 | sub sanitise_xml($) { |
967 | sub sanitise_xml($) { |
995 | local $_ = shift; |
968 | local $_ = shift; |
996 | |
969 | |
997 | # we now weed out all tags we do not support |
970 | # we now weed out all tags we do not support |
998 | s%<(?!/?i>|/?u>|/?b>|fg |/fg>)%<%g; |
971 | s{ <(?! /?i> | /?u> | /?b> | /?big | /?small | /?s | /?tt | fg\ | /fg>) |
|
|
972 | }{ |
|
|
973 | "<" |
|
|
974 | }gex; |
|
|
975 | |
999 | # now all entities |
976 | # now all entities |
1000 | s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&/g; |
977 | s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&/g; |
1001 | |
978 | |
1002 | # handle some elements |
979 | # handle some elements |
1003 | s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs; |
980 | s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs; |
… | |
… | |
1056 | |
1033 | |
1057 | ## try to create single paragraphs of multiple lines sent by the server |
1034 | ## try to create single paragraphs of multiple lines sent by the server |
1058 | # no longer neecssary with TRT servers |
1035 | # no longer neecssary with TRT servers |
1059 | #$text =~ s/(?<=\S)\n(?=\w)/ /g; |
1036 | #$text =~ s/(?<=\S)\n(?=\w)/ /g; |
1060 | |
1037 | |
|
|
1038 | for (split /\n/, $text) { |
1061 | ::message ({ |
1039 | ::message ({ |
1062 | fg => $fg, |
1040 | fg => $fg, |
1063 | markup => $_, |
1041 | markup => $_, |
1064 | type => $type, |
1042 | type => $type, |
1065 | extra => [@extra], |
1043 | extra => [@extra], |
1066 | color_flags => $color |
1044 | color_flags => $color, #d# ugly, kill |
1067 | }) for split /\n/, $text; |
1045 | }); |
|
|
1046 | |
|
|
1047 | $color &= ~NDI_CLEAR; # only clear once for multiline messages |
|
|
1048 | # actually, this is an ugly design. _we_ should control the channels, |
|
|
1049 | # not some random other widget, as the channels are clearly protocol-specific. |
|
|
1050 | # then we could also react to flags such as CLEAR without resorting to |
|
|
1051 | # hacks such as color_flags, above. |
|
|
1052 | } |
1068 | |
1053 | |
1069 | $self->{statusbox}->add ($text, |
1054 | $self->{statusbox}->add ($text, |
1070 | group => $text, |
1055 | group => $text, |
1071 | fg => $fg, |
1056 | fg => $fg, |
1072 | timeout => $color >= 2 ? 180 : 10, |
1057 | timeout => $color >= 2 ? 180 : 10, |
1073 | tooltip_font => $::FONT_FIXED, |
1058 | tooltip_font => $::FONT_FIXED, |
1074 | ); |
1059 | ) if $type eq "info"; |
1075 | } |
1060 | } |
1076 | } |
1061 | } |
1077 | |
1062 | |
1078 | sub spell_add { |
1063 | sub spell_add { |
1079 | my ($self, $spell) = @_; |
1064 | my ($self, $spell) = @_; |
… | |
… | |
1317 | 0 |
1302 | 0 |
1318 | }); |
1303 | }); |
1319 | |
1304 | |
1320 | $self->update_server_info; |
1305 | $self->update_server_info; |
1321 | |
1306 | |
1322 | $self->send_command ("output-sync $::CFG->{output_sync}"); |
|
|
1323 | $self->send_command ("output-count $::CFG->{output_count}"); |
|
|
1324 | $self->send_command ("output-rate $::CFG->{output_rate}") if $::CFG->{output_rate} > 0; |
1307 | $self->send_command ("output-rate $::CFG->{output_rate}") if $::CFG->{output_rate} > 0; |
1325 | $self->send_command ("pickup $::CFG->{pickup}"); |
1308 | $self->send_command ("pickup $::CFG->{pickup}"); |
1326 | } |
1309 | } |
1327 | |
1310 | |
1328 | sub lookat { |
1311 | sub lookat { |