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.189 by root, Mon May 8 22:17:24 2006 UTC vs.
Revision 1.311 by root, Fri Jun 23 22:35:16 2006 UTC

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

Diff Legend

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