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.292 by root, Tue Jun 6 03:02:15 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
…		…
2111		2498
2112	$self->{fontsize} = $fontsize;	2499	$self->{fontsize} = $fontsize;
2113	$self->reflow;	2500	$self->reflow;
2114	}	2501	}
2115		2502
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 {	2503	sub size_allocate {
2136	my ($self, $w, $h) = @_;	2504	my ($self, $w, $h) = @_;
2137		2505
2138	$self->SUPER::size_allocate ($w, $h);	2506	$self->SUPER::size_allocate ($w, $h);
2139		2507
2140	$self->{layout}->set_font ($self->{font}) if $self->{font};	2508	$self->{layout}->set_font ($self->{font}) if $self->{font};
2141	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	2509	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
2142	$self->{layout}->set_width ($self->{children}[0]{w});	2510	$self->{layout}->set_width ($self->{children}[0]{w});
		2511	$self->{layout}->set_indent (-$self->{fontsize} * $::FONTSIZE * 4);
2143		2512
2144	$self->reflow;	2513	$self->reflow;
2145	}	2514	}
2146		2515
		2516	sub text_size {
		2517	my ($self, $text, $indent) = @_;
		2518
		2519	my $layout = $self->{layout};
		2520
		2521	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2522	$layout->set_width ($self->{children}[0]{w} - $indent);
		2523	$layout->set_indent (-$self->{fontsize} * $::FONTSIZE * 4);
		2524	$layout->set_markup ($text);
		2525
		2526	$layout->size
		2527	}
		2528
		2529	sub reflow {
		2530	my ($self) = @_;
		2531
		2532	$self->{need_reflow}++;
		2533	$self->update;
		2534	}
		2535
		2536	sub set_offset {
		2537	my ($self, $offset) = @_;
		2538
		2539	# todo: base offset on lines or so, not on pixels
		2540	$self->{children}[1]->set_value ($offset);
		2541	}
		2542
		2543	sub clear {
		2544	my ($self) = @_;
		2545
		2546	$self->{par} = [];
		2547	$self->{height} = 0;
		2548	$self->{children}[1]->set_range ([0, 0, 0, 1, 1]);
		2549	}
		2550
