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.170 by root, Mon Apr 24 11:45:17 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	$TOOLTIP->move ($widget->coord2global ($widget->{w}, 0));
30	$TOOLTIP->show;	38	$TOOLTIP->show;
31	}	39	}
32		40
33	return;	41	return;
34	}	42	}
35	}	43	}
36	}	44	}
37		45
38	$TOOLTIP->hide;	46	$TOOLTIP->hide;
39	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;
40	}	71	}
41		72
42	# class methods for events	73	# class methods for events
43	sub feed_sdl_key_down_event {	74	sub feed_sdl_key_down_event {
44	$FOCUS->emit (key_down => $_[0]) || $FOCUS->key_down ($_[0])	75	$FOCUS->emit (key_down => $_[0])
45	if $FOCUS;	76	if $FOCUS;
46	}	77	}
47		78
48	sub feed_sdl_key_up_event {	79	sub feed_sdl_key_up_event {
49	$FOCUS->emit (key_up => $_[0]) || $FOCUS->key_up ($_[0])	80	$FOCUS->emit (key_up => $_[0])
50	if $FOCUS;	81	if $FOCUS;
51	}	82	}
52		83
53	sub feed_sdl_button_down_event {	84	sub feed_sdl_button_down_event {
54	my ($ev) = @_;	85	my ($ev) = @_;
…		…
58	my $widget = $ROOT->find_widget ($x, $y);	89	my $widget = $ROOT->find_widget ($x, $y);
59		90
60	$GRAB = $widget;	91	$GRAB = $widget;
61	$GRAB->update if $GRAB;	92	$GRAB->update if $GRAB;
62		93
63	check_tooltip;	94	$TOOLTIP_WATCHER->cb->();
64	}	95	}
65		96
66	$BUTTON_STATE |= 1 << ($ev->{button} - 1);	97	$BUTTON_STATE |= 1 << ($ev->{button} - 1);
67		98
68	if ($GRAB) {	99	$GRAB->emit (button_down => $ev, $GRAB->coord2local ($x, $y))
69	($x, $y) = $GRAB->coord2local ($x, $y);	100	if $GRAB;
70	$GRAB->emit (button_down => $ev, $x, $y) || $GRAB->button_down ($ev, $x, $y);
71	}
72	}	101	}
73		102
74	sub feed_sdl_button_up_event {	103	sub feed_sdl_button_up_event {
75	my ($ev) = @_;	104	my ($ev) = @_;
76	my ($x, $y) = ($ev->{x}, $ev->{y});	105	my ($x, $y) = ($ev->{x}, $ev->{y});
77		106
78	my $widget = $GRAB || $ROOT->find_widget ($x, $y);	107	my $widget = $GRAB || $ROOT->find_widget ($x, $y);
79		108
80	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));	109	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));
81		110
82	if ($GRAB) {	111	$GRAB->emit (button_up => $ev, $GRAB->coord2local ($x, $y))
83	($x, $y) = $GRAB->coord2local ($x, $y);	112	if $GRAB;
84	$GRAB->emit (button_up => $ev, $x, $y) || $GRAB->button_up ($ev, $x, $y);
85	}
86		113
87	if (!$BUTTON_STATE) {	114	if (!$BUTTON_STATE) {
88	my $grab = $GRAB; undef $GRAB;	115	my $grab = $GRAB; undef $GRAB;
89	$grab->update if $grab;	116	$grab->update if $grab;
90	$GRAB->update if $GRAB;	117	$GRAB->update if $GRAB;
91		118
92	check_tooltip;	119	$TOOLTIP_WATCHER->cb->();
93	}	120	}
94	}	121	}
95		122
96	sub feed_sdl_motion_event {	123	sub feed_sdl_motion_event {
97	my ($ev) = @_;	124	my ($ev) = @_;
…		…
103	my $hover = $HOVER; $HOVER = $widget;	130	my $hover = $HOVER; $HOVER = $widget;
104		131
105	$hover->update if $hover && $hover->{can_hover};	132	$hover->update if $hover && $hover->{can_hover};
106	$HOVER->update if $HOVER && $HOVER->{can_hover};	133	$HOVER->update if $HOVER && $HOVER->{can_hover};
107		134
108	check_tooltip;	135	$TOOLTIP_WATCHER->start;
109	}	136	}
110		137
111	if ($HOVER) {
112	($x, $y) = $HOVER->coord2local ($x, $y);
113	$HOVER->emit (mouse_motion => $ev, $x, $y) || $HOVER->mouse_motion ($ev, $x, $y);	138	$HOVER->emit (mouse_motion => $ev, $HOVER->coord2local ($x, $y))
114	}	139	if $HOVER;
115	}	140	}
116		141
117	# convert position array to integers	142	# convert position array to integers
118	sub harmonize {	143	sub harmonize {
119	my ($vals) = @_;	144	my ($vals) = @_;
…		…
125	$rem += $_ - $i;	150	$rem += $_ - $i;
126	$_ = $i;	151	$_ = $i;
127	}	152	}
128	}	153	}
129		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
130	#############################################################################	196	#############################################################################
131		197
132	package CFClient::UI::Base;	198	package CFClient::UI::Base;
133		199
134	use strict;	200	use strict;
…		…
137		203
138	sub new {	204	sub new {
139	my $class = shift;	205	my $class = shift;
140		206
141	my $self = bless {	207	my $self = bless {
142	x => 0,	208	x => "center",
143	y => 0,	209	y => "center",
144	z => 0,	210	z => 0,
		211	w => undef,
		212	h => undef,
145	can_events => 1,	213	can_events => 1,
146	@_	214	@_
147	}, $class;	215	}, $class;
148		216
		217	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);
		218
149	for (keys %$self) {	219	for (keys %$self) {
150	if (/^connect_(.*)$/) {	220	if (/^on_(.*)$/) {
151	$self->connect ($1 => delete $self->{$_});	221	$self->connect ($1 => delete $self->{$_});
152	}	222	}
153	}	223	}
154		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
155	$self	237	$self
156	}	238	}
157		239
158	sub destroy {	240	sub destroy {
159	my ($self) = @_;	241	my ($self) = @_;
…		…
168	return if $self->{parent};	250	return if $self->{parent};
169		251
170	$CFClient::UI::ROOT->add ($self);	252	$CFClient::UI::ROOT->add ($self);
171	}	253	}
172		254
173	sub hide {	255	sub set_visible {
174	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};
175		279
176	undef $GRAB if $GRAB == $self;	280	undef $GRAB if $GRAB == $self;
177	undef $HOVER if $HOVER == $self;	281	undef $HOVER if $HOVER == $self;
178		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
179	$self->{parent}->remove ($self)	312	$self->{parent}->remove ($self)
180	if $self->{parent};	313	if $self->{parent};
181	}	314	}
182		315
183	sub move {	316	sub move_abs {
184	my ($self, $x, $y, $z) = @_;	317	my ($self, $x, $y, $z) = @_;
185		318
186	$self->{x} = int $x;	319	$self->{x} = List::Util::max 0, List::Util::min $self->{root}{w} - $self->{w}, int $x;
187	$self->{y} = int $y;	320	$self->{y} = List::Util::max 0, List::Util::min $self->{root}{h} - $self->{h}, int $y;
188	$self->{z} = $z if defined $z;	321	$self->{z} = $z if defined $z;
189		322
190	$self->update;	323	$self->update;
191	}	324	}
192		325
193	sub set_size {	326	sub set_size {
194	my ($self, $w, $h) = @_;	327	my ($self, $w, $h) = @_;
195		328
196	$self->{user_w} = $w;	329	$self->{force_w} = $w;
197	$self->{user_h} = $h;	330	$self->{force_h} = $h;
198		331
199	$self->check_size;	332	$self->realloc;
200	}	333	}
201		334
202	sub size_request {	335	sub size_request {
203	require Carp;	336	require Carp;
204	Carp::confess "size_request is abstract";	337	Carp::confess "size_request is abstract";
…		…
206		339
207	sub configure {	340	sub configure {
208	my ($self, $x, $y, $w, $h) = @_;	341	my ($self, $x, $y, $w, $h) = @_;
209		342
210	if ($self->{aspect}) {	343	if ($self->{aspect}) {
		344	my ($ow, $oh) = ($w, $h);
		345
211	my $w2 = List::Util::min $w, int $h * $self->{aspect};	346	$w = List::Util::min $w, int $h * $self->{aspect};
212	my $h2 = List::Util::min $h, int $w / $self->{aspect};	347	$h = List::Util::min $h, int $w / $self->{aspect};
213		348
214	# use alignment to adjust x, y	349	# use alignment to adjust x, y
215		350
216	$x += int +($w - $w2) * 0.5;	351	$x += int 0.5 * ($ow - $w);
217	$y += int +($h - $h2) * 0.5;	352	$y += int 0.5 * ($oh - $h);
218
219	($w, $h) = ($w2, $h2);
220	}	353	}
221		354
222	if ($self->{x} != $x || $self->{y} != $y) {	355	if ($self->{x} ne $x || $self->{y} ne $y) {
223	$self->{x} = $x;	356	$self->{x} = $x;
224	$self->{y} = $y;	357	$self->{y} = $y;
225	$self->update;	358	$self->update;
226	}	359	}
227		360
228	if ($self->{w} != $w || $self->{h} != $h) {	361	if ($self->{alloc_w} != $w || $self->{alloc_h} != $h) {
		362	return unless $self->{visible};
		363
229	$self->{w} = $w;	364	$self->{alloc_w} = $w;
230	$self->{h} = $h;	365	$self->{alloc_h} = $h;
231		366
232	$self->size_allocate ($w, $h);	367	$self->{root}{size_alloc}{$self+0} = $self;
233	$self->update;
234	}	368	}
235	}	369	}
236		370
237	sub size_allocate {	371	sub children {
238	# nothing to be done	372	# nop
		373	}
		374
		375	sub visible_children {
		376	$_[0]->children
239	}	377	}
240		378
241	sub set_max_size {	379	sub set_max_size {
242	my ($self, $w, $h) = @_;	380	my ($self, $w, $h) = @_;
243		381
244	delete $self->{max_w}; $self->{max_w} = $w if $w;	382	$self->{max_w} = int $w if defined $w;
245	delete $self->{max_h}; $self->{max_h} = $h if $h;	383	$self->{max_h} = int $h if defined $h;
246	}
247		384
248	# return top left coordinates	385	$self->realloc;
249	sub _topleft {	386	}
		387
		388	sub set_tooltip {
250	my ($self, $x, $y) = @_;	389	my ($self, $tooltip) = @_;
251		390
252	$self->{parent}	391	$tooltip =~ s/^\s+//;
253	or Carp::confess "no parent widget in _topleft\n";#d#	392	$tooltip =~ s/\s+$//;
254		393
255	$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	}
256	}	402	}
257		403
258	# translate global coordinates to local coordinate system	404	# translate global coordinates to local coordinate system
259	sub coord2local {	405	sub coord2local {
260	my ($self, $x, $y) = @_;	406	my ($self, $x, $y) = @_;
261		407
262	my ($X, $Y) = $self->_topleft;	408	$self->{parent}->coord2local ($x - $self->{x}, $y - $self->{y})
263	($x - $X, $y - $Y)
264	}	409	}
265		410
266	# translate local coordinates to global coordinate system	411	# translate local coordinates to global coordinate system
267	sub coord2global {	412	sub coord2global {
268	my ($self, $x, $y) = @_;	413	my ($self, $x, $y) = @_;
269		414
270	my ($X, $Y) = $self->_topleft;	415	$self->{parent}->coord2global ($x + $self->{x}, $y + $self->{y})
271	($x + $X, $y + $Y)
272	}	416	}
273		417
274	sub focus_in {	418	sub invoke_focus_in {
275	my ($self) = @_;	419	my ($self) = @_;
276		420
277	return if $FOCUS == $self;	421	return if $FOCUS == $self;
278	return unless $self->{can_focus};	422	return unless $self->{can_focus};
279		423
280	my $focus = $FOCUS; $FOCUS = $self;	424	my $focus = $FOCUS; $FOCUS = $self;
281		425
282	$self->emit (focus_in => $focus);
283
284	$focus->update if $focus;	426	$focus->update if $focus;
285	$FOCUS->update;	427	$FOCUS->update;
286	}
287		428
		429	0
		430	}
		431
288	sub focus_out {	432	sub invoke_focus_out {
289	my ($self) = @_;	433	my ($self) = @_;
290		434
291	return unless $FOCUS == $self;	435	return unless $FOCUS == $self;
292		436
293	my $focus = $FOCUS; undef $FOCUS;	437	my $focus = $FOCUS; undef $FOCUS;
294		438
295	$self->emit (focus_out => $focus);
296
297	$focus->update if $focus; #?	439	$focus->update if $focus; #?
298	}
299		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
300	sub mouse_motion { }	453	sub invoke_mouse_motion { 1 }
301	sub button_up { }	454	sub invoke_button_up { 1 }
302	sub key_down { }	455	sub invoke_key_down { 1 }
303	sub key_up { }	456	sub invoke_key_up { 1 }
304		457
305	sub button_down {	458	sub invoke_button_down {
306	my ($self, $ev, $x, $y) = @_;	459	my ($self, $ev, $x, $y) = @_;
307		460
308	$self->focus_in;	461	$self->grab_focus;
309	}
310		462
311	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	463	1
312	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	464	}
313	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	465
314	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	466	sub connect {
315	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
316		531
317	sub draw {	532	sub draw {
318	my ($self) = @_;	533	my ($self) = @_;
319		534
320	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);
321		546
322	glPushMatrix;	547	glPushMatrix;
323	glTranslate $self->{x}, $self->{y}, 0;	548	glTranslate $self->{x}, $self->{y}, 0;
324	$self->_draw;
325	glPopMatrix;
326		549
327	if ($self == $HOVER && $self->{can_hover}) {	550	if ($self == $HOVER && $self->{can_hover}) {
328	my ($x, $y) = @$self{qw(x y)};
329
330	glColor 1, 0.8, 0.5, 0.2;	551	glColor 1*0.2, 0.8*0.2, 0.5*0.2, 0.2;
331	glEnable GL_BLEND;	552	glEnable GL_BLEND;
332	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	553	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
333	glBegin GL_QUADS;	554	glBegin GL_QUADS;
334	glVertex $x , $y;
335	glVertex $x + $self->{w}, $y;
336	glVertex $x + $self->{w}, $y + $self->{h};
337	glVertex $x , $y + $self->{h};
338	glEnd;
339	glDisable GL_BLEND;
340	}
341
342	if ($ENV{PCLIENT_DEBUG}) {
343	glPushMatrix;
344	glColor 1, 1, 0, 1;
345	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;
346	glBegin GL_LINE_LOOP;
347	glVertex 0 , 0;	555	glVertex 0 , 0;
348	glVertex $self->{w}, 0;	556	glVertex $self->{w}, 0;
349	glVertex $self->{w}, $self->{h};	557	glVertex $self->{w}, $self->{h};
350	glVertex 0 , $self->{h};	558	glVertex 0 , $self->{h};
351	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;
352	glPopMatrix;	573	glPopMatrix;
353	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;
354	}	575	}
		576
		577	$self->_draw;
		578	glPopMatrix;
355	}	579	}
356		580
357	sub _draw {	581	sub _draw {
358	my ($self) = @_;	582	my ($self) = @_;
359		583
360	warn "no draw defined for $self\n";	584	warn "no draw defined for $self\n";
361	}	585	}
362		586
363	sub find_widget {
364	my ($self, $x, $y) = @_;
365
366	return () unless $self->{can_events};
367
368	return $self
369	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
370	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
371
372	()
373	}
374
375	sub set_parent {
376	my ($self, $parent) = @_;
377
378	Scalar::Util::weaken ($self->{parent} = $parent);
379	}
380
381	sub check_size {
382	my ($self) = @_;
383
384	$self->{parent}
385	or return 1;
386
387	my ($w, $h) = $self->{user_w} && $self->{user_h}
388	? @$self{qw(user_w user_h)}
389	: $self->size_request;
390
391	if ($w != $self->{req_w} || $h != $self->{req_h}) {
392	$self->{req_w} = $w;
393	$self->{req_h} = $h;
394
395	$self->{parent}->check_size
396	or $self->size_allocate (
397	(List::Util::max $self->{w}, $w),
398	(List::Util::max $self->{h}, $h),
399	);
400
401	1
402	} else {
403	0
404	}
405	}
406
407	sub update {
408	my ($self) = @_;
409
410	$self->{parent}->update
411	if $self->{parent};
412	}
413
414	sub connect {
415	my ($self, $signal, $cb) = @_;
416
417	push @{ $self->{signal_cb}{$signal} }, $cb;
418	}
419
420	sub emit {
421	my ($self, $signal, @args) = @_;
422
423	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
424	}
425
426	sub DESTROY {	587	sub DESTROY {
427	my ($self) = @_;	588	my ($self) = @_;
428		589
429	#$self->deactivate;	590	delete $WIDGET{$self+0};
		591
		592	eval { $self->destroy };
		593	warn "exception during widget destruction: $@" if $@ & $@ != /during global destruction/;
430	}	594	}
431		595
432	#############################################################################	596	#############################################################################
433		597
434	package CFClient::UI::DrawBG;	598	package CFClient::UI::DrawBG;
…		…
442	my $class = shift;	606	my $class = shift;
443		607
444	# range [value, low, high, page]	608	# range [value, low, high, page]
445		609
446	$class->SUPER::new (	610	$class->SUPER::new (
447	bg => [0, 0, 0, 0.2],	611	#bg => [0, 0, 0, 0.2],
448	active_bg => [1, 1, 1, 0.5],	612	#active_bg => [1, 1, 1, 0.5],
449	@_	613	@_
450	)	614	)
451	}	615	}
452		616
453	sub _draw {	617	sub _draw {
454	my ($self) = @_;	618	my ($self) = @_;
455		619
		620	my $color = $FOCUS == $self && $self->{active_bg}
		621	? $self->{active_bg}
		622	: $self->{bg};
		623
		624	if ($color && (@$color < 4 || $color->[3])) {
456	my ($w, $h) = @$self{qw(w h)};	625	my ($w, $h) = @$self{qw(w h)};
457		626
458	glEnable GL_BLEND;	627	glEnable GL_BLEND;
459	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	628	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
460	glColor @{ $FOCUS == $self ? $self->{active_bg} : $self->{bg} };	629	glColor_premultiply @$color;
461		630
462	glBegin GL_QUADS;	631	glBegin GL_QUADS;
463	glVertex 0 , 0;	632	glVertex 0 , 0;
464	glVertex 0 , $h;	633	glVertex 0 , $h;
465	glVertex $w, $h;	634	glVertex $w, $h;
466	glVertex $w, 0;	635	glVertex $w, 0;
467	glEnd;	636	glEnd;
468		637
469	glDisable GL_BLEND;	638	glDisable GL_BLEND;
		639	}
470	}	640	}
471		641
472	#############################################################################	642	#############################################################################
473		643
474	package CFClient::UI::Empty;	644	package CFClient::UI::Empty;
…		…
479	my ($class, %arg) = @_;	649	my ($class, %arg) = @_;
480	$class->SUPER::new (can_events => 0, %arg);	650	$class->SUPER::new (can_events => 0, %arg);
481	}	651	}
482		652
483	sub size_request {	653	sub size_request {
484	(0, 0)	654	my ($self) = @_;
		655
		656	($self->{w} + 0, $self->{h} + 0)
485	}	657	}
486		658
487	sub draw { }	659	sub draw { }
488		660
489	#############################################################################	661	#############################################################################
…		…
493	our @ISA = CFClient::UI::Base::;	665	our @ISA = CFClient::UI::Base::;
494		666
495	sub new {	667	sub new {
496	my ($class, %arg) = @_;	668	my ($class, %arg) = @_;
497		669
498	my $children = delete $arg{children} || [];	670	my $children = delete $arg{children};
499		671
500	my $self = $class->SUPER::new (	672	my $self = $class->SUPER::new (
501	children => [],	673	children => [],
502	can_events => 0,	674	can_events => 0,
503	%arg,	675	%arg,
504	);	676	);
		677
505	$self->add ($_) for @$children;	678	$self->add (@$children)
		679	if $children;
506		680
507	$self	681	$self
508	}	682	}
509		683
510	sub add {	684	sub add {
511	my ($self, $child) = @_;	685	my ($self, @widgets) = @_;
512		686
513	$child->set_parent ($self);	687	$_->set_parent ($self)
		688	for @widgets;
514		689
515	use sort 'stable';	690	use sort 'stable';
516		691
517	$self->{children} = [	692	$self->{children} = [
518	sort { $a->{z} <=> $b->{z} }	693	sort { $a->{z} <=> $b->{z} }
519	@{$self->{children}}, $child	694	@{$self->{children}}, @widgets
520	];	695	];
521		696
522	$child->check_size;	697	$self->realloc;
		698	}
		699
		700	sub children {
		701	@{ $_[0]{children} }
523	}	702	}
524		703
525	sub remove {	704	sub remove {
526	my ($self, $child) = @_;	705	my ($self, $child) = @_;
527		706
528	delete $child->{parent};	707	delete $child->{parent};
529	$child->hide;	708	$child->hide;
530		709
531	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];	710	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];
532		711
533	$self->check_size;	712	$self->realloc;
534	$self->update;
535	}	713	}
536		714
537	sub clear {	715	sub clear {
538	my ($self) = @_;	716	my ($self) = @_;
539		717
…		…
542		720
543	for (@$children) {	721	for (@$children) {
544	delete $_->{parent};	722	delete $_->{parent};
545	$_->hide;	723	$_->hide;
546	}	724	}
		725
		726	$self->realloc;
547	}	727	}
548		728
549	sub find_widget {	729	sub find_widget {
550	my ($self, $x, $y) = @_;	730	my ($self, $x, $y) = @_;
551		731
552	$x -= $self->{x};	732	$x -= $self->{x};
553	$y -= $self->{y};	733	$y -= $self->{y};
554		734
555	my $res;	735	my $res;
556		736
557	for (reverse @{ $self->{children} }) {	737	for (reverse $self->visible_children) {
558	$res = $_->find_widget ($x, $y)	738	$res = $_->find_widget ($x, $y)
559	and return $res;	739	and return $res;
560	}	740	}
561		741
562	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})	742	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})
…		…
583	}	763	}
584		764
585	sub add {	765	sub add {
586	my ($self, $child) = @_;	766	my ($self, $child) = @_;
587		767
588	$self->{children} = [];	768	$self->SUPER::remove ($_) for @{ $self->{children} };
589
590	$self->SUPER::add ($child);	769	$self->SUPER::add ($child);
591	}	770	}
592		771
593	sub remove {	772	sub remove {
594	my ($self, $widget) = @_;	773	my ($self, $widget) = @_;
…		…
603		782
604	sub size_request {	783	sub size_request {
605	$_[0]{children}[0]->size_request	784	$_[0]{children}[0]->size_request
606	}	785	}
607		786
608	sub size_allocate {	787	sub invoke_size_allocate {
609	my ($self, $w, $h) = @_;	788	my ($self, $w, $h) = @_;
610		789
611	$self->{children}[0]->configure (0, 0, $w, $h);	790	$self->{children}[0]->configure (0, 0, $w, $h);
		791
		792	1
612	}	793	}
613		794
614	#############################################################################	795	#############################################################################
		796
		797	# back-buffered drawing area
615		798
616	package CFClient::UI::Window;	799	package CFClient::UI::Window;
617		800
618	our @ISA = CFClient::UI::Bin::;	801	our @ISA = CFClient::UI::Bin::;
619		802
…		…
626	}	809	}
627		810
628	sub update {	811	sub update {
629	my ($self) = @_;	812	my ($self) = @_;
630		813
631	# we want to do this delayed...	814	$ROOT->on_post_alloc ($self => sub { $self->render_child });
632	$self->render_chld;
633	$self->SUPER::update;	815	$self->SUPER::update;
634	}	816	}
635		817
		818	sub invoke_size_allocate {
		819	my ($self, $w, $h) = @_;
		820
		821	$self->update;
		822
		823	$self->SUPER::invoke_size_allocate ($w, $h)
		824	}
		825
		826	sub _render {
		827	my ($self) = @_;
		828
		829	$self->{children}[0]->draw;
		830	}
		831
