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.197 by root, Fri May 12 01:47:04 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_tooltip_from ($widget);	37	$TOOLTIP->set_tooltip_from ($widget);
30	$TOOLTIP->show;	38	$TOOLTIP->show;
31
32	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
33
34	if ($x + $TOOLTIP->{w} > $::WIDTH) {
35	($x, $y) = $widget->coord2global (-$TOOLTIP->{w}, 0);
36	}
37
38	$TOOLTIP->move ($x, $y);
39	$TOOLTIP->check_size;
40	$TOOLTIP->update;
41	}	39	}
42		40
43	return;	41	return;
44	}	42	}
45	}	43	}
46	}	44	}
47		45
48	$TOOLTIP->hide;	46	$TOOLTIP->hide;
49	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;
50	}	71	}
51		72
52	# class methods for events	73	# class methods for events
53	sub feed_sdl_key_down_event {	74	sub feed_sdl_key_down_event {
54	$FOCUS->emit (key_down => $_[0]) || $FOCUS->key_down ($_[0])	75	$FOCUS->emit (key_down => $_[0])
55	if $FOCUS;	76	if $FOCUS;
56	}	77	}
57		78
58	sub feed_sdl_key_up_event {	79	sub feed_sdl_key_up_event {
59	$FOCUS->emit (key_up => $_[0]) || $FOCUS->key_up ($_[0])	80	$FOCUS->emit (key_up => $_[0])
60	if $FOCUS;	81	if $FOCUS;
61	}	82	}
62		83
63	sub feed_sdl_button_down_event {	84	sub feed_sdl_button_down_event {
64	my ($ev) = @_;	85	my ($ev) = @_;
…		…
68	my $widget = $ROOT->find_widget ($x, $y);	89	my $widget = $ROOT->find_widget ($x, $y);
69		90
70	$GRAB = $widget;	91	$GRAB = $widget;
71	$GRAB->update if $GRAB;	92	$GRAB->update if $GRAB;
72		93
73	check_tooltip;	94	$TOOLTIP_WATCHER->cb->();
74	}	95	}
75		96
76	$BUTTON_STATE |= 1 << ($ev->{button} - 1);	97	$BUTTON_STATE |= 1 << ($ev->{button} - 1);
77		98
78	if ($GRAB) {	99	$GRAB->emit (button_down => $ev, $GRAB->coord2local ($x, $y))
79	($x, $y) = $GRAB->coord2local ($x, $y);	100	if $GRAB;
80	$GRAB->emit (button_down => $ev, $x, $y) || $GRAB->button_down ($ev, $x, $y);
81	}
82	}	101	}
83		102
84	sub feed_sdl_button_up_event {	103	sub feed_sdl_button_up_event {
85	my ($ev) = @_;	104	my ($ev) = @_;
86	my ($x, $y) = ($ev->{x}, $ev->{y});	105	my ($x, $y) = ($ev->{x}, $ev->{y});
87		106
88	my $widget = $GRAB || $ROOT->find_widget ($x, $y);	107	my $widget = $GRAB || $ROOT->find_widget ($x, $y);
89		108
90	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));	109	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));
91		110
92	if ($GRAB) {	111	$GRAB->emit (button_up => $ev, $GRAB->coord2local ($x, $y))
93	($x, $y) = $GRAB->coord2local ($x, $y);	112	if $GRAB;
94	$GRAB->emit (button_up => $ev, $x, $y) || $GRAB->button_up ($ev, $x, $y);
95	}
96		113
97	if (!$BUTTON_STATE) {	114	if (!$BUTTON_STATE) {
98	my $grab = $GRAB; undef $GRAB;	115	my $grab = $GRAB; undef $GRAB;
99	$grab->update if $grab;	116	$grab->update if $grab;
100	$GRAB->update if $GRAB;	117	$GRAB->update if $GRAB;
101		118
102	check_tooltip;	119	$TOOLTIP_WATCHER->cb->();
103	}	120	}
104	}	121	}
105		122
106	sub feed_sdl_motion_event {	123	sub feed_sdl_motion_event {
107	my ($ev) = @_;	124	my ($ev) = @_;
…		…
113	my $hover = $HOVER; $HOVER = $widget;	130	my $hover = $HOVER; $HOVER = $widget;
114		131
115	$hover->update if $hover && $hover->{can_hover};	132	$hover->update if $hover && $hover->{can_hover};
116	$HOVER->update if $HOVER && $HOVER->{can_hover};	133	$HOVER->update if $HOVER && $HOVER->{can_hover};
117		134
118	check_tooltip;	135	$TOOLTIP_WATCHER->start;
119	}	136	}
120		137
121	if ($HOVER) {
122	($x, $y) = $HOVER->coord2local ($x, $y);
123	$HOVER->emit (mouse_motion => $ev, $x, $y) || $HOVER->mouse_motion ($ev, $x, $y);	138	$HOVER->emit (mouse_motion => $ev, $HOVER->coord2local ($x, $y))
124	}	139	if $HOVER;
125	}	140	}
126		141
127	# convert position array to integers	142	# convert position array to integers
128	sub harmonize {	143	sub harmonize {
129	my ($vals) = @_;	144	my ($vals) = @_;
…		…
135	$rem += $_ - $i;	150	$rem += $_ - $i;
136	$_ = $i;	151	$_ = $i;
137	}	152	}
138	}	153	}
139		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
140	#############################################################################	196	#############################################################################
141		197
142	package CFClient::UI::Base;	198	package CFClient::UI::Base;
143		199
144	use strict;	200	use strict;
…		…
147		203
148	sub new {	204	sub new {
149	my $class = shift;	205	my $class = shift;
150		206
151	my $self = bless {	207	my $self = bless {
152	x => 0,	208	x => "center",
153	y => 0,	209	y => "center",
154	z => 0,	210	z => 0,
		211	w => undef,
		212	h => undef,
155	can_events => 1,	213	can_events => 1,
156	@_	214	@_
157	}, $class;	215	}, $class;
158		216
		217	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);
		218
159	for (keys %$self) {	219	for (keys %$self) {
160	if (/^connect_(.*)$/) {	220	if (/^on_(.*)$/) {
161	$self->connect ($1 => delete $self->{$_});	221	$self->connect ($1 => delete $self->{$_});
162	}	222	}
163	}	223	}
164		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
165	$self	237	$self
166	}	238	}
167		239
168	sub destroy {	240	sub destroy {
169	my ($self) = @_;	241	my ($self) = @_;
…		…
178	return if $self->{parent};	250	return if $self->{parent};
179		251
180	$CFClient::UI::ROOT->add ($self);	252	$CFClient::UI::ROOT->add ($self);
181	}	253	}
182		254
183	sub hide {	255	sub set_visible {
184	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};
185		279
186	undef $GRAB if $GRAB == $self;	280	undef $GRAB if $GRAB == $self;
187	undef $HOVER if $HOVER == $self;	281	undef $HOVER if $HOVER == $self;
188		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
189	$self->{parent}->remove ($self)	313	$self->{parent}->remove ($self)
190	if $self->{parent};	314	if $self->{parent};
191	}	315	}
192		316
193	sub move {	317	sub move_abs {
194	my ($self, $x, $y, $z) = @_;	318	my ($self, $x, $y, $z) = @_;
195		319
196	$self->{x} = int $x;	320	$self->{x} = List::Util::max 0, int $x;
197	$self->{y} = int $y;	321	$self->{y} = List::Util::max 0, int $y;
198	$self->{z} = $z if defined $z;	322	$self->{z} = $z if defined $z;
199		323
200	$self->update;	324	$self->update;
201	}	325	}
202		326
203	sub set_size {	327	sub set_size {
204	my ($self, $w, $h) = @_;	328	my ($self, $w, $h) = @_;
205		329
206	$self->{user_w} = $w;	330	$self->{force_w} = $w;
207	$self->{user_h} = $h;	331	$self->{force_h} = $h;
208		332
209	$self->check_size;	333	$self->realloc;
210	}	334	}
211		335
212	sub size_request {	336	sub size_request {
213	require Carp;	337	require Carp;
214	Carp::confess "size_request is abstract";	338	Carp::confess "size_request is abstract";
…		…
216		340
217	sub configure {	341	sub configure {
218	my ($self, $x, $y, $w, $h) = @_;	342	my ($self, $x, $y, $w, $h) = @_;
219		343
220	if ($self->{aspect}) {	344	if ($self->{aspect}) {
		345	my ($ow, $oh) = ($w, $h);
		346
221	my $w2 = List::Util::min $w, int $h * $self->{aspect};	347	$w = List::Util::min $w, int $h * $self->{aspect};
222	my $h2 = List::Util::min $h, int $w / $self->{aspect};	348	$h = List::Util::min $h, int $w / $self->{aspect};
223		349
224	# use alignment to adjust x, y	350	# use alignment to adjust x, y
225		351
226	$x += int +($w - $w2) * 0.5;	352	$x += int 0.5 * ($ow - $w);
227	$y += int +($h - $h2) * 0.5;	353	$y += int 0.5 * ($oh - $h);
228
229	($w, $h) = ($w2, $h2);
230	}	354	}
231		355
232	if ($self->{x} != $x || $self->{y} != $y) {	356	if ($self->{x} ne $x || $self->{y} ne $y) {
233	$self->{x} = $x;	357	$self->{x} = $x;
234	$self->{y} = $y;	358	$self->{y} = $y;
235	$self->update;	359	$self->update;
236	}	360	}
237		361
238	if ($self->{w} != $w || $self->{h} != $h) {	362	if ($self->{alloc_w} != $w || $self->{alloc_h} != $h) {
239	$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;
240	}	369	}
241	}	370	}
242		371
243	sub size_allocate {	372	sub size_allocate {
244	# nothing to be done	373	# nothing to be done
245	}	374	}
246		375
247	sub children {	376	sub children {
		377	# nop
248	}	378	}
249		379
250	# call when resolution changes etc.	380	sub visible_children {
251	sub reconfigure {	381	$_[0]->children
252	my ($self) = @_;
253
254	$_->reconfigure
255	for $self->children;
256
257	$self->check_size;
258	$CFClient::UI::ROOT->{size_alloc}{$self} = [$self, $self->{w}, $self->{h}];
259	$self->update;
260	}	382	}
261		383
262	sub set_max_size {	384	sub set_max_size {
263	my ($self, $w, $h) = @_;	385	my ($self, $w, $h) = @_;
264		386
265	delete $self->{max_w}; $self->{max_w} = $w if $w;	387	$self->{max_w} = int $w if defined $w;
266	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	}
267	}	407	}
268		408
269	# translate global coordinates to local coordinate system	409	# translate global coordinates to local coordinate system
270	sub coord2local {	410	sub coord2local {
271	my ($self, $x, $y) = @_;	411	my ($self, $x, $y) = @_;
…		…
286	return if $FOCUS == $self;	426	return if $FOCUS == $self;
287	return unless $self->{can_focus};	427	return unless $self->{can_focus};
288		428
289	my $focus = $FOCUS; $FOCUS = $self;	429	my $focus = $FOCUS; $FOCUS = $self;
290		430
291	$self->emit (focus_in => $focus);	431	$self->_emit (focus_in => $focus);
292		432
293	$focus->update if $focus;	433	$focus->update if $focus;
294	$FOCUS->update;	434	$FOCUS->update;
295	}	435	}
296		436
…		…
299		439
300	return unless $FOCUS == $self;	440	return unless $FOCUS == $self;
301		441
302	my $focus = $FOCUS; undef $FOCUS;	442	my $focus = $FOCUS; undef $FOCUS;
303		443
304	$self->emit (focus_out => $focus);	444	$self->_emit (focus_out => $focus);
305		445
306	$focus->update if $focus; #?	446	$focus->update if $focus; #?
307	}
308		447
		448	$::MAPWIDGET->focus_in #d# focus mapwidget if no other widget has focus
		449	unless $FOCUS;
		450	}
		451