2147	sub add_paragraph {	2551	sub add_paragraph {
2148	my ($self, $color, $text) = @_;	2552	my ($self, $color, $text, $indent) = @_;
2149		2553
2150	#TODO: intelligently "reformat" paragraph	2554	for my $line (split /\n/, $text) {
2151		2555	my ($w, $h) = $self->text_size ($line);
2152	my $height = $self->text_height ($text);
2153
2154	$self->{height} += $height;	2556	$self->{height} += $h;
		2557	push @{$self->{par}}, [$w + $indent, $h, $color, $indent, $line];
		2558	}
2155		2559
2156	push @{$self->{par}}, [$height, $color, $text];
2157
2158	$self->{children}[1]{range} = [$self->{height} - $self->{h}, 0, $self->{height}, $self->{h}];	2560	$self->{children}[1]->set_range ([$self->{height}, 0, $self->{height}, $self->{h}, 1]);
2159	$self->{children}[1]->update;
2160	}	2561	}
2161		2562
2162	sub update {	2563	sub update {
2163	my ($self) = @_;	2564	my ($self) = @_;
2164		2565
…		…
2167	return unless $self->{h} > 0;	2568	return unless $self->{h} > 0;
2168		2569
2169	delete $self->{texture};	2570	delete $self->{texture};
2170		2571
2171	$ROOT->on_post_alloc ($self, sub {	2572	$ROOT->on_post_alloc ($self, sub {
		2573	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
		2574
2172	if (delete $self->{need_reflow}) {	2575	if (delete $self->{need_reflow}) {
2173	my $height = 0;	2576	my $height = 0;
2174		2577
2175	$height += $_->[0] = $self->text_height ($_->[2])	2578	my $layout = $self->{layout};
		2579
		2580	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2581
2176	for @{$self->{par}};	2582	for (@{$self->{par}}) {
		2583	if (1 || $_->[0] >= $W) { # TODO: works,but needs reconfigure etc. support
		2584	$layout->set_width ($W - $_->[3]);
		2585	$layout->set_indent (-$self->{fontsize} * $::FONTSIZE * 4);
		2586	$layout->set_markup ($_->[4]);
		2587	my ($w, $h) = $layout->size;
		2588	$_->[0] = $w + $_->[3];
		2589	$_->[1] = $h;
		2590	}
		2591
		2592	$height += $_->[1];
		2593	}
2177		2594
2178	$self->{height} = $height;	2595	$self->{height} = $height;
2179		2596
2180	$self->{children}[1]{range} = [$height - $self->{h}, 0, $height, $self->{h}];	2597	$self->{children}[1]->set_range ([$height, 0, $height, $H, 1]);
2181		2598
2182	delete $self->{texture};	2599	delete $self->{texture};
2183	}	2600	}
2184		2601
2185	$self->{texture} ||= new_from_opengl CFClient::Texture $self->{children}[0]{w}, $self->{children}[0]{h}, sub {	2602	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {
2186	glClearColor 0, 0, 0, 0;	2603	glClearColor 0, 0, 0, 0;
2187	glClear GL_COLOR_BUFFER_BIT;	2604	glClear GL_COLOR_BUFFER_BIT;
2188		2605
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];	2606	my $top = int $self->{children}[1]{range}[0];
2193		2607
2194	my $y0 = $top;	2608	my $y0 = $top;
2195	my $y1 = $top + $self->{h};	2609	my $y1 = $top + $H;
2196		2610
2197	my $y = 0;	2611	my $y = 0;
2198		2612
2199	my $layout = $self->{layout};	2613	my $layout = $self->{layout};
2200		2614
2201	$layout->set_font ($self->{font}) if $self->{font};	2615	$layout->set_font ($self->{font}) if $self->{font};
2202		2616
		2617	glEnable GL_BLEND;
		2618	#TODO# not correct in windows where rgba is forced off
		2619	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
		2620
2203	for my $par (@{$self->{par}}) {	2621	for my $par (@{$self->{par}}) {
2204	my $h = $par->[0];	2622	my $h = $par->[1];
2205		2623
2206	if ($y0 < $y + $h && $y < $y1) {	2624	if ($y0 < $y + $h && $y < $y1) {
2207	$layout->set_foreground (@{ $par->[1] });	2625	$layout->set_foreground (@{ $par->[2] });
		2626	$layout->set_width ($W - $par->[3]);
		2627	$layout->set_indent (-$self->{fontsize} * $::FONTSIZE * 4);
2208	$layout->set_markup ($par->[2]);	2628	$layout->set_markup ($par->[4]);
2209		2629
2210	my ($W, $H) = $layout->size;	2630	my ($w, $h, $data, $format, $internalformat) = $layout->render;
2211	CFClient::Texture->new_from_layout ($layout)->draw_quad_alpha_premultiplied (0, $y - $y0);	2631
		2632	glRasterPos $par->[3], $y - $y0;
		2633	glDrawPixels $w, $h, $format, GL_UNSIGNED_BYTE, $data;
2212	}	2634	}
2213		2635
2214	$y += $h;	2636	$y += $h;
2215	}	2637	}
2216		2638
2217	glDisable GL_TEXTURE_2D;	2639	glDisable GL_BLEND;
2218	};	2640	};
2219	});	2641	});
2220	}	2642	}
2221		2643
2222	sub _draw {	2644	sub _draw {
2223	my ($self) = @_;	2645	my ($self) = @_;
2224		2646
2225	glEnable GL_TEXTURE_2D;	2647	glEnable GL_TEXTURE_2D;
2226	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2648	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2227	glColor 1, 1, 1, 1;	2649	glColor 0, 0, 0, 1;
2228	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});	2650	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});
2229	glDisable GL_TEXTURE_2D;	2651	glDisable GL_TEXTURE_2D;
2230		2652
2231	$self->{children}[1]->draw;	2653	$self->{children}[1]->draw;
2232		2654
…		…
2282		2704
2283	sub new {	2705	sub new {
2284	my $class = shift;	2706	my $class = shift;
2285		2707
2286	my $self = $class->SUPER::new (	2708	my $self = $class->SUPER::new (
2287	state => 0,	2709	state => 0,
2288	connect_activate => \&toggle_flopper,	2710	on_activate => \&toggle_flopper,
2289	@_	2711	@_
2290	);	2712	);
2291		2713
2292	if ($self->{state}) {
2293	$self->{state} = 0;
2294	$self->toggle_flopper;
2295	}
2296
2297	$self	2714	$self
2298	}	2715	}
2299		2716
2300	sub toggle_flopper {	2717	sub toggle_flopper {
2301	my ($self) = @_;	2718	my ($self) = @_;
2302		2719
2303	# TODO: use animation	2720	$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	}	2721	}
2315		2722
2316	#############################################################################	2723	#############################################################################
2317		2724
2318	package CFClient::UI::Tooltip;	2725	package CFClient::UI::Tooltip;
…		…
2331	}	2738	}
2332		2739
2333	sub set_tooltip_from {	2740	sub set_tooltip_from {
2334	my ($self, $widget) = @_;	2741	my ($self, $widget) = @_;
2335		2742
		2743	my $tooltip = $widget->{tooltip};
		2744
		2745	if ($ENV{CFPLUS_DEBUG} & 2) {
		2746	$tooltip .= "\n\n" . (ref $widget) . "\n"
		2747	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"
		2748	. "req $widget->{req_w} $widget->{req_h}\n"
		2749	. "visible $widget->{visible}";
		2750	}
		2751
2336	$self->add (new CFClient::UI::Label	2752	$self->add (new CFClient::UI::Label
2337	markup => $widget->{tooltip},	2753	markup => $tooltip,
2338	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,	2754	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2339	fontsize => 0.8,	2755	fontsize => 0.8,
2340	fg => [0, 0, 0, 1],	2756	fg => [0, 0, 0, 1],
		2757	ellipsise => 0,
2341	font => ($widget->{tooltip_font} || $::FONT_PROP),	2758	font => ($widget->{tooltip_font} || $::FONT_PROP),
2342	);	2759	);
2343	}	2760	}
2344		2761
2345	sub size_request {	2762	sub size_request {
2346	my ($self) = @_;	2763	my ($self) = @_;
…		…
2352		2769
2353	sub size_allocate {	2770	sub size_allocate {
2354	my ($self, $w, $h) = @_;	2771	my ($self, $w, $h) = @_;
2355		2772
2356	$self->SUPER::size_allocate ($w - 4, $h - 4);	2773	$self->SUPER::size_allocate ($w - 4, $h - 4);
		2774	}
		2775
		2776	sub visibility_change {
		2777	my ($self, $visible) = @_;
		2778
		2779	return unless $visible;
		2780
		2781	$self->{root}->on_post_alloc ("move_$self" => sub {
		2782	my $widget = $self->{owner}
		2783	or return;
		2784
		2785	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
		2786
		2787	($x, $y) = $widget->coord2global (-$self->{w}, 0)
		2788	if $x + $self->{w} > $::WIDTH;
		2789
		2790	$self->move_abs ($x, $y);
		2791	});
2357	}	2792	}
2358		2793
2359	sub _draw {	2794	sub _draw {
2360	my ($self) = @_;	2795	my ($self) = @_;
2361		2796
…		…
2378	glVertex $w, $h;	2813	glVertex $w, $h;
2379	glVertex $w, 0;	2814	glVertex $w, 0;
2380	glEnd;	2815	glEnd;
2381		2816
2382	glTranslate 2 - 0.375, 2 - 0.375;	2817	glTranslate 2 - 0.375, 2 - 0.375;
		2818
2383	$self->SUPER::_draw;	2819	$self->SUPER::_draw;
2384	}	2820	}
2385		2821
2386	#############################################################################	2822	#############################################################################
2387		2823
…		…
2392	use CFClient::OpenGL;	2828	use CFClient::OpenGL;
2393		2829
2394	sub new {	2830	sub new {
2395	my $class = shift;	2831	my $class = shift;
2396		2832
2397	$class->SUPER::new (	2833	my $self = $class->SUPER::new (
2398	aspect => 1,	2834	aspect => 1,
		2835	can_events => 0,
2399	@_,	2836	@_,
2400	)	2837	);
		2838
		2839	if ($self->{anim} && $self->{animspeed}) {
		2840	Scalar::Util::weaken (my $widget = $self);
		2841
		2842	$self->{timer} = Event->timer (
		2843	at => $self->{animspeed} * int $::NOW / $self->{animspeed},
		2844	hard => 1,
		2845	interval => $self->{animspeed},
		2846	cb => sub {
		2847	++$widget->{frame};
		2848	$widget->update;
		2849	},
		2850	);
		2851	}
		2852
		2853	$self
2401	}	2854	}
2402		2855
2403	sub size_request {	2856	sub size_request {
2404	(32, 8)	2857	(32, 8)
2405	}	2858	}
2406		2859
		2860	sub update {
		2861	my ($self) = @_;
		2862
		2863	return unless $self->{visible};
		2864
		2865	$self->SUPER::update;
		2866	}
		2867
2407	sub _draw {	2868	sub _draw {
2408	my ($self) = @_;	2869	my ($self) = @_;
2409		2870
2410	return unless $::CONN;#d# manage and cache textures differently	2871	return unless $::CONN;
		2872
		2873	my $face;
		2874
		2875	if ($self->{frame}) {
		2876	my $anim = $::CONN->{anim}[$self->{anim}];
		2877
		2878	$face = $anim->[ $self->{frame} % @$anim ]
		2879	if $anim && @$anim;
		2880	}
		2881
2411	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$self->{face}]];	2882	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
2412		2883
2413	# TODO animation
2414	if ($tex) {	2884	if ($tex) {
2415	glEnable GL_TEXTURE_2D;	2885	glEnable GL_TEXTURE_2D;
2416	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2886	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2417	glColor 1, 1, 1, 1;	2887	glColor 0, 0, 0, 1;
2418	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});	2888	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
2419	glDisable GL_TEXTURE_2D;	2889	glDisable GL_TEXTURE_2D;
2420	}	2890	}
2421	}	2891	}
2422		2892
		2893	sub DESTROY {
		2894	my ($self) = @_;
		2895
		2896	$self->{timer}->cancel
		2897	if $self->{timer};
		2898
		2899	$self->SUPER::DESTROY;
		2900	}
		2901