636	sub render_chld {	832	sub render_child {
637	my ($self) = @_;	833	my ($self) = @_;
638		834
639	$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 {
640	glClearColor 0, 0, 0, 1;	836	glClearColor 0, 0, 0, 0;
641	glClear GL_COLOR_BUFFER_BIT;	837	glClear GL_COLOR_BUFFER_BIT;
642	$self->child->draw;	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
		846	$self->_render;
643	};	847	};
644	}	848	}
645		849
646	sub size_allocate {
647	my ($self, $w, $h) = @_;
648
649	$self->child->configure (0, 0, $w, $h);
650
651	$self->render_chld;
652	}
653
654	sub _draw {	850	sub _draw {
655	my ($self) = @_;	851	my ($self) = @_;
656		852
657	my ($w, $h) = ($self->w, $self->h);	853	my ($w, $h) = @$self{qw(w h)};
658		854
659	my $tex = $self->{texture}	855	my $tex = $self->{texture}
660	or return;	856	or return;
661		857
662	glEnable GL_BLEND;
663	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
664	glEnable GL_TEXTURE_2D;	858	glEnable GL_TEXTURE_2D;
665	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	859	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
		860	glColor 0, 0, 0, 1;
666		861
667	$tex->draw_quad (0, 0, $w, $h);	862	$tex->draw_quad_alpha_premultiplied (0, 0, $w, $h);
668		863
669	glDisable GL_BLEND;
670	glDisable GL_TEXTURE_2D;	864	glDisable GL_TEXTURE_2D;
671	}	865	}
672		866
673	#############################################################################	867	#############################################################################
674		868
675	package CFClient::UI::ViewPort;	869	package CFClient::UI::ViewPort;
676		870
677	our @ISA = CFClient::UI::Window::;	871	our @ISA = CFClient::UI::Window::;
678
679	sub new { die }
680
681	sub size_request {
682	my ($self) = @_;
683
684	@$self{qw(child_w child_h)} = @{$self->child}{qw(req_w req_h)};
685	$self->child->size_allocate (0, 0, @$self{qw(child_w child_h)});
686
687	@$self{qw(child_w child_h)}
688	}
689
690	sub _draw {
691	my ($self) = @_;
692
693	$self->{children}[1]->draw;
694	}
695
696
697	#############################################################################
698
699	package CFClient::UI::Frame;
700
701	our @ISA = CFClient::UI::Bin::;
702
703	use CFClient::OpenGL;
704		872
705	sub new {	873	sub new {
706	my $class = shift;	874	my $class = shift;
707		875
		876	$class->SUPER::new (
		877	scroll_x => 0,
		878	scroll_y => 1,
		879	@_,
		880	)
		881	}
		882
		883	sub size_request {
		884	my ($self) = @_;
		885
		886	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
		887
		888	$w = 10 if $self->{scroll_x};
		889	$h = 10 if $self->{scroll_y};
		890
		891	($w, $h)
		892	}
		893
		894	sub invoke_size_allocate {
		895	my ($self, $w, $h) = @_;
		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);
		903	$self->update;
		904
		905	1
		906	}
		907
		908	sub set_offset {
		909	my ($self, $x, $y) = @_;
		910
		911	$self->{view_x} = int $x;
		912	$self->{view_y} = int $y;
		913
		914	$self->update;
		915	}
		916
		917	# hmm, this does not work for topleft of $self... but we should not ask for that
		918	sub coord2local {
		919	my ($self, $x, $y) = @_;
		920
		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)
		931	}
		932
		933	sub find_widget {
		934	my ($self, $x, $y) = @_;
		935
		936	if ( $x >= $self->{x} && $x < $self->{x} + $self->{w}
		937	&& $y >= $self->{y} && $y < $self->{y} + $self->{h}
		938	) {
		939	$self->child->find_widget ($x + $self->{view_x}, $y + $self->{view_y})
		940	} else {
		941	$self->CFClient::UI::Base::find_widget ($x, $y)
		942	}
		943	}
		944
		945	sub _render {
		946	my ($self) = @_;
		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
		951	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};
		952
		953	$self->SUPER::_render;
		954	}
		955
		956	#############################################################################
		957
		958	package CFClient::UI::ScrolledWindow;
		959
		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
