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

Diff Legend

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