309	sub mouse_motion { }	452	sub mouse_motion { 0 }
310	sub button_up { }	453	sub button_up { 0 }
311	sub key_down { }	454	sub key_down { 0 }
312	sub key_up { }	455	sub key_up { 0 }
313		456
314	sub button_down {	457	sub button_down {
315	my ($self, $ev, $x, $y) = @_;	458	my ($self, $ev, $x, $y) = @_;
316		459
317	$self->focus_in;	460	$self->focus_in;
318	}
319		461
320	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	462	0
321	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	463	}
322	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	464
323	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	465	sub find_widget {
324	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
325		542
326	sub draw {	543	sub draw {
327	my ($self) = @_;	544	my ($self) = @_;
328		545
329	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);
330		557
331	glPushMatrix;	558	glPushMatrix;
332	glTranslate $self->{x}, $self->{y}, 0;	559	glTranslate $self->{x}, $self->{y}, 0;
333	$self->_draw;
334	glPopMatrix;
335		560
336	if ($self == $HOVER && $self->{can_hover}) {	561	if ($self == $HOVER && $self->{can_hover}) {
337	my ($x, $y) = @$self{qw(x y)};
338
339	glColor 1, 0.8, 0.5, 0.2;	562	glColor 1*0.2, 0.8*0.2, 0.5*0.2, 0.2;
340	glEnable GL_BLEND;	563	glEnable GL_BLEND;
341	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	564	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
342	glBegin GL_QUADS;	565	glBegin GL_QUADS;
343	glVertex $x , $y;
344	glVertex $x + $self->{w}, $y;
345	glVertex $x + $self->{w}, $y + $self->{h};
346	glVertex $x , $y + $self->{h};
347	glEnd;
348	glDisable GL_BLEND;
349	}
350
351	if ($ENV{PCLIENT_DEBUG}) {
352	glPushMatrix;
353	glColor 1, 1, 0, 1;
354	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;
355	glBegin GL_LINE_LOOP;
356	glVertex 0 , 0;	566	glVertex 0 , 0;
357	glVertex $self->{w}, 0;	567	glVertex $self->{w}, 0;
358	glVertex $self->{w}, $self->{h};	568	glVertex $self->{w}, $self->{h};
359	glVertex 0 , $self->{h};	569	glVertex 0 , $self->{h};
360	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;
361	glPopMatrix;	584	glPopMatrix;
362	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;
363	}	586	}
		587
		588	$self->_draw;
		589	glPopMatrix;
364	}	590	}
365		591
366	sub _draw {	592	sub _draw {
367	my ($self) = @_;	593	my ($self) = @_;
368		594
369	warn "no draw defined for $self\n";	595	warn "no draw defined for $self\n";
370	}	596	}
371		597
372	sub find_widget {
373	my ($self, $x, $y) = @_;
374
375	return () unless $self->{can_events};
376
377	return $self
378	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
379	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
380
381	()
382	}
383
384	sub set_parent {
385	my ($self, $parent) = @_;
386
387	Scalar::Util::weaken ($self->{parent} = $parent);
388
389	$self->check_size
390	unless exists $self->{req_w};
391	}
392
393	sub check_size {
394	my ($self, $forced) = @_;
395
396	$self->{force_alloc} = 1 if $forced;
397	$CFClient::UI::ROOT->{check_size}{$self} = $self;
398	}
399
400	sub update {
401	my ($self) = @_;
402
403	$self->{parent}->update
404	if $self->{parent};
405	}
406
407	sub connect {
408	my ($self, $signal, $cb) = @_;
409
410	push @{ $self->{signal_cb}{$signal} }, $cb;
411	}
412
413	sub emit {
414	my ($self, $signal, @args) = @_;
415
416	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
417	}
418
419	sub DESTROY {	598	sub DESTROY {
420	my ($self) = @_;	599	my ($self) = @_;
421		600
		601	delete $WIDGET{$self+0};
422	#$self->deactivate;	602	#$self->deactivate;
423	}	603	}
424		604
425	#############################################################################	605	#############################################################################
426		606
…		…
435	my $class = shift;	615	my $class = shift;
436		616
437	# range [value, low, high, page]	617	# range [value, low, high, page]
438		618
439	$class->SUPER::new (	619	$class->SUPER::new (
440	bg => [0, 0, 0, 0.2],	620	#bg => [0, 0, 0, 0.2],
441	active_bg => [1, 1, 1, 0.5],	621	#active_bg => [1, 1, 1, 0.5],
442	@_	622	@_
443	)	623	)
444	}	624	}
445		625
446	sub _draw {	626	sub _draw {
447	my ($self) = @_;	627	my ($self) = @_;
448		628
		629	my $color = $FOCUS == $self && $self->{active_bg}
		630	? $self->{active_bg}
		631	: $self->{bg};
		632
		633	if ($color && (@$color < 4 || $color->[3])) {
449	my ($w, $h) = @$self{qw(w h)};	634	my ($w, $h) = @$self{qw(w h)};
450		635
451	glEnable GL_BLEND;	636	glEnable GL_BLEND;
452	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	637	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
453	glColor @{ $FOCUS == $self ? $self->{active_bg} : $self->{bg} };	638	glColor_premultiply @$color;
454		639
455	glBegin GL_QUADS;	640	glBegin GL_QUADS;
456	glVertex 0 , 0;	641	glVertex 0 , 0;
457	glVertex 0 , $h;	642	glVertex 0 , $h;
458	glVertex $w, $h;	643	glVertex $w, $h;
459	glVertex $w, 0;	644	glVertex $w, 0;
460	glEnd;	645	glEnd;
461		646
462	glDisable GL_BLEND;	647	glDisable GL_BLEND;
		648	}
463	}	649	}
464		650
465	#############################################################################	651	#############################################################################
466		652
467	package CFClient::UI::Empty;	653	package CFClient::UI::Empty;
…		…
472	my ($class, %arg) = @_;	658	my ($class, %arg) = @_;
473	$class->SUPER::new (can_events => 0, %arg);	659	$class->SUPER::new (can_events => 0, %arg);
474	}	660	}
475		661
476	sub size_request {	662	sub size_request {
477	(0, 0)	663	my ($self) = @_;
		664
		665	($self->{w} + 0, $self->{h} + 0)
478	}	666	}
479		667
480	sub draw { }	668	sub draw { }
481		669
482	#############################################################################	670	#############################################################################
…		…
486	our @ISA = CFClient::UI::Base::;	674	our @ISA = CFClient::UI::Base::;
487		675
488	sub new {	676	sub new {
489	my ($class, %arg) = @_;	677	my ($class, %arg) = @_;
490		678
491	my $children = delete $arg{children} || [];	679	my $children = delete $arg{children};
492		680
493	my $self = $class->SUPER::new (	681	my $self = $class->SUPER::new (
494	children => [],	682	children => [],
495	can_events => 0,	683	can_events => 0,
496	%arg,	684	%arg,
497	);	685	);
		686
498	$self->add ($_) for @$children;	687	$self->add (@$children)
		688	if $children;
499		689
500	$self	690	$self
501	}	691	}
502		692
503	sub add {	693	sub add {
…		…
511	$self->{children} = [	701	$self->{children} = [
512	sort { $a->{z} <=> $b->{z} }	702	sort { $a->{z} <=> $b->{z} }
513	@{$self->{children}}, @widgets	703	@{$self->{children}}, @widgets
514	];	704	];
515		705
516	$self->check_size (1);	706	$self->realloc;
517	$self->update;
518	}	707	}
519		708
520	sub children {	709	sub children {
521	@{ $_[0]{children} }	710	@{ $_[0]{children} }
522	}	711	}
…		…
527	delete $child->{parent};	716	delete $child->{parent};
528	$child->hide;	717	$child->hide;
529		718
530	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];	719	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];
531		720
532	$self->check_size;	721	$self->realloc;
533	$self->update;
534	}	722	}
535		723
536	sub clear {	724	sub clear {
537	my ($self) = @_;	725	my ($self) = @_;
538		726
…		…
542	for (@$children) {	730	for (@$children) {
543	delete $_->{parent};	731	delete $_->{parent};
544	$_->hide;	732	$_->hide;
545	}	733	}
546		734
547	$self->check_size;	735	$self->realloc;
548	$self->update;
549	}	736	}
550		737
551	sub find_widget {	738	sub find_widget {
552	my ($self, $x, $y) = @_;	739	my ($self, $x, $y) = @_;
553		740
554	$x -= $self->{x};	741	$x -= $self->{x};
555	$y -= $self->{y};	742	$y -= $self->{y};
556		743
557	my $res;	744	my $res;
558		745
559	for (reverse @{ $self->{children} }) {	746	for (reverse $self->visible_children) {
560	$res = $_->find_widget ($x, $y)	747	$res = $_->find_widget ($x, $y)
561	and return $res;	748	and return $res;
562	}	749	}
563		750
564	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})	751	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})
…		…
613	$self->{children}[0]->configure (0, 0, $w, $h);	800	$self->{children}[0]->configure (0, 0, $w, $h);
614	}	801	}
615		802
616	#############################################################################	803	#############################################################################
617		804
		805	# back-buffered drawing area
		806