708	my $self = $class->SUPER::new (	977	$self = $class->SUPER::new (
709	bg => [1, 1, 1, 1],	978	vp => (new CFClient::UI::ViewPort expand => 1),
710	border_bg => [1, 1, 1, 1],	979	slider => $slider,
711	border => 0.8,	980	%arg,
712	@_
713	);	981	);
714		982
		983	$self->SUPER::add ($self->{vp}, $self->{slider});
		984	$self->add ($child) if $child;
		985
715	$self	986	$self
716	}	987	}
717		988
718	sub _draw {	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 {
719	my ($self) = @_;	1006	my ($self, $w, $h) = @_;
720		1007
721	my ($w, $h) = ($self->{w}, $self->{h});	1008	my $child = $self->{vp}->child;
		1009	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
722		1010
723	glEnable GL_BLEND;	1011	$self->SUPER::invoke_size_allocate ($w, $h)
724	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
725	glEnable GL_TEXTURE_2D;
726	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
727
728	# glBegin GL_QUADS;
729	# glColor 0, 0, 0, 0;
730	# glVertex 0 , 0;
731	# glVertex 0 , $h;
732	# glVertex $w, $h;
733	# glVertex $w, 0;
734	# glEnd;
735
736
737	$self->child->draw;
738	glDisable GL_BLEND;
739	glDisable GL_TEXTURE_2D;
740	}	1012	}
		1013
		1014	#TODO# update range on size_allocate depending on child
		1015	# update viewport offset on scroll
741		1016
742	#############################################################################	1017	#############################################################################
743		1018
744	package CFClient::UI::FancyFrame;	1019	package CFClient::UI::Frame;
745		1020
746	our @ISA = CFClient::UI::Bin::;	1021	our @ISA = CFClient::UI::Bin::;
747		1022
748	use CFClient::OpenGL;	1023	use CFClient::OpenGL;
749
750	my @tex =
751	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
752	qw(d1_bg.png d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
753		1024
754	sub new {	1025	sub new {
755	my $class = shift;	1026	my $class = shift;
756		1027
757	# TODO: user_x, user_y, overwrite moveto?	1028	$class->SUPER::new (
		1029	bg => undef,
		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) = @_;
758		1075
759	my $self = $class->SUPER::new (	1076	my $self = $class->SUPER::new (
760	bg => [1, 1, 1, 1],	1077	bg => [1, 1, 1, 1],
761	border_bg => [1, 1, 1, 1],	1078	border_bg => [1, 1, 1, 1],
762	border => 0.8,	1079	border => 0.6,
763	can_events => 1,	1080	can_events => 1,
764	@_	1081	min_w => 16,
		1082	min_h => 16,
		1083	%arg,
765	);	1084	);
766		1085
767	$self->{title} &&= new CFClient::UI::Label	1086	$self->{title_widget} = new CFClient::UI::Label
768	align => 0,	1087	align => 0,
769	valign => 1,	1088	valign => 1,
770	text => $self->{title},	1089	text => $self->{title},
771	fontsize => 1;	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	}
772		1101
773	$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};
774	}	1111	}
775		1112
776	sub border {	1113	sub border {
777	int $_[0]{border} * $::FONTSIZE	1114	int $_[0]{border} * $::FONTSIZE
778	}	1115	}
779		1116
780	sub size_request {	1117	sub size_request {
781	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};
782		1125
783	my ($w, $h) = $self->SUPER::size_request;	1126	my ($w, $h) = $self->SUPER::size_request;
784		1127
785	(	1128	(
786	$w + $self->border * 2,	1129	$w + $self->border * 2,
787	$h + $self->border * 2,	1130	$h + $self->border * 2,
788	)	1131	)
789	}	1132	}
790		1133
791	sub size_allocate {	1134	sub invoke_size_allocate {
792	my ($self, $w, $h) = @_;	1135	my ($self, $w, $h) = @_;
793		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
794	$h -= List::Util::max 0, $self->border * 2;	1145	$h -= List::Util::max 0, $border * 2;
795	$w -= List::Util::max 0, $self->border * 2;	1146	$w -= List::Util::max 0, $border * 2;
796		1147
797	$self->{title}->configure ($self->border, $self->border - $::FONTSIZE * 2, $w, $::FONTSIZE * 2)
798	if $self->{title};
799
800	$self->child->configure ($self->border, $self->border, $w, $h);	1148	$self->child->configure ($border, $border, $w, $h);
801	}
802		1149
		1150	$self->{close_button}->configure ($self->{w} - $border, 0, $border, $border)
		1151	if $self->{close_button};
		1152
		1153	1
		1154	}
		1155
803	sub button_down {	1156	sub invoke_button_down {
804	my ($self, $ev, $x, $y) = @_;	1157	my ($self, $ev, $x, $y) = @_;
805		1158
		1159	my ($w, $h) = @$self{qw(w h)};
806	my $border = $self->border;	1160	my $border = $self->border;
807		1161
808	if ($x < $self->{w} && $x >= $self->{w} - $border	1162	my $lr = ($x >= 0 && $x < $border) || ($x > $w - $border && $x < $w);
809	&& $y < $self->{h} && $y >= $self->{h} - $border) {	1163	my $td = ($y >= 0 && $y < $border) || ($y > $h - $border && $y < $h);
810		1164
		1165	if ($lr & $td) {
		1166	my ($wx, $wy) = ($self->{x}, $self->{y});
811	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1167	my ($ox, $oy) = ($ev->{x}, $ev->{y});
812	my ($bw, $bh) = ($self->{w}, $self->{h});	1168	my ($bw, $bh) = ($self->{w}, $self->{h});
813		1169
		1170	my $mx = $x < $border;
		1171	my $my = $y < $border;
		1172
814	$self->{motion} = sub {	1173	$self->{motion} = sub {
815	my ($ev, $x, $y) = @_;	1174	my ($ev, $x, $y) = @_;
816		1175
817	($x, $y) = ($ev->{x}, $ev->{y});	1176	my $dx = $ev->{x} - $ox;
		1177	my $dy = $ev->{y} - $oy;
818		1178
819	$self->{user_w} = $bw + $x - $ox;	1179	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
820	$self->{user_h} = $bh + $y - $oy;	1180	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
821	$self->check_size;	1181
		1182	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
		1183	$self->realloc;
822	};	1184	};
823		1185
824	} elsif ($x >= 0 && $x < $self->{w}	1186	} elsif ($lr ^ $td) {
825	&& $y >= 0 && $y < $border) {
826
827	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1187	my ($ox, $oy) = ($ev->{x}, $ev->{y});
828	my ($bx, $by) = ($self->{x}, $self->{y});	1188	my ($bx, $by) = ($self->{x}, $self->{y});
829		1189
830	$self->{motion} = sub {	1190	$self->{motion} = sub {
831	my ($ev, $x, $y) = @_;	1191	my ($ev, $x, $y) = @_;
832		1192
833	($x, $y) = ($ev->{x}, $ev->{y});	1193	($x, $y) = ($ev->{x}, $ev->{y});
834		1194
835	$self->move ($bx + $x - $ox, $by + $y - $oy);	1195	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
836	$self->update;	1196	# HACK: the next line is required to enforce placement
		1197	$self->{parent}->invoke_size_allocate ($self->{parent}{w}, $self->{parent}{h});
837	};	1198	};
		1199	} else {
		1200	return 0;
		1201	}
		1202
838	}	1203	1
839	}	1204	}
840		1205
841	sub button_up {	1206	sub invoke_button_up {
842	my ($self, $ev, $x, $y) = @_;	1207	my ($self, $ev, $x, $y) = @_;
843		1208
844	delete $self->{motion};	1209	! ! delete $self->{motion}
845	}	1210	}
846		1211
847	sub mouse_motion {	1212	sub invoke_mouse_motion {
848	my ($self, $ev, $x, $y) = @_;	1213	my ($self, $ev, $x, $y) = @_;
849		1214
850	$self->{motion}->($ev, $x, $y) if $self->{motion};	1215	$self->{motion}->($ev, $x, $y) if $self->{motion};
		1216
		1217	! ! $self->{motion}
851	}	1218	}
852		1219
853	sub _draw {	1220	sub _draw {
854	my ($self) = @_;	1221	my ($self) = @_;
855		1222
		1223	my $child = $self->{children}[0];
		1224
856	my ($w, $h ) = ($self->{w}, $self->{h});	1225	my ($w, $h ) = ($self->{w}, $self->{h});
857	my ($cw, $ch) = ($self->child->{w}, $self->child->{h});	1226	my ($cw, $ch) = ($child->{w}, $child->{h});
858		1227
859	glEnable GL_BLEND;
860	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
861	glEnable GL_TEXTURE_2D;	1228	glEnable GL_TEXTURE_2D;
862	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1229	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
863		1230
864	my $border = $self->border;	1231	my $border = $self->border;
865		1232
866	glColor @{ $self->{border_bg} };	1233	glColor @{ $self->{border_bg} };
867	$tex[1]->draw_quad (0, 0, $w, $border);	1234	$border[0]->draw_quad_alpha (0, 0, $w, $border);
868	$tex[3]->draw_quad (0, $border, $border, $ch);	1235	$border[1]->draw_quad_alpha (0, $border, $border, $ch);
869	$tex[2]->draw_quad ($w - $border, $border, $border, $ch);	1236	$border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);
870	$tex[4]->draw_quad (0, $h - $border, $w, $border);	1237	$border[3]->draw_quad_alpha (0, $h - $border, $w, $border);
871		1238
872	my $bg = $tex[0];	1239	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {
		1240	glColor @{ $self->{bg} };
873		1241
874	# TODO: repeat texture not scale	1242	# TODO: repeat texture not scale
875	my $rep_x = $cw / $bg->{w};	1243	# solve this better(?)
876	my $rep_y = $ch / $bg->{h};	1244	$bg->{s} = $cw / $bg->{w};
877		1245	$bg->{t} = $ch / $bg->{h};
878	glColor @{ $self->{bg} };
879
880	$bg->{s} = $rep_x;
881	$bg->{t} = $rep_y;
882	$bg->{wrap_mode} = 1;
883	$bg->draw_quad ($border, $border, $cw, $ch);	1246	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
		1247	}
884		1248
885	glDisable GL_TEXTURE_2D;	1249	glDisable GL_TEXTURE_2D;
886	glDisable GL_BLEND;
887		1250
888	$self->{title}->draw if $self->{title};
889	$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};
890	}	1262	}
891		1263
892	#############################################################################	1264	#############################################################################
893		1265
894	package CFClient::UI::Table;	1266	package CFClient::UI::Table;
…		…
902	sub new {	1274	sub new {
903	my $class = shift;	1275	my $class = shift;
904		1276
905	$class->SUPER::new (	1277	$class->SUPER::new (
906	col_expand => [],	1278	col_expand => [],
907	@_	1279	@_,
908	)	1280	)
		1281	}
		1282
		1283	sub children {
		1284	grep $_, map @$_, grep $_, @{ $_[0]{children} }
909	}	1285	}
910		1286
911	sub add {	1287	sub add {
912	my ($self, $x, $y, $child) = @_;	1288	my ($self, $x, $y, $child) = @_;
913		1289
914	$child->set_parent ($self);	1290	$child->set_parent ($self);
915	$self->{children}[$y][$x] = $child;	1291	$self->{children}[$y][$x] = $child;
916		1292
917	$child->check_size;	1293	$self->realloc;
918	}	1294	}
919		1295
		1296	sub remove {
		1297	my ($self, $child) = @_;
		1298
		1299	# TODO: not yet implemented
		1300	}
		1301
