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

Diff Legend

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