618	package CFClient::UI::Window;	807	package CFClient::UI::Window;
619		808
620	our @ISA = CFClient::UI::Bin::;	809	our @ISA = CFClient::UI::Bin::;
621		810
622	use CFClient::OpenGL;	811	use CFClient::OpenGL;
…		…
628	}	817	}
629		818
630	sub update {	819	sub update {
631	my ($self) = @_;	820	my ($self) = @_;
632		821
633	$ROOT->on_refresh ($self => sub { $self->render_child });	822	$ROOT->on_post_alloc ($self => sub { $self->render_child });
634	$self->SUPER::update;	823	$self->SUPER::update;
635	}	824	}
636		825
637	sub size_allocate {	826	sub size_allocate {
638	my ($self, $w, $h) = @_;	827	my ($self, $w, $h) = @_;
…		…
640	$self->SUPER::size_allocate ($w, $h);	829	$self->SUPER::size_allocate ($w, $h);
641	$self->update;	830	$self->update;
642	}	831	}
643		832
644	sub _render {	833	sub _render {
		834	my ($self) = @_;
		835
645	$_[0]{children}[0]->draw;	836	$self->{children}[0]->draw;
646	}	837	}
647		838
648	sub render_child {	839	sub render_child {
649	my ($self) = @_;	840	my ($self) = @_;
650		841
651	$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 {
652	glClearColor 0, 0, 0, 0;	843	glClearColor 0, 0, 0, 0;
653	glClear GL_COLOR_BUFFER_BIT;	844	glClear GL_COLOR_BUFFER_BIT;
654		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
655	$self->_render;	853	$self->_render;
656	# glColorMask 1, 1, 1, 0;
657	# glEnable GL_BLEND;
658	# glBlendFunc GL_SRC_ALPHA, GL_ZERO;
659	# glRasterPos 0, 0;
660	# glCopyPixels 0, 0, $self->{w}, $self->{h};
661	# glDisable GL_BLEND;
662	# glColorMask 1, 1, 1, 1;
663	};	854	};
664	}	855	}
665		856
666	sub _draw {	857	sub _draw {
667	my ($self) = @_;	858	my ($self) = @_;
668		859
669	my ($w, $h) = ($self->w, $self->h);	860	my ($w, $h) = @$self{qw(w h)};
670		861
671	my $tex = $self->{texture}	862	my $tex = $self->{texture}
672	or return;	863	or return;
673		864
674	glEnable GL_TEXTURE_2D;	865	glEnable GL_TEXTURE_2D;
…		…
684		875
685	package CFClient::UI::ViewPort;	876	package CFClient::UI::ViewPort;
686		877
687	our @ISA = CFClient::UI::Window::;	878	our @ISA = CFClient::UI::Window::;
688		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
689	sub size_request {	890	sub size_request {
690	my ($self) = @_;	891	my ($self) = @_;
691		892
692	@$self{qw(child_w child_h)} = @{$self->child}{qw(req_w req_h)};	893	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
693	$self->child->configure (0, 0, @$self{qw(child_w child_h)});
694		894
695	@$self{qw(child_w child_h)}	895	$w = 10 if $self->{scroll_x};
		896	$h = 10 if $self->{scroll_y};
		897
		898	($w, $h)
696	}	899	}
697		900
698	sub size_allocate {	901	sub size_allocate {
699	my ($self, $w, $h) = @_;	902	my ($self, $w, $h) = @_;
700		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);
701	$self->update;	910	$self->update;
702	}	911	}
703		912
704	sub set_offset {	913	sub set_offset {
705	my ($self, $x, $y) = @_;	914	my ($self, $x, $y) = @_;
…		…
739	}	948	}
740		949
741	sub _render {	950	sub _render {
742	my ($self) = @_;	951	my ($self) = @_;
743		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
744	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};	956	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};
745		957
746	$self->SUPER::_render;	958	$self->SUPER::_render;
747	}	959	}
748		960
749	#############################################################################	961	#############################################################################
750		962
751	package CFClient::UI::ScrolledWindow;	963	package CFClient::UI::ScrolledWindow;
752		964
753	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;
754		1029
755	sub new {	1030	sub new {
756	my $class = shift;	1031	my $class = shift;
757		1032
758	my $self;
759
760	my $slider = new CFClient::UI::Slider
761	vertical => 1,
762	range => [0, 0, 1, 0.01], # HACK fix
763	connect_changed => sub {
764	$self->{vp}->set_offset (0, $_[1] * ($self->{vp}{child_h} - $self->{vp}{h}));
765	},
766	;
767
768	$self = $class->SUPER::new (	1033	$class->SUPER::new (
769	vp => (new CFClient::UI::ViewPort),	1034	bg => undef,
770	slider => $slider,
771	@_,	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,
772	);	1091	);
773		1092
774	$self->{vp}->add ($self->{scrolled});
775	$self->add ($self->{vp});
776	$self->add ($self->{slider});
777
778	$self
779	}
780
781	#TODO# update range on size_allocate depeneing on child
782	# update viewport offset on scroll
783
784	#############################################################################
785
786	package CFClient::UI::Frame;
787
788	our @ISA = CFClient::UI::Bin::;
789
790	use CFClient::OpenGL;
791
792	#############################################################################
793
794	package CFClient::UI::FancyFrame;
795
796	our @ISA = CFClient::UI::Bin::;
797
798	use CFClient::OpenGL;
799
800	my @tex =
801	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
802	qw(d1_bg.png d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
803
804	sub new {
805	my $class = shift;
806
807	# TODO: user_x, user_y, overwrite moveto?
808
809	my $self = $class->SUPER::new (
810	bg => [1, 1, 1, 1],
811	border_bg => [1, 1, 1, 1],
812	border => 0.6,
813	can_events => 1,
814	@_
815	);
816
817	$self->{title} &&= new CFClient::UI::Label	1093	$self->{title} = new CFClient::UI::Label
818	align => 0,	1094	align => 0,
819	valign => 1,	1095	valign => 1,
820	text => $self->{title},	1096	text => $title,
821	fontsize => $self->{border};	1097	fontsize => $self->{border}
		1098	if defined $title;
822		1099
823	$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};
824	}	1108	}
825		1109
826	sub border {	1110	sub border {
827	int $_[0]{border} * $::FONTSIZE	1111	int $_[0]{border} * $::FONTSIZE
828	}	1112	}
829		1113
830	sub size_request {	1114	sub size_request {
831	my ($self) = @_;	1115	my ($self) = @_;
		1116
		1117	$self->{title}->size_request
		1118	if $self->{title};
832		1119
833	my ($w, $h) = $self->SUPER::size_request;	1120	my ($w, $h) = $self->SUPER::size_request;
834		1121
835	(	1122	(
836	$w + $self->border * 2,	1123	$w + $self->border * 2,
…		…
839	}	1126	}
840		1127
841	sub size_allocate {	1128	sub size_allocate {
842	my ($self, $w, $h) = @_;	1129	my ($self, $w, $h) = @_;
843		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
844	$h -= List::Util::max 0, $self->border * 2;	1139	$h -= List::Util::max 0, $border * 2;
845	$w -= List::Util::max 0, $self->border * 2;	1140	$w -= List::Util::max 0, $border * 2;
846		1141
847	$self->{title}->configure ($self->border, $self->border - $::FONTSIZE * 2, $w, $::FONTSIZE * 2)
848	if $self->{title};
849
850	$self->child->configure ($self->border, $self->border, $w, $h);	1142	$self->child->configure ($border, $border, $w, $h);
851	}	1143	}
852		1144
853	sub button_down {	1145	sub button_down {
854	my ($self, $ev, $x, $y) = @_;	1146	my ($self, $ev, $x, $y) = @_;
855		1147
…		…
871	my ($ev, $x, $y) = @_;	1163	my ($ev, $x, $y) = @_;
872		1164
873	my $dx = $ev->{x} - $ox;	1165	my $dx = $ev->{x} - $ox;
874	my $dy = $ev->{y} - $oy;	1166	my $dy = $ev->{y} - $oy;
875		1167
876	$self->{user_w} = $bw + $dx * ($mx ? -1 : 1);	1168	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
877	$self->{user_h} = $bh + $dy * ($my ? -1 : 1);	1169	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
		1170
878	$self->move ($wx + $dx * $mx, $wy + $dy * $my);	1171	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
879	$self->check_size;	1172	$self->realloc;
880	};	1173	};
881		1174
882	} elsif ($lr ^ $td) {	1175	} elsif ($lr ^ $td) {
883	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1176	my ($ox, $oy) = ($ev->{x}, $ev->{y});
884	my ($bx, $by) = ($self->{x}, $self->{y});	1177	my ($bx, $by) = ($self->{x}, $self->{y});
…		…
886	$self->{motion} = sub {	1179	$self->{motion} = sub {
887	my ($ev, $x, $y) = @_;	1180	my ($ev, $x, $y) = @_;
888		1181
889	($x, $y) = ($ev->{x}, $ev->{y});	1182	($x, $y) = ($ev->{x}, $ev->{y});
890		1183
891	$self->move ($bx + $x - $ox, $by + $y - $oy);	1184	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
892	$self->update;	1185	# HACK: the next line is required to enforce placement
		1186	$self->{parent}->size_allocate ($self->{parent}{w}, $self->{parent}{h});
893	};	1187	};
		1188	} else {
		1189	return 0;
		1190	}
		1191
894	}	1192	1
895	}	1193	}
896		1194
897	sub button_up {	1195	sub button_up {
898	my ($self, $ev, $x, $y) = @_;	1196	my ($self, $ev, $x, $y) = @_;
899		1197
900	delete $self->{motion};	1198	!!delete $self->{motion}
901	}	1199	}
902		1200
903	sub mouse_motion {	1201	sub mouse_motion {
904	my ($self, $ev, $x, $y) = @_;	1202	my ($self, $ev, $x, $y) = @_;
905		1203
906	$self->{motion}->($ev, $x, $y) if $self->{motion};	1204	$self->{motion}->($ev, $x, $y) if $self->{motion};
		1205
		1206	!!$self->{motion}
907	}	1207	}
908		1208
909	sub _draw {	1209	sub _draw {
910	my ($self) = @_;	1210	my ($self) = @_;
911		1211
		1212	my $child = $self->{children}[0];
		1213
912	my ($w, $h ) = ($self->{w}, $self->{h});	1214	my ($w, $h ) = ($self->{w}, $self->{h});
913	my ($cw, $ch) = ($self->child->{w}, $self->child->{h});	1215	my ($cw, $ch) = ($child->{w}, $child->{h});
914		1216
915	glEnable GL_TEXTURE_2D;	1217	glEnable GL_TEXTURE_2D;
916	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1218	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
917		1219
918	my $border = $self->border;	1220	my $border = $self->border;
919		1221
920	glColor @{ $self->{border_bg} };	1222	glColor @{ $self->{border_bg} };
921	$tex[1]->draw_quad_alpha (0, 0, $w, $border);	1223	$border[0]->draw_quad_alpha (0, 0, $w, $border);
922	$tex[3]->draw_quad_alpha (0, $border, $border, $ch);	1224	$border[1]->draw_quad_alpha (0, $border, $border, $ch);
923	$tex[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);	1225	$border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);
924	$tex[4]->draw_quad_alpha (0, $h - $border, $w, $border);	1226	$border[3]->draw_quad_alpha (0, $h - $border, $w, $border);
925		1227
926	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {	1228	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {
927	my $bg = $tex[0];	1229	glColor @{ $self->{bg} };
928		1230
929	# TODO: repeat texture not scale	1231	# TODO: repeat texture not scale
		1232	# solve this better(?)
930	my $rep_x = $cw / $bg->{w};	1233	$bg->{s} = $cw / $bg->{w};
931	my $rep_y = $ch / $bg->{h};	1234	$bg->{t} = $ch / $bg->{h};
932
933	glColor @{ $self->{bg} };
934
935	$bg->{s} = $rep_x;
936	$bg->{t} = $rep_y;
937	$bg->{wrap_mode} = 1;
938	$bg->draw_quad_alpha ($border, $border, $cw, $ch);	1235	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
939	}	1236	}
940		1237
941	glDisable GL_TEXTURE_2D;	1238	glDisable GL_TEXTURE_2D;
942		1239
943	$self->{title}->draw if $self->{title};
944
945	$self->child->draw;	1240	$child->draw;
		1241
		1242	if ($self->{title}) {
		1243	glTranslate 0, $border - $self->{h};
		1244	$self->{title}->_draw;
		1245	}
946	}	1246	}
947		1247
948	#############################################################################	1248	#############################################################################
949		1249
950	package CFClient::UI::Table;	1250	package CFClient::UI::Table;
…		…
958	sub new {	1258	sub new {
959	my $class = shift;	1259	my $class = shift;
960		1260
961	$class->SUPER::new (	1261	$class->SUPER::new (
962	col_expand => [],	1262	col_expand => [],
963	@_	1263	@_,
964	)	1264	)
		1265	}
		1266
		1267	sub children {
		1268	grep $_, map @$_, grep $_, @{ $_[0]{children} }
965	}	1269	}
966		1270
967	sub add {	1271	sub add {
968	my ($self, $x, $y, $child) = @_;	1272	my ($self, $x, $y, $child) = @_;
969		1273
970	$child->set_parent ($self);	1274	$child->set_parent ($self);
971	$self->{children}[$y][$x] = $child;	1275	$self->{children}[$y][$x] = $child;
972		1276
973	$child->check_size;	1277	$self->realloc;
974	}	1278	}
975		1279
976	sub children {
977	grep $_, map @$_, grep $_, @{ $_[0]{children} }
978	}
979
980	# 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?
981	sub clear {	1281	sub clear {
982	my ($self) = @_;	1282	my ($self) = @_;
983		1283
984	my @children = $self->children;	1284	my @children = $self->children;
985	delete $self->{children};	1285	delete $self->{children};
…		…
987	for (@children) {	1287	for (@children) {
988	delete $_->{parent};	1288	delete $_->{parent};
989	$_->hide;	1289	$_->hide;
990	}	1290	}
991		1291
992	$self->update;	1292	$self->realloc;
993	}	1293	}
994		1294
995	sub get_wh {	1295	sub get_wh {
996	my ($self) = @_;	1296	my ($self) = @_;
997		1297
…		…
1028	sub size_allocate {	1328	sub size_allocate {
1029	my ($self, $w, $h) = @_;	1329	my ($self, $w, $h) = @_;
1030		1330
1031	my ($ws, $hs) = $self->get_wh;	1331	my ($ws, $hs) = $self->get_wh;
1032		1332
1033	my $req_w = sum @$ws;	1333	my $req_w = (sum @$ws) || 1;
1034	my $req_h = sum @$hs;	1334	my $req_h = (sum @$hs) || 1;
1035		1335
1036	# TODO: nicer code && do row_expand	1336	# TODO: nicer code && do row_expand
1037	my @col_expand = @{$self->{col_expand}};	1337	my @col_expand = @{$self->{col_expand}};
1038	@col_expand = (1) x @$ws unless @col_expand;	1338	@col_expand = (1) x @$ws unless @col_expand;
1039	my $col_expand = (sum @col_expand) || 1;	1339	my $col_expand = (sum @col_expand) || 1;
…		…
1093	}	1393	}
1094	}	1394	}
1095		1395
1096	#############################################################################	1396	#############################################################################
1097		1397
1098	package CFClient::UI::HBox;	1398	package CFClient::UI::Box;
1099
1100	# TODO: wrap into common Box base class
1101		1399
1102	our @ISA = CFClient::UI::Container::;	1400	our @ISA = CFClient::UI::Container::;
1103		1401
1104	sub size_request {	1402	sub size_request {
1105	my ($self) = @_;	1403	my ($self) = @_;
1106		1404
1107	my @alloc = map [$_->size_request], @{$self->{children}};	1405	$self->{vertical}
1108		1406	? (
1109	(	1407	(List::Util::max map $_->{req_w}, @{$self->{children}}),
1110	(List::Util::sum map $_->[0], @alloc),	1408	(List::Util::sum map $_->{req_h}, @{$self->{children}}),
1111	(List::Util::max map $_->[1], @alloc),	1409	)
1112	)	1410	: (
		1411	(List::Util::sum map $_->{req_w}, @{$self->{children}}),
		1412	(List::Util::max map $_->{req_h}, @{$self->{children}}),
		1413	)
1113	}	1414	}
1114		1415
1115	sub size_allocate {	1416	sub size_allocate {
1116	my ($self, $w, $h) = @_;	1417	my ($self, $w, $h) = @_;
1117		1418
1118	($h, $w) = ($w, $h);	1419	my $space = $self->{vertical} ? $h : $w;
1119
1120	my $children = $self->{children};	1420	my $children = $self->{children};
1121		1421
1122	my @h = map $_->{req_w}, @$children;	1422	my @req;
1123		1423
1124	my $req_h = List::Util::sum @h;	1424	if ($self->{homogeneous}) {
1125		1425	@req = ($space / (@$children || 1)) x @$children;
1126	if ($req_h > $h) {
1127	# ah well, not enough space
1128	$_ *= $h / $req_h for @h;
1129	} 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 {
1130	my $exp = List::Util::sum map $_->{expand}, @$children;	1434	my $expand = (List::Util::sum map $_->{expand}, @$children) || 1;
1131	$exp ||= 1;
1132		1435
		1436	$space = ($space - $req) / $expand; # remaining space to give away
		1437
		1438	$req[$_] += $space * $children->[$_]{expand}
1133	for (0 .. $#$children) {	1439	for 0 .. $#$children;
1134	my $child = $children->[$_];
1135
1136	my $alloc_h = $h[$_];
1137	$alloc_h += ($h - $req_h) * $child->{expand} / $exp;
1138	$h[$_] = $alloc_h;
1139	}	1440	}
1140	}	1441	}
1141		1442
1142	CFClient::UI::harmonize \@h;	1443	CFClient::UI::harmonize \@req;
1143		1444
1144	my $y = 0;	1445	my $pos = 0;
1145	for (0 .. $#$children) {	1446	for (0 .. $#$children) {
1146	my $child = $children->[$_];
1147	my $h = $h[$_];	1447	my $alloc = $req[$_];
1148	$child->configure ($y, 0, $h, $w);	1448	$children->[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));
1149		1449
1150	$y += $h;	1450	$pos += $alloc;
1151	}	1451	}
1152		1452
1153	1	1453	1
1154	}	1454	}
1155		1455
1156	#############################################################################	1456	#############################################################################
1157		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
1158	package CFClient::UI::VBox;	1473	package CFClient::UI::VBox;
1159		1474
1160	# TODO: wrap into common Box base class
1161
1162	our @ISA = CFClient::UI::Container::;	1475	our @ISA = CFClient::UI::Box::;
1163		1476
1164	sub size_request {	1477	sub new {
1165	my ($self) = @_;	1478	my $class = shift;
1166		1479
1167	my @alloc = map [$_->size_request], @{$self->{children}};	1480	$class->SUPER::new (
1168		1481	vertical => 1,
1169	(	1482	@_,
1170	(List::Util::max map $_->[0], @alloc),
1171	(List::Util::sum map $_->[1], @alloc),
1172	)	1483	)
1173	}	1484	}
1174		1485
1175	sub size_allocate {
1176	my ($self, $w, $h) = @_;
1177
1178	Carp::confess "negative size" if $w < 0 || $h < 0;#d#
1179
1180	my $children = $self->{children};
1181
1182	my @h = map $_->{req_h}, @$children;
1183
1184	my $req_h = List::Util::sum @h;
1185
1186	if ($req_h > $h) {
1187	# ah well, not enough space
1188	$_ *= $h / $req_h for @h;
1189	} else {
1190	my $exp = List::Util::sum map $_->{expand}, @$children;
1191	$exp ||= 1;
1192
1193	for (0 .. $#$children) {
1194	my $child = $children->[$_];
1195
1196	$h[$_] += ($h - $req_h) * $child->{expand} / $exp;
1197	}
1198	}
1199
1200	CFClient::UI::harmonize \@h;
1201
1202	my $y = 0;
1203	for (0 .. $#$children) {
1204	my $child = $children->[$_];
1205	my $h = $h[$_];
1206	$child->configure (0, $y, $w, $h);
1207
1208	$y += $h;
1209	}
1210
1211	1
1212	}
1213
1214	#############################################################################	1486	#############################################################################
1215		1487
1216	package CFClient::UI::Label;	1488	package CFClient::UI::Label;
1217		1489
1218	our @ISA = CFClient::UI::Base::;	1490	our @ISA = CFClient::UI::DrawBG::;
1219		1491
1220	use CFClient::OpenGL;	1492	use CFClient::OpenGL;
1221		1493
1222	sub new {	1494	sub new {
1223	my ($class, %arg) = @_;	1495	my ($class, %arg) = @_;
1224		1496
1225	my $self = $class->SUPER::new (	1497	my $self = $class->SUPER::new (
1226	fg => [1, 1, 1],	1498	fg => [1, 1, 1],
		1499	#bg => none
		1500	#active_bg => none
1227	#font => default_font	1501	#font => default_font
1228	#text => initial text	1502	#text => initial text
1229	#markup => initial narkup	1503	#markup => initial narkup
		1504	#max_w => maximum pixel width
		1505	ellipsise => 3, # end
1230	layout => (new CFClient::Layout),	1506	layout => (new CFClient::Layout),
1231	fontsize => 1,	1507	fontsize => 1,
1232	align => -1,	1508	align => -1,
1233	valign => -1,	1509	valign => -1,
1234	padding => 2,	1510	padding_x => 2,
		1511	padding_y => 2,
1235	can_events => 0,	1512	can_events => 0,
1236	%arg	1513	%arg
1237	);	1514	);
1238		1515
1239	if (exists $self->{template}) {	1516	if (exists $self->{template}) {
…		…
1249	}	1526	}
1250		1527
1251	$self	1528	$self
1252	}	1529	}
1253		1530
1254	sub escape {	1531	sub escape($) {
1255	local $_ = $_[1];	1532	local $_ = $_[0];
1256		1533
1257	s/&/&amp;/g;	1534	s/&/&amp;/g;
1258	s/>/&gt;/g;	1535	s/>/&gt;/g;
1259	s/</&lt;/g;	1536	s/</&lt;/g;
1260		1537
1261	$_[1]	1538	$_
1262	}	1539	}
1263		1540
1264	sub update {	1541	sub update {
1265	my ($self) = @_;	1542	my ($self) = @_;
1266		1543
1267	delete $self->{texture};	1544	delete $self->{texture};
1268	$self->SUPER::update;	1545	$self->SUPER::update;
1269	}	1546	}
1270		1547
		1548	sub realloc {
		1549	my ($self) = @_;
		1550
		1551	delete $self->{ox};
		1552	$self->SUPER::realloc;
		1553	}
		1554