920	# 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?
921	sub clear {	1303	sub clear {
922	my ($self) = @_;	1304	my ($self) = @_;
923		1305
924	my $children = delete $self->{children};	1306	my @children = $self->children;
		1307	delete $self->{children};
925		1308
926	for (grep $_, map @$_, grep $_, @$children) {	1309	for (@children) {
927	delete $_->{parent};	1310	delete $_->{parent};
928	$_->hide;	1311	$_->hide;
929	}	1312	}
930		1313
931	$self->update;	1314	$self->realloc;
932	}	1315	}
933		1316
934	sub get_wh {	1317	sub get_wh {
935	my ($self) = @_;	1318	my ($self) = @_;
936		1319
…		…
962	(sum @$ws),	1345	(sum @$ws),
963	(sum @$hs),	1346	(sum @$hs),
964	)	1347	)
965	}	1348	}
966		1349
967	sub size_allocate {	1350	sub invoke_size_allocate {
968	my ($self, $w, $h) = @_;	1351	my ($self, $w, $h) = @_;
969		1352
970	my ($ws, $hs) = $self->get_wh;	1353	my ($ws, $hs) = $self->get_wh;
971		1354
972	my $req_w = sum @$ws;	1355	my $req_w = (sum @$ws) || 1;
973	my $req_h = sum @$hs;	1356	my $req_h = (sum @$hs) || 1;
974		1357
975	# TODO: nicer code && do row_expand	1358	# TODO: nicer code && do row_expand
976	my @col_expand = @{$self->{col_expand}};	1359	my @col_expand = @{$self->{col_expand}};
977	@col_expand = (1) x @$ws unless @col_expand;	1360	@col_expand = (1) x @$ws unless @col_expand;
978	my $col_expand = (sum @col_expand) || 1;	1361	my $col_expand = (sum @col_expand) || 1;
…		…
1004	}	1387	}
1005		1388
1006	$y += $row_h;	1389	$y += $row_h;
1007	}	1390	}
1008		1391
		1392	1
1009	}	1393	}
1010		1394
1011	sub find_widget {	1395	sub find_widget {
1012	my ($self, $x, $y) = @_;	1396	my ($self, $x, $y) = @_;
1013		1397
…		…
1032	}	1416	}
1033	}	1417	}
1034		1418
1035	#############################################################################	1419	#############################################################################
1036		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
1037	package CFClient::UI::HBox;	1481	package CFClient::UI::HBox;
1038		1482
1039	# TODO: wrap into common Box base class
1040
1041	our @ISA = CFClient::UI::Container::;	1483	our @ISA = CFClient::UI::Box::;
1042		1484
1043	sub size_request {	1485	sub new {
1044	my ($self) = @_;	1486	my $class = shift;
1045		1487
1046	my @alloc = map [$_->size_request], @{$self->{children}};	1488	$class->SUPER::new (
1047		1489	vertical => 0,
1048	(	1490	@_,
1049	(List::Util::sum map $_->[0], @alloc),
1050	(List::Util::max map $_->[1], @alloc),
1051	)	1491	)
1052	}	1492	}
1053		1493
1054	sub size_allocate {
1055	my ($self, $w, $h) = @_;
1056
1057	($h, $w) = ($w, $h);
1058
1059	my $children = $self->{children};
1060
1061	my @h = map $_->{req_w}, @$children;
1062
1063	my $req_h = List::Util::sum @h;
1064
1065	if ($req_h > $h) {
1066	# ah well, not enough space
1067	$_ *= $h / $req_h for @h;
1068	} else {
1069	my $exp = List::Util::sum map $_->{expand}, @$children;
1070	$exp ||= 1;
1071
1072	for (0 .. $#$children) {
1073	my $child = $children->[$_];
1074
1075	my $alloc_h = $h[$_];
1076	$alloc_h += ($h - $req_h) * $child->{expand} / $exp;
1077	$h[$_] = $alloc_h;
1078	}
1079	}
1080
1081	CFClient::UI::harmonize \@h;
1082
1083	my $y = 0;
1084	for (0 .. $#$children) {
1085	my $child = $children->[$_];
1086	my $h = $h[$_];
1087	$child->configure ($y, 0, $h, $w);
1088
1089	$y += $h;
1090	}
1091
1092	1
1093	}
1094
1095	#############################################################################	1494	#############################################################################
1096		1495
1097	package CFClient::UI::VBox;	1496	package CFClient::UI::VBox;
1098		1497
1099	# TODO: wrap into common Box base class
1100
1101	our @ISA = CFClient::UI::Container::;	1498	our @ISA = CFClient::UI::Box::;
1102		1499
1103	sub size_request {	1500	sub new {
1104	my ($self) = @_;	1501	my $class = shift;
1105		1502
1106	my @alloc = map [$_->size_request], @{$self->{children}};	1503	$class->SUPER::new (
1107		1504	vertical => 1,
1108	(	1505	@_,
1109	(List::Util::max map $_->[0], @alloc),
1110	(List::Util::sum map $_->[1], @alloc),
1111	)	1506	)
1112	}	1507	}
1113		1508
1114	sub size_allocate {
1115	my ($self, $w, $h) = @_;
1116
1117	my $children = $self->{children};
1118
1119	my @h = map $_->{req_h}, @$children;
1120
1121	my $req_h = List::Util::sum @h;
1122
1123	if ($req_h > $h) {
1124	# ah well, not enough space
1125	$_ *= $h / $req_h for @h;
1126	} else {
1127	my $exp = List::Util::sum map $_->{expand}, @$children;
1128	$exp ||= 1;
1129
1130	for (0 .. $#$children) {
1131	my $child = $children->[$_];
1132
1133	$h[$_] += ($h - $req_h) * $child->{expand} / $exp;
1134	}
1135	}
1136
1137	CFClient::UI::harmonize \@h;
1138
1139	my $y = 0;
1140	for (0 .. $#$children) {
1141	my $child = $children->[$_];
1142	my $h = $h[$_];
1143	$child->configure (0, $y, $w, $h);
1144
1145	$y += $h;
1146	}
1147
1148	1
1149	}
1150
1151	#############################################################################	1509	#############################################################################
1152		1510
1153	package CFClient::UI::Label;	1511	package CFClient::UI::Label;
1154		1512
1155	our @ISA = CFClient::UI::Base::;	1513	our @ISA = CFClient::UI::DrawBG::;
1156		1514
1157	use CFClient::OpenGL;	1515	use CFClient::OpenGL;
1158		1516
1159	sub new {	1517	sub new {
1160	my ($class, %arg) = @_;	1518	my ($class, %arg) = @_;
1161		1519
1162	my $self = $class->SUPER::new (	1520	my $self = $class->SUPER::new (
1163	fg => [1, 1, 1],	1521	fg => [1, 1, 1],
		1522	#bg => none
		1523	#active_bg => none
1164	#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),
1165	fontsize => 1,	1530	fontsize => 1,
1166	text => "",
1167	align => -1,	1531	align => -1,
1168	valign => -1,	1532	valign => -1,
1169	padding => 2,	1533	padding_x => 2,
1170	layout => new CFClient::Layout,	1534	padding_y => 2,
1171	can_events => 0,	1535	can_events => 0,
1172	%arg	1536	%arg
1173	);	1537	);
1174		1538
1175	if (exists $self->{template}) {	1539	if (exists $self->{template}) {
1176	my $layout = new CFClient::Layout;	1540	my $layout = new CFClient::Layout;
1177	$layout->set_text (delete $self->{template});	1541	$layout->set_text (delete $self->{template});
1178	$self->{template} = $layout;	1542	$self->{template} = $layout;
1179	}	1543	}
1180		1544
1181	$self->set_text (delete $self->{text}) if exists $self->{text};	1545	if (exists $self->{markup}) {
1182	$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	}
1183		1550
1184	$self	1551	$self
1185	}	1552	}
1186		1553
1187	sub escape {	1554	sub escape($) {
1188	local $_ = $_[1];	1555	local $_ = $_[0];
1189		1556
1190	s/&/&amp;/g;	1557	s/&/&amp;/g;
1191	s/>/&gt;/g;	1558	s/>/&gt;/g;
1192	s/</&lt;/g;	1559	s/</&lt;/g;
1193		1560
1194	$_[1]	1561	$_
		1562	}
		1563
		1564	sub update {
		1565	my ($self) = @_;
		1566
		1567	delete $self->{texture};
		1568	$self->SUPER::update;
		1569	}
		1570
		1571	sub realloc {
		1572	my ($self) = @_;
		1573
		1574	delete $self->{ox};
		1575	$self->SUPER::realloc;
1195	}	1576	}
1196		1577
1197	sub set_text {	1578	sub set_text {
1198	my ($self, $text) = @_;	1579	my ($self, $text) = @_;
1199		1580
		1581	return if $self->{text} eq "T$text";
		1582	$self->{text} = "T$text";
		1583
		1584	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1200	$self->{layout}->set_text ($text);	1585	$self->{layout}->set_text ($text);
1201		1586
1202	delete $self->{texture};	1587	delete $self->{size_req};
1203	$self->check_size;	1588	$self->realloc;
1204	$self->update;	1589	$self->update;
1205	}	1590	}
1206		1591
1207	sub set_markup {	1592	sub set_markup {
1208	my ($self, $markup) = @_;	1593	my ($self, $markup) = @_;
1209		1594
		1595	return if $self->{text} eq "M$markup";
		1596	$self->{text} = "M$markup";
		1597
		1598	my $rgba = $markup =~ /span.*(?:foreground|background)/;
		1599
		1600	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;
1210	$self->{layout}->set_markup ($markup);	1601	$self->{layout}->set_markup ($markup);
1211		1602
1212	delete $self->{texture};	1603	delete $self->{size_req};
1213	$self->check_size;	1604	$self->realloc;
1214	$self->update;	1605	$self->update;
1215	}	1606	}
1216		1607
1217	sub size_request {	1608	sub size_request {
1218	my ($self) = @_;	1609	my ($self) = @_;
1219		1610
		1611	$self->{size_req} ||= do {
1220	$self->{layout}->set_font ($self->{font}) if $self->{font};	1612	$self->{layout}->set_font ($self->{font}) if $self->{font};
1221	$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});
1222	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1616	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1223		1617
1224	my ($w, $h) = $self->{layout}->size;	1618	my ($w, $h) = $self->{layout}->size;
1225		1619
1226	if (exists $self->{template}) {	1620	if (exists $self->{template}) {
1227	$self->{template}->set_font ($self->{font}) if $self->{font};	1621	$self->{template}->set_font ($self->{font}) if $self->{font};
1228	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);	1622	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);
1229		1623
1230	my ($w2, $h2) = $self->{template}->size;	1624	my ($w2, $h2) = $self->{template}->size;
1231		1625
1232	$w = List::Util::max $w, $w2;	1626	$w = List::Util::max $w, $w2;
1233	$h = List::Util::max $h, $h2;	1627	$h = List::Util::max $h, $h2;
		1628	}
		1629
		1630	[$w, $h]
