ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/ext/widget.ext
Revision: 1.1
Committed: Mon Jun 25 05:43:53 2007 UTC (17 years ago) by root
Branch: MAIN
Log Message:
first round of implementing server-side widgets. the framework is there, but hasn't been used for anything realistic yet, so likely not yet fully usable

File Contents

# User Rev Content
1 root 1.1 #! perl # mandatory depends=login
2    
3     # sends the following ext message types
4     # ws_n id # widgetset new
5     # ws_d id # widgetset destroy
6     # ws_c ws id class args # widgetset create
7     # w_c id [rid] name args # widget method call
8     # w_s id name value # widget member set
9     # w_g id rid name # widget member get
10     #
11     # and expects the following exti message types
12     # w_r rid res # widget call return
13     # w_e id name args # widget_event
14    
15     cf::client->attach (
16     on_connect => sub {
17     my ($ns) = @_;
18    
19     $ns->{id} = "a";
20     },
21     );
22    
23     cf::player->attach (
24     on_login => sub {
25     my ($pl) = @_;
26    
27     #DEMO CODE
28     return unless $pl->ob->name eq "schmorp";
29    
30     my $ns = $pl->ns;
31    
32     return unless $ns->{can_widgetx};
33    
34     my $ws = $ns->new_widgetset;
35    
36     $ns->async (sub {
37     Coro::Timer::sleep 20;
38     warn "undef\n";#d#
39     undef $ws;#
40     });#d#
41    
42     my $w = $ws->new (Toplevel =>
43     x => "center",
44     y => "center",
45     title => "Server Query",
46     has_close_button => 1,
47     on_delete => sub {
48     warn "i was being d-e-l-e-t-e-d\n";
49     },
50     );
51    
52     $w->add ($ws->new (Entry =>
53     on_changed => sub {
54     warn "i was changed<@_>\n";
55     }
56     ));
57    
58     $ns->async (sub {
59     warn $w->get ("parent");
60     });
61    
62     $w->show;
63    
64     },
65     );
66    
67     cf::register_exticmd w_e => sub {
68     my ($ns, $pkt) = @_;
69    
70     if (my $w = $ns->{widget}{$pkt->{id}}) {
71     if (my $cb = $w->{ev}{$pkt->{name}}) {
72     $_->($w, @{ $pkt->{args} || [] })
73     for @$cb;
74     }
75     }
76    
77     ()
78     };
79    
80     cf::register_exticmd w_r => sub {
81     my ($ns, $pkt) = @_;
82    
83     if (my $cb = delete $ns->{widget_return}{$pkt->{rid}}) {
84     $cb->(@{$pkt->{res} || [] });
85     }
86    
87     ()
88     };
89    
90     sub cf::client::new_widgetset {
91     my ($self) = @_;
92    
93     my $id = ++$self->{id};
94    
95     my $ws = bless {
96     id => $id,
97     ns => $self,
98     w => {},
99     }, "ext::widget::set";
100    
101     $ws->msg (ws_n => id => $id);
102    
103     $ws
104     }
105    
106     #############################################################################
107    
108     package ext::widget::set;
109    
110     sub DESTROY {
111     $_[0]->destroy;
112     }
113    
114     sub destroy {
115     my ($self) = @_;
116    
117     $self->msg (ws_d => id => $self->{id});
118     delete $self->{ns};
119     $_->destroy
120     for values %{ $self->{w} };
121     }
122    
123     sub msg {
124     my ($self, $type, %msg) = @_;
125    
126     if (my $ns = shift->{ns}) {
127     $msg{msgtype} = $type;
128     $ns->send_packet ("ext " . cf::to_json \%msg);
129     }
130     }
131    
132     sub new {
133     my ($self, $class, %args) = @_;
134    
135     my $id = ++$self->{ns}{id};
136    
137     my $proxy = $self->{w}{$id} = bless {
138     id => $id,
139     }, "ext::widget::proxy";
140    
141     Scalar::Util::weaken ($proxy->{ws} = $self);
142     Scalar::Util::weaken ($proxy->{ns} = $self->{ns});
143     Scalar::Util::weaken ($self->{ns}{widget}{$id} = $proxy);
144    
145     for my $ev (grep /^on_/, keys %args) {
146     push @{$proxy->{ev}{$ev}}, $args{$ev};
147     $args{$ev} = 0;
148     }
149    
150     $self->msg (ws_c =>
151     ws => $self->{w}{id},
152     id => $id,
153     class => $class,
154     args => \%args,
155     );
156    
157     $proxy
158     }
159    
160     #############################################################################
161    
162     package ext::widget::proxy;
163    
164     sub DESTROY {
165     my ($self) = @_;
166    
167     delete $self->{ns}{widget}{$self->{id}};
168    
169     if (my $ws = $self->{ws}) {
170     delete $ws->{w}{$self->{id}};
171     $self->msg (w_c => name => "destroy");
172     }
173     }
174    
175     sub msg {
176     my ($self, $type, %msg) = @_;
177    
178     if (my $ws = $self->{ws}) {
179     $ws->msg ($type,
180     %msg,
181     id => $self->{id},
182     );
183     }
184     }
185    
186     sub msg_cb {
187     my ($self, $cb, $type, %msg) = @_;
188    
189     if (my $ws = $self->{ws}) {
190    
191     my $rid = ++$ws->{ns}{id};
192    
193     $self->msg ($type, %msg, rid => $rid);
194    
195     if ($cb) {
196     $ws->{ns}{widget_return}{$rid} = $cb;
197     } else {
198     # synchronous case
199     my $wait = new Coro::Signal;
200     my @res;
201    
202     $ws->{ns}{widget_return}{$rid} = sub {
203     @res = @_;
204     $wait->send;
205     };
206     $wait->wait;
207    
208     return @res;
209     }
210     }
211    
212     ()
213     }
214    
215     sub set {
216     my ($self, $member, $value) = @_;
217    
218     $self->msg (w_s => name => $member, value => $value);
219     }
220    
221     sub get {
222     my ($self, $member, $cb) = @_;
223    
224     $self->msg_cb ($cb, w_g => name => $member);
225     }
226    
227     sub TO_JSON {
228     { __widget_ref__ => $_[0]{id} }
229     }
230    
231     our $AUTOLOAD;
232    
233     sub AUTOLOAD {
234     $AUTOLOAD =~ s/^.*://
235     or return;
236    
237     my $self = shift;
238    
239     $self->msg (w_c => name => $AUTOLOAD, args => \@_);
240    
241     ()
242     }
243