2423	#############################################################################	2902	#############################################################################
2424		2903
2425	package CFClient::UI::InventoryItem;	2904	package CFClient::UI::Buttonbar;
2426		2905
2427	our @ISA = CFClient::UI::HBox::;	2906	our @ISA = CFClient::UI::HBox::;
2428		2907
2429	sub new {	2908	# 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		2909
2532	#############################################################################	2910	#############################################################################
2533		2911
2534	package CFClient::UI::Menu;	2912	package CFClient::UI::Menu;
2535		2913
…		…
2547	);	2925	);
2548		2926
2549	$self->add ($self->{vbox} = new CFClient::UI::VBox);	2927	$self->add ($self->{vbox} = new CFClient::UI::VBox);
2550		2928
2551	for my $item (@{ $self->{items} }) {	2929	for my $item (@{ $self->{items} }) {
2552	my ($widget, $cb) = @$item;	2930	my ($widget, $cb, $tooltip) = @$item;
2553		2931
2554	# handle various types of items, only text for now	2932	# handle various types of items, only text for now
2555	if (!ref $widget) {	2933	if (!ref $widget) {
2556	$widget = new CFClient::UI::Label	2934	$widget = new CFClient::UI::Label
2557	can_hover => 1,	2935	can_hover => 1,
2558	can_events => 1,	2936	can_events => 1,
2559	text => $widget;	2937	text => $widget,
		2938	tooltip => $tooltip
2560	}	2939	}
2561		2940
2562	$self->{item}{$widget} = $item;	2941	$self->{item}{$widget} = $item;
2563		2942
2564	$self->{vbox}->add ($widget);	2943	$self->{vbox}->add ($widget);
…		…
2569		2948
2570	# popup given the event (must be a mouse button down event currently)	2949	# popup given the event (must be a mouse button down event currently)
2571	sub popup {	2950	sub popup {
2572	my ($self, $ev) = @_;	2951	my ($self, $ev) = @_;
2573		2952
2574	$self->emit ("popdown");	2953	$self->_emit ("popdown");
2575		2954
2576	# maybe save $GRAB? must be careful about events...	2955	# maybe save $GRAB? must be careful about events...
2577	$GRAB = $self;	2956	$GRAB = $self;
2578	$self->{button} = $ev->{button};	2957	$self->{button} = $ev->{button};
2579		2958
2580	$self->show;	2959	$self->show;
2581	$self->move ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);	2960	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
2582	}	2961	}
2583		2962
2584	sub mouse_motion {	2963	sub mouse_motion {
2585	my ($self, $ev, $x, $y) = @_;	2964	my ($self, $ev, $x, $y) = @_;
2586		2965
2587	# TODO: should use vbox->find_widget or so	2966	# TODO: should use vbox->find_widget or so
2588	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});	2967	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
2589	$self->{hover} = $self->{item}{$HOVER};	2968	$self->{hover} = $self->{item}{$HOVER};
		2969
		2970	0
2590	}	2971	}
2591		2972
2592	sub button_up {	2973	sub button_up {
2593	my ($self, $ev, $x, $y) = @_;	2974	my ($self, $ev, $x, $y) = @_;
2594		2975
2595	if ($ev->{button} == $self->{button}) {	2976	if ($ev->{button} == $self->{button}) {
2596	undef $GRAB;	2977	undef $GRAB;
2597	$self->hide;	2978	$self->hide;
2598		2979
2599	$self->emit ("popdown");	2980	$self->_emit ("popdown");
2600	$self->{hover}[1]->() if $self->{hover};	2981	$self->{hover}[1]->() if $self->{hover};
		2982	} else {
		2983	return 0
		2984	}
		2985
2601	}	2986	1
2602	}	2987	}
2603		2988
2604	#############################################################################	2989	#############################################################################
2605		2990
		2991	package CFClient::UI::Multiplexer;
		2992
		2993	our @ISA = CFClient::UI::Container::;
		2994
		2995	sub new {
		2996	my $class = shift;
		2997
		2998	my $self = $class->SUPER::new (
		2999	@_,
		3000	);
		3001
		3002	$self->{current} = $self->{children}[0]
		3003	if @{ $self->{children} };
		3004
		3005	$self
		3006	}
		3007
		3008	sub add {
		3009	my ($self, @widgets) = @_;
		3010
		3011	$self->SUPER::add (@widgets);
		3012
		3013	$self->{current} = $self->{children}[0]
		3014	if @{ $self->{children} };
		3015	}
		3016
		3017	sub set_current_page {
		3018	my ($self, $page_or_widget) = @_;
		3019
		3020	my $widget = ref $page_or_widget
		3021	? $page_or_widget
		3022	: $self->{children}[$page_or_widget];
		3023
		3024	$self->{current} = $widget;
		3025	$self->{current}->configure (0, 0, $self->{w}, $self->{h});
		3026
		3027	$self->_emit (page_changed => $self->{current});
		3028
		3029	$self->realloc;
		3030	}
		3031
		3032	sub visible_children {
		3033	$_[0]{current}
		3034	}
		3035
		3036	sub size_request {
		3037	my ($self) = @_;
		3038
		3039	$self->{current}->size_request
		3040	}
		3041
		3042	sub size_allocate {
		3043	my ($self, $w, $h) = @_;
		3044
		3045	$self->{current}->configure (0, 0, $w, $h);
		3046	}
		3047
		3048	sub _draw {
		3049	my ($self) = @_;
		3050
		3051	$self->{current}->draw;
		3052	}
		3053
		3054	#############################################################################
		3055
		3056	package CFClient::UI::Notebook;
		3057
		3058	our @ISA = CFClient::UI::VBox::;
		3059
		3060	sub new {
		3061	my $class = shift;
		3062
		3063	my $self = $class->SUPER::new (
		3064	buttonbar => (new CFClient::UI::Buttonbar),
		3065	multiplexer => (new CFClient::UI::Multiplexer expand => 1),
		3066	# filter => # will be put between multiplexer and $self
		3067	@_,
		3068	);
		3069
		3070	$self->{filter}->add ($self->{multiplexer}) if $self->{filter};
		3071	$self->SUPER::add ($self->{buttonbar}, $self->{filter} || $self->{multiplexer});
		3072
		3073	$self
		3074	}
		3075
		3076	sub add {
		3077	my ($self, $title, $widget, $tooltip) = @_;
		3078
		3079	Scalar::Util::weaken $self;
		3080
		3081	$self->{buttonbar}->add (new CFClient::UI::Button
		3082	markup => $title,
		3083	tooltip => $tooltip,
		3084	on_activate => sub { $self->set_current_page ($widget) },
		3085	);
		3086
		3087	$self->{multiplexer}->add ($widget);
		3088	}
		3089
		3090	sub set_current_page {
		3091	my ($self, $page) = @_;
		3092
		3093	$self->{multiplexer}->set_current_page ($page);
		3094	$self->_emit (page_changed => $self->{multiplexer}{current});
		3095	}
		3096
		3097	#############################################################################
		3098
		3099	package CFClient::UI::Combobox;
		3100
		3101	use utf8;
		3102
		3103	our @ISA = CFClient::UI::Button::;
		3104
		3105	sub new {
		3106	my $class = shift;
		3107
		3108	my $self = $class->SUPER::new (
		3109	options => [], # [title, value, tooltip], ...
		3110	value => undef,
		3111	@_,
		3112	);
		3113
		3114	$self->_set_value ($self->{value});
		3115
		3116	$self
		3117	}
		3118
		3119	sub button_down {
		3120	my ($self, $ev) = @_;
		3121
		3122	my @menu_items;
		3123
		3124	for (@{ $self->{options} }) {
		3125	my ($title, $value, $tooltip) = @$_;
		3126
		3127	push @menu_items, [$tooltip, sub { $self->set_value ($value) }];
		3128	}
		3129
		3130	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
		3131	}
		3132
		3133	sub _set_value {
		3134	my ($self, $value) = @_;
		3135
		3136	my ($item) = grep $_->[1] eq $value, @{ $self->{options} }
		3137	or return;
		3138
		3139	$self->{value} = $item->[1];
		3140	$self->set_markup ("$item->[0] ⇓");
		3141	$self->set_tooltip ($item->[2]);
		3142	}
		3143
		3144	sub set_value {
		3145	my ($self, $value) = @_;
		3146
		3147	return unless $self->{value} ne $value;
		3148
		3149	$self->_set_value ($value);
		3150	$self->_emit (changed => $value);
		3151	}
		3152
		3153	#############################################################################
		3154