1234	}	1631	};
1235		1632
1236	(	1633	@{ $self->{size_req} }
1237	$w + $self->{padding} * 2,
1238	$h + $self->{padding} * 2,
1239	)
1240	}	1634	}
1241		1635
1242	sub size_allocate {	1636	sub invoke_size_allocate {
1243	my ($self, $w, $h) = @_;	1637	my ($self, $w, $h) = @_;
1244		1638
		1639	delete $self->{ox};
		1640
1245	delete $self->{texture};	1641	delete $self->{texture}
		1642	unless $w >= $self->{req_w} && $self->{old_w} >= $self->{req_w};
		1643
		1644	1
1246	}	1645	}
1247		1646
1248	sub set_fontsize {	1647	sub set_fontsize {
1249	my ($self, $fontsize) = @_;	1648	my ($self, $fontsize) = @_;
1250		1649
1251	$self->{fontsize} = $fontsize;	1650	$self->{fontsize} = $fontsize;
1252	delete $self->{texture};	1651	delete $self->{texture};
1253	$self->check_size;	1652
1254	$self->update;	1653	$self->realloc;
		1654	}
		1655
		1656	sub reconfigure {
		1657	my ($self) = @_;
		1658
		1659	delete $self->{size_req};
		1660
		1661	$self->SUPER::reconfigure;
1255	}	1662	}
1256		1663
1257	sub _draw {	1664	sub _draw {
1258	my ($self) = @_;	1665	my ($self) = @_;
1259		1666
		1667	$self->SUPER::_draw; # draw background, if applicable
		1668
1260	my $tex = $self->{texture} ||= do {	1669	my $tex = $self->{texture} ||= do {
		1670	$self->{layout}->set_foreground (@{$self->{fg}});
1261	$self->{layout}->set_font ($self->{font}) if $self->{font};	1671	$self->{layout}->set_font ($self->{font}) if $self->{font};
1262	$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});
1263	$self->{layout}->set_height (List::Util::min $self->{h}, $self->{fontsize} * $::FONTSIZE);	1675	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
		1676
1264	new_from_layout CFClient::Texture $self->{layout}	1677	new_from_layout CFClient::Texture $self->{layout}
1265	};	1678	};
1266		1679
1267	glEnable GL_BLEND;	1680	unless (exists $self->{ox}) {
1268	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
1269	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 {
1270	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1700	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1271		1701	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy}, $w, $h);
1272	glColor @{$self->{fg}};	1702	}
1273
1274	$self->{ox} = int (
1275	$self->{align} < 0 ? $self->{padding}
1276	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding}
1277	: ($self->{w} - $tex->{w}) * 0.5
1278	);
1279
1280	$self->{oy} = int (
1281	$self->{valign} < 0 ? $self->{padding}
1282	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding}
1283	: ($self->{h} - $tex->{h}) * 0.5
1284	);
1285
1286	$tex->draw_quad ($self->{ox}, $self->{oy});
1287		1703
1288	glDisable GL_TEXTURE_2D;	1704	glDisable GL_TEXTURE_2D;
1289	glDisable GL_BLEND;
1290	}	1705	}
1291		1706
1292	#############################################################################	1707	#############################################################################
1293		1708
1294	package CFClient::UI::EntryBase;	1709	package CFClient::UI::EntryBase;
…		…
1307	active_fg => [0, 0, 0],	1722	active_fg => [0, 0, 0],
1308	can_hover => 1,	1723	can_hover => 1,
1309	can_focus => 1,	1724	can_focus => 1,
1310	valign => 0,	1725	valign => 0,
1311	can_events => 1,	1726	can_events => 1,
		1727	#text => ...
		1728	#hidden => "*",
1312	@_	1729	@_
1313	)	1730	)
1314	}	1731	}
1315		1732
1316	sub _set_text {	1733	sub _set_text {
…		…
1318		1735
1319	delete $self->{cur_h};	1736	delete $self->{cur_h};
1320		1737
1321	return if $self->{text} eq $text;	1738	return if $self->{text} eq $text;
1322		1739
1323	delete $self->{texture};
1324
1325	$self->{last_activity} = $::NOW;	1740	$self->{last_activity} = $::NOW;
1326	$self->{text} = $text;	1741	$self->{text} = $text;
1327		1742
1328	$text =~ s/./*/g if $self->{hidden};	1743	$text =~ s/./*/g if $self->{hidden};
1329	$self->{layout}->set_text ("$text ");	1744	$self->{layout}->set_text ("$text ");
		1745	delete $self->{size_req};
1330		1746
1331	$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);
1332	}	1758	}
1333		1759
1334	sub get_text {	1760	sub get_text {
1335	$_[0]{text}	1761	$_[0]{text}
1336	}	1762	}
…		…
1341	my ($w, $h) = $self->SUPER::size_request;	1767	my ($w, $h) = $self->SUPER::size_request;
1342		1768
1343	($w + 1, $h) # add 1 for cursor	1769	($w + 1, $h) # add 1 for cursor
1344	}	1770	}
1345		1771
1346	sub size_allocate {
1347	my ($self, $w, $h) = @_;
1348
1349	$self->_set_text (delete $self->{text});#d# don't check for == inside _set_text
1350	}
1351
1352	sub set_text {
1353	my ($self, $text) = @_;
1354
1355	$self->{cursor} = length $text;
1356	$self->_set_text ($text);
1357	$self->update;
1358	}
1359
1360	sub key_down {	1772	sub invoke_key_down {
1361	my ($self, $ev) = @_;	1773	my ($self, $ev) = @_;
1362		1774
1363	my $mod = $ev->{mod};	1775	my $mod = $ev->{mod};
1364	my $sym = $ev->{sym};	1776	my $sym = $ev->{sym};
1365	my $uni = $ev->{unicode};	1777	my $uni = $ev->{unicode};
1366		1778
1367	my $text = $self->get_text;	1779	my $text = $self->get_text;
1368		1780
1369	if ($sym == 8) {	1781	if ($uni == 8) {
1370	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};	1782	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};
1371	} elsif ($sym == 127) {	1783	} elsif ($uni == 127) {
1372	substr $text, $self->{cursor}, 1, "";	1784	substr $text, $self->{cursor}, 1, "";
1373	} elsif ($sym == CFClient::SDLK_LEFT) {	1785	} elsif ($sym == CFClient::SDLK_LEFT) {
1374	--$self->{cursor} if $self->{cursor};	1786	--$self->{cursor} if $self->{cursor};
1375	} elsif ($sym == CFClient::SDLK_RIGHT) {	1787	} elsif ($sym == CFClient::SDLK_RIGHT) {
1376	++$self->{cursor} if $self->{cursor} < length $self->{text};	1788	++$self->{cursor} if $self->{cursor} < length $self->{text};
1377	} elsif ($sym == CFClient::SDLK_HOME) {	1789	} elsif ($sym == CFClient::SDLK_HOME) {
1378	$self->{cursor} = 0;	1790	$self->{cursor} = 0;
1379	} elsif ($sym == CFClient::SDLK_END) {	1791	} elsif ($sym == CFClient::SDLK_END) {
1380	$self->{cursor} = length $text;	1792	$self->{cursor} = length $text;
1381	} elsif ($sym == 27) {	1793	} elsif ($uni == 27) {
1382	$self->emit ('escape');	1794	$self->emit ('escape');
1383	} elsif ($uni) {	1795	} elsif ($uni) {
1384	substr $text, $self->{cursor}++, 0, chr $uni;	1796	substr $text, $self->{cursor}++, 0, chr $uni;
		1797	} else {
		1798	return 0;
1385	}	1799	}
1386		1800
1387	$self->_set_text ($text);	1801	$self->_set_text ($text);
1388	$self->update;
1389	}
1390		1802
		1803	$self->realloc;
		1804
		1805	1
		1806	}
		1807
