server/ext/widget.ext

#! perl # mandatory depends=login

# sends the following ext message types
# ws_a       id name...                        # associate well-known widget with given id
# ws_n       ws                                # widgetset new
# ws_d       ws                                # widgetset destroy
# ws_c       ws id class @args                 # widgetset create
# w_c        id rid name @args                 # widget method call
# w_s        id @attr                          # widget member set
# w_g        id rid @attr                      # widget member get
#
# and expects the following exti message types
# w_r        rid res                           # widget call return
# w_e        id rid @args                      # widget_event

our $DEBUG = 1;

cf::client->attach (
   on_connect => sub {
      my ($ns) = @_;

      Scalar::Util::weaken (my $weakns = $ns);

      $ns->{id} = "a";
      $ns->{json_coder}->filter_json_single_key_object (__w_ => sub {
        # cannot deserialise ATM
        undef
      });
   },
);

sub csc_update_stats {
   my ($ns) = @_;

   while (my ($k, $v) = each %{ $ns->{csc}{stat} }) {
      $v->set_text ($ns->pl->ob->stats->$k);
   }
}

sub demo_start {
   my ($ns) = @_;

   my $ws = $ns->{csc} = $ns->new_widgetset;

   $ws->{tab} = $ws->new (Label => text => "dumb tst", c_tab => ["hull"]);
   
   $ws->find ("setup_notebook")->add ($ws->{tab});
   $ws->find ("setup_dialog")->toggle_visibility;
}

sub csc_start {
   my ($ns) = @_;

   my $ws = $ns->{csc} = $ns->new_widgetset;

   my $w = $ws->new (Toplevel =>
      min_w => 600,
      min_h => 400,
      x     => "center",
      y     => "center",
      title => "Character Creation",
      has_close_button => 1,
      on_delete => sub {
         $ws->destroy;
      },
   );

   $w->add (my $ntb = $ws->new (Notebook => expand => 1));

   $ntb->add_tab (Statistics => (my $stats = $ws->new (Table => expand => 1)), "Basic statistics of your new character");

   $stats->add_at (0, 0, (my $statstable = $ws->new ("Table")));

   for (
      [0, "Str"],
      [1, "Dex"],
      [2, "Con"],
      [3, "Int"],
      [4, "Wis"],
      [5, "Pow"],
      [6, "Cha"],
   ) {
      my ($x, $label) = @$_;

      $statstable->add_at ($x, 0, $ws->new (Label =>
         can_hover => 1, can_events => 1,
         align => +1, text => $label, tooltip => "#stat_$label",
      ));
      $statstable->add_at ($x, 1, $ws->{stat}{$label} = $ws->new (Label =>
         can_hover => 1, can_events => 1,
         align => +1, template => "88", tooltip => "#stat_$label",
      ));
   }

   csc_update_stats $ns;

   $ws->{tl} = $w;
   $w->show;
}

cf::player->attach (
   on_login => sub {
      my ($pl) = @_;

      return unless $cf::CFG{devel};

      my $ns = $pl->ns;

      return unless $ns->{can_widget};
      #csc_start $ns;
      demo_start $ns;
   },
);

cf::register_exticmd w_e => sub {
   my ($ns, $id, $rid, @args) = @_;

   if (my $w = $ns->{widget}{$id}) {
      if (my $cb = $w->{ev}{$rid}) {
         $cb->($w, @args);
      }
   }

   ()
};

cf::register_exticmd w_r => sub {
   my ($ns, $rid, $res) = @_;

   if (my $cb = delete $ns->{widget_return}{$rid}) {
      $cb->(@$res);
   }

   ()
};

sub cf::client::new_widgetset {
   my ($self) = @_;

   my $id = ++$self->{id};

   my $ws = bless {
      id => $id,
      ns => $self,
      _w => {},
   }, "ext::widget::set";

   $ws->msg (ws_n => $id);

   $ws
}

#############################################################################

package ext::widget::set;

sub DESTROY {
   $_[0]->destroy;
}

sub destroy {
   my ($self) = @_;

   $self->msg (ws_d => $self->{id});
   delete $self->{ns};
   $_->destroy
      for values %{ $self->{w} };
}

sub msg {
   my ($self, @msg) = @_;

   if (my $ns = shift->{ns}) {
      warn "msg " . $ns->{json_coder}->encode (\@msg) if $DEBUG;#d#
      $ns->send_packet ("ext " . $ns->{json_coder}->encode (\@msg));
   }
}

