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.195 by root, Thu May 11 23:54:31 2006 UTC vs.
Revision 1.288 by root, Mon Jun 5 21:14:40 2006 UTC

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

Diff Legend

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