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

Diff Legend

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