ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/deliantra/Deliantra-Client/DC/UI.pm

Comparing deliantra/Deliantra-Client/DC/UI.pm (file contents):
Revision 1.214 by root, Wed May 17 22:59:13 2006 UTC vs.
Revision 1.307 by root, Sun Jun 18 19:13:20 2006 UTC

…		…
3	use utf8;	3	use utf8;
4	use strict;	4	use strict;
5		5
6	use Scalar::Util ();	6	use Scalar::Util ();
7	use List::Util ();	7	use List::Util ();
		8	use Event;
8		9
9	use CFClient;	10	use CFClient;
		11	use CFClient::Texture;
10		12
11	our ($FOCUS, $HOVER, $GRAB); # various widgets	13	our ($FOCUS, $HOVER, $GRAB); # various widgets
12		14
		15	our $LAYOUT;
13	our $ROOT;	16	our $ROOT;
14	our $TOOLTIP;	17	our $TOOLTIP;
15	our $BUTTON_STATE;	18	our $BUTTON_STATE;
16		19
17	our %WIDGET; # all widgets, weak-referenced	20	our %WIDGET; # all widgets, weak-referenced
18		21
19	sub check_tooltip {	22	our $TOOLTIP_WATCHER = Event->idle (min => 1/60, cb => sub {
20	if (!$GRAB) {	23	if (!$GRAB) {
21	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {	24	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {
22	if (length $widget->{tooltip}) {	25	if (length $widget->{tooltip}) {
23
24	if ($TOOLTIP->{owner} != $widget) {	26	if ($TOOLTIP->{owner} != $widget) {
		27	$TOOLTIP->hide;
		28
25	$TOOLTIP->{owner} = $widget;	29	$TOOLTIP->{owner} = $widget;
		30
		31	return if $ENV{CFPLUS_DEBUG} & 8;
26		32
27	my $tip = $widget->{tooltip};	33	my $tip = $widget->{tooltip};
28		34
29	$tip = $tip->($widget) if CODE:: eq ref $tip;	35	$tip = $tip->($widget) if CODE:: eq ref $tip;
30		36
31	$TOOLTIP->set_tooltip_from ($widget);	37	$TOOLTIP->set_tooltip_from ($widget);
32	$TOOLTIP->show;	38	$TOOLTIP->show;
33
34	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
35
36	($x, $y) = $widget->coord2global (-$TOOLTIP->{w}, 0)
37	if $x + $TOOLTIP->{w} > $::WIDTH;
38
39	$TOOLTIP->move ($x, $y);
40	$TOOLTIP->check_size;
41	$TOOLTIP->update;
42	}	39	}
43		40
44	return;	41	return;
45	}	42	}
46	}	43	}
47	}	44	}
48		45
49	$TOOLTIP->hide;	46	$TOOLTIP->hide;
50	delete $TOOLTIP->{owner};	47	delete $TOOLTIP->{owner};
		48	});
		49
		50	sub get_layout {
		51	my $layout;
		52
		53	for (grep { $_->{name} } values %WIDGET) {
		54	my $win = $layout->{$_->{name}} = { };
		55
		56	$win->{x} = ($_->{x} + $_->{w} * 0.5) / $::WIDTH if $_->{x} =~ /^[0-9.]+$/;
		57	$win->{y} = ($_->{y} + $_->{h} * 0.5) / $::HEIGHT if $_->{y} =~ /^[0-9.]+$/;
		58	$win->{w} = $_->{w} / $::WIDTH if defined $_->{w};
		59	$win->{h} = $_->{h} / $::HEIGHT if defined $_->{h};
		60
		61	$win->{show} = $_->{visible} && $_->{is_toplevel};
		62	}
		63
		64	$layout
		65	}
		66
		67	sub set_layout {
		68	my ($layout) = @_;
		69
		70	$LAYOUT = $layout;
51	}	71	}
52		72
53	# class methods for events	73	# class methods for events
54	sub feed_sdl_key_down_event {	74	sub feed_sdl_key_down_event {
55	$FOCUS->emit (key_down => $_[0]) || $FOCUS->key_down ($_[0])	75	$FOCUS->emit (key_down => $_[0])
56	if $FOCUS;	76	if $FOCUS;
57	}	77	}
58		78
59	sub feed_sdl_key_up_event {	79	sub feed_sdl_key_up_event {
60	$FOCUS->emit (key_up => $_[0]) || $FOCUS->key_up ($_[0])	80	$FOCUS->emit (key_up => $_[0])
61	if $FOCUS;	81	if $FOCUS;
62	}	82	}
63		83
64	sub feed_sdl_button_down_event {	84	sub feed_sdl_button_down_event {
65	my ($ev) = @_;	85	my ($ev) = @_;
…		…
69	my $widget = $ROOT->find_widget ($x, $y);	89	my $widget = $ROOT->find_widget ($x, $y);
70		90
71	$GRAB = $widget;	91	$GRAB = $widget;
72	$GRAB->update if $GRAB;	92	$GRAB->update if $GRAB;
73		93
74	check_tooltip;	94	$TOOLTIP_WATCHER->cb->();
75	}	95	}
76		96
77	$BUTTON_STATE |= 1 << ($ev->{button} - 1);	97	$BUTTON_STATE |= 1 << ($ev->{button} - 1);
78		98
79	if ($GRAB) {	99	$GRAB->emit (button_down => $ev, $GRAB->coord2local ($x, $y))
80	($x, $y) = $GRAB->coord2local ($x, $y);	100	if $GRAB;
81	$GRAB->emit (button_down => $ev, $x, $y) || $GRAB->button_down ($ev, $x, $y);
82	}
83	}	101	}
84		102
85	sub feed_sdl_button_up_event {	103	sub feed_sdl_button_up_event {
86	my ($ev) = @_;	104	my ($ev) = @_;
87	my ($x, $y) = ($ev->{x}, $ev->{y});	105	my ($x, $y) = ($ev->{x}, $ev->{y});
88		106
89	my $widget = $GRAB || $ROOT->find_widget ($x, $y);	107	my $widget = $GRAB || $ROOT->find_widget ($x, $y);
90		108
91	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));	109	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));
92		110
93	if ($GRAB) {	111	$GRAB->emit (button_up => $ev, $GRAB->coord2local ($x, $y))
94	($x, $y) = $GRAB->coord2local ($x, $y);	112	if $GRAB;
95	$GRAB->emit (button_up => $ev, $x, $y) || $GRAB->button_up ($ev, $x, $y);
96	}
97		113
98	if (!$BUTTON_STATE) {	114	if (!$BUTTON_STATE) {
99	my $grab = $GRAB; undef $GRAB;	115	my $grab = $GRAB; undef $GRAB;
100	$grab->update if $grab;	116	$grab->update if $grab;
101	$GRAB->update if $GRAB;	117	$GRAB->update if $GRAB;
102		118
103	check_tooltip;	119	$TOOLTIP_WATCHER->cb->();
104	}	120	}
105	}	121	}
106		122
107	sub feed_sdl_motion_event {	123	sub feed_sdl_motion_event {
108	my ($ev) = @_;	124	my ($ev) = @_;
…		…
114	my $hover = $HOVER; $HOVER = $widget;	130	my $hover = $HOVER; $HOVER = $widget;
115		131
116	$hover->update if $hover && $hover->{can_hover};	132	$hover->update if $hover && $hover->{can_hover};
117	$HOVER->update if $HOVER && $HOVER->{can_hover};	133	$HOVER->update if $HOVER && $HOVER->{can_hover};
118		134
119	check_tooltip;	135	$TOOLTIP_WATCHER->start;
120	}	136	}
121		137
122	if ($HOVER) {
123	($x, $y) = $HOVER->coord2local ($x, $y);
124	$HOVER->emit (mouse_motion => $ev, $x, $y) || $HOVER->mouse_motion ($ev, $x, $y);	138	$HOVER->emit (mouse_motion => $ev, $HOVER->coord2local ($x, $y))
125	}	139	if $HOVER;
126	}	140	}
127		141
128	# convert position array to integers	142	# convert position array to integers
129	sub harmonize {	143	sub harmonize {
130	my ($vals) = @_;	144	my ($vals) = @_;
…		…
136	$rem += $_ - $i;	150	$rem += $_ - $i;
137	$_ = $i;	151	$_ = $i;
138	}	152	}
139	}	153	}
140		154
		155	sub full_refresh {
		156	# make a copy, otherwise for complains about freed values.
		157	my @widgets = values %WIDGET;
		158
		159	$_->update
		160	for @widgets;
		161	}
		162
		163	sub reconfigure_widgets {
		164	# make a copy, otherwise C<for> complains about freed values.
		165	my @widgets = values %WIDGET;
		166
		167	$_->reconfigure
		168	for @widgets;
		169	}
		170
141	# call when resolution changes etc.	171	# call when resolution changes etc.
142	sub rescale_widgets {	172	sub rescale_widgets {
143	my ($sx, $sy) = @_;	173	my ($sx, $sy) = @_;
144		174
145	# make a copy, otherwise for complains about freed values.
146	my @widgets = values %WIDGET;	175	for my $widget (values %WIDGET) {
147
148	for my $widget (@widgets) {
149	if ($widget->{toplevel}) {	176	if ($widget->{is_toplevel}) {
		177	$widget->{x} += int $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
		178	$widget->{y} += int $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
		179
150	$widget->{x} = int 0.5 + $widget->{x} * $sx if exists $widget->{x};	180	$widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/;
151	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};	181	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};
152	$widget->{req_w} = int 0.5 + $widget->{req_w} * $sx if exists $widget->{req_w};	182	$widget->{force_w} = int 0.5 + $widget->{force_w} * $sx if exists $widget->{force_w};
153	$widget->{user_w} = int 0.5 + $widget->{user_w} * $sx if exists $widget->{user_w};
154	$widget->{y} = int 0.5 + $widget->{y} * $sy if exists $widget->{y};	183	$widget->{y} = int 0.5 + $widget->{y} * $sy if $widget->{y} =~ /^[0-9.]+$/;
155	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};	184	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};
156	$widget->{req_h} = int 0.5 + $widget->{req_h} * $sy if exists $widget->{req_h};	185	$widget->{force_h} = int 0.5 + $widget->{force_h} * $sy if exists $widget->{force_h};
157	$widget->{user_h} = int 0.5 + $widget->{user_h} * $sy if exists $widget->{user_h};	186
		187	$widget->{x} -= int $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
		188	$widget->{y} -= int $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
		189
158	}	190	}
159
160	$widget->reconfigure;
161	}	191	}
		192
		193	reconfigure_widgets;
162	}	194	}
163		195
164	#############################################################################	196	#############################################################################
165		197
166	package CFClient::UI::Base;	198	package CFClient::UI::Base;
…		…
171		203
172	sub new {	204	sub new {
173	my $class = shift;	205	my $class = shift;
174		206
175	my $self = bless {	207	my $self = bless {
176	x => 0,	208	x => "center",
177	y => 0,	209	y => "center",
178	z => 0,	210	z => 0,
		211	w => undef,
		212	h => undef,
179	can_events => 1,	213	can_events => 1,
180	@_	214	@_
181	}, $class;	215	}, $class;
182		216
		217	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);
		218
183	for (keys %$self) {	219	for (keys %$self) {
184	if (/^connect_(.*)$/) {	220	if (/^on_(.*)$/) {
185	$self->connect ($1 => delete $self->{$_});	221	$self->connect ($1 => delete $self->{$_});
186	}	222	}
187	}	223	}
188		224
189	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);	225	if (my $layout = $CFClient::UI::LAYOUT->{$self->{name}}) {
		226	$self->{x} = $layout->{x} * $CFClient::UI::ROOT->{alloc_w} if exists $layout->{x};
		227	$self->{y} = $layout->{y} * $CFClient::UI::ROOT->{alloc_h} if exists $layout->{y};
		228	$self->{force_w} = $layout->{w} * $CFClient::UI::ROOT->{alloc_w} if exists $layout->{w};
		229	$self->{force_h} = $layout->{h} * $CFClient::UI::ROOT->{alloc_h} if exists $layout->{h};
		230
		231	$self->{x} -= $self->{force_w} * 0.5 if exists $layout->{x};
		232	$self->{y} -= $self->{force_h} * 0.5 if exists $layout->{y};
		233
		234	$self->show if $layout->{show};
		235	}