1391	sub focus_in {	1808	sub invoke_focus_in {
1392	my ($self) = @_;	1809	my ($self) = @_;
1393		1810
1394	$self->{last_activity} = $::NOW;	1811	$self->{last_activity} = $::NOW;
1395		1812
1396	$self->SUPER::focus_in;	1813	$self->SUPER::invoke_focus_in
1397	}	1814	}
1398		1815
1399	sub button_down {	1816	sub invoke_button_down {
1400	my ($self, $ev, $x, $y) = @_;	1817	my ($self, $ev, $x, $y) = @_;
1401		1818
1402	$self->SUPER::button_down ($ev, $x, $y);	1819	$self->SUPER::invoke_button_down ($ev, $x, $y);
1403		1820
1404	my $idx = $self->{layout}->xy_to_index ($x, $y);	1821	my $idx = $self->{layout}->xy_to_index ($x, $y);
1405		1822
1406	# byte-index to char-index	1823	# byte-index to char-index
1407	my $text = $self->{text};	1824	my $text = $self->{text};
1408	utf8::encode $text;	1825	utf8::encode $text;
1409	$self->{cursor} = length substr $text, 0, $idx;	1826	$self->{cursor} = length substr $text, 0, $idx;
1410		1827
1411	$self->_set_text ($self->{text});	1828	$self->_set_text ($self->{text});
1412	$self->update;	1829	$self->update;
		1830
		1831	1
1413	}	1832	}
1414		1833
1415	sub mouse_motion {	1834	sub invoke_mouse_motion {
1416	my ($self, $ev, $x, $y) = @_;	1835	my ($self, $ev, $x, $y) = @_;
1417	# 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
1418	}	1839	}
1419		1840
1420	sub _draw {	1841	sub _draw {
1421	my ($self) = @_;	1842	my ($self) = @_;
1422		1843
1423	local $self->{fg} = $self->{fg};	1844	local $self->{fg} = $self->{fg};
1424		1845
1425	if ($FOCUS == $self) {	1846	if ($FOCUS == $self) {
1426	glColor @{$self->{active_bg}};	1847	glColor_premultiply @{$self->{active_bg}};
1427	$self->{fg} = $self->{active_fg};	1848	$self->{fg} = $self->{active_fg};
1428	} else {	1849	} else {
1429	glColor @{$self->{bg}};	1850	glColor_premultiply @{$self->{bg}};
1430	}	1851	}
1431		1852
1432	glEnable GL_BLEND;	1853	glEnable GL_BLEND;
1433	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1854	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1434	glBegin GL_QUADS;	1855	glBegin GL_QUADS;
1435	glVertex 0 , 0;	1856	glVertex 0 , 0;
1436	glVertex 0 , $self->{h};	1857	glVertex 0 , $self->{h};
1437	glVertex $self->{w}, $self->{h};	1858	glVertex $self->{w}, $self->{h};
1438	glVertex $self->{w}, 0;	1859	glVertex $self->{w}, 0;
…		…
1463		1884
1464	our @ISA = CFClient::UI::EntryBase::;	1885	our @ISA = CFClient::UI::EntryBase::;
1465		1886
1466	use CFClient::OpenGL;	1887	use CFClient::OpenGL;
1467		1888
1468	sub key_down {	1889	sub invoke_key_down {
1469	my ($self, $ev) = @_;	1890	my ($self, $ev) = @_;
1470		1891
1471	my $sym = $ev->{sym};	1892	my $sym = $ev->{sym};
1472		1893
1473	if ($sym == 13) {	1894	if ($sym == 13) {
1474	unshift @{$self->{history}},	1895	unshift @{$self->{history}},
1475	my $txt = $self->get_text;	1896	my $txt = $self->get_text;
		1897
1476	$self->{history_pointer} = -1;	1898	$self->{history_pointer} = -1;
1477	$self->{history_saveback} = '';	1899	$self->{history_saveback} = '';
1478	$self->emit (activate => $txt);	1900	$self->emit (activate => $txt);
1479	$self->update;	1901	$self->update;
1480		1902
…		…
1499	} else {	1921	} else {
1500	$self->set_text ($self->{history_saveback});	1922	$self->set_text ($self->{history_saveback});
1501	}	1923	}
1502		1924
1503	} else {	1925	} else {
1504	$self->SUPER::key_down ($ev);	1926	return $self->SUPER::invoke_key_down ($ev)
		1927	}
		1928
1505	}	1929	1
1506
1507	}	1930	}
1508		1931
1509	#############################################################################	1932	#############################################################################
1510		1933
1511	package CFClient::UI::Button;	1934	package CFClient::UI::Button;
…		…
1520		1943
1521	sub new {	1944	sub new {
1522	my $class = shift;	1945	my $class = shift;
1523		1946
1524	$class->SUPER::new (	1947	$class->SUPER::new (
1525	padding => 4,	1948	padding_x => 4,
		1949	padding_y => 4,
1526	fg => [1, 1, 1],	1950	fg => [1, 1, 1],
1527	bg => [1, 1, 1, 0.2],
1528	active_fg => [0, 0, 1],	1951	active_fg => [0, 0, 1],
1529	can_hover => 1,	1952	can_hover => 1,
1530	align => 0,	1953	align => 0,
1531	valign => 0,	1954	valign => 0,
1532	can_events => 1,	1955	can_events => 1,
1533	@_	1956	@_
1534	)	1957	)
1535	}	1958	}
1536		1959
1537	sub button_up {	1960	sub invoke_button_up {
1538	my ($self, $ev, $x, $y) = @_;	1961	my ($self, $ev, $x, $y) = @_;
1539		1962
		1963	$self->emit ("activate")
1540	if ($x >= 0 && $x < $self->{w}	1964	if $x >= 0 && $x < $self->{w}
1541	&& $y >= 0 && $y < $self->{h}) {	1965	&& $y >= 0 && $y < $self->{h};
1542	$self->emit ("activate");	1966
1543	}	1967	1
1544	}	1968	}
1545		1969
1546	sub _draw {	1970	sub _draw {
1547	my ($self) = @_;	1971	my ($self) = @_;
1548		1972
1549	local $self->{fg} = $self->{fg};	1973	local $self->{fg} = $GRAB == $self ? $self->{active_fg} : $self->{fg};
1550		1974
1551	if ($GRAB == $self) {
1552	$self->{fg} = $self->{active_fg};
1553	}
1554
1555	glEnable GL_BLEND;
1556	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1557	glEnable GL_TEXTURE_2D;	1975	glEnable GL_TEXTURE_2D;
1558	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1976	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1559	glColor 0, 0, 0, 1;	1977	glColor 0, 0, 0, 1;
1560		1978
1561	$tex[0]->draw_quad (0, 0, $self->{w}, $self->{h});	1979	$tex[0]->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
1562		1980
1563	glDisable GL_TEXTURE_2D;	1981	glDisable GL_TEXTURE_2D;
1564	glDisable GL_BLEND;
1565		1982
1566	$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
1567	}	2020	}
1568		2021
1569	#############################################################################	2022	#############################################################################
1570		2023
1571	package CFClient::UI::CheckBox;	2024	package CFClient::UI::CheckBox;
…		…
1580		2033
1581	sub new {	2034	sub new {
1582	my $class = shift;	2035	my $class = shift;
1583		2036
1584	$class->SUPER::new (	2037	$class->SUPER::new (
1585	padding => 2,	2038	padding_x => 2,
		2039	padding_y => 2,
1586	fg => [1, 1, 1],	2040	fg => [1, 1, 1],
1587	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],
1588	state => 0,	2044	state => 0,
1589	can_hover => 1,	2045	can_hover => 1,
1590	@_	2046	@_
1591	)	2047	)
1592	}	2048	}
1593		2049
1594	sub size_request {	2050	sub size_request {
1595	my ($self) = @_;	2051	my ($self) = @_;
1596		2052
1597	($self->{padding} * 2 + 6) x 2	2053	(6) x 2
1598	}	2054	}
1599		2055
1600	sub button_down {	2056	sub invoke_button_down {
1601	my ($self, $ev, $x, $y) = @_;	2057	my ($self, $ev, $x, $y) = @_;
1602		2058
1603	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	2059	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1604	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	2060	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1605	$self->{state} = !$self->{state};	2061	$self->{state} = !$self->{state};
1606	$self->emit (changed => $self->{state});	2062	$self->emit (changed => $self->{state});
		2063	} else {
		2064	return 0
		2065	}
		2066
1607	}	2067	1
1608	}	2068	}
1609		2069
1610	sub _draw {	2070	sub _draw {
1611	my ($self) = @_;	2071	my ($self) = @_;
1612		2072
1613	$self->SUPER::_draw;	2073	$self->SUPER::_draw;
1614		2074
1615	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	2075	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1616		2076
1617	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;
1618		2080
1619	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	2081	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1620		2082
1621	glEnable GL_BLEND;	2083	my $tex = $self->{state} ? $tex[1] : $tex[0];
		2084
1622	glEnable GL_TEXTURE_2D;	2085	glEnable GL_TEXTURE_2D;
1623	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1624
1625	my $tex = $self->{state} ? $tex[1] : $tex[0];
1626
1627	$tex->draw_quad (0, 0, $s, $s);	2086	$tex->draw_quad_alpha (0, 0, $s, $s);
1628
1629	glDisable GL_TEXTURE_2D;	2087	glDisable GL_TEXTURE_2D;
1630	glDisable GL_BLEND;
1631	}	2088	}
1632		2089
1633	#############################################################################	2090	#############################################################################
1634		2091
1635	package CFClient::UI::Image;	2092	package CFClient::UI::Image;
1636		2093
1637	our @ISA = CFClient::UI::Base::;	2094	our @ISA = CFClient::UI::Base::;
1638		2095
1639	use CFClient::OpenGL;	2096	use CFClient::OpenGL;
1640	use Carp qw/confess/;
1641		2097
1642	our %loaded_images;	2098	our %texture_cache;
1643		2099
1644	sub new {	2100	sub new {
1645	my $class = shift;	2101	my $class = shift;
1646		2102
1647	my $self = $class->SUPER::new (can_events => 0, @_);	2103	my $self = $class->SUPER::new (
		2104	can_events => 0,
		2105	@_,
		2106	);
1648		2107
1649	$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";
1650		2110
1651	$loaded_images{$self->{image}} ||=	2111	$self->{tex} = $texture_cache{$self->{path}} ||=
1652	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;
1653		2113
1654	my $tex = $self->{tex} = $loaded_images{$self->{image}};	2114	Scalar::Util::weaken $texture_cache{$self->{path}};
1655		2115
1656	Scalar::Util::weaken $loaded_images{$self->{image}};	2116	$self->{aspect} ||= $self->{tex}{w} / $self->{tex}{h};
1657
1658	$self->{aspect} = $tex->{w} / $tex->{h};
1659		2117
1660	$self	2118	$self
1661	}	2119	}
1662		2120
1663	sub size_request {	2121	sub size_request {
1664	my ($self) = @_;	2122	my ($self) = @_;
1665		2123
1666	($self->{tex}->{w}, $self->{tex}->{h})	2124	($self->{tex}{w}, $self->{tex}{h})
1667	}	2125	}
1668		2126
1669	sub _draw {	2127	sub _draw {
1670	my ($self) = @_;	2128	my ($self) = @_;
1671		2129
…		…
1678	glTranslate 0, -$self->{w}, 0;	2136	glTranslate 0, -$self->{w}, 0;
1679		2137
1680	($w, $h) = ($h, $w);	2138	($w, $h) = ($h, $w);
1681	}	2139	}
1682		2140
1683	glEnable GL_BLEND;
1684	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1685	glEnable GL_TEXTURE_2D;	2141	glEnable GL_TEXTURE_2D;
1686	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2142	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1687		2143
1688	$tex->draw_quad (0, 0, $w, $h);	2144	$tex->draw_quad_alpha (0, 0, $w, $h);
1689		2145
1690	glDisable GL_BLEND;
1691	glDisable GL_TEXTURE_2D;	2146	glDisable GL_TEXTURE_2D;
1692	}	2147	}
1693		2148
1694	#############################################################################	2149	#############################################################################
1695		2150
…		…
1743	}	2198	}
1744		2199
1745	sub set_max {	2200	sub set_max {
1746	my ($self, $max) = @_;	2201	my ($self, $max) = @_;
1747		2202
		2203	return if $self->{max_val} == $max;
		2204
1748	$self->{max_val} = $max;	2205	$self->{max_val} = $max;
		2206	$self->update;
1749	}	2207	}
1750		2208
1751	sub set_value {	2209	sub set_value {
1752	my ($self, $val, $max) = @_;	2210	my ($self, $val, $max) = @_;
1753		2211
1754	$self->set_max ($max)	2212	$self->set_max ($max)
1755	if defined $max;	2213	if defined $max;
1756		2214
1757	$max = $self->{max_val};	2215	return if $self->{val} == $val;
		2216
1758	$self->{val} = $val;	2217	$self->{val} = $val;
1759
1760	$self->update;	2218	$self->update;
1761	}	2219	}
1762		2220
1763	sub _draw {	2221	sub _draw {
1764	my ($self) = @_;	2222	my ($self) = @_;
…		…
1782		2240
1783	my $h1 = $self->{h} * (1 - $ycut1);	2241	my $h1 = $self->{h} * (1 - $ycut1);
1784	my $h2 = $self->{h} * (1 - $ycut2);	2242	my $h2 = $self->{h} * (1 - $ycut2);
1785		2243
1786	glEnable GL_BLEND;	2244	glEnable GL_BLEND;
1787	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;
1788	glEnable GL_TEXTURE_2D;	2247	glEnable GL_TEXTURE_2D;
1789	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2248	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1790		2249
1791	glBindTexture GL_TEXTURE_2D, $t1->{name};	2250	glBindTexture GL_TEXTURE_2D, $t1->{name};
1792	glBegin GL_QUADS;	2251	glBegin GL_QUADS;
…		…
1827		2286
1828	sub new {	2287	sub new {
1829	my ($class, %arg) = @_;	2288	my ($class, %arg) = @_;
1830		2289
1831	my $self = $class->SUPER::new (	2290	my $self = $class->SUPER::new (
1832	tooltip => $arg{type},	2291	tooltip => $arg{type},
1833	can_hover => 1,	2292	can_hover => 1,
		2293	can_events => 1,
1834	%arg,	2294	%arg,
1835	);	2295	);
1836		2296
1837	$self->add ($self->{value} = new CFClient::UI::Label valign => +1, align => 0, template => "999");	2297	$self->add ($self->{value} = new CFClient::UI::Label valign => +1, align => 0, template => "999");
1838	$self->add ($self->{gauge} = new CFClient::UI::VGauge type => $self->{type}, expand => 1, can_hover => 1);	2298	$self->add ($self->{gauge} = new CFClient::UI::VGauge type => $self->{type}, expand => 1, can_hover => 1);
…		…
1846		2306
1847	$self->{value}->set_fontsize ($fsize);	2307	$self->{value}->set_fontsize ($fsize);
1848	$self->{max} ->set_fontsize ($fsize);	2308	$self->{max} ->set_fontsize ($fsize);
1849	}	2309	}
1850		2310
		2311	sub set_max {
		2312	my ($self, $max) = @_;
		2313
		2314	$self->{gauge}->set_max ($max);
		2315	$self->{max}->set_text ($max);
		2316	}
		2317
1851	sub set_value {	2318	sub set_value {
1852	my ($self, $val, $max) = @_;	2319	my ($self, $val, $max) = @_;
1853		2320
1854	$self->set_max ($max)	2321	$self->set_max ($max)
1855	if defined $max;	2322	if defined $max;
1856		2323
1857	$self->{gauge}->set_value ($val, $max);	2324	$self->{gauge}->set_value ($val, $max);
1858	$self->{value}->set_text ($val);	2325	$self->{value}->set_text ($val);
1859	}
1860
1861	sub set_max {
1862	my ($self, $max) = @_;
1863
1864	$self->{gauge}->set_max ($max);
1865	$self->{max}->set_text ($max);
1866	}	2326	}
1867		2327
1868	#############################################################################	2328	#############################################################################
1869		2329
1870	package CFClient::UI::Slider;	2330	package CFClient::UI::Slider;
…		…
1880	qw(s1_slider.png s1_slider_bg.png);	2340	qw(s1_slider.png s1_slider_bg.png);
1881		2341
1882	sub new {	2342	sub new {
1883	my $class = shift;	2343	my $class = shift;
1884		2344
1885	# range [value, low, high, page]	2345	# range [value, low, high, page, unit]
1886		2346
1887	# TODO: 0-width page	2347	# TODO: 0-width page
1888	# TODO: req_w/h are wrong with vertical	2348	# TODO: req_w/h are wrong with vertical
1889	# TODO: calculations are off	2349	# TODO: calculations are off
1890	my $self = $class->SUPER::new (	2350	my $self = $class->SUPER::new (
1891	fg => [1, 1, 1],	2351	fg => [1, 1, 1],
1892	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],
1893	range => [0, 0, 100, 10],	2355	range => [0, 0, 100, 10, 0],
1894	req_w => 20,	2356	min_w => $::WIDTH / 80,
1895	req_h => 20,	2357	min_h => $::WIDTH / 80,
1896	vertical => 0,	2358	vertical => 0,
1897	can_hover => 1,	2359	can_hover => 1,
1898	inner_pad => 5,	2360	inner_pad => 0.02,
1899	@_	2361	@_
1900	);	2362	);
1901		2363
		2364	$self->set_value ($self->{range}[0]);
		2365	$self->update;
		2366
1902	$self	2367	$self
1903	}	2368	}
1904		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
1905	sub size_request {	2404	sub size_request {
1906	my ($self) = @_;	2405	my ($self) = @_;
1907		2406
1908	my $w = $self->{req_w};	2407	($self->{req_w}, $self->{req_h})
1909	my $h = $self->{req_h};
1910
1911	$self->{vertical} ? ($h, $w) : ($w, $h)
1912	}	2408	}
1913		2409
1914	sub button_down {	2410	sub invoke_button_down {
1915	my ($self, $ev, $x, $y) = @_;	2411	my ($self, $ev, $x, $y) = @_;
1916		2412
1917	$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
1918	$self->mouse_motion ($ev, $x, $y);	2417	$self->invoke_mouse_motion ($ev, $x, $y)
1919	}	2418	}
1920		2419
1921	sub mouse_motion {	2420	sub invoke_mouse_motion {
1922	my ($self, $ev, $x, $y) = @_;	2421	my ($self, $ev, $x, $y) = @_;
1923		2422
1924	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
1925	my ($value, $lo, $hi, $page) = @{$self->{range}};	2451	my ($value, $lo, $hi, $page) = @{$self->{range}};
		2452	my $range = ($hi - $page - $lo) || 1e-100;
1926		2453
1927	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});	2454	my $knob_w = List::Util::min 1, $page / ($hi - $lo) || 0.1;
1928		2455
1929	my $inner_pad_px = $self->_calc_inner_pad_px ($w);	2456	$self->{offset} = List::Util::max $self->{inner_pad}, $knob_w * 0.5;
1930	my $inner_w = $w - $inner_pad_px * 2; # * 2 for left & right	2457	$self->{scale} = 1 - 2 * $self->{offset} || 1e-100;
1931		2458
1932	$x -= $inner_pad_px; # substract the padding	2459	$value = ($value - $lo) / $range;
1933	$x = $x * ($hi - $lo) / $inner_w + $lo;	2460	$value = $value * $self->{scale} + $self->{offset};
1934	$x = $lo if $x < $lo;
1935	$x = $hi - $page if $x > $hi - $page;
1936	$self->{range}[0] = $x;
1937		2461
1938	$self->emit (changed => $x);	2462	$self->{knob_x} = $value - $knob_w * 0.5;
1939	$self->update;	2463	$self->{knob_w} = $knob_w;
1940	}	2464	}
1941	}
1942
1943	# the inner_* stuff is for generating a padding for the slider handle,
1944	# so that the handle doesn't leave the texture. This calculation isn't 100%
1945	# correct propably, but it does the job for now
1946	sub _calc_inner_pad_px {
1947	my ($self, $w) = @_;
1948	($w / 100) * $self->{inner_pad} # % to pixels
1949	}
1950
1951	sub _draw {
1952	my ($self) = @_;
1953		2465
1954	$self->SUPER::_draw ();	2466	$self->SUPER::_draw ();
1955		2467
1956	my ($w, $h) = @$self{qw(w h)};	2468	glScale $self->{w}, $self->{h};
1957		2469
1958	if ($self->{vertical}) {	2470	if ($self->{vertical}) {
1959	# draw a vertical slider like a rotated horizontal slider	2471	# draw a vertical slider like a rotated horizontal slider
1960		2472
		2473	glTranslate 1, 0, 0;
1961	glRotate 90, 0, 0, 1;	2474	glRotate 90, 0, 0, 1;
1962	glTranslate 0, -$self->{w}, 0;
1963
1964	($w, $h) = ($h, $w);
1965	}	2475	}
1966		2476
1967	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};	2477	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};
1968	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};	2478	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};
1969		2479
1970	my ($value, $lo, $hi, $page) = @{$self->{range}};
1971
1972	$hi = $value + 1 if $lo == $hi;
1973
1974	my $inner_pad_px = $self->_calc_inner_pad_px ($w);
1975	my $inner_w = $w - $inner_pad_px * 2; # * 2 for left & right
1976
1977	$page = int $page * $inner_w / ($hi - $lo);
1978	$value = int +($value - $lo) * $inner_w / ($hi - $lo);
1979
1980	$w -= $page;
1981	$page &= ~1;
1982	glTranslate $page * 0.5, 0, 0;
1983	$page ||= 2;
1984
1985	my $knob_a = $inner_pad_px + ($value - $page * 0.5);
1986	my $knob_b = $inner_pad_px + ($value + $page * 0.5);
1987
1988	glEnable GL_BLEND;
1989	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1990	glEnable GL_TEXTURE_2D;	2480	glEnable GL_TEXTURE_2D;
1991	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2481	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1992		2482
1993	# draw background	2483	# draw background
1994	$tex[1]->draw_quad (0, 0, $w, $h);	2484	$tex[1]->draw_quad_alpha (0, 0, 1, 1);
1995		2485
1996	# draw handle	2486	# draw handle
1997	$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);
1998		2488
1999	glDisable GL_BLEND;
2000	glDisable GL_TEXTURE_2D;	2489	glDisable GL_TEXTURE_2D;
2001	}	2490	}
2002		2491
2003	#############################################################################	2492	#############################################################################
2004		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
2005	package CFClient::UI::TextView;	2535	package CFClient::UI::TextScroller;
2006		2536
2007	our @ISA = CFClient::UI::HBox::;	2537	our @ISA = CFClient::UI::HBox::;
2008		2538
2009	use CFClient::OpenGL;	2539	use CFClient::OpenGL;
2010		2540
…		…
2012	my $class = shift;	2542	my $class = shift;
2013		2543
2014	my $self = $class->SUPER::new (	2544	my $self = $class->SUPER::new (
2015	fontsize => 1,	2545	fontsize => 1,
2016	can_events => 0,	2546	can_events => 0,
		2547	indent => 0,
2017	#font => default_font	2548	#font => default_font
2018	@_,	2549	@_,
2019		2550
2020	layout => (new CFClient::Layout),	2551	layout => (new CFClient::Layout 1),
2021	par => [],	2552	par => [],
2022	height => 0,	2553	height => 0,
2023	children => [	2554	children => [
2024	(new CFClient::UI::Empty expand => 1),	2555	(new CFClient::UI::Empty expand => 1),
2025	(new CFClient::UI::Slider vertical => 1),	2556	(new CFClient::UI::Slider vertical => 1),
2026	],	2557	],
2027	);	2558	);
2028		2559
2029	$self->{children}[1]->connect (changed => sub {	2560	$self->{children}[1]->connect (changed => sub { $self->update });
2030	$self->update;
2031	});
2032		2561
2033	$self	2562	$self
2034	}	2563	}
2035		2564
2036	sub set_fontsize {	2565	sub set_fontsize {
…		…
2038		2567
2039	$self->{fontsize} = $fontsize;	2568	$self->{fontsize} = $fontsize;
2040	$self->reflow;	2569	$self->reflow;
2041	}	2570	}
2042		2571
2043	sub text_height {	2572	sub visible_children {
2044	my ($self, $text) = @_;	2573	my ($self) = @_;
2045		2574
2046	my $layout = $self->{layout};	2575	@{$self->{children}}[0,1]
2047
2048	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
2049	$layout->set_width ($self->{w});
2050	$layout->set_text ($text);
2051
2052	($layout->size)[1]
2053	}	2576	}
2054		2577
2055	sub reflow {
2056	my ($self) = @_;
2057
2058	$self->{need_reflow}++;
2059	$self->update;
2060	}
2061
2062	sub size_allocate {	2578	sub invoke_size_allocate {
2063	my ($self, $w, $h) = @_;	2579	my ($self, $w, $h) = @_;
2064		2580
2065	$self->SUPER::size_allocate ($w, $h);	2581	my (undef, undef, @other) = @{ $self->{children} };
		2582	$_->configure (@$_{qw(x y req_w req_h)}) for @other;
2066		2583
2067	$self->{layout}->set_font ($self->{font}) if $self->{font};	2584	$self->{layout}->set_font ($self->{font}) if $self->{font};
2068	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	2585	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
2069	$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});
2070		2588
2071	$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]);
2072	}	2632	}
2073		2633
2074	sub add_paragraph {	2634	sub add_paragraph {
2075	my ($self, $color, $text) = @_;	2635	my ($self, $color, $para, $indent) = @_;
2076		2636
2077	#TODO: intelligently "reformat" paragraph	2637	my ($text, @w) = ref $para ? @$para : $para;
2078		2638
2079	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	};
2080		2647
2081	$self->{height} += $height;	2648	$self->add (@w) if @w;
		2649	push @{$self->{par}}, $para;
2082		2650
2083	push @{$self->{par}}, [$height, $color, $text];	2651	$self->{need_reflow}++;
		2652	$self->update;
		2653	}