sub alloc {
   my ($self) = @_;

   my $id = ++$self->{ns}{id};

   my $proxy = bless {
      id => $id,
   }, "ext::widget::proxy";

   Scalar::Util::weaken ($proxy->{ns} = $self->{ns});
   Scalar::Util::weaken ($self->{ns}{widget}{$id} = $proxy);

   $proxy
}

sub new {
   my ($self, $class, %args) = @_;

   my $proxy = $self->alloc;

   Scalar::Util::weaken ($self->{_w}{$proxy->{id}} = $proxy);
   Scalar::Util::weaken ($proxy->{ws} = $self);

   for my $ev (grep /^on_/, keys %args) {
      my $rid = ++$self->{ns}{id};
      $proxy->{ev}{$rid} = $args{$ev};
      $args{$ev} = $rid;
   }

   $self->msg (ws_c =>
      $self->{id},
      $proxy->{id},
      $class,
      \%args,
   );

   $proxy
}

sub find {
   my ($self, @names) = @_;

   my @res;
   my @alloc;

   for my $name (@names) {
      push @res, $self->{ns}{widget_wkw}{$name} ||= do {
         my $proxy = $self->alloc;

         push @alloc, $proxy->{id} => $name;

         $proxy
      };
   }

   $self->msg (ws_a => @alloc)
      if @alloc;

   wantarray ? @res : $res[0]
}

#############################################################################

package ext::widget::proxy;

sub DESTROY {
   my ($self) = @_;

   delete $self->{ns}{widget}{$self->{id}};

   if (my $ws = $self->{ws}) {
      $self->msg (w_c => 0, "destroy");
      delete $ws->{_w}{$self->{id}};
   }
}

sub msg {
   my ($self, $type, @arg) = @_;

   if (my $ns = $self->{ns}) {
      my @msg = ($type, $self->{id}, @arg);
      warn "MSG " . $ns->{json_coder}->encode (\@msg) if $DEBUG;#d#
      $ns->send_packet ("ext " . $ns->{json_coder}->encode (\@msg));
   }
}

sub msg_cb {
   my ($self, $cb, $type, @arg) = @_;

   if (my $ws = $self->{ws}) {
      my $rid = ++$ws->{ns}{id};

      $self->msg ($type, $rid, @arg);

      if ($cb) {
         $ws->{ns}{widget_return}{$rid} = $cb;
      } else {
         # synchronous case
         my $wait = new Coro::Signal;
         my @res;

         $ws->{ns}{widget_return}{$rid} = sub {
            @res = @_;
            $wait->send;
         };
         $wait->wait;

         return @res;
      }
   }

   ()
}

sub set {
   my ($self, @kv) = @_;

   $self->msg (w_s => \@kv);
}

sub get {
   my ($self, $member, $cb) = @_;

   $self->msg_cb ($cb, w_g => [$member]);
}

sub TO_JSON {
   { __w_ => $_[0]{id} }
}

our $AUTOLOAD;

sub AUTOLOAD {
   $AUTOLOAD =~ s/^.*://
      or return;

   my $self = shift;

   #TODO: handle non-void context
   $self->msg (w_c => 0, $AUTOLOAD, @_);

   ()
}

