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

Diff Legend

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