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.182 by root, Sun Apr 30 11:17:08 2006 UTC vs.
Revision 1.306 by root, Sun Jun 18 17:39:36 2006 UTC

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

Diff Legend

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