Revision:	1.17
Committed:	Fri Aug 17 21:18:01 2007 UTC (16 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.16:	+67 -19 lines
Log Message:	- optimise widget protocol a bit (incompatible change). - implement well-known-widgets on server and client side, marginally test. - add "title" parameter for infobox.
#	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			# w_c id rid name @args # widget method call
9	root	1.10	# w_s id @attr # widget member set
10			# w_g id rid @attr # widget member get
11	root	1.1	#
12			# and expects the following exti message types
13			# w_r rid res # widget call return
14	root	1.17	# w_e id rid @args # widget_event
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	root	1.4	Scalar::Util::weaken (my $weakns = $ns);
23
24	root	1.1	$ns->{id} = "a";
25	root	1.15	$ns->{json_coder}->filter_json_single_key_object (__w_ => sub {
26	root	1.4	# cannot deserialise ATM
27			undef
28			});
29	root	1.1	},
30			);
31
32	root	1.2	sub csc_update_stats {
33			my ($ns) = @_;
34
35			while (my ($k, $v) = each %{ $ns->{csc}{stat} }) {
36			$v->set_text ($ns->pl->ob->stats->$k);
37			}
38			}
39
40	root	1.17	sub demo_start {
41			my ($ns) = @_;
42
43			my $ws = $ns->{csc} = $ns->new_widgetset;
44
45			$ws->{tab} = $ws->new (Label => text => "dumb tst", c_tab => ["hull"]);
46
47			$ws->find ("setup_notebook")->add ($ws->{tab});
48			$ws->find ("setup_dialog")->toggle_visibility;
49			}
50
51	root	1.2	sub csc_start {
52			my ($ns) = @_;
53
54			my $ws = $ns->{csc} = $ns->new_widgetset;
55
56			my $w = $ws->new (Toplevel =>
57			min_w => 600,
58			min_h => 400,
59			x => "center",
60			y => "center",
61			title => "Character Creation",
62	root	1.3	has_close_button => 1,
63			on_delete => sub {
64			$ws->destroy;
65			},
66	root	1.2	);
67
68			$w->add (my $ntb = $ws->new (Notebook => expand => 1));
69
70	root	1.17	$ntb->add_tab (Statistics => (my $stats = $ws->new (Table => expand => 1)), "Basic statistics of your new character");
71	root	1.2
72	root	1.17	$stats->add_at (0, 0, (my $statstable = $ws->new ("Table")));
73	root	1.2
74			for (
75	root	1.3	[0, "Str"],
76			[1, "Dex"],
77			[2, "Con"],
78			[3, "Int"],
79			[4, "Wis"],
80			[5, "Pow"],
81			[6, "Cha"],
82	root	1.2	) {
83	root	1.3	my ($x, $label) = @$_;
84	root	1.2
85	root	1.9	$statstable->add_at ($x, 0, $ws->new (Label =>
86	root	1.2	can_hover => 1, can_events => 1,
87			align => +1, text => $label, tooltip => "#stat_$label",
88			));
89	root	1.9	$statstable->add_at ($x, 1, $ws->{stat}{$label} = $ws->new (Label =>
90	root	1.2	can_hover => 1, can_events => 1,
91			align => +1, template => "88", tooltip => "#stat_$label",
92			));
93			}
94
95			csc_update_stats $ns;
96
97	root	1.17	$ws->{tl} = $w;
98	root	1.2	$w->show;
99			}
100
101	root	1.1	cf::player->attach (
102			on_login => sub {
103			my ($pl) = @_;
104
105	root	1.8	return unless $cf::CFG{devel};
106	root	1.1
107			my $ns = $pl->ns;
108
109	root	1.2	return unless $ns->{can_widget};
110	root	1.5	#csc_start $ns;
111	root	1.17	demo_start $ns;
112	root	1.1	},
113			);
114
115			cf::register_exticmd w_e => sub {
116	root	1.17	my ($ns, $id, $rid, @args) = @_;
117	root	1.1
118	root	1.14	if (my $w = $ns->{widget}{$id}) {
119	root	1.17	if (my $cb = $w->{ev}{$rid}) {
120			$cb->($w, @args);
121	root	1.1	}
122			}
123
124			()
125			};
126
127			cf::register_exticmd w_r => sub {
128	root	1.14	my ($ns, $rid, $res) = @_;
129	root	1.1
130	root	1.14	if (my $cb = delete $ns->{widget_return}{$rid}) {
131			$cb->(@$res);
132	root	1.1	}
133
134			()
135			};
136
137			sub cf::client::new_widgetset {
138			my ($self) = @_;
139
140			my $id = ++$self->{id};
141
142			my $ws = bless {
143			id => $id,
144			ns => $self,
145	root	1.12	_w => {},
146	root	1.1	}, "ext::widget::set";
147
148	root	1.14	$ws->msg (ws_n => $id);
149	root	1.1
150			$ws
151			}
152
153			#############################################################################
154
155			package ext::widget::set;
156
157			sub DESTROY {
158			$_[0]->destroy;
159			}
160
161			sub destroy {
162			my ($self) = @_;
163
164	root	1.14	$self->msg (ws_d => $self->{id});
165	root	1.1	delete $self->{ns};
166			$_->destroy
167			for values %{ $self->{w} };
168			}
169
170			sub msg {
171	root	1.14	my ($self, @msg) = @_;
172	root	1.1
173			if (my $ns = shift->{ns}) {
174	root	1.14	warn "msg " . $ns->{json_coder}->encode (\@msg) if $DEBUG;#d#
175			$ns->send_packet ("ext " . $ns->{json_coder}->encode (\@msg));
176	root	1.1	}
177			}
178
179	root	1.17	sub alloc {
180			my ($self) = @_;
181	root	1.1
182			my $id = ++$self->{ns}{id};
183
184	root	1.13	my $proxy = bless {
185	root	1.1	id => $id,
186			}, "ext::widget::proxy";
187
188			Scalar::Util::weaken ($proxy->{ns} = $self->{ns});
189			Scalar::Util::weaken ($self->{ns}{widget}{$id} = $proxy);
190
191	root	1.17	$proxy
192			}
193
194			sub new {
195			my ($self, $class, %args) = @_;
196
197			my $proxy = $self->alloc;
198
199			Scalar::Util::weaken ($self->{_w}{$proxy->{id}} = $proxy);
200			Scalar::Util::weaken ($proxy->{ws} = $self);
201
202	root	1.1	for my $ev (grep /^on_/, keys %args) {
203	root	1.17	my $rid = ++$self->{ns}{id};
204			$proxy->{ev}{$rid} = $args{$ev};
205			$args{$ev} = $rid;
206	root	1.1	}
207
208			$self->msg (ws_c =>
209	root	1.16	$self->{id},
210	root	1.17	$proxy->{id},
211	root	1.14	$class,
212			\%args,
213	root	1.1	);
214
215			$proxy
216			}
217
218	root	1.17	sub find {
219			my ($self, @names) = @_;
220
221			my @res;
222			my @alloc;
223
224			for my $name (@names) {
225			push @res, $self->{ns}{widget_wkw}{$name} \|\|= do {
226			my $proxy = $self->alloc;
227
228			push @alloc, $proxy->{id} => $name;
229
230			$proxy
231			};
232			}
233
234			$self->msg (ws_a => @alloc)
235			if @alloc;
236
237			wantarray ? @res : $res[0]
238			}
239
240	root	1.1	#############################################################################
241
242			package ext::widget::proxy;
243
244			sub DESTROY {
245			my ($self) = @_;
246
247			delete $self->{ns}{widget}{$self->{id}};
248
249			if (my $ws = $self->{ws}) {
250	root	1.14	$self->msg (w_c => 0, "destroy");
251	root	1.12	delete $ws->{_w}{$self->{id}};
252	root	1.1	}
253			}
254
255			sub msg {
256	root	1.14	my ($self, $type, @arg) = @_;
257	root	1.1
258	root	1.17	if (my $ns = $self->{ns}) {
259			my @msg = ($type, $self->{id}, @arg);
260			warn "MSG " . $ns->{json_coder}->encode (\@msg) if $DEBUG;#d#
261			$ns->send_packet ("ext " . $ns->{json_coder}->encode (\@msg));
262	root	1.1	}
263			}
264
265			sub msg_cb {
266	root	1.14	my ($self, $cb, $type, @arg) = @_;
267	root	1.1
268			if (my $ws = $self->{ws}) {
269			my $rid = ++$ws->{ns}{id};
270
271	root	1.14	$self->msg ($type, $rid, @arg);
272	root	1.1
273			if ($cb) {
274			$ws->{ns}{widget_return}{$rid} = $cb;
275			} else {
276			# synchronous case
277			my $wait = new Coro::Signal;
278			my @res;
279
280			$ws->{ns}{widget_return}{$rid} = sub {
281			@res = @_;
282			$wait->send;
283			};
284			$wait->wait;
285
286			return @res;
287			}
288			}
289
290			()
291			}
292
293			sub set {
294	root	1.12	my ($self, @kv) = @_;
295	root	1.1
296	root	1.14	$self->msg (w_s => \@kv);
297	root	1.1	}
298
299			sub get {
300			my ($self, $member, $cb) = @_;
301
302	root	1.14	$self->msg_cb ($cb, w_g => [$member]);
303	root	1.1	}
304
305			sub TO_JSON {
306	root	1.15	{ __w_ => $_[0]{id} }
307	root	1.1	}
308
309			our $AUTOLOAD;
310
311			sub AUTOLOAD {
312			$AUTOLOAD =~ s/^.*://
313			or return;
314
315			my $self = shift;
316
317	root	1.17	#TODO: handle non-void context
318			$self->msg (w_c => 0, $AUTOLOAD, @_);
319	root	1.1
320			()
321			}
322