2606	package CFClient::UI::Statusbox;	3155	package CFClient::UI::Statusbox;
2607		3156
2608	our @ISA = CFClient::UI::VBox::;	3157	our @ISA = CFClient::UI::VBox::;
2609		3158
		3159	sub new {
		3160	my $class = shift;
		3161
		3162	my $self = $class->SUPER::new (
		3163	fontsize => 0.8,
		3164	@_,
		3165	);
		3166
		3167	Scalar::Util::weaken (my $this = $self);
		3168
		3169	$self->{timer} = Event->timer (after => 1, interval => 1, cb => sub { $this->reorder });
		3170
		3171	$self
		3172	}
		3173
2610	sub reorder {	3174	sub reorder {
2611	my ($self) = @_;	3175	my ($self) = @_;
2612	my $NOW = time;	3176	my $NOW = Time::HiRes::time;
		3177
		3178	# freeze display when hovering over any label
		3179	return if $CFClient::UI::TOOLTIP->{owner}
		3180	&& grep $CFClient::UI::TOOLTIP->{owner} == $_->{label},
		3181	values %{ $self->{item} };
2613		3182
2614	while (my ($k, $v) = each %{ $self->{item} }) {	3183	while (my ($k, $v) = each %{ $self->{item} }) {
2615	delete $self->{item}{$k} if $v->{timeout} < $NOW;	3184	delete $self->{item}{$k} if $v->{timeout} < $NOW;
2616	}	3185	}
2617		3186
…		…
2620	my @items = sort {	3189	my @items = sort {
2621	$a->{pri} <=> $b->{pri}	3190	$a->{pri} <=> $b->{pri}
2622	or $b->{id} <=> $a->{id}	3191	or $b->{id} <=> $a->{id}
2623	} values %{ $self->{item} };	3192	} values %{ $self->{item} };
2624		3193
		3194	$self->{timer}->interval (1);
		3195
2625	my $count = 10 + 1;	3196	my $count = 10 + 1;
2626	for my $item (@items) {	3197	for my $item (@items) {
2627	last unless --$count;	3198	last unless --$count;
2628		3199
2629	push @widgets, $item->{label} ||= do {	3200	my $label = $item->{label} ||= do {
2630	# TODO: doesn't handle markup well (read as: at all)	3201	# TODO: doesn't handle markup well (read as: at all)
2631	my $short = $item->{count} > 1	3202	my $short = $item->{count} > 1
2632	? "<b>$item->{count} ×</b> $item->{text}"	3203	? "<b>$item->{count} ×</b> $item->{text}"
2633	: $item->{text};	3204	: $item->{text};
2634		3205
2635	for ($short) {	3206	for ($short) {
2636	s/^\s+//;	3207	s/^\s+//;
2637	s/\012.*/…/s;	3208	s/\s+/ /g;
2638	my $len = int 40 / $item->{fontsize};
2639	substr $_, $len, length, "…" if $len < length;
2640	}	3209	}
2641		3210
2642	new CFClient::UI::Label	3211	new CFClient::UI::Label
2643	markup => $short,	3212	markup => $short,
2644	tooltip => $item->{tooltip},	3213	tooltip => $item->{tooltip},
2645	tooltip_font => $::FONT_PROP,	3214	tooltip_font => $::FONT_PROP,
2646	tooltip_width => 0.67,	3215	tooltip_width => 0.67,
2647	fontsize => $item->{fontsize},	3216	fontsize => $item->{fontsize} || $self->{fontsize},
2648	color => $item->{color},	3217	max_w => $::WIDTH * 0.44,
		3218	fg => [@{ $item->{fg} }],
2649	can_events => 1,	3219	can_events => 1,
2650	can_hover => 1	3220	can_hover => 1
2651	};	3221	};
		3222
		3223	if ((my $diff = $item->{timeout} - $NOW) < 2) {
		3224	$label->{fg}[3] = ($item->{fg}[3] || 1) * $diff / 2;
		3225	$label->update;
		3226	$label->set_max_size (undef, $label->{req_h} * $diff)
		3227	if $diff < 1;
		3228	$self->{timer}->interval (1/30);
		3229	} else {
		3230	$label->{fg}[3] = $item->{fg}[3] || 1;
		3231	}
		3232
		3233	push @widgets, $label;
2652	}	3234	}
2653		3235
2654	$self->clear;	3236	$self->clear;
2655	$self->SUPER::add (reverse @widgets);	3237	$self->SUPER::add (reverse @widgets);
2656	}	3238	}
…		…
2659	my ($self, $text, %arg) = @_;	3241	my ($self, $text, %arg) = @_;
2660		3242
2661	$text =~ s/^\s+//;	3243	$text =~ s/^\s+//;
2662	$text =~ s/\s+$//;	3244	$text =~ s/\s+$//;
2663		3245
		3246	return unless $text;
		3247
