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

Diff Legend

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