190		236
191	$self	237	$self
192	}	238	}
193		239
194	sub destroy {	240	sub destroy {
…		…
204	return if $self->{parent};	250	return if $self->{parent};
205		251
206	$CFClient::UI::ROOT->add ($self);	252	$CFClient::UI::ROOT->add ($self);
207	}	253	}
208		254
209	sub hide {	255	sub set_visible {
210	my ($self) = @_;	256	my ($self) = @_;
		257
		258	return if $self->{visible};
		259
		260	$self->{root} = $self->{parent}{root};
		261	$self->{visible} = $self->{parent}{visible} + 1;
		262
		263	$self->emit (visibility_change => 1);
		264
		265	$self->realloc if !exists $self->{req_w};
		266
		267	$_->set_visible for $self->children;
		268	}
		269
		270	sub set_invisible {
		271	my ($self) = @_;
		272
		273	return unless $self->{visible};
		274
		275	$_->set_invisible for $self->children;
		276
		277	delete $self->{visible};
		278	delete $self->{root};
211		279
212	undef $GRAB if $GRAB == $self;	280	undef $GRAB if $GRAB == $self;
213	undef $HOVER if $HOVER == $self;	281	undef $HOVER if $HOVER == $self;
214		282
		283	$CFClient::UI::TOOLTIP_WATCHER->cb->()
		284	if $TOOLTIP->{owner} == $self;
		285
		286	$self->emit ("focus_out");
		287	$self->emit (visibility_change => 0);
		288	}
		289
		290	sub set_visibility {
		291	my ($self, $visible) = @_;
		292
		293	return if $self->{visible} == $visible;
		294
		295	$visible ? $self->hide
		296	: $self->show;
		297	}
		298
		299	sub toggle_visibility {
		300	my ($self) = @_;
		301
		302	$self->{visible}
		303	? $self->hide
		304	: $self->show;
		305	}
		306
		307	sub hide {
		308	my ($self) = @_;
		309
		310	$self->set_invisible;
		311
215	$self->{parent}->remove ($self)	312	$self->{parent}->remove ($self)
216	if $self->{parent};	313	if $self->{parent};
217	}	314	}
218		315
219	sub move {	316	sub move_abs {
220	my ($self, $x, $y, $z) = @_;	317	my ($self, $x, $y, $z) = @_;
221		318
222	$self->{x} = int $x;	319	$self->{x} = List::Util::max 0, List::Util::min $self->{root}{w} - $self->{w}, int $x;
223	$self->{y} = int $y;	320	$self->{y} = List::Util::max 0, List::Util::min $self->{root}{h} - $self->{h}, int $y;
224	$self->{z} = $z if defined $z;	321	$self->{z} = $z if defined $z;
225		322
226	$self->update;	323	$self->update;
227	}	324	}
228		325
229	sub set_size {	326	sub set_size {
230	my ($self, $w, $h) = @_;	327	my ($self, $w, $h) = @_;
231		328
232	$self->{user_w} = $w;	329	$self->{force_w} = $w;
233	$self->{user_h} = $h;	330	$self->{force_h} = $h;
234		331
235	$self->check_size;	332	$self->realloc;
236	}	333	}
237		334
238	sub size_request {	335	sub size_request {
239	require Carp;	336	require Carp;
240	Carp::confess "size_request is abstract";	337	Carp::confess "size_request is abstract";
…		…
242		339
243	sub configure {	340	sub configure {
244	my ($self, $x, $y, $w, $h) = @_;	341	my ($self, $x, $y, $w, $h) = @_;
245		342
246	if ($self->{aspect}) {	343	if ($self->{aspect}) {
		344	my ($ow, $oh) = ($w, $h);
		345
247	my $w2 = List::Util::min $w, int $h * $self->{aspect};	346	$w = List::Util::min $w, int $h * $self->{aspect};
248	my $h2 = List::Util::min $h, int $w / $self->{aspect};	347	$h = List::Util::min $h, int $w / $self->{aspect};
249		348
250	# use alignment to adjust x, y	349	# use alignment to adjust x, y
251		350
252	$x += int +($w - $w2) * 0.5;	351	$x += int 0.5 * ($ow - $w);
253	$y += int +($h - $h2) * 0.5;	352	$y += int 0.5 * ($oh - $h);
254
255	($w, $h) = ($w2, $h2);
256	}	353	}
257		354
258	if ($self->{x} != $x || $self->{y} != $y) {	355	if ($self->{x} ne $x || $self->{y} ne $y) {
259	$self->{x} = $x;	356	$self->{x} = $x;
260	$self->{y} = $y;	357	$self->{y} = $y;
261	$self->update;	358	$self->update;
262	}	359	}
263		360
264	if ($self->{w} != $w || $self->{h} != $h) {	361	if ($self->{alloc_w} != $w || $self->{alloc_h} != $h) {
265	$CFClient::UI::ROOT->{size_alloc}{$self} = [$self, $w, $h];	362	return unless $self->{visible};
266	}
267	}
268		363
269	sub size_allocate {	364	$self->{alloc_w} = $w;
270	# nothing to be done	365	$self->{alloc_h} = $h;
271	}
272		366
273	sub reconfigure {	367	$self->{root}{size_alloc}{$self+0} = $self;
274	my ($self) = @_;	368	}
275
276	$self->check_size (1);
277	$self->update;
278	}	369	}
279		370
280	sub children {	371	sub children {
		372	# nop
		373	}
		374
		375	sub visible_children {
		376	$_[0]->children
281	}	377	}
282		378
283	sub set_max_size {	379	sub set_max_size {
284	my ($self, $w, $h) = @_;	380	my ($self, $w, $h) = @_;
285		381
286	delete $self->{max_w}; $self->{max_w} = $w if $w;	382	$self->{max_w} = int $w if defined $w;
287	delete $self->{max_h}; $self->{max_h} = $h if $h;	383	$self->{max_h} = int $h if defined $h;
		384
		385	$self->realloc;
288	}	386	}
289		387
290	sub set_tooltip {	388	sub set_tooltip {
291	my ($self, $tooltip) = @_;	389	my ($self, $tooltip) = @_;
292		390
		391	$tooltip =~ s/^\s+//;
		392	$tooltip =~ s/\s+$//;
		393
		394	return if $self->{tooltip} eq $tooltip;
		395
293	$self->{tooltip} = $tooltip;	396	$self->{tooltip} = $tooltip;
294		397
295	if ($CFClient::UI::TOOLTIP->{owner} == $self) {	398	if ($CFClient::UI::TOOLTIP->{owner} == $self) {
296	delete $CFClient::UI::TOOLTIP->{owner};	399	delete $CFClient::UI::TOOLTIP->{owner};
297	CFClient::UI::check_tooltip;	400	$CFClient::UI::TOOLTIP_WATCHER->cb->();
298	}	401	}
299	}	402	}
300		403
301	# translate global coordinates to local coordinate system	404	# translate global coordinates to local coordinate system
302	sub coord2local {	405	sub coord2local {
…		…
310	my ($self, $x, $y) = @_;	413	my ($self, $x, $y) = @_;
311		414
312	$self->{parent}->coord2global ($x + $self->{x}, $y + $self->{y})	415	$self->{parent}->coord2global ($x + $self->{x}, $y + $self->{y})
313	}	416	}
314		417
315	sub focus_in {	418	sub invoke_focus_in {
316	my ($self) = @_;	419	my ($self) = @_;
317		420
318	return if $FOCUS == $self;	421	return if $FOCUS == $self;
319	return unless $self->{can_focus};	422	return unless $self->{can_focus};
320		423
321	my $focus = $FOCUS; $FOCUS = $self;	424	my $focus = $FOCUS; $FOCUS = $self;
322		425
323	$self->emit (focus_in => $focus);
324
325	$focus->update if $focus;	426	$focus->update if $focus;
326	$FOCUS->update;	427	$FOCUS->update;
327	}
328		428
		429	0
		430	}
		431
329	sub focus_out {	432	sub invoke_focus_out {
330	my ($self) = @_;	433	my ($self) = @_;
331		434
332	return unless $FOCUS == $self;	435	return unless $FOCUS == $self;
333		436
334	my $focus = $FOCUS; undef $FOCUS;	437	my $focus = $FOCUS; undef $FOCUS;
335		438
336	$self->emit (focus_out => $focus);
337
338	$focus->update if $focus; #?	439	$focus->update if $focus; #?
339	}
340		440
		441	$::MAPWIDGET->grab_focus #d# focus mapwidget if no other widget has focus
		442	unless $FOCUS;
		443
		444	0
		445	}
		446
		447	sub grab_focus {
		448	my ($self) = @_;
		449
		450	$self->emit ("focus_in");
		451	}
		452
341	sub mouse_motion { }	453	sub invoke_mouse_motion { 1 }
342	sub button_up { }	454	sub invoke_button_up { 1 }
343	sub key_down { }	455	sub invoke_key_down { 1 }
344	sub key_up { }	456	sub invoke_key_up { 1 }
345		457
346	sub button_down {	458	sub invoke_button_down {
347	my ($self, $ev, $x, $y) = @_;	459	my ($self, $ev, $x, $y) = @_;
348		460
349	$self->focus_in;	461	$self->grab_focus;
350	}
351		462
352	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	463	1
353	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	464	}
354	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	465
355	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	466	sub connect {
356	sub z { $_[0]{z} = $_[1] if @_ > 1; $_[0]{z} }	467	my ($self, $signal, $cb) = @_;
		468
		469	push @{ $self->{signal_cb}{$signal} }, $cb;
		470	}
		471
		472	sub emit {
		473	my ($self, $signal, @args) = @_;
		474
		475	(List::Util::sum +(map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}), # before
		476	($self->can ("invoke_$signal") || sub { 1 })->($self, @args)) # closure
		477	|| ($self->{parent} && $self->{parent}->emit ($signal, @args)) # parent
		478	}
		479
		480	sub find_widget {
		481	my ($self, $x, $y) = @_;
		482
		483	return () unless $self->{can_events};
		484
		485	return $self
		486	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
		487	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
		488
		489	()
		490	}
		491
		492	sub set_parent {
		493	my ($self, $parent) = @_;
		494
		495	Scalar::Util::weaken ($self->{parent} = $parent);
		496	$self->set_visible if $parent->{visible};
		497	}
		498
		499	sub realloc {
		500	my ($self) = @_;
		501
		502	if ($self->{visible}) {
		503	return if $self->{root}{realloc}{$self+0};
		504
		505	$self->{root}{realloc}{$self+0} = $self;
		506	$self->{root}->update;
		507	} else {
		508	delete $self->{req_w};
		509	delete $self->{req_h};
		510	}
		511	}
		512
		513	sub update {
		514	my ($self) = @_;
		515
		516	$self->{parent}->update
		517	if $self->{parent};
		518	}
		519
		520	sub reconfigure {
		521	my ($self) = @_;
		522
		523	$self->realloc;
		524	$self->update;
		525	}
		526
		527	# using global variables seems a bit hacky, but passing through all drawing
		528	# functions seems pointless.
		529	our ($draw_x, $draw_y, $draw_w, $draw_h); # screen rectangle being drawn
357		530
358	sub draw {	531	sub draw {
359	my ($self) = @_;	532	my ($self) = @_;
360		533
361	return unless $self->{h} && $self->{w};	534	return unless $self->{h} && $self->{w};
		535
		536	# update screen rectangle
		537	local $draw_x = $draw_x + $self->{x};
		538	local $draw_y = $draw_y + $self->{y};
		539	local $draw_w = $draw_x + $self->{w};
		540	local $draw_h = $draw_y + $self->{h};
		541
		542	# skip widgets that are entirely outside the drawing area
		543	return if ($draw_x + $self->{w} < 0) || ($draw_x >= $draw_w)
		544	|| ($draw_y + $self->{h} < 0) || ($draw_y >= $draw_h);
362		545
363	glPushMatrix;	546	glPushMatrix;
364	glTranslate $self->{x}, $self->{y}, 0;	547	glTranslate $self->{x}, $self->{y}, 0;
365	$self->_draw;
366	glPopMatrix;
367		548
368	if ($self == $HOVER && $self->{can_hover}) {	549	if ($self == $HOVER && $self->{can_hover}) {
369	my ($x, $y) = @$self{qw(x y)};
370
371	glColor 1, 0.8, 0.5, 0.2;	550	glColor 1*0.2, 0.8*0.2, 0.5*0.2, 0.2;
372	glEnable GL_BLEND;	551	glEnable GL_BLEND;
373	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	552	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
374	glBegin GL_QUADS;	553	glBegin GL_QUADS;
375	glVertex $x , $y;
376	glVertex $x + $self->{w}, $y;
377	glVertex $x + $self->{w}, $y + $self->{h};
378	glVertex $x , $y + $self->{h};
379	glEnd;
380	glDisable GL_BLEND;
381	}
382
383	if ($ENV{PCLIENT_DEBUG}) {
384	glPushMatrix;
385	glColor 1, 1, 0, 1;
386	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;
387	glBegin GL_LINE_LOOP;
388	glVertex 0 , 0;	554	glVertex 0 , 0;
389	glVertex $self->{w}, 0;	555	glVertex $self->{w}, 0;
390	glVertex $self->{w}, $self->{h};	556	glVertex $self->{w}, $self->{h};
391	glVertex 0 , $self->{h};	557	glVertex 0 , $self->{h};
392	glEnd;	558	glEnd;
		559	glDisable GL_BLEND;
		560	}
		561
		562	if ($ENV{CFPLUS_DEBUG} & 1) {
		563	glPushMatrix;
		564	glColor 1, 1, 0, 1;
		565	glTranslate 0.375, 0.375;
		566	glBegin GL_LINE_LOOP;
		567	glVertex 0 , 0;
		568	glVertex $self->{w} - 1, 0;
		569	glVertex $self->{w} - 1, $self->{h} - 1;
		570	glVertex 0 , $self->{h} - 1;
		571	glEnd;
393	glPopMatrix;	572	glPopMatrix;
394	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;	573	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;
395	}	574	}
		575
		576	$self->_draw;
		577	glPopMatrix;
396	}	578	}
397		579
398	sub _draw {	580	sub _draw {
399	my ($self) = @_;	581	my ($self) = @_;
400		582
401	warn "no draw defined for $self\n";	583	warn "no draw defined for $self\n";
402	}	584	}
403		585
404	sub find_widget {
405	my ($self, $x, $y) = @_;
406
407	return () unless $self->{can_events};
408
409	return $self
410	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
411	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
412
413	()
414	}
415
416	sub set_parent {
417	my ($self, $parent) = @_;
418
419	Scalar::Util::weaken ($self->{parent} = $parent);
420
421	# TODO: req_w _does_change after ->reconfigure
422	$self->check_size
423	unless exists $self->{req_w};
424	}
425
426	sub check_size {
427	my ($self, $forced) = @_;
428
429	$self->{force_alloc} = 1 if $forced;
430	$CFClient::UI::ROOT->{check_size}{$self} = $self;
431	}
432
433	sub update {
434	my ($self) = @_;
435
436	$self->{parent}->update
437	if $self->{parent};
438	}
439
440	sub connect {
441	my ($self, $signal, $cb) = @_;
442
443	push @{ $self->{signal_cb}{$signal} }, $cb;
444	}
445
446	sub emit {
447	my ($self, $signal, @args) = @_;
448
449	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
450	}
451
452	sub DESTROY {	586	sub DESTROY {
453	my ($self) = @_;	587	my ($self) = @_;
454		588
455	delete $WIDGET{$self+0};	589	delete $WIDGET{$self+0};
456	#$self->deactivate;	590
		591	eval { $self->destroy };
		592	warn "exception during widget destruction: $@" if $@ & $@ != /during global destruction/;
457	}	593	}
458		594
459	#############################################################################	595	#############################################################################
460		596
461	package CFClient::UI::DrawBG;	597	package CFClient::UI::DrawBG;
…		…
486		622
487	if ($color && (@$color < 4 || $color->[3])) {	623	if ($color && (@$color < 4 || $color->[3])) {
488	my ($w, $h) = @$self{qw(w h)};	624	my ($w, $h) = @$self{qw(w h)};
489		625
490	glEnable GL_BLEND;	626	glEnable GL_BLEND;
491	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	627	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
492	glColor @$color;	628	glColor_premultiply @$color;
493		629
494	glBegin GL_QUADS;	630	glBegin GL_QUADS;
495	glVertex 0 , 0;	631	glVertex 0 , 0;
496	glVertex 0 , $h;	632	glVertex 0 , $h;
497	glVertex $w, $h;	633	glVertex $w, $h;
…		…
512	my ($class, %arg) = @_;	648	my ($class, %arg) = @_;
513	$class->SUPER::new (can_events => 0, %arg);	649	$class->SUPER::new (can_events => 0, %arg);
514	}	650	}
515		651
516	sub size_request {	652	sub size_request {
517	(0, 0)	653	my ($self) = @_;
		654
		655	($self->{w} + 0, $self->{h} + 0)
518	}	656	}
519		657
520	sub draw { }	658	sub draw { }
521		659
522	#############################################################################	660	#############################################################################
…		…
526	our @ISA = CFClient::UI::Base::;	664	our @ISA = CFClient::UI::Base::;
527		665
528	sub new {	666	sub new {
529	my ($class, %arg) = @_;	667	my ($class, %arg) = @_;
530		668
531	my $children = delete $arg{children} || [];	669	my $children = delete $arg{children};
532		670
533	my $self = $class->SUPER::new (	671	my $self = $class->SUPER::new (
534	children => [],	672	children => [],
535	can_events => 0,	673	can_events => 0,
536	%arg,	674	%arg,
537	);	675	);
		676
538	$self->add ($_) for @$children;	677	$self->add (@$children)
		678	if $children;
539		679
540	$self	680	$self
541	}	681	}
542		682
543	sub add {	683	sub add {
…		…
551	$self->{children} = [	691	$self->{children} = [
552	sort { $a->{z} <=> $b->{z} }	692	sort { $a->{z} <=> $b->{z} }
553	@{$self->{children}}, @widgets	693	@{$self->{children}}, @widgets
554	];	694	];
555		695
556	$self->check_size (1);	696	$self->realloc;
557	$self->update;
558	}	697	}
559		698
560	sub children {	699	sub children {
561	@{ $_[0]{children} }	700	@{ $_[0]{children} }
562	}	701	}
…		…
567	delete $child->{parent};	706	delete $child->{parent};
568	$child->hide;	707	$child->hide;
569		708
570	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];	709	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];
571		710
572	$self->check_size;	711	$self->realloc;
573	$self->update;
574	}	712	}
575		713
576	sub clear {	714	sub clear {
577	my ($self) = @_;	715	my ($self) = @_;
578		716
…		…
582	for (@$children) {	720	for (@$children) {
583	delete $_->{parent};	721	delete $_->{parent};
584	$_->hide;	722	$_->hide;
585	}	723	}
586		724
587	$self->check_size;	725	$self->realloc;
588	$self->update;
589	}	726	}
590		727
591	sub find_widget {	728	sub find_widget {
592	my ($self, $x, $y) = @_;	729	my ($self, $x, $y) = @_;
593		730
594	$x -= $self->{x};	731	$x -= $self->{x};
595	$y -= $self->{y};	732	$y -= $self->{y};
596		733
597	my $res;	734	my $res;
598		735
599	for (reverse @{ $self->{children} }) {	736	for (reverse $self->visible_children) {
600	$res = $_->find_widget ($x, $y)	737	$res = $_->find_widget ($x, $y)
601	and return $res;	738	and return $res;
602	}	739	}
603		740
604	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})	741	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})
…		…
625	}	762	}
626		763
627	sub add {	764	sub add {
628	my ($self, $child) = @_;	765	my ($self, $child) = @_;
629		766
630	$self->{children} = [];	767	$self->SUPER::remove ($_) for @{ $self->{children} };
631
632	$self->SUPER::add ($child);	768	$self->SUPER::add ($child);
633	}	769	}
634		770
635	sub remove {	771	sub remove {
636	my ($self, $widget) = @_;	772	my ($self, $widget) = @_;
…		…
645		781
646	sub size_request {	782	sub size_request {
647	$_[0]{children}[0]->size_request	783	$_[0]{children}[0]->size_request
648	}	784	}
649		785
650	sub size_allocate {	786	sub invoke_size_allocate {
651	my ($self, $w, $h) = @_;	787	my ($self, $w, $h) = @_;
652		788
653	$self->{children}[0]->configure (0, 0, $w, $h);	789	$self->{children}[0]->configure (0, 0, $w, $h);
		790
		791	1
654	}	792	}
655		793
656	#############################################################################	794	#############################################################################
		795
		796	# back-buffered drawing area
657		797
658	package CFClient::UI::Window;	798	package CFClient::UI::Window;
659		799
660	our @ISA = CFClient::UI::Bin::;	800	our @ISA = CFClient::UI::Bin::;
661		801
…		…
672		812
673	$ROOT->on_post_alloc ($self => sub { $self->render_child });	813	$ROOT->on_post_alloc ($self => sub { $self->render_child });
674	$self->SUPER::update;	814	$self->SUPER::update;
675	}	815	}
676		816
677	sub size_allocate {	817	sub invoke_size_allocate {
678	my ($self, $w, $h) = @_;	818	my ($self, $w, $h) = @_;
679		819
680	$self->SUPER::size_allocate ($w, $h);
681	$self->update;	820	$self->update;
		821
		822	$self->SUPER::invoke_size_allocate ($w, $h)
682	}	823	}
683		824
684	sub _render {	825	sub _render {
		826	my ($self) = @_;
		827
685	$_[0]{children}[0]->draw;	828	$self->{children}[0]->draw;
686	}	829	}
687		830
688	sub render_child {	831	sub render_child {
689	my ($self) = @_;	832	my ($self) = @_;
690		833
691	$self->{texture} = new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {	834	$self->{texture} = new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {
692	glClearColor 0, 0, 0, 0;	835	glClearColor 0, 0, 0, 0;
693	glClear GL_COLOR_BUFFER_BIT;	836	glClear GL_COLOR_BUFFER_BIT;
694		837
		838	{
		839	package CFClient::UI::Base;
		840
		841	($draw_x, $draw_y, $draw_w, $draw_h) =
		842	(0, 0, $self->{w}, $self->{h});
		843	}
		844
695	$self->_render;	845	$self->_render;
696	# glColorMask 1, 1, 1, 0;
697	# glEnable GL_BLEND;
698	# glBlendFunc GL_SRC_ALPHA, GL_ZERO;
699	# glRasterPos 0, 0;
700	# glCopyPixels 0, 0, $self->{w}, $self->{h};
701	# glDisable GL_BLEND;
702	# glColorMask 1, 1, 1, 1;
703	};	846	};
704	}	847	}
705		848
706	sub _draw {	849	sub _draw {
707	my ($self) = @_;	850	my ($self) = @_;
708		851
709	my ($w, $h) = ($self->w, $self->h);	852	my ($w, $h) = @$self{qw(w h)};
710		853
711	my $tex = $self->{texture}	854	my $tex = $self->{texture}
712	or return;	855	or return;
713		856
714	glEnable GL_TEXTURE_2D;	857	glEnable GL_TEXTURE_2D;
…		…
724		867
725	package CFClient::UI::ViewPort;	868	package CFClient::UI::ViewPort;
726		869
727	our @ISA = CFClient::UI::Window::;	870	our @ISA = CFClient::UI::Window::;
728		871
		872	sub new {
		873	my $class = shift;
		874
		875	$class->SUPER::new (
		876	scroll_x => 0,
		877	scroll_y => 1,
		878	@_,
		879	)
		880	}
		881
729	sub size_request {	882	sub size_request {
730	my ($self) = @_;	883	my ($self) = @_;
731		884
732	@$self{qw(child_w child_h)} = @{$self->child}{qw(req_w req_h)};	885	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
733	$self->child->configure (0, 0, @$self{qw(child_w child_h)});
734		886
735	@$self{qw(child_w child_h)}	887	$w = 10 if $self->{scroll_x};
736	}	888	$h = 10 if $self->{scroll_y};
737		889
		890	($w, $h)
		891	}
		892
738	sub size_allocate {	893	sub invoke_size_allocate {
739	my ($self, $w, $h) = @_;	894	my ($self, $w, $h) = @_;
740		895
		896	my $child = $self->child;
		897
		898	$w = $child->{req_w} if $self->{scroll_x} && $child->{req_w};
		899	$h = $child->{req_h} if $self->{scroll_y} && $child->{req_h};
		900
		901	$self->child->configure (0, 0, $w, $h);
741	$self->update;	902	$self->update;
		903
		904	1
742	}	905	}
743		906
744	sub set_offset {	907	sub set_offset {
745	my ($self, $x, $y) = @_;	908	my ($self, $x, $y) = @_;
746		909
…		…
779	}	942	}
780		943
781	sub _render {	944	sub _render {
782	my ($self) = @_;	945	my ($self) = @_;
783		946
		947	local $CFClient::UI::Base::draw_x = $CFClient::UI::Base::draw_x - $self->{view_x};
		948	local $CFClient::UI::Base::draw_y = $CFClient::UI::Base::draw_y - $self->{view_y};
		949
784	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};	950	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};
785		951
786	$self->SUPER::_render;	952	$self->SUPER::_render;
787	}	953	}
788		954
…		…
791	package CFClient::UI::ScrolledWindow;	957	package CFClient::UI::ScrolledWindow;
792		958
793	our @ISA = CFClient::UI::HBox::;	959	our @ISA = CFClient::UI::HBox::;
794		960
795	sub new {	961	sub new {
796	my $class = shift;	962	my ($class, %arg) = @_;
		963
		964	my $child = delete $arg{child};
797		965
798	my $self;	966	my $self;
799		967
800	my $slider = new CFClient::UI::Slider	968	my $slider = new CFClient::UI::Slider
801	vertical => 1,	969	vertical => 1,
802	range => [0, 0, 1, 0.01], # HACK fix	970	range => [0, 0, 1, 0.01], # HACK fix
803	connect_changed => sub {	971	on_changed => sub {
804	$self->{vp}->set_offset (0, $_[1] * ($self->{vp}{child_h} - $self->{vp}{h}));	972	$self->{vp}->set_offset (0, $_[1]);
805	},	973	},
806	;	974	;
807		975
808	$self = $class->SUPER::new (	976	$self = $class->SUPER::new (
809	vp => (new CFClient::UI::ViewPort),	977	vp => (new CFClient::UI::ViewPort expand => 1),
810	slider => $slider,	978	slider => $slider,
811	@_,	979	%arg,
812	);	980	);
813		981
814	$self->{vp}->add ($self->{scrolled});
815	$self->add ($self->{vp});
816	$self->add ($self->{slider});	982	$self->SUPER::add ($self->{vp}, $self->{slider});
		983	$self->add ($child) if $child;
817		984
818	$self	985	$self
		986	}
		987
		988	sub add {
		989	my ($self, $widget) = @_;
		990
		991	$self->{vp}->add ($self->{child} = $widget);
		992	}
		993
		994	sub update {
		995	my ($self) = @_;
		996
		997	$self->SUPER::update;
		998
		999	# todo: overwrite size_allocate of child
		1000	my $child = $self->{vp}->child;
		1001	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
		1002	}
		1003
		1004	sub invoke_size_allocate {
		1005	my ($self, $w, $h) = @_;
		1006
		1007	my $child = $self->{vp}->child;
		1008	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
		1009
		1010	$self->SUPER::invoke_size_allocate ($w, $h)
819	}	1011	}
820		1012
821	#TODO# update range on size_allocate depending on child	1013	#TODO# update range on size_allocate depending on child
822	# update viewport offset on scroll	1014	# update viewport offset on scroll
823		1015
…		…
843		1035
844	if ($self->{bg}) {	1036	if ($self->{bg}) {
845	my ($w, $h) = @$self{qw(w h)};	1037	my ($w, $h) = @$self{qw(w h)};
846		1038
847	glEnable GL_BLEND;	1039	glEnable GL_BLEND;
848	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1040	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
849	glColor @{ $self->{bg} };	1041	glColor_premultiply @{ $self->{bg} };
850		1042
851	glBegin GL_QUADS;	1043	glBegin GL_QUADS;
852	glVertex 0 , 0;	1044	glVertex 0 , 0;
853	glVertex 0 , $h;	1045	glVertex 0 , $h;
854	glVertex $w, $h;	1046	glVertex $w, $h;
…		…
867		1059
868	our @ISA = CFClient::UI::Bin::;	1060	our @ISA = CFClient::UI::Bin::;
869		1061
870	use CFClient::OpenGL;	1062	use CFClient::OpenGL;
871		1063
872	my @tex =	1064	my $bg =
		1065	new_from_file CFClient::Texture CFClient::find_rcfile "d1_bg.png",
		1066	mipmap => 1, wrap => 1;
		1067
		1068	my @border =
873	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }	1069	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
874	qw(d1_bg.png d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);	1070	qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
875		1071
876	sub new {	1072	sub new {
877	my $class = shift;	1073	my ($class, %arg) = @_;
878
879	# TODO: user_x, user_y, overwrite moveto?
880		1074
881	my $self = $class->SUPER::new (	1075	my $self = $class->SUPER::new (
882	bg => [1, 1, 1, 1],	1076	bg => [1, 1, 1, 1],
883	border_bg => [1, 1, 1, 1],	1077	border_bg => [1, 1, 1, 1],
884	border => 0.6,	1078	border => 0.6,
885	toplevel => 1,
886	can_events => 1,	1079	can_events => 1,
887	@_	1080	min_w => 16,
		1081	min_h => 16,
		1082	%arg,
888	);	1083	);
889		1084
890	$self->{title} &&= new CFClient::UI::Label	1085	$self->{title_widget} = new CFClient::UI::Label
891	align => 0,	1086	align => 0,
892	valign => 1,	1087	valign => 1,
893	text => $self->{title},	1088	text => $self->{title},
894	fontsize => $self->{border};	1089	fontsize => $self->{border},
		1090	if exists $self->{title};
		1091
		1092	if ($self->{has_close_button}) {
		1093	$self->{close_button} =
		1094	new CFClient::UI::ImageButton
		1095	image => 'x1_close.png',
		1096	on_activate => sub { $self->hide };
		1097
		1098	$self->CFClient::UI::Container::add ($self->{close_button});
		1099	}
895		1100
896	$self	1101	$self
		1102	}
		1103
		1104	sub add {
		1105	my ($self, @widgets) = @_;
		1106
		1107	$self->SUPER::add (@widgets);
		1108	$self->CFClient::UI::Container::add ($self->{close_button}) if $self->{close_button};
		1109	$self->CFClient::UI::Container::add ($self->{title_widget}) if $self->{title_widget};
897	}	1110	}
898		1111
899	sub border {	1112	sub border {
900	int $_[0]{border} * $::FONTSIZE	1113	int $_[0]{border} * $::FONTSIZE
901	}	1114	}
902		1115
903	sub size_request {	1116	sub size_request {
904	my ($self) = @_;	1117	my ($self) = @_;
		1118
		1119	$self->{title_widget}->size_request
		1120	if $self->{title_widget};
		1121
		1122	$self->{close_button}->size_request
		1123	if $self->{close_button};
905		1124
906	my ($w, $h) = $self->SUPER::size_request;	1125	my ($w, $h) = $self->SUPER::size_request;
907		1126
908	(	1127	(
909	$w + $self->border * 2,	1128	$w + $self->border * 2,
910	$h + $self->border * 2,	1129	$h + $self->border * 2,
911	)	1130	)
912	}	1131	}
913		1132
914	sub size_allocate {	1133	sub invoke_size_allocate {
915	my ($self, $w, $h) = @_;	1134	my ($self, $w, $h) = @_;
916		1135
		1136	if ($self->{title_widget}) {
		1137	$self->{title_widget}{w} = $w;
		1138	$self->{title_widget}{h} = $h;
		1139	$self->{title_widget}->invoke_size_allocate ($w, $h);
		1140	}
		1141
		1142	my $border = $self->border;
		1143
917	$h -= List::Util::max 0, $self->border * 2;	1144	$h -= List::Util::max 0, $border * 2;
918	$w -= List::Util::max 0, $self->border * 2;	1145	$w -= List::Util::max 0, $border * 2;
919		1146
920	$self->{title}->configure ($self->border, int $self->border - $::FONTSIZE * 2, $w, int $::FONTSIZE * 2)
921	if $self->{title};
922
923	$self->child->configure ($self->border, $self->border, $w, $h);	1147	$self->child->configure ($border, $border, $w, $h);
924	}
925		1148
		1149	$self->{close_button}->configure ($self->{w} - $border, 0, $border, $border)
		1150	if $self->{close_button};
		1151
		1152	1
		1153	}
		1154
926	sub button_down {	1155	sub invoke_button_down {
927	my ($self, $ev, $x, $y) = @_;	1156	my ($self, $ev, $x, $y) = @_;
928		1157
929	my ($w, $h) = @$self{qw(w h)};	1158	my ($w, $h) = @$self{qw(w h)};
930	my $border = $self->border;	1159	my $border = $self->border;
931		1160
…		…
944	my ($ev, $x, $y) = @_;	1173	my ($ev, $x, $y) = @_;
945		1174
946	my $dx = $ev->{x} - $ox;	1175	my $dx = $ev->{x} - $ox;
947	my $dy = $ev->{y} - $oy;	1176	my $dy = $ev->{y} - $oy;
948		1177
949	$self->{user_w} = $bw + $dx * ($mx ? -1 : 1);	1178	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
950	$self->{user_h} = $bh + $dy * ($my ? -1 : 1);	1179	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
		1180
951	$self->move ($wx + $dx * $mx, $wy + $dy * $my);	1181	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
952	$self->check_size;	1182	$self->realloc;
953	};	1183	};
954		1184
955	} elsif ($lr ^ $td) {	1185	} elsif ($lr ^ $td) {
956	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1186	my ($ox, $oy) = ($ev->{x}, $ev->{y});
957	my ($bx, $by) = ($self->{x}, $self->{y});	1187	my ($bx, $by) = ($self->{x}, $self->{y});
…		…
959	$self->{motion} = sub {	1189	$self->{motion} = sub {
960	my ($ev, $x, $y) = @_;	1190	my ($ev, $x, $y) = @_;
961		1191
962	($x, $y) = ($ev->{x}, $ev->{y});	1192	($x, $y) = ($ev->{x}, $ev->{y});
963		1193
964	$self->move ($bx + $x - $ox, $by + $y - $oy);	1194	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
965	$self->update;	1195	# HACK: the next line is required to enforce placement
		1196	$self->{parent}->invoke_size_allocate ($self->{parent}{w}, $self->{parent}{h});
966	};	1197	};
		1198	} else {
		1199	return 0;
		1200	}
		1201
