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.186 by root, Mon May 8 20:39:34 2006 UTC vs.
Revision 1.303 by elmex, Tue Jun 13 10:28:38 2006 UTC

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

Diff Legend

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