ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/deliantra/Deliantra-Client/DC/UI.pm

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

Diff Legend

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