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.185 by root, Mon May 8 17:23:08 2006 UTC vs.
Revision 1.311 by root, Fri Jun 23 22:35:16 2006 UTC

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

Diff Legend

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