2664	my $timeout = time + ((delete $arg{timeout}) || 60);	3248	my $timeout = (int time) + ((delete $arg{timeout}) || 60);
2665		3249
2666	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};	3250	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
2667		3251
2668	if (my $item = $self->{item}{$group}) {	3252	if (my $item = $self->{item}{$group}) {
2669	if ($item->{text} eq $text) {	3253	if ($item->{text} eq $text) {
…		…
2679	$self->{item}{$group} = {	3263	$self->{item}{$group} = {
2680	id => ++$self->{id},	3264	id => ++$self->{id},
2681	text => $text,	3265	text => $text,
2682	timeout => $timeout,	3266	timeout => $timeout,
2683	tooltip => $text,	3267	tooltip => $text,
2684	fontsize => 0.8,
2685	color => [0.8, 0.8, 0.8, 0.8],	3268	fg => [0.8, 0.8, 0.8, 0.8],
2686	pri => 0,	3269	pri => 0,
2687	count => 1,	3270	count => 1,
2688	%arg,	3271	%arg,
2689	};	3272	};
2690	}	3273	}
2691		3274
2692	$self->reorder;	3275	$self->reorder;
2693	}	3276	}
2694		3277
		3278	sub reconfigure {
		3279	my ($self) = @_;
		3280
		3281	delete $_->{label}
		3282	for values %{ $self->{item} || {} };
		3283
		3284	$self->reorder;
		3285	$self->SUPER::reconfigure;
		3286	}
		3287
		3288	sub DESTROY {
		3289	my ($self) = @_;
		3290
		3291	$self->{timer}->cancel;
		3292
		3293	$self->SUPER::DESTROY;
		3294	}
		3295