1271	sub set_text {	1555	sub set_text {
1272	my ($self, $text) = @_;	1556	my ($self, $text) = @_;
1273		1557
1274	return if $self->{text} eq "T$text";	1558	return if $self->{text} eq "T$text";
1275	$self->{text} = "T$text";	1559	$self->{text} = "T$text";
1276		1560
1277	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;	1561	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1278	$self->{layout}->set_text ($text);	1562	$self->{layout}->set_text ($text);
1279		1563
		1564	delete $self->{req_h};
		1565	$self->realloc;
1280	$self->update;	1566	$self->update;
1281	$self->check_size;
1282	}	1567	}
1283		1568
1284	sub set_markup {	1569	sub set_markup {
1285	my ($self, $markup) = @_;	1570	my ($self, $markup) = @_;
1286		1571
…		…
1290	my $rgba = $markup =~ /span.*(?:foreground|background)/;	1575	my $rgba = $markup =~ /span.*(?:foreground|background)/;
1291		1576
1292	$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;
1293	$self->{layout}->set_markup ($markup);	1578	$self->{layout}->set_markup ($markup);
1294		1579
		1580	delete $self->{req_h};
		1581	$self->realloc;
1295	$self->update;	1582	$self->update;
1296	$self->check_size;
1297	}	1583	}
1298		1584
1299	sub size_request {	1585	sub size_request {
1300	my ($self) = @_;	1586	my ($self) = @_;
1301		1587
		1588	if (exists $self->{req_h}) {
		1589	@$self{qw(req_w req_h)}
		1590	} else {
1302	$self->{layout}->set_font ($self->{font}) if $self->{font};	1591	$self->{layout}->set_font ($self->{font}) if $self->{font};
1303	$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});
1304	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1595	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1305		1596
1306	my ($w, $h) = $self->{layout}->size;	1597	my ($w, $h) = $self->{layout}->size;
1307		1598
1308	if (exists $self->{template}) {	1599	if (exists $self->{template}) {
1309	$self->{template}->set_font ($self->{font}) if $self->{font};	1600	$self->{template}->set_font ($self->{font}) if $self->{font};
1310	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);	1601	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);
1311		1602
1312	my ($w2, $h2) = $self->{template}->size;	1603	my ($w2, $h2) = $self->{template}->size;
1313		1604
1314	$w = List::Util::max $w, $w2;	1605	$w = List::Util::max $w, $w2;
1315	$h = List::Util::max $h, $h2;	1606	$h = List::Util::max $h, $h2;
1316	}	1607	}
1317		1608
		1609	($w, $h)
1318	(	1610	}
1319	$w + $self->{padding} * 2,
1320	$h + $self->{padding} * 2,
1321	)
1322	}	1611	}
1323		1612
1324	sub size_allocate {	1613	sub size_allocate {
1325	my ($self, $w, $h) = @_;	1614	my ($self, $w, $h) = @_;
1326		1615
		1616	delete $self->{ox};
		1617
1327	delete $self->{texture};	1618	delete $self->{texture}
		1619	unless $w >= $self->{req_w} && $self->{old_w} >= $self->{req_w};
1328	}	1620	}
1329		1621
1330	sub set_fontsize {	1622	sub set_fontsize {
1331	my ($self, $fontsize) = @_;	1623	my ($self, $fontsize) = @_;
1332		1624
1333	$self->{fontsize} = $fontsize;	1625	$self->{fontsize} = $fontsize;
1334	delete $self->{texture};	1626	delete $self->{texture};
1335		1627
1336	$self->update;	1628	$self->realloc;
1337	$self->check_size;
1338	}	1629	}
1339		1630
1340	sub _draw {	1631	sub _draw {
1341	my ($self) = @_;	1632	my ($self) = @_;
		1633
		1634	$self->SUPER::_draw; # draw background, if applicable
1342		1635
1343	my $tex = $self->{texture} ||= do {	1636	my $tex = $self->{texture} ||= do {
1344	$self->{layout}->set_foreground (@{$self->{fg}});	1637	$self->{layout}->set_foreground (@{$self->{fg}});
1345	$self->{layout}->set_font ($self->{font}) if $self->{font};	1638	$self->{layout}->set_font ($self->{font}) if $self->{font};
1346	$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});
1347	$self->{layout}->set_height (List::Util::min $self->{h}, $self->{fontsize} * $::FONTSIZE);	1642	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1348		1643
1349	my $tex = new_from_layout CFClient::Texture $self->{layout};	1644	new_from_layout CFClient::Texture $self->{layout}
1350
1351	$self->{ox} = int $self->{align} < 0 ? $self->{padding}
1352	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding}
1353	: ($self->{w} - $tex->{w}) * 0.5;
1354
1355	$self->{oy} = int $self->{valign} < 0 ? $self->{padding}
1356	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding}
1357	: ($self->{h} - $tex->{h}) * 0.5;
1358
1359	$tex
1360	};	1645	};
1361		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
1362	glEnable GL_TEXTURE_2D;	1657	glEnable GL_TEXTURE_2D;
1363	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1364		1658
1365	if ($tex->{format} == GL_ALPHA) {	1659	if ($tex->{format} == GL_ALPHA) {
		1660	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
1366	glColor @{$self->{fg}};	1661	glColor @{$self->{fg}};
1367	$tex->draw_quad_alpha ($self->{ox}, $self->{oy});	1662	$tex->draw_quad_alpha ($self->{ox}, $self->{oy});
1368	} else {	1663	} else {
		1664	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1369	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy});	1665	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy});