967	}	1202	1
968	}	1203	}
969		1204
970	sub button_up {	1205	sub invoke_button_up {
971	my ($self, $ev, $x, $y) = @_;	1206	my ($self, $ev, $x, $y) = @_;
972		1207
973	delete $self->{motion};	1208	! ! delete $self->{motion}
974	}	1209	}
975		1210
976	sub mouse_motion {	1211	sub invoke_mouse_motion {
977	my ($self, $ev, $x, $y) = @_;	1212	my ($self, $ev, $x, $y) = @_;
978		1213
979	$self->{motion}->($ev, $x, $y) if $self->{motion};	1214	$self->{motion}->($ev, $x, $y) if $self->{motion};
		1215
		1216	! ! $self->{motion}
980	}	1217	}
981		1218
982	sub _draw {	1219	sub _draw {
983	my ($self) = @_;	1220	my ($self) = @_;
984		1221
		1222	my $child = $self->{children}[0];
		1223
985	my ($w, $h ) = ($self->{w}, $self->{h});	1224	my ($w, $h ) = ($self->{w}, $self->{h});
986	my ($cw, $ch) = ($self->child->{w}, $self->child->{h});	1225	my ($cw, $ch) = ($child->{w}, $child->{h});
987		1226
988	glEnable GL_TEXTURE_2D;	1227	glEnable GL_TEXTURE_2D;
989	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1228	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
990		1229
991	my $border = $self->border;	1230	my $border = $self->border;
992		1231
993	glColor @{ $self->{border_bg} };	1232	glColor @{ $self->{border_bg} };
994	$tex[1]->draw_quad_alpha (0, 0, $w, $border);	1233	$border[0]->draw_quad_alpha (0, 0, $w, $border);
995	$tex[3]->draw_quad_alpha (0, $border, $border, $ch);	1234	$border[1]->draw_quad_alpha (0, $border, $border, $ch);
996	$tex[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);	1235	$border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);
997	$tex[4]->draw_quad_alpha (0, $h - $border, $w, $border);	1236	$border[3]->draw_quad_alpha (0, $h - $border, $w, $border);
998		1237
999	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {	1238	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {
1000	my $bg = $tex[0];	1239	glColor @{ $self->{bg} };
1001		1240
1002	# TODO: repeat texture not scale	1241	# TODO: repeat texture not scale
		1242	# solve this better(?)
1003	my $rep_x = $cw / $bg->{w};	1243	$bg->{s} = $cw / $bg->{w};
1004	my $rep_y = $ch / $bg->{h};	1244	$bg->{t} = $ch / $bg->{h};
1005
1006	glColor @{ $self->{bg} };
1007
1008	$bg->{s} = $rep_x;
1009	$bg->{t} = $rep_y;
1010	$bg->{wrap_mode} = 1;
1011	$bg->draw_quad_alpha ($border, $border, $cw, $ch);	1245	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
1012	}	1246	}
1013		1247
1014	glDisable GL_TEXTURE_2D;	1248	glDisable GL_TEXTURE_2D;
1015		1249
1016	$self->{title}->draw if $self->{title};
1017
1018	$self->child->draw;	1250	$child->draw;
		1251
		1252	if ($self->{title_widget}) {
		1253	glTranslate 0, $border - $self->{h};
		1254	$self->{title_widget}->_draw;
		1255
		1256	glTranslate 0, - ($border - $self->{h});
		1257	}
		1258
		1259	$self->{close_button}->draw
		1260	if $self->{close_button};
1019	}	1261	}
1020		1262
1021	#############################################################################	1263	#############################################################################
1022		1264
1023	package CFClient::UI::Table;	1265	package CFClient::UI::Table;
…		…
1031	sub new {	1273	sub new {
1032	my $class = shift;	1274	my $class = shift;
1033		1275
1034	$class->SUPER::new (	1276	$class->SUPER::new (
1035	col_expand => [],	1277	col_expand => [],
1036	@_	1278	@_,
1037	)	1279	)
		1280	}
		1281
		1282	sub children {
		1283	grep $_, map @$_, grep $_, @{ $_[0]{children} }
1038	}	1284	}
1039		1285
1040	sub add {	1286	sub add {
1041	my ($self, $x, $y, $child) = @_;	1287	my ($self, $x, $y, $child) = @_;
1042		1288
1043	$child->set_parent ($self);	1289	$child->set_parent ($self);
1044	$self->{children}[$y][$x] = $child;	1290	$self->{children}[$y][$x] = $child;
1045		1291
1046	$child->check_size;	1292	$self->realloc;
1047	}	1293	}
1048		1294
1049	sub children {	1295	sub remove {
1050	grep $_, map @$_, grep $_, @{ $_[0]{children} }	1296	my ($self, $child) = @_;
1051	}
1052		1297
		1298	# TODO: not yet implemented
		1299	}
		1300
1053	# TODO: move to container class maybe? send childs a signal on removal?	1301	# TODO: move to container class maybe? send children a signal on removal?
1054	sub clear {	1302	sub clear {
1055	my ($self) = @_;	1303	my ($self) = @_;
1056		1304
1057	my @children = $self->children;	1305	my @children = $self->children;
1058	delete $self->{children};	1306	delete $self->{children};
…		…
1060	for (@children) {	1308	for (@children) {
1061	delete $_->{parent};	1309	delete $_->{parent};
1062	$_->hide;	1310	$_->hide;
1063	}	1311	}
1064		1312
1065	$self->update;	1313	$self->realloc;
1066	}	1314	}
1067		1315
1068	sub get_wh {	1316	sub get_wh {
1069	my ($self) = @_;	1317	my ($self) = @_;
1070		1318
…		…
1096	(sum @$ws),	1344	(sum @$ws),
1097	(sum @$hs),	1345	(sum @$hs),
1098	)	1346	)
1099	}	1347	}
1100		1348
1101	sub size_allocate {	1349	sub invoke_size_allocate {
1102	my ($self, $w, $h) = @_;	1350	my ($self, $w, $h) = @_;
1103		1351
1104	my ($ws, $hs) = $self->get_wh;	1352	my ($ws, $hs) = $self->get_wh;
1105		1353
1106	my $req_w = sum @$ws;	1354	my $req_w = (sum @$ws) || 1;
1107	my $req_h = sum @$hs;	1355	my $req_h = (sum @$hs) || 1;
1108		1356
1109	# TODO: nicer code && do row_expand	1357	# TODO: nicer code && do row_expand
1110	my @col_expand = @{$self->{col_expand}};	1358	my @col_expand = @{$self->{col_expand}};
1111	@col_expand = (1) x @$ws unless @col_expand;	1359	@col_expand = (1) x @$ws unless @col_expand;
1112	my $col_expand = (sum @col_expand) || 1;	1360	my $col_expand = (sum @col_expand) || 1;
…		…
1138	}	1386	}
1139		1387
1140	$y += $row_h;	1388	$y += $row_h;
1141	}	1389	}
1142		1390
		1391	1
1143	}	1392	}
1144		1393
1145	sub find_widget {	1394	sub find_widget {
1146	my ($self, $x, $y) = @_;	1395	my ($self, $x, $y) = @_;
1147		1396
…		…
1166	}	1415	}
1167	}	1416	}
1168		1417
1169	#############################################################################	1418	#############################################################################
1170		1419
		1420	package CFClient::UI::Box;
		1421
		1422	our @ISA = CFClient::UI::Container::;
		1423
		1424	sub size_request {
		1425	my ($self) = @_;
		1426
		1427	$self->{vertical}
		1428	? (
		1429	(List::Util::max map $_->{req_w}, @{$self->{children}}),
		1430	(List::Util::sum map $_->{req_h}, @{$self->{children}}),
		1431	)
		1432	: (
		1433	(List::Util::sum map $_->{req_w}, @{$self->{children}}),
		1434	(List::Util::max map $_->{req_h}, @{$self->{children}}),
		1435	)
		1436	}
		1437
		1438	sub invoke_size_allocate {
		1439	my ($self, $w, $h) = @_;
		1440
		1441	my $space = $self->{vertical} ? $h : $w;
		1442	my $children = $self->{children};
		1443
		1444	my @req;
		1445
		1446	if ($self->{homogeneous}) {
		1447	@req = ($space / (@$children || 1)) x @$children;
		1448	} else {
		1449	@req = map $_->{$self->{vertical} ? "req_h" : "req_w"}, @$children;
		1450	my $req = List::Util::sum @req;
		1451
		1452	if ($req > $space) {
		1453	# ah well, not enough space
		1454	$_ *= $space / $req for @req;
		1455	} else {
		1456	my $expand = (List::Util::sum map $_->{expand}, @$children) || 1;
		1457
		1458	$space = ($space - $req) / $expand; # remaining space to give away
		1459
		1460	$req[$_] += $space * $children->[$_]{expand}
		1461	for 0 .. $#$children;
		1462	}
		1463	}
		1464
		1465	CFClient::UI::harmonize \@req;
		1466
		1467	my $pos = 0;
		1468	for (0 .. $#$children) {
		1469	my $alloc = $req[$_];
		1470	$children->[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));
		1471
		1472	$pos += $alloc;
		1473	}
		1474
		1475	1
		1476	}
		1477
		1478	#############################################################################
		1479