2695	#############################################################################	3296	#############################################################################
2696		3297
2697	package CFClient::UI::Root;	3298	package CFClient::UI::Inventory;
2698		3299
2699	our @ISA = CFClient::UI::Container::;	3300	our @ISA = CFClient::UI::ScrolledWindow::;
2700
2701	use CFClient::OpenGL;
2702		3301
2703	sub new {	3302	sub new {
2704	my $class = shift;	3303	my $class = shift;
2705		3304
2706	$class->SUPER::new (	3305	my $self = $class->SUPER::new (
		3306	child => (new CFClient::UI::Table col_expand => [0, 1, 0]),
		3307	@_,
		3308	);
		3309
		3310	$self
		3311	}
		3312
		3313	sub set_items {
		3314	my ($self, $items) = @_;
		3315
		3316	$self->{child}->clear;
		3317	return unless $items;
		3318
		3319	my @items = sort {
		3320	($a->{type} <=> $b->{type})
		3321	or ($a->{name} cmp $b->{name})
		3322	} @$items;
		3323
		3324	$self->{real_items} = \@items;
		3325
		3326	my $row = 0;
		3327	for my $item (@items) {
		3328	CFClient::Item::update_widgets $item;
		3329
		3330	$self->{child}->add (0, $row, $item->{face_widget});
		3331	$self->{child}->add (1, $row, $item->{desc_widget});
		3332	$self->{child}->add (2, $row, $item->{weight_widget});
		3333
		3334	$row++;
		3335	}
		3336	}
		3337
		3338	#############################################################################
		3339
		3340	package CFClient::UI::BindEditor;
		3341
		3342	our @ISA = CFClient::UI::FancyFrame::;
		3343
		3344	sub new {
		3345	my $class = shift;
		3346
		3347	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3348
		3349	$self->add (my $vb = new CFClient::UI::VBox);
		3350
		3351
		3352	$vb->add ($self->{rec_btn} = new CFClient::UI::Button
		3353	text => "start recording",
		3354	tooltip => "Start/Stops recording of actions."
		3355	."All subsequent actions after the recording started will be captured."
		3356	."The actions are displayed after the record was stopped."
		3357	."To bind the action you have to click on the 'Bind' button",
		3358	on_activate => sub {
		3359	unless ($self->{recording}) {
		3360	$self->start;
		3361	} else {
		3362	$self->stop;
		3363	}
		3364	});
		3365
		3366	$vb->add (new CFClient::UI::Label text => "Actions:");
		3367	$vb->add ($self->{cmdbox} = new CFClient::UI::VBox);
		3368
		3369	$vb->add (new CFClient::UI::Label text => "Bound to: ");
		3370	$vb->add (my $hb = new CFClient::UI::HBox);
		3371	$hb->add ($self->{keylbl} = new CFClient::UI::Label expand => 1);
		3372	$hb->add (new CFClient::UI::Button
		3373	text => "bind",
		3374	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
		3375	on_activate => sub {
		3376	$self->ask_for_bind;
		3377	});
		3378
		3379	$vb->add (my $hb = new CFClient::UI::HBox);
		3380	$hb->add (new CFClient::UI::Button
		3381	text => "ok",
		3382	expand => 1,
		3383	tooltip => "This closes the binding editor and saves the binding",
		3384	on_activate => sub {
		3385	$self->hide;
		3386	$self->commit;
		3387	});
		3388
		3389	$hb->add (new CFClient::UI::Button
		3390	text => "cancel",
		3391	expand => 1,
		3392	tooltip => "This closes the binding editor without saving",
		3393	on_activate => sub {
		3394	$self->hide;
		3395	$self->{binding_cancel}->()
		3396	if $self->{binding_cancel};
		3397	});
		3398
		3399	$self->update_binding_widgets;
		3400
		3401	$self
		3402	}
		3403
		3404	sub commit {
		3405	my ($self) = @_;
		3406	my ($mod, $sym, $cmds) = $self->get_binding;
		3407	if ($sym != 0 && @$cmds > 0) {
		3408	$::STATUSBOX->add ("Bound actions to '".CFClient::Binder::keycombo_to_name ($mod, $sym)
		3409	."'. Don't forget 'Save Config'!");
		3410	$self->{binding_change}->($mod, $sym, $cmds)
		3411	if $self->{binding_change};
		3412	} else {
		3413	$::STATUSBOX->add ("No action bound, no key or action specified!");
		3414	$self->{binding_cancel}->()
		3415	if $self->{binding_cancel};
		3416	}
		3417	}
		3418
		3419	sub start {
		3420	my ($self) = @_;
		3421
		3422	$self->{rec_btn}->set_text ("stop recording");
		3423	$self->{recording} = 1;
		3424	$self->clear_command_list;
		3425	$::CONN->start_record if $::CONN;
		3426	}
		3427
		3428	sub stop {
		3429	my ($self) = @_;
		3430
		3431	$self->{rec_btn}->set_text ("start recording");
		3432	$self->{recording} = 0;
		3433
		3434	my $rec;
		3435	$rec = $::CONN->stop_record if $::CONN;
		3436	return unless ref $rec eq 'ARRAY';
		3437	$self->set_command_list ($rec);
		3438	}
		3439
		3440
		3441	sub ask_for_bind_and_commit {
		3442	my ($self) = @_;
		3443	$self->ask_for_bind (1);
		3444	}
		3445
		3446	sub ask_for_bind {
		3447	my ($self, $commit) = @_;
		3448
		3449	CFClient::Binder::open_binding_dialog (sub {
		3450	my ($mod, $sym) = @_;
		3451	$self->{binding} = [$mod, $sym]; # XXX: how to stop that memleak?
		3452	$self->update_binding_widgets;
		3453	$self->commit if $commit;
		3454	});
		3455	}
		3456
		3457	# $mod and $sym are the modifiers and key symbol
		3458	# $cmds is a array ref of strings (the commands)
		3459	# $cb is the callback that is executed on OK
		3460	# $ccb is the callback that is executed on CANCEL and
		3461	# when the binding was unsuccessful on OK
		3462	sub set_binding {
		3463	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
		3464
		3465	$self->clear_command_list;
		3466	$self->{recording} = 0;
		3467	$self->{rec_btn}->set_text ("start recording");
		3468
		3469	$self->{binding} = [$mod, $sym];
		3470	$self->{commands} = $cmds;
		3471
		3472	$self->{binding_change} = $cb;
		3473	$self->{binding_cancel} = $ccb;
		3474
		3475	$self->update_binding_widgets;
		3476	}
		3477
		3478	# this is a shortcut method that asks for a binding
		3479	# and then just binds it.
		3480	sub do_quick_binding {
		3481	my ($self, $cmds) = @_;
		3482	$self->set_binding (undef, undef, $cmds, sub {
		3483	$::CFG->{bindings}->{$_[0]}->{$_[1]} = $_[2];
		3484	});
		3485	$self->ask_for_bind (1);
		3486	}
		3487
		3488	sub update_binding_widgets {
		3489	my ($self) = @_;
		3490	my ($mod, $sym, $cmds) = $self->get_binding;
		3491	$self->{keylbl}->set_text (CFClient::Binder::keycombo_to_name ($mod, $sym));
		3492	$self->set_command_list ($cmds);
		3493	}
		3494
		3495	sub get_binding {
		3496	my ($self) = @_;
		3497	return (
		3498	$self->{binding}->[0],
		3499	$self->{binding}->[1],
		3500	[ grep { defined $_ } @{$self->{commands}} ]
		3501	);
		3502	}
		3503
		3504	sub clear_command_list {
		3505	my ($self) = @_;
		3506	$self->{cmdbox}->clear ();
		3507	}
		3508
		3509	sub set_command_list {
		3510	my ($self, $cmds) = @_;
		3511
		3512	$self->{cmdbox}->clear ();
		3513	$self->{commands} = $cmds;
		3514
		3515	my $idx = 0;
		3516
		3517	for (@$cmds) {
		3518	$self->{cmdbox}->add (my $hb = new CFClient::UI::HBox);
		3519
		3520	my $i = $idx;
		3521	$hb->add (new CFClient::UI::Label text => $_);
		3522	$hb->add (new CFClient::UI::Button
		3523	text => "delete",
		3524	tooltip => "Deletes the action from the record",
		3525	on_activate => sub {
		3526	$self->{cmdbox}->remove ($hb);
		3527	$cmds->[$i] = undef;
		3528	});
		3529
		3530
		3531	$idx++
		3532	}
		3533	}
		3534
		3535	#############################################################################
		3536
		3537	package CFClient::UI::SpellList;
		3538
		3539	our @ISA = CFClient::UI::Table::;
		3540
		3541	sub new {
		3542	my $class = shift;
		3543
		3544	my $self = $class->SUPER::new (
		3545	binding => [],
		3546	commands => [],
2707	@_,	3547	@_,
2708	)	3548	)
2709	}	3549	}
2710		3550
2711	sub configure {	3551	my @TOOLTIP_LVL = (align => 1, can_events => 1, can_hover => 1, tooltip =>
2712	my ($self, $x, $y, $w, $h) = @_;	3552	"<b>Level</b>. Minimum level the caster needs in the associated skill to be able to attempt casting this spell.");
		3553	my @TOOLTIP_SP = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3554	"<b>Spell points / Grace points</b>. Amount of spell or grace points used by each invocation.");
		3555	my @TOOLTIP_DMG = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3556	"<b>Damage</b>. The amount of damage the spell deals when it hits.");