2084		2654
2085	$self->{children}[1]{range} = [$self->{height} - $self->{h}, 0, $self->{height}, $self->{h}];	2655	sub scroll_to_bottom {
2086	$self->{children}[1]->update;	2656	my ($self) = @_;
		2657
		2658	$self->{scroll_to_bottom} = 1;
		2659	$self->update;
2087	}	2660	}
2088		2661
2089	sub update {	2662	sub update {
2090	my ($self) = @_;	2663	my ($self) = @_;
2091		2664
…		…
2093		2666
2094	return unless $self->{h} > 0;	2667	return unless $self->{h} > 0;
2095		2668
2096	delete $self->{texture};	2669	delete $self->{texture};
2097		2670
2098	$ROOT->on_refresh ($self, sub {	2671	$ROOT->on_post_alloc ($self => sub {
		2672	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
		2673
2099	if (delete $self->{need_reflow}) {	2674	if (delete $self->{need_reflow}) {
2100	my $height = 0;	2675	my $height = 0;
2101		2676
2102	$height += $_->[0] = $self->text_height ($_->[2])
2103	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	}
2104		2689
2105	$self->{height} = $height;	2690	$self->{height} = $height;
2106		2691
2107	$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]);
2108		2693
2109	delete $self->{texture};	2694	delete $self->{texture};
2110	}	2695	}
2111		2696
		2697	if (delete $self->{scroll_to_bottom}) {
		2698	$self->{children}[1]->set_value (1e10);
		2699	}
		2700
2112	$self->{texture} ||= new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {	2701	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {
2113	glClearColor 0, 0, 0, 1;	2702	glClearColor 0, 0, 0, 0;
2114	glClear GL_COLOR_BUFFER_BIT;	2703	glClear GL_COLOR_BUFFER_BIT;
2115		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
2116	glEnable GL_BLEND;	2712	glEnable GL_BLEND;
		2713	#TODO# not correct in windows where rgba is forced off
2117	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	2714	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
2118	glEnable GL_TEXTURE_2D;
2119	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2120		2715
2121	my $top = int $self->{children}[1]{range}[0];
2122
2123	my $y0 = $top;
2124	my $y1 = $top + $self->{h};
2125
2126	my $y = 0;
2127
2128	my $layout = $self->{layout};
2129
2130	$layout->set_font ($self->{font}) if $self->{font};
2131
2132	for my $par (@{$self->{par}}) {	2716	for my $para (@{$self->{par}}) {
2133	my $h = $par->[0];	2717	my $h = $para->{h};
2134		2718
2135	if ($y0 < $y + $h && $y < $y1) {	2719	if ($y0 < $y + $h && $y < $y1) {
2136	$layout->set_text ($par->[2]);
2137		2720
2138	glColor @{ $par->[1] };	2721	my $layout = $self->get_layout ($para);
2139	my ($W, $H) = $layout->size;	2722
2140	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	}
2141	}	2740	}
2142		2741
2143	$y += $h;	2742	$y += $h;
2144	}	2743	}
2145		2744
2146	glDisable GL_TEXTURE_2D;
2147	glDisable GL_BLEND;	2745	glDisable GL_BLEND;
2148	};	2746	};
2149	});	2747	});
2150	}	2748	}
2151		2749
		2750	sub reconfigure {
		2751	my ($self) = @_;
		2752
		2753	$self->SUPER::reconfigure;
		2754
		2755	$_->{w} = 1e10 for @{ $self->{par} };
		2756	$self->reflow;
		2757	}
		2758
