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.163 by root, Mon Apr 24 06:40:29 2006 UTC vs.
Revision 1.302 by root, Mon Jun 12 13:26:14 2006 UTC

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

Diff Legend

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