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

Diff Legend

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