1171	package CFClient::UI::HBox;	1480	package CFClient::UI::HBox;
1172		1481
1173	# TODO: wrap into common Box base class
1174
1175	our @ISA = CFClient::UI::Container::;	1482	our @ISA = CFClient::UI::Box::;
1176		1483
1177	sub size_request {	1484	sub new {
1178	my ($self) = @_;	1485	my $class = shift;
1179		1486
1180	my @alloc = map [$_->size_request], @{$self->{children}};	1487	$class->SUPER::new (
1181		1488	vertical => 0,
1182	(	1489	@_,
1183	(List::Util::sum map $_->[0], @alloc),
1184	(List::Util::max map $_->[1], @alloc),
1185	)	1490	)
1186	}	1491	}
1187		1492
1188	sub size_allocate {
1189	my ($self, $w, $h) = @_;
1190
1191	($h, $w) = ($w, $h);
1192
1193	my $children = $self->{children};
1194
1195	my @h = map $_->{req_w}, @$children;
1196
1197	my $req_h = List::Util::sum @h;
1198
1199	if ($req_h > $h) {
1200	# ah well, not enough space
1201	$_ *= $h / $req_h for @h;
1202	} else {
1203	my $exp = List::Util::sum map $_->{expand}, @$children;
1204	$exp ||= 1;
1205
1206	for (0 .. $#$children) {
1207	my $child = $children->[$_];
1208
1209	my $alloc_h = $h[$_];
1210	$alloc_h += ($h - $req_h) * $child->{expand} / $exp;
1211	$h[$_] = $alloc_h;
1212	}
1213	}
1214
1215	CFClient::UI::harmonize \@h;
1216
1217	my $y = 0;
1218	for (0 .. $#$children) {
1219	my $child = $children->[$_];
1220	my $h = $h[$_];
1221	$child->configure ($y, 0, $h, $w);
1222
1223	$y += $h;
1224	}
1225
1226	1
1227	}
1228
1229	#############################################################################	1493	#############################################################################
1230		1494
1231	package CFClient::UI::VBox;	1495	package CFClient::UI::VBox;
1232		1496
1233	# TODO: wrap into common Box base class
1234
1235	our @ISA = CFClient::UI::Container::;	1497	our @ISA = CFClient::UI::Box::;
1236		1498
1237	sub size_request {	1499	sub new {
1238	my ($self) = @_;	1500	my $class = shift;
1239		1501
1240	my @alloc = map [$_->size_request], @{$self->{children}};	1502	$class->SUPER::new (
1241		1503	vertical => 1,
1242	(	1504	@_,
1243	(List::Util::max map $_->[0], @alloc),
1244	(List::Util::sum map $_->[1], @alloc),
1245	)	1505	)
1246	}
1247
1248	sub size_allocate {
1249	my ($self, $w, $h) = @_;
1250
1251	Carp::confess "negative size" if $w < 0 || $h < 0;#d#
1252
1253	my $children = $self->{children};
1254
1255	my @h = map $_->{req_h}, @$children;
1256
1257	my $req_h = List::Util::sum @h;
1258
1259	if ($req_h > $h) {
1260	# ah well, not enough space
1261	$_ *= $h / $req_h for @h;
1262	} else {
1263	my $exp = List::Util::sum map $_->{expand}, @$children;
1264	$exp ||= 1;
1265
1266	for (0 .. $#$children) {
1267	my $child = $children->[$_];
1268
1269	$h[$_] += ($h - $req_h) * $child->{expand} / $exp;
1270	}
1271	}
1272
1273	CFClient::UI::harmonize \@h;
1274
1275	my $y = 0;
1276	for (0 .. $#$children) {
1277	my $child = $children->[$_];
1278	my $h = $h[$_];
1279	$child->configure (0, $y, $w, $h);
1280
1281	$y += $h;
1282	}
1283
1284	1
1285	}	1506	}
1286		1507
1287	#############################################################################	1508	#############################################################################
1288		1509
1289	package CFClient::UI::Label;	1510	package CFClient::UI::Label;
…		…
1306	ellipsise => 3, # end	1527	ellipsise => 3, # end
1307	layout => (new CFClient::Layout),	1528	layout => (new CFClient::Layout),
1308	fontsize => 1,	1529	fontsize => 1,
1309	align => -1,	1530	align => -1,
1310	valign => -1,	1531	valign => -1,
1311	padding => 2,	1532	padding_x => 2,
		1533	padding_y => 2,
1312	can_events => 0,	1534	can_events => 0,
1313	%arg	1535	%arg
1314	);	1536	);
1315		1537
1316	if (exists $self->{template}) {	1538	if (exists $self->{template}) {
…		…
1343		1565
1344	delete $self->{texture};	1566	delete $self->{texture};
1345	$self->SUPER::update;	1567	$self->SUPER::update;
1346	}	1568	}
1347		1569
		1570	sub realloc {
		1571	my ($self) = @_;
		1572
		1573	delete $self->{ox};
		1574	$self->SUPER::realloc;
		1575	}
		1576
1348	sub set_text {	1577	sub set_text {
1349	my ($self, $text) = @_;	1578	my ($self, $text) = @_;
1350		1579
1351	return if $self->{text} eq "T$text";	1580	return if $self->{text} eq "T$text";
1352	$self->{text} = "T$text";	1581	$self->{text} = "T$text";
1353		1582
1354	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;	1583	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1355	$self->{layout}->set_text ($text);	1584	$self->{layout}->set_text ($text);
1356		1585
		1586	delete $self->{size_req};
		1587	$self->realloc;
1357	$self->update;	1588	$self->update;
1358	$self->check_size;
1359	}	1589	}
1360		1590
1361	sub set_markup {	1591	sub set_markup {
1362	my ($self, $markup) = @_;	1592	my ($self, $markup) = @_;
1363		1593
…		…
1367	my $rgba = $markup =~ /span.*(?:foreground|background)/;	1597	my $rgba = $markup =~ /span.*(?:foreground|background)/;
1368		1598
1369	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;	1599	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;
1370	$self->{layout}->set_markup ($markup);	1600	$self->{layout}->set_markup ($markup);
1371		1601
		1602	delete $self->{size_req};
		1603	$self->realloc;
1372	$self->update;	1604	$self->update;
1373	$self->check_size;
1374	}	1605	}
1375		1606
1376	sub size_request {	1607	sub size_request {
1377	my ($self) = @_;	1608	my ($self) = @_;
1378		1609
		1610	$self->{size_req} ||= do {
1379	$self->{layout}->set_font ($self->{font}) if $self->{font};	1611	$self->{layout}->set_font ($self->{font}) if $self->{font};
1380	$self->{layout}->set_width ($self->{max_w} || -1);	1612	$self->{layout}->set_width ($self->{max_w} || -1);
1381	$self->{layout}->set_ellipsise ($self->{ellipsise});	1613	$self->{layout}->set_ellipsise ($self->{ellipsise});
1382	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});	1614	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1383	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1615	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1384		1616
1385	my ($w, $h) = $self->{layout}->size;	1617	my ($w, $h) = $self->{layout}->size;
1386		1618
1387	if (exists $self->{template}) {	1619	if (exists $self->{template}) {
1388	$self->{template}->set_font ($self->{font}) if $self->{font};	1620	$self->{template}->set_font ($self->{font}) if $self->{font};
1389	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);	1621	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);
1390		1622
1391	my ($w2, $h2) = $self->{template}->size;	1623	my ($w2, $h2) = $self->{template}->size;
1392		1624
1393	$w = List::Util::max $w, $w2;	1625	$w = List::Util::max $w, $w2;
1394	$h = List::Util::max $h, $h2;	1626	$h = List::Util::max $h, $h2;
		1627	}
		1628
		1629	[$w, $h]
1395	}	1630	};
1396		1631
1397	(	1632	@{ $self->{size_req} }
1398	$w + $self->{padding} * 2,
1399	$h + $self->{padding} * 2,
1400	)
1401	}	1633	}
1402		1634
1403	sub size_allocate {	1635	sub invoke_size_allocate {
1404	my ($self, $w, $h) = @_;	1636	my ($self, $w, $h) = @_;
1405		1637
		1638	delete $self->{ox};
		1639
1406	delete $self->{texture};	1640	delete $self->{texture}
		1641	unless $w >= $self->{req_w} && $self->{old_w} >= $self->{req_w};
		1642
		1643	1
1407	}	1644	}
1408		1645
1409	sub set_fontsize {	1646	sub set_fontsize {
1410	my ($self, $fontsize) = @_;	1647	my ($self, $fontsize) = @_;
1411		1648
1412	$self->{fontsize} = $fontsize;	1649	$self->{fontsize} = $fontsize;
1413	delete $self->{texture};	1650	delete $self->{texture};
1414		1651
1415	$self->update;	1652	$self->realloc;
1416	$self->check_size;	1653	}
		1654
		1655	sub reconfigure {
		1656	my ($self) = @_;
		1657
		1658	delete $self->{size_req};
		1659
		1660	$self->SUPER::reconfigure;
1417	}	1661	}
1418		1662
1419	sub _draw {	1663	sub _draw {
1420	my ($self) = @_;	1664	my ($self) = @_;
1421		1665
…		…
1427	$self->{layout}->set_width ($self->{w});	1671	$self->{layout}->set_width ($self->{w});
1428	$self->{layout}->set_ellipsise ($self->{ellipsise});	1672	$self->{layout}->set_ellipsise ($self->{ellipsise});
1429	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});	1673	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1430	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1674	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1431		1675
1432	my $tex = new_from_layout CFClient::Texture $self->{layout};	1676	new_from_layout CFClient::Texture $self->{layout}
		1677	};
1433		1678
		1679	unless (exists $self->{ox}) {
1434	$self->{ox} = int ($self->{align} < 0 ? $self->{padding}	1680	$self->{ox} = int ($self->{align} < 0 ? $self->{padding_x}
1435	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding}	1681	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding_x}
1436	: ($self->{w} - $tex->{w}) * 0.5);	1682	: ($self->{w} - $tex->{w}) * 0.5);
1437		1683
1438	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding}	1684	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding_y}
1439	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding}	1685	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding_y}
1440	: ($self->{h} - $tex->{h}) * 0.5);	1686	: ($self->{h} - $tex->{h}) * 0.5);
1441
1442	$tex
1443	};	1687	};
1444		1688
1445	glEnable GL_TEXTURE_2D;	1689	glEnable GL_TEXTURE_2D;
1446	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1690
		1691	my $w = List::Util::min $self->{w} + 4, $tex->{w};
		1692	my $h = List::Util::min $self->{h} + 2, $tex->{h};
1447		1693
1448	if ($tex->{format} == GL_ALPHA) {	1694	if ($tex->{format} == GL_ALPHA) {
		1695	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
1449	glColor @{$self->{fg}};	1696	glColor @{$self->{fg}};
1450	$tex->draw_quad_alpha ($self->{ox}, $self->{oy});	1697	$tex->draw_quad_alpha ($self->{ox}, $self->{oy}, $w, $h);
1451	} else {	1698	} else {
		1699	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1452	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy});	1700	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy}, $w, $h);
1453	}	1701	}
1454		1702
1455	glDisable GL_TEXTURE_2D;	1703	glDisable GL_TEXTURE_2D;
1456	}	1704	}
1457		1705
…		…
1473	active_fg => [0, 0, 0],	1721	active_fg => [0, 0, 0],
1474	can_hover => 1,	1722	can_hover => 1,
1475	can_focus => 1,	1723	can_focus => 1,
1476	valign => 0,	1724	valign => 0,
1477	can_events => 1,	1725	can_events => 1,
		1726	#text => ...
		1727	#hidden => "*",
1478	@_	1728	@_
1479	)	1729	)
1480	}	1730	}
1481		1731
1482	sub _set_text {	1732	sub _set_text {
…		…
1484		1734
1485	delete $self->{cur_h};	1735	delete $self->{cur_h};
1486		1736
1487	return if $self->{text} eq $text;	1737	return if $self->{text} eq $text;
1488		1738
1489	delete $self->{texture};
1490
1491	$self->{last_activity} = $::NOW;	1739	$self->{last_activity} = $::NOW;
1492	$self->{text} = $text;	1740	$self->{text} = $text;
1493		1741
1494	$text =~ s/./*/g if $self->{hidden};	1742	$text =~ s/./*/g if $self->{hidden};
1495	$self->{layout}->set_text ("$text ");	1743	$self->{layout}->set_text ("$text ");
		1744	delete $self->{size_req};
1496		1745
1497	$self->emit (changed => $self->{text});	1746	$self->emit (changed => $self->{text});
		1747
		1748	$self->realloc;
		1749	$self->update;
1498	}	1750	}
1499		1751
1500	sub set_text {	1752	sub set_text {
1501	my ($self, $text) = @_;	1753	my ($self, $text) = @_;
1502		1754
1503	$self->{cursor} = length $text;	1755	$self->{cursor} = length $text;
1504	$self->_set_text ($text);	1756	$self->_set_text ($text);
1505	$self->update;
1506	$self->check_size;
1507	}	1757	}
1508		1758
1509	sub get_text {	1759	sub get_text {
1510	$_[0]{text}	1760	$_[0]{text}
1511	}	1761	}
…		…
1516	my ($w, $h) = $self->SUPER::size_request;	1766	my ($w, $h) = $self->SUPER::size_request;
1517		1767
1518	($w + 1, $h) # add 1 for cursor	1768	($w + 1, $h) # add 1 for cursor
1519	}	1769	}
1520		1770
1521	sub size_allocate {
1522	my ($self, $w, $h) = @_;
1523
1524	$self->_set_text (delete $self->{text});#d# don't check for == inside _set_text
1525	}
1526
1527	sub key_down {	1771	sub invoke_key_down {
1528	my ($self, $ev) = @_;	1772	my ($self, $ev) = @_;
1529		1773
1530	my $mod = $ev->{mod};	1774	my $mod = $ev->{mod};
1531	my $sym = $ev->{sym};	1775	my $sym = $ev->{sym};
1532	my $uni = $ev->{unicode};	1776	my $uni = $ev->{unicode};
…		…
1547	$self->{cursor} = length $text;	1791	$self->{cursor} = length $text;
1548	} elsif ($uni == 27) {	1792	} elsif ($uni == 27) {
1549	$self->emit ('escape');	1793	$self->emit ('escape');
1550	} elsif ($uni) {	1794	} elsif ($uni) {
1551	substr $text, $self->{cursor}++, 0, chr $uni;	1795	substr $text, $self->{cursor}++, 0, chr $uni;
		1796	} else {
		1797	return 0;
1552	}	1798	}
1553		1799
1554	$self->_set_text ($text);	1800	$self->_set_text ($text);
1555	$self->update;
1556	$self->check_size;
1557	}
1558		1801
		1802	$self->realloc;
		1803
		1804	1
		1805	}
		1806
1559	sub focus_in {	1807	sub invoke_focus_in {
1560	my ($self) = @_;	1808	my ($self) = @_;
1561		1809
1562	$self->{last_activity} = $::NOW;	1810	$self->{last_activity} = $::NOW;
1563		1811
1564	$self->SUPER::focus_in;	1812	$self->SUPER::invoke_focus_in
1565	}	1813	}
1566		1814
1567	sub button_down {	1815	sub invoke_button_down {
1568	my ($self, $ev, $x, $y) = @_;	1816	my ($self, $ev, $x, $y) = @_;
1569		1817
1570	$self->SUPER::button_down ($ev, $x, $y);	1818	$self->SUPER::invoke_button_down ($ev, $x, $y);
1571		1819
1572	my $idx = $self->{layout}->xy_to_index ($x, $y);	1820	my $idx = $self->{layout}->xy_to_index ($x, $y);
1573		1821
1574	# byte-index to char-index	1822	# byte-index to char-index
1575	my $text = $self->{text};	1823	my $text = $self->{text};
1576	utf8::encode $text;	1824	utf8::encode $text;
1577	$self->{cursor} = length substr $text, 0, $idx;	1825	$self->{cursor} = length substr $text, 0, $idx;
1578		1826
1579	$self->_set_text ($self->{text});	1827	$self->_set_text ($self->{text});
1580	$self->update;	1828	$self->update;
		1829
		1830	1
1581	}	1831	}
1582		1832
1583	sub mouse_motion {	1833	sub invoke_mouse_motion {
1584	my ($self, $ev, $x, $y) = @_;	1834	my ($self, $ev, $x, $y) = @_;
1585	# printf "M %d,%d %d,%d\n", $ev->motion_x, $ev->motion_y, $x, $y;#d#	1835	# printf "M %d,%d %d,%d\n", $ev->motion_x, $ev->motion_y, $x, $y;#d#
		1836
		1837	1
1586	}	1838	}
1587		1839
1588	sub _draw {	1840	sub _draw {
1589	my ($self) = @_;	1841	my ($self) = @_;
1590		1842
1591	local $self->{fg} = $self->{fg};	1843	local $self->{fg} = $self->{fg};
1592		1844
1593	if ($FOCUS == $self) {	1845	if ($FOCUS == $self) {
1594	glColor @{$self->{active_bg}};	1846	glColor_premultiply @{$self->{active_bg}};
1595	$self->{fg} = $self->{active_fg};	1847	$self->{fg} = $self->{active_fg};
1596	} else {	1848	} else {
1597	glColor @{$self->{bg}};	1849	glColor_premultiply @{$self->{bg}};
1598	}	1850	}
1599		1851
1600	glEnable GL_BLEND;	1852	glEnable GL_BLEND;
1601	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1853	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1602	glBegin GL_QUADS;	1854	glBegin GL_QUADS;
1603	glVertex 0 , 0;	1855	glVertex 0 , 0;
1604	glVertex 0 , $self->{h};	1856	glVertex 0 , $self->{h};
1605	glVertex $self->{w}, $self->{h};	1857	glVertex $self->{w}, $self->{h};
1606	glVertex $self->{w}, 0;	1858	glVertex $self->{w}, 0;
…		…
1631		1883
1632	our @ISA = CFClient::UI::EntryBase::;	1884	our @ISA = CFClient::UI::EntryBase::;
1633		1885
1634	use CFClient::OpenGL;	1886	use CFClient::OpenGL;
1635		1887
1636	sub key_down {	1888	sub invoke_key_down {
1637	my ($self, $ev) = @_;	1889	my ($self, $ev) = @_;
1638		1890
1639	my $sym = $ev->{sym};	1891	my $sym = $ev->{sym};
1640		1892
1641	if ($sym == 13) {	1893	if ($sym == 13) {
1642	unshift @{$self->{history}},	1894	unshift @{$self->{history}},
1643	my $txt = $self->get_text;	1895	my $txt = $self->get_text;
		1896
1644	$self->{history_pointer} = -1;	1897	$self->{history_pointer} = -1;
1645	$self->{history_saveback} = '';	1898	$self->{history_saveback} = '';
1646	$self->emit (activate => $txt);	1899	$self->emit (activate => $txt);
1647	$self->update;	1900	$self->update;
1648		1901
…		…
1667	} else {	1920	} else {
1668	$self->set_text ($self->{history_saveback});	1921	$self->set_text ($self->{history_saveback});
1669	}	1922	}
1670		1923
1671	} else {	1924	} else {
1672	$self->SUPER::key_down ($ev);	1925	return $self->SUPER::invoke_key_down ($ev)
		1926	}
		1927
1673	}	1928	1
1674
1675	}	1929	}
1676		1930
1677	#############################################################################	1931	#############################################################################
1678		1932
1679	package CFClient::UI::Button;	1933	package CFClient::UI::Button;
…		…
1688		1942
1689	sub new {	1943	sub new {
1690	my $class = shift;	1944	my $class = shift;
1691		1945
1692	$class->SUPER::new (	1946	$class->SUPER::new (
1693	padding => 4,	1947	padding_x => 4,
		1948	padding_y => 4,
1694	fg => [1, 1, 1],	1949	fg => [1, 1, 1],
1695	active_fg => [0, 0, 1],	1950	active_fg => [0, 0, 1],
1696	can_hover => 1,	1951	can_hover => 1,
1697	align => 0,	1952	align => 0,
1698	valign => 0,	1953	valign => 0,
1699	can_events => 1,	1954	can_events => 1,
1700	@_	1955	@_
1701	)	1956	)
1702	}	1957	}
1703		1958
1704	sub button_up {	1959	sub invoke_button_up {
1705	my ($self, $ev, $x, $y) = @_;	1960	my ($self, $ev, $x, $y) = @_;
1706		1961
		1962	$self->emit ("activate")
1707	if ($x >= 0 && $x < $self->{w}	1963	if $x >= 0 && $x < $self->{w}
1708	&& $y >= 0 && $y < $self->{h}) {	1964	&& $y >= 0 && $y < $self->{h};
1709	$self->emit ("activate");	1965
1710	}	1966	1
1711	}	1967	}
1712		1968
1713	sub _draw {	1969	sub _draw {
1714	my ($self) = @_;	1970	my ($self) = @_;
1715		1971
1716	local $self->{fg} = $self->{fg};	1972	local $self->{fg} = $GRAB == $self ? $self->{active_fg} : $self->{fg};
1717
1718	if ($GRAB == $self) {
1719	$self->{fg} = $self->{active_fg};
1720	}
1721		1973
1722	glEnable GL_TEXTURE_2D;	1974	glEnable GL_TEXTURE_2D;
1723	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1975	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1724	glColor 0, 0, 0, 1;	1976	glColor 0, 0, 0, 1;
1725		1977
…		…
1730	$self->SUPER::_draw;	1982	$self->SUPER::_draw;
1731	}	1983	}
1732		1984
1733	#############################################################################	1985	#############################################################################
1734		1986
		1987	package CFClient::UI::ImageButton;
		1988
		1989	our @ISA = CFClient::UI::Image::;
		1990
		1991	use CFClient::OpenGL;
		1992
		1993	my %textures;
		1994
		1995	sub new {
		1996	my $class = shift;
		1997
		1998	my $self = $class->SUPER::new (
		1999	padding_x => 4,
		2000	padding_y => 4,
		2001	fg => [1, 1, 1],
		2002	active_fg => [0, 0, 1],
		2003	can_hover => 1,
		2004	align => 0,
		2005	valign => 0,
		2006	can_events => 1,
		2007	@_
		2008	);
		2009	}
		2010
		2011	sub invoke_button_up {
		2012	my ($self, $ev, $x, $y) = @_;
		2013
		2014	$self->emit ("activate")
		2015	if $x >= 0 && $x < $self->{w}
		2016	&& $y >= 0 && $y < $self->{h};
		2017
		2018	1
		2019	}
		2020
		2021	#############################################################################
		2022