2713		3557
2714	$self->{w} = $w;	3558	sub rebuild_spell_list {
2715	$self->{h} = $h;	3559	my ($self) = @_;
2716	}
2717		3560
2718	sub check_size {	3561	$CFClient::UI::ROOT->on_refresh ($self => sub {
		3562	$self->clear;
		3563
		3564	$self->add (1, 0, new CFClient::UI::Label text => "Spell Name");
		3565	$self->add (2, 0, new CFClient::UI::Label text => "Lvl" , @TOOLTIP_LVL);
		3566	$self->add (3, 0, new CFClient::UI::Label text => "Sp/Gp", @TOOLTIP_SP);
		3567	$self->add (4, 0, new CFClient::UI::Label text => "Dmg" , @TOOLTIP_DMG);
		3568
		3569	my $row = 0;
		3570
		3571	for (sort { $a cmp $b } keys %{ $self->{spell} }) {
		3572	my $spell = $self->{spell}{$_};
		3573
		3574	$row++;
		3575
		3576	$self->add (0, $row, new CFClient::UI::Face
		3577	face => $spell->{face},
		3578	can_hover => 1,
		3579	can_events => 1,
		3580	tooltip => $spell->{message},
		3581	);
		3582
		3583	$self->add (1, $row, new CFClient::UI::Label
		3584	expand => 1,
		3585	text => $spell->{name},
		3586	can_hover => 1,
		3587	can_events => 1,
		3588	tooltip => $spell->{message},
		3589	);
		3590
		3591	$self->add (2, $row, new CFClient::UI::Label text => $spell->{level}, @TOOLTIP_LVL);
		3592	$self->add (3, $row, new CFClient::UI::Label text => $spell->{mana} || $spell->{grace}, @TOOLTIP_SP);
		3593	$self->add (4, $row, new CFClient::UI::Label text => $spell->{damage}, @TOOLTIP_DMG);
		3594
		3595	# TODO: should be done via popup
		3596	$self->add (5, $row, new CFClient::UI::Button
		3597	text => "bind",
		3598	tooltip => "bind spell readying (cast command) to key",
		3599	on_activate => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) },
		3600	);
		3601	}
		3602	});
		3603	}
		3604
		3605	sub add_spell {
2719	my ($self) = @_;	3606	my ($self, $spell) = @_;
2720		3607
2721	$self->size_allocate ($self->{w}, $self->{h})	3608	$self->{spell}->{$spell->{name}} = $spell;
2722	if $self->{w};	3609	$self->rebuild_spell_list;
		3610	}
		3611
		3612	sub remove_spell {
		3613	my ($self, $spell) = @_;
		3614
		3615	delete $self->{spell}->{$spell->{name}};
		3616	$self->rebuild_spell_list;
		3617	}
		3618
		3619	#############################################################################
		3620
		3621	package CFClient::UI::Root;
		3622
		3623	our @ISA = CFClient::UI::Container::;
		3624
		3625	use List::Util qw(min max);
		3626
		3627	use CFClient::OpenGL;
		3628
		3629	sub new {
		3630	my $class = shift;
		3631
		3632	my $self = $class->SUPER::new (
		3633	visible => 1,
		3634	@_,
		3635	);
		3636
		3637	Scalar::Util::weaken ($self->{root} = $self);
		3638
		3639	$self
2723	}	3640	}
2724		3641
2725	sub size_request {	3642	sub size_request {
2726	my ($self) = @_;	3643	my ($self) = @_;
2727		3644
2728	($self->{w}, $self->{h})	3645	($self->{w}, $self->{h})
		3646	}
		3647
		3648	sub _to_pixel {
		3649	my ($coord, $size, $max) = @_;
		3650
		3651	$coord =
		3652	$coord eq "center" ? ($max - $size) * 0.5
		3653	: $coord eq "max" ? $max
		3654	: $coord;
		3655
		3656	$coord = 0 if $coord < 0;
		3657	$coord = $max - $size if $coord > $max - $size;
		3658
		3659	int $coord + 0.5
2729	}	3660	}
2730		3661
2731	sub size_allocate {	3662	sub size_allocate {
2732	my ($self, $w, $h) = @_;	3663	my ($self, $w, $h) = @_;
2733		3664
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) {	3665	for my $child ($self->children) {
2751	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};	3666	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};
2752		3667
2753	$X = List::Util::max 0, List::Util::min $w - $W, $X;	3668	$X = $child->{force_x} if exists $child->{force_x};
2754	$Y = List::Util::max 0, List::Util::min $h - $H, $Y;	3669	$Y = $child->{force_y} if exists $child->{force_y};
		3670
		3671	$X = _to_pixel $X, $W, $self->{w};
		3672	$Y = _to_pixel $Y, $H, $self->{h};
		3673
2755	$child->configure ($X, $Y, $W, $H);	3674	$child->configure ($X, $Y, $W, $H);
2756	}	3675	}
2757
2758	$self->{old_w} = $w;
2759	$self->{old_h} = $h;
2760	}	3676	}
2761		3677
2762	sub coord2local {	3678	sub coord2local {
2763	my ($self, $x, $y) = @_;	3679	my ($self, $x, $y) = @_;
2764		3680
…		…
2772	}	3688	}
2773		3689
2774	sub update {	3690	sub update {
2775	my ($self) = @_;	3691	my ($self) = @_;
2776		3692
2777	$self->check_size;
2778	$::WANT_REFRESH++;	3693	$::WANT_REFRESH++;
2779	}	3694	}
2780		3695
2781	sub add {	3696	sub add {
2782	my ($self, $child) = @_;	3697	my ($self, @children) = @_;
2783		3698
2784	# integerise window positions	3699	$_->{is_toplevel} = 1
2785	$child->{x} = int $child->{x};	3700	for @children;
2786	$child->{y} = int $child->{y};
2787		3701
2788	$self->SUPER::add ($child);	3702	$self->SUPER::add (@children);
		3703	}
		3704
		3705	sub remove {
		3706	my ($self, @children) = @_;
		3707
		3708	$self->SUPER::remove (@children);
		3709
		3710	delete $self->{is_toplevel}
		3711	for @children;
		3712
		3713	while (@children) {
		3714	my $w = pop @children;
		3715	push @children, $w->children;
		3716	$w->set_invisible;
		3717	}
2789	}	3718	}
2790		3719
2791	sub on_refresh {	3720	sub on_refresh {
2792	my ($self, $id, $cb) = @_;	3721	my ($self, $id, $cb) = @_;
2793		3722
…		…
2806	while ($self->{refresh_hook}) {	3735	while ($self->{refresh_hook}) {
2807	$_->()	3736	$_->()
2808	for values %{delete $self->{refresh_hook}};	3737	for values %{delete $self->{refresh_hook}};
2809	}	3738	}
2810		3739
2811	if ($self->{check_size}) {	3740	if ($self->{realloc}) {
2812	my @queue = ([], []);	3741	my %queue;
		3742	my @queue;
		3743	my $widget;
2813		3744
2814	for (;;) {	3745	outer:
2815	if ($self->{check_size}) {	3746	while () {
2816	# heuristic: check containers last	3747	if (my $realloc = delete $self->{realloc}) {
2817	push @{ $queue[ ! ! $_->isa ("CFClient::UI::Container") ] }, $_	3748	for $widget (values %$realloc) {
2818	for values %{delete $self->{check_size}}	3749	$widget->{visible} or next; # do not resize invisible widgets
		3750
		3751	$queue{$widget+0}++ and next; # duplicates are common
		3752
		3753	push @{ $queue[$widget->{visible}] }, $widget;
		3754	}
2819	}	3755	}
2820		3756
2821	my $widget = (pop @{ $queue[0] }) || (pop @{ $queue[1] }) || last;	3757	while () {
		3758	@queue or last outer;
2822		3759
2823	my ($w, $h) = $widget->{user_w} && $widget->{user_h}	3760	$widget = pop @{ $queue[-1] || [] }
2824	? @$widget{qw(user_w user_h)}	3761	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		3762
		3763	pop @queue;
		3764	}
		3765
		3766	delete $queue{$widget+0};
		3767
		3768	my ($w, $h) = $widget->size_request;
		3769
		3770	$w = max $widget->{min_w}, $w + $widget->{padding_x} * 2;
		3771	$h = max $widget->{min_h}, $h + $widget->{padding_y} * 2;
		3772
		3773	$w = min $widget->{max_w}, $w if exists $widget->{max_w};
		3774	$h = min $widget->{max_h}, $h if exists $widget->{max_h};
		3775
		3776	$w = $widget->{force_w} if exists $widget->{force_w};
		3777	$h = $widget->{force_h} if exists $widget->{force_h};
		3778
		3779	if ($widget->{req_w} != $w || $widget->{req_h} != $h
		3780	|| delete $widget->{force_realloc}) {
2831	$widget->{req_w} = $w;	3781	$widget->{req_w} = $w;
2832	$widget->{req_h} = $h;	3782	$widget->{req_h} = $h;
2833		3783
2834	$self->{size_alloc}{$widget} = [$widget, $widget->{w} || $w, $widget->{h} || $h];	3784	$self->{size_alloc}{$widget+0} = $widget;
2835		3785
2836	$widget->{parent}->check_size
2837	if $widget->{parent};	3786	if (my $parent = $widget->{parent}) {
		3787	$self->{realloc}{$parent+0} = $parent
		3788	unless $queue{$parent+0};
		3789
		3790	$parent->{force_size_alloc} = 1;
		3791	$self->{size_alloc}{$parent+0} = $parent;
		3792	}
2838	}	3793	}
		3794
		3795	delete $self->{realloc}{$widget+0};
2839	}	3796	}
2840	}	3797	}
2841		3798
2842	while ($self->{size_alloc}) {	3799	while (my $size_alloc = delete $self->{size_alloc}) {
2843	for (values %{delete $self->{size_alloc}}) {	3800	my @queue = sort { $b->{visible} <=> $a->{visible} }
2844	my ($widget, $w, $h) = @$_;	3801	values %$size_alloc;
		3802
		3803	while () {
		3804	my $widget = pop @queue || last;
		3805
		3806	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};
2845		3807
2846	$w = 0 if $w < 0;	3808	$w = 0 if $w < 0;
2847	$h = 0 if $h < 0;	3809	$h = 0 if $h < 0;
2848		3810
		3811	$w = int $w + 0.5;
		3812	$h = int $h + 0.5;
		3813
		3814	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {
		3815	$widget->{old_w} = $widget->{w};
		3816	$widget->{old_h} = $widget->{h};
		3817
2849	$widget->{w} = $w;	3818	$widget->{w} = $w;
2850	$widget->{h} = $h;	3819	$widget->{h} = $h;
2851	$widget->size_allocate ($w, $h);	3820
2852	$widget->emit (size_allocate => $w, $h);	3821	$widget->emit (size_allocate => $w, $h);
		3822	}
2853	}	3823	}
2854	}	3824	}
2855		3825
2856	while ($self->{post_alloc_hook}) {	3826	while ($self->{post_alloc_hook}) {
2857	$_->()	3827	$_->()
2858	for values %{delete $self->{post_alloc_hook}};	3828	for values %{delete $self->{post_alloc_hook}};
2859	}	3829	}
2860		3830
		3831
2861	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3832	glViewport 0, 0, $::WIDTH, $::HEIGHT;
2862	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3833	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
2863	glClear GL_COLOR_BUFFER_BIT;	3834	glClear GL_COLOR_BUFFER_BIT;
2864		3835
2865	glMatrixMode GL_PROJECTION;	3836	glMatrixMode GL_PROJECTION;
2866	glLoadIdentity;	3837	glLoadIdentity;
2867	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000 , 10000;	3838	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
2868	glMatrixMode GL_MODELVIEW;	3839	glMatrixMode GL_MODELVIEW;
2869	glLoadIdentity;	3840	glLoadIdentity;
2870		3841
		3842	{
		3843	package CFClient::UI::Base;
		3844
		3845	($draw_x, $draw_y, $draw_w, $draw_h) =
		3846	(0, 0, $self->{w}, $self->{h});
		3847	}
		3848
2871	$self->_draw;	3849	$self->_draw;
2872	}	3850	}
2873		3851
2874	#############################################################################	3852	#############################################################################
2875		3853
2876	package CFClient::UI;	3854	package CFClient::UI;
2877		3855
2878	$ROOT = new CFClient::UI::Root;	3856	$ROOT = new CFClient::UI::Root;
2879	$TOOLTIP = new CFClient::UI::Tooltip;	3857	$TOOLTIP = new CFClient::UI::Tooltip z => 900;
2880		3858
2881	1	3859	1
2882		3860

Diff Legend

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