1370	}	1666	}
1371		1667
1372	glDisable GL_TEXTURE_2D;	1668	glDisable GL_TEXTURE_2D;
1373	}	1669	}
…		…
1390	active_fg => [0, 0, 0],	1686	active_fg => [0, 0, 0],
1391	can_hover => 1,	1687	can_hover => 1,
1392	can_focus => 1,	1688	can_focus => 1,
1393	valign => 0,	1689	valign => 0,
1394	can_events => 1,	1690	can_events => 1,
		1691	#text => ...
1395	@_	1692	@_
1396	)	1693	)
1397	}	1694	}
1398		1695
1399	sub _set_text {	1696	sub _set_text {
…		…
1401		1698
1402	delete $self->{cur_h};	1699	delete $self->{cur_h};
1403		1700
1404	return if $self->{text} eq $text;	1701	return if $self->{text} eq $text;
1405		1702
1406	delete $self->{texture};
1407
1408	$self->{last_activity} = $::NOW;	1703	$self->{last_activity} = $::NOW;
1409	$self->{text} = $text;	1704	$self->{text} = $text;
1410		1705
1411	$text =~ s/./*/g if $self->{hidden};	1706	$text =~ s/./*/g if $self->{hidden};
1412	$self->{layout}->set_text ("$text ");	1707	$self->{layout}->set_text ("$text ");
		1708	delete $self->{req_h};
1413		1709
1414	$self->emit (changed => $self->{text});	1710	$self->_emit (changed => $self->{text});
		1711
		1712	$self->realloc;
		1713	$self->update;
1415	}	1714	}
1416		1715
1417	sub set_text {	1716	sub set_text {
1418	my ($self, $text) = @_;	1717	my ($self, $text) = @_;
1419		1718
1420	$self->{cursor} = length $text;	1719	$self->{cursor} = length $text;
1421	$self->_set_text ($text);	1720	$self->_set_text ($text);
1422	$self->check_size;
1423	$self->update;
1424	}	1721	}
1425		1722
1426	sub get_text {	1723	sub get_text {
1427	$_[0]{text}	1724	$_[0]{text}
1428	}	1725	}
…		…
1431	my ($self) = @_;	1728	my ($self) = @_;
1432		1729
1433	my ($w, $h) = $self->SUPER::size_request;	1730	my ($w, $h) = $self->SUPER::size_request;
1434		1731
1435	($w + 1, $h) # add 1 for cursor	1732	($w + 1, $h) # add 1 for cursor
1436	}
1437
1438	sub size_allocate {
1439	my ($self, $w, $h) = @_;
1440
1441	$self->_set_text (delete $self->{text});#d# don't check for == inside _set_text
1442	}	1733	}
1443		1734
1444	sub key_down {	1735	sub key_down {
1445	my ($self, $ev) = @_;	1736	my ($self, $ev) = @_;
1446		1737
…		…
1448	my $sym = $ev->{sym};	1739	my $sym = $ev->{sym};
1449	my $uni = $ev->{unicode};	1740	my $uni = $ev->{unicode};
1450		1741
1451	my $text = $self->get_text;	1742	my $text = $self->get_text;
1452		1743
1453	if ($sym == 8) {	1744	if ($uni == 8) {
1454	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};	1745	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};
1455	} elsif ($sym == 127) {	1746	} elsif ($uni == 127) {
1456	substr $text, $self->{cursor}, 1, "";	1747	substr $text, $self->{cursor}, 1, "";
1457	} elsif ($sym == CFClient::SDLK_LEFT) {	1748	} elsif ($sym == CFClient::SDLK_LEFT) {
1458	--$self->{cursor} if $self->{cursor};	1749	--$self->{cursor} if $self->{cursor};
1459	} elsif ($sym == CFClient::SDLK_RIGHT) {	1750	} elsif ($sym == CFClient::SDLK_RIGHT) {
1460	++$self->{cursor} if $self->{cursor} < length $self->{text};	1751	++$self->{cursor} if $self->{cursor} < length $self->{text};
1461	} elsif ($sym == CFClient::SDLK_HOME) {	1752	} elsif ($sym == CFClient::SDLK_HOME) {
1462	$self->{cursor} = 0;	1753	$self->{cursor} = 0;
1463	} elsif ($sym == CFClient::SDLK_END) {	1754	} elsif ($sym == CFClient::SDLK_END) {
1464	$self->{cursor} = length $text;	1755	$self->{cursor} = length $text;
1465	} elsif ($sym == 27) {	1756	} elsif ($uni == 27) {
1466	$self->emit ('escape');	1757	$self->_emit ('escape');
1467	} elsif ($uni) {	1758	} elsif ($uni) {
1468	substr $text, $self->{cursor}++, 0, chr $uni;	1759	substr $text, $self->{cursor}++, 0, chr $uni;
		1760	} else {
		1761	return 0;
1469	}	1762	}
1470		1763
1471	$self->_set_text ($text);	1764	$self->_set_text ($text);
1472	$self->update;	1765
		1766	$self->realloc;
		1767
		1768	1
1473	}	1769	}
1474		1770
1475	sub focus_in {	1771	sub focus_in {
1476	my ($self) = @_;	1772	my ($self) = @_;
1477		1773
…		…
1492	utf8::encode $text;	1788	utf8::encode $text;
1493	$self->{cursor} = length substr $text, 0, $idx;	1789	$self->{cursor} = length substr $text, 0, $idx;
1494		1790
1495	$self->_set_text ($self->{text});	1791	$self->_set_text ($self->{text});
1496	$self->update;	1792	$self->update;
		1793
		1794	1
1497	}	1795	}
1498		1796
1499	sub mouse_motion {	1797	sub mouse_motion {
1500	my ($self, $ev, $x, $y) = @_;	1798	my ($self, $ev, $x, $y) = @_;
1501	# 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
1502	}	1802	}
1503		1803
1504	sub _draw {	1804	sub _draw {
1505	my ($self) = @_;	1805	my ($self) = @_;
1506		1806
1507	local $self->{fg} = $self->{fg};	1807	local $self->{fg} = $self->{fg};
1508		1808
1509	if ($FOCUS == $self) {	1809	if ($FOCUS == $self) {
1510	glColor @{$self->{active_bg}};	1810	glColor_premultiply @{$self->{active_bg}};
1511	$self->{fg} = $self->{active_fg};	1811	$self->{fg} = $self->{active_fg};
1512	} else {	1812	} else {
1513	glColor @{$self->{bg}};	1813	glColor_premultiply @{$self->{bg}};
1514	}	1814	}
1515		1815
1516	glEnable GL_BLEND;	1816	glEnable GL_BLEND;
1517	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1817	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1518	glBegin GL_QUADS;	1818	glBegin GL_QUADS;
1519	glVertex 0 , 0;	1819	glVertex 0 , 0;
1520	glVertex 0 , $self->{h};	1820	glVertex 0 , $self->{h};
1521	glVertex $self->{w}, $self->{h};	1821	glVertex $self->{w}, $self->{h};
1522	glVertex $self->{w}, 0;	1822	glVertex $self->{w}, 0;
…		…
1557	if ($sym == 13) {	1857	if ($sym == 13) {
1558	unshift @{$self->{history}},	1858	unshift @{$self->{history}},
1559	my $txt = $self->get_text;	1859	my $txt = $self->get_text;
1560	$self->{history_pointer} = -1;	1860	$self->{history_pointer} = -1;
1561	$self->{history_saveback} = '';	1861	$self->{history_saveback} = '';
1562	$self->emit (activate => $txt);	1862	$self->_emit (activate => $txt);
1563	$self->update;	1863	$self->update;
1564		1864
1565	} elsif ($sym == CFClient::SDLK_UP) {	1865	} elsif ($sym == CFClient::SDLK_UP) {
1566	if ($self->{history_pointer} < 0) {	1866	if ($self->{history_pointer} < 0) {
1567	$self->{history_saveback} = $self->get_text;	1867	$self->{history_saveback} = $self->get_text;
…		…
1583	} else {	1883	} else {
1584	$self->set_text ($self->{history_saveback});	1884	$self->set_text ($self->{history_saveback});
1585	}	1885	}
1586		1886
1587	} else {	1887	} else {
1588	$self->SUPER::key_down ($ev);	1888	return $self->SUPER::key_down ($ev)
		1889	}
		1890
1589	}	1891	1
1590
1591	}	1892	}
1592		1893
1593	#############################################################################	1894	#############################################################################
1594		1895
1595	package CFClient::UI::Button;	1896	package CFClient::UI::Button;
…		…
1604		1905
1605	sub new {	1906	sub new {
1606	my $class = shift;	1907	my $class = shift;
1607		1908
1608	$class->SUPER::new (	1909	$class->SUPER::new (
1609	padding => 4,	1910	padding_x => 4,
		1911	padding_y => 4,
1610	fg => [1, 1, 1],	1912	fg => [1, 1, 1],
1611	bg => [1, 1, 1, 0.2],
1612	active_fg => [0, 0, 1],	1913	active_fg => [0, 0, 1],
1613	can_hover => 1,	1914	can_hover => 1,
1614	align => 0,	1915	align => 0,
1615	valign => 0,	1916	valign => 0,
1616	can_events => 1,	1917	can_events => 1,
1617	@_	1918	@_
1618	)	1919	)
1619	}	1920	}
1620		1921
		1922	sub activate { }
		1923