2152	sub _draw {	2759	sub _draw {
2153	my ($self) = @_;	2760	my ($self) = @_;
2154		2761
2155	if ($self->{texture}) {
2156	glEnable GL_TEXTURE_2D;	2762	glEnable GL_TEXTURE_2D;
2157	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2763	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2158	$self->{texture}->draw_quad (0, 0, $self->{w}, $self->{h});	2764	glColor 0, 0, 0, 1;
		2765	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});
2159	glDisable GL_TEXTURE_2D;	2766	glDisable GL_TEXTURE_2D;
2160	}
2161		2767
2162	$self->{children}[1]->draw;	2768	$self->{children}[1]->draw;
2163
2164	}	2769	}
2165		2770
2166	#############################################################################	2771	#############################################################################
2167		2772
2168	package CFClient::UI::Animator;	2773	package CFClient::UI::Animator;
…		…
2213		2818
2214	sub new {	2819	sub new {
2215	my $class = shift;	2820	my $class = shift;
2216		2821
2217	my $self = $class->SUPER::new (	2822	my $self = $class->SUPER::new (
2218	state => 0,	2823	state => 0,
2219	connect_activate => \&toggle_flopper,	2824	on_activate => \&toggle_flopper,
2220	@_	2825	@_
2221	);	2826	);
2222		2827
2223	if ($self->{state}) {
2224	$self->{state} = 0;
2225	$self->toggle_flopper;
2226	}
2227
2228	$self	2828	$self
2229	}	2829	}
2230		2830
2231	sub toggle_flopper {	2831	sub toggle_flopper {
2232	my ($self) = @_;	2832	my ($self) = @_;
2233		2833
2234	# TODO: use animation	2834	$self->{other}->toggle_visibility;
2235	if ($self->{state} = !$self->{state}) {
2236	$CFClient::UI::ROOT->add ($self->{other});
2237	$self->{other}->move ($self->coord2global (0, $self->{h}));
2238	$self->emit ("open");
2239	} else {
2240	$CFClient::UI::ROOT->remove ($self->{other});
2241	$self->emit ("close");
2242	}
2243
2244	$self->emit (changed => $self->{state});
2245	}	2835	}
2246		2836
2247	#############################################################################	2837	#############################################################################
2248		2838
2249	package CFClient::UI::Tooltip;	2839	package CFClient::UI::Tooltip;
…		…
2259	@_,	2849	@_,
2260	can_events => 0,	2850	can_events => 0,
2261	)	2851	)
2262	}	2852	}
2263		2853
2264	sub set_markup {	2854	sub set_tooltip_from {
2265	my ($self, $text) = @_;	2855	my ($self, $widget) = @_;
2266		2856
2267	$self->{label} ||= new CFClient::UI::Label fontsize => 0.8, fg => [0, 0, 0];	2857	my $tooltip = $widget->{tooltip};
2268	$self->{label}->set_markup ($text);	2858
2269	$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	);
2270	}	2877	}
2271		2878
2272	sub size_request {	2879	sub size_request {
2273	my ($self) = @_;	2880	my ($self) = @_;
2274		2881
2275	$self->child->set_max_size ($::WIDTH * 0.3);
2276
2277	my ($w, $h) = @{$self->child}{qw(req_w req_h)};	2882	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
2278		2883
2279	($w + 4, $h + 4)	2884	($w + 4, $h + 4)
2280	}	2885	}
2281		2886
2282	sub size_allocate {	2887	sub invoke_size_allocate {
2283	my ($self, $w, $h) = @_;	2888	my ($self, $w, $h) = @_;
2284		2889
2285	$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	});
2286	}	2909	}
2287		2910
2288	sub _draw {	2911	sub _draw {
2289	my ($self) = @_;	2912	my ($self) = @_;
2290		2913
2291	glPushMatrix;
2292	glTranslate 0.375, 0.375;	2914	glTranslate 0.375, 0.375;
2293		2915
2294	my ($w, $h) = @$self{qw(w h)};	2916	my ($w, $h) = @$self{qw(w h)};
2295		2917
2296	glColor 1, 0.8, 0.4;	2918	glColor 1, 0.8, 0.4;
…		…
2307	glVertex 0 , $h;	2929	glVertex 0 , $h;
2308	glVertex $w, $h;	2930	glVertex $w, $h;
2309	glVertex $w, 0;	2931	glVertex $w, 0;
2310	glEnd;	2932	glEnd;
2311		2933
2312	glPopMatrix;	2934	glTranslate 2 - 0.375, 2 - 0.375;
2313		2935
2314	glTranslate 2, 2;
2315	$self->SUPER::_draw;	2936	$self->SUPER::_draw;
2316	}	2937	}
2317		2938
2318	#############################################################################	2939	#############################################################################
2319		2940
…		…
2324	use CFClient::OpenGL;	2945	use CFClient::OpenGL;
2325		2946
2326	sub new {	2947	sub new {
2327	my $class = shift;	2948	my $class = shift;
2328		2949
2329	$class->SUPER::new (	2950	my $self = $class->SUPER::new (
2330	aspect => 1,	2951	aspect => 1,
		2952	can_events => 0,
		2953	@_,
		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
		2971	}
		2972
		2973	sub size_request {
		2974	(32, 8)
		2975	}
		2976
		2977	sub update {
		2978	my ($self) = @_;
		2979
		2980	return unless $self->{visible};
		2981
		2982	$self->SUPER::update;
		2983	}
		2984
		2985	sub _draw {
		2986	my ($self) = @_;
		2987
		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
		2999	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
		3000
		3001	if ($tex) {
		3002	glEnable GL_TEXTURE_2D;
		3003	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
		3004	glColor 0, 0, 0, 1;
		3005	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
		3006	glDisable GL_TEXTURE_2D;
		3007	}
		3008	}
		3009
		3010	sub destroy {
		3011	my ($self) = @_;
		3012
		3013	$self->{timer}->cancel
		3014	if $self->{timer};
		3015
		3016	$self->SUPER::destroy;
		3017	}
		3018
		3019	#############################################################################
		3020
		3021	package CFClient::UI::Buttonbar;
		3022
		3023	our @ISA = CFClient::UI::HBox::;
		3024
		3025	# TODO: should actualyl wrap buttons and other goodies.
		3026
		3027	#############################################################################
		3028
		3029	package CFClient::UI::Menu;
		3030
		3031	our @ISA = CFClient::UI::FancyFrame::;
		3032
		3033	use CFClient::OpenGL;
		3034
		3035	sub new {
		3036	my $class = shift;
		3037
		3038	my $self = $class->SUPER::new (
		3039	items => [],
		3040	z => 100,
		3041	@_,
		3042	);
		3043
		3044	$self->add ($self->{vbox} = new CFClient::UI::VBox);
		3045
		3046	for my $item (@{ $self->{items} }) {
		3047	my ($widget, $cb, $tooltip) = @$item;
		3048
		3049	# handle various types of items, only text for now
		3050	if (!ref $widget) {
		3051	$widget = new CFClient::UI::Label
		3052	can_hover => 1,
		3053	can_events => 1,
		3054	markup => $widget,
		3055	tooltip => $tooltip
		3056	}
		3057
		3058	$self->{item}{$widget} = $item;
		3059
		3060	$self->{vbox}->add ($widget);
		3061	}
		3062
		3063	$self
		3064	}
		3065
		3066	# popup given the event (must be a mouse button down event currently)
		3067	sub popup {
		3068	my ($self, $ev) = @_;
		3069
		3070	$self->emit ("popdown");
		3071
		3072	# maybe save $GRAB? must be careful about events...
		3073	$GRAB = $self;
		3074	$self->{button} = $ev->{button};
		3075
		3076	$self->show;
		3077	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
		3078	}
		3079
		3080	sub invoke_mouse_motion {
		3081	my ($self, $ev, $x, $y) = @_;
		3082
		3083	# TODO: should use vbox->find_widget or so
		3084	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
		3085	$self->{hover} = $self->{item}{$HOVER};
		3086
		3087	0
		3088	}
		3089
		3090	sub invoke_button_up {
		3091	my ($self, $ev, $x, $y) = @_;
		3092
		3093	if ($ev->{button} == $self->{button}) {
		3094	undef $GRAB;
		3095	$self->hide;
		3096
		3097	$self->emit ("popdown");
		3098	$self->{hover}[1]->() if $self->{hover};
		3099	} else {
		3100	return 0
		3101	}
		3102
		3103	1
		3104	}
		3105
		3106	#############################################################################
		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 => [],
2331	@_,	3677	@_,
2332	)	3678	)
2333	}	3679	}
2334		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
		3789	package CFClient::UI::Root;
		3790
		3791	our @ISA = CFClient::UI::Container::;
		3792
		3793	use List::Util qw(min max);
		3794
		3795	use CFClient::OpenGL;
		3796
		3797	sub new {
		3798	my $class = shift;
		3799
		3800	my $self = $class->SUPER::new (
		3801	visible => 1,
		3802	@_,
		3803	);
		3804
		3805	Scalar::Util::weaken ($self->{root} = $self);
		3806
		3807	$self
		3808	}
		3809
2335	sub size_request {	3810	sub size_request {
2336	(32, 8)
2337	}
2338
2339	sub draw {
2340	my ($self) = @_;	3811	my ($self) = @_;
2341		3812
2342	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$self->{face}]];	3813	($self->{w}, $self->{h})
2343
2344	if ($tex) {
2345	glEnable GL_BLEND;
2346	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
2347	glEnable GL_TEXTURE_2D;
2348	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2349	glColor 1, 1, 1, 1;
2350	$tex->draw_quad (0, 0, $self->{w}, $self->{h});
2351	glDisable GL_TEXTURE_2D;
2352	glDisable GL_BLEND;
2353	}
2354	}	3814	}
2355		3815
2356	#############################################################################	3816	sub _to_pixel {
		3817	my ($coord, $size, $max) = @_;
2357		3818
2358	package CFClient::UI::Root;	3819	$coord =
		3820	$coord eq "center" ? ($max - $size) * 0.5
		3821	: $coord eq "max" ? $max
		3822	: $coord;
2359		3823
2360	our @ISA = CFClient::UI::Container::;	3824	$coord = 0 if $coord < 0;
		3825	$coord = $max - $size if $coord > $max - $size;
2361		3826
2362	use CFClient::OpenGL;	3827	int $coord + 0.5
2363
2364	sub check_size {
2365	my ($self) = @_;
2366
2367	$self->configure (0, 0, $::WIDTH, $::HEIGHT);
2368	}	3828	}
2369		3829
2370	sub size_request {	3830	sub invoke_size_allocate {
2371	($::WIDTH, $::HEIGHT)
2372	}
2373
2374	sub configure {
2375	my ($self, $x, $y, $w, $h) = @_;	3831	my ($self, $w, $h) = @_;
2376		3832
2377	$self->SUPER::configure ($x, $y, $w, $h);
2378
2379	for my $child (@{$self->{children}}) {	3833	for my $child ($self->children) {
2380	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)};
2381		3835
2382	$X = List::Util::max 0, List::Util::min $w - $W, $X;	3836	$X = $child->{force_x} if exists $child->{force_x};
2383	$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
2384	$child->configure ($X, $Y, $W,$H);	3842	$child->configure ($X, $Y, $W, $H);
		3843	}
		3844
2385	}	3845	1
2386	}	3846	}
2387		3847
2388	sub _topleft {	3848	sub coord2local {
2389	my ($self, $x, $y) = @_;	3849	my ($self, $x, $y) = @_;
2390		3850
2391	($x, $y)	3851	($x, $y)
2392	}	3852	}
2393		3853
		3854	sub coord2global {
		3855	my ($self, $x, $y) = @_;
		3856
		3857	($x, $y)
		3858	}
		3859
2394	sub update {	3860	sub update {
2395	my ($self) = @_;	3861	my ($self) = @_;
2396		3862
2397	$self->check_size;	3863	$::WANT_REFRESH++;
2398	::refresh ();
2399	}	3864	}
2400		3865
2401	sub add {	3866	sub add {
2402	my ($self, $child) = @_;	3867	my ($self, @children) = @_;
2403		3868
2404	# integerize window positions	3869	$_->{is_toplevel} = 1
2405	$child->{x} = int $child->{x};	3870	for @children;
2406	$child->{y} = int $child->{y};
2407		3871
2408	$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	}
2409	}	3888	}
2410		3889
2411	sub on_refresh {	3890	sub on_refresh {
2412	my ($self, $id, $cb) = @_;	3891	my ($self, $id, $cb) = @_;
2413		3892
2414	$self->{refresh_hook}{$id} = $cb;	3893	$self->{refresh_hook}{$id} = $cb;
2415	}	3894	}
2416		3895
		3896	sub on_post_alloc {
		3897	my ($self, $id, $cb) = @_;
		3898
		3899	$self->{post_alloc_hook}{$id} = $cb;
		3900	}
		3901
2417	sub draw {	3902	sub draw {
2418	my ($self) = @_;	3903	my ($self) = @_;
2419		3904
2420	while (my $rcb = delete $self->{refresh_hook}) {	3905	while ($self->{refresh_hook}) {
2421	$_->() for values %$rcb;	3906	$_->()
		3907	for values %{delete $self->{refresh_hook}};
2422	}	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
2423		4001
2424	glViewport 0, 0, $::WIDTH, $::HEIGHT;	4002	glViewport 0, 0, $::WIDTH, $::HEIGHT;
2425	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	4003	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
2426	glClear GL_COLOR_BUFFER_BIT;	4004	glClear GL_COLOR_BUFFER_BIT;
2427		4005
2428	glMatrixMode GL_PROJECTION;	4006	glMatrixMode GL_PROJECTION;
2429	glLoadIdentity;	4007	glLoadIdentity;
2430	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000 , 10000;	4008	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
2431	glMatrixMode GL_MODELVIEW;	4009	glMatrixMode GL_MODELVIEW;
2432	glLoadIdentity;	4010	glLoadIdentity;
2433		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
2434	$self->_draw;	4019	$self->_draw;
2435	}	4020	}
2436		4021
2437	#############################################################################	4022	#############################################################################
2438		4023
2439	package CFClient::UI;	4024	package CFClient::UI;
2440		4025
2441	$ROOT = new CFClient::UI::Root;	4026	$ROOT = new CFClient::UI::Root;
2442	$TOOLTIP = new CFClient::UI::Tooltip;	4027	$TOOLTIP = new CFClient::UI::Tooltip z => 900;
2443		4028
2444	1	4029	1
2445		4030

Diff Legend

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