1735	package CFClient::UI::CheckBox;	2023	package CFClient::UI::CheckBox;
1736		2024
1737	our @ISA = CFClient::UI::DrawBG::;	2025	our @ISA = CFClient::UI::DrawBG::;
1738		2026
1739	my @tex =	2027	my @tex =
…		…
1744		2032
1745	sub new {	2033	sub new {
1746	my $class = shift;	2034	my $class = shift;
1747		2035
1748	$class->SUPER::new (	2036	$class->SUPER::new (
1749	padding => 2,	2037	padding_x => 2,
		2038	padding_y => 2,
1750	fg => [1, 1, 1],	2039	fg => [1, 1, 1],
1751	active_fg => [1, 1, 0],	2040	active_fg => [1, 1, 0],
1752	bg => [0, 0, 0, 0.2],	2041	bg => [0, 0, 0, 0.2],
1753	active_bg => [1, 1, 1, 0.5],	2042	active_bg => [1, 1, 1, 0.5],
1754	state => 0,	2043	state => 0,
…		…
1758	}	2047	}
1759		2048
1760	sub size_request {	2049	sub size_request {
1761	my ($self) = @_;	2050	my ($self) = @_;
1762		2051
1763	($self->{padding} * 2 + 6) x 2	2052	(6) x 2
1764	}	2053	}
1765		2054
1766	sub button_down {	2055	sub invoke_button_down {
1767	my ($self, $ev, $x, $y) = @_;	2056	my ($self, $ev, $x, $y) = @_;
1768		2057
1769	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	2058	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1770	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	2059	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1771	$self->{state} = !$self->{state};	2060	$self->{state} = !$self->{state};
1772	$self->emit (changed => $self->{state});	2061	$self->emit (changed => $self->{state});
		2062	} else {
		2063	return 0
		2064	}
		2065
1773	}	2066	1
1774	}	2067	}
1775		2068
1776	sub _draw {	2069	sub _draw {
1777	my ($self) = @_;	2070	my ($self) = @_;
1778		2071
1779	$self->SUPER::_draw;	2072	$self->SUPER::_draw;
1780		2073
1781	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	2074	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1782		2075
1783	my $s = (List::Util::min @$self{qw(w h)}) - $self->{padding} * 2;	2076	my ($w, $h) = @$self{qw(w h)};
		2077
		2078	my $s = List::Util::min $w - $self->{padding_x} * 2, $h - $self->{padding_y} * 2;
1784		2079
1785	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	2080	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1786		2081
1787	my $tex = $self->{state} ? $tex[1] : $tex[0];	2082	my $tex = $self->{state} ? $tex[1] : $tex[0];
1788		2083
…		…
1943		2238
1944	my $h1 = $self->{h} * (1 - $ycut1);	2239	my $h1 = $self->{h} * (1 - $ycut1);
1945	my $h2 = $self->{h} * (1 - $ycut2);	2240	my $h2 = $self->{h} * (1 - $ycut2);
1946		2241
1947	glEnable GL_BLEND;	2242	glEnable GL_BLEND;
1948	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	2243	glBlendFuncSeparate GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA,
		2244	GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1949	glEnable GL_TEXTURE_2D;	2245	glEnable GL_TEXTURE_2D;
1950	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2246	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1951		2247
1952	glBindTexture GL_TEXTURE_2D, $t1->{name};	2248	glBindTexture GL_TEXTURE_2D, $t1->{name};
1953	glBegin GL_QUADS;	2249	glBegin GL_QUADS;
…		…
2052	my $self = $class->SUPER::new (	2348	my $self = $class->SUPER::new (
2053	fg => [1, 1, 1],	2349	fg => [1, 1, 1],
2054	active_fg => [0, 0, 0],	2350	active_fg => [0, 0, 0],
2055	bg => [0, 0, 0, 0.2],	2351	bg => [0, 0, 0, 0.2],
2056	active_bg => [1, 1, 1, 0.5],	2352	active_bg => [1, 1, 1, 0.5],
2057	range => [0, 0, 100, 10],	2353	range => [0, 0, 100, 10, 0],
2058	req_w => $::WIDTH / 80,	2354	min_w => $::WIDTH / 80,
2059	req_h => $::WIDTH / 80,	2355	min_h => $::WIDTH / 80,
2060	vertical => 0,	2356	vertical => 0,
2061	can_hover => 1,	2357	can_hover => 1,
2062	inner_pad => .05,	2358	inner_pad => 0.02,
2063	@_	2359	@_
2064	);	2360	);
2065		2361
2066	$self->set_value ($self->{range}[0]);	2362	$self->set_value ($self->{range}[0]);
2067	$self->update;	2363	$self->update;
2068		2364
2069	$self	2365	$self
2070	}	2366	}
2071		2367
		2368	sub set_range {
		2369	my ($self, $range) = @_;
		2370
		2371	($range, $self->{range}) = ($self->{range}, $range);
		2372
		2373	if ("@$range" ne "@{$self->{range}}") {
		2374	$self->update;
		2375	$self->set_value ($self->{range}[0]);
		2376	}
		2377	}
		2378
2072	sub set_value {	2379	sub set_value {
2073	my ($self, $value) = @_;	2380	my ($self, $value) = @_;
2074		2381
2075	my ($old_value, $lo, $hi, $page, $unit) = @{$self->{range}};	2382	my ($old_value, $lo, $hi, $page, $unit) = @{$self->{range}};
2076		2383
2077	$hi = $lo + 1 if $hi <= $lo;	2384	$hi = $lo + 1 if $hi <= $lo;
2078		2385
		2386	$page = $hi - $lo if $page > $hi - $lo;
		2387
2079	$value = $lo if $value < $lo;	2388	$value = $lo if $value < $lo;
2080	$value = $hi if $value > $hi;	2389	$value = $hi - $page if $value > $hi - $page;
2081		2390
2082	$value = $lo + $unit * int +($value - $lo + $unit * 0.5) / $unit	2391	$value = $lo + $unit * int +($value - $lo + $unit * 0.5) / $unit
2083	if $unit;	2392	if $unit;
2084
2085	$page = $hi - $lo if $page > $hi - $lo;
2086		2393
2087	@{$self->{range}} = ($value, $lo, $hi, $page, $unit);	2394	@{$self->{range}} = ($value, $lo, $hi, $page, $unit);
2088		2395
2089	if ($value != $old_value) {	2396	if ($value != $old_value) {
2090	$self->emit (changed => $value);	2397	$self->emit (changed => $value);
…		…
2093	}	2400	}
2094		2401
2095	sub size_request {	2402	sub size_request {
2096	my ($self) = @_;	2403	my ($self) = @_;
2097		2404
2098	my $w = $self->{req_w};	2405	($self->{req_w}, $self->{req_h})
2099	my $h = $self->{req_h};
2100
2101	$self->{vertical} ? ($h, $w) : ($w, $h)
2102	}	2406	}
2103		2407
2104	sub button_down {	2408	sub invoke_button_down {
2105	my ($self, $ev, $x, $y) = @_;	2409	my ($self, $ev, $x, $y) = @_;
2106		2410
2107	$self->SUPER::button_down ($ev, $x, $y);	2411	$self->SUPER::invoke_button_down ($ev, $x, $y);
		2412
		2413	$self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x];
		2414
2108	$self->mouse_motion ($ev, $x, $y);	2415	$self->invoke_mouse_motion ($ev, $x, $y)
2109	}	2416	}
2110		2417
2111	sub mouse_motion {	2418	sub invoke_mouse_motion {
2112	my ($self, $ev, $x, $y) = @_;	2419	my ($self, $ev, $x, $y) = @_;
2113		2420
2114	if ($GRAB == $self) {	2421	if ($GRAB == $self) {
2115	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});	2422	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});
2116		2423
2117	my (undef, $lo, $hi, $page) = @{$self->{range}};	2424	my (undef, $lo, $hi, $page) = @{$self->{range}};
2118		2425
2119	$x = $x / ($w * (1 - 2 * $self->{inner_pad})) - $self->{inner_pad};	2426	$x = ($x - $self->{click}[1]) / ($w * $self->{scale});
2120		2427
2121	$self->set_value ($x * ($hi - $lo) + $lo);	2428	$self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo));
		2429	} else {
		2430	return 0;
		2431	}
		2432
2122	}	2433	1
2123	}	2434	}
2124		2435
2125	sub update {	2436	sub update {
2126	my ($self) = @_;	2437	my ($self) = @_;
2127		2438
2128	$CFClient::UI::ROOT->on_post_alloc ($self => sub {	2439	delete $self->{knob_w};
		2440	$self->SUPER::update;
		2441	}
		2442
		2443	sub _draw {
		2444	my ($self) = @_;
		2445
		2446	unless ($self->{knob_w}) {
2129	$self->set_value ($self->{range}[0]);	2447	$self->set_value ($self->{range}[0]);
2130		2448
2131	my ($value, $lo, $hi, $page) = @{$self->{range}};	2449	my ($value, $lo, $hi, $page) = @{$self->{range}};
		2450	my $range = ($hi - $page - $lo) || 1e-100;
2132		2451
2133	my $inner_w = 1 - 2 * $self->{inner_pad};	2452	my $knob_w = List::Util::min 1, $page / ($hi - $lo) || 0.1;
2134		2453
2135	$self->{scale} = ($inner_w / ($hi - $lo)) || 1;	2454	$self->{offset} = List::Util::max $self->{inner_pad}, $knob_w * 0.5;
		2455	$self->{scale} = 1 - 2 * $self->{offset} || 1e-100;
2136		2456
2137	$page = $self->{scale} * $page || 10 / ($self->{w} || 1);	2457	$value = ($value - $lo) / $range;
2138	$value = $self->{scale} * ($value - $lo);	2458	$value = $value * $self->{scale} + $self->{offset};
2139		2459
2140	$value = $self->{inner_pad} + ($value - $page * 0.5);
2141
2142	$value = 0 if $value < 0;
2143	$page = 1 - $value if $value + $page > 1;
2144
2145	$self->{knob_x} = $value;	2460	$self->{knob_x} = $value - $knob_w * 0.5;
2146	$self->{knob_w} = $page;	2461	$self->{knob_w} = $knob_w;
2147	});	2462	}
2148
2149	$self->SUPER::update;
2150	}
2151
2152	sub _draw {
2153	my ($self) = @_;
2154		2463
2155	$self->SUPER::_draw ();	2464	$self->SUPER::_draw ();
2156		2465
2157	glScale $self->{w}, $self->{h};	2466	glScale $self->{w}, $self->{h};
2158		2467
…		…
2178	glDisable GL_TEXTURE_2D;	2487	glDisable GL_TEXTURE_2D;
2179	}	2488	}
2180		2489
2181	#############################################################################	2490	#############################################################################
2182		2491
		2492	package CFClient::UI::ValSlider;
		2493
		2494	our @ISA = CFClient::UI::HBox::;
		2495
		2496	sub new {
		2497	my ($class, %arg) = @_;
		2498
		2499	my $range = delete $arg{range};
		2500
		2501	my $self = $class->SUPER::new (
		2502	slider => (new CFClient::UI::Slider expand => 1, range => $range),
		2503	entry => (new CFClient::UI::Label text => "", template => delete $arg{template}),
		2504	to_value => sub { shift },
		2505	from_value => sub { shift },
		2506	%arg,
		2507	);
		2508
		2509	$self->{slider}->connect (changed => sub {
		2510	my ($self, $value) = @_;
		2511	$self->{parent}{entry}->set_text ($self->{parent}{to_value}->($value));
		2512	$self->{parent}->emit (changed => $value);
		2513	});
		2514
		2515	# $self->{entry}->connect (changed => sub {
		2516	# my ($self, $value) = @_;
		2517	# $self->{parent}{slider}->set_value ($self->{parent}{from_value}->($value));
		2518	# $self->{parent}->emit (changed => $value);
		2519	# });
		2520
		2521	$self->add ($self->{slider}, $self->{entry});
		2522
		2523	$self->{slider}->emit (changed => $self->{slider}{range}[0]);
		2524
		2525	$self
		2526	}
		2527
		2528	sub set_range { shift->{slider}->set_range (@_) }
		2529	sub set_value { shift->{slider}->set_value (@_) }
		2530
		2531	#############################################################################
		2532