1621	sub button_up {	1924	sub button_up {
1622	my ($self, $ev, $x, $y) = @_;	1925	my ($self, $ev, $x, $y) = @_;
1623		1926
		1927	$self->emit ("activate")
1624	if ($x >= 0 && $x < $self->{w}	1928	if $x >= 0 && $x < $self->{w}
1625	&& $y >= 0 && $y < $self->{h}) {	1929	&& $y >= 0 && $y < $self->{h};
1626	$self->emit ("activate");	1930
1627	}	1931	1
1628	}	1932	}
1629		1933
1630	sub _draw {	1934	sub _draw {
1631	my ($self) = @_;	1935	my ($self) = @_;
1632		1936
1633	local $self->{fg} = $self->{fg};	1937	local $self->{fg} = $GRAB == $self ? $self->{active_fg} : $self->{fg};
1634
1635	if ($GRAB == $self) {
1636	$self->{fg} = $self->{active_fg};
1637	}
1638		1938
1639	glEnable GL_TEXTURE_2D;	1939	glEnable GL_TEXTURE_2D;
1640	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1940	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1641	glColor 0, 0, 0, 1;	1941	glColor 0, 0, 0, 1;
1642		1942
…		…
1661		1961
1662	sub new {	1962	sub new {
1663	my $class = shift;	1963	my $class = shift;
1664		1964
1665	$class->SUPER::new (	1965	$class->SUPER::new (
1666	padding => 2,	1966	padding_x => 2,
		1967	padding_y => 2,
1667	fg => [1, 1, 1],	1968	fg => [1, 1, 1],
1668	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],
1669	state => 0,	1972	state => 0,
1670	can_hover => 1,	1973	can_hover => 1,
1671	@_	1974	@_
1672	)	1975	)
1673	}	1976	}
1674		1977
1675	sub size_request {	1978	sub size_request {
1676	my ($self) = @_;	1979	my ($self) = @_;
1677		1980
1678	($self->{padding} * 2 + 6) x 2	1981	(6) x 2
1679	}	1982	}
1680		1983
1681	sub button_down {	1984	sub button_down {
1682	my ($self, $ev, $x, $y) = @_;	1985	my ($self, $ev, $x, $y) = @_;
1683		1986
1684	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	1987	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1685	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	1988	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1686	$self->{state} = !$self->{state};	1989	$self->{state} = !$self->{state};
1687	$self->emit (changed => $self->{state});	1990	$self->_emit (changed => $self->{state});
		1991	} else {
		1992	return 0
		1993	}
		1994
1688	}	1995	1
1689	}	1996	}
1690		1997
1691	sub _draw {	1998	sub _draw {
1692	my ($self) = @_;	1999	my ($self) = @_;
1693		2000
1694	$self->SUPER::_draw;	2001	$self->SUPER::_draw;
1695		2002
1696	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	2003	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1697		2004
1698	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;
1699		2008
1700	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	2009	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1701		2010
1702	my $tex = $self->{state} ? $tex[1] : $tex[0];	2011	my $tex = $self->{state} ? $tex[1] : $tex[0];
1703		2012
…		…
1858		2167
1859	my $h1 = $self->{h} * (1 - $ycut1);	2168	my $h1 = $self->{h} * (1 - $ycut1);
1860	my $h2 = $self->{h} * (1 - $ycut2);	2169	my $h2 = $self->{h} * (1 - $ycut2);
1861		2170
1862	glEnable GL_BLEND;	2171	glEnable GL_BLEND;
1863	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;
1864	glEnable GL_TEXTURE_2D;	2174	glEnable GL_TEXTURE_2D;
1865	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2175	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1866		2176
1867	glBindTexture GL_TEXTURE_2D, $t1->{name};	2177	glBindTexture GL_TEXTURE_2D, $t1->{name};
1868	glBegin GL_QUADS;	2178	glBegin GL_QUADS;
…		…
1957	qw(s1_slider.png s1_slider_bg.png);	2267	qw(s1_slider.png s1_slider_bg.png);
1958		2268
1959	sub new {	2269	sub new {
1960	my $class = shift;	2270	my $class = shift;
1961		2271
1962	# range [value, low, high, page]	2272	# range [value, low, high, page, unit]
1963		2273
1964	# TODO: 0-width page	2274	# TODO: 0-width page
1965	# TODO: req_w/h are wrong with vertical	2275	# TODO: req_w/h are wrong with vertical
1966	# TODO: calculations are off	2276	# TODO: calculations are off
1967	my $self = $class->SUPER::new (	2277	my $self = $class->SUPER::new (
1968	fg => [1, 1, 1],	2278	fg => [1, 1, 1],
1969	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],
1970	range => [0, 0, 100, 10],	2282	range => [0, 0, 100, 10, 0],
1971	req_w => $::WIDTH / 80,	2283	min_w => $::WIDTH / 80,
1972	req_h => $::WIDTH / 80,	2284	min_h => $::WIDTH / 80,
1973	vertical => 0,	2285	vertical => 0,
1974	can_hover => 1,	2286	can_hover => 1,
1975	inner_pad => 5,	2287	inner_pad => 0.02,
1976	@_	2288	@_
1977	);	2289	);
1978		2290
		2291	$self->set_value ($self->{range}[0]);
		2292	$self->update;
		2293
1979	$self	2294	$self
1980	}	2295	}
1981		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
1982	sub size_request {	2331	sub size_request {
1983	my ($self) = @_;	2332	my ($self) = @_;
1984		2333
1985	my $w = $self->{req_w};	2334	($self->{req_w}, $self->{req_h})
1986	my $h = $self->{req_h};
1987
1988	$self->{vertical} ? ($h, $w) : ($w, $h)
1989	}	2335	}
1990		2336
1991	sub button_down {	2337	sub button_down {
1992	my ($self, $ev, $x, $y) = @_;	2338	my ($self, $ev, $x, $y) = @_;
1993		2339
1994	$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
1995	$self->mouse_motion ($ev, $x, $y);	2344	$self->mouse_motion ($ev, $x, $y)
1996	}	2345	}
1997		2346
1998	sub mouse_motion {	2347	sub mouse_motion {
1999	my ($self, $ev, $x, $y) = @_;	2348	my ($self, $ev, $x, $y) = @_;
2000		2349
2001	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
2002	my ($value, $lo, $hi, $page) = @{$self->{range}};	2378	my ($value, $lo, $hi, $page) = @{$self->{range}};
		2379	my $range = ($hi - $page - $lo) || 1e-100;
2003		2380
2004	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});	2381	my $knob_w = List::Util::min 1, $page / ($hi - $lo) || 0.1;
2005		2382
2006	my $inner_pad_px = $self->_calc_inner_pad_px ($w);	2383	$self->{offset} = List::Util::max $self->{inner_pad}, $knob_w * 0.5;
2007	my $inner_w = $w - $inner_pad_px * 2; # * 2 for left & right	2384	$self->{scale} = 1 - 2 * $self->{offset} || 1e-100;
2008		2385
2009	$x -= $inner_pad_px; # substract the padding	2386	$value = ($value - $lo) / $range;
2010	$x = $x * ($hi - $lo) / $inner_w + $lo;	2387	$value = $value * $self->{scale} + $self->{offset};
2011	$x = $lo if $x < $lo;
2012	$x = $hi - $page if $x > $hi - $page;
2013	$self->{range}[0] = $x;
2014		2388
2015	$self->emit (changed => $x);	2389	$self->{knob_x} = $value - $knob_w * 0.5;
2016	$self->update;	2390	$self->{knob_w} = $knob_w;
2017	}	2391	}
2018	}
2019
2020	# the inner_* stuff is for generating a padding for the slider handle,
2021	# so that the handle doesn't leave the texture. This calculation isn't 100%
2022	# correct propably, but it does the job for now
2023	sub _calc_inner_pad_px {
2024	my ($self, $w) = @_;
2025	($w / 100) * $self->{inner_pad} # % to pixels
2026	}
2027
2028	sub _draw {
2029	my ($self) = @_;
2030		2392
2031	$self->SUPER::_draw ();	2393	$self->SUPER::_draw ();
2032		2394
2033	my ($w, $h) = @$self{qw(w h)};	2395	glScale $self->{w}, $self->{h};
2034		2396
2035	if ($self->{vertical}) {	2397	if ($self->{vertical}) {
2036	# draw a vertical slider like a rotated horizontal slider	2398	# draw a vertical slider like a rotated horizontal slider
2037		2399
		2400	glTranslate 1, 0, 0;
2038	glRotate 90, 0, 0, 1;	2401	glRotate 90, 0, 0, 1;
2039	glTranslate 0, -$self->{w}, 0;
2040
2041	($w, $h) = ($h, $w);
2042	}	2402	}
2043		2403
2044	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};	2404	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};
2045	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};	2405	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};
2046		2406
2047	my ($value, $lo, $hi, $page) = @{$self->{range}};
2048
2049	$hi = $value + 1 if $lo == $hi;
2050
2051	my $inner_pad_px = $self->_calc_inner_pad_px ($w);
2052	my $inner_w = $w - $inner_pad_px * 2; # * 2 for left & right
2053
2054	$page = int $page * $inner_w / ($hi - $lo);
2055	$value = int +($value - $lo) * $inner_w / ($hi - $lo);
2056
2057	$w -= $page;
2058	$page &= ~1;
2059	glTranslate $page * 0.5, 0, 0;
2060	$page ||= 2;
2061
2062	my $knob_a = $inner_pad_px + ($value - $page * 0.5);
2063	my $knob_b = $inner_pad_px + ($value + $page * 0.5);
2064
2065	glEnable GL_TEXTURE_2D;	2407	glEnable GL_TEXTURE_2D;
2066	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2408	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2067		2409
2068	# draw background	2410	# draw background
2069	$tex[1]->draw_quad_alpha (0, 0, $w, $h);	2411	$tex[1]->draw_quad_alpha (0, 0, 1, 1);
2070		2412
2071	# draw handle	2413	# draw handle
2072	$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);
2073		2415
2074	glDisable GL_TEXTURE_2D;	2416	glDisable GL_TEXTURE_2D;
2075	}	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 (@_) }
2076		2459
2077	#############################################################################	2460	#############################################################################
2078		2461
2079	package CFClient::UI::TextView;	2462	package CFClient::UI::TextView;
2080		2463
…		…
2110		2493
2111	$self->{fontsize} = $fontsize;	2494	$self->{fontsize} = $fontsize;
2112	$self->reflow;	2495	$self->reflow;
2113	}	2496	}
2114		2497
2115	sub text_height {
2116	my ($self, $text) = @_;
2117
2118	my $layout = $self->{layout};
2119
2120	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
2121	$layout->set_width ($self->{children}[0]{w});
2122	$layout->set_markup ($text);
2123
2124	($layout->size)[1]
2125	}
2126
2127	sub reflow {
2128	my ($self) = @_;
2129
2130	$self->{need_reflow}++;
2131	$self->update;
2132	}
2133
2134	sub size_allocate {	2498	sub size_allocate {
2135	my ($self, $w, $h) = @_;	2499	my ($self, $w, $h) = @_;
2136		2500
2137	$self->SUPER::size_allocate ($w, $h);	2501	$self->SUPER::size_allocate ($w, $h);
2138		2502
…		…
2141	$self->{layout}->set_width ($self->{children}[0]{w});	2505	$self->{layout}->set_width ($self->{children}[0]{w});
2142		2506
2143	$self->reflow;	2507	$self->reflow;
2144	}	2508	}
2145		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
2146	sub add_paragraph {	2544	sub add_paragraph {
2147	my ($self, $color, $text) = @_;	2545	my ($self, $color, $text, $indent) = @_;
2148		2546
2149	#TODO: intelligently "reformat" paragraph	2547	for my $line (split /\n/, $text) {
2150		2548	my ($w, $h) = $self->text_size ($line);
2151	my $height = $self->text_height ($text);
2152
2153	$self->{height} += $height;	2549	$self->{height} += $h;
		2550	push @{$self->{par}}, [$w + $indent, $h, $color, $indent, $line];
		2551	}
2154		2552
2155	push @{$self->{par}}, [$height, $color, $text];
2156
2157	$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]);
2158	$self->{children}[1]->update;
2159	}	2554	}
2160		2555
2161	sub update {	2556	sub update {
2162	my ($self) = @_;	2557	my ($self) = @_;
2163		2558
…		…
2165		2560
2166	return unless $self->{h} > 0;	2561	return unless $self->{h} > 0;
2167		2562
2168	delete $self->{texture};	2563	delete $self->{texture};
2169		2564
2170	$ROOT->on_refresh ($self, sub {	2565	$ROOT->on_post_alloc ($self, sub {
		2566	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
		2567
2171	if (delete $self->{need_reflow}) {	2568	if (delete $self->{need_reflow}) {
2172	my $height = 0;	2569	my $height = 0;
2173		2570
2174	$height += $_->[0] = $self->text_height ($_->[2])	2571	my $layout = $self->{layout};
		2572
		2573	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2574
2175	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	}
2176		2586
2177	$self->{height} = $height;	2587	$self->{height} = $height;
2178		2588
2179	$self->{children}[1]{range} = [$height - $self->{h}, 0, $height, $self->{h}];	2589	$self->{children}[1]->set_range ([$height, 0, $height, $H, 1]);
2180		2590
2181	delete $self->{texture};	2591	delete $self->{texture};
2182	}	2592	}
2183		2593
2184	$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 {
2185	glClearColor 0, 0, 0, 0;	2595	glClearColor 0, 0, 0, 0;
2186	glClear GL_COLOR_BUFFER_BIT;	2596	glClear GL_COLOR_BUFFER_BIT;
2187		2597
2188	glEnable GL_TEXTURE_2D;
2189	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2190
2191	my $top = int $self->{children}[1]{range}[0];	2598	my $top = int $self->{children}[1]{range}[0];
2192		2599
2193	my $y0 = $top;	2600	my $y0 = $top;
2194	my $y1 = $top + $self->{h};	2601	my $y1 = $top + $H;
2195		2602
2196	my $y = 0;	2603	my $y = 0;
2197		2604
2198	my $layout = $self->{layout};	2605	my $layout = $self->{layout};
2199		2606
2200	$layout->set_font ($self->{font}) if $self->{font};	2607	$layout->set_font ($self->{font}) if $self->{font};
2201		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
2202	for my $par (@{$self->{par}}) {	2613	for my $par (@{$self->{par}}) {
2203	my $h = $par->[0];	2614	my $h = $par->[1];
2204		2615
2205	if ($y0 < $y + $h && $y < $y1) {	2616	if ($y0 < $y + $h && $y < $y1) {
2206	$layout->set_foreground (@{ $par->[1] });	2617	$layout->set_foreground (@{ $par->[2] });
		2618	$layout->set_width ($W - $par->[3]);
2207	$layout->set_markup ($par->[2]);	2619	$layout->set_markup ($par->[4]);
2208		2620
2209	my ($W, $H) = $layout->size;	2621	my ($w, $h, $data, $format, $internalformat) = $layout->render;
2210	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;
2211	}	2625	}
2212		2626
2213	$y += $h;	2627	$y += $h;
2214	}	2628	}
2215		2629
2216	glDisable GL_TEXTURE_2D;	2630	glDisable GL_BLEND;
2217	};	2631	};
2218	});	2632	});
2219	}	2633	}
2220		2634
2221	sub _draw {	2635	sub _draw {
2222	my ($self) = @_;	2636	my ($self) = @_;
2223		2637
2224	glEnable GL_TEXTURE_2D;	2638	glEnable GL_TEXTURE_2D;
2225	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2639	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2226	glColor 1, 1, 1, 1;	2640	glColor 0, 0, 0, 1;
2227	$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});
2228	glDisable GL_TEXTURE_2D;	2642	glDisable GL_TEXTURE_2D;
2229		2643
2230	$self->{children}[1]->draw;	2644	$self->{children}[1]->draw;
2231		2645
…		…
2281		2695
2282	sub new {	2696	sub new {
2283	my $class = shift;	2697	my $class = shift;
2284		2698
2285	my $self = $class->SUPER::new (	2699	my $self = $class->SUPER::new (
2286	state => 0,	2700	state => 0,
2287	connect_activate => \&toggle_flopper,	2701	on_activate => \&toggle_flopper,
2288	@_	2702	@_
2289	);	2703	);
2290		2704
2291	if ($self->{state}) {
2292	$self->{state} = 0;
2293	$self->toggle_flopper;
2294	}
2295
2296	$self	2705	$self
2297	}	2706	}
2298		2707
2299	sub toggle_flopper {	2708	sub toggle_flopper {
2300	my ($self) = @_;	2709	my ($self) = @_;
2301		2710
2302	# TODO: use animation	2711	$self->{other}->toggle_visibility;
2303	if ($self->{state} = !$self->{state}) {
2304	$CFClient::UI::ROOT->add ($self->{other});
2305	$self->{other}->move ($self->coord2global (0, $self->{h}));
2306	$self->emit ("open");
2307	} else {
2308	$CFClient::UI::ROOT->remove ($self->{other});
2309	$self->emit ("close");
2310	}
2311
2312	$self->emit (changed => $self->{state});
2313	}	2712	}
2314		2713
2315	#############################################################################	2714	#############################################################################
2316		2715
2317	package CFClient::UI::Tooltip;	2716	package CFClient::UI::Tooltip;
…		…
2330	}	2729	}
2331		2730
2332	sub set_tooltip_from {	2731	sub set_tooltip_from {
2333	my ($self, $widget) = @_;	2732	my ($self, $widget) = @_;
2334		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
2335	$self->add (new CFClient::UI::Label	2743	$self->add (new CFClient::UI::Label
2336	markup => $widget->{tooltip},	2744	markup => $tooltip,
2337	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,	2745	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2338	fontsize => 0.8,	2746	fontsize => 0.8,
2339	fg => [0, 0, 0, 1],	2747	fg => [0, 0, 0, 1],
		2748	ellipsise => 0,
2340	font => ($widget->{tooltip_font} || $::FONT_PROP),	2749	font => ($widget->{tooltip_font} || $::FONT_PROP),
2341	);	2750	);
2342	}	2751	}
2343		2752
2344	sub size_request {	2753	sub size_request {
2345	my ($self) = @_;	2754	my ($self) = @_;
…		…
2351		2760
2352	sub size_allocate {	2761	sub size_allocate {
2353	my ($self, $w, $h) = @_;	2762	my ($self, $w, $h) = @_;
2354		2763
2355	$self->SUPER::size_allocate ($w - 4, $h - 4);	2764	$self->SUPER::size_allocate ($w - 4, $h - 4);
		2765	}
		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	});
2356	}	2783	}
2357		2784
2358	sub _draw {	2785	sub _draw {
2359	my ($self) = @_;	2786	my ($self) = @_;
2360		2787
…		…
2377	glVertex $w, $h;	2804	glVertex $w, $h;
2378	glVertex $w, 0;	2805	glVertex $w, 0;
2379	glEnd;	2806	glEnd;
2380		2807
2381	glTranslate 2 - 0.375, 2 - 0.375;	2808	glTranslate 2 - 0.375, 2 - 0.375;
		2809
2382	$self->SUPER::_draw;	2810	$self->SUPER::_draw;
2383	}	2811	}
2384		2812
2385	#############################################################################	2813	#############################################################################
2386		2814
…		…
2391	use CFClient::OpenGL;	2819	use CFClient::OpenGL;
2392		2820
2393	sub new {	2821	sub new {
2394	my $class = shift;	2822	my $class = shift;
2395		2823
2396	$class->SUPER::new (	2824	my $self = $class->SUPER::new (
2397	aspect => 1,	2825	aspect => 1,
		2826	can_events => 0,
2398	@_,	2827	@_,
2399	)	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
2400	}	2845	}
2401		2846
2402	sub size_request {	2847	sub size_request {
2403	(32, 8)	2848	(32, 8)
2404	}	2849	}
2405		2850
		2851	sub update {
		2852	my ($self) = @_;
		2853
		2854	return unless $self->{visible};
		2855
		2856	$self->SUPER::update;
		2857	}
		2858
2406	sub _draw {	2859	sub _draw {
2407	my ($self) = @_;	2860	my ($self) = @_;
2408		2861
2409	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
2410	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$self->{face}]];	2873	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
2411		2874
2412	# TODO animation
2413	if ($tex) {	2875	if ($tex) {
2414	glEnable GL_TEXTURE_2D;	2876	glEnable GL_TEXTURE_2D;
2415	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2877	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2416	glColor 1, 1, 1, 1;	2878	glColor 0, 0, 0, 1;
2417	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});	2879	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
2418	glDisable GL_TEXTURE_2D;	2880	glDisable GL_TEXTURE_2D;
2419	}	2881	}
2420	}	2882	}
2421		2883
		2884	sub DESTROY {
		2885	my ($self) = @_;
		2886
		2887	$self->{timer}->cancel
		2888	if $self->{timer};
		2889
		2890	$self->SUPER::DESTROY;
		2891	}
		2892
