ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/Protocol.pm
Revision: 1.169
Committed: Sat Sep 1 07:22:21 2007 UTC (16 years, 9 months ago) by root
Branch: MAIN
Changes since 1.168: +28 -39 lines
Log Message:
simpler, more powerful and slightly less compact widget protocol

File Contents

# User Rev Content
1 root 1.69 package CFPlus::Protocol;
2 root 1.1
3     use utf8;
4     use strict;
5    
6 root 1.2 use Crossfire::Protocol::Constants;
7    
8 root 1.69 use CFPlus;
9 root 1.96 use CFPlus::DB;
10 root 1.69 use CFPlus::UI;
11     use CFPlus::Pod;
12 root 1.91 use CFPlus::Macro;
13     use CFPlus::Item;
14 root 1.1
15 root 1.87 use Crossfire::Protocol::Base 0.95;
16    
17 root 1.1 use base 'Crossfire::Protocol::Base';
18    
19     sub new {
20 root 1.101 my ($class, %arg) = @_;
21 root 1.1
22 root 1.101 my $self = $class->SUPER::new (%arg,
23 root 1.99 setup_req => {
24 root 1.101 extmap => 1,
25 root 1.103 excmd => 1,
26 root 1.169 xwidget2 => 1,#d#
27 root 1.101 %{$arg{setup_req} || {}},
28 root 1.99 },
29     );
30 root 1.1
31     $self->{map_widget}->clr_commands;
32    
33 root 1.72 my @cmd_help = map {
34     $_->{kw}[0] =~ /^(\S+) (?:\s+ \( ([^\)]*) \) )?/x
35     or die "unparseable command help: $_->{kw}[0]";
36    
37     my $cmd = $1;
38     my @args = split /\|/, $2;
39     @args = (".*") unless @args;
40    
41     my (undef, @par) = CFPlus::Pod::section_of $_;
42     my $text = CFPlus::Pod::as_label @par;
43    
44     $_ = $_ eq ".*" ? "" : " $_"
45     for @args;
46    
47     map ["$cmd$_", $text],
48     sort { (length $a) <=> (length $b) }
49     @args
50 root 1.96 } sort { $a->{par} <=> $b->{par} }
51     CFPlus::Pod::find command => "*";
52 root 1.1
53 root 1.111 $self->{json_coder}
54     ->convert_blessed
55 root 1.169 ->filter_json_single_key_object ("\fw" => sub {
56 root 1.111 $self->{widget}{$_[0]}
57 root 1.169 })
58     ->filter_json_single_key_object ("\fc" => sub {
59     my ($id) = @_;
60     sub {
61     $self->send_exti_msg (w_e => $id, @_);
62     }
63 root 1.111 });
64    
65 root 1.123 # destroy widgets on logout
66 root 1.109 $self->{on_stop_game_guard} = $self->{map_widget}{root}->connect (stop_game => sub {
67     for my $ws (values %{delete $self->{widgetset} || {}}) {
68     $_->destroy
69     for values %{delete $ws->{w} || {}};
70     }
71     });
72    
73 root 1.96 $self->{map_widget}->add_command (@$_)
74     for @cmd_help;
75 root 1.1
76 root 1.83 {
77     $self->{dialogue} = my $tex = new_from_file CFPlus::Texture
78     CFPlus::find_rcfile "dialogue.png", minify => 1, mipmap => 1;
79     $self->{map}->set_texture (1, @$tex{qw(name w h s t)}, @{$tex->{minified}});
80     }
81    
82 root 1.96 {
83     $self->{noface} = my $tex = new_from_file CFPlus::Texture
84     CFPlus::find_rcfile "noface.png", minify => 1, mipmap => 1;
85     $self->{map}->set_texture (2, @$tex{qw(name w h s t)}, @{$tex->{minified}});
86     }
87    
88 root 1.1 $self->{open_container} = 0;
89    
90     # per server
91 root 1.96 $self->{mapcache} = "mapcache_$self->{host}_$self->{port}";
92 root 1.1
93     $self
94     }
95    
96 root 1.159 sub update_fx_want {
97     my ($self) = @_;
98    
99     $self->send_exti_msg (fx_want => {
100     3 => !!$::CFG->{bgm_enable}, # FT_MUSIC
101     5 => !!$::CFG->{audio_enable}, # FT_SOUND
102     6 => 1, # FT_RSRC
103     });
104     }
105    
106     sub ext_capabilities {
107     my ($self, %cap) = @_;
108    
109     #$self->send ("setup sound 0"); # we use a different protocol
110     $self->update_fx_want;
111    
112     $self->send_exti_req (resource => "exp_table", sub {
113     my ($exp_table) = @_;
114    
115     $self->register_face_handler ($exp_table, sub {
116     my ($face) = @_;
117    
118     $self->{exp_table} = $self->{json_coder}->decode (delete $face->{data});
119     $_->() for values %{ $self->{on_exp_update} || {} };
120     });
121    
122     ()
123     });
124    
125     if (my $ts = $cap{tileset}) {
126     if (my ($default) = grep $_->[2] & 1, @$ts) {
127     $self->{tileset} = $default;
128     $self->{tilesize} = $default->[3];
129     $self->setup_req (tileset => $default->[0]);
130    
131     my $w = int $self->{mapw} * 32 / $self->{tilesize};
132     my $h = int $self->{maph} * 32 / $self->{tilesize};
133    
134     $self->setup_req (mapsize => "${w}x${h}");
135     }
136     }
137     }
138    
139     sub ext_ambient_music {
140     my ($self, $songs) = @_;
141     &::audio_music_set_ambient ($songs);
142     }
143    
144     #############################################################################
145    
146 root 1.155 sub widget_associate {
147     my ($self, $ws, $id, $widget) = @_;
148    
149 root 1.169 $widget ||= new CFPlus::UI::Bin;
150 root 1.155
151 root 1.169 $widget->{s_id} = $id;
152     $self->{widget}{$id} = $widget;
153 root 1.155
154 root 1.169 if ($ws) {
155     $widget->{s_ws} = $ws;
156     $self->{widgetset}{$ws}{w}{$id} = $widget;
157     }
158 root 1.155
159 root 1.169 $widget->connect (on_destroy => sub {
160     my ($widget) = @_;
161 root 1.155
162 root 1.169 delete $self->{widget}{$widget->{s_id}};
163     delete $self->{widgetset}{$widget->{s_ws}}{$widget->{s_id}}
164     if exists $widget->{s_ws};
165     });
166 root 1.155 }
167    
168 root 1.159 # widgetset new
169     sub ext_ws_n {
170 root 1.160 my ($self, $id) = @_;
171 root 1.159
172     $self->{widgetset}{$id} = {
173     w => {},
174     };
175     }
176    
177     # widgetset destroy
178     sub ext_ws_d {
179 root 1.160 my ($self, $id) = @_;
180 root 1.159
181     my $ws = delete $self->{widgetset}{$id}
182     or return;
183    
184     $_->destroy
185     for values %{$ws->{w}};
186     }
187    
188     # widgetset create
189 root 1.160 sub ext_ws_c {
190     my ($self, $ws, $id, $class, $args) = @_;
191 root 1.159
192     $self->widget_associate (
193     $ws, $id => scalar eval {
194     local $SIG{__DIE__};
195     "CFPlus::UI::$class"->new (%$args)
196     }
197 root 1.169 );
198 root 1.159 }
199    
200     # widgetset associate
201     sub ext_ws_a {
202 root 1.160 my ($self, %ass) = @_;
203 root 1.159
204     # everything that has a name, wether conceivably useful or not
205     my %wkw = (
206     root => $CFPlus::UI::ROOT,
207     tooltip => $CFPlus::UI::TOOLTIP,
208    
209     mapwidget => $::MAPWIDGET,
210     buttonbar => $::BUTTONBAR,
211     metaserver => $::METASERVER,
212     buttonbar => $::BUTTONBAR,
213     login_button => $::LOGIN_BUTTON,
214     quit_dialog => $::QUIT_DIALOG,
215     host_entry => $::HOST_ENTRY,
216     metaserver => $::METASERVER,
217     server_info => $::SERVER_INFO,
218    
219     setup_dialog => $::SETUP_DIALOG,
220     setup_notebook => $::SETUP_NOTEBOOK,
221     setup_server => $::SETUP_SERVER,
222     setup_keyboard => $::SETUP_KEYBOARD,
223    
224     pl_notebook => $::PL_NOTEBOOK,
225     pl_window => $::PL_WINDOW,
226     inventory_page => $::INVENTORY_PAGE,
227     stats_page => $::STATS_PAGE,
228     skill_page => $::SKILL_PAGE,
229     spell_page => $::SPELL_PAGE,
230     spell_list => $::SPELL_LIST,
231    
232     floorbox => $::FLOORBOX,
233     help_window => $::HELP_WINDOW,
234     message_window => $::MESSAGE_WINDOW,
235     statusbox => $::SDTATUSBOX,
236    
237     inv => $::INV,
238     invr => $::INVR,
239     invr_hb => $::INVR_HB,
240     );
241    
242     while (my ($id, $name) = each %ass) {
243 root 1.169 $self->widget_associate (undef, $id => $wkw{$name});
244 root 1.159 }
245     }
246    
247     # widget call
248     sub ext_w_c {
249 root 1.169 my ($self, $id, $rcb, $method, @args) = @_;
250 root 1.159
251     my $w = $self->{widget}{$id}
252     or return;
253    
254 root 1.169 if ($rcb) {
255     $rcb->($w->$method (@args));
256 root 1.159 } else {
257     $w->$method (@args);
258     }
259     }
260    
261     # widget set
262     sub ext_w_s {
263 root 1.160 my ($self, $id, $attr) = @_;
264 root 1.159
265     my $w = $self->{widget}{$id}
266     or return;
267    
268     for (my $i = 0; $i < $#$attr; $i += 2) {
269     my ($member, $value) = @$attr[$i, $i+1];
270     if (defined $value) {
271     $w->{$member} = $value;
272     } else {
273     delete $w->{$member};
274     }
275     $w->{parent}->realloc if $member =~ /^c_/ && $w->{visible};
276     }
277     }
278    
279     # widget get
280     sub ext_w_g {
281 root 1.169 my ($self, $id, $rid, @attr) = @_;
282 root 1.159
283     my $w = $self->{widget}{$id}
284     or return;
285    
286 root 1.169 $self->send_exti_msg (w_e => $rid, map $w->{$_}, @attr);
287 root 1.160 }
288 root 1.147
289 root 1.159 # message window
290     sub ext_channel_info {
291 root 1.160 my ($self, $info) = @_;
292 root 1.159 $self->{channels}->{$info->{id}} = $info;
293     $::MESSAGE_WINDOW->add_channel ($info);
294 root 1.147 }
295    
296 root 1.159 #############################################################################
297    
298 elmex 1.34 sub logprint {
299     my ($self, @a) = @_;
300    
301 root 1.145 CFPlus::DB::logprint "$Crossfire::VARDIR/log.$self->{host}" => (join "", @a), sub { };
302 elmex 1.34 }
303    
304 root 1.52 sub _stat_numdiff {
305 root 1.54 my ($self, $name, $old, $new) = @_;
306 root 1.52
307     my $diff = $new - $old;
308 root 1.54
309     $diff = 0.01 * int $diff * 100;
310    
311     0.1 >= abs $diff ? ()
312     : $diff < 0 ? "$name$diff" : "$name+$diff"
313 root 1.52 }
314    
315     sub _stat_skillmaskdiff {
316 root 1.54 my ($self, $name, $old, $new) = @_;
317 root 1.52
318 root 1.54 my $diff = $old ^ $new
319     or return;
320 root 1.52
321 root 1.53 my @diff = map
322     {
323     $diff & $_
324     ? (($new & $_ ? "+" : "-") . $self->{spell_paths}{$_})
325     : ()
326     }
327     sort { $a <=> $b } keys %{$self->{spell_paths}};
328 root 1.52
329     join "", @diff
330     }
331    
332     # all stats that are chacked against changes
333     my @statchange = (
334     [&CS_STAT_STR => \&_stat_numdiff, "Str"],
335     [&CS_STAT_INT => \&_stat_numdiff, "Int"],
336     [&CS_STAT_WIS => \&_stat_numdiff, "Wis"],
337     [&CS_STAT_DEX => \&_stat_numdiff, "Dex"],
338     [&CS_STAT_CON => \&_stat_numdiff, "Con"],
339     [&CS_STAT_CHA => \&_stat_numdiff, "Cha"],
340     [&CS_STAT_POW => \&_stat_numdiff, "Pow"],
341     [&CS_STAT_WC => \&_stat_numdiff, "Wc"],
342     [&CS_STAT_AC => \&_stat_numdiff, "Ac"],
343     [&CS_STAT_DAM => \&_stat_numdiff, "Dam"],
344     [&CS_STAT_SPEED => \&_stat_numdiff, "Speed"],
345     [&CS_STAT_WEAP_SP => \&_stat_numdiff, "WSp"],
346     [&CS_STAT_MAXHP => \&_stat_numdiff, "HP"],
347     [&CS_STAT_MAXSP => \&_stat_numdiff, "Mana"],
348     [&CS_STAT_MAXGRACE => \&_stat_numdiff, "Grace"],
349     [&CS_STAT_WEIGHT_LIM => \&_stat_numdiff, "Weight"],
350     [&CS_STAT_SPELL_ATTUNE => \&_stat_skillmaskdiff, "attuned"],
351     [&CS_STAT_SPELL_REPEL => \&_stat_skillmaskdiff, "repelled"],
352     [&CS_STAT_SPELL_DENY => \&_stat_skillmaskdiff, "denied"],
353     [&CS_STAT_RES_PHYS => \&_stat_numdiff, "phys"],
354     [&CS_STAT_RES_MAG => \&_stat_numdiff, "magic"],
355     [&CS_STAT_RES_FIRE => \&_stat_numdiff, "fire"],
356     [&CS_STAT_RES_ELEC => \&_stat_numdiff, "electricity"],
357     [&CS_STAT_RES_COLD => \&_stat_numdiff, "cold"],
358     [&CS_STAT_RES_CONF => \&_stat_numdiff, "confusion"],
359     [&CS_STAT_RES_ACID => \&_stat_numdiff, "acid"],
360     [&CS_STAT_RES_DRAIN => \&_stat_numdiff, "drain"],
361     [&CS_STAT_RES_GHOSTHIT => \&_stat_numdiff, "ghosthit"],
362     [&CS_STAT_RES_POISON => \&_stat_numdiff, "poison"],
363     [&CS_STAT_RES_SLOW => \&_stat_numdiff, "slow"],
364     [&CS_STAT_RES_PARA => \&_stat_numdiff, "paralyse"],
365     [&CS_STAT_TURN_UNDEAD => \&_stat_numdiff, "turnundead"],
366     [&CS_STAT_RES_FEAR => \&_stat_numdiff, "fear"],
367     [&CS_STAT_RES_DEPLETE => \&_stat_numdiff, "depletion"],
368     [&CS_STAT_RES_DEATH => \&_stat_numdiff, "death"],
369     [&CS_STAT_RES_HOLYWORD => \&_stat_numdiff, "godpower"],
370     [&CS_STAT_RES_BLIND => \&_stat_numdiff, "blind"],
371     );
372    
373 root 1.1 sub stats_update {
374     my ($self, $stats) = @_;
375    
376 root 1.59 my $prev = $self->{prev_stats} || { };
377    
378     if (my @diffs =
379     (
380     ($stats->{+CS_STAT_EXP64} > $prev->{+CS_STAT_EXP64} ? ($stats->{+CS_STAT_EXP64} - $prev->{+CS_STAT_EXP64}) . " experience gained" : ()),
381     map {
382     $stats->{$_} && $prev->{$_}
383     && $stats->{$_}[1] > $prev->{$_}[1] ? "($self->{skill_info}{$_}+" . ($stats->{$_}[1] - $prev->{$_}[1]) . ")" : ()
384     } sort { $a <=> $b } keys %{$self->{skill_info}}
385     )
386     ) {
387     my $msg = join " ", @diffs;
388     $self->{statusbox}->add ($msg, group => "experience $msg", fg => [0.5, 1, 0.5, 0.8], timeout => 5);
389     }
390    
391     if (
392     my @diffs = map $_->[1]->($self, $_->[2], $prev->{$_->[0]}, $stats->{$_->[0]}), @statchange
393     ) {
394     my $msg = "<b>stat change</b>: " . (join " ", @diffs);
395 root 1.166 $self->{statusbox}->add ($msg, group => "stat $msg", fg => [0.8, 1, 0.2, 1], timeout => 20);
396 root 1.59 }
397    
398     $self->update_stats_window ($stats, $prev);
399    
400     $self->{prev_stats} = { %$stats };
401     }
402    
403     my %RES_TBL = (
404     phys => CS_STAT_RES_PHYS,
405     magic => CS_STAT_RES_MAG,
406     fire => CS_STAT_RES_FIRE,
407     elec => CS_STAT_RES_ELEC,
408     cold => CS_STAT_RES_COLD,
409     conf => CS_STAT_RES_CONF,
410     acid => CS_STAT_RES_ACID,
411     drain => CS_STAT_RES_DRAIN,
412     ghit => CS_STAT_RES_GHOSTHIT,
413     pois => CS_STAT_RES_POISON,
414     slow => CS_STAT_RES_SLOW,
415     para => CS_STAT_RES_PARA,
416     tund => CS_STAT_TURN_UNDEAD,
417     fear => CS_STAT_RES_FEAR,
418     depl => CS_STAT_RES_DEPLETE,
419     deat => CS_STAT_RES_DEATH,
420     holyw => CS_STAT_RES_HOLYWORD,
421     blind => CS_STAT_RES_BLIND,
422     );
423    
424     sub update_stats_window {
425     my ($self, $stats, $prev) = @_;
426    
427     # I love text protocols...
428 root 1.52
429 root 1.59 my $hp = $stats->{+CS_STAT_HP} * 1;
430     my $hp_m = $stats->{+CS_STAT_MAXHP} * 1;
431     my $sp = $stats->{+CS_STAT_SP} * 1;
432     my $sp_m = $stats->{+CS_STAT_MAXSP} * 1;
433     my $fo = $stats->{+CS_STAT_FOOD} * 1;
434     my $fo_m = 999;
435     my $gr = $stats->{+CS_STAT_GRACE} * 1;
436     my $gr_m = $stats->{+CS_STAT_MAXGRACE} * 1;
437    
438     $::GAUGES->{hp} ->set_value ($hp, $hp_m);
439     $::GAUGES->{mana} ->set_value ($sp, $sp_m);
440     $::GAUGES->{food} ->set_value ($fo, $fo_m);
441     $::GAUGES->{grace} ->set_value ($gr, $gr_m);
442     $::GAUGES->{exp} ->set_text ("Exp: " . (::formsep ($stats->{+CS_STAT_EXP64}))
443     . " (lvl " . ($stats->{+CS_STAT_LEVEL} * 1) . ")");
444 root 1.157 $::GAUGES->{prg} ->set_value ($stats->{+CS_STAT_LEVEL}, $stats->{+CS_STAT_EXP64});
445 root 1.106 $::GAUGES->{range} ->set_text ($stats->{+CS_STAT_RANGE});
446 root 1.59 my $title = $stats->{+CS_STAT_TITLE};
447     $title =~ s/^Player: //;
448     $::STATWIDS->{title} ->set_text ("Title: " . $title);
449    
450     $::STATWIDS->{st_str} ->set_text (sprintf "%d" , $stats->{+CS_STAT_STR});
451     $::STATWIDS->{st_dex} ->set_text (sprintf "%d" , $stats->{+CS_STAT_DEX});
452     $::STATWIDS->{st_con} ->set_text (sprintf "%d" , $stats->{+CS_STAT_CON});
453     $::STATWIDS->{st_int} ->set_text (sprintf "%d" , $stats->{+CS_STAT_INT});
454     $::STATWIDS->{st_wis} ->set_text (sprintf "%d" , $stats->{+CS_STAT_WIS});
455     $::STATWIDS->{st_pow} ->set_text (sprintf "%d" , $stats->{+CS_STAT_POW});
456     $::STATWIDS->{st_cha} ->set_text (sprintf "%d" , $stats->{+CS_STAT_CHA});
457     $::STATWIDS->{st_wc} ->set_text (sprintf "%d" , $stats->{+CS_STAT_WC});
458     $::STATWIDS->{st_ac} ->set_text (sprintf "%d" , $stats->{+CS_STAT_AC});
459     $::STATWIDS->{st_dam} ->set_text (sprintf "%d" , $stats->{+CS_STAT_DAM});
460     $::STATWIDS->{st_arm} ->set_text (sprintf "%d" , $stats->{+CS_STAT_RES_PHYS});
461     $::STATWIDS->{st_spd} ->set_text (sprintf "%.1f", $stats->{+CS_STAT_SPEED});
462     $::STATWIDS->{st_wspd}->set_text (sprintf "%.1f", $stats->{+CS_STAT_WEAP_SP});
463    
464 root 1.64 $self->update_weight;
465 root 1.59
466     $::STATWIDS->{"res_$_"}->set_text (sprintf "%d%", $stats->{$RES_TBL{$_}})
467     for keys %RES_TBL;
468    
469     my $sktbl = $::STATWIDS->{skill_tbl};
470     my @skills = keys %{ $self->{skill_info} };
471    
472 root 1.162 my @order = sort { $stats->{$b->[0]}[1] <=> $stats->{$a->[0]}[1] or $a->[1] cmp $b->[1] }
473     map [$_, $self->{skill_info}{$_}],
474     grep exists $stats->{$_},
475     @skills;
476    
477     if ($self->{stat_order} ne join ",", map $_->[0], @order) {
478     $self->{stat_order} = join ",", map $_->[0], @order;
479    
480 root 1.59 $sktbl->clear;
481    
482 root 1.158 my $sw = $self->{skillwid}{""} ||= [
483 root 1.124 0, 0, (new CFPlus::UI::Label text => "Experience", align => 1),
484     1, 0, (new CFPlus::UI::Label text => "Lvl.", align => 1),
485 root 1.157 2, 0, (new CFPlus::UI::Label text => "Progress", align => 0),
486     3, 0, (new CFPlus::UI::Label text => "Skill", expand => 1),
487     4, 0, (new CFPlus::UI::Label text => "Experience", align => 1),
488     5, 0, (new CFPlus::UI::Label text => "Lvl.", align => 1),
489     6, 0, (new CFPlus::UI::Label text => "Progress", align => 0),
490     7, 0, (new CFPlus::UI::Label text => "Skill", expand => 1),
491 root 1.158 ];
492    
493     my @add = @$sw;
494 root 1.59
495 elmex 1.68 my $TOOLTIP_ALL = "\n\n<small>Left click - ready skill\nMiddle click - use spell\nRight click - further options</small>";
496    
497     my @TOOLTIP_LVL = (tooltip => "<b>Level</b>. The level of the skill.$TOOLTIP_ALL", can_events => 1, can_hover => 1);
498     my @TOOLTIP_EXP = (tooltip => "<b>Experience</b>. The experience points you have in this skill.$TOOLTIP_ALL", can_events => 1, can_hover => 1);
499    
500 root 1.65 my ($x, $y) = (0, 1);
501 root 1.162 for (@order) {
502 root 1.59 my ($idx, $name) = @$_;
503    
504 elmex 1.68 my $spell_cb = sub {
505     my ($widget, $ev) = @_;
506    
507     if ($ev->{button} == 1) {
508     $::CONN->user_send ("ready_skill $name");
509     } elsif ($ev->{button} == 2) {
510     $::CONN->user_send ("use_skill $name");
511     } elsif ($ev->{button} == 3) {
512 root 1.90 my $shortname = CFPlus::shorten $name, 14;
513 root 1.69 (new CFPlus::UI::Menu
514 elmex 1.68 items => [
515 root 1.91 ["bind <i>ready_skill $shortname</i> to a key" => sub { CFPlus::Macro::quick_macro ["ready_skill $name"] }],
516     ["bind <i>use_skill $shortname</i> to a key" => sub { CFPlus::Macro::quick_macro ["use_skill $name"] }],
517 elmex 1.68 ],
518     )->popup ($ev);
519     } else {
520     return 0;
521     }
522    
523     1
524     };
525    
526 root 1.158 my $sw = $self->{skillwid}{$idx} ||= [
527     # exp
528     (new CFPlus::UI::Label
529     align => 1, font => $::FONT_FIXED, fg => [1, 1, 0], on_button_down => $spell_cb, @TOOLTIP_EXP),
530    
531     # level
532     (new CFPlus::UI::Label
533     text => "0", align => 1, font => $::FONT_FIXED, fg => [0, 1, 0], padding_x => 4, on_button_down => $spell_cb, @TOOLTIP_LVL),
534    
535     # progress
536     (new CFPlus::UI::ExperienceProgress),
537    
538     # label
539     (new CFPlus::UI::Label text => $name, on_button_down => $spell_cb,
540     can_events => 1, can_hover => 1, tooltip => (CFPlus::Pod::section_label skill_description => $name) . $TOOLTIP_ALL),
541     ];
542    
543 root 1.124 push @add,
544 root 1.158 $x * 4 + 0, $y, $sw->[0],
545     $x * 4 + 1, $y, $sw->[1],
546     $x * 4 + 2, $y, $sw->[2],
547     $x * 4 + 3, $y, $sw->[3],
548 root 1.124 ;
549 root 1.59
550     $x++ and ($x, $y) = (0, $y + 1);
551 root 1.52 }
552 root 1.124
553     $sktbl->add_at (@add);
554 root 1.1 }
555    
556 root 1.163 for (@order) {
557     my ($idx, $name) = @$_;
558     my $val = $stats->{$idx};
559    
560 root 1.166 next if $prev->{$idx}[1] eq $val->[1];
561 root 1.163
562     my $sw = $self->{skillwid}{$idx};
563     $sw->[0]->set_text (::formsep ($val->[1]));
564     $sw->[1]->set_text ($val->[0] * 1);
565     $sw->[2]->set_value (@$val);
566 root 1.162
567 root 1.164 $::GAUGES->{sklprg}->set_label ("$name %d%%");
568 root 1.163 $::GAUGES->{sklprg}->set_value (@$val);
569 root 1.59 }
570 root 1.1 }
571    
572     sub user_send {
573     my ($self, $command) = @_;
574    
575 root 1.91 $self->{record}->($command)
576 root 1.87 if $self->{record};
577 elmex 1.9
578 elmex 1.34 $self->logprint ("send: ", $command);
579 root 1.1 $self->send_command ($command);
580     }
581    
582 root 1.91 sub record {
583     my ($self, $cb) = @_;
584 elmex 1.9
585 root 1.91 $self->{record} = $cb;
586 elmex 1.9 }
587    
588 root 1.1 sub map_scroll {
589     my ($self, $dx, $dy) = @_;
590    
591     $self->{map}->scroll ($dx, $dy);
592     }
593    
594     sub feed_map1a {
595     my ($self, $data) = @_;
596    
597 root 1.148 my $missing = $self->{map}->map1a_update ($data, $self->{setup}{extmap});
598     my $delay;
599    
600     for my $tile (@$missing) {
601     next if $self->{delay}{$tile};
602    
603     $delay = 1;
604    
605     if (my $tex = $::CONN->{texture}[$tile]) {
606     $tex->upload;
607     } else {
608     $self->{delay}{$tile} = 1;
609    
610     # we assume the face is in-flight and will eventually come
611 root 1.156 push @{$self->{tile_cb}{$tile}}, sub {
612 root 1.148 delete $self->{delay}{$tile};
613     $_[0]->upload;
614     };
615     }
616     }
617    
618     if ($delay) {
619     # delay the map drawing a tiny bit in the hope of getting the missing fetched
620     Event->timer (after => 0.03, cb => sub {
621     $_[0]->w->cancel;
622 root 1.161 $self->{map_widget}->update
623     if $self->{map_widget};
624 root 1.148 });
625     } else {
626     $self->{map_widget}->update;
627     }
628 root 1.1 }
629    
630 root 1.36 sub magicmap {
631     my ($self, $w, $h, $x, $y, $data) = @_;
632    
633     $self->{map_widget}->set_magicmap ($w, $h, $x, $y, $data);
634     }
635    
636 root 1.1 sub flush_map {
637     my ($self) = @_;
638    
639     my $map_info = delete $self->{map_info}
640     or return;
641    
642     my ($hash, $x, $y, $w, $h) = @$map_info;
643    
644 root 1.153 my $data = Compress::LZF::compress $self->{map}->get_rect ($x, $y, $w, $h);
645     $self->{map_cache_new}{$hash} = \$data;
646     CFPlus::DB::put $self->{mapcache} => $hash => $data, sub { };
647 root 1.1 }
648    
649     sub map_clear {
650     my ($self) = @_;
651    
652     $self->flush_map;
653     delete $self->{neigh_map};
654    
655     $self->{map}->clear;
656 root 1.37 delete $self->{map_widget}{magicmap};
657 root 1.1 }
658    
659 root 1.97 sub bg_fetch {
660     my ($self) = @_;
661    
662 root 1.156 my $tile;
663 root 1.97
664     do {
665 root 1.156 $tile = pop @{$self->{bg_fetch}}
666 root 1.97 or return;
667 root 1.156 } while $self->{texture}[$tile];
668 root 1.97
669 root 1.156 CFPlus::DB::get tilecache => $tile, sub {
670     my ($data) = @_;
671 root 1.97
672 root 1.98 return unless $self->{map}; # stop when destroyed
673    
674 root 1.156 if (defined $data) {
675     $self->have_tile ($tile, $data);
676     $self->{texture}[$tile]->upload;
677 root 1.150 }
678 root 1.97
679     $self->bg_fetch;
680     };
681     }
682 root 1.1
683     sub load_map($$$) {
684     my ($self, $hash, $x, $y) = @_;
685    
686 root 1.100 my $gen = $self->{map_change_gen};
687    
688 root 1.152 my $cb = sub {
689 root 1.100 return unless $gen == $self->{map_change_gen};
690    
691 root 1.96 my ($data) = @_;
692    
693     if (defined $data) {
694 root 1.152 $self->{map_cache_new}{$hash} = \$data;
695    
696     my $data = Compress::LZF::decompress $data;
697 root 1.1
698 root 1.97 my $inprogress = @{ $self->{bg_fetch} || [] };
699 root 1.98 unshift @{ $self->{bg_fetch} }, $self->{map}->set_rect ($x, $y, $data);
700 root 1.97 $self->bg_fetch unless $inprogress;
701 root 1.1 }
702 root 1.96 };
703 root 1.152
704     if (my $rdata = $self->{map_cache_old}{$hash}) {
705     $cb->($$rdata);
706     } else {
707     CFPlus::DB::get $self->{mapcache} => $hash, $cb;
708     }
709 root 1.1 }
710    
711     # hardcode /world/world_xxx_xxx map names, the savings are enourmous,
712     # (server resource,s latency, bandwidth), so this hack is warranted.
713     # the right fix is to make real tiled maps with an overview file
714     sub send_mapinfo {
715     my ($self, $data, $cb) = @_;
716    
717     if ($self->{map_info}[0] =~ m%^/world/world_(\d\d\d)_(\d\d\d)$%) {
718     my ($wx, $wy) = ($1, $2);
719    
720     if ($data =~ /^spatial ([1-4]+)$/) {
721     my @dx = (0, 0, 1, 0, -1);
722     my @dy = (0, -1, 0, 1, 0);
723     my ($dx, $dy);
724    
725     for (split //, $1) {
726     $dx += $dx[$_];
727     $dy += $dy[$_];
728     }
729    
730     $cb->(spatial => 15,
731     $self->{map_info}[1] - $self->{map}->ox + $dx * 50,
732     $self->{map_info}[2] - $self->{map}->oy + $dy * 50,
733     50, 50,
734     sprintf "/world/world_%03d_%03d", $wx + $dx, $wy + $dy
735     );
736    
737     return;
738     }
739     }
740    
741     $self->SUPER::send_mapinfo ($data, $cb);
742     }
743    
744     # this method does a "flood fill" into every tile direction
745     # it assumes that tiles are arranged in a rectangular grid,
746     # i.e. a map is the same as the left of the right map etc.
747     # failure to comply are harmless and result in display errors
748     # at worst.
749     sub flood_fill {
750     my ($self, $block, $gx, $gy, $path, $hash, $flags) = @_;
751    
752     # the server does not allow map paths > 6
753     return if 7 <= length $path;
754    
755     my ($x0, $y0, $x1, $y1) = @{$self->{neigh_rect}};
756    
757     for (
758     [1, 3, 0, -1],
759     [2, 4, 1, 0],
760     [3, 1, 0, 1],
761     [4, 2, -1, 0],
762     ) {
763     my ($tile, $tile2, $dx, $dy) = @$_;
764    
765     next if $block & (1 << $tile);
766     my $block = $block | (1 << $tile2);
767    
768     my $gx = $gx + $dx;
769     my $gy = $gy + $dy;
770    
771     next unless $flags & (1 << ($tile - 1));
772     next if $self->{neigh_grid}{$gx, $gy}++;
773    
774     my $neigh = $self->{neigh_map}{$hash} ||= [];
775     if (my $info = $neigh->[$tile]) {
776     my ($flags, $x, $y, $w, $h, $hash) = @$info;
777    
778     $self->flood_fill ($block, $gx, $gy, "$path$tile", $hash, $flags)
779     if $x >= $x0 && $x + $w < $x1 && $y >= $y0 && $y + $h < $y1;
780    
781     } else {
782 root 1.100 my $gen = $self->{map_change_gen};
783 root 1.1 $self->send_mapinfo ("spatial $path$tile", sub {
784 root 1.100 return unless $gen == $self->{map_change_gen};
785    
786 root 1.1 my ($mode, $flags, $x, $y, $w, $h, $hash) = @_;
787    
788     return if $mode ne "spatial";
789    
790     $x += $self->{map}->ox;
791     $y += $self->{map}->oy;
792    
793     $self->load_map ($hash, $x, $y)
794     unless $self->{neigh_map}{$hash}[5]++;#d#
795    
796     $neigh->[$tile] = [$flags, $x, $y, $w, $h, $hash];
797    
798     $self->flood_fill ($block, $gx, $gy, "$path$tile", $hash, $flags)
799     if $x >= $x0 && $x + $w < $x1 && $y >= $y0 && $y + $h < $y1;
800     });
801     }
802     }
803     }
804    
805     sub map_change {
806     my ($self, $mode, $flags, $x, $y, $w, $h, $hash) = @_;
807    
808     $self->flush_map;
809    
810 root 1.100 ++$self->{map_change_gen};
811 root 1.152 $self->{map_cache_old} = delete $self->{map_cache_new};
812 root 1.100
813 root 1.1 my ($ox, $oy) = ($::MAP->ox, $::MAP->oy);
814    
815     my $mapmapw = $self->{mapmap}->{w};
816     my $mapmaph = $self->{mapmap}->{h};
817    
818     $self->{neigh_rect} = [
819     $ox - $mapmapw * 0.5, $oy - $mapmapw * 0.5,
820     $ox + $mapmapw * 0.5 + $w, $oy + $mapmapw * 0.5 + $h,
821     ];
822    
823     delete $self->{neigh_grid};
824    
825     $x += $ox;
826     $y += $oy;
827    
828     $self->{map_info} = [$hash, $x, $y, $w, $h];
829    
830     (my $map = $hash) =~ s/^.*?\/([^\/]+)$/\1/;
831     $::STATWIDS->{map}->set_text ("Map: " . $map);
832    
833     $self->load_map ($hash, $x, $y);
834     $self->flood_fill (0, 0, 0, "", $hash, $flags);
835     }
836    
837     sub face_find {
838 root 1.96 my ($self, $facenum, $face, $cb) = @_;
839 root 1.1
840 root 1.131 if ($face->{type} == 0) { # FT_FACE
841     my $id = CFPlus::DB::get_tile_id_sync $face->{name};
842 root 1.1
843 root 1.156 $face->{id} = $id;
844 root 1.131 $self->{map}->set_tileid ($facenum => $id);
845 root 1.1
846 root 1.131 CFPlus::DB::get tilecache => $id, $cb;
847 root 1.1
848 root 1.131 } elsif ($face->{type} & 1) { # with metadata
849 root 1.140 CFPlus::DB::get res_meta => $face->{name}, $cb;
850 root 1.156
851     } else { # no metadata
852     CFPlus::DB::get res_data => $face->{name}, $cb;
853 root 1.131 }
854 root 1.1 }
855    
856     sub face_update {
857 root 1.58 my ($self, $facenum, $face, $changed) = @_;
858 root 1.1
859 root 1.156 if ($face->{type} == 0) {
860     # image, FT_FACE
861 root 1.132 CFPlus::DB::put tilecache => $face->{id} => $face->{data}, sub { }
862 root 1.131 if $changed;
863    
864 root 1.156 $self->have_tile ($face->{id}, delete $face->{data});
865 root 1.1
866 root 1.156 } elsif ($face->{type} & 1) {
867     # split metadata case, FT_MUSIC, FT_SOUND
868 root 1.147 if ($changed) { # new data
869 root 1.156 my ($meta, $data) = unpack "(w/a*)*", $face->{data};
870     $face->{data} = $meta;
871 root 1.147
872 root 1.168 # rely on strict ordering here and also on later fetch
873 root 1.147 CFPlus::DB::put res_data => $face->{name} => $data, sub { };
874 root 1.156 CFPlus::DB::put res_meta => $face->{name} => $meta, sub { };
875 root 1.147 }
876    
877 root 1.156 $face->{data} = $self->{json_coder}->decode ($face->{data});
878 root 1.147 ::add_license ($face);
879 root 1.168 ::message ({ markup => CFPlus::asxml "downloaded resource '$face->{data}{name}', type $face->{type}." })
880     if $changed;
881 root 1.131
882     if ($face->{type} == 3) { # FT_MUSIC
883 root 1.147 &::audio_music_push ($facenum);
884 root 1.139 } elsif ($face->{type} == 5) { # FT_SOUND
885 root 1.147 &::audio_sound_push ($facenum);
886 root 1.131 }
887    
888 root 1.156 } else {
889     # flat resource case, FT_RSRC
890     CFPlus::DB::put res_data => $face->{name} => $face->{data}, sub { }
891     if $changed;
892     }
893    
894     if (my $cbs = $self->{face_cb}{$facenum}) {
895     $_->($face, $changed) for @$cbs;
896 root 1.131 }
897 root 1.1 }
898    
899 root 1.99 sub smooth_update {
900     my ($self, $facenum, $face) = @_;
901    
902     $self->{map}->set_smooth ($facenum, $face->{smoothface}, $face->{smoothlevel});
903     }
904    
905 root 1.146 sub have_tile {
906 root 1.156 my ($self, $tile, $data) = @_;
907 root 1.1
908 root 1.118 return unless $self->{map};
909    
910 root 1.148 my $tex = $self->{texture}[$tile] ||=
911 root 1.146 new CFPlus::Texture
912 root 1.156 tile => $tile,
913     image => $data, delete_image => 1,
914     minify => 1, mipmap => 1;
915 root 1.122
916 root 1.156 if (my $cbs = delete $self->{tile_cb}{$tile}) {
917     $_->($tex) for @$cbs;
918     }
919     }
920    
921     # call in non-void context registers a temporary
922     # hook with handle, otherwise its permanent
923     sub on_face_change {
924     my ($self, $num, $cb) = @_;
925    
926     push @{$self->{face_cb}{$num}}, $cb;
927    
928     defined wantarray
929     ? CFPlus::guard {
930     @{$self->{face_cb}{$num}}
931     = grep $_ != $cb,
932     @{$self->{face_cb}{$num}};
933     }
934     : ()
935 root 1.122 }
936    
937 root 1.156 # call in non-void context registers a temporary
938     # hook with handle, otherwise its permanent
939     sub register_face_handler {
940     my ($self, $num, $cb) = @_;
941 root 1.122
942 root 1.157 return unless $num;
943    
944 root 1.156 # invoke if available right now
945     $cb->($self->{face}[$num], 0)
946     unless exists $self->{face}[$num]{loading};
947 root 1.122
948 root 1.156 # future changes
949     $self->on_face_change ($num => $cb)
950 root 1.1 }
951    
952     sub sound_play {
953 root 1.141 my ($self, $type, $face, $dx, $dy, $vol) = @_;
954 root 1.1
955 root 1.141 &::audio_sound_play ($face, $dx, $dy, $vol)
956     unless $type & 1; # odd types are silent for future expansion
957 root 1.1 }
958    
959     my $LAST_QUERY; # server is stupid, stupid, stupid
960    
961     sub query {
962     my ($self, $flags, $prompt) = @_;
963    
964     $prompt = $LAST_QUERY unless length $prompt;
965     $LAST_QUERY = $prompt;
966    
967 root 1.22 $self->{query}-> ($self, $flags, $prompt);
968 root 1.1 }
969    
970 root 1.108 sub sanitise_xml($) {
971     local $_ = shift;
972    
973     # we now weed out all tags we do not support
974     s%<(?!/?i>|/?u>|/?b>|fg |/fg>)%&lt;%g;
975     # now all entities
976     s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&amp;/g;
977    
978     # handle some elements
979     s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs;
980     s/<fg name="([^"]*)">(.*?)<\/fg>/<span foreground="$1">$2<\/span>/gs;
981    
982     $_
983     }
984    
985 root 1.105 our %NAME_TO_COLOR = (
986     black => 0,
987     white => 1,
988     darkblue => 2,
989     red => 3,
990     orange => 4,
991     lightblue => 5,
992     darkorange => 6,
993     green => 7,
994     darkgreen => 8,
995     grey => 9,
996     brown => 10,
997     yellow => 11,
998     tan => 12,
999     );
1000    
1001 root 1.103 our @CF_COLOR = (
1002     [1.00, 1.00, 1.00], #[0.00, 0.00, 0.00],
1003     [1.00, 1.00, 1.00],
1004     [0.50, 0.50, 1.00], #[0.00, 0.00, 0.55]
1005     [1.00, 0.00, 0.00],
1006     [1.00, 0.54, 0.00],
1007     [0.11, 0.56, 1.00],
1008     [0.93, 0.46, 0.00],
1009     [0.18, 0.54, 0.34],
1010     [0.56, 0.73, 0.56],
1011     [0.80, 0.80, 0.80],
1012     [0.75, 0.61, 0.20],
1013     [0.99, 0.77, 0.26],
1014     [0.74, 0.65, 0.41],
1015     );
1016    
1017 root 1.105 sub msg {
1018     my ($self, $color, $type, $text, @extra) = @_;
1019 root 1.1
1020 root 1.108 $text = sanitise_xml $text;
1021 root 1.107
1022 root 1.105 if (my $cb = $self->{cb_msg}{$type}) {
1023     $_->($self, $color, $type, $text, @extra) for values %$cb;
1024     } elsif ($type =~ /^(?:chargen-race-title|chargen-race-description)$/) {
1025     $type =~ s/-/_/g;
1026     $self->{$type} = $text;
1027     } else {
1028     $self->logprint ("msg: ", $text);
1029     return if $color < 0; # negative color == ignore if not understood
1030 root 1.93
1031 elmex 1.154 my $fg = $CF_COLOR[$color & NDI_COLOR_MASK] || [1, 0, 0];
1032 elmex 1.34
1033 root 1.105 ## try to create single paragraphs of multiple lines sent by the server
1034     # no longer neecssary with TRT servers
1035     #$text =~ s/(?<=\S)\n(?=\w)/ /g;
1036    
1037 elmex 1.154 ::message ({
1038     fg => $fg,
1039     markup => $_,
1040     type => $type,
1041     extra => [@extra],
1042     color_flags => $color
1043     }) for split /\n/, $text;
1044 root 1.105
1045     $self->{statusbox}->add ($text,
1046     group => $text,
1047     fg => $fg,
1048     timeout => $color >= 2 ? 180 : 10,
1049     tooltip_font => $::FONT_FIXED,
1050     );
1051     }
1052 root 1.1 }
1053    
1054     sub spell_add {
1055     my ($self, $spell) = @_;
1056    
1057 root 1.66 # try to create single paragraphs out of the multiple lines sent by the server
1058 root 1.27 $spell->{message} =~ s/(?<=\S)\n(?=\w)/ /g;
1059     $spell->{message} =~ s/\n+$//;
1060     $spell->{message} ||= "Server did not provide a description for this spell.";
1061    
1062 root 1.88 $::SPELL_LIST->add_spell ($spell);
1063 elmex 1.14
1064 root 1.69 $self->{map_widget}->add_command ("invoke $spell->{name}", CFPlus::asxml $spell->{message});
1065     $self->{map_widget}->add_command ("cast $spell->{name}", CFPlus::asxml $spell->{message});
1066 root 1.1 }
1067    
1068     sub spell_delete {
1069     my ($self, $spell) = @_;
1070 root 1.51
1071 root 1.88 $::SPELL_LIST->remove_spell ($spell);
1072 root 1.1 }
1073    
1074 root 1.87 sub setup {
1075     my ($self, $setup) = @_;
1076    
1077 root 1.95 $self->{map_widget}->set_tilesize ($self->{tilesize});
1078 root 1.87 $::MAP->resize ($self->{mapw}, $self->{maph});
1079     }
1080    
1081 root 1.1 sub addme_success {
1082     my ($self) = @_;
1083    
1084 root 1.72 my %skill_help;
1085 root 1.21
1086 root 1.72 for my $node (CFPlus::Pod::find skill_description => "*") {
1087     my (undef, @par) = CFPlus::Pod::section_of $node;
1088     $skill_help{$node->{kw}[0]} = CFPlus::Pod::as_label @par;
1089 root 1.21 };
1090 root 1.72
1091 root 1.1 for my $skill (values %{$self->{skill_info}}) {
1092     $self->{map_widget}->add_command ("ready_skill $skill",
1093 root 1.69 (CFPlus::asxml "Ready the skill '$skill'\n\n")
1094 root 1.72 . $skill_help{$skill});
1095 root 1.1 $self->{map_widget}->add_command ("use_skill $skill",
1096 root 1.69 (CFPlus::asxml "Immediately use the skill '$skill'\n\n")
1097 root 1.72 . $skill_help{$skill});
1098 root 1.1 }
1099     }
1100    
1101     sub eof {
1102     my ($self) = @_;
1103    
1104     $self->{map_widget}->clr_commands;
1105    
1106     ::stop_game ();
1107     }
1108    
1109     sub update_floorbox {
1110 root 1.69 $CFPlus::UI::ROOT->on_refresh ($::FLOORBOX => sub {
1111 root 1.1 return unless $::CONN;
1112 elmex 1.62
1113 root 1.1 $::FLOORBOX->clear;
1114    
1115 root 1.124 my @add;
1116    
1117 root 1.1 my $row;
1118 elmex 1.62 for (sort { $a->{count} <=> $b->{count} } values %{ $::CONN->{container}{$::CONN->{open_container} || 0} }) {
1119 root 1.25 if ($row < 6) {
1120 root 1.1 local $_->{face_widget}; # hack to force recreation of widget
1121     local $_->{desc_widget}; # hack to force recreation of widget
1122 root 1.69 CFPlus::Item::update_widgets $_;
1123 root 1.1
1124 root 1.124 push @add,
1125     0, $row, $_->{face_widget},
1126     1, $row, $_->{desc_widget};
1127 root 1.1
1128     $row++;
1129     } else {
1130 root 1.124 push @add, 1, $row, new CFPlus::UI::Button
1131 root 1.30 text => "More...",
1132 root 1.51 on_activate => sub { ::toggle_player_page ($::INVENTORY_PAGE); 0 },
1133 root 1.124 ;
1134 root 1.1 last;
1135     }
1136     }
1137 elmex 1.62 if ($::CONN->{open_container}) {
1138 root 1.124 push @add, 1, $row++, new CFPlus::UI::Button
1139 elmex 1.62 text => "Close container",
1140     on_activate => sub { $::CONN->send ("apply $::CONN->{open_container}") }
1141 root 1.124 ;
1142 elmex 1.62 }
1143 root 1.124
1144     $::FLOORBOX->add_at (@add);
1145 root 1.1 });
1146 elmex 1.62
1147 root 1.148 $::WANT_REFRESH->start;
1148 root 1.1 }
1149    
1150     sub set_opencont {
1151     my ($conn, $tag, $name) = @_;
1152     $conn->{open_container} = $tag;
1153 elmex 1.62 update_floorbox;
1154 elmex 1.10
1155 root 1.155 $::INVR_HB->clear ();
1156     $::INVR_HB->add (new CFPlus::UI::Label align => 0, expand => 1, text => $name);
1157 elmex 1.10
1158     if ($tag != 0) { # Floor isn't closable, is it?
1159 root 1.155 $::INVR_HB->add (new CFPlus::UI::Button
1160 elmex 1.10 text => "Close container",
1161     tooltip => "Close the currently open container (if one is open)",
1162     on_activate => sub {
1163     $::CONN->send ("apply $tag") # $::CONN->{open_container}")
1164     if $tag != 0;
1165 root 1.38 0
1166 elmex 1.10 },
1167     );
1168     }
1169    
1170 root 1.1 $::INVR->set_items ($conn->{container}{$tag});
1171     }
1172    
1173 root 1.47 sub update_containers {
1174     my ($self) = @_;
1175 root 1.1
1176 root 1.69 $CFPlus::UI::ROOT->on_refresh ("update_containers_$self" => sub {
1177 root 1.55 my $todo = delete $self->{update_container}
1178     or return;
1179    
1180     for my $tag (keys %$todo) {
1181 elmex 1.62 update_floorbox if $tag == 0 or $tag == $self->{open_container};
1182 root 1.47 if ($tag == 0) {
1183 root 1.48 $::INVR->set_items ($self->{container}{0})
1184     if $tag == $self->{open_container};
1185 root 1.47 } elsif ($tag == $self->{player}{tag}) {
1186     $::INV->set_items ($self->{container}{$tag})
1187     } else {
1188 root 1.48 $::INVR->set_items ($self->{container}{$tag})
1189     if $tag == $self->{open_container};
1190 root 1.47 }
1191     }
1192     });
1193 root 1.1 }
1194    
1195 root 1.48 sub container_add {
1196     my ($self, $tag, $items) = @_;
1197    
1198     $self->{update_container}{$tag}++;
1199     $self->update_containers;
1200     }
1201    
1202 root 1.1 sub container_clear {
1203     my ($self, $tag) = @_;
1204    
1205 root 1.47 $self->{update_container}{$tag}++;
1206     $self->update_containers;
1207 root 1.1 }
1208    
1209     sub item_delete {
1210     my ($self, @items) = @_;
1211    
1212 root 1.49 $self->{update_container}{$_->{container}}++
1213 root 1.47 for @items;
1214    
1215     $self->update_containers;
1216 root 1.1 }
1217    
1218     sub item_update {
1219     my ($self, $item) = @_;
1220    
1221     #d# print "item_update: $item->{tag} in $item->{container} ($self->{player}{tag}) ($::CONN->{open_container})\n";
1222    
1223 root 1.69 CFPlus::Item::update_widgets $item;
1224 root 1.1
1225 root 1.2 if ($item->{tag} == $::CONN->{open_container} && not ($item->{flags} & F_OPEN)) {
1226 root 1.1 set_opencont ($::CONN, 0, "Floor");
1227    
1228 root 1.2 } elsif ($item->{flags} & F_OPEN) {
1229 root 1.69 set_opencont ($::CONN, $item->{tag}, CFPlus::Item::desc_string $item);
1230 root 1.47
1231 root 1.1 } else {
1232 root 1.47 $self->{update_container}{$item->{container}}++;
1233     $self->update_containers;
1234 root 1.1 }
1235     }
1236    
1237 elmex 1.3 sub player_update {
1238     my ($self, $player) = @_;
1239 root 1.64
1240     $self->update_weight;
1241     }
1242    
1243     sub update_weight {
1244     my ($self) = @_;
1245    
1246     my $weight = .001 * $self->{player}{weight};
1247     my $limit = .001 * $self->{stat}{+CS_STAT_WEIGHT_LIM};
1248    
1249     $::STATWIDS->{weight}->set_text (sprintf "Weight: %.1fkg", $weight);
1250     $::STATWIDS->{m_weight}->set_text (sprintf "%.1fkg", $limit);
1251     $::STATWIDS->{i_weight}->set_text (sprintf "%.1f/%.1fkg", $weight, $limit);
1252 root 1.28 }
1253    
1254 root 1.32 sub update_server_info {
1255     my ($self) = @_;
1256    
1257     my @yesno = ("<span foreground='red'>no</span>", "<span foreground='green'>yes</span>");
1258    
1259     $::SERVER_INFO->set_markup (
1260     "server <tt>$self->{host}:$self->{port}</tt>\n"
1261     . "protocol version <tt>$self->{version}</tt>\n"
1262     . "minimap support $yesno[$self->{setup}{mapinfocmd} > 0]\n"
1263     . "extended command support $yesno[$self->{setup}{extcmd} > 0]\n"
1264 root 1.104 . "examine command support $yesno[$self->{setup}{excmd} > 0]\n"
1265 root 1.86 . "editing support $yesno[!!$self->{editor_support}]\n"
1266 root 1.80 . "map attributes $yesno[$self->{setup}{extmap} > 0]\n"
1267 root 1.104 . "big image protocol support $yesno[$self->{setup}{fxix} > 0]\n"
1268 root 1.32 . "cfplus support $yesno[$self->{cfplus_ext} > 0]"
1269     . ($self->{cfplus_ext} > 0 ? ", version $self->{cfplus_ext}" : "") ."\n"
1270     . "map size $self->{mapw}×$self->{maph}\n"
1271     );
1272 elmex 1.89
1273 root 1.32 }
1274    
1275 root 1.28 sub logged_in {
1276     my ($self) = @_;
1277    
1278 root 1.128 $self->send_ext_req (cfplus_support => version => 2, sub {
1279     my (%msg) = @_;
1280    
1281     $self->{cfplus_ext} = $msg{version};
1282 root 1.32 $self->update_server_info;
1283 root 1.70
1284 root 1.85 if ($self->{cfplus_ext} >= 2) {
1285     $self->send_ext_req ("editor_support", sub {
1286 root 1.128 $self->{editor_support} = { @_ };
1287 root 1.85 $self->update_server_info;
1288    
1289     0
1290     });
1291     }
1292    
1293 root 1.70 0
1294 root 1.32 });
1295 root 1.31
1296 root 1.32 $self->update_server_info;
1297 root 1.13
1298     $self->send_command ("output-sync $::CFG->{output_sync}");
1299     $self->send_command ("output-count $::CFG->{output_count}");
1300 root 1.94 $self->send_command ("output-rate $::CFG->{output_rate}") if $::CFG->{output_rate} > 0;
1301 root 1.29 $self->send_command ("pickup $::CFG->{pickup}");
1302 elmex 1.3 }
1303    
1304 root 1.32 sub lookat {
1305     my ($self, $x, $y) = @_;
1306    
1307     if ($self->{cfplus_ext}) {
1308 root 1.128 $self->send_ext_req (lookat => $x, $y, sub {
1309     my (%msg) = @_;
1310 root 1.32
1311 root 1.128 if (exists $msg{npc_dialog}) {
1312 root 1.32 # start npc chat dialog
1313 root 1.69 $self->{npc_dialog} = new CFPlus::NPCDialog::
1314 root 1.128 token => $msg{npc_dialog},
1315     title => "$msg{npc_dialog}[0] (NPC)",
1316 root 1.32 conn => $self,
1317     ;
1318     }
1319     });
1320     }
1321    
1322     $self->send ("lookat $x $y");
1323     }
1324    
1325     sub destroy {
1326     my ($self) = @_;
1327    
1328 root 1.79 (delete $self->{npc_dialog})->destroy
1329 root 1.32 if $self->{npc_dialog};
1330    
1331     $self->SUPER::destroy;
1332 root 1.111
1333     %$self = ();
1334 root 1.32 }
1335    
1336 root 1.69 package CFPlus::NPCDialog;
1337 root 1.32
1338 root 1.76 our @ISA = 'CFPlus::UI::Toplevel';
1339 root 1.32
1340     sub new {
1341     my $class = shift;
1342    
1343     my $self = $class->SUPER::new (
1344     x => 'center',
1345     y => 'center',
1346     name => "npc_dialog",
1347     force_w => $::WIDTH * 0.7,
1348     force_h => $::HEIGHT * 0.7,
1349     title => "NPC Dialog",
1350     kw => { hi => 0, yes => 0, no => 0 },
1351 root 1.64 has_close_button => 1,
1352 root 1.32 @_,
1353     );
1354    
1355 root 1.92 CFPlus::weaken (my $this = $self);
1356 root 1.32
1357 root 1.64 $self->connect (delete => sub { $this->destroy; 1 });
1358    
1359 root 1.32 # better use a pane...
1360 root 1.69 $self->add (my $hbox = new CFPlus::UI::HBox);
1361     $hbox->add ($self->{textview} = new CFPlus::UI::TextScroller expand => 1);
1362 root 1.32
1363 root 1.69 $hbox->add (my $vbox = new CFPlus::UI::VBox);
1364 root 1.32
1365 root 1.69 $vbox->add (new CFPlus::UI::Label text => "Message Entry:");
1366     $vbox->add ($self->{entry} = new CFPlus::UI::Entry
1367 root 1.73 tooltip => "#npc_message_entry",
1368 root 1.32 on_activate => sub {
1369     my ($entry, $text) = @_;
1370    
1371     return unless $text =~ /\S/;
1372    
1373     $entry->set_text ("");
1374     $this->send ($text);
1375 root 1.38
1376     0
1377 root 1.32 },
1378     );
1379    
1380 root 1.69 $vbox->add ($self->{options} = new CFPlus::UI::VBox);
1381 root 1.32
1382 root 1.69 $self->{bye_button} = new CFPlus::UI::Button
1383 root 1.32 text => "Bye (close)",
1384     tooltip => "Use this button to end talking to the NPC. This also closes the dialog window.",
1385 root 1.64 on_activate => sub { $this->destroy; 1 },
1386 root 1.32 ;
1387    
1388     $self->update_options;
1389    
1390 root 1.128 $self->{id} = "npc-channel-" . $self->{conn}->token;
1391     $self->{conn}->connect_ext ($self->{id} => sub {
1392     $this->feed (@_) if $this;
1393     });
1394    
1395     $self->{conn}->send_ext_msg (npc_dialog_begin => $self->{id}, $self->{token});
1396 root 1.32
1397 root 1.38 $self->{entry}->grab_focus;
1398 root 1.32
1399 root 1.67 $self->{textview}->add_paragraph ({
1400     fg => [1, 1, 0, 1],
1401     markup => "<small>[starting conversation with <b>$self->{title}</b>]</small>\n\n",
1402     });
1403 root 1.32
1404     $self->show;
1405     $self
1406     };
1407    
1408     sub update_options {
1409     my ($self) = @_;
1410    
1411 root 1.92 CFPlus::weaken $self;
1412 root 1.32
1413     $self->{options}->clear;
1414 root 1.39 $self->{options}->add ($self->{bye_button});
1415 root 1.32
1416     for my $kw (sort keys %{ $self->{kw} }) {
1417 root 1.69 $self->{options}->add (new CFPlus::UI::Button
1418 root 1.32 text => $kw,
1419     on_activate => sub {
1420     $self->send ($kw);
1421 root 1.38 0
1422 root 1.32 },
1423     );
1424     }
1425     }
1426    
1427     sub feed {
1428 root 1.128 my ($self, $type, @arg) = @_;
1429 root 1.32
1430 root 1.92 CFPlus::weaken $self;
1431 root 1.42
1432 root 1.128 if ($type eq "update") {
1433     my (%info) = @arg;
1434 root 1.41
1435 root 1.128 $self->{kw}{$_} = 1 for @{$info{add_topics} || []};
1436     $self->{kw}{$_} = 0 for @{$info{del_topics} || []};
1437 root 1.32
1438 root 1.128 if (exists $info{msg}) {
1439     my $text = "\n" . CFPlus::Protocol::sanitise_xml $info{msg};
1440     my $match = join "|", map "\\b\Q$_\E\\b", sort { (length $b) <=> (length $a) } keys %{ $self->{kw} };
1441     my @link;
1442     $text =~ s{
1443     ($match)
1444     }{
1445     my $kw = $1;
1446    
1447     push @link, new CFPlus::UI::Label
1448     markup => "<span foreground='#c0c0ff' underline='single'>$kw</span>",
1449     can_hover => 1,
1450     can_events => 1,
1451     padding_x => 0,
1452     padding_y => 0,
1453     on_button_up => sub {
1454     $self->send ($kw);
1455     };
1456    
1457     "\x{fffc}"
1458     }giex;
1459    
1460     $self->{textview}->add_paragraph ({ markup => $text, widget => \@link });
1461     $self->{textview}->scroll_to_bottom;
1462     }
1463    
1464 root 1.32 $self->update_options;
1465     } else {
1466     $self->destroy;
1467     }
1468    
1469     1
1470     }
1471    
1472     sub send {
1473     my ($self, $msg) = @_;
1474    
1475 root 1.69 $self->{textview}->add_paragraph ({ markup => "\n" . CFPlus::asxml $msg });
1476 root 1.42 $self->{textview}->scroll_to_bottom;
1477 root 1.61
1478 root 1.128 $self->{conn}->send_ext_msg (npc_dialog_tell => $self->{id}, $msg);
1479 root 1.32 }
1480    
1481     sub destroy {
1482     my ($self) = @_;
1483    
1484 root 1.39 #Carp::cluck "debug\n";#d# #todo# enable: destroy gets called twice because scalar keys {} is 1
1485 root 1.32
1486 root 1.70 if ($self->{conn}) {
1487 root 1.128 $self->{conn}->send_ext_msg (npc_dialog_end => $self->{id}) if $self->{id};
1488 root 1.70 delete $self->{conn}{npc_dialog};
1489     $self->{conn}->disconnect_ext ($self->{id});
1490     }
1491 root 1.32
1492     $self->SUPER::destroy;
1493     }
1494    
1495 root 1.67 1
1496 root 1.84