2183	package CFClient::UI::TextView;	2533	package CFClient::UI::TextScroller;
2184		2534
2185	our @ISA = CFClient::UI::HBox::;	2535	our @ISA = CFClient::UI::HBox::;
2186		2536
2187	use CFClient::OpenGL;	2537	use CFClient::OpenGL;
2188		2538
…		…
2190	my $class = shift;	2540	my $class = shift;
2191		2541
2192	my $self = $class->SUPER::new (	2542	my $self = $class->SUPER::new (
2193	fontsize => 1,	2543	fontsize => 1,
2194	can_events => 0,	2544	can_events => 0,
		2545	indent => 0,
2195	#font => default_font	2546	#font => default_font
2196	@_,	2547	@_,
2197		2548
2198	layout => (new CFClient::Layout 1),	2549	layout => (new CFClient::Layout 1),
2199	par => [],	2550	par => [],
…		…
2214		2565
2215	$self->{fontsize} = $fontsize;	2566	$self->{fontsize} = $fontsize;
2216	$self->reflow;	2567	$self->reflow;
2217	}	2568	}
2218		2569
2219	sub text_height {
2220	my ($self, $text) = @_;
2221
2222	my $layout = $self->{layout};
2223
2224	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
2225	$layout->set_width ($self->{children}[0]{w});
2226	$layout->set_markup ($text);
2227
2228	($layout->size)[1]
2229	}
2230
2231	sub reflow {
2232	my ($self) = @_;
2233
2234	$self->{need_reflow}++;
2235	$self->update;
2236	}
2237
2238	sub size_allocate {	2570	sub invoke_size_allocate {
2239	my ($self, $w, $h) = @_;	2571	my ($self, $w, $h) = @_;
2240
2241	$self->SUPER::size_allocate ($w, $h);
2242		2572
2243	$self->{layout}->set_font ($self->{font}) if $self->{font};	2573	$self->{layout}->set_font ($self->{font}) if $self->{font};
2244	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	2574	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
2245	$self->{layout}->set_width ($self->{children}[0]{w});	2575	$self->{layout}->set_width ($self->{children}[0]{w});
		2576	$self->{layout}->set_indent ($self->{fontsize} * $::FONTSIZE * $self->{indent});
2246		2577
2247	$self->reflow;	2578	$self->reflow;
		2579
		2580	$self->SUPER::invoke_size_allocate ($w, $h)
		2581	}
		2582
		2583	sub text_size {
		2584	my ($self, $text, $indent) = @_;
		2585
		2586	my $layout = $self->{layout};
		2587
		2588	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2589	$layout->set_width ($self->{children}[0]{w} - $indent);
		2590	$layout->set_indent ($self->{fontsize} * $::FONTSIZE * $self->{indent});
		2591	$layout->set_markup ($text);
		2592
		2593	$layout->size
		2594	}
		2595
		2596	sub reflow {
		2597	my ($self) = @_;
		2598
		2599	$self->{need_reflow}++;
		2600	$self->update;
		2601	}
		2602
		2603	sub set_offset {
		2604	my ($self, $offset) = @_;
		2605
		2606	# todo: base offset on lines or so, not on pixels
		2607	$self->{children}[1]->set_value ($offset);
		2608	}
		2609
		2610	sub clear {
		2611	my ($self) = @_;
		2612
		2613	$self->{par} = [];
		2614	$self->{height} = 0;
		2615	$self->{children}[1]->set_range ([0, 0, 0, 1, 1]);
2248	}	2616	}
2249		2617
2250	sub add_paragraph {	2618	sub add_paragraph {
2251	my ($self, $color, $text) = @_;	2619	my ($self, $color, $text, $indent) = @_;
2252		2620
2253	#TODO: intelligently "reformat" paragraph	2621	for my $line (split /\n/, $text) {
2254		2622	my ($w, $h) = $self->text_size ($line);
2255	my $height = $self->text_height ($text);
2256
2257	$self->{height} += $height;	2623	$self->{height} += $h;
		2624	push @{$self->{par}}, [$w + $indent, $h, $color, $indent, $line];
		2625	}
2258		2626
2259	push @{$self->{par}}, [$height, $color, $text];
2260
2261	$self->{children}[1]{range} = [$self->{height} - $self->{h}, 0, $self->{height}, $self->{h}];	2627	$self->{children}[1]->set_range ([$self->{height}, 0, $self->{height}, $self->{h}, 1]);
2262	$self->{children}[1]->update;
2263	}	2628	}
2264		2629
2265	sub update {	2630	sub update {
2266	my ($self) = @_;	2631	my ($self) = @_;
2267		2632
…		…
2269		2634
2270	return unless $self->{h} > 0;	2635	return unless $self->{h} > 0;
2271		2636
2272	delete $self->{texture};	2637	delete $self->{texture};
2273		2638
2274	$ROOT->on_post_alloc ($self, sub {	2639	$ROOT->on_post_alloc ($self => sub {
		2640	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
		2641
2275	if (delete $self->{need_reflow}) {	2642	if (delete $self->{need_reflow}) {
2276	my $height = 0;	2643	my $height = 0;
2277		2644
2278	$height += $_->[0] = $self->text_height ($_->[2])	2645	my $layout = $self->{layout};
		2646
		2647	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2648
2279	for @{$self->{par}};	2649	for (@{$self->{par}}) {
		2650	if (1 || $_->[0] >= $W) { # TODO: works,but needs reconfigure etc. support
		2651	$layout->set_width ($W - $_->[3]);
		2652	$layout->set_indent ($self->{fontsize} * $::FONTSIZE * $self->{indent});
		2653	$layout->set_markup ($_->[4]);
		2654	my ($w, $h) = $layout->size;
		2655	$_->[0] = $w + $_->[3];
		2656	$_->[1] = $h;
		2657	}
		2658
		2659	$height += $_->[1];
		2660	}
2280		2661
2281	$self->{height} = $height;	2662	$self->{height} = $height;
2282		2663
2283	$self->{children}[1]{range} = [$height - $self->{h}, 0, $height, $self->{h}];	2664	$self->{children}[1]->set_range ([$height, 0, $height, $H, 1]);
2284		2665
2285	delete $self->{texture};	2666	delete $self->{texture};
2286	}	2667	}
2287		2668
2288	$self->{texture} ||= new_from_opengl CFClient::Texture $self->{children}[0]{w}, $self->{children}[0]{h}, sub {	2669	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {
2289	glClearColor 0, 0, 0, 0;	2670	glClearColor 0, 0, 0, 0;
2290	glClear GL_COLOR_BUFFER_BIT;	2671	glClear GL_COLOR_BUFFER_BIT;
2291		2672
2292	glEnable GL_TEXTURE_2D;
2293	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2294
2295	my $top = int $self->{children}[1]{range}[0];	2673	my $top = int $self->{children}[1]{range}[0];
2296		2674
2297	my $y0 = $top;	2675	my $y0 = $top;
2298	my $y1 = $top + $self->{h};	2676	my $y1 = $top + $H;
2299		2677
2300	my $y = 0;	2678	my $y = 0;
2301		2679
2302	my $layout = $self->{layout};	2680	my $layout = $self->{layout};
2303		2681
2304	$layout->set_font ($self->{font}) if $self->{font};	2682	$layout->set_font ($self->{font}) if $self->{font};
2305		2683
		2684	glEnable GL_BLEND;
		2685	#TODO# not correct in windows where rgba is forced off
		2686	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
		2687
2306	for my $par (@{$self->{par}}) {	2688	for my $par (@{$self->{par}}) {
2307	my $h = $par->[0];	2689	my $h = $par->[1];
2308		2690
2309	if ($y0 < $y + $h && $y < $y1) {	2691	if ($y0 < $y + $h && $y < $y1) {
2310	$layout->set_foreground (@{ $par->[1] });	2692	$layout->set_foreground (@{ $par->[2] });
		2693	$layout->set_width ($W - $par->[3]);
		2694	$layout->set_indent ($self->{fontsize} * $::FONTSIZE * $self->{indent});
2311	$layout->set_markup ($par->[2]);	2695	$layout->set_markup ($par->[4]);
2312		2696
2313	my ($W, $H) = $layout->size;	2697	my ($w, $h, $data, $format, $internalformat) = $layout->render;
2314	CFClient::Texture->new_from_layout ($layout)->draw_quad_alpha_premultiplied (0, $y - $y0);	2698
		2699	glRasterPos $par->[3], $y - $y0;
		2700	glDrawPixels $w, $h, $format, GL_UNSIGNED_BYTE, $data;
2315	}	2701	}
2316		2702
2317	$y += $h;	2703	$y += $h;
2318	}	2704	}
2319		2705
2320	glDisable GL_TEXTURE_2D;	2706	glDisable GL_BLEND;
2321	};	2707	};
2322	});	2708	});
2323	}	2709	}
2324		2710
2325	sub _draw {	2711	sub _draw {
2326	my ($self) = @_;	2712	my ($self) = @_;
2327		2713
2328	glEnable GL_TEXTURE_2D;	2714	glEnable GL_TEXTURE_2D;
2329	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2715	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2330	glColor 1, 1, 1, 1;	2716	glColor 0, 0, 0, 1;
2331	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});	2717	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});
2332	glDisable GL_TEXTURE_2D;	2718	glDisable GL_TEXTURE_2D;
2333		2719
2334	$self->{children}[1]->draw;	2720	$self->{children}[1]->draw;
2335		2721
…		…
2385		2771
2386	sub new {	2772	sub new {
2387	my $class = shift;	2773	my $class = shift;
2388		2774
2389	my $self = $class->SUPER::new (	2775	my $self = $class->SUPER::new (
2390	state => 0,	2776	state => 0,
2391	connect_activate => \&toggle_flopper,	2777	on_activate => \&toggle_flopper,
2392	@_	2778	@_
2393	);	2779	);
2394		2780
2395	if ($self->{state}) {
2396	$self->{state} = 0;
2397	$self->toggle_flopper;
2398	}
2399
2400	$self	2781	$self
2401	}	2782	}
2402		2783
2403	sub toggle_flopper {	2784	sub toggle_flopper {
2404	my ($self) = @_;	2785	my ($self) = @_;
2405		2786
2406	# TODO: use animation	2787	$self->{other}->toggle_visibility;
2407	if ($self->{state} = !$self->{state}) {
2408	$CFClient::UI::ROOT->add ($self->{other});
2409	$self->{other}->move ($self->coord2global (0, $self->{h}));
2410	$self->emit ("open");
2411	} else {
2412	$CFClient::UI::ROOT->remove ($self->{other});
2413	$self->emit ("close");
2414	}
2415
2416	$self->emit (changed => $self->{state});
2417	}	2788	}
2418		2789
2419	#############################################################################	2790	#############################################################################
2420		2791
2421	package CFClient::UI::Tooltip;	2792	package CFClient::UI::Tooltip;
…		…
2434	}	2805	}
2435		2806
2436	sub set_tooltip_from {	2807	sub set_tooltip_from {
2437	my ($self, $widget) = @_;	2808	my ($self, $widget) = @_;
2438		2809
		2810	my $tooltip = $widget->{tooltip};
		2811
		2812	if ($ENV{CFPLUS_DEBUG} & 2) {
		2813	$tooltip .= "\n\n" . (ref $widget) . "\n"
		2814	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"
		2815	. "req $widget->{req_w} $widget->{req_h}\n"
		2816	. "visible $widget->{visible}";
		2817	}
		2818
		2819	$tooltip =~ s/^\n+//;
		2820	$tooltip =~ s/\n+$//;
		2821
2439	$self->add (new CFClient::UI::Label	2822	$self->add (new CFClient::UI::Label
2440	markup => $widget->{tooltip},	2823	markup => $tooltip,
2441	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,	2824	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2442	fontsize => 0.8,	2825	fontsize => 0.8,
2443	fg => [0, 0, 0, 1],	2826	fg => [0, 0, 0, 1],
2444	ellipsise => 0,	2827	ellipsise => 0,
2445	font => ($widget->{tooltip_font} || $::FONT_PROP),	2828	font => ($widget->{tooltip_font} || $::FONT_PROP),
…		…
2452	my ($w, $h) = @{$self->child}{qw(req_w req_h)};	2835	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
2453		2836
2454	($w + 4, $h + 4)	2837	($w + 4, $h + 4)
2455	}	2838	}
2456		2839
2457	sub size_allocate {	2840	sub invoke_size_allocate {
2458	my ($self, $w, $h) = @_;	2841	my ($self, $w, $h) = @_;
2459		2842
2460	$self->SUPER::size_allocate ($w - 4, $h - 4);	2843	$self->SUPER::invoke_size_allocate ($w - 4, $h - 4)
		2844	}
		2845
		2846	sub invoke_visibility_change {
		2847	my ($self, $visible) = @_;
		2848
		2849	return unless $visible;
		2850
		2851	$self->{root}->on_post_alloc ("move_$self" => sub {
		2852	my $widget = $self->{owner}
		2853	or return;
		2854
		2855	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
		2856
		2857	($x, $y) = $widget->coord2global (-$self->{w}, 0)
		2858	if $x + $self->{w} > $self->{root}{w};
		2859
		2860	$self->move_abs ($x, $y);
		2861	});
2461	}	2862	}
2462		2863
2463	sub _draw {	2864	sub _draw {
2464	my ($self) = @_;	2865	my ($self) = @_;
2465		2866
…		…
2482	glVertex $w, $h;	2883	glVertex $w, $h;
2483	glVertex $w, 0;	2884	glVertex $w, 0;
2484	glEnd;	2885	glEnd;
2485		2886
2486	glTranslate 2 - 0.375, 2 - 0.375;	2887	glTranslate 2 - 0.375, 2 - 0.375;
		2888
2487	$self->SUPER::_draw;	2889	$self->SUPER::_draw;
2488	}	2890	}
2489		2891
2490	#############################################################################	2892	#############################################################################
2491		2893
…		…
2496	use CFClient::OpenGL;	2898	use CFClient::OpenGL;
2497		2899
2498	sub new {	2900	sub new {
2499	my $class = shift;	2901	my $class = shift;
2500		2902
2501	$class->SUPER::new (	2903	my $self = $class->SUPER::new (
2502	aspect => 1,	2904	aspect => 1,
		2905	can_events => 0,
2503	@_,	2906	@_,
2504	)	2907	);
		2908
		2909	if ($self->{anim} && $self->{animspeed}) {
		2910	Scalar::Util::weaken (my $widget = $self);
		2911
		2912	$self->{timer} = Event->timer (
		2913	at => $self->{animspeed} * int $::NOW / $self->{animspeed},
		2914	hard => 1,
		2915	interval => $self->{animspeed},
		2916	cb => sub {
		2917	++$widget->{frame};
		2918	$widget->update;
		2919	},
		2920	);
		2921	}
		2922
		2923	$self
2505	}	2924	}
2506		2925
2507	sub size_request {	2926	sub size_request {
2508	(32, 8)	2927	(32, 8)
2509	}	2928	}
2510		2929
		2930	sub update {
		2931	my ($self) = @_;
		2932
		2933	return unless $self->{visible};
		2934
		2935	$self->SUPER::update;
		2936	}
		2937
2511	sub _draw {	2938	sub _draw {
2512	my ($self) = @_;	2939	my ($self) = @_;
2513		2940
2514	return unless $::CONN;#d# manage and cache textures differently	2941	return unless $::CONN;
		2942
		2943	my $face;
		2944
		2945	if ($self->{frame}) {
		2946	my $anim = $::CONN->{anim}[$self->{anim}];
		2947
		2948	$face = $anim->[ $self->{frame} % @$anim ]
		2949	if $anim && @$anim;
		2950	}
		2951
2515	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$self->{face}]];	2952	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
2516		2953
2517	# TODO animation
2518	if ($tex) {	2954	if ($tex) {
2519	glEnable GL_TEXTURE_2D;	2955	glEnable GL_TEXTURE_2D;
2520	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2956	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2521	glColor 1, 1, 1, 1;	2957	glColor 0, 0, 0, 1;
2522	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});	2958	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
2523	glDisable GL_TEXTURE_2D;	2959	glDisable GL_TEXTURE_2D;
2524	}	2960	}
2525	}	2961	}
2526		2962
		2963	sub destroy {
		2964	my ($self) = @_;
		2965
		2966	$self->{timer}->cancel
		2967	if $self->{timer};
		2968
		2969	$self->SUPER::destroy;
		2970	}
		2971
2527	#############################################################################	2972	#############################################################################
2528		2973
2529	package CFClient::UI::InventoryItem;	2974	package CFClient::UI::Buttonbar;
2530		2975
2531	our @ISA = CFClient::UI::HBox::;	2976	our @ISA = CFClient::UI::HBox::;
2532		2977
2533	sub _item_to_desc {	2978	# TODO: should actualyl wrap buttons and other goodies.
2534	my ($item) = @_;
2535
2536	my $desc =
2537	$item->{nrof} < 2
2538	? $item->{name}
2539	: "$item->{nrof} $item->{name_pl}";
2540
2541	$item->{flags} & Crossfire::Protocol::F_OPEN
2542	and $desc .= " (open)";
2543	$item->{flags} & Crossfire::Protocol::F_APPLIED
2544	and $desc .= " (applied)";
2545	$item->{flags} & Crossfire::Protocol::F_UNPAID
2546	and $desc .= " (unpaid)";
2547	$item->{flags} & Crossfire::Protocol::F_MAGIC
2548	and $desc .= " (magic)";
2549	$item->{flags} & Crossfire::Protocol::F_CURSED
2550	and $desc .= " (cursed)";
2551	$item->{flags} & Crossfire::Protocol::F_DAMNED
2552	and $desc .= " (damned)";
2553	$item->{flags} & Crossfire::Protocol::F_LOCKED
2554	and $desc .= " *";
2555
2556	$desc
2557	}
2558
2559	sub new {
2560	my $class = shift;
2561
2562	my %args = @_;
2563
2564	my $item = delete $args{item};
2565
2566	my $desc = _item_to_desc ($item);
2567
2568	my $self = $class->SUPER::new (
2569	can_hover => 1,
2570	can_events => 1,
2571	tooltip => ((CFClient::UI::Label::escape $desc)
2572	. "\n<small>leftclick - pick up\nmiddle click - apply\nrightclick - menu</small>"),
2573	connect_button_down => sub {
2574	my ($self, $ev, $x, $y) = @_;
2575
2576	# todo: maybe put examine on 1? but should just be a tooltip :(
2577	if ($ev->{button} == 1) {
2578	my $targ = $::CONN->{player}{tag};
2579
2580	if ($item->{container} == $::CONN->{player}{tag}) {
2581	$targ = $main::OPENCONT;
2582	}
2583
2584	$::CONN->send ("move $targ $item->{tag} 0");
2585	} elsif ($ev->{button} == 2) {
2586	$::CONN->send ("apply $item->{tag}");
2587	} elsif ($ev->{button} == 3) {
2588	my @menu_items = (
2589	["examine", sub { $::CONN->send ("examine $item->{tag}") }],
2590	["mark", sub { $::CONN->send ("mark $item->{tag}") }],
2591	["apply", sub { $::CONN->send ("apply $item->{tag}") }],
2592	["drop", sub { $::CONN->send ("move $main::OPENCONT $item->{tag} 0") }],
2593	[
2594	$item->{flags} & Crossfire::Protocol::F_LOCKED ? "lock" : "unlock",
2595	sub { $::CONN->send ("lock $item->{tag}") },
2596	],
2597	);
2598
2599	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
2600	}
2601
2602	1
2603	},
2604	%args
2605	);
2606
2607
2608	$self->add (new CFClient::UI::Face
2609	can_events => 0,
2610	face => $item->{face},
2611	anim => $item->{anim},
2612	animspeed => $item->{animspeed},
2613	);
2614
2615	$self->add ($self->{name_lbl} = new CFClient::UI::Label can_events => 0);
2616
2617	$self->{item} = $item;
2618
2619	$self->update_item;
2620
2621	$self
2622	}
2623
2624	sub update_item {
2625	my ($self) = @_;
2626
2627	my $desc = _item_to_desc ($self->{item});
2628
2629	$self->{name_lbl}->set_text ($desc);
2630	}
2631
2632	#############################################################################
2633
2634	package CFClient::UI::Inventory;
2635
2636	our @ISA = CFClient::UI::ScrolledWindow::;
2637
2638	sub new {
2639	my $class = shift;
2640
2641	my $self = $class->SUPER::new (
2642	scrolled => (new CFClient::UI::VBox),
2643	@_,
2644	);
2645
2646	$self
2647	}
2648
2649	sub set_items {
2650	my ($self, $items) = @_;
2651
2652	$self->{scrolled}->clear;
2653	return unless $items;
2654
2655	my @items = sort {
2656	($a->{type} <=> $b->{type})
2657	or ($a->{name} cmp $b->{name})
2658	} @$items;
2659
2660	$self->{real_items} = \@items;
2661
2662	for my $item (@items) {
2663	$item = $item->{widget} ||= new CFClient::UI::InventoryItem item => $item;
2664	$item->update_item ();
2665	}
2666
2667	$self->{scrolled}->add (@items);
2668
2669	# $range->{range} = [$self->{pos}, 0, $self->{max_pos}, $page];
2670	}
2671
2672	sub size_request {
2673	my ($self) = @_;
2674	($self->{req_w}, $self->{req_h});
2675	}
2676		2979
2677	#############################################################################	2980	#############################################################################
2678		2981
2679	package CFClient::UI::Menu;	2982	package CFClient::UI::Menu;
2680		2983
…		…
2692	);	2995	);
2693		2996
2694	$self->add ($self->{vbox} = new CFClient::UI::VBox);	2997	$self->add ($self->{vbox} = new CFClient::UI::VBox);
2695		2998
2696	for my $item (@{ $self->{items} }) {	2999	for my $item (@{ $self->{items} }) {
2697	my ($widget, $cb) = @$item;	3000	my ($widget, $cb, $tooltip) = @$item;
2698		3001
2699	# handle various types of items, only text for now	3002	# handle various types of items, only text for now
2700	if (!ref $widget) {	3003	if (!ref $widget) {
2701	$widget = new CFClient::UI::Label	3004	$widget = new CFClient::UI::Label
2702	can_hover => 1,	3005	can_hover => 1,
2703	can_events => 1,	3006	can_events => 1,
2704	text => $widget;	3007	markup => $widget,
		3008	tooltip => $tooltip
2705	}	3009	}
2706		3010
2707	$self->{item}{$widget} = $item;	3011	$self->{item}{$widget} = $item;
2708		3012
2709	$self->{vbox}->add ($widget);	3013	$self->{vbox}->add ($widget);
…		…
2721	# maybe save $GRAB? must be careful about events...	3025	# maybe save $GRAB? must be careful about events...
2722	$GRAB = $self;	3026	$GRAB = $self;
2723	$self->{button} = $ev->{button};	3027	$self->{button} = $ev->{button};
2724		3028
2725	$self->show;	3029	$self->show;
2726	$self->move ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);	3030	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
2727	}	3031	}
2728		3032
2729	sub mouse_motion {	3033	sub invoke_mouse_motion {
2730	my ($self, $ev, $x, $y) = @_;	3034	my ($self, $ev, $x, $y) = @_;
2731		3035
2732	# TODO: should use vbox->find_widget or so	3036	# TODO: should use vbox->find_widget or so
2733	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});	3037	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
2734	$self->{hover} = $self->{item}{$HOVER};	3038	$self->{hover} = $self->{item}{$HOVER};
2735	}
2736		3039
		3040	0
		3041	}
		3042
2737	sub button_up {	3043	sub invoke_button_up {
2738	my ($self, $ev, $x, $y) = @_;	3044	my ($self, $ev, $x, $y) = @_;
2739		3045
2740	if ($ev->{button} == $self->{button}) {	3046	if ($ev->{button} == $self->{button}) {
2741	undef $GRAB;	3047	undef $GRAB;
2742	$self->hide;	3048	$self->hide;
2743		3049
2744	$self->emit ("popdown");	3050	$self->emit ("popdown");
2745	$self->{hover}[1]->() if $self->{hover};	3051	$self->{hover}[1]->() if $self->{hover};
		3052	} else {
		3053	return 0
		3054	}
		3055
2746	}	3056	1
2747	}	3057	}
2748		3058
2749	#############################################################################	3059	#############################################################################
2750		3060
2751	package CFClient::UI::Statusbox;	3061	package CFClient::UI::Multiplexer;
2752		3062
2753	our @ISA = CFClient::UI::VBox::;	3063	our @ISA = CFClient::UI::Container::;
2754		3064
2755	sub new {	3065	sub new {
2756	my $class = shift;	3066	my $class = shift;
2757		3067
2758	$class->SUPER::new (	3068	my $self = $class->SUPER::new (
		3069	@_,
		3070	);
		3071
		3072	$self->{current} = $self->{children}[0]
		3073	if @{ $self->{children} };
		3074
		3075	$self
		3076	}
		3077
		3078	sub add {
		3079	my ($self, @widgets) = @_;
		3080
		3081	$self->SUPER::add (@widgets);
		3082
		3083	$self->{current} = $self->{children}[0]
		3084	if @{ $self->{children} };
		3085	}
		3086
		3087	sub set_current_page {
		3088	my ($self, $page_or_widget) = @_;
		3089
		3090	my $widget = ref $page_or_widget
		3091	? $page_or_widget
		3092	: $self->{children}[$page_or_widget];
		3093
		3094	$self->{current} = $widget;
		3095	$self->{current}->configure (0, 0, $self->{w}, $self->{h});
		3096
		3097	$self->emit (page_changed => $self->{current});
		3098
		3099	$self->realloc;
		3100	}
		3101
		3102	sub visible_children {
		3103	$_[0]{current}
		3104	}
		3105
		3106	sub size_request {
		3107	my ($self) = @_;
		3108
		3109	$self->{current}->size_request
		3110	}
		3111
		3112	sub invoke_size_allocate {
		3113	my ($self, $w, $h) = @_;
		3114
		3115	$self->{current}->configure (0, 0, $w, $h);
		3116
		3117	1
		3118	}
		3119
		3120	sub _draw {
		3121	my ($self) = @_;
		3122
		3123	$self->{current}->draw;
		3124	}
		3125
		3126	#############################################################################
		3127
		3128	package CFClient::UI::Notebook;
		3129
		3130	our @ISA = CFClient::UI::VBox::;
		3131
		3132	sub new {
		3133	my $class = shift;
		3134
		3135	my $self = $class->SUPER::new (
		3136	buttonbar => (new CFClient::UI::Buttonbar),
		3137	multiplexer => (new CFClient::UI::Multiplexer expand => 1),
		3138	# filter => # will be put between multiplexer and $self
		3139	@_,
		3140	);
		3141
		3142	$self->{filter}->add ($self->{multiplexer}) if $self->{filter};
		3143	$self->SUPER::add ($self->{buttonbar}, $self->{filter} || $self->{multiplexer});
		3144
		3145	$self
		3146	}
		3147
		3148	sub add {
		3149	my ($self, $title, $widget, $tooltip) = @_;
		3150
		3151	Scalar::Util::weaken $self;
		3152
		3153	$self->{buttonbar}->add (new CFClient::UI::Button
		3154	markup => $title,
		3155	tooltip => $tooltip,
		3156	on_activate => sub { $self->set_current_page ($widget) },
		3157	);
		3158
		3159	$self->{multiplexer}->add ($widget);
		3160	}
		3161
		3162	sub set_current_page {
		3163	my ($self, $page) = @_;
		3164
		3165	$self->{multiplexer}->set_current_page ($page);
		3166	$self->emit (page_changed => $self->{multiplexer}{current});
		3167	}
		3168
		3169	#############################################################################
		3170
		3171	package CFClient::UI::Combobox;
		3172
		3173	use utf8;
		3174
		3175	our @ISA = CFClient::UI::Button::;
		3176
		3177	sub new {
		3178	my $class = shift;
		3179
		3180	my $self = $class->SUPER::new (
		3181	options => [], # [value, title, longdesc], ...
		3182	value => undef,
		3183	@_,
		3184	);
		3185
		3186	$self->_set_value ($self->{value});
		3187
		3188	$self
		3189	}
		3190
		3191	sub invoke_button_down {
		3192	my ($self, $ev) = @_;
		3193
		3194	my @menu_items;
		3195
		3196	for (@{ $self->{options} }) {
		3197	my ($value, $title, $tooltip) = @$_;
		3198
		3199	push @menu_items, [$tooltip || $title, sub { $self->set_value ($value) }];
		3200	}
		3201
		3202	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
		3203	}
		3204
		3205	sub _set_value {
		3206	my ($self, $value) = @_;
		3207
		3208	my ($item) = grep $_->[0] eq $value, @{ $self->{options} }
		3209	or return;
		3210
		3211	$self->{value} = $item->[0];
		3212	$self->set_markup ("$item->[1] ⇓");
		3213	$self->set_tooltip ($item->[2]);
		3214	}
		3215
		3216	sub set_value {
		3217	my ($self, $value) = @_;
		3218
		3219	return unless $self->{value} ne $value;
		3220
		3221	$self->_set_value ($value);
		3222	$self->emit (changed => $value);
		3223	}
		3224
		3225	#############################################################################
		3226
		3227	package CFClient::UI::Statusbox;
		3228
		3229	our @ISA = CFClient::UI::VBox::;
		3230
		3231	sub new {
		3232	my $class = shift;
		3233
		3234	my $self = $class->SUPER::new (
2759	fontsize => 0.8,	3235	fontsize => 0.8,
2760	@_,	3236	@_,
2761	)	3237	);
		3238
		3239	Scalar::Util::weaken (my $this = $self);
		3240
		3241	$self->{timer} = Event->timer (after => 1, interval => 1, cb => sub { $this->reorder });
		3242
		3243	$self
2762	}	3244	}
2763		3245
2764	sub reorder {	3246	sub reorder {
2765	my ($self) = @_;	3247	my ($self) = @_;
2766	my $NOW = time;	3248	my $NOW = Time::HiRes::time;
		3249
		3250	# freeze display when hovering over any label
		3251	return if $CFClient::UI::TOOLTIP->{owner}
		3252	&& grep $CFClient::UI::TOOLTIP->{owner} == $_->{label},
		3253	values %{ $self->{item} };
2767		3254
2768	while (my ($k, $v) = each %{ $self->{item} }) {	3255	while (my ($k, $v) = each %{ $self->{item} }) {
2769	delete $self->{item}{$k} if $v->{timeout} < $NOW;	3256	delete $self->{item}{$k} if $v->{timeout} < $NOW;
2770	}	3257	}
2771		3258
…		…
2774	my @items = sort {	3261	my @items = sort {
2775	$a->{pri} <=> $b->{pri}	3262	$a->{pri} <=> $b->{pri}
2776	or $b->{id} <=> $a->{id}	3263	or $b->{id} <=> $a->{id}
2777	} values %{ $self->{item} };	3264	} values %{ $self->{item} };
2778		3265
		3266	$self->{timer}->interval (1);
		3267
2779	my $count = 10 + 1;	3268	my $count = 10 + 1;
2780	for my $item (@items) {	3269	for my $item (@items) {
2781	last unless --$count;	3270	last unless --$count;
2782		3271
2783	push @widgets, $item->{label} ||= do {	3272	my $label = $item->{label} ||= do {
2784	# TODO: doesn't handle markup well (read as: at all)	3273	# TODO: doesn't handle markup well (read as: at all)
2785	my $short = $item->{count} > 1	3274	my $short = $item->{count} > 1
2786	? "<b>$item->{count} ×</b> $item->{text}"	3275	? "<b>$item->{count} ×</b> $item->{text}"
2787	: $item->{text};	3276	: $item->{text};
2788		3277
…		…
2796	tooltip => $item->{tooltip},	3285	tooltip => $item->{tooltip},
2797	tooltip_font => $::FONT_PROP,	3286	tooltip_font => $::FONT_PROP,
2798	tooltip_width => 0.67,	3287	tooltip_width => 0.67,
2799	fontsize => $item->{fontsize} || $self->{fontsize},	3288	fontsize => $item->{fontsize} || $self->{fontsize},
2800	max_w => $::WIDTH * 0.44,	3289	max_w => $::WIDTH * 0.44,
2801	fg => $item->{fg},	3290	fg => [@{ $item->{fg} }],
2802	can_events => 1,	3291	can_events => 1,
2803	can_hover => 1	3292	can_hover => 1
2804	};	3293	};
		3294
		3295	if ((my $diff = $item->{timeout} - $NOW) < 2) {
		3296	$label->{fg}[3] = ($item->{fg}[3] || 1) * $diff / 2;
		3297	$label->update;
		3298	$label->set_max_size (undef, $label->{req_h} * $diff)
		3299	if $diff < 1;
		3300	$self->{timer}->interval (1/30);
		3301	} else {
		3302	$label->{fg}[3] = $item->{fg}[3] || 1;
		3303	}
		3304
		3305	push @widgets, $label;
2805	}	3306	}
2806		3307
2807	$self->clear;	3308	$self->clear;
2808	$self->SUPER::add (reverse @widgets);	3309	$self->SUPER::add (reverse @widgets);
2809	}	3310	}
…		…
2812	my ($self, $text, %arg) = @_;	3313	my ($self, $text, %arg) = @_;
2813		3314
2814	$text =~ s/^\s+//;	3315	$text =~ s/^\s+//;
2815	$text =~ s/\s+$//;	3316	$text =~ s/\s+$//;
2816		3317
		3318	return unless $text;
		3319
2817	my $timeout = time + ((delete $arg{timeout}) || 60);	3320	my $timeout = (int time) + ((delete $arg{timeout}) || 60);
2818		3321
2819	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};	3322	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
2820		3323
2821	if (my $item = $self->{item}{$group}) {	3324	if (my $item = $self->{item}{$group}) {
2822	if ($item->{text} eq $text) {	3325	if ($item->{text} eq $text) {
2823	$item->{count}++;	3326	$item->{count}++;
2824	} else {	3327	} else {
2825	$item->{count} = 1;	3328	$item->{count} = 1;
2826	$item->{text} = $item->{tooltip} = $text;	3329	$item->{text} = $item->{tooltip} = $text;
2827	}	3330	}
2828	$item->{id} = ++$self->{id};	3331	$item->{id} += 0.2;#d#
2829	$item->{timeout} = $timeout;	3332	$item->{timeout} = $timeout;
2830	delete $item->{label};	3333	delete $item->{label};
2831	} else {	3334	} else {
2832	$self->{item}{$group} = {	3335	$self->{item}{$group} = {
2833	id => ++$self->{id},	3336	id => ++$self->{id},
…		…
2852		3355
2853	$self->reorder;	3356	$self->reorder;
2854	$self->SUPER::reconfigure;	3357	$self->SUPER::reconfigure;
2855	}	3358	}
2856		3359
		3360	sub destroy {
		3361	my ($self) = @_;
		3362
		3363	$self->{timer}->cancel;
		3364
		3365	$self->SUPER::destroy;
		3366	}
		3367
2857	#############################################################################	3368	#############################################################################
2858		3369
2859	package CFClient::UI::Root;	3370	package CFClient::UI::Inventory;
2860		3371
2861	our @ISA = CFClient::UI::Container::;	3372	our @ISA = CFClient::UI::ScrolledWindow::;
2862
2863	use CFClient::OpenGL;
2864		3373
2865	sub new {	3374	sub new {
2866	my $class = shift;	3375	my $class = shift;
2867		3376
2868	$class->SUPER::new (	3377	my $self = $class->SUPER::new (
		3378	child => (new CFClient::UI::Table col_expand => [0, 1, 0]),
		3379	@_,
		3380	);
		3381
		3382	$self
		3383	}
		3384
		3385	sub set_items {
		3386	my ($self, $items) = @_;
		3387
		3388	$self->{child}->clear;
		3389	return unless $items;
		3390
		3391	my @items = sort {
		3392	($a->{type} <=> $b->{type})
		3393	or ($a->{name} cmp $b->{name})
		3394	} @$items;
		3395
		3396	$self->{real_items} = \@items;
		3397
		3398	my $row = 0;
		3399	for my $item (@items) {
		3400	CFClient::Item::update_widgets $item;
		3401
		3402	$self->{child}->add (0, $row, $item->{face_widget});
		3403	$self->{child}->add (1, $row, $item->{desc_widget});
		3404	$self->{child}->add (2, $row, $item->{weight_widget});
		3405
		3406	$row++;
		3407	}
		3408	}
		3409
		3410	#############################################################################
		3411
		3412	package CFClient::UI::BindEditor;
		3413
		3414	our @ISA = CFClient::UI::FancyFrame::;
		3415
		3416	sub new {
		3417	my $class = shift;
		3418
		3419	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3420
		3421	$self->add (my $vb = new CFClient::UI::VBox);
		3422
		3423
		3424	$vb->add ($self->{rec_btn} = new CFClient::UI::Button
		3425	text => "start recording",
		3426	tooltip => "Start/Stops recording of actions."
		3427	."All subsequent actions after the recording started will be captured."
		3428	."The actions are displayed after the record was stopped."
		3429	."To bind the action you have to click on the 'Bind' button",
		3430	on_activate => sub {
		3431	unless ($self->{recording}) {
		3432	$self->start;
		3433	} else {
		3434	$self->stop;
		3435	}
		3436	});
		3437
		3438	$vb->add (new CFClient::UI::Label text => "Actions:");
		3439	$vb->add ($self->{cmdbox} = new CFClient::UI::VBox);
		3440
		3441	$vb->add (new CFClient::UI::Label text => "Bound to: ");
		3442	$vb->add (my $hb = new CFClient::UI::HBox);
		3443	$hb->add ($self->{keylbl} = new CFClient::UI::Label expand => 1);
		3444	$hb->add (new CFClient::UI::Button
		3445	text => "bind",
		3446	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
		3447	on_activate => sub {
		3448	$self->ask_for_bind;
		3449	});
		3450
		3451	$vb->add (my $hb = new CFClient::UI::HBox);
		3452	$hb->add (new CFClient::UI::Button
		3453	text => "ok",
		3454	expand => 1,
		3455	tooltip => "This closes the binding editor and saves the binding",
		3456	on_activate => sub {
		3457	$self->hide;
		3458	$self->commit;
		3459	});
		3460
		3461	$hb->add (new CFClient::UI::Button
		3462	text => "cancel",
		3463	expand => 1,
		3464	tooltip => "This closes the binding editor without saving",
		3465	on_activate => sub {
		3466	$self->hide;
		3467	$self->{binding_cancel}->()
		3468	if $self->{binding_cancel};
		3469	});
		3470
		3471	$self->update_binding_widgets;
		3472
		3473	$self
		3474	}
		3475
		3476	sub commit {
		3477	my ($self) = @_;
		3478	my ($mod, $sym, $cmds) = $self->get_binding;
		3479	if ($sym != 0 && @$cmds > 0) {
		3480	$::STATUSBOX->add ("Bound actions to '".CFClient::Binder::keycombo_to_name ($mod, $sym)
		3481	."'. Don't forget 'Save Config'!");
		3482	$self->{binding_change}->($mod, $sym, $cmds)
		3483	if $self->{binding_change};
		3484	} else {
		3485	$::STATUSBOX->add ("No action bound, no key or action specified!");
		3486	$self->{binding_cancel}->()
		3487	if $self->{binding_cancel};
		3488	}
		3489	}
		3490
		3491	sub start {
		3492	my ($self) = @_;
		3493
		3494	$self->{rec_btn}->set_text ("stop recording");
		3495	$self->{recording} = 1;
		3496	$self->clear_command_list;
		3497	$::CONN->start_record if $::CONN;
		3498	}
		3499
		3500	sub stop {
		3501	my ($self) = @_;
		3502
		3503	$self->{rec_btn}->set_text ("start recording");
		3504	$self->{recording} = 0;
		3505
		3506	my $rec;
		3507	$rec = $::CONN->stop_record if $::CONN;
		3508	return unless ref $rec eq 'ARRAY';
		3509	$self->set_command_list ($rec);
		3510	}
		3511
		3512
		3513	sub ask_for_bind_and_commit {
		3514	my ($self) = @_;
		3515	$self->ask_for_bind (1);
		3516	}
		3517
		3518	sub ask_for_bind {
		3519	my ($self, $commit, $end_cb) = @_;
		3520
		3521	CFClient::Binder::open_binding_dialog (sub {
		3522	my ($mod, $sym) = @_;
		3523	$self->{binding} = [$mod, $sym]; # XXX: how to stop that memleak?
		3524	$self->update_binding_widgets;
		3525	$self->commit if $commit;
		3526	$end_cb->() if $end_cb;
		3527	});
		3528	}
		3529
		3530	# $mod and $sym are the modifiers and key symbol
		3531	# $cmds is a array ref of strings (the commands)
		3532	# $cb is the callback that is executed on OK
		3533	# $ccb is the callback that is executed on CANCEL and
		3534	# when the binding was unsuccessful on OK
		3535	sub set_binding {
		3536	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
		3537
		3538	$self->clear_command_list;
		3539	$self->{recording} = 0;
		3540	$self->{rec_btn}->set_text ("start recording");
		3541
		3542	$self->{binding} = [$mod, $sym];
		3543	$self->{commands} = $cmds;
		3544
		3545	$self->{binding_change} = $cb;
		3546	$self->{binding_cancel} = $ccb;
		3547
		3548	$self->update_binding_widgets;
		3549	}
		3550
		3551	# this is a shortcut method that asks for a binding
		3552	# and then just binds it.
		3553	sub do_quick_binding {
		3554	my ($self, $cmds, $end_cb) = @_;
		3555	$self->set_binding (undef, undef, $cmds, sub {
		3556	$::CFG->{bindings}->{$_[0]}->{$_[1]} = $_[2];
		3557	});
		3558	$self->ask_for_bind (1, $end_cb);
		3559	}
		3560
		3561	sub update_binding_widgets {
		3562	my ($self) = @_;
		3563	my ($mod, $sym, $cmds) = $self->get_binding;
		3564	$self->{keylbl}->set_text (CFClient::Binder::keycombo_to_name ($mod, $sym));
		3565	$self->set_command_list ($cmds);
		3566	}
		3567
		3568	sub get_binding {
		3569	my ($self) = @_;
		3570	return (
		3571	$self->{binding}->[0],
		3572	$self->{binding}->[1],
		3573	[ grep { defined $_ } @{$self->{commands}} ]
		3574	);
		3575	}
		3576
		3577	sub clear_command_list {
		3578	my ($self) = @_;
		3579	$self->{cmdbox}->clear ();
		3580	}
		3581
		3582	sub set_command_list {
		3583	my ($self, $cmds) = @_;
		3584
		3585	$self->{cmdbox}->clear ();
		3586	$self->{commands} = $cmds;
		3587
		3588	my $idx = 0;
		3589
		3590	for (@$cmds) {
		3591	$self->{cmdbox}->add (my $hb = new CFClient::UI::HBox);
		3592
		3593	my $i = $idx;
		3594	$hb->add (new CFClient::UI::Label text => $_);
		3595	$hb->add (new CFClient::UI::Button
		3596	text => "delete",
		3597	tooltip => "Deletes the action from the record",
		3598	on_activate => sub {
		3599	$self->{cmdbox}->remove ($hb);
		3600	$cmds->[$i] = undef;
		3601	});
		3602
		3603
		3604	$idx++
		3605	}
		3606	}
		3607
		3608	#############################################################################
		3609
		3610	package CFClient::UI::SpellList;
		3611
		3612	our @ISA = CFClient::UI::Table::;
		3613
		3614	sub new {
		3615	my $class = shift;
		3616
		3617	my $self = $class->SUPER::new (
		3618	binding => [],
		3619	commands => [],
2869	@_,	3620	@_,
2870	)	3621	)
2871	}	3622	}
2872		3623
2873	sub configure {	3624	my $TOOLTIP_ALL = "\n\n<small>Left click - ready spell\nMiddle click - invoke spell\nRight click - further options</small>";
2874	my ($self, $x, $y, $w, $h) = @_;
2875		3625
2876	$self->{w} = $w;	3626	my @TOOLTIP_NAME = (align => -1, can_events => 1, can_hover => 1, tooltip =>
2877	$self->{h} = $h;	3627	"<b>Name</b>. The name of the spell.$TOOLTIP_ALL");
2878	}	3628	my @TOOLTIP_SKILL = (align => -1, can_events => 1, can_hover => 1, tooltip =>
		3629	"<b>Skill</b>. The skill (or magic school) required to be able to attempt casting this spell.$TOOLTIP_ALL");
		3630	my @TOOLTIP_LVL = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3631	"<b>Level</b>. Minimum level the caster needs in the associated skill to be able to attempt casting this spell.$TOOLTIP_ALL");
		3632	my @TOOLTIP_SP = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3633	"<b>Spell points / Grace points</b>. Amount of spell or grace points used by each invocation.$TOOLTIP_ALL");
		3634	my @TOOLTIP_DMG = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3635	"<b>Damage</b>. The amount of damage the spell deals when it hits.$TOOLTIP_ALL");
2879		3636
2880	sub check_size {	3637	sub rebuild_spell_list {
		3638	my ($self) = @_;
		3639
		3640	$CFClient::UI::ROOT->on_refresh ($self => sub {
		3641	$self->clear;
		3642
		3643	return unless $::CONN;
		3644
		3645	$self->add (1, 0, new CFClient::UI::Label text => "Spell Name", @TOOLTIP_NAME);
		3646	$self->add (2, 0, new CFClient::UI::Label text => "Skill", @TOOLTIP_SKILL);
		3647	$self->add (3, 0, new CFClient::UI::Label text => "Lvl" , @TOOLTIP_LVL);
		3648	$self->add (4, 0, new CFClient::UI::Label text => "Sp/Gp", @TOOLTIP_SP);
		3649	$self->add (5, 0, new CFClient::UI::Label text => "Dmg" , @TOOLTIP_DMG);
		3650
		3651	my $row = 0;
		3652
		3653	for (sort { $a cmp $b } keys %{ $self->{spell} }) {
		3654	my $spell = $self->{spell}{$_};
		3655
		3656	$row++;
		3657
		3658	my $spell_cb = sub {
		3659	my ($widget, $ev) = @_;
		3660
		3661	if ($ev->{button} == 1) {
		3662	$::CONN->user_send ("cast $spell->{name}");
		3663	} elsif ($ev->{button} == 2) {
		3664	$::CONN->user_send ("invoke $spell->{name}");
		3665	} elsif ($ev->{button} == 3) {
		3666	(new CFClient::UI::Menu
		3667	items => [
		3668	["bind <i>cast $spell->{name}</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) }],
		3669	["bind <i>invoke $spell->{name}</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["invoke $spell->{name}"]) }],
		3670	],
		3671	)->popup ($ev);
		3672	} else {
		3673	return 0;
		3674	}
		3675
		3676	1
		3677	};
		3678
		3679	my $tooltip = "$spell->{message}$TOOLTIP_ALL";
		3680
		3681	#TODO: add path info to tooltip
		3682	#$self->add (6, $row, new CFClient::UI::Label text => $spell->{path});
		3683
		3684	$self->add (0, $row, new CFClient::UI::Face
		3685	face => $spell->{face},
		3686	can_hover => 1,
		3687	can_events => 1,
		3688	tooltip => $tooltip,
		3689	on_button_down => $spell_cb,
		3690	);
		3691
		3692	$self->add (1, $row, new CFClient::UI::Label
		3693	expand => 1,
		3694	text => $spell->{name},
		3695	can_hover => 1,
		3696	can_events => 1,
		3697	tooltip => $tooltip,
		3698	on_button_down => $spell_cb,
		3699	);
		3700
		3701	$self->add (2, $row, new CFClient::UI::Label text => $::CONN->{skill_info}{$spell->{skill}}, @TOOLTIP_SKILL);
		3702	$self->add (3, $row, new CFClient::UI::Label text => $spell->{level}, @TOOLTIP_LVL);
		3703	$self->add (4, $row, new CFClient::UI::Label text => $spell->{mana} || $spell->{grace}, @TOOLTIP_SP);
		3704	$self->add (5, $row, new CFClient::UI::Label text => $spell->{damage}, @TOOLTIP_DMG);
		3705	}
		3706	});
		3707	}
		3708
		3709	sub add_spell {
2881	my ($self) = @_;	3710	my ($self, $spell) = @_;
2882		3711
2883	$self->size_allocate ($self->{w}, $self->{h})	3712	$self->{spell}->{$spell->{name}} = $spell;
2884	if $self->{w};	3713	$self->rebuild_spell_list;
		3714	}
		3715
		3716	sub remove_spell {
		3717	my ($self, $spell) = @_;
		3718
		3719	delete $self->{spell}->{$spell->{name}};
		3720	$self->rebuild_spell_list;
		3721	}
		3722
		3723	sub clear_spells {
		3724	my ($self) = @_;
		3725
		3726	$self->{spell} = {};
		3727	$self->rebuild_spell_list;
		3728	}
		3729
		3730	#############################################################################
		3731
		3732	package CFClient::UI::Root;
		3733
		3734	our @ISA = CFClient::UI::Container::;
		3735
		3736	use List::Util qw(min max);
		3737
		3738	use CFClient::OpenGL;
		3739
		3740	sub new {
		3741	my $class = shift;
		3742
		3743	my $self = $class->SUPER::new (
		3744	visible => 1,
		3745	@_,
		3746	);
		3747
		3748	Scalar::Util::weaken ($self->{root} = $self);
		3749
		3750	$self
2885	}	3751	}
2886		3752
2887	sub size_request {	3753	sub size_request {
2888	my ($self) = @_;	3754	my ($self) = @_;
2889		3755
2890	($self->{w}, $self->{h})	3756	($self->{w}, $self->{h})
2891	}	3757	}
2892		3758
		3759	sub _to_pixel {
		3760	my ($coord, $size, $max) = @_;
		3761
		3762	$coord =
		3763	$coord eq "center" ? ($max - $size) * 0.5
		3764	: $coord eq "max" ? $max
		3765	: $coord;
		3766
		3767	$coord = 0 if $coord < 0;
		3768	$coord = $max - $size if $coord > $max - $size;
		3769
		3770	int $coord + 0.5
		3771	}
		3772
2893	sub size_allocate {	3773	sub invoke_size_allocate {
2894	my ($self, $w, $h) = @_;	3774	my ($self, $w, $h) = @_;
2895
2896	my $old_w = $self->{old_w}; $self->{old_w} = $w;
2897	my $old_h = $self->{old_h}; $self->{old_h} = $h;
2898
2899	CFClient::UI::rescale_widgets $w / $old_w, $h / $old_h
2900	if $old_w && $old_h && ($old_w != $w || $old_h != $h);
2901		3775
2902	for my $child ($self->children) {	3776	for my $child ($self->children) {
2903	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};	3777	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};
2904		3778
2905	$X = $child->{req_x} > 0 ? $child->{req_x} : $w - $W - $child->{req_x} + 1	3779	$X = $child->{force_x} if exists $child->{force_x};
2906	if exists $child->{req_x};	3780	$Y = $child->{force_y} if exists $child->{force_y};
2907		3781
2908	$Y = $child->{req_y} > 0 ? $child->{req_y} : $h - $H - $child->{req_y} + 1	3782	$X = _to_pixel $X, $W, $self->{w};
2909	if exists $child->{req_y};	3783	$Y = _to_pixel $Y, $H, $self->{h};
2910
2911	$X = List::Util::max 0, List::Util::min $w - $W, int $X + 0.5;
2912	$Y = List::Util::max 0, List::Util::min $h - $H, int $Y + 0.5;
2913		3784
2914	$child->configure ($X, $Y, $W, $H);	3785	$child->configure ($X, $Y, $W, $H);
2915	}	3786	}
		3787
		3788	1
2916	}	3789	}
2917		3790
2918	sub coord2local {	3791	sub coord2local {
2919	my ($self, $x, $y) = @_;	3792	my ($self, $x, $y) = @_;
2920		3793
…		…
2928	}	3801	}
2929		3802
2930	sub update {	3803	sub update {
2931	my ($self) = @_;	3804	my ($self) = @_;
2932		3805
2933	$self->check_size;
2934	$::WANT_REFRESH++;	3806	$::WANT_REFRESH++;
2935	}	3807	}
2936		3808
2937	sub add {	3809	sub add {
2938	my ($self, @children) = @_;	3810	my ($self, @children) = @_;
2939		3811
2940	for my $child (@children) {
2941	$child->{toplevel} = 1;	3812	$_->{is_toplevel} = 1
2942		3813	for @children;
2943	# integerise window positions
2944	$child->{x} = int $child->{x};
2945	$child->{y} = int $child->{y};
2946	}
2947		3814
2948	$self->SUPER::add (@children);	3815	$self->SUPER::add (@children);
		3816	}
		3817
		3818	sub remove {
		3819	my ($self, @children) = @_;
		3820
		3821	$self->SUPER::remove (@children);
		3822
		3823	delete $self->{is_toplevel}
		3824	for @children;
		3825
		3826	while (@children) {
		3827	my $w = pop @children;
		3828	push @children, $w->children;
		3829	$w->set_invisible;
		3830	}
2949	}	3831	}
2950		3832
2951	sub on_refresh {	3833	sub on_refresh {
2952	my ($self, $id, $cb) = @_;	3834	my ($self, $id, $cb) = @_;
2953		3835
…		…
2966	while ($self->{refresh_hook}) {	3848	while ($self->{refresh_hook}) {
2967	$_->()	3849	$_->()
2968	for values %{delete $self->{refresh_hook}};	3850	for values %{delete $self->{refresh_hook}};
2969	}	3851	}
2970		3852
2971	if ($self->{check_size}) {	3853	if ($self->{realloc}) {
2972	my @queue = ([], []);	3854	my %queue;
		3855	my @queue;
		3856	my $widget;
2973		3857
2974	for (;;) {	3858	outer:
2975	if ($self->{check_size}) {	3859	while () {
2976	# heuristic: check containers last	3860	if (my $realloc = delete $self->{realloc}) {
2977	push @{ $queue[ ! ! $_->isa ("CFClient::UI::Container") ] }, $_	3861	for $widget (values %$realloc) {
2978	for values %{delete $self->{check_size}}	3862	$widget->{visible} or next; # do not resize invisible widgets
		3863
		3864	$queue{$widget+0}++ and next; # duplicates are common
		3865
		3866	push @{ $queue[$widget->{visible}] }, $widget;
		3867	}
2979	}	3868	}
2980		3869
2981	my $widget = (pop @{ $queue[0] }) || (pop @{ $queue[1] }) || last;	3870	while () {
		3871	@queue or last outer;
2982		3872
2983	my ($w, $h) = $widget->{user_w} && $widget->{user_h}	3873	$widget = pop @{ $queue[-1] || [] }
2984	? @$widget{qw(user_w user_h)}	3874	and last;
2985	: $widget->size_request;
2986
2987	if (delete $widget->{force_alloc}
2988	or $w != $widget->{req_w} or $h != $widget->{req_h}) {
2989	Carp::confess "$widget: size_request is negative" if $w < 0 || $h < 0;#d#
2990		3875
		3876	pop @queue;
		3877	}
		3878
		3879	delete $queue{$widget+0};
		3880
		3881	my ($w, $h) = $widget->size_request;
		3882
		3883	$w = max $widget->{min_w}, $w + $widget->{padding_x} * 2;
		3884	$h = max $widget->{min_h}, $h + $widget->{padding_y} * 2;
		3885
		3886	$w = min $widget->{max_w}, $w if exists $widget->{max_w};
		3887	$h = min $widget->{max_h}, $h if exists $widget->{max_h};
		3888
		3889	$w = $widget->{force_w} if exists $widget->{force_w};
		3890	$h = $widget->{force_h} if exists $widget->{force_h};
		3891
		3892	if ($widget->{req_w} != $w || $widget->{req_h} != $h
		3893	|| delete $widget->{force_realloc}) {
2991	$widget->{req_w} = $w;	3894	$widget->{req_w} = $w;
2992	$widget->{req_h} = $h;	3895	$widget->{req_h} = $h;
2993		3896
2994	$self->{size_alloc}{$widget} = [$widget, $widget->{w} || $w, $widget->{h} || $h];	3897	$self->{size_alloc}{$widget+0} = $widget;
2995		3898
2996	$widget->{parent}->check_size
2997	if $widget->{parent};	3899	if (my $parent = $widget->{parent}) {
		3900	$self->{realloc}{$parent+0} = $parent
		3901	unless $queue{$parent+0};
		3902
		3903	$parent->{force_size_alloc} = 1;
		3904	$self->{size_alloc}{$parent+0} = $parent;
		3905	}
2998	}	3906	}
		3907
		3908	delete $self->{realloc}{$widget+0};
2999	}	3909	}
3000	}	3910	}
3001		3911
3002	while ($self->{size_alloc}) {	3912	while (my $size_alloc = delete $self->{size_alloc}) {
3003	for (values %{delete $self->{size_alloc}}) {	3913	my @queue = sort { $b->{visible} <=> $a->{visible} }
3004	my ($widget, $w, $h) = @$_;	3914	values %$size_alloc;
		3915
		3916	while () {
		3917	my $widget = pop @queue || last;
		3918
		3919	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};
3005		3920
3006	$w = 0 if $w < 0;	3921	$w = 0 if $w < 0;
3007	$h = 0 if $h < 0;	3922	$h = 0 if $h < 0;
3008		3923
		3924	$w = int $w + 0.5;
		3925	$h = int $h + 0.5;
		3926
		3927	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {
		3928	$widget->{old_w} = $widget->{w};
		3929	$widget->{old_h} = $widget->{h};
		3930
3009	$widget->{w} = $w;	3931	$widget->{w} = $w;
3010	$widget->{h} = $h;	3932	$widget->{h} = $h;
3011	$widget->size_allocate ($w, $h);	3933
3012	$widget->emit (size_allocate => $w, $h);	3934	$widget->emit (size_allocate => $w, $h);
		3935	}
3013	}	3936	}
3014	}	3937	}
3015		3938
3016	while ($self->{post_alloc_hook}) {	3939	while ($self->{post_alloc_hook}) {
3017	$_->()	3940	$_->()
3018	for values %{delete $self->{post_alloc_hook}};	3941	for values %{delete $self->{post_alloc_hook}};
3019	}	3942	}
3020		3943
		3944
3021	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3945	glViewport 0, 0, $::WIDTH, $::HEIGHT;
3022	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3946	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
3023	glClear GL_COLOR_BUFFER_BIT;	3947	glClear GL_COLOR_BUFFER_BIT;
3024		3948
3025	glMatrixMode GL_PROJECTION;	3949	glMatrixMode GL_PROJECTION;
3026	glLoadIdentity;	3950	glLoadIdentity;
3027	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000 , 10000;	3951	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
3028	glMatrixMode GL_MODELVIEW;	3952	glMatrixMode GL_MODELVIEW;
3029	glLoadIdentity;	3953	glLoadIdentity;
3030		3954
		3955	{
		3956	package CFClient::UI::Base;
		3957
		3958	($draw_x, $draw_y, $draw_w, $draw_h) =
		3959	(0, 0, $self->{w}, $self->{h});
		3960	}
		3961
3031	$self->_draw;	3962	$self->_draw;
3032	}	3963	}
3033		3964
3034	#############################################################################	3965	#############################################################################
3035		3966

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines