ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/ext/widget.ext
Revision: 1.23
Committed: Sat Dec 29 21:07:23 2007 UTC (16 years, 4 months ago) by root
Branch: MAIN
Changes since 1.22: +51 -47 lines
Log Message:
work around perl 5.8 bug

File Contents

# User Rev Content
1 root 1.1 #! perl # mandatory depends=login
2    
3     # sends the following ext message types
4 root 1.17 # ws_a id name... # associate well-known widget with given id
5 root 1.14 # ws_n ws # widgetset new
6     # ws_d ws # widgetset destroy
7 root 1.17 # ws_c ws id class @args # widgetset create
8 root 1.21 # ws_ct ws ttype ttext done_cb \%cfg # widgetset create from template
9 root 1.17 # w_c id rid name @args # widget method call
10 root 1.10 # w_s id @attr # widget member set
11     # w_g id rid @attr # widget member get
12 root 1.1 #
13     # and expects the following exti message types
14 root 1.19 # w_e id @args # widget_call
15 root 1.1
16 root 1.13 our $DEBUG = 1;
17    
18 root 1.1 cf::client->attach (
19     on_connect => sub {
20     my ($ns) = @_;
21    
22     $ns->{id} = "a";
23 root 1.19 $ns->{json_coder}->filter_json_single_key_object ("\fw" => sub {
24 root 1.23 $ns->{widget}{$_[0]}
25 root 1.4 });
26 root 1.23
27     cf::weaken $ns;
28 root 1.1 },
29     );
30    
31 root 1.2 sub csc_update_stats {
32     my ($ns) = @_;
33    
34     while (my ($k, $v) = each %{ $ns->{csc}{stat} }) {
35     $v->set_text ($ns->pl->ob->stats->$k);
36     }
37     }
38    
39 root 1.21 my $cg_template = eval <<EOF;
40     [
41     Toplevel => {
42     s_id => "toplevel",
43     title => "Character Creation",
44     x => "center",
45     y => "center",
46     z => 5,
47     force_w => 760,
48     force_h => 440,
49     s_cl => [VBox => { s_cl => [
50     Label => {
51     text => "Character Creation",
52     fontsize => 1,
53     align => 0,
54     },
55     Label => {
56     markup => "View or Edit your character attributes below, then press <b>Finish</b> to create your character",
57     fontsize => 0.8,
58     align => 0,
59     },
60     HBox => { s_cl => [
61     Face => {
62     s_id => "face",
63     face => 0,
64     bg => [.2, .2, .2, 1],
65     min_w => 64,
66     min_h => 64,
67     },
68     Label => {
69     s_id => "desc",
70     fontsize => 0.8,
71     ellipsize => 0,
72     },
73     ]},
74     Notebook => {
75     expand => 1,
76     s_cl => [
77     Table => {
78     c_tab => ["Basics", "Title, background and other information of your character."],
79     },
80     Table => {
81     c_tab => ["Stats", "Your character's primary stats such as strength, dexterity and so on."],
82     },
83     Table => {
84     c_tab => ["Race", "Your character's race."],
85     },
86     Table => {
87     c_tab => ["Class", "Your character's initial class."],
88     },
89     ],
90     },
91     Button => {
92     s_id => "finish",
93     text => "Finish",
94     },
95     ]}],
96     },
97     ]
98     EOF
99     die if $@;
100    
101 root 1.2 sub csc_start {
102     my ($ns) = @_;
103    
104     my $ws = $ns->{csc} = $ns->new_widgetset;
105    
106     my $w = $ws->new (Toplevel =>
107     min_w => 600,
108     min_h => 400,
109     x => "center",
110     y => "center",
111     title => "Character Creation",
112 root 1.3 has_close_button => 1,
113     on_delete => sub {
114     $ws->destroy;
115     },
116 root 1.2 );
117    
118     $w->add (my $ntb = $ws->new (Notebook => expand => 1));
119    
120 root 1.17 $ntb->add_tab (Statistics => (my $stats = $ws->new (Table => expand => 1)), "Basic statistics of your new character");
121 root 1.2
122 root 1.17 $stats->add_at (0, 0, (my $statstable = $ws->new ("Table")));
123 root 1.2
124     for (
125 root 1.3 [0, "Str"],
126     [1, "Dex"],
127     [2, "Con"],
128     [3, "Int"],
129     [4, "Wis"],
130     [5, "Pow"],
131     [6, "Cha"],
132 root 1.2 ) {
133 root 1.3 my ($x, $label) = @$_;
134 root 1.2
135 root 1.9 $statstable->add_at ($x, 0, $ws->new (Label =>
136 root 1.2 can_hover => 1, can_events => 1,
137     align => +1, text => $label, tooltip => "#stat_$label",
138     ));
139 root 1.9 $statstable->add_at ($x, 1, $ws->{stat}{$label} = $ws->new (Label =>
140 root 1.2 can_hover => 1, can_events => 1,
141     align => +1, template => "88", tooltip => "#stat_$label",
142     ));
143     }
144    
145     csc_update_stats $ns;
146    
147 root 1.17 $ws->{tl} = $w;
148 root 1.2 $w->show;
149 root 1.22
150     # my ($tl, $entry) = $ws->template (inline => $cg_template,
151     # [
152     # toplevel => {},
153     # entry => {
154     # text => "xyz",
155     # on_changed => sub {
156     # warn "changed<@_>\n";#d#
157     # },
158     # },
159     # ],
160     # );
161     #
162     # $tl->show;
163     #
164     # $ns->{xxxw} = [$tl, $entry];#d#
165     #
166     # $ws->find ("setup_notebook")->add ($ws->{tab});
167     # $ws->find ("setup_dialog")->toggle_visibility;
168 root 1.2 }
169    
170 root 1.1 cf::player->attach (
171     on_login => sub {
172     my ($pl) = @_;
173    
174 root 1.22 my $ns = $pl->ns;
175     return unless $ns->{can_widget};
176    
177 root 1.8 return unless $cf::CFG{devel};
178 root 1.1
179 root 1.5 #csc_start $ns;
180 root 1.1 },
181     );
182    
183     cf::register_exticmd w_e => sub {
184 root 1.19 my ($ns, $id, @args) = @_;
185 root 1.1
186 root 1.19 if (my $cb = $ns->{widget_cb}{$id}) {
187     $cb->(@args);
188 root 1.1 }
189    
190     ()
191     };
192    
193     sub cf::client::new_widgetset {
194     my ($self) = @_;
195    
196     my $id = ++$self->{id};
197    
198     my $ws = bless {
199     id => $id,
200     ns => $self,
201 root 1.12 _w => {},
202 root 1.1 }, "ext::widget::set";
203    
204 root 1.23 cf::weaken $ws->{ns};
205    
206 root 1.14 $ws->msg (ws_n => $id);
207 root 1.1
208     $ws
209     }
210    
211 root 1.19 sub cf::client::alloc_wid {
212     pop @{ $_[0]{ids} }
213     or ++$_[0]{id}
214     }
215    
216     sub cf::client::free_wid {
217     push @{ $_[0]{ids} }, $_[1];
218     }
219    
220 root 1.1 #############################################################################
221    
222     package ext::widget::set;
223    
224     sub DESTROY {
225     $_[0]->destroy;
226     }
227    
228     sub destroy {
229     my ($self) = @_;
230    
231 root 1.14 $self->msg (ws_d => $self->{id});
232 root 1.1 delete $self->{ns};
233     $_->destroy
234     for values %{ $self->{w} };
235     }
236    
237     sub msg {
238 root 1.14 my ($self, @msg) = @_;
239 root 1.1
240     if (my $ns = shift->{ns}) {
241 root 1.14 warn "msg " . $ns->{json_coder}->encode (\@msg) if $DEBUG;#d#
242     $ns->send_packet ("ext " . $ns->{json_coder}->encode (\@msg));
243 root 1.1 }
244     }
245    
246 root 1.17 sub alloc {
247     my ($self) = @_;
248 root 1.1
249 root 1.19 my $id = $self->{ns}->alloc_wid;
250 root 1.1
251 root 1.13 my $proxy = bless {
252 root 1.1 id => $id,
253     }, "ext::widget::proxy";
254    
255     Scalar::Util::weaken ($proxy->{ns} = $self->{ns});
256     Scalar::Util::weaken ($self->{ns}{widget}{$id} = $proxy);
257    
258 root 1.17 $proxy
259     }
260    
261     sub new {
262     my ($self, $class, %args) = @_;
263    
264     my $proxy = $self->alloc;
265    
266 root 1.23 cf::weaken
267     +($self->{_w}{$proxy->{id}} = $proxy),
268     +($proxy->{ws} = $self);
269 root 1.17
270 root 1.1 for my $ev (grep /^on_/, keys %args) {
271 root 1.19 $args{$ev} = $proxy->{"_$ev"} = $proxy->cb ($args{$ev});
272 root 1.1 }
273    
274     $self->msg (ws_c =>
275 root 1.16 $self->{id},
276 root 1.17 $proxy->{id},
277 root 1.14 $class,
278     \%args,
279 root 1.1 );
280    
281     $proxy
282     }
283    
284 root 1.20 sub template {
285 root 1.21 my ($self, $type, $template, $args, $done_cb) = @_;
286 root 1.20
287     my %cfg;
288    
289 root 1.21 while (@$args) {
290     my ($name, $args) = splice @$args, 0, 2, ();
291 root 1.20
292     my $proxy = $self->alloc;
293    
294 root 1.22 $self->{delete $args->{alias} or $name} = $proxy;
295    
296 root 1.23 cf::weaken
297     +($self->{_w}{$proxy->{id}} = $proxy),
298     +($proxy->{ws} = $self);
299 root 1.20
300     for my $ev (grep /^on_/, keys %$args) {
301     $args->{$ev} = $proxy->{"_$ev"} = $proxy->cb ($args->{$ev});
302     }
303    
304     $cfg{$name} = {
305     %$args,
306     id => $proxy->{id},
307     };
308     }
309    
310 root 1.21 if ($done_cb) {
311     my $proxy = $self->alloc;
312     my $ocb = $done_cb;
313     $done_cb = $proxy->cb (sub {
314     undef $proxy;
315     undef $done_cb;
316     &$ocb
317     });
318     }
319    
320 root 1.22 if ($type eq "face") {
321     $self->{ns}->send_face ($template, 100);
322     $self->{ns}->flush_fx;
323     }
324    
325 root 1.20 $self->msg (ws_ct =>
326     $self->{id},
327 root 1.21 $type => $template,
328     $done_cb,
329 root 1.20 \%cfg,
330     );
331     }
332    
333 root 1.17 sub find {
334     my ($self, @names) = @_;
335    
336     my @res;
337     my @alloc;
338    
339     for my $name (@names) {
340     push @res, $self->{ns}{widget_wkw}{$name} ||= do {
341     my $proxy = $self->alloc;
342    
343     push @alloc, $proxy->{id} => $name;
344    
345     $proxy
346     };
347     }
348    
349     $self->msg (ws_a => @alloc)
350     if @alloc;
351    
352     wantarray ? @res : $res[0]
353     }
354    
355 root 1.1 #############################################################################
356    
357     package ext::widget::proxy;
358    
359     sub msg {
360 root 1.14 my ($self, $type, @arg) = @_;
361 root 1.1
362 root 1.17 if (my $ns = $self->{ns}) {
363     my @msg = ($type, $self->{id}, @arg);
364     warn "MSG " . $ns->{json_coder}->encode (\@msg) if $DEBUG;#d#
365     $ns->send_packet ("ext " . $ns->{json_coder}->encode (\@msg));
366 root 1.1 }
367     }
368    
369     sub msg_cb {
370 root 1.14 my ($self, $cb, $type, @arg) = @_;
371 root 1.1
372     if (my $ws = $self->{ws}) {
373 root 1.19 my $rid = $ws->{ns}->alloc_wid;
374 root 1.1
375 root 1.19 if ($cb) {
376     $ws->{ns}{widget_cb}{$rid} = sub {
377     delete $ws->{ns}{widget_cb}{$rid};
378     $ws->{ns}->free_wid ($rid);
379     &$cb
380     };
381 root 1.1
382 root 1.19 $self->msg ($type, $rid, @arg);
383 root 1.1 } else {
384     # synchronous case
385     my $wait = new Coro::Signal;
386     my @res;
387    
388 root 1.19 $ws->{ns}{widget_cb}{$rid} = sub {
389     delete $ws->{ns}{widget_cb}{$rid};
390     $ws->{ns}->free_wid ($rid);
391    
392 root 1.1 @res = @_;
393     $wait->send;
394     };
395 root 1.19 $self->msg ($type, $rid, @arg);
396 root 1.1 $wait->wait;
397    
398     return @res;
399     }
400     }
401    
402     ()
403     }
404    
405 root 1.23 sub DESTROY {
406     my ($self) = @_;
407    
408     delete $self->{ns}{widget}{$self->{id}};
409    
410     if (my $ws = $self->{ws}) {
411     $self->msg (w_c => 0, "destroy");
412     delete $ws->{_w}{$self->{id}};
413     }
414     }
415    
416     sub cb {
417     my ($self, $cb) = @_;
418    
419     my $proxy = bless {
420     ns => $self->{ns},
421     id => $self->{ns}->alloc_wid,
422     }, "ext::widget::callback";
423    
424     cf::weaken $proxy->{ns};
425    
426     $self->{ns}{widget_cb}{$proxy->{id}} = $cb;
427    
428     $proxy
429     }
430    
431     sub oneshot_cb {
432     my ($self, $cb) = @_;
433    
434     if ("CODE" eq ref $cb) {
435     my $ocb = $cb;
436     $cb = cb $self, sub {
437     undef $cb;
438     &$ocb
439     };
440     }
441    
442     $cb
443     }
444    
445 root 1.1 sub set {
446 root 1.12 my ($self, @kv) = @_;
447 root 1.1
448 root 1.14 $self->msg (w_s => \@kv);
449 root 1.1 }
450    
451     sub get {
452     my ($self, $member, $cb) = @_;
453    
454 root 1.19 $self->msg_cb ($cb, w_g => ref $member ? @$member : $member);
455 root 1.1 }
456    
457     sub TO_JSON {
458 root 1.19 { "\fw" => $_[0]{id} }
459 root 1.1 }
460    
461     our $AUTOLOAD;
462    
463     sub AUTOLOAD {
464     $AUTOLOAD =~ s/^.*://
465     or return;
466    
467     my $self = shift;
468    
469 root 1.17 #TODO: handle non-void context
470     $self->msg (w_c => 0, $AUTOLOAD, @_);
471 root 1.1
472     ()
473     }
474    
475 root 1.19 package ext::widget::callback;
476    
477     sub DESTROY {
478     my ($self) = @_;
479    
480     if (my $ns = $self->{ns}) {
481     delete $ns->{widget_cb}{$self->{id}};
482     $ns->free_wid ($self->{id});
483     }
484     }
485    
486     sub TO_JSON {
487     { "\fc" => $_[0]{id} }
488     }
489