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

Diff Legend

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