2422	#############################################################################	2893	#############################################################################
2423		2894
2424	package CFClient::UI::InventoryItem;	2895	package CFClient::UI::Buttonbar;
2425		2896
2426	our @ISA = CFClient::UI::HBox::;	2897	our @ISA = CFClient::UI::HBox::;
2427		2898
2428	sub new {	2899	# TODO: should actualyl wrap buttons and other goodies.
2429	my $class = shift;
2430
2431	my %args = @_;
2432
2433	my $item = delete $args{item};
2434
2435	my $desc = $item->{nrof} < 2
2436	? $item->{name}
2437	: "$item->{nrof} $item->{name_pl}";
2438
2439
2440	my $self = $class->SUPER::new (
2441	can_hover => 1,
2442	can_events => 1,
2443	tooltip => (CFClient::UI::Label->escape ($desc)
2444	. "\n<small>leftclick - pick up\nmiddle click - apply\nrightclick - menu</small>"),
2445	connect_button_down => sub {
2446	my ($self, $ev, $x, $y) = @_;
2447
2448	# todo: maybe put examine on 1? but should just be a tooltip :(
2449	if ($ev->{button} == 1) {
2450	$::CONN->send ("move $::CONN->{player}{tag} $item->{tag} 0");
2451	} elsif ($ev->{button} == 2) {
2452	$::CONN->send ("apply $item->{tag}");
2453	} elsif ($ev->{button} == 3) {
2454	CFClient::UI::Menu->new (
2455	items => [
2456	["examine", sub { $::CONN->send ("examine $item->{tag}") }],
2457	[
2458	$item->{flags} & Crossfire::Protocol::F_LOCKED ? "lock" : "unlock",
2459	sub { $::CONN->send ("lock $item->{tag}") },
2460	],
2461	["mark", sub { $::CONN->send ("mark $item->{tag}") }],
2462	["apply", sub { $::CONN->send ("apply $item->{tag}") }],
2463	["drop", sub { $::CONN->send ("move 0 $item->{tag} 0") }],
2464	],
2465	)->popup ($ev);
2466	}
2467
2468	1
2469	},
2470	%args
2471	);
2472
2473	$self->add (new CFClient::UI::Face
2474	can_events => 0,
2475	face => $item->{face},
2476	anim => $item->{anim},
2477	animspeed => $item->{animspeed},
2478	);
2479
2480	$self->add (new CFClient::UI::Label
2481	can_events => 0,
2482	text => $desc,
2483	);
2484
2485	$self
2486	}
2487
2488	#############################################################################
2489
2490	package CFClient::UI::Inventory;
2491
2492	our @ISA = CFClient::UI::ScrolledWindow::;
2493
2494	sub new {
2495	my $class = shift;
2496
2497	my $self = $class->SUPER::new (
2498	scrolled => (new CFClient::UI::VBox),
2499	@_,
2500	);
2501
2502	$self
2503	}
2504
2505	sub set_items {
2506	my ($self, $items) = @_;
2507
2508	$self->{scrolled}->clear;
2509	return unless $items;
2510
2511	my @items = sort { $a->{type} <=> $b->{type} } @$items;
2512
2513	$self->{real_items} = \@items;
2514
2515	for my $item (@items) {
2516	my $desc = $item->{nrof} < 2
2517	? $item->{name}
2518	: "$item->{nrof} $item->{name_pl}";
2519
2520	$self->{scrolled}->add ($item->{widget} ||= new CFClient::UI::InventoryItem item => $item);
2521	}
2522
2523	# $range->{range} = [$self->{pos}, 0, $self->{max_pos}, $page];
2524	}
2525
2526	sub size_request {
2527	my ($self) = @_;
2528	($self->{req_w}, $self->{req_h});
2529	}
2530		2900
2531	#############################################################################	2901	#############################################################################
2532		2902
2533	package CFClient::UI::Menu;	2903	package CFClient::UI::Menu;
2534		2904
…		…
2568		2938
2569	# 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)
2570	sub popup {	2940	sub popup {
2571	my ($self, $ev) = @_;	2941	my ($self, $ev) = @_;
2572		2942
2573	$self->emit ("popdown");	2943	$self->_emit ("popdown");
2574		2944
2575	# maybe save $GRAB? must be careful about events...	2945	# maybe save $GRAB? must be careful about events...
2576	$GRAB = $self;	2946	$GRAB = $self;
2577	$self->{button} = $ev->{button};	2947	$self->{button} = $ev->{button};
2578		2948
2579	$self->show;	2949	$self->show;
2580	$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);
2581	}	2951	}
2582		2952
2583	sub mouse_motion {	2953	sub mouse_motion {
2584	my ($self, $ev, $x, $y) = @_;	2954	my ($self, $ev, $x, $y) = @_;
2585		2955
2586	# TODO: should use vbox->find_widget or so	2956	# TODO: should use vbox->find_widget or so
2587	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});	2957	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
2588	$self->{hover} = $self->{item}{$HOVER};	2958	$self->{hover} = $self->{item}{$HOVER};
		2959
		2960	0
2589	}	2961	}
2590		2962
2591	sub button_up {	2963	sub button_up {
2592	my ($self, $ev, $x, $y) = @_;	2964	my ($self, $ev, $x, $y) = @_;
2593		2965
2594	if ($ev->{button} == $self->{button}) {	2966	if ($ev->{button} == $self->{button}) {
2595	undef $GRAB;	2967	undef $GRAB;
2596	$self->hide;	2968	$self->hide;
2597		2969
2598	$self->emit ("popdown");	2970	$self->_emit ("popdown");
2599	$self->{hover}[1]->() if $self->{hover};	2971	$self->{hover}[1]->() if $self->{hover};
		2972	} else {
		2973	return 0
		2974	}
		2975
2600	}	2976	1
2601	}	2977	}
2602		2978
2603	#############################################################################	2979	#############################################################################
2604		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
2605	package CFClient::UI::Statusbox;	3089	package CFClient::UI::Statusbox;
2606		3090
2607	our @ISA = CFClient::UI::VBox::;	3091	our @ISA = CFClient::UI::VBox::;
2608		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
2609	sub reorder {	3108	sub reorder {
2610	my ($self) = @_;	3109	my ($self) = @_;
2611	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} };
2612		3116
2613	while (my ($k, $v) = each %{ $self->{item} }) {	3117	while (my ($k, $v) = each %{ $self->{item} }) {
2614	delete $self->{item}{$k} if $v->{timeout} < $NOW;	3118	delete $self->{item}{$k} if $v->{timeout} < $NOW;
2615	}	3119	}
2616		3120
…		…
2619	my @items = sort {	3123	my @items = sort {
2620	$a->{pri} <=> $b->{pri}	3124	$a->{pri} <=> $b->{pri}
2621	or $b->{id} <=> $a->{id}	3125	or $b->{id} <=> $a->{id}
2622	} values %{ $self->{item} };	3126	} values %{ $self->{item} };
2623		3127
		3128	$self->{timer}->interval (1);
		3129
2624	my $count = 10 + 1;	3130	my $count = 10 + 1;
2625	for my $item (@items) {	3131	for my $item (@items) {
2626	last unless --$count;	3132	last unless --$count;
2627		3133
2628	push @widgets, $item->{label} ||= do {	3134	my $label = $item->{label} ||= do {
2629	# TODO: doesn't handle markup well (read as: at all)	3135	# TODO: doesn't handle markup well (read as: at all)
2630	my $short = $item->{count} > 1	3136	my $short = $item->{count} > 1
2631	? "<b>$item->{count} ×</b> $item->{text}"	3137	? "<b>$item->{count} ×</b> $item->{text}"
2632	: $item->{text};	3138	: $item->{text};
2633		3139
2634	for ($short) {	3140	for ($short) {
2635	s/^\s+//;	3141	s/^\s+//;
2636	s/\012.*/…/s;	3142	s/\s+/ /g;
2637	my $len = int 30 / $item->{fontsize};
2638	substr $_, $len, length, "…" if $len < length;
2639	}	3143	}
2640		3144
2641	new CFClient::UI::Label	3145	new CFClient::UI::Label
2642	markup => $short,	3146	markup => $short,
2643	tooltip => $item->{tooltip},	3147	tooltip => $item->{tooltip},
2644	tooltip_font => $::FONT_PROP,	3148	tooltip_font => $::FONT_PROP,
2645	tooltip_width => 0.67,	3149	tooltip_width => 0.67,
2646	fontsize => $item->{fontsize},	3150	fontsize => $item->{fontsize} || $self->{fontsize},
2647	color => $item->{color},	3151	max_w => $::WIDTH * 0.44,
		3152	fg => [@{ $item->{fg} }],
2648	can_events => 1,	3153	can_events => 1,
2649	can_hover => 1	3154	can_hover => 1
2650	};	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;
2651	}	3168	}
2652		3169
2653	$self->clear;	3170	$self->clear;
2654	$self->SUPER::add (reverse @widgets);	3171	$self->SUPER::add (reverse @widgets);
2655	}	3172	}
2656		3173
2657	sub add {	3174	sub add {
2658	my ($self, $text, %arg) = @_;	3175	my ($self, $text, %arg) = @_;
2659		3176
		3177	$text =~ s/^\s+//;
		3178	$text =~ s/\s+$//;
		3179
		3180	return unless $text;
		3181
2660	my $timeout = time + ((delete $arg{timeout}) || 60);	3182	my $timeout = (int time) + ((delete $arg{timeout}) || 60);
2661		3183
2662	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};	3184	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
2663		3185
2664	if (my $item = $self->{item}{$group}) {	3186	if (my $item = $self->{item}{$group}) {
2665	if ($item->{text} eq $text) {	3187	if ($item->{text} eq $text) {
2666	$item->{count}++;	3188	$item->{count}++;
2667	} else {	3189	} else {
2668	$item->{count} = 1;	3190	$item->{count} = 1;
2669	$item->{text} = $item->{tooltip} = $text;	3191	$item->{text} = $item->{tooltip} = $text;
2670	}	3192	}
		3193	$item->{id} = ++$self->{id};
2671	$item->{timeout} = $timeout;	3194	$item->{timeout} = $timeout;
2672	delete $item->{label};	3195	delete $item->{label};
2673	} else {	3196	} else {
2674	$self->{item}{$group} = {	3197	$self->{item}{$group} = {
2675	id => ++$self->{id},	3198	id => ++$self->{id},
2676	text => $text,	3199	text => $text,
2677	timeout => $timeout,	3200	timeout => $timeout,
2678	tooltip => $text,	3201	tooltip => $text,
2679	fontsize => 0.8,
2680	color => [0.8, 0.8, 0.8, 0.8],	3202	fg => [0.8, 0.8, 0.8, 0.8],
2681	pri => 0,	3203	pri => 0,
2682	count => 1,	3204	count => 1,
2683	%arg,	3205	%arg,
2684	};	3206	};
2685	}	3207	}
2686		3208
2687	$self->reorder;	3209	$self->reorder;
2688	}	3210	}
2689		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
2690	#############################################################################	3230	#############################################################################
2691		3231
2692	package CFClient::UI::Root;	3232	package CFClient::UI::Inventory;
2693		3233
2694	our @ISA = CFClient::UI::Container::;	3234	our @ISA = CFClient::UI::ScrolledWindow::;
2695
2696	use CFClient::OpenGL;
2697		3235
2698	sub new {	3236	sub new {
2699	my $class = shift;	3237	my $class = shift;
2700		3238
2701	$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 => [],
2702	@_,	3481	@_,
2703	)	3482	)
2704	}	3483	}
2705		3484
2706	sub configure {	3485	# XXX: Do sorting? Argl...
2707	my ($self, $x, $y, $w, $h) = @_;	3486	sub add_spell {
2708
2709	$self->{w} = $w;
2710	$self->{h} = $h;
2711	}
2712
2713	sub check_size {
2714	my ($self) = @_;	3487	my ($self, $spell) = @_;
		3488	$self->{spells}->{$spell->{name}} = $spell;
2715		3489
2716	$self->size_allocate ($self->{w}, $self->{h})	3490	$self->add (0, $self->{tbl_idx}, new CFClient::UI::Face
2717	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
2718	}	3546	}
2719		3547
2720	sub size_request {	3548	sub size_request {
2721	my ($self) = @_;	3549	my ($self) = @_;
2722		3550
2723	($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
2724	}	3566	}
2725		3567
2726	sub size_allocate {	3568	sub size_allocate {
2727	my ($self, $w, $h) = @_;	3569	my ($self, $w, $h) = @_;
2728		3570
2729	my $old_w = $self->{old_w};
2730	my $old_h = $self->{old_h};
2731
2732	if ($old_w && $old_h) {
2733	for my $child ($self->children) {
2734	$child->{x} = int 0.5 + $child->{x} * $w / $old_w;
2735	$child->{w} = int 0.5 + $child->{w} * $w / $old_w;
2736	$child->{req_w} = int 0.5 + $child->{req_w} * $w / $old_w if exists $child->{req_w};
2737	$child->{user_w} = int 0.5 + $child->{user_w} * $w / $old_w if exists $child->{user_w};
2738	$child->{y} = int 0.5 + $child->{y} * $h / $old_h;
2739	$child->{h} = int 0.5 + $child->{h} * $h / $old_h;
2740	$child->{req_h} = int 0.5 + $child->{req_h} * $h / $old_h if exists $child->{req_h};
2741	$child->{user_h} = int 0.5 + $child->{user_h} * $h / $old_h if exists $child->{user_h};
2742	}
2743	}
2744
2745	for my $child ($self->children) {	3571	for my $child ($self->children) {
2746	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)};
2747		3573
2748	$X = List::Util::max 0, List::Util::min $w - $W, $X;	3574	$X = $child->{force_x} if exists $child->{force_x};
2749	$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
2750	$child->configure ($X, $Y, $W, $H);	3580	$child->configure ($X, $Y, $W, $H);
2751	}	3581	}
2752
2753	$self->{old_w} = $w;
2754	$self->{old_h} = $h;
2755	}	3582	}
2756		3583
2757	sub coord2local {	3584	sub coord2local {
2758	my ($self, $x, $y) = @_;	3585	my ($self, $x, $y) = @_;
2759		3586
…		…
2767	}	3594	}
2768		3595
2769	sub update {	3596	sub update {
2770	my ($self) = @_;	3597	my ($self) = @_;
2771		3598
2772	$self->check_size;
2773	$::WANT_REFRESH++;	3599	$::WANT_REFRESH++;
2774	}	3600	}
2775		3601
2776	sub add {	3602	sub add {
2777	my ($self, $child) = @_;	3603	my ($self, @children) = @_;
2778		3604
2779	# integerise window positions	3605	$_->{is_toplevel} = 1
2780	$child->{x} = int $child->{x};	3606	for @children;
2781	$child->{y} = int $child->{y};
2782		3607
2783	$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	}
2784	}	3624	}
2785		3625
2786	sub on_refresh {	3626	sub on_refresh {
2787	my ($self, $id, $cb) = @_;	3627	my ($self, $id, $cb) = @_;
2788		3628
2789	$self->{refresh_hook}{$id} = $cb;	3629	$self->{refresh_hook}{$id} = $cb;
2790	}	3630	}
2791		3631
		3632	sub on_post_alloc {
		3633	my ($self, $id, $cb) = @_;
		3634
		3635	$self->{post_alloc_hook}{$id} = $cb;
		3636	}
		3637
2792	sub draw {	3638	sub draw {
2793	my ($self) = @_;	3639	my ($self) = @_;
2794
2795	if ($self->{check_size}) {
2796	my @queue = ([], []);
2797
2798	for (;;) {
2799	if ($self->{check_size}) {
2800	# heuristic: check containers last
2801	push @{ $queue[ ! ! $_->isa ("CFClient::UI::Container") ] }, $_
2802	for values %{delete $self->{check_size}}
2803	}
2804
2805	my $widget = (pop @{ $queue[0] }) || (pop @{ $queue[1] }) || last;
2806
2807	my ($w, $h) = $widget->{user_w} && $widget->{user_h}
2808	? @$widget{qw(user_w user_h)}
2809	: $widget->size_request;
2810
2811	if (delete $widget->{force_alloc}
2812	or $w != $widget->{req_w} or $h != $widget->{req_h}) {
2813	Carp::confess "$widget: size_request is negative" if $w < 0 || $h < 0;#d#
2814
2815	$widget->{req_w} = $w;
2816	$widget->{req_h} = $h;
2817
2818	$self->{size_alloc}{$widget} = [$widget, $widget->{w} || $w, $widget->{h} || $h];
2819
2820	$widget->{parent}->check_size
2821	if $widget->{parent};
2822	}
2823	}
2824	}
2825
2826	while ($self->{size_alloc}) {
2827	for (values %{delete $self->{size_alloc}}) {
2828	my ($widget, $w, $h) = @$_;
2829
2830	$w = 0 if $w < 0;
2831	$h = 0 if $h < 0;
2832
2833	$widget->{w} = $w;
2834	$widget->{h} = $h;
2835	$widget->size_allocate ($w, $h);
2836	$widget->emit (size_allocate => $w, $h);
2837	}
2838	}
2839		3640
2840	while ($self->{refresh_hook}) {	3641	while ($self->{refresh_hook}) {
2841	$_->()	3642	$_->()
2842	for values %{delete $self->{refresh_hook}};	3643	for values %{delete $self->{refresh_hook}};
2843	}	3644	}
2844		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
2845	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3738	glViewport 0, 0, $::WIDTH, $::HEIGHT;
2846	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3739	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
2847	glClear GL_COLOR_BUFFER_BIT;	3740	glClear GL_COLOR_BUFFER_BIT;
2848		3741
2849	glMatrixMode GL_PROJECTION;	3742	glMatrixMode GL_PROJECTION;
2850	glLoadIdentity;	3743	glLoadIdentity;
2851	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000 , 10000;	3744	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
2852	glMatrixMode GL_MODELVIEW;	3745	glMatrixMode GL_MODELVIEW;
2853	glLoadIdentity;	3746	glLoadIdentity;
2854		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
2855	$self->_draw;	3755	$self->_draw;
2856	}	3756	}
2857		3757
2858	#############################################################################	3758	#############################################################################
2859		3759
2860	package CFClient::UI;	3760	package CFClient::UI;
2861		3761
2862	$ROOT = new CFClient::UI::Root;	3762	$ROOT = new CFClient::UI::Root;
2863	$TOOLTIP = new CFClient::UI::Tooltip;	3763	$TOOLTIP = new CFClient::UI::Tooltip z => 900;
2864		3764
2865	1	3765	1
2866		3766

Diff Legend

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