… | |
… | |
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 'Crossfire::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 | xwidget2 => 1,#d# |
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) = @_; |
… | |
… | |
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 }; |
… | |
… | |
478 | for keys %RES_TBL; |
465 | for keys %RES_TBL; |
479 | |
466 | |
480 | my $sktbl = $::STATWIDS->{skill_tbl}; |
467 | my $sktbl = $::STATWIDS->{skill_tbl}; |
481 | my @skills = keys %{ $self->{skill_info} }; |
468 | my @skills = keys %{ $self->{skill_info} }; |
482 | |
469 | |
483 | if (grep +(exists $stats->{$_}) != (exists $prev->{$_}), @skills) { |
470 | my @order = sort { $stats->{$b->[0]}[1] <=> $stats->{$a->[0]}[1] or $a->[1] cmp $b->[1] } |
|
|
471 | map [$_, $self->{skill_info}{$_}], |
|
|
472 | grep exists $stats->{$_}, |
|
|
473 | @skills; |
|
|
474 | |
|
|
475 | if ($self->{stat_order} ne join ",", map $_->[0], @order) { |
|
|
476 | $self->{stat_order} = join ",", map $_->[0], @order; |
|
|
477 | |
484 | $sktbl->clear; |
478 | $sktbl->clear; |
485 | |
479 | |
486 | my $sw = $self->{skillwid}{""} ||= [ |
480 | my $sw = $self->{skillwid}{""} ||= [ |
487 | 0, 0, (new CFPlus::UI::Label text => "Experience", align => 1), |
481 | 0, 0, (new CFPlus::UI::Label text => "Experience", align => 1), |
488 | 1, 0, (new CFPlus::UI::Label text => "Lvl.", align => 1), |
482 | 1, 0, (new CFPlus::UI::Label text => "Lvl.", align => 1), |
… | |
… | |
500 | |
494 | |
501 | my @TOOLTIP_LVL = (tooltip => "<b>Level</b>. The level of the skill.$TOOLTIP_ALL", can_events => 1, can_hover => 1); |
495 | my @TOOLTIP_LVL = (tooltip => "<b>Level</b>. The level of the skill.$TOOLTIP_ALL", can_events => 1, can_hover => 1); |
502 | my @TOOLTIP_EXP = (tooltip => "<b>Experience</b>. The experience points you have in this skill.$TOOLTIP_ALL", can_events => 1, can_hover => 1); |
496 | my @TOOLTIP_EXP = (tooltip => "<b>Experience</b>. The experience points you have in this skill.$TOOLTIP_ALL", can_events => 1, can_hover => 1); |
503 | |
497 | |
504 | my ($x, $y) = (0, 1); |
498 | my ($x, $y) = (0, 1); |
505 | for ( |
499 | for (@order) { |
506 | sort { $stats->{$b->[0]}[1] <=> $stats->{$a->[0]}[1] or $a->[1] cmp $b->[1] } |
|
|
507 | map [$_, $self->{skill_info}{$_}], |
|
|
508 | grep exists $stats->{$_}, |
|
|
509 | @skills |
|
|
510 | ) { |
|
|
511 | my ($idx, $name) = @$_; |
500 | my ($idx, $name) = @$_; |
512 | |
501 | |
513 | my $spell_cb = sub { |
502 | my $spell_cb = sub { |
514 | my ($widget, $ev) = @_; |
503 | my ($widget, $ev) = @_; |
515 | |
504 | |
… | |
… | |
560 | } |
549 | } |
561 | |
550 | |
562 | $sktbl->add_at (@add); |
551 | $sktbl->add_at (@add); |
563 | } |
552 | } |
564 | |
553 | |
565 | for (grep exists $stats->{$_}, @skills) { |
554 | for (@order) { |
|
|
555 | my ($idx, $name) = @$_; |
|
|
556 | my $val = $stats->{$idx}; |
|
|
557 | |
|
|
558 | next if $prev->{$idx}[1] eq $val->[1]; |
|
|
559 | |
566 | my $sw = $self->{skillwid}{$_}; |
560 | my $sw = $self->{skillwid}{$idx}; |
567 | $sw->[0]->set_text (::formsep ($stats->{$_}[1])); |
561 | $sw->[0]->set_text (::formsep ($val->[1])); |
568 | $sw->[1]->set_text ($stats->{$_}[0] * 1); |
562 | $sw->[1]->set_text ($val->[0] * 1); |
569 | $sw->[2]->set_value (@{$stats->{$_}}); |
563 | $sw->[2]->set_value (@$val); |
570 | } |
|
|
571 | } |
|
|
572 | |
564 | |
573 | sub macro_send { |
565 | $::GAUGES->{sklprg}->set_label ("$name %d%%"); |
574 | my ($self, $macro) = @_; |
566 | $::GAUGES->{sklprg}->set_value (@$val); |
575 | |
|
|
576 | for my $cmd (@{ $macro->{action} }) { |
|
|
577 | $self->send_command ($cmd); |
|
|
578 | } |
567 | } |
579 | } |
568 | } |
580 | |
569 | |
581 | sub user_send { |
570 | sub user_send { |
582 | my ($self, $command) = @_; |
571 | my ($self, $command) = @_; |
… | |
… | |
584 | $self->{record}->($command) |
573 | $self->{record}->($command) |
585 | if $self->{record}; |
574 | if $self->{record}; |
586 | |
575 | |
587 | $self->logprint ("send: ", $command); |
576 | $self->logprint ("send: ", $command); |
588 | $self->send_command ($command); |
577 | $self->send_command ($command); |
589 | ::status ($command); |
|
|
590 | } |
578 | } |
591 | |
579 | |
592 | sub record { |
580 | sub record { |
593 | my ($self, $cb) = @_; |
581 | my ($self, $cb) = @_; |
594 | |
582 | |
… | |
… | |
877 | # split metadata case, FT_MUSIC, FT_SOUND |
865 | # split metadata case, FT_MUSIC, FT_SOUND |
878 | if ($changed) { # new data |
866 | if ($changed) { # new data |
879 | my ($meta, $data) = unpack "(w/a*)*", $face->{data}; |
867 | my ($meta, $data) = unpack "(w/a*)*", $face->{data}; |
880 | $face->{data} = $meta; |
868 | $face->{data} = $meta; |
881 | |
869 | |
|
|
870 | # rely on strict ordering here and also on later fetch |
882 | CFPlus::DB::put res_data => $face->{name} => $data, sub { }; |
871 | CFPlus::DB::put res_data => $face->{name} => $data, sub { }; |
883 | CFPlus::DB::put res_meta => $face->{name} => $meta, sub { }; |
872 | CFPlus::DB::put res_meta => $face->{name} => $meta, sub { }; |
884 | } |
873 | } |
885 | |
874 | |
886 | $face->{data} = $self->{json_coder}->decode ($face->{data}); |
875 | $face->{data} = $self->{json_coder}->decode ($face->{data}); |
887 | |
|
|
888 | ::add_license ($face); |
876 | ::add_license ($face); |
|
|
877 | ::message ({ markup => CFPlus::asxml "downloaded resource '$face->{data}{name}', type $face->{type}." }) |
|
|
878 | if $changed; |
889 | |
879 | |
890 | if ($face->{type} == 3) { # FT_MUSIC |
880 | if ($face->{type} == 3) { # FT_MUSIC |
891 | ::message ({ markup => "downloaded song #$facenum" }) |
|
|
892 | if $changed; |
|
|
893 | |
|
|
894 | &::audio_music_push ($facenum); |
881 | &::audio_music_push ($facenum); |
895 | } elsif ($face->{type} == 5) { # FT_SOUND |
882 | } elsif ($face->{type} == 5) { # FT_SOUND |
896 | ::message ({ markup => "downloaded sound #$facenum" }) |
|
|
897 | if $changed; |
|
|
898 | |
|
|
899 | &::audio_sound_push ($facenum); |
883 | &::audio_sound_push ($facenum); |
900 | } |
884 | } |
901 | |
885 | |
902 | } else { |
886 | } else { |
903 | # flat resource case, FT_RSRC |
887 | # flat resource case, FT_RSRC |
… | |
… | |
983 | |
967 | |
984 | sub sanitise_xml($) { |
968 | sub sanitise_xml($) { |
985 | local $_ = shift; |
969 | local $_ = shift; |
986 | |
970 | |
987 | # we now weed out all tags we do not support |
971 | # we now weed out all tags we do not support |
988 | s%<(?!/?i>|/?u>|/?b>|fg |/fg>)%<%g; |
972 | s{ <(?! /?i> | /?u> | /?b> | /?big | /?small | /?s | /?tt | fg\ | /fg>) |
|
|
973 | }{ |
|
|
974 | "<" |
|
|
975 | }gex; |
|
|
976 | |
989 | # now all entities |
977 | # now all entities |
990 | s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&/g; |
978 | s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&/g; |
991 | |
979 | |
992 | # handle some elements |
980 | # handle some elements |
993 | s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs; |
981 | s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs; |
… | |
… | |
1046 | |
1034 | |
1047 | ## try to create single paragraphs of multiple lines sent by the server |
1035 | ## try to create single paragraphs of multiple lines sent by the server |
1048 | # no longer neecssary with TRT servers |
1036 | # no longer neecssary with TRT servers |
1049 | #$text =~ s/(?<=\S)\n(?=\w)/ /g; |
1037 | #$text =~ s/(?<=\S)\n(?=\w)/ /g; |
1050 | |
1038 | |
|
|
1039 | for (split /\n/, $text) { |
1051 | ::message ({ |
1040 | ::message ({ |
1052 | fg => $fg, |
1041 | fg => $fg, |
1053 | markup => $_, |
1042 | markup => $_, |
1054 | type => $type, |
1043 | type => $type, |
1055 | extra => [@extra], |
1044 | extra => [@extra], |
1056 | color_flags => $color |
1045 | color_flags => $color, #d# ugly, kill |
1057 | }) for split /\n/, $text; |
1046 | }); |
|
|
1047 | |
|
|
1048 | $color &= ~NDI_CLEAR; # only clear once for multiline messages |
|
|
1049 | # actually, this is an ugly design. _we_ should control the channels, |
|
|
1050 | # not some random other widget, as the channels are clearly protocol-specific. |
|
|
1051 | # then we could also react to flags such as CLEAR without resorting to |
|
|
1052 | # hacks such as color_flags, above. |
|
|
1053 | } |
1058 | |
1054 | |
1059 | $self->{statusbox}->add ($text, |
1055 | $self->{statusbox}->add ($text, |
1060 | group => $text, |
1056 | group => $text, |
1061 | fg => $fg, |
1057 | fg => $fg, |
1062 | timeout => $color >= 2 ? 180 : 10, |
1058 | timeout => $color >= 2 ? 180 : 10, |
1063 | tooltip_font => $::FONT_FIXED, |
1059 | tooltip_font => $::FONT_FIXED, |
1064 | ); |
1060 | ) if $type eq "info"; |
1065 | } |
1061 | } |
1066 | } |
1062 | } |
1067 | |
1063 | |
1068 | sub spell_add { |
1064 | sub spell_add { |
1069 | my ($self, $spell) = @_; |
1065 | my ($self, $spell) = @_; |