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.264 by root, Thu Jun 1 02:58:30 2006 UTC vs.
Revision 1.337 by root, Mon Jul 24 04:24:43 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;
10	use CFClient::Texture;	11	use CFClient::Texture;
11		12
12	our ($FOCUS, $HOVER, $GRAB); # various widgets	13	our ($FOCUS, $HOVER, $GRAB); # various widgets
…		…
15	our $ROOT;	16	our $ROOT;
16	our $TOOLTIP;	17	our $TOOLTIP;
17	our $BUTTON_STATE;	18	our $BUTTON_STATE;
18		19
19	our %WIDGET; # all widgets, weak-referenced	20	our %WIDGET; # all widgets, weak-referenced
		21
		22	our $TOOLTIP_WATCHER = Event->idle (min => 1/60, cb => sub {
		23	if (!$GRAB) {
		24	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {
		25	if (length $widget->{tooltip}) {
		26	if ($TOOLTIP->{owner} != $widget) {
		27	$TOOLTIP->hide;
		28
		29	$TOOLTIP->{owner} = $widget;
		30
		31	return if $ENV{CFPLUS_DEBUG} & 8;
		32
		33	my $tip = $widget->{tooltip};
		34
		35	$tip = $tip->($widget) if CODE:: eq ref $tip;
		36
		37	$TOOLTIP->set_tooltip_from ($widget);
		38	$TOOLTIP->show;
		39	}
		40
		41	return;
		42	}
		43	}
		44	}
		45
		46	$TOOLTIP->hide;
		47	delete $TOOLTIP->{owner};
		48	});
20		49
21	sub get_layout {	50	sub get_layout {
22	my $layout;	51	my $layout;
23		52
24	for (grep { $_->{name} } values %WIDGET) {	53	for (grep { $_->{name} } values %WIDGET) {
…		…
39	my ($layout) = @_;	68	my ($layout) = @_;
40		69
41	$LAYOUT = $layout;	70	$LAYOUT = $layout;
42	}	71	}
43		72
44	sub check_tooltip {
45	if (!$GRAB) {
46	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {
47	if (length $widget->{tooltip}) {
48
49	if ($TOOLTIP->{owner} != $widget) {
50	$TOOLTIP->hide;
51
52	$TOOLTIP->{owner} = $widget;
53
54	my $tip = $widget->{tooltip};
55
56	$tip = $tip->($widget) if CODE:: eq ref $tip;
57
58	$TOOLTIP->set_tooltip_from ($widget);
59	$TOOLTIP->show;
60	}
61
62	return;
63	}
64	}
65	}
66
67	$TOOLTIP->hide;
68	delete $TOOLTIP->{owner};
69	}
70
71	# class methods for events	73	# class methods for events
72	sub feed_sdl_key_down_event {	74	sub feed_sdl_key_down_event {
73	$FOCUS->emit (key_down => $_[0])	75	$FOCUS->emit (key_down => $_[0])
74	if $FOCUS;	76	if $FOCUS;
75	}	77	}
…		…
77	sub feed_sdl_key_up_event {	79	sub feed_sdl_key_up_event {
78	$FOCUS->emit (key_up => $_[0])	80	$FOCUS->emit (key_up => $_[0])
79	if $FOCUS;	81	if $FOCUS;
80	}	82	}
81		83
		84	sub check_hover {
		85	my ($widget) = @_;
		86
		87	if ($widget != $HOVER) {
		88	my $hover = $HOVER; $HOVER = $widget;
		89
		90	$hover->update if $hover && $hover->{can_hover};
		91	$HOVER->update if $HOVER && $HOVER->{can_hover};
		92
		93	$TOOLTIP_WATCHER->start;
		94	}
		95	}
		96
82	sub feed_sdl_button_down_event {	97	sub feed_sdl_button_down_event {
83	my ($ev) = @_;	98	my ($ev) = @_;
84	my ($x, $y) = ($ev->{x}, $ev->{y});	99	my ($x, $y) = ($ev->{x}, $ev->{y});
85		100
86	if (!$BUTTON_STATE) {	101	unless ($BUTTON_STATE) {
87	my $widget = $ROOT->find_widget ($x, $y);	102	my $widget = $ROOT->find_widget ($x, $y);
88		103
89	$GRAB = $widget;	104	$GRAB = $widget;
90	$GRAB->update if $GRAB;	105	$GRAB->update if $GRAB;
91		106
92	check_tooltip;	107	$TOOLTIP_WATCHER->cb->();
93	}	108	}
94		109
95	$BUTTON_STATE |= 1 << ($ev->{button} - 1);	110	$BUTTON_STATE |= 1 << ($ev->{button} - 1);
96		111
97	$GRAB->emit (button_down => $ev, $GRAB->coord2local ($x, $y))	112	if ($GRAB) {
98	if $GRAB;	113	if ($ev->{button} == 4 || $ev->{button} == 5) {
		114	# mousewheel
		115	$ev->{dx} = 0;
		116	$ev->{dy} = $ev->{button} * 2 - 9;
		117	$GRAB->emit (mouse_wheel => $ev);
		118	} else {
		119	$GRAB->emit (button_down => $ev)
		120	}
		121	}
99	}	122	}
100		123
101	sub feed_sdl_button_up_event {	124	sub feed_sdl_button_up_event {
102	my ($ev) = @_;	125	my ($ev) = @_;
103	my ($x, $y) = ($ev->{x}, $ev->{y});
104		126
105	my $widget = $GRAB || $ROOT->find_widget ($x, $y);	127	my $widget = $GRAB || $ROOT->find_widget ($ev->{x}, $ev->{y});
106		128
107	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));	129	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));
108		130
109	$GRAB->emit (button_up => $ev, $GRAB->coord2local ($x, $y))	131	$GRAB->emit (button_up => $ev)
110	if $GRAB;	132	if $GRAB && $ev->{button} != 4 && $ev->{button} != 5;
111		133
112	if (!$BUTTON_STATE) {	134	unless ($BUTTON_STATE) {
113	my $grab = $GRAB; undef $GRAB;	135	my $grab = $GRAB; undef $GRAB;
114	$grab->update if $grab;	136	$grab->update if $grab;
115	$GRAB->update if $GRAB;	137	$GRAB->update if $GRAB;
116		138
117	check_tooltip;	139	check_hover $widget;
		140	$TOOLTIP_WATCHER->cb->();
118	}	141	}
119	}	142	}
120		143
121	sub feed_sdl_motion_event {	144	sub feed_sdl_motion_event {
122	my ($ev) = @_;	145	my ($ev) = @_;
123	my ($x, $y) = ($ev->{x}, $ev->{y});	146	my ($x, $y) = ($ev->{x}, $ev->{y});
124		147
125	my $widget = $GRAB || $ROOT->find_widget ($x, $y);	148	my $widget = $GRAB || $ROOT->find_widget ($x, $y);
126		149
127	if ($widget != $HOVER) {	150	check_hover $widget;
128	my $hover = $HOVER; $HOVER = $widget;
129		151
130	$hover->update if $hover && $hover->{can_hover};	152	$HOVER->emit (mouse_motion => $ev)
131	$HOVER->update if $HOVER && $HOVER->{can_hover};
132
133	check_tooltip;
134	}
135
136	$HOVER->emit (mouse_motion => $ev, $HOVER->coord2local ($x, $y))
137	if $HOVER;	153	if $HOVER;
138	}	154	}
139		155
140	# convert position array to integers	156	# convert position array to integers
141	sub harmonize {	157	sub harmonize {
…		…
170	sub rescale_widgets {	186	sub rescale_widgets {
171	my ($sx, $sy) = @_;	187	my ($sx, $sy) = @_;
172		188
173	for my $widget (values %WIDGET) {	189	for my $widget (values %WIDGET) {
174	if ($widget->{is_toplevel}) {	190	if ($widget->{is_toplevel}) {
175	$widget->{x} += $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;	191	$widget->{x} += int $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
176	$widget->{y} += $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;	192	$widget->{y} += int $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
177		193
178	$widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/;	194	$widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/;
179	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};	195	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};
180	$widget->{force_w} = int 0.5 + $widget->{force_w} * $sx if exists $widget->{force_w};	196	$widget->{force_w} = int 0.5 + $widget->{force_w} * $sx if exists $widget->{force_w};
181	$widget->{y} = int 0.5 + $widget->{y} * $sy if $widget->{y} =~ /^[0-9.]+$/;	197	$widget->{y} = int 0.5 + $widget->{y} * $sy if $widget->{y} =~ /^[0-9.]+$/;
182	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};	198	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};
183	$widget->{force_h} = int 0.5 + $widget->{force_h} * $sy if exists $widget->{force_h};	199	$widget->{force_h} = int 0.5 + $widget->{force_h} * $sy if exists $widget->{force_h};
184		200
185	$widget->{x} -= $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;	201	$widget->{x} -= int $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
186	$widget->{y} -= $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;	202	$widget->{y} -= int $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
187		203
188	}	204	}
189	}	205	}
190		206
191	reconfigure_widgets;	207	reconfigure_widgets;
		208	}
		209
		210	#############################################################################
		211
		212	package CFClient::UI::Event;
		213
		214	sub xy {
		215	$_[1]->coord2local ($_[0]{x}, $_[0]{y})
192	}	216	}
193		217
194	#############################################################################	218	#############################################################################
195		219
196	package CFClient::UI::Base;	220	package CFClient::UI::Base;
…		…
270		294
271	return unless $self->{visible};	295	return unless $self->{visible};
272		296
273	$_->set_invisible for $self->children;	297	$_->set_invisible for $self->children;
274		298
		299	delete $self->{visible};
275	delete $self->{root};	300	delete $self->{root};
276	delete $self->{visible};
277		301
278	undef $GRAB if $GRAB == $self;	302	undef $GRAB if $GRAB == $self;
279	undef $HOVER if $HOVER == $self;	303	undef $HOVER if $HOVER == $self;
280		304
281	CFClient::UI::check_tooltip	305	$CFClient::UI::TOOLTIP_WATCHER->cb->()
282	if $TOOLTIP->{owner} == $self;	306	if $TOOLTIP->{owner} == $self;
283		307
284	$self->focus_out;	308	$self->emit ("focus_out");
285
286	$self->emit (visibility_change => 0);	309	$self->emit (visibility_change => 0);
287	}	310	}
288		311
289	sub set_visibility {	312	sub set_visibility {
290	my ($self, $visible) = @_;	313	my ($self, $visible) = @_;
…		…
313	}	336	}
314		337
315	sub move_abs {	338	sub move_abs {
316	my ($self, $x, $y, $z) = @_;	339	my ($self, $x, $y, $z) = @_;
317		340
318	$self->{x} = List::Util::max 0, int $x;	341	$self->{x} = List::Util::max 0, List::Util::min $self->{root}{w} - $self->{w}, int $x;
319	$self->{y} = List::Util::max 0, int $y;	342	$self->{y} = List::Util::max 0, List::Util::min $self->{root}{h} - $self->{h}, int $y;
320	$self->{z} = $z if defined $z;	343	$self->{z} = $z if defined $z;
321		344
322	$self->update;	345	$self->update;
323	}	346	}
324		347
…		…
334	sub size_request {	357	sub size_request {
335	require Carp;	358	require Carp;
336	Carp::confess "size_request is abstract";	359	Carp::confess "size_request is abstract";
337	}	360	}
338		361
		362	sub baseline_shift {
		363	0
		364	}
		365
339	sub configure {	366	sub configure {
340	my ($self, $x, $y, $w, $h) = @_;	367	my ($self, $x, $y, $w, $h) = @_;
341		368
342	if ($self->{aspect}) {	369	if ($self->{aspect}) {
343	my ($ow, $oh) = ($w, $h);	370	my ($ow, $oh) = ($w, $h);
344		371
345	$w = List::Util::min $w, int $h * $self->{aspect};	372	$w = List::Util::min $w, CFClient::ceil $h * $self->{aspect};
346	$h = List::Util::min $h, int $w / $self->{aspect};	373	$h = List::Util::min $h, CFClient::ceil $w / $self->{aspect};
347		374
348	# use alignment to adjust x, y	375	# use alignment to adjust x, y
349		376
350	$x += int 0.5 * ($ow - $w);	377	$x += int 0.5 * ($ow - $w);
351	$y += int 0.5 * ($oh - $h);	378	$y += int 0.5 * ($oh - $h);
…		…
365		392
366	$self->{root}{size_alloc}{$self+0} = $self;	393	$self->{root}{size_alloc}{$self+0} = $self;
367	}	394	}
368	}	395	}
369		396
370	sub size_allocate {
371	# nothing to be done
372	}
373
374	sub children {	397	sub children {
		398	# nop
		399	}
		400
		401	sub visible_children {
		402	$_[0]->children
375	}	403	}
376		404
377	sub set_max_size {	405	sub set_max_size {
378	my ($self, $w, $h) = @_;	406	my ($self, $w, $h) = @_;
379		407
380	delete $self->{max_w}; $self->{max_w} = $w if $w;	408	$self->{max_w} = int $w if defined $w;
381	delete $self->{max_h}; $self->{max_h} = $h if $h;	409	$self->{max_h} = int $h if defined $h;
		410
		411	$self->realloc;
382	}	412	}
383		413
384	sub set_tooltip {	414	sub set_tooltip {
385	my ($self, $tooltip) = @_;	415	my ($self, $tooltip) = @_;
386		416
…		…
391		421
392	$self->{tooltip} = $tooltip;	422	$self->{tooltip} = $tooltip;
393		423
394	if ($CFClient::UI::TOOLTIP->{owner} == $self) {	424	if ($CFClient::UI::TOOLTIP->{owner} == $self) {
395	delete $CFClient::UI::TOOLTIP->{owner};	425	delete $CFClient::UI::TOOLTIP->{owner};
396	CFClient::UI::check_tooltip;	426	$CFClient::UI::TOOLTIP_WATCHER->cb->();
397	}	427	}
398	}	428	}
399		429
400	# translate global coordinates to local coordinate system	430	# translate global coordinates to local coordinate system
401	sub coord2local {	431	sub coord2local {
402	my ($self, $x, $y) = @_;	432	my ($self, $x, $y) = @_;
403		433
		434	Carp::confess unless $self->{parent};#d#
		435
404	$self->{parent}->coord2local ($x - $self->{x}, $y - $self->{y})	436	$self->{parent}->coord2local ($x - $self->{x}, $y - $self->{y})
405	}	437	}
406		438
407	# translate local coordinates to global coordinate system	439	# translate local coordinates to global coordinate system
408	sub coord2global {	440	sub coord2global {
409	my ($self, $x, $y) = @_;	441	my ($self, $x, $y) = @_;
410		442
		443	Carp::confess unless $self->{parent};#d#
		444
411	$self->{parent}->coord2global ($x + $self->{x}, $y + $self->{y})	445	$self->{parent}->coord2global ($x + $self->{x}, $y + $self->{y})
412	}	446	}
413		447
414	sub focus_in {	448	sub invoke_focus_in {
415	my ($self) = @_;	449	my ($self) = @_;
416		450
417	return if $FOCUS == $self;	451	return if $FOCUS == $self;
418	return unless $self->{can_focus};	452	return unless $self->{can_focus};
419		453
420	my $focus = $FOCUS; $FOCUS = $self;	454	$FOCUS = $self;
421		455
422	$self->_emit (focus_in => $focus);	456	$self->update;
423		457
424	$focus->update if $focus;	458	0
425	$FOCUS->update;
426	}	459	}
427		460
428	sub focus_out {	461	sub invoke_focus_out {
429	my ($self) = @_;	462	my ($self) = @_;
430		463
431	return unless $FOCUS == $self;	464	return unless $FOCUS == $self;
432		465
433	my $focus = $FOCUS; undef $FOCUS;	466	undef $FOCUS;
434		467
435	$self->_emit (focus_out => $focus);	468	$self->update;
436		469
437	$focus->update if $focus; #?
438
439	$::MAPWIDGET->focus_in #d# focus mapwidget if no other widget has focus	470	$::MAPWIDGET->grab_focus #d# focus mapwidget if no other widget has focus
440	unless $FOCUS;	471	unless $FOCUS;
441	}
442		472
		473	0
		474	}
		475
		476	sub grab_focus {
		477	my ($self) = @_;
		478
		479	$FOCUS->emit ("focus_out") if $FOCUS;
		480	$self->emit ("focus_in");
		481	}
		482
443	sub mouse_motion { }	483	sub invoke_mouse_motion { 0 }
444	sub button_up { }	484	sub invoke_button_up { 0 }
445	sub key_down { }	485	sub invoke_key_down { 0 }
446	sub key_up { }	486	sub invoke_key_up { 0 }
		487	sub invoke_mouse_wheel { 0 }
447		488
448	sub button_down {	489	sub invoke_button_down {
449	my ($self, $ev, $x, $y) = @_;	490	my ($self, $ev, $x, $y) = @_;
450		491
451	$self->focus_in;	492	$self->grab_focus;
452	}
453		493
454	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	494	0
455	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	495	}
456	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	496
457	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	497	sub connect {
458	sub z { $_[0]{z} = $_[1] if @_ > 1; $_[0]{z} }	498	my ($self, $signal, $cb) = @_;
		499
		500	push @{ $self->{signal_cb}{$signal} }, $cb;
		501
		502	defined wantarray and CFClient::guard {
		503	@{ $self->{signal_cb}{$signal} } = grep $_ != $cb,
		504	@{ $self->{signal_cb}{$signal} };
		505	}
		506	}
		507
		508	my %has_coords = (
		509	button_down => 1,
		510	button_up => 1,
		511	mouse_motion => 1,
		512	mouse_wheel => 1,
		513	);
		514
		515	sub emit {
		516	my ($self, $signal, @args) = @_;
		517
		518	# I do not really like this solution, but I dislike duplication
		519	# and needlessly verbose code, too.
		520	my @append
		521	= $has_coords{$signal}
		522	? $args[0]->xy ($self)
		523	: ();
		524
		525	#warn +(caller(1))[3] . "emit $signal on $self (parent $self->{parent})\n";#d#
		526
		527	#d##TODO# stop propagating at first true, do not use sum
		528	(List::Util::sum map $_->($self, @args, @append), @{$self->{signal_cb}{$signal} || []}) # before
		529	|| ($self->can ("invoke_$signal") || sub { 1 })->($self, @args, @append) # closure
		530	|| ($self->{parent} && $self->{parent}->emit ($signal, @args)) # parent
		531	}
459		532
460	sub find_widget {	533	sub find_widget {
461	my ($self, $x, $y) = @_;	534	my ($self, $x, $y) = @_;
462		535
463	return () unless $self->{can_events};	536	return () unless $self->{can_events};
…		…
472	sub set_parent {	545	sub set_parent {
473	my ($self, $parent) = @_;	546	my ($self, $parent) = @_;
474		547
475	Scalar::Util::weaken ($self->{parent} = $parent);	548	Scalar::Util::weaken ($self->{parent} = $parent);
476	$self->set_visible if $parent->{visible};	549	$self->set_visible if $parent->{visible};
477	}
478
479	sub connect {
480	my ($self, $signal, $cb) = @_;
481
482	push @{ $self->{signal_cb}{$signal} }, $cb;
483	}
484
485	sub _emit {
486	my ($self, $signal, @args) = @_;
487
488	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
489	}
490
491	sub emit {
492	my ($self, $signal, @args) = @_;
493
494	$self->_emit ($signal, @args)
495	|| $self->$signal (@args);
496	}
497
498	sub visibility_change {
499	#my ($self, $visible) = @_;
500	}	550	}
501		551
502	sub realloc {	552	sub realloc {
503	my ($self) = @_;	553	my ($self) = @_;
504		554
…		…
525		575
526	$self->realloc;	576	$self->realloc;
527	$self->update;	577	$self->update;
528	}	578	}
529		579
		580	# using global variables seems a bit hacky, but passing through all drawing
		581	# functions seems pointless.
		582	our ($draw_x, $draw_y, $draw_w, $draw_h); # screen rectangle being drawn
		583
530	sub draw {	584	sub draw {
531	my ($self) = @_;	585	my ($self) = @_;
532		586
533	return unless $self->{h} && $self->{w};	587	return unless $self->{h} && $self->{w};
		588
		589	# update screen rectangle
		590	local $draw_x = $draw_x + $self->{x};
		591	local $draw_y = $draw_y + $self->{y};
		592
		593	# skip widgets that are entirely outside the drawing area
		594	return if ($draw_x + $self->{w} < 0) || ($draw_x >= $draw_w)
		595	|| ($draw_y + $self->{h} < 0) || ($draw_y >= $draw_h);
534		596
535	glPushMatrix;	597	glPushMatrix;
536	glTranslate $self->{x}, $self->{y}, 0;	598	glTranslate $self->{x}, $self->{y}, 0;
537	$self->_draw;
538	glPopMatrix;
539		599
540	if ($self == $HOVER && $self->{can_hover}) {	600	if ($self == $HOVER && $self->{can_hover}) {
541	my ($x, $y) = @$self{qw(x y)};
542
543	glColor 1, 0.8, 0.5, 0.2;	601	glColor 1*0.2, 0.8*0.2, 0.5*0.2, 0.2;
544	glEnable GL_BLEND;	602	glEnable GL_BLEND;
545	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	603	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
546	glBegin GL_QUADS;	604	glBegin GL_QUADS;
547	glVertex $x , $y;	605	glVertex 0 , 0;
548	glVertex $x + $self->{w}, $y;	606	glVertex $self->{w}, 0;
549	glVertex $x + $self->{w}, $y + $self->{h};	607	glVertex $self->{w}, $self->{h};
550	glVertex $x , $y + $self->{h};	608	glVertex 0 , $self->{h};
551	glEnd;	609	glEnd;
552	glDisable GL_BLEND;	610	glDisable GL_BLEND;
553	}	611	}
554		612
555	if ($ENV{CFPLUS_DEBUG} & 1) {	613	if ($ENV{CFPLUS_DEBUG} & 1) {
556	glPushMatrix;	614	glPushMatrix;
557	glColor 1, 1, 0, 1;	615	glColor 1, 1, 0, 1;
558	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;	616	glTranslate 0.375, 0.375;
559	glBegin GL_LINE_LOOP;	617	glBegin GL_LINE_LOOP;
560	glVertex 0 , 0;	618	glVertex 0 , 0;
561	glVertex $self->{w} - 1, 0;	619	glVertex $self->{w} - 1, 0;
562	glVertex $self->{w} - 1, $self->{h} - 1;	620	glVertex $self->{w} - 1, $self->{h} - 1;
563	glVertex 0 , $self->{h} - 1;	621	glVertex 0 , $self->{h} - 1;
564	glEnd;	622	glEnd;
565	glPopMatrix;	623	glPopMatrix;
566	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;	624	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;
567	}	625	}
		626
		627	$self->_draw;
		628	glPopMatrix;
568	}	629	}
569		630
570	sub _draw {	631	sub _draw {
571	my ($self) = @_;	632	my ($self) = @_;
572		633
…		…
574	}	635	}
575		636
576	sub DESTROY {	637	sub DESTROY {
577	my ($self) = @_;	638	my ($self) = @_;
578		639
		640	return if CFClient::in_destruct;
		641
579	delete $WIDGET{$self+0};	642	delete $WIDGET{$self+0};
580	#$self->deactivate;	643
		644	eval { $self->destroy };
		645	warn "exception during widget destruction: $@" if $@ & $@ != /during global destruction/;
581	}	646	}
582		647
583	#############################################################################	648	#############################################################################
584		649
585	package CFClient::UI::DrawBG;	650	package CFClient::UI::DrawBG;
…		…
610		675
611	if ($color && (@$color < 4 || $color->[3])) {	676	if ($color && (@$color < 4 || $color->[3])) {
612	my ($w, $h) = @$self{qw(w h)};	677	my ($w, $h) = @$self{qw(w h)};
613		678
614	glEnable GL_BLEND;	679	glEnable GL_BLEND;
615	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	680	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
616	glColor @$color;	681	glColor_premultiply @$color;
617		682
618	glBegin GL_QUADS;	683	glBegin GL_QUADS;
619	glVertex 0 , 0;	684	glVertex 0 , 0;
620	glVertex 0 , $h;	685	glVertex 0 , $h;
621	glVertex $w, $h;	686	glVertex $w, $h;
…		…
652	our @ISA = CFClient::UI::Base::;	717	our @ISA = CFClient::UI::Base::;
653		718
654	sub new {	719	sub new {
655	my ($class, %arg) = @_;	720	my ($class, %arg) = @_;
656		721
657	my $children = delete $arg{children} || [];	722	my $children = delete $arg{children};
658		723
659	my $self = $class->SUPER::new (	724	my $self = $class->SUPER::new (
660	children => [],	725	children => [],
661	can_events => 0,	726	can_events => 0,
662	%arg,	727	%arg,
663	);	728	);
		729
664	$self->add ($_) for @$children;	730	$self->add (@$children)
		731	if $children;
665		732
666	$self	733	$self
		734	}
		735
		736	sub realloc {
		737	my ($self) = @_;
		738
		739	$self->{force_realloc} = 1;
		740	$self->{force_size_alloc} = 1;
		741	$self->SUPER::realloc;
667	}	742	}
668		743
669	sub add {	744	sub add {
670	my ($self, @widgets) = @_;	745	my ($self, @widgets) = @_;
671		746
…		…
717	$x -= $self->{x};	792	$x -= $self->{x};
718	$y -= $self->{y};	793	$y -= $self->{y};
719		794
720	my $res;	795	my $res;
721		796
722	for (reverse @{ $self->{children} }) {	797	for (reverse $self->visible_children) {
723	$res = $_->find_widget ($x, $y)	798	$res = $_->find_widget ($x, $y)
724	and return $res;	799	and return $res;
725	}	800	}
726		801
727	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})	802	$self->SUPER::find_widget ($x + $self->{x}, $y + $self->{y})
…		…
748	}	823	}
749		824
750	sub add {	825	sub add {
751	my ($self, $child) = @_;	826	my ($self, $child) = @_;
752		827
753	$self->{children} = [];	828	$self->SUPER::remove ($_) for @{ $self->{children} };
754
755	$self->SUPER::add ($child);	829	$self->SUPER::add ($child);
756	}	830	}
757		831
758	sub remove {	832	sub remove {
759	my ($self, $widget) = @_;	833	my ($self, $widget) = @_;
…		…
768		842
769	sub size_request {	843	sub size_request {
770	$_[0]{children}[0]->size_request	844	$_[0]{children}[0]->size_request
771	}	845	}
772		846
773	sub size_allocate {	847	sub invoke_size_allocate {
774	my ($self, $w, $h) = @_;	848	my ($self, $w, $h) = @_;
775		849
776	$self->{children}[0]->configure (0, 0, $w, $h);	850	$self->{children}[0]->configure (0, 0, $w, $h);
		851
		852	1
777	}	853	}
778		854
779	#############################################################################	855	#############################################################################
		856
		857	# back-buffered drawing area
780		858
781	package CFClient::UI::Window;	859	package CFClient::UI::Window;
782		860
783	our @ISA = CFClient::UI::Bin::;	861	our @ISA = CFClient::UI::Bin::;
784		862
…		…
795		873
796	$ROOT->on_post_alloc ($self => sub { $self->render_child });	874	$ROOT->on_post_alloc ($self => sub { $self->render_child });
797	$self->SUPER::update;	875	$self->SUPER::update;
798	}	876	}
799		877
800	sub size_allocate {	878	sub invoke_size_allocate {
801	my ($self, $w, $h) = @_;	879	my ($self, $w, $h) = @_;
802		880
803	$self->SUPER::size_allocate ($w, $h);
804	$self->update;	881	$self->update;
		882
		883	$self->SUPER::invoke_size_allocate ($w, $h)
805	}	884	}
806		885
807	sub _render {	886	sub _render {
		887	my ($self) = @_;
		888
808	$_[0]{children}[0]->draw;	889	$self->{children}[0]->draw;
809	}	890	}
810		891
811	sub render_child {	892	sub render_child {
812	my ($self) = @_;	893	my ($self) = @_;
813		894
814	$self->{texture} = new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {	895	$self->{texture} = new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {
815	glClearColor 0, 0, 0, 0;	896	glClearColor 0, 0, 0, 0;
816	glClear GL_COLOR_BUFFER_BIT;	897	glClear GL_COLOR_BUFFER_BIT;
817		898
		899	{
		900	package CFClient::UI::Base;
		901
		902	($draw_x, $draw_y, $draw_w, $draw_h) =
		903	(0, 0, $self->{w}, $self->{h});
		904	}
		905
818	$self->_render;	906	$self->_render;
819	};	907	};
820	}	908	}
821		909
822	sub _draw {	910	sub _draw {
823	my ($self) = @_;	911	my ($self) = @_;
824		912
825	my ($w, $h) = ($self->w, $self->h);	913	my ($w, $h) = @$self{qw(w h)};
826		914
827	my $tex = $self->{texture}	915	my $tex = $self->{texture}
828	or return;	916	or return;
829		917
830	glEnable GL_TEXTURE_2D;	918	glEnable GL_TEXTURE_2D;
831	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	919	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
832	glColor 1, 1, 1, 1;	920	glColor 0, 0, 0, 1;
833		921
834	$tex->draw_quad_alpha_premultiplied (0, 0, $w, $h);	922	$tex->draw_quad_alpha_premultiplied (0, 0, $w, $h);
835		923
836	glDisable GL_TEXTURE_2D;	924	glDisable GL_TEXTURE_2D;
837	}	925	}
…		…
861	$h = 10 if $self->{scroll_y};	949	$h = 10 if $self->{scroll_y};
862		950
863	($w, $h)	951	($w, $h)
864	}	952	}
865		953
866	sub size_allocate {	954	sub invoke_size_allocate {
867	my ($self, $w, $h) = @_;	955	my ($self, $w, $h) = @_;
868		956
869	my $child = $self->child;	957	my $child = $self->child;
870		958
871	$w = $child->{req_w} if $self->{scroll_x} && $child->{req_w};	959	$w = $child->{req_w} if $self->{scroll_x} && $child->{req_w};
872	$h = $child->{req_h} if $self->{scroll_y} && $child->{req_h};	960	$h = $child->{req_h} if $self->{scroll_y} && $child->{req_h};
873		961
874	$self->child->configure (0, 0, $w, $h);	962	$self->child->configure (0, 0, $w, $h);
875	$self->update;	963	$self->update;
		964
		965	1
876	}	966	}
877		967
878	sub set_offset {	968	sub set_offset {
879	my ($self, $x, $y) = @_;	969	my ($self, $x, $y) = @_;
880		970
…		…
913	}	1003	}
914		1004
915	sub _render {	1005	sub _render {
916	my ($self) = @_;	1006	my ($self) = @_;
917		1007
		1008	local $CFClient::UI::Base::draw_x = $CFClient::UI::Base::draw_x - $self->{view_x};
		1009	local $CFClient::UI::Base::draw_y = $CFClient::UI::Base::draw_y - $self->{view_y};
		1010
918	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};	1011	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};
919		1012
920	$self->SUPER::_render;	1013	$self->SUPER::_render;
921	}	1014	}
922		1015
…		…
925	package CFClient::UI::ScrolledWindow;	1018	package CFClient::UI::ScrolledWindow;
926		1019
927	our @ISA = CFClient::UI::HBox::;	1020	our @ISA = CFClient::UI::HBox::;
928		1021
929	sub new {	1022	sub new {
930	my $class = shift;	1023	my ($class, %arg) = @_;
		1024
		1025	my $child = delete $arg{child};
931		1026
932	my $self;	1027	my $self;
933		1028
934	my $slider = new CFClient::UI::Slider	1029	my $slider = new CFClient::UI::Slider
935	vertical => 1,	1030	vertical => 1,
…		…
938	$self->{vp}->set_offset (0, $_[1]);	1033	$self->{vp}->set_offset (0, $_[1]);
939	},	1034	},
940	;	1035	;
941		1036
942	$self = $class->SUPER::new (	1037	$self = $class->SUPER::new (
943	vp => (new CFClient::UI::ViewPort expand => 1),	1038	vp => (new CFClient::UI::ViewPort expand => 1),
		1039	can_events => 1,
944	slider => $slider,	1040	slider => $slider,
945	@_,	1041	%arg,
946	);	1042	);
947		1043
948	$self->{vp}->add ($self->{scrolled});
949	$self->add ($self->{vp});
950	$self->add ($self->{slider});	1044	$self->SUPER::add ($self->{vp}, $self->{slider});
		1045	$self->add ($child) if $child;
951		1046
952	$self	1047	$self
953	}	1048	}
954		1049
		1050	#TODO# update range on size_allocate depending on child
		1051
		1052	sub add {
		1053	my ($self, $widget) = @_;
		1054
		1055	$self->{vp}->add ($self->{child} = $widget);
		1056	}
		1057
		1058	sub invoke_mouse_wheel {
		1059	my ($self, $ev) = @_;
		1060
		1061	return 0 unless $ev->{dy}; # only vertical movements
		1062
		1063	$self->{slider}->emit (mouse_wheel => $ev);
		1064
		1065	1
		1066	}
		1067
		1068	sub update_slider {
		1069	my ($self) = @_;
		1070
		1071	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $self->{vp}->child->{h}, $self->{vp}{h}, 1]);
		1072	}
		1073
955	sub update {	1074	sub update {
956	my ($self) = @_;	1075	my ($self) = @_;
957		1076
958	$self->SUPER::update;	1077	$self->SUPER::update;
959		1078
960	# todo: overwrite size_allocate of child	1079	$self->update_slider;
961	my $child = $self->{vp}->child;
962	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
963	}	1080	}
964		1081
965	sub size_allocate {	1082	sub invoke_size_allocate {
966	my ($self, $w, $h) = @_;	1083	my ($self, $w, $h) = @_;
967		1084
		1085	$self->update_slider;
		1086
968	$self->SUPER::size_allocate ($w, $h);	1087	$self->SUPER::invoke_size_allocate ($w, $h)
969
970	my $child = $self->{vp}->child;
971	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
972	}	1088	}
973
974	#TODO# update range on size_allocate depending on child
975	# update viewport offset on scroll
976		1089
977	#############################################################################	1090	#############################################################################
978		1091
979	package CFClient::UI::Frame;	1092	package CFClient::UI::Frame;
980		1093
…		…
996		1109
997	if ($self->{bg}) {	1110	if ($self->{bg}) {
998	my ($w, $h) = @$self{qw(w h)};	1111	my ($w, $h) = @$self{qw(w h)};
999		1112
1000	glEnable GL_BLEND;	1113	glEnable GL_BLEND;
1001	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1114	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1002	glColor @{ $self->{bg} };	1115	glColor_premultiply @{ $self->{bg} };
1003		1116
1004	glBegin GL_QUADS;	1117	glBegin GL_QUADS;
1005	glVertex 0 , 0;	1118	glVertex 0 , 0;
1006	glVertex 0 , $h;	1119	glVertex 0 , $h;
1007	glVertex $w, $h;	1120	glVertex $w, $h;
…		…
1029	my @border =	1142	my @border =
1030	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }	1143	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
1031	qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);	1144	qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
1032		1145
1033	sub new {	1146	sub new {
1034	my $class = shift;	1147	my ($class, %arg) = @_;
1035		1148
1036	my $self = $class->SUPER::new (	1149	my $self = $class->SUPER::new (
1037	bg => [1, 1, 1, 1],	1150	bg => [1, 1, 1, 1],
1038	border_bg => [1, 1, 1, 1],	1151	border_bg => [1, 1, 1, 1],
1039	border => 0.6,	1152	border => 0.6,
1040	can_events => 1,	1153	can_events => 1,
1041	min_w => 16,	1154	min_w => 64,
1042	min_h => 16,	1155	min_h => 32,
1043	@_	1156	%arg,
1044	);	1157	);
1045		1158
1046	$self->{title} &&= new CFClient::UI::Label	1159	$self->{title_widget} = new CFClient::UI::Label
1047	align => 0,	1160	align => 0,
1048	valign => 1,	1161	valign => 1,
1049	text => $self->{title},	1162	text => $self->{title},
1050	fontsize => $self->{border};	1163	fontsize => $self->{border},
		1164	if exists $self->{title};
		1165
		1166	if ($self->{has_close_button}) {
		1167	$self->{close_button} =
		1168	new CFClient::UI::ImageButton
		1169	path => 'x1_close.png',
		1170	on_activate => sub { $self->emit ("delete") };
		1171
		1172	$self->CFClient::UI::Container::add ($self->{close_button});
		1173	}
1051		1174
1052	$self	1175	$self
		1176	}
		1177
		1178	sub add {
		1179	my ($self, @widgets) = @_;
		1180
		1181	$self->SUPER::add (@widgets);
		1182	$self->CFClient::UI::Container::add ($self->{close_button}) if $self->{close_button};
		1183	$self->CFClient::UI::Container::add ($self->{title_widget}) if $self->{title_widget};
1053	}	1184	}
1054		1185
1055	sub border {	1186	sub border {
1056	int $_[0]{border} * $::FONTSIZE	1187	int $_[0]{border} * $::FONTSIZE
1057	}	1188	}
1058		1189
1059	sub size_request {	1190	sub size_request {
1060	my ($self) = @_;	1191	my ($self) = @_;
		1192
		1193	$self->{title_widget}->size_request
		1194	if $self->{title_widget};
		1195
		1196	$self->{close_button}->size_request
		1197	if $self->{close_button};
1061		1198
1062	my ($w, $h) = $self->SUPER::size_request;	1199	my ($w, $h) = $self->SUPER::size_request;
1063		1200
1064	(	1201	(
1065	$w + $self->border * 2,	1202	$w + $self->border * 2,
1066	$h + $self->border * 2,	1203	$h + $self->border * 2,
1067	)	1204	)
1068	}	1205	}
1069		1206
1070	sub size_allocate {	1207	sub invoke_size_allocate {
1071	my ($self, $w, $h) = @_;	1208	my ($self, $w, $h) = @_;
1072		1209
		1210	if ($self->{title_widget}) {
		1211	$self->{title_widget}{w} = $w;
		1212	$self->{title_widget}{h} = $h;
		1213	$self->{title_widget}->invoke_size_allocate ($w, $h);
		1214	}
		1215
		1216	my $border = $self->border;
		1217
1073	$h -= List::Util::max 0, $self->border * 2;	1218	$h -= List::Util::max 0, $border * 2;
1074	$w -= List::Util::max 0, $self->border * 2;	1219	$w -= List::Util::max 0, $border * 2;
1075		1220
1076	$self->{title}->configure ($self->border, int $self->border - $::FONTSIZE * 2, $w, int $::FONTSIZE * 2)
1077	if $self->{title};
1078
1079	$self->child->configure ($self->border, $self->border, $w, $h);	1221	$self->child->configure ($border, $border, $w, $h);
1080	}
1081		1222
		1223	$self->{close_button}->configure ($self->{w} - $border, 0, $border, $border)
		1224	if $self->{close_button};
		1225
		1226	1
		1227	}
		1228
		1229	sub invoke_delete {
		1230	my ($self) = @_;
		1231
		1232	$self->hide;
		1233
		1234	1
		1235	}
		1236
1082	sub button_down {	1237	sub invoke_button_down {
1083	my ($self, $ev, $x, $y) = @_;	1238	my ($self, $ev, $x, $y) = @_;
1084		1239
1085	my ($w, $h) = @$self{qw(w h)};	1240	my ($w, $h) = @$self{qw(w h)};
1086	my $border = $self->border;	1241	my $border = $self->border;
1087		1242
…		…
1103	my $dy = $ev->{y} - $oy;	1258	my $dy = $ev->{y} - $oy;
1104		1259
1105	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);	1260	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
1106	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);	1261	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
1107		1262
		1263	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
1108	$self->realloc;	1264	$self->realloc;
1109	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
1110	};	1265	};
1111		1266
1112	} elsif ($lr ^ $td) {	1267	} elsif ($lr ^ $td) {
1113	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1268	my ($ox, $oy) = ($ev->{x}, $ev->{y});
1114	my ($bx, $by) = ($self->{x}, $self->{y});	1269	my ($bx, $by) = ($self->{x}, $self->{y});
…		…
1117	my ($ev, $x, $y) = @_;	1272	my ($ev, $x, $y) = @_;
1118		1273
1119	($x, $y) = ($ev->{x}, $ev->{y});	1274	($x, $y) = ($ev->{x}, $ev->{y});
1120		1275
1121	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);	1276	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
		1277	# HACK: the next line is required to enforce placement
		1278	$self->{parent}->invoke_size_allocate ($self->{parent}{w}, $self->{parent}{h});
1122	};	1279	};
		1280	} else {
		1281	return 0;
		1282	}
		1283
1123	}	1284	1
1124	}	1285	}
1125		1286
1126	sub button_up {	1287	sub invoke_button_up {
1127	my ($self, $ev, $x, $y) = @_;	1288	my ($self, $ev, $x, $y) = @_;
1128		1289
1129	delete $self->{motion};	1290	! ! delete $self->{motion}
1130	}	1291	}
1131		1292
1132	sub mouse_motion {	1293	sub invoke_mouse_motion {
1133	my ($self, $ev, $x, $y) = @_;	1294	my ($self, $ev, $x, $y) = @_;
1134		1295
1135	$self->{motion}->($ev, $x, $y) if $self->{motion};	1296	$self->{motion}->($ev, $x, $y) if $self->{motion};
		1297
		1298	! ! $self->{motion}
1136	}	1299	}
1137		1300
1138	sub _draw {	1301	sub _draw {
1139	my ($self) = @_;	1302	my ($self) = @_;
1140		1303
		1304	my $child = $self->{children}[0];
		1305
1141	my ($w, $h ) = ($self->{w}, $self->{h});	1306	my ($w, $h ) = ($self->{w}, $self->{h});
1142	my ($cw, $ch) = ($self->child->{w}, $self->child->{h});	1307	my ($cw, $ch) = ($child->{w}, $child->{h});
1143		1308
1144	glEnable GL_TEXTURE_2D;	1309	glEnable GL_TEXTURE_2D;
1145	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1310	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
1146		1311
1147	my $border = $self->border;	1312	my $border = $self->border;
…		…
1162	$bg->draw_quad_alpha ($border, $border, $cw, $ch);	1327	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
1163	}	1328	}
1164		1329
1165	glDisable GL_TEXTURE_2D;	1330	glDisable GL_TEXTURE_2D;
1166		1331
1167	$self->{title}->draw if $self->{title};
1168
1169	$self->child->draw;	1332	$child->draw;
		1333
		1334	if ($self->{title_widget}) {
		1335	glTranslate 0, $border - $self->{h};
		1336	$self->{title_widget}->_draw;
		1337
		1338	glTranslate 0, - ($border - $self->{h});
		1339	}
		1340
		1341	$self->{close_button}->draw
		1342	if $self->{close_button};
1170	}	1343	}
1171		1344
1172	#############################################################################	1345	#############################################################################
1173		1346
1174	package CFClient::UI::Table;	1347	package CFClient::UI::Table;
…		…
1191	sub children {	1364	sub children {
1192	grep $_, map @$_, grep $_, @{ $_[0]{children} }	1365	grep $_, map @$_, grep $_, @{ $_[0]{children} }
1193	}	1366	}
1194		1367
1195	sub add {	1368	sub add {
1196	my ($self, $x, $y, $child) = @_;	1369	my ($self) = shift;
1197		1370
		1371	while (@_) {
		1372	my ($x, $y, $child) = splice @_, 0, 3, ();
1198	$child->set_parent ($self);	1373	$child->set_parent ($self);
1199	$self->{children}[$y][$x] = $child;	1374	$self->{children}[$y][$x] = $child;
		1375	}
1200		1376
		1377	$self->{force_realloc} = 1;
		1378	$self->{force_size_alloc} = 1;
1201	$self->realloc;	1379	$self->realloc;
		1380	}
		1381
		1382	sub remove {
		1383	my ($self, $child) = @_;
		1384
		1385	# TODO: not yet implemented
1202	}	1386	}
1203		1387
1204	# TODO: move to container class maybe? send children a signal on removal?	1388	# TODO: move to container class maybe? send children a signal on removal?
1205	sub clear {	1389	sub clear {
1206	my ($self) = @_;	1390	my ($self) = @_;
…		…
1247	(sum @$ws),	1431	(sum @$ws),
1248	(sum @$hs),	1432	(sum @$hs),
1249	)	1433	)
1250	}	1434	}
1251		1435
1252	sub size_allocate {	1436	sub invoke_size_allocate {
1253	my ($self, $w, $h) = @_;	1437	my ($self, $w, $h) = @_;
1254		1438
1255	my ($ws, $hs) = $self->get_wh;	1439	my ($ws, $hs) = $self->get_wh;
1256		1440
1257	my $req_w = (sum @$ws) || 1;	1441	my $req_w = (sum @$ws) || 1;
…		…
1289	}	1473	}
1290		1474
1291	$y += $row_h;	1475	$y += $row_h;
1292	}	1476	}
1293		1477
		1478	1
1294	}	1479	}
1295		1480
1296	sub find_widget {	1481	sub find_widget {
1297	my ($self, $x, $y) = @_;	1482	my ($self, $x, $y) = @_;
1298		1483
…		…
1335	(List::Util::sum map $_->{req_w}, @{$self->{children}}),	1520	(List::Util::sum map $_->{req_w}, @{$self->{children}}),
1336	(List::Util::max map $_->{req_h}, @{$self->{children}}),	1521	(List::Util::max map $_->{req_h}, @{$self->{children}}),
1337	)	1522	)
1338	}	1523	}
1339		1524
1340	sub size_allocate {	1525	sub invoke_size_allocate {
1341	my ($self, $w, $h) = @_;	1526	my ($self, $w, $h) = @_;
1342		1527
1343	my $space = $self->{vertical} ? $h : $w;	1528	my $space = $self->{vertical} ? $h : $w;
1344	my $children = $self->{children};	1529	my @children = $self->visible_children;
1345		1530
1346	my @req;	1531	my @req;
1347		1532
1348	if ($self->{homogeneous}) {	1533	if ($self->{homogeneous}) {
1349	@req = ($space / (@$children || 1)) x @$children;	1534	@req = ($space / (@children || 1)) x @children;
1350	} else {	1535	} else {
1351	@req = map $_->{$self->{vertical} ? "req_h" : "req_w"}, @$children;	1536	@req = map $_->{$self->{vertical} ? "req_h" : "req_w"}, @children;
1352	my $req = List::Util::sum @req;	1537	my $req = List::Util::sum @req;
1353		1538
1354	if ($req > $space) {	1539	if ($req > $space) {
1355	# ah well, not enough space	1540	# ah well, not enough space
1356	$_ *= $space / $req for @req;	1541	$_ *= $space / $req for @req;
1357	} else {	1542	} else {
1358	my $expand = (List::Util::sum map $_->{expand}, @$children) || 1;	1543	my $expand = (List::Util::sum map $_->{expand}, @children) || 1;
1359		1544
1360	$space = ($space - $req) / $expand; # remaining space to give away	1545	$space = ($space - $req) / $expand; # remaining space to give away
1361		1546
1362	$req[$_] += $space * $children->[$_]{expand}	1547	$req[$_] += $space * $children[$_]{expand}
1363	for 0 .. $#$children;	1548	for 0 .. $#children;
1364	}	1549	}
1365	}	1550	}
1366		1551
1367	CFClient::UI::harmonize \@req;	1552	CFClient::UI::harmonize \@req;
1368		1553
1369	my $pos = 0;	1554	my $pos = 0;
1370	for (0 .. $#$children) {	1555	for (0 .. $#children) {
1371	my $alloc = $req[$_];	1556	my $alloc = $req[$_];
1372	$children->[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));	1557	$children[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));
1373		1558
1374	$pos += $alloc;	1559	$pos += $alloc;
1375	}	1560	}
1376		1561
1377	1	1562	1
…		…
1450	}	1635	}
1451		1636
1452	$self	1637	$self
1453	}	1638	}
1454		1639
1455	sub escape($) {
1456	local $_ = $_[0];
1457
1458	s/&/&amp;/g;
1459	s/>/&gt;/g;
1460	s/</&lt;/g;
1461
1462	$_
1463	}
1464
1465	sub update {	1640	sub update {
1466	my ($self) = @_;	1641	my ($self) = @_;
1467		1642
1468	delete $self->{texture};	1643	delete $self->{texture};
1469	$self->SUPER::update;	1644	$self->SUPER::update;
1470	}	1645	}
1471		1646
		1647	sub realloc {
		1648	my ($self) = @_;
		1649
		1650	delete $self->{ox};
		1651	$self->SUPER::realloc;
		1652	}
		1653
1472	sub set_text {	1654	sub set_text {
1473	my ($self, $text) = @_;	1655	my ($self, $text) = @_;
1474		1656
1475	return if $self->{text} eq "T$text";	1657	return if $self->{text} eq "T$text";
1476	$self->{text} = "T$text";	1658	$self->{text} = "T$text";
1477		1659
1478	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1479	$self->{layout}->set_text ($text);	1660	$self->{layout}->set_text ($text);
1480		1661
		1662	delete $self->{size_req};
1481	$self->realloc;	1663	$self->realloc;
1482	$self->update;	1664	$self->update;
1483	}	1665	}
1484		1666
1485	sub set_markup {	1667	sub set_markup {
…		…
1488	return if $self->{text} eq "M$markup";	1670	return if $self->{text} eq "M$markup";
1489	$self->{text} = "M$markup";	1671	$self->{text} = "M$markup";
1490		1672
1491	my $rgba = $markup =~ /span.*(?:foreground|background)/;	1673	my $rgba = $markup =~ /span.*(?:foreground|background)/;
1492		1674
1493	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;
1494	$self->{layout}->set_markup ($markup);	1675	$self->{layout}->set_markup ($markup);
1495		1676
		1677	delete $self->{size_req};
1496	$self->realloc;	1678	$self->realloc;
1497	$self->update;	1679	$self->update;
1498	}	1680	}
1499		1681
1500	sub size_request {	1682	sub size_request {
1501	my ($self) = @_;	1683	my ($self) = @_;
1502		1684
		1685	$self->{size_req} ||= do {
1503	$self->{layout}->set_font ($self->{font}) if $self->{font};	1686	$self->{layout}->set_font ($self->{font}) if $self->{font};
1504	$self->{layout}->set_width ($self->{max_w} || -1);	1687	$self->{layout}->set_width ($self->{max_w} || -1);
1505	$self->{layout}->set_ellipsise ($self->{ellipsise});	1688	$self->{layout}->set_ellipsise ($self->{ellipsise});
1506	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});	1689	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1507	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1690	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1508		1691
1509	my ($w, $h) = $self->{layout}->size;	1692	my ($w, $h) = $self->{layout}->size;
1510		1693
1511	if (exists $self->{template}) {	1694	if (exists $self->{template}) {
1512	$self->{template}->set_font ($self->{font}) if $self->{font};	1695	$self->{template}->set_font ($self->{font}) if $self->{font};
		1696	$self->{template}->set_width ($self->{max_w} || -1);
1513	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);	1697	$self->{template}->set_height ($self->{fontsize} * $::FONTSIZE);
1514		1698
1515	my ($w2, $h2) = $self->{template}->size;	1699	my ($w2, $h2) = $self->{template}->size;
1516		1700
1517	$w = List::Util::max $w, $w2;	1701	$w = List::Util::max $w, $w2;
1518	$h = List::Util::max $h, $h2;	1702	$h = List::Util::max $h, $h2;
		1703	}
		1704
		1705	[$w, $h]
1519	}	1706	};
1520		1707
1521	($w, $h)	1708	@{ $self->{size_req} }
1522	}	1709	}
1523		1710
		1711	sub baseline_shift {
		1712	$_[0]{layout}->descent
		1713	}
		1714
1524	sub size_allocate {	1715	sub invoke_size_allocate {
1525	my ($self, $w, $h) = @_;	1716	my ($self, $w, $h) = @_;
1526		1717
		1718	delete $self->{ox};
		1719
1527	delete $self->{texture}	1720	delete $self->{texture}
1528	;#d#	1721	unless $w >= $self->{req_w} && $self->{old_w} >= $self->{req_w};
		1722
		1723	1
1529	}	1724	}
1530		1725
1531	sub set_fontsize {	1726	sub set_fontsize {
1532	my ($self, $fontsize) = @_;	1727	my ($self, $fontsize) = @_;
1533		1728
1534	$self->{fontsize} = $fontsize;	1729	$self->{fontsize} = $fontsize;
		1730	delete $self->{size_req};
1535	delete $self->{texture};	1731	delete $self->{texture};
1536		1732
1537	$self->realloc;	1733	$self->realloc;
1538	}	1734	}
1539		1735
		1736	sub reconfigure {
		1737	my ($self) = @_;
		1738
		1739	delete $self->{size_req};
		1740	delete $self->{texture};
		1741
		1742	$self->SUPER::reconfigure;
		1743	}
		1744
1540	sub _draw {	1745	sub _draw {
1541	my ($self) = @_;	1746	my ($self) = @_;
1542		1747
1543	$self->SUPER::_draw; # draw background, if applicable	1748	$self->SUPER::_draw; # draw background, if applicable
1544		1749
1545	my $tex = $self->{texture} ||= do {	1750	my $size = $self->{texture} ||= do {
1546	$self->{layout}->set_foreground (@{$self->{fg}});	1751	$self->{layout}->set_foreground (@{$self->{fg}});
1547	$self->{layout}->set_font ($self->{font}) if $self->{font};	1752	$self->{layout}->set_font ($self->{font}) if $self->{font};
1548	$self->{layout}->set_width ($self->{w});	1753	$self->{layout}->set_width ($self->{w});
1549	$self->{layout}->set_ellipsise ($self->{ellipsise});	1754	$self->{layout}->set_ellipsise ($self->{ellipsise});
1550	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});	1755	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1551	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1756	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1552		1757
1553	my $tex = new_from_layout CFClient::Texture $self->{layout};	1758	[$self->{layout}->size]
		1759	};
1554		1760
		1761	unless (exists $self->{ox}) {
1555	$self->{ox} = int ($self->{align} < 0 ? $self->{padding_x}	1762	$self->{ox} = int ($self->{align} < 0 ? $self->{padding_x}
1556	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding_x}	1763	: $self->{align} > 0 ? $self->{w} - $size->[0] - $self->{padding_x}
1557	: ($self->{w} - $tex->{w}) * 0.5);	1764	: ($self->{w} - $size->[0]) * 0.5);
1558		1765
1559	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding_y}	1766	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding_y}
1560	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding_y}	1767	: $self->{valign} > 0 ? $self->{h} - $size->[1] - $self->{padding_y}
1561	: ($self->{h} - $tex->{h}) * 0.5);	1768	: ($self->{h} - $size->[1]) * 0.5);
1562
1563	$tex
1564	};	1769	};
1565		1770
1566	glEnable GL_TEXTURE_2D;	1771	my $w = List::Util::min $self->{w} + 4, $size->[0];
1567	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1772	my $h = List::Util::min $self->{h} + 2, $size->[1];
1568		1773
1569	if ($tex->{format} == GL_ALPHA) {	1774	$self->{layout}->render ($self->{ox}, $self->{oy});
1570	glColor @{$self->{fg}};
1571	$tex->draw_quad_alpha ($self->{ox}, $self->{oy});
1572	} else {
1573	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy});
1574	}
1575
1576	glDisable GL_TEXTURE_2D;
1577	}	1775	}
1578		1776
1579	#############################################################################	1777	#############################################################################
1580		1778
1581	package CFClient::UI::EntryBase;	1779	package CFClient::UI::EntryBase;
…		…
1595	can_hover => 1,	1793	can_hover => 1,
1596	can_focus => 1,	1794	can_focus => 1,
1597	valign => 0,	1795	valign => 0,
1598	can_events => 1,	1796	can_events => 1,
1599	#text => ...	1797	#text => ...
		1798	#hidden => "*",
1600	@_	1799	@_
1601	)	1800	)
1602	}	1801	}
1603		1802
1604	sub _set_text {	1803	sub _set_text {
…		…
1606		1805
1607	delete $self->{cur_h};	1806	delete $self->{cur_h};
1608		1807
1609	return if $self->{text} eq $text;	1808	return if $self->{text} eq $text;
1610		1809
1611	delete $self->{texture};
1612
1613	$self->{last_activity} = $::NOW;	1810	$self->{last_activity} = $::NOW;
1614	$self->{text} = $text;	1811	$self->{text} = $text;
1615		1812
1616	$text =~ s/./*/g if $self->{hidden};	1813	$text =~ s/./*/g if $self->{hidden};
1617	$self->{layout}->set_text ("$text ");	1814	$self->{layout}->set_text ("$text ");
		1815	delete $self->{size_req};
1618		1816
1619	$self->_emit (changed => $self->{text});	1817	$self->emit (changed => $self->{text});
		1818
		1819	$self->realloc;
		1820	$self->update;
1620	}	1821	}
1621		1822
1622	sub set_text {	1823	sub set_text {
1623	my ($self, $text) = @_;	1824	my ($self, $text) = @_;
1624		1825
1625	$self->{cursor} = length $text;	1826	$self->{cursor} = length $text;
1626	$self->_set_text ($text);	1827	$self->_set_text ($text);
1627
1628	$self->realloc;
1629	}	1828	}
1630		1829
1631	sub get_text {	1830	sub get_text {
1632	$_[0]{text}	1831	$_[0]{text}
1633	}	1832	}
…		…
1638	my ($w, $h) = $self->SUPER::size_request;	1837	my ($w, $h) = $self->SUPER::size_request;
1639		1838
1640	($w + 1, $h) # add 1 for cursor	1839	($w + 1, $h) # add 1 for cursor
1641	}	1840	}
1642		1841
1643	sub key_down {	1842	sub invoke_key_down {
1644	my ($self, $ev) = @_;	1843	my ($self, $ev) = @_;
1645		1844
1646	my $mod = $ev->{mod};	1845	my $mod = $ev->{mod};
1647	my $sym = $ev->{sym};	1846	my $sym = $ev->{sym};
1648	my $uni = $ev->{unicode};	1847	my $uni = $ev->{unicode};
…		…
1660	} elsif ($sym == CFClient::SDLK_HOME) {	1859	} elsif ($sym == CFClient::SDLK_HOME) {
1661	$self->{cursor} = 0;	1860	$self->{cursor} = 0;
1662	} elsif ($sym == CFClient::SDLK_END) {	1861	} elsif ($sym == CFClient::SDLK_END) {
1663	$self->{cursor} = length $text;	1862	$self->{cursor} = length $text;
1664	} elsif ($uni == 27) {	1863	} elsif ($uni == 27) {
1665	$self->_emit ('escape');	1864	$self->emit ('escape');
1666	} elsif ($uni) {	1865	} elsif ($uni) {
1667	substr $text, $self->{cursor}++, 0, chr $uni;	1866	substr $text, $self->{cursor}++, 0, chr $uni;
		1867	} else {
		1868	return 0;
1668	}	1869	}
1669		1870
1670	$self->_set_text ($text);	1871	$self->_set_text ($text);
1671		1872
1672	$self->realloc;	1873	$self->realloc;
1673	}
1674		1874
		1875	1
		1876	}
		1877
1675	sub focus_in {	1878	sub invoke_focus_in {
1676	my ($self) = @_;	1879	my ($self) = @_;
1677		1880
1678	$self->{last_activity} = $::NOW;	1881	$self->{last_activity} = $::NOW;
1679		1882
1680	$self->SUPER::focus_in;	1883	$self->SUPER::invoke_focus_in
1681	}	1884	}
1682		1885
1683	sub button_down {	1886	sub invoke_button_down {
1684	my ($self, $ev, $x, $y) = @_;	1887	my ($self, $ev, $x, $y) = @_;
1685		1888
1686	$self->SUPER::button_down ($ev, $x, $y);	1889	$self->SUPER::invoke_button_down ($ev, $x, $y);
1687		1890
1688	my $idx = $self->{layout}->xy_to_index ($x, $y);	1891	my $idx = $self->{layout}->xy_to_index ($x, $y);
1689		1892
1690	# byte-index to char-index	1893	# byte-index to char-index
1691	my $text = $self->{text};	1894	my $text = $self->{text};
1692	utf8::encode $text;	1895	utf8::encode $text; $text = substr $text, 0, $idx; utf8::decode $text;
1693	$self->{cursor} = length substr $text, 0, $idx;	1896	$self->{cursor} = length $text;
1694		1897
1695	$self->_set_text ($self->{text});	1898	$self->_set_text ($self->{text});
1696	$self->update;	1899	$self->update;
		1900
		1901	1
1697	}	1902	}
1698		1903
1699	sub mouse_motion {	1904	sub invoke_mouse_motion {
1700	my ($self, $ev, $x, $y) = @_;	1905	my ($self, $ev, $x, $y) = @_;
1701	# printf "M %d,%d %d,%d\n", $ev->motion_x, $ev->motion_y, $x, $y;#d#	1906	# printf "M %d,%d %d,%d\n", $ev->motion_x, $ev->motion_y, $x, $y;#d#
		1907
		1908	1
1702	}	1909	}
1703		1910
1704	sub _draw {	1911	sub _draw {
1705	my ($self) = @_;	1912	my ($self) = @_;
1706		1913
1707	local $self->{fg} = $self->{fg};	1914	local $self->{fg} = $self->{fg};
1708		1915
1709	if ($FOCUS == $self) {	1916	if ($FOCUS == $self) {
1710	glColor @{$self->{active_bg}};	1917	glColor_premultiply @{$self->{active_bg}};
1711	$self->{fg} = $self->{active_fg};	1918	$self->{fg} = $self->{active_fg};
1712	} else {	1919	} else {
1713	glColor @{$self->{bg}};	1920	glColor_premultiply @{$self->{bg}};
1714	}	1921	}
1715		1922
1716	glEnable GL_BLEND;	1923	glEnable GL_BLEND;
1717	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1924	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1718	glBegin GL_QUADS;	1925	glBegin GL_QUADS;
1719	glVertex 0 , 0;	1926	glVertex 0 , 0;
1720	glVertex 0 , $self->{h};	1927	glVertex 0 , $self->{h};
1721	glVertex $self->{w}, $self->{h};	1928	glVertex $self->{w}, $self->{h};
1722	glVertex $self->{w}, 0;	1929	glVertex $self->{w}, 0;
…		…
1747		1954
1748	our @ISA = CFClient::UI::EntryBase::;	1955	our @ISA = CFClient::UI::EntryBase::;
1749		1956
1750	use CFClient::OpenGL;	1957	use CFClient::OpenGL;
1751		1958
1752	sub key_down {	1959	sub invoke_key_down {
1753	my ($self, $ev) = @_;	1960	my ($self, $ev) = @_;
1754		1961
1755	my $sym = $ev->{sym};	1962	my $sym = $ev->{sym};
1756		1963
1757	if ($sym == 13) {	1964	if ($sym == 13) {
1758	unshift @{$self->{history}},	1965	unshift @{$self->{history}},
1759	my $txt = $self->get_text;	1966	my $txt = $self->get_text;
		1967
1760	$self->{history_pointer} = -1;	1968	$self->{history_pointer} = -1;
1761	$self->{history_saveback} = '';	1969	$self->{history_saveback} = '';
1762	$self->_emit (activate => $txt);	1970	$self->emit (activate => $txt);
1763	$self->update;	1971	$self->update;
1764		1972
1765	} elsif ($sym == CFClient::SDLK_UP) {	1973	} elsif ($sym == CFClient::SDLK_UP) {
1766	if ($self->{history_pointer} < 0) {	1974	if ($self->{history_pointer} < 0) {
1767	$self->{history_saveback} = $self->get_text;	1975	$self->{history_saveback} = $self->get_text;
…		…
1783	} else {	1991	} else {
1784	$self->set_text ($self->{history_saveback});	1992	$self->set_text ($self->{history_saveback});
1785	}	1993	}
1786		1994
1787	} else {	1995	} else {
1788	$self->SUPER::key_down ($ev);	1996	return $self->SUPER::invoke_key_down ($ev)
		1997	}
		1998
1789	}	1999	1
1790
1791	}	2000	}
1792		2001
1793	#############################################################################	2002	#############################################################################
1794		2003
1795	package CFClient::UI::Button;	2004	package CFClient::UI::Button;
…		…
1816	can_events => 1,	2025	can_events => 1,
1817	@_	2026	@_
1818	)	2027	)
1819	}	2028	}
1820		2029
1821	sub activate { }
1822
1823	sub button_up {	2030	sub invoke_button_up {
1824	my ($self, $ev, $x, $y) = @_;	2031	my ($self, $ev, $x, $y) = @_;
1825		2032
1826	$self->emit ("activate")	2033	$self->emit ("activate")
1827	if $x >= 0 && $x < $self->{w}	2034	if $x >= 0 && $x < $self->{w}
1828	&& $y >= 0 && $y < $self->{h};	2035	&& $y >= 0 && $y < $self->{h};
		2036
		2037	1
1829	}	2038	}
1830		2039
1831	sub _draw {	2040	sub _draw {
1832	my ($self) = @_;	2041	my ($self) = @_;
1833		2042
1834	local $self->{fg} = $self->{fg};	2043	local $self->{fg} = $GRAB == $self ? $self->{active_fg} : $self->{fg};
1835
1836	if ($GRAB == $self) {
1837	$self->{fg} = $self->{active_fg};
1838	}
1839		2044
1840	glEnable GL_TEXTURE_2D;	2045	glEnable GL_TEXTURE_2D;
1841	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2046	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1842	glColor 0, 0, 0, 1;	2047	glColor 0, 0, 0, 1;
1843		2048
…		…
1880	my ($self) = @_;	2085	my ($self) = @_;
1881		2086
1882	(6) x 2	2087	(6) x 2
1883	}	2088	}
1884		2089
		2090	sub toggle {
		2091	my ($self) = @_;
		2092
		2093	$self->{state} = !$self->{state};
		2094	$self->emit (changed => $self->{state});
		2095	$self->update;
		2096	}
		2097
1885	sub button_down {	2098	sub invoke_button_down {
1886	my ($self, $ev, $x, $y) = @_;	2099	my ($self, $ev, $x, $y) = @_;
1887		2100
1888	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}	2101	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1889	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {	2102	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1890	$self->{state} = !$self->{state};	2103	$self->toggle;
1891	$self->_emit (changed => $self->{state});	2104	} else {
		2105	return 0
		2106	}
		2107
1892	}	2108	1
1893	}	2109	}
1894		2110
1895	sub _draw {	2111	sub _draw {
1896	my ($self) = @_;	2112	my ($self) = @_;
1897		2113
…		…
1917	package CFClient::UI::Image;	2133	package CFClient::UI::Image;
1918		2134
1919	our @ISA = CFClient::UI::Base::;	2135	our @ISA = CFClient::UI::Base::;
1920		2136
1921	use CFClient::OpenGL;	2137	use CFClient::OpenGL;
1922	use Carp qw/confess/;
1923		2138
1924	our %loaded_images;	2139	our %texture_cache;
1925		2140
1926	sub new {	2141	sub new {
1927	my $class = shift;	2142	my $class = shift;
1928		2143
1929	my $self = $class->SUPER::new (can_events => 0, @_);	2144	my $self = $class->SUPER::new (
		2145	can_events => 0,
		2146	@_,
		2147	);
1930		2148
1931	$self->{image} or confess "Image has 'image' not set. This is a fatal error!";	2149	$self->{path} || $self->{tex}
		2150	or Carp::croak "'path' or 'tex' attributes required";
1932		2151
1933	$loaded_images{$self->{image}} ||=	2152	$self->{tex} ||= $texture_cache{$self->{path}} ||=
1934	new_from_file CFClient::Texture CFClient::find_rcfile $self->{image}, mipmap => 1;	2153	new_from_file CFClient::Texture CFClient::find_rcfile $self->{path}, mipmap => 1;
1935		2154
1936	my $tex = $self->{tex} = $loaded_images{$self->{image}};	2155	Scalar::Util::weaken $texture_cache{$self->{path}};
1937		2156
1938	Scalar::Util::weaken $loaded_images{$self->{image}};	2157	$self->{aspect} ||= $self->{tex}{w} / $self->{tex}{h};
1939
1940	$self->{aspect} = $tex->{w} / $tex->{h};
1941		2158
1942	$self	2159	$self
1943	}	2160	}
1944		2161
		2162	sub STORABLE_freeze {
		2163	my ($self, $cloning) = @_;
		2164
		2165	$self->{path}
		2166	or die "cannot serialise CFClient::UI::Image on non-loadable images\n";
		2167
		2168	$self->{path}
		2169	}
		2170
		2171	sub STORABLE_attach {
		2172	my ($self, $cloning, $path) = @_;
		2173
		2174	$self->new (path => $path)
		2175	}
		2176
1945	sub size_request {	2177	sub size_request {
1946	my ($self) = @_;	2178	my ($self) = @_;
1947		2179
1948	($self->{tex}->{w}, $self->{tex}->{h})	2180	($self->{tex}{w}, $self->{tex}{h})
1949	}	2181	}
1950		2182
1951	sub _draw {	2183	sub _draw {
1952	my ($self) = @_;	2184	my ($self) = @_;
1953		2185
…		…
1963	}	2195	}
1964		2196
1965	glEnable GL_TEXTURE_2D;	2197	glEnable GL_TEXTURE_2D;
1966	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2198	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1967		2199
1968	$tex->draw_quad_alpha (0, 0, $w, $h);	2200	$tex->draw_quad (0, 0, $w, $h);
1969		2201
1970	glDisable GL_TEXTURE_2D;	2202	glDisable GL_TEXTURE_2D;
		2203	}
		2204
		2205	#############################################################################
		2206
		2207	package CFClient::UI::ImageButton;
		2208
		2209	our @ISA = CFClient::UI::Image::;
		2210
		2211	use CFClient::OpenGL;
		2212
		2213	my %textures;
		2214
		2215	sub new {
		2216	my $class = shift;
		2217
		2218	my $self = $class->SUPER::new (
		2219	padding_x => 4,
		2220	padding_y => 4,
		2221	fg => [1, 1, 1],
		2222	active_fg => [0, 0, 1],
		2223	can_hover => 1,
		2224	align => 0,
		2225	valign => 0,
		2226	can_events => 1,
		2227	@_
		2228	);
		2229	}
		2230
		2231	sub invoke_button_up {
		2232	my ($self, $ev, $x, $y) = @_;
		2233
		2234	$self->emit ("activate")
		2235	if $x >= 0 && $x < $self->{w}
		2236	&& $y >= 0 && $y < $self->{h};
		2237
		2238	1
1971	}	2239	}
1972		2240
1973	#############################################################################	2241	#############################################################################
1974		2242
1975	package CFClient::UI::VGauge;	2243	package CFClient::UI::VGauge;
…		…
2062	my $ycut1 = max 0, min 1, $ycut;	2330	my $ycut1 = max 0, min 1, $ycut;
2063	my $ycut2 = max 0, min 1, $ycut - 1;	2331	my $ycut2 = max 0, min 1, $ycut - 1;
2064		2332
2065	my $h1 = $self->{h} * (1 - $ycut1);	2333	my $h1 = $self->{h} * (1 - $ycut1);
2066	my $h2 = $self->{h} * (1 - $ycut2);	2334	my $h2 = $self->{h} * (1 - $ycut2);
		2335	my $h3 = $self->{h};
		2336
		2337	$_ = $_ * (284-4)/288 + 4/288 for ($h1, $h2, $h3);
2067		2338
2068	glEnable GL_BLEND;	2339	glEnable GL_BLEND;
2069	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	2340	glBlendFuncSeparate GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA,
		2341	GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
2070	glEnable GL_TEXTURE_2D;	2342	glEnable GL_TEXTURE_2D;
2071	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2343	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2072		2344
2073	glBindTexture GL_TEXTURE_2D, $t1->{name};	2345	glBindTexture GL_TEXTURE_2D, $t1->{name};
2074	glBegin GL_QUADS;	2346	glBegin GL_QUADS;
…		…
2089		2361
2090	if ($t3) {	2362	if ($t3) {
2091	glBindTexture GL_TEXTURE_2D, $t3->{name};	2363	glBindTexture GL_TEXTURE_2D, $t3->{name};
2092	glBegin GL_QUADS;	2364	glBegin GL_QUADS;
2093	glTexCoord 0 , $t3->{t} * (1 - $ycut2); glVertex 0 , $h2;	2365	glTexCoord 0 , $t3->{t} * (1 - $ycut2); glVertex 0 , $h2;
2094	glTexCoord 0 , $t3->{t}; glVertex 0 , $self->{h};	2366	glTexCoord 0 , $t3->{t}; glVertex 0 , $h3;
2095	glTexCoord $t3->{s}, $t3->{t}; glVertex $w, $self->{h};	2367	glTexCoord $t3->{s}, $t3->{t}; glVertex $w, $h3;
2096	glTexCoord $t3->{s}, $t3->{t} * (1 - $ycut2); glVertex $w, $h2;	2368	glTexCoord $t3->{s}, $t3->{t} * (1 - $ycut2); glVertex $w, $h2;
2097	glEnd;	2369	glEnd;
2098	}	2370	}
2099		2371
2100	glDisable GL_BLEND;	2372	glDisable GL_BLEND;
…		…
2188	$self->update;	2460	$self->update;
2189		2461
2190	$self	2462	$self
2191	}	2463	}
2192		2464
2193	sub changed { }
2194
2195	sub set_range {	2465	sub set_range {
2196	my ($self, $range) = @_;	2466	my ($self, $range) = @_;
2197		2467
2198	($range, $self->{range}) = ($self->{range}, $range);	2468	($range, $self->{range}) = ($self->{range}, $range);
2199		2469
2200	$self->update
2201	if "@$range" ne "@{$self->{range}}";	2470	if ("@$range" ne "@{$self->{range}}") {
		2471	$self->update;
		2472	$self->set_value ($self->{range}[0]);
		2473	}
2202	}	2474	}
2203		2475
2204	sub set_value {	2476	sub set_value {
2205	my ($self, $value) = @_;	2477	my ($self, $value) = @_;
2206		2478
…		…
2217	if $unit;	2489	if $unit;
2218		2490
2219	@{$self->{range}} = ($value, $lo, $hi, $page, $unit);	2491	@{$self->{range}} = ($value, $lo, $hi, $page, $unit);
2220		2492
2221	if ($value != $old_value) {	2493	if ($value != $old_value) {
2222	$self->_emit (changed => $value);	2494	$self->emit (changed => $value);
2223	$self->update;	2495	$self->update;
2224	}	2496	}
2225	}	2497	}
2226		2498
2227	sub size_request {	2499	sub size_request {
2228	my ($self) = @_;	2500	my ($self) = @_;
2229		2501
2230	($self->{req_w}, $self->{req_h})	2502	($self->{req_w}, $self->{req_h})
2231	}	2503	}
2232		2504
2233	sub button_down {	2505	sub invoke_button_down {
2234	my ($self, $ev, $x, $y) = @_;	2506	my ($self, $ev, $x, $y) = @_;
2235		2507
2236	$self->SUPER::button_down ($ev, $x, $y);	2508	$self->SUPER::invoke_button_down ($ev, $x, $y);
2237		2509
2238	$self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x];	2510	$self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x];
2239		2511
2240	$self->mouse_motion ($ev, $x, $y);	2512	$self->invoke_mouse_motion ($ev, $x, $y)
2241	}	2513	}
2242		2514
2243	sub mouse_motion {	2515	sub invoke_mouse_motion {
2244	my ($self, $ev, $x, $y) = @_;	2516	my ($self, $ev, $x, $y) = @_;
2245		2517
2246	if ($GRAB == $self) {	2518	if ($GRAB == $self) {
2247	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});	2519	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});
2248		2520
2249	my (undef, $lo, $hi, $page) = @{$self->{range}};	2521	my (undef, $lo, $hi, $page) = @{$self->{range}};
2250		2522
2251	$x = ($x - $self->{click}[1]) / ($w * $self->{scale});	2523	$x = ($x - $self->{click}[1]) / ($w * $self->{scale});
2252		2524
2253	$self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo));	2525	$self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo));
		2526	} else {
		2527	return 0;
		2528	}
		2529
2254	}	2530	1
		2531	}
		2532
		2533	sub invoke_mouse_wheel {
		2534	my ($self, $ev) = @_;
		2535
		2536	my $delta = $self->{vertical} ? $ev->{dy} : $ev->{dx};
		2537
		2538	$self->set_value ($self->{range}[0] + $delta * $self->{range}[3] * 0.2);
		2539
		2540	! ! $delta
2255	}	2541	}
2256		2542
2257	sub update {	2543	sub update {
2258	my ($self) = @_;	2544	my ($self) = @_;
2259		2545
2260	$CFClient::UI::ROOT->on_post_alloc ($self => sub {	2546	delete $self->{knob_w};
		2547	$self->SUPER::update;
		2548	}
		2549
		2550	sub _draw {
		2551	my ($self) = @_;
		2552
		2553	unless ($self->{knob_w}) {
2261	$self->set_value ($self->{range}[0]);	2554	$self->set_value ($self->{range}[0]);
2262		2555
2263	my ($value, $lo, $hi, $page) = @{$self->{range}};	2556	my ($value, $lo, $hi, $page) = @{$self->{range}};
2264	my $range = ($hi - $page - $lo) || 1e-100;	2557	my $range = ($hi - $page - $lo) || 1e-100;
2265		2558
…		…
2271	$value = ($value - $lo) / $range;	2564	$value = ($value - $lo) / $range;
2272	$value = $value * $self->{scale} + $self->{offset};	2565	$value = $value * $self->{scale} + $self->{offset};
2273		2566
2274	$self->{knob_x} = $value - $knob_w * 0.5;	2567	$self->{knob_x} = $value - $knob_w * 0.5;
2275	$self->{knob_w} = $knob_w;	2568	$self->{knob_w} = $knob_w;
2276	});	2569	}
2277
2278	$self->SUPER::update;
2279	}
2280
2281	sub _draw {
2282	my ($self) = @_;
2283		2570
2284	$self->SUPER::_draw ();	2571	$self->SUPER::_draw ();
2285		2572
2286	glScale $self->{w}, $self->{h};	2573	glScale $self->{w}, $self->{h};
2287		2574
…		…
2348	sub set_range { shift->{slider}->set_range (@_) }	2635	sub set_range { shift->{slider}->set_range (@_) }
2349	sub set_value { shift->{slider}->set_value (@_) }	2636	sub set_value { shift->{slider}->set_value (@_) }
2350		2637
2351	#############################################################################	2638	#############################################################################
2352		2639
2353	package CFClient::UI::TextView;	2640	package CFClient::UI::TextScroller;
2354		2641
2355	our @ISA = CFClient::UI::HBox::;	2642	our @ISA = CFClient::UI::HBox::;
2356		2643
2357	use CFClient::OpenGL;	2644	use CFClient::OpenGL;
2358		2645
2359	sub new {	2646	sub new {
2360	my $class = shift;	2647	my $class = shift;
2361		2648
2362	my $self = $class->SUPER::new (	2649	my $self = $class->SUPER::new (
2363	fontsize => 1,	2650	fontsize => 1,
2364	can_events => 0,	2651	can_events => 1,
		2652	indent => 0,
2365	#font => default_font	2653	#font => default_font
2366	@_,	2654	@_,
2367		2655
2368	layout => (new CFClient::Layout 1),	2656	layout => (new CFClient::Layout),
2369	par => [],	2657	par => [],
2370	height => 0,	2658	height => 0,
2371	children => [	2659	children => [
2372	(new CFClient::UI::Empty expand => 1),	2660	(new CFClient::UI::Empty expand => 1),
2373	(new CFClient::UI::Slider vertical => 1),	2661	(new CFClient::UI::Slider vertical => 1),
…		…
2384		2672
2385	$self->{fontsize} = $fontsize;	2673	$self->{fontsize} = $fontsize;
2386	$self->reflow;	2674	$self->reflow;
2387	}	2675	}
2388		2676
		2677	sub size_request {
		2678	my ($self) = @_;
		2679
		2680	my ($empty, $slider) = @{ $self->{children} };
		2681
		2682	local $self->{children} = [$empty, $slider];
		2683	$self->SUPER::size_request
		2684	}
		2685
2389	sub size_allocate {	2686	sub invoke_size_allocate {
2390	my ($self, $w, $h) = @_;	2687	my ($self, $w, $h) = @_;
2391		2688
2392	$self->SUPER::size_allocate ($w, $h);	2689	my ($empty, $slider, @other) = @{ $self->{children} };
		2690	$_->configure (@$_{qw(x y req_w req_h)}) for @other;
2393		2691
2394	$self->{layout}->set_font ($self->{font}) if $self->{font};	2692	$self->{layout}->set_font ($self->{font}) if $self->{font};
2395	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	2693	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
2396	$self->{layout}->set_width ($self->{children}[0]{w});	2694	$self->{layout}->set_width ($empty->{w});
		2695	$self->{layout}->set_indent ($self->{fontsize} * $::FONTSIZE * $self->{indent});
2397		2696
2398	$self->reflow;	2697	$self->reflow;
2399	}
2400		2698
2401	sub text_size {	2699	local $self->{children} = [$empty, $slider];
		2700	$self->SUPER::invoke_size_allocate ($w, $h)
		2701	}
		2702
		2703	sub invoke_mouse_wheel {
2402	my ($self, $text, $indent) = @_;	2704	my ($self, $ev) = @_;
		2705
		2706	return 0 unless $ev->{dy}; # only vertical movements
		2707
		2708	$self->{children}[1]->emit (mouse_wheel => $ev);
		2709
		2710	1
		2711	}
		2712
		2713	sub get_layout {
		2714	my ($self, $para) = @_;
2403		2715
2404	my $layout = $self->{layout};	2716	my $layout = $self->{layout};
2405		2717
		2718	$layout->set_font ($self->{font}) if $self->{font};
		2719	$layout->set_foreground (@{$para->{fg}});
2406	$layout->set_height ($self->{fontsize} * $::FONTSIZE);	2720	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
2407	$layout->set_width ($self->{children}[0]{w} - $indent);	2721	$layout->set_width ($self->{children}[0]{w} - $para->{indent});
		2722	$layout->set_indent ($self->{fontsize} * $::FONTSIZE * $self->{indent});
2408	$layout->set_markup ($text);	2723	$layout->set_markup ($para->{markup});
		2724
		2725	$layout->set_shapes (
		2726	map
		2727	+(0, $_->baseline_shift +$_->{padding_y} - $_->{h}, $_->{w}, $_->{h}),
		2728	@{$para->{widget}}
2409		2729	);
		2730
2410	$layout->size	2731	$layout
2411	}	2732	}
2412		2733
2413	sub reflow {	2734	sub reflow {
2414	my ($self) = @_;	2735	my ($self) = @_;
2415		2736
…		…
2424	$self->{children}[1]->set_value ($offset);	2745	$self->{children}[1]->set_value ($offset);
2425	}	2746	}
2426		2747
2427	sub clear {	2748	sub clear {
2428	my ($self) = @_;	2749	my ($self) = @_;
		2750
		2751	my (undef, undef, @other) = @{ $self->{children} };
		2752	$self->remove ($_) for @other;
2429		2753
2430	$self->{par} = [];	2754	$self->{par} = [];
2431	$self->{height} = 0;	2755	$self->{height} = 0;
2432	$self->{children}[1]->set_range ([0, 0, 0, 1, 1]);	2756	$self->{children}[1]->set_range ([0, 0, 0, 1, 1]);
2433	}	2757	}
2434		2758
2435	sub add_paragraph {	2759	sub add_paragraph {
2436	my ($self, $color, $text, $indent) = @_;	2760	my ($self, $color, $para, $indent) = @_;
2437		2761
2438	for my $line (split /\n/, $text) {	2762	my ($text, @w) = ref $para ? @$para : $para;
2439	my ($w, $h) = $self->text_size ($line);	2763
2440	$self->{height} += $h;	2764	$para = {
2441	push @{$self->{par}}, [$w + $indent, $h, $color, $indent, $line];	2765	w => 1e10,
		2766	wrapped => 1,
		2767	fg => $color,
		2768	indent => $indent,
		2769	markup => $text,
		2770	widget => \@w,
2442	}	2771	};
2443		2772
2444	$self->{children}[1]->set_range ([$self->{height}, 0, $self->{height}, $self->{h}, 1]);	2773	$self->add (@w) if @w;
		2774	push @{$self->{par}}, $para;
		2775
		2776	$self->{need_reflow}++;
		2777	$self->update;
		2778	}
		2779
		2780	sub scroll_to_bottom {
		2781	my ($self) = @_;
		2782
		2783	$self->{scroll_to_bottom} = 1;
		2784	$self->update;
2445	}	2785	}
2446		2786
2447	sub update {	2787	sub update {
2448	my ($self) = @_;	2788	my ($self) = @_;
2449		2789
…		…
2451		2791
2452	return unless $self->{h} > 0;	2792	return unless $self->{h} > 0;
2453		2793
2454	delete $self->{texture};	2794	delete $self->{texture};
2455		2795
2456	$ROOT->on_post_alloc ($self, sub {	2796	$ROOT->on_post_alloc ($self => sub {
2457	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};	2797	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
2458		2798
2459	if (delete $self->{need_reflow}) {	2799	if (delete $self->{need_reflow}) {
2460	my $height = 0;	2800	my $height = 0;
2461		2801
2462	my $layout = $self->{layout};
2463
2464	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
2465
2466	for (@{$self->{par}}) {	2802	for my $para (@{$self->{par}}) {
2467	if (1 || $_->[0] >= $W) { # TODO: works,but needs reconfigure etc. support	2803	if ($para->{w} != $W && ($para->{wrapped} || $para->{w} > $W)) {
2468	$layout->set_width ($W - $_->[3]);	2804	my $layout = $self->get_layout ($para);
2469	$layout->set_markup ($_->[4]);
2470	my ($w, $h) = $layout->size;	2805	my ($w, $h) = $layout->size;
2471	$_->[0] = $w + $_->[3];	2806
2472	$_->[1] = $h;	2807	$para->{w} = $w + $para->{indent};
		2808	$para->{h} = $h;
		2809	$para->{wrapped} = $layout->has_wrapped;
2473	}	2810	}
2474		2811
2475	$height += $_->[1];	2812	$height += $para->{h};
2476	}	2813	}
2477		2814
2478	$self->{height} = $height;	2815	$self->{height} = $height;
2479		2816
2480	$self->{children}[1]->set_range ([$height, 0, $height, $H, 1]);	2817	$self->{children}[1]->set_range ([$self->{children}[1]{range}[0], 0, $height, $H, 1]);
2481		2818
2482	delete $self->{texture};	2819	delete $self->{texture};
2483	}	2820	}
2484		2821
		2822	if (delete $self->{scroll_to_bottom}) {
		2823	$self->{children}[1]->set_value (1e10);
		2824	}
		2825
2485	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {	2826	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {
2486	glClearColor 0.5, 0.5, 0.5, 0;	2827	glClearColor 0, 0, 0, 0;
2487	glClear GL_COLOR_BUFFER_BIT;	2828	glClear GL_COLOR_BUFFER_BIT;
2488		2829
2489	my $top = int $self->{children}[1]{range}[0];	2830	my $top = int $self->{children}[1]{range}[0];
2490		2831
2491	my $y0 = $top;	2832	my $y0 = $top;
2492	my $y1 = $top + $H;	2833	my $y1 = $top + $H;
2493		2834
2494	my $y = 0;	2835	my $y = 0;
2495		2836
2496	my $layout = $self->{layout};
2497
2498	$layout->set_font ($self->{font}) if $self->{font};
2499
2500	glEnable GL_BLEND;
2501	#TODO# not correct in windows where rgba is forced off
2502	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
2503
2504	for my $par (@{$self->{par}}) {	2837	for my $para (@{$self->{par}}) {
2505	my $h = $par->[1];	2838	my $h = $para->{h};
2506		2839
2507	if ($y0 < $y + $h && $y < $y1) {	2840	if ($y0 < $y + $h && $y < $y1) {
2508	$layout->set_foreground (@{ $par->[2] });
2509	$layout->set_width ($W - $par->[3]);
2510	$layout->set_markup ($par->[4]);
2511		2841
2512	my ($w, $h, $data, $format, $internalformat) = $layout->render;	2842	my $layout = $self->get_layout ($para);
2513		2843
2514	glRasterPos $par->[3], $y - $y0;	2844	$layout->render ($para->{indent}, $y - $y0);
2515	glDrawPixels $w, $h, $format, GL_UNSIGNED_BYTE, $data;	2845
		2846	if (my @w = @{ $para->{widget} }) {
		2847	my @s = $layout->get_shapes;
		2848
		2849	for (@w) {
		2850	my ($dx, $dy) = splice @s, 0, 2, ();
		2851
		2852	$_->{x} = $dx + $para->{indent};
		2853	$_->{y} = $dy + $y - $y0;
		2854
		2855	$_->draw;
		2856	}
		2857	}
2516	}	2858	}
2517		2859
2518	$y += $h;	2860	$y += $h;
2519	}	2861	}
2520
2521	glDisable GL_BLEND;
2522	};	2862	};
2523	});	2863	});
2524	}	2864	}
2525		2865
		2866	sub reconfigure {
		2867	my ($self) = @_;
		2868
		2869	$self->SUPER::reconfigure;
		2870
		2871	$_->{w} = 1e10 for @{ $self->{par} };
		2872	$self->reflow;
		2873	}
		2874
2526	sub _draw {	2875	sub _draw {
2527	my ($self) = @_;	2876	my ($self) = @_;
2528		2877
2529	glEnable GL_TEXTURE_2D;	2878	glEnable GL_TEXTURE_2D;
2530	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2879	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2531	glColor 1, 1, 1, 1;	2880	glColor 0, 0, 0, 1;
2532	$self->{texture}->draw_quad_alpha (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});	2881	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});
2533	glDisable GL_TEXTURE_2D;	2882	glDisable GL_TEXTURE_2D;
2534		2883
2535	$self->{children}[1]->draw;	2884	$self->{children}[1]->draw;
2536
2537	}	2885	}
2538		2886
2539	#############################################################################	2887	#############################################################################
2540		2888
2541	package CFClient::UI::Animator;	2889	package CFClient::UI::Animator;
…		…
2628	$tooltip .= "\n\n" . (ref $widget) . "\n"	2976	$tooltip .= "\n\n" . (ref $widget) . "\n"
2629	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"	2977	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"
2630	. "req $widget->{req_w} $widget->{req_h}\n"	2978	. "req $widget->{req_w} $widget->{req_h}\n"
2631	. "visible $widget->{visible}";	2979	. "visible $widget->{visible}";
2632	}	2980	}
		2981
		2982	$tooltip =~ s/^\n+//;
		2983	$tooltip =~ s/\n+$//;
2633		2984
2634	$self->add (new CFClient::UI::Label	2985	$self->add (new CFClient::UI::Label
2635	markup => $tooltip,	2986	markup => $tooltip,
2636	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,	2987	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2637	fontsize => 0.8,	2988	fontsize => 0.8,
…		…
2647	my ($w, $h) = @{$self->child}{qw(req_w req_h)};	2998	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
2648		2999
2649	($w + 4, $h + 4)	3000	($w + 4, $h + 4)
2650	}	3001	}
2651		3002
2652	sub size_allocate {	3003	sub invoke_size_allocate {
2653	my ($self, $w, $h) = @_;	3004	my ($self, $w, $h) = @_;
2654		3005
2655	$self->SUPER::size_allocate ($w - 4, $h - 4);	3006	$self->SUPER::invoke_size_allocate ($w - 4, $h - 4)
2656	}	3007	}
2657		3008
2658	sub visibility_change {	3009	sub invoke_visibility_change {
2659	my ($self, $visible) = @_;	3010	my ($self, $visible) = @_;
2660		3011
2661	return unless $visible;	3012	return unless $visible;
2662		3013
2663	$self->{root}->on_post_alloc ("move_$self" => sub {	3014	$self->{root}->on_post_alloc ("move_$self" => sub {
2664	my $widget = $self->{owner}	3015	my $widget = $self->{owner}
2665	or return;	3016	or return;
2666		3017
		3018	if ($widget->{visible}) {
2667	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);	3019	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
2668		3020
2669	($x, $y) = $widget->coord2global (-$self->{w}, 0)	3021	($x, $y) = $widget->coord2global (-$self->{w}, 0)
2670	if $x + $self->{w} > $::WIDTH;	3022	if $x + $self->{w} > $self->{root}{w};
2671		3023
2672	$self->move_abs ($x, $y);	3024	$self->move_abs ($x, $y);
		3025	} else {
		3026	$self->hide;
		3027	}
2673	});	3028	});
2674	}	3029	}
2675		3030
2676	sub _draw {	3031	sub _draw {
2677	my ($self) = @_;	3032	my ($self) = @_;
…		…
2703		3058
2704	#############################################################################	3059	#############################################################################
2705		3060
2706	package CFClient::UI::Face;	3061	package CFClient::UI::Face;
2707		3062
2708	our @ISA = CFClient::UI::Base::;	3063	our @ISA = CFClient::UI::DrawBG::;
2709		3064
2710	use CFClient::OpenGL;	3065	use CFClient::OpenGL;
2711		3066
2712	sub new {	3067	sub new {
2713	my $class = shift;	3068	my $class = shift;
…		…
2750	sub _draw {	3105	sub _draw {
2751	my ($self) = @_;	3106	my ($self) = @_;
2752		3107
2753	return unless $::CONN;	3108	return unless $::CONN;
2754		3109
		3110	$self->SUPER::_draw;
		3111
2755	my $face;	3112	my $face;
2756		3113
2757	if ($self->{frame}) {	3114	if ($self->{frame}) {
2758	my $anim = $::CONN->{anim}[$self->{anim}];	3115	my $anim = $::CONN->{anim}[$self->{anim}];
2759		3116
…		…
2764	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];	3121	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
2765		3122
2766	if ($tex) {	3123	if ($tex) {
2767	glEnable GL_TEXTURE_2D;	3124	glEnable GL_TEXTURE_2D;
2768	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	3125	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2769	glColor 1, 1, 1, 1;	3126	glColor 0, 0, 0, 1;
2770	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});	3127	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
2771	glDisable GL_TEXTURE_2D;	3128	glDisable GL_TEXTURE_2D;
2772	}	3129	}
2773	}	3130	}
2774		3131
2775	sub DESTROY {	3132	sub destroy {
2776	my ($self) = @_;	3133	my ($self) = @_;
2777		3134
2778	$self->{timer}->cancel	3135	$self->{timer}->cancel
2779	if $self->{timer};	3136	if $self->{timer};
2780		3137
2781	$self->SUPER::DESTROY;	3138	$self->SUPER::destroy;
2782	}	3139	}
2783		3140
2784	#############################################################################	3141	#############################################################################
2785		3142
2786	package CFClient::UI::Inventory;	3143	package CFClient::UI::Buttonbar;
2787		3144
2788	our @ISA = CFClient::UI::ScrolledWindow::;	3145	our @ISA = CFClient::UI::HBox::;
2789		3146
2790	sub new {	3147	# TODO: should actualyl wrap buttons and other goodies.
2791	my $class = shift;
2792
2793	my $self = $class->SUPER::new (
2794	scrolled => (new CFClient::UI::Table col_expand => [0, 1, 0]),
2795	@_,
2796	);
2797
2798	$self
2799	}
2800
2801	sub set_items {
2802	my ($self, $items) = @_;
2803
2804	$self->{scrolled}->clear;
2805	return unless $items;
2806
2807	my @items = sort {
2808	($a->{type} <=> $b->{type})
2809	or ($a->{name} cmp $b->{name})
2810	} @$items;
2811
2812	$self->{real_items} = \@items;
2813
2814	my $row = 0;
2815	for my $item (@items) {
2816	CFClient::Item::update_widgets $item;
2817
2818	$self->{scrolled}->add (0, $row, $item->{face_widget});
2819	$self->{scrolled}->add (1, $row, $item->{desc_widget});
2820	$self->{scrolled}->add (2, $row, $item->{weight_widget});
2821
2822	$row++;
2823	}
2824	}
2825		3148
2826	#############################################################################	3149	#############################################################################
2827		3150
2828	package CFClient::UI::Menu;	3151	package CFClient::UI::Menu;
2829		3152
…		…
2841	);	3164	);
2842		3165
2843	$self->add ($self->{vbox} = new CFClient::UI::VBox);	3166	$self->add ($self->{vbox} = new CFClient::UI::VBox);
2844		3167
2845	for my $item (@{ $self->{items} }) {	3168	for my $item (@{ $self->{items} }) {
2846	my ($widget, $cb) = @$item;	3169	my ($widget, $cb, $tooltip) = @$item;
2847		3170
2848	# handle various types of items, only text for now	3171	# handle various types of items, only text for now
2849	if (!ref $widget) {	3172	if (!ref $widget) {
		3173	if ($widget =~ /\t/) {
		3174	my ($left, $right) = split /\t/, $widget, 2;
		3175
		3176	$widget = new CFClient::UI::HBox
		3177	can_hover => 1,
		3178	can_events => 1,
		3179	tooltip => $tooltip,
		3180	children => [
		3181	(new CFClient::UI::Label markup => $left, expand => 1),
		3182	(new CFClient::UI::Label markup => $right, align => +1),
		3183	],
		3184	;
		3185
		3186	} else {
2850	$widget = new CFClient::UI::Label	3187	$widget = new CFClient::UI::Label
2851	can_hover => 1,	3188	can_hover => 1,
2852	can_events => 1,	3189	can_events => 1,
2853	text => $widget;	3190	markup => $widget,
		3191	tooltip => $tooltip;
		3192	}
2854	}	3193	}
2855		3194
2856	$self->{item}{$widget} = $item;	3195	$self->{item}{$widget} = $item;
2857		3196
2858	$self->{vbox}->add ($widget);	3197	$self->{vbox}->add ($widget);
…		…
2863		3202
2864	# popup given the event (must be a mouse button down event currently)	3203	# popup given the event (must be a mouse button down event currently)
2865	sub popup {	3204	sub popup {
2866	my ($self, $ev) = @_;	3205	my ($self, $ev) = @_;
2867		3206
2868	$self->_emit ("popdown");	3207	$self->emit ("popdown");
2869		3208
2870	# maybe save $GRAB? must be careful about events...	3209	# maybe save $GRAB? must be careful about events...
2871	$GRAB = $self;	3210	$GRAB = $self;
2872	$self->{button} = $ev->{button};	3211	$self->{button} = $ev->{button};
2873		3212
2874	$self->show;	3213	$self->show;
2875	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);	3214	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
2876	}	3215	}
2877		3216
2878	sub mouse_motion {	3217	sub invoke_mouse_motion {
2879	my ($self, $ev, $x, $y) = @_;	3218	my ($self, $ev, $x, $y) = @_;
2880		3219
2881	# TODO: should use vbox->find_widget or so	3220	# TODO: should use vbox->find_widget or so
2882	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});	3221	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
2883	$self->{hover} = $self->{item}{$HOVER};	3222	$self->{hover} = $self->{item}{$HOVER};
2884	}
2885		3223
		3224	0
		3225	}
		3226
2886	sub button_up {	3227	sub invoke_button_up {
2887	my ($self, $ev, $x, $y) = @_;	3228	my ($self, $ev, $x, $y) = @_;
2888		3229
2889	if ($ev->{button} == $self->{button}) {	3230	if ($ev->{button} == $self->{button}) {
2890	undef $GRAB;	3231	undef $GRAB;
2891	$self->hide;	3232	$self->hide;
2892		3233
2893	$self->_emit ("popdown");	3234	$self->emit ("popdown");
2894	$self->{hover}[1]->() if $self->{hover};	3235	$self->{hover}[1]->() if $self->{hover};
		3236	} else {
		3237	return 0
		3238	}
		3239
2895	}	3240	1
2896	}	3241	}
2897		3242
2898	#############################################################################	3243	#############################################################################
2899		3244
2900	package CFClient::UI::Statusbox;	3245	package CFClient::UI::Multiplexer;
2901		3246
2902	our @ISA = CFClient::UI::VBox::;	3247	our @ISA = CFClient::UI::Container::;
2903		3248
2904	sub new {	3249	sub new {
2905	my $class = shift;	3250	my $class = shift;
2906		3251
2907	$class->SUPER::new (	3252	my $self = $class->SUPER::new (
		3253	@_,
		3254	);
		3255
		3256	$self->{current} = $self->{children}[0]
		3257	if @{ $self->{children} };
		3258
		3259	$self
		3260	}
		3261
		3262	sub add {
		3263	my ($self, @widgets) = @_;
		3264
		3265	$self->SUPER::add (@widgets);
		3266
		3267	$self->{current} = $self->{children}[0]
		3268	if @{ $self->{children} };
		3269	}
		3270
		3271	sub get_current_page {
		3272	my ($self) = @_;
		3273
		3274	$self->{current}
		3275	}
		3276
		3277	sub set_current_page {
		3278	my ($self, $page_or_widget) = @_;
		3279
		3280	my $widget = ref $page_or_widget
		3281	? $page_or_widget
		3282	: $self->{children}[$page_or_widget];
		3283
		3284	$self->{current} = $widget;
		3285	$self->{current}->configure (0, 0, $self->{w}, $self->{h});
		3286
		3287	$self->emit (page_changed => $self->{current});
		3288
		3289	$self->realloc;
		3290	}
		3291
		3292	sub visible_children {
		3293	$_[0]{current}
		3294	}
		3295
		3296	sub size_request {
		3297	my ($self) = @_;
		3298
		3299	$self->{current}->size_request
		3300	}
		3301
		3302	sub invoke_size_allocate {
		3303	my ($self, $w, $h) = @_;
		3304
		3305	$self->{current}->configure (0, 0, $w, $h);
		3306
		3307	1
		3308	}
		3309
		3310	sub _draw {
		3311	my ($self) = @_;
		3312
		3313	$self->{current}->draw;
		3314	}
		3315
		3316	#############################################################################
		3317
		3318	package CFClient::UI::Notebook;
		3319
		3320	our @ISA = CFClient::UI::VBox::;
		3321
		3322	sub new {
		3323	my $class = shift;
		3324
		3325	my $self = $class->SUPER::new (
		3326	buttonbar => (new CFClient::UI::Buttonbar),
		3327	multiplexer => (new CFClient::UI::Multiplexer expand => 1),
		3328	# filter => # will be put between multiplexer and $self
		3329	@_,
		3330	);
		3331
		3332	$self->{filter}->add ($self->{multiplexer}) if $self->{filter};
		3333	$self->SUPER::add ($self->{buttonbar}, $self->{filter} || $self->{multiplexer});
		3334
		3335	$self
		3336	}
		3337
		3338	sub add {
		3339	my ($self, $title, $widget, $tooltip) = @_;
		3340
		3341	Scalar::Util::weaken $self;
		3342
		3343	$self->{buttonbar}->add (new CFClient::UI::Button
		3344	markup => $title,
		3345	tooltip => $tooltip,
		3346	on_activate => sub { $self->set_current_page ($widget) },
		3347	);
		3348
		3349	$self->{multiplexer}->add ($widget);
		3350	}
		3351
		3352	sub get_current_page {
		3353	my ($self) = @_;
		3354
		3355	$self->{multiplexer}->get_current_page
		3356	}
		3357
		3358	sub set_current_page {
		3359	my ($self, $page) = @_;
		3360
		3361	$self->{multiplexer}->set_current_page ($page);
		3362	$self->emit (page_changed => $self->{multiplexer}{current});
		3363	}
		3364
		3365	#############################################################################
		3366
		3367	package CFClient::UI::Selector;
		3368
		3369	use utf8;
		3370
		3371	our @ISA = CFClient::UI::Button::;
		3372
		3373	sub new {
		3374	my $class = shift;
		3375
		3376	my $self = $class->SUPER::new (
		3377	options => [], # [value, title, longdesc], ...
		3378	value => undef,
		3379	@_,
		3380	);
		3381
		3382	$self->_set_value ($self->{value});
		3383
		3384	$self
		3385	}
		3386
		3387	sub invoke_button_down {
		3388	my ($self, $ev) = @_;
		3389
		3390	my @menu_items;
		3391
		3392	for (@{ $self->{options} }) {
		3393	my ($value, $title, $tooltip) = @$_;
		3394
		3395	push @menu_items, [$tooltip || $title, sub { $self->set_value ($value) }];
		3396	}
		3397
		3398	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
		3399	}
		3400
		3401	sub _set_value {
		3402	my ($self, $value) = @_;
		3403
		3404	my ($item) = grep $_->[0] eq $value, @{ $self->{options} }
		3405	or return;
		3406
		3407	$self->{value} = $item->[0];
		3408	$self->set_markup ("$item->[1] ⇓");
		3409	$self->set_tooltip ($item->[2]);
		3410	}
		3411
		3412	sub set_value {
		3413	my ($self, $value) = @_;
		3414
		3415	return unless $self->{value} ne $value;
		3416
		3417	$self->_set_value ($value);
		3418	$self->emit (changed => $value);
		3419	}
		3420
		3421	#############################################################################
		3422
		3423	package CFClient::UI::Statusbox;
		3424
		3425	our @ISA = CFClient::UI::VBox::;
		3426
		3427	sub new {
		3428	my $class = shift;
		3429
		3430	my $self = $class->SUPER::new (
2908	fontsize => 0.8,	3431	fontsize => 0.8,
2909	@_,	3432	@_,
2910	)	3433	);
		3434
		3435	Scalar::Util::weaken (my $this = $self);
		3436
		3437	$self->{timer} = Event->timer (after => 1, interval => 1, cb => sub { $this->reorder });
		3438
		3439	$self
2911	}	3440	}
2912		3441
2913	sub reorder {	3442	sub reorder {
2914	my ($self) = @_;	3443	my ($self) = @_;
2915	my $NOW = time;	3444	my $NOW = Time::HiRes::time;
		3445
		3446	# freeze display when hovering over any label
		3447	return if $CFClient::UI::TOOLTIP->{owner}
		3448	&& grep $CFClient::UI::TOOLTIP->{owner} == $_->{label},
		3449	values %{ $self->{item} };
2916		3450
2917	while (my ($k, $v) = each %{ $self->{item} }) {	3451	while (my ($k, $v) = each %{ $self->{item} }) {
2918	delete $self->{item}{$k} if $v->{timeout} < $NOW;	3452	delete $self->{item}{$k} if $v->{timeout} < $NOW;
2919	}	3453	}
2920		3454
…		…
2923	my @items = sort {	3457	my @items = sort {
2924	$a->{pri} <=> $b->{pri}	3458	$a->{pri} <=> $b->{pri}
2925	or $b->{id} <=> $a->{id}	3459	or $b->{id} <=> $a->{id}
2926	} values %{ $self->{item} };	3460	} values %{ $self->{item} };
2927		3461
		3462	$self->{timer}->interval (1);
		3463
2928	my $count = 10 + 1;	3464	my $count = 10 + 1;
2929	for my $item (@items) {	3465	for my $item (@items) {
2930	last unless --$count;	3466	last unless --$count;
2931		3467
2932	push @widgets, $item->{label} ||= do {	3468	my $label = $item->{label} ||= do {
2933	# TODO: doesn't handle markup well (read as: at all)	3469	# TODO: doesn't handle markup well (read as: at all)
2934	my $short = $item->{count} > 1	3470	my $short = $item->{count} > 1
2935	? "<b>$item->{count} ×</b> $item->{text}"	3471	? "<b>$item->{count} ×</b> $item->{text}"
2936	: $item->{text};	3472	: $item->{text};
2937		3473
…		…
2945	tooltip => $item->{tooltip},	3481	tooltip => $item->{tooltip},
2946	tooltip_font => $::FONT_PROP,	3482	tooltip_font => $::FONT_PROP,
2947	tooltip_width => 0.67,	3483	tooltip_width => 0.67,
2948	fontsize => $item->{fontsize} || $self->{fontsize},	3484	fontsize => $item->{fontsize} || $self->{fontsize},
2949	max_w => $::WIDTH * 0.44,	3485	max_w => $::WIDTH * 0.44,
2950	fg => $item->{fg},	3486	fg => [@{ $item->{fg} }],
2951	can_events => 1,	3487	can_events => 1,
2952	can_hover => 1	3488	can_hover => 1
2953	};	3489	};
		3490
		3491	if ((my $diff = $item->{timeout} - $NOW) < 2) {
		3492	$label->{fg}[3] = ($item->{fg}[3] || 1) * $diff / 2;
		3493	$label->update;
		3494	$label->set_max_size (undef, $label->{req_h} * $diff)
		3495	if $diff < 1;
		3496	$self->{timer}->interval (1/30);
		3497	} else {
		3498	$label->{fg}[3] = $item->{fg}[3] || 1;
		3499	}
		3500
		3501	push @widgets, $label;
2954	}	3502	}
2955		3503
2956	$self->clear;	3504	$self->clear;
2957	$self->SUPER::add (reverse @widgets);	3505	$self->SUPER::add (reverse @widgets);
2958	}	3506	}
…		…
2963	$text =~ s/^\s+//;	3511	$text =~ s/^\s+//;
2964	$text =~ s/\s+$//;	3512	$text =~ s/\s+$//;
2965		3513
2966	return unless $text;	3514	return unless $text;
2967		3515
2968	my $timeout = time + ((delete $arg{timeout}) || 60);	3516	my $timeout = (int time) + ((delete $arg{timeout}) || 60);
2969		3517
2970	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};	3518	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
2971		3519
2972	if (my $item = $self->{item}{$group}) {	3520	if (my $item = $self->{item}{$group}) {
2973	if ($item->{text} eq $text) {	3521	if ($item->{text} eq $text) {
2974	$item->{count}++;	3522	$item->{count}++;
2975	} else {	3523	} else {
2976	$item->{count} = 1;	3524	$item->{count} = 1;
2977	$item->{text} = $item->{tooltip} = $text;	3525	$item->{text} = $item->{tooltip} = $text;
2978	}	3526	}
2979	$item->{id} = ++$self->{id};	3527	$item->{id} += 0.2;#d#
2980	$item->{timeout} = $timeout;	3528	$item->{timeout} = $timeout;
2981	delete $item->{label};	3529	delete $item->{label};
2982	} else {	3530	} else {
2983	$self->{item}{$group} = {	3531	$self->{item}{$group} = {
2984	id => ++$self->{id},	3532	id => ++$self->{id},
…		…
2990	count => 1,	3538	count => 1,
2991	%arg,	3539	%arg,
2992	};	3540	};
2993	}	3541	}
2994		3542
		3543	$ROOT->on_refresh (reorder => sub {
2995	$self->reorder;	3544	$self->reorder;
		3545	});
2996	}	3546	}
2997		3547
2998	sub reconfigure {	3548	sub reconfigure {
2999	my ($self) = @_;	3549	my ($self) = @_;
3000		3550
…		…
3003		3553
3004	$self->reorder;	3554	$self->reorder;
3005	$self->SUPER::reconfigure;	3555	$self->SUPER::reconfigure;
3006	}	3556	}
3007		3557
		3558	sub destroy {
		3559	my ($self) = @_;
		3560
		3561	$self->{timer}->cancel;
		3562
		3563	$self->SUPER::destroy;
		3564	}
		3565
3008	#############################################################################	3566	#############################################################################
3009		3567
		3568	package CFClient::UI::Inventory;
		3569
		3570	our @ISA = CFClient::UI::Table::;
		3571
		3572	sub new {
		3573	my $class = shift;
		3574
		3575	my $self = $class->SUPER::new (
		3576	col_expand => [0, 1, 0],
		3577	items => [],
		3578	@_,
		3579	);
		3580
		3581	$self->set_sort_order (undef);
		3582
		3583	$self
		3584	}
		3585
		3586	sub update_items {
		3587	my ($self) = @_;
		3588
		3589	$self->clear;
		3590
		3591	my @item = $self->{sort}->(@{ $self->{items} });
		3592
		3593	my @adds;
		3594	my $row = 0;
		3595	for my $item ($self->{sort}->(@{ $self->{items} })) {
		3596	CFClient::Item::update_widgets $item;
		3597
		3598	push @adds, 0, $row, $item->{face_widget};
		3599	push @adds, 1, $row, $item->{desc_widget};
		3600	push @adds, 2, $row, $item->{weight_widget};
		3601
		3602	$row++;
		3603	}
		3604
		3605	$self->add (@adds);
		3606	}
		3607
		3608	sub set_sort_order {
		3609	my ($self, $order) = @_;
		3610
		3611	$self->{sort} = $order ||= sub {
		3612	sort {
		3613	$a->{type} <=> $b->{type}
		3614	or $a->{name} cmp $b->{name}
		3615	} @_
		3616	};
		3617
		3618	$self->update_items;
		3619	}
		3620
		3621	sub set_items {
		3622	my ($self, $items) = @_;
		3623
		3624	$self->{items} = [$items ? values %$items : ()];
		3625	$self->update_items;
		3626	}
		3627
		3628	#############################################################################
		3629
		3630	package CFClient::UI::SpellList;
		3631
		3632	our @ISA = CFClient::UI::Table::;
		3633
		3634	sub new {
		3635	my $class = shift;
		3636
		3637	my $self = $class->SUPER::new (
		3638	binding => [],
		3639	commands => [],
		3640	@_,
		3641	)
		3642	}
		3643
		3644	my $TOOLTIP_ALL = "\n\n<small>Left click - ready spell\nMiddle click - invoke spell\nRight click - further options</small>";
		3645
		3646	my @TOOLTIP_NAME = (align => -1, can_events => 1, can_hover => 1, tooltip =>
		3647	"<b>Name</b>. The name of the spell.$TOOLTIP_ALL");
		3648	my @TOOLTIP_SKILL = (align => -1, can_events => 1, can_hover => 1, tooltip =>
		3649	"<b>Skill</b>. The skill (or magic school) required to be able to attempt casting this spell.$TOOLTIP_ALL");
		3650	my @TOOLTIP_LVL = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3651	"<b>Level</b>. Minimum level the caster needs in the associated skill to be able to attempt casting this spell.$TOOLTIP_ALL");
		3652	my @TOOLTIP_SP = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3653	"<b>Spell points / Grace points</b>. Amount of spell or grace points used by each invocation.$TOOLTIP_ALL");
		3654	my @TOOLTIP_DMG = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3655	"<b>Damage</b>. The amount of damage the spell deals when it hits.$TOOLTIP_ALL");
		3656
		3657	sub rebuild_spell_list {
		3658	my ($self) = @_;
		3659
		3660	$CFClient::UI::ROOT->on_refresh ($self => sub {
		3661	$self->clear;
		3662
		3663	return unless $::CONN;
		3664
		3665	$self->add (1, 0, new CFClient::UI::Label text => "Spell Name", @TOOLTIP_NAME);
		3666	$self->add (2, 0, new CFClient::UI::Label text => "Skill", @TOOLTIP_SKILL);
		3667	$self->add (3, 0, new CFClient::UI::Label text => "Lvl" , @TOOLTIP_LVL);
		3668	$self->add (4, 0, new CFClient::UI::Label text => "Sp/Gp", @TOOLTIP_SP);
		3669	$self->add (5, 0, new CFClient::UI::Label text => "Dmg" , @TOOLTIP_DMG);
		3670
		3671	my $row = 0;
		3672
		3673	for (sort { $a cmp $b } keys %{ $self->{spell} }) {
		3674	my $spell = $self->{spell}{$_};
		3675
		3676	$row++;
		3677
		3678	my $spell_cb = sub {
		3679	my ($widget, $ev) = @_;
		3680
		3681	if ($ev->{button} == 1) {
		3682	$::CONN->user_send ("cast $spell->{name}");
		3683	} elsif ($ev->{button} == 2) {
		3684	$::CONN->user_send ("invoke $spell->{name}");
		3685	} elsif ($ev->{button} == 3) {
		3686	(new CFClient::UI::Menu
		3687	items => [
		3688	["bind <i>cast $spell->{name}</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) }],
		3689	["bind <i>invoke $spell->{name}</i> to a key" => sub { $::BIND_EDITOR->do_quick_binding (["invoke $spell->{name}"]) }],
		3690	],
		3691	)->popup ($ev);
		3692	} else {
		3693	return 0;
		3694	}
		3695
		3696	1
		3697	};
		3698
		3699	my $tooltip = "$spell->{message}$TOOLTIP_ALL";
		3700
		3701	#TODO: add path info to tooltip
		3702	#$self->add (6, $row, new CFClient::UI::Label text => $spell->{path});
		3703
		3704	$self->add (0, $row, new CFClient::UI::Face
		3705	face => $spell->{face},
		3706	can_hover => 1,
		3707	can_events => 1,
		3708	tooltip => $tooltip,
		3709	on_button_down => $spell_cb,
		3710	);
		3711
		3712	$self->add (1, $row, new CFClient::UI::Label
		3713	expand => 1,
		3714	text => $spell->{name},
		3715	can_hover => 1,
		3716	can_events => 1,
		3717	tooltip => $tooltip,
		3718	on_button_down => $spell_cb,
		3719	);
		3720
		3721	$self->add (2, $row, new CFClient::UI::Label text => $::CONN->{skill_info}{$spell->{skill}}, @TOOLTIP_SKILL);
		3722	$self->add (3, $row, new CFClient::UI::Label text => $spell->{level}, @TOOLTIP_LVL);
		3723	$self->add (4, $row, new CFClient::UI::Label text => $spell->{mana} || $spell->{grace}, @TOOLTIP_SP);
		3724	$self->add (5, $row, new CFClient::UI::Label text => $spell->{damage}, @TOOLTIP_DMG);
		3725	}
		3726	});
		3727	}
		3728
		3729	sub add_spell {
		3730	my ($self, $spell) = @_;
		3731
		3732	$self->{spell}->{$spell->{name}} = $spell;
		3733	$self->rebuild_spell_list;
		3734	}
		3735
		3736	sub remove_spell {
		3737	my ($self, $spell) = @_;
		3738
		3739	delete $self->{spell}->{$spell->{name}};
		3740	$self->rebuild_spell_list;
		3741	}
		3742
		3743	sub clear_spells {
		3744	my ($self) = @_;
		3745
		3746	$self->{spell} = {};
		3747	$self->rebuild_spell_list;
		3748	}
		3749
		3750	#############################################################################
		3751
3010	package CFClient::UI::Root;	3752	package CFClient::UI::Root;
3011		3753
3012	our @ISA = CFClient::UI::Container::;	3754	our @ISA = CFClient::UI::Container::;
		3755
		3756	use List::Util qw(min max);
3013		3757
3014	use CFClient::OpenGL;	3758	use CFClient::OpenGL;
3015		3759
3016	sub new {	3760	sub new {
3017	my $class = shift;	3761	my $class = shift;
…		…
3044	$coord = $max - $size if $coord > $max - $size;	3788	$coord = $max - $size if $coord > $max - $size;
3045		3789
3046	int $coord + 0.5	3790	int $coord + 0.5
3047	}	3791	}
3048		3792
3049	sub size_allocate {	3793	sub invoke_size_allocate {
3050	my ($self, $w, $h) = @_;	3794	my ($self, $w, $h) = @_;
3051		3795
3052	for my $child ($self->children) {	3796	for my $child ($self->children) {
3053	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};	3797	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};
3054		3798
…		…
3058	$X = _to_pixel $X, $W, $self->{w};	3802	$X = _to_pixel $X, $W, $self->{w};
3059	$Y = _to_pixel $Y, $H, $self->{h};	3803	$Y = _to_pixel $Y, $H, $self->{h};
3060		3804
3061	$child->configure ($X, $Y, $W, $H);	3805	$child->configure ($X, $Y, $W, $H);
3062	}	3806	}
		3807
		3808	1
3063	}	3809	}
3064		3810
3065	sub coord2local {	3811	sub coord2local {
3066	my ($self, $x, $y) = @_;	3812	my ($self, $x, $y) = @_;
3067		3813
…		…
3123	$_->()	3869	$_->()
3124	for values %{delete $self->{refresh_hook}};	3870	for values %{delete $self->{refresh_hook}};
3125	}	3871	}
3126		3872
3127	if ($self->{realloc}) {	3873	if ($self->{realloc}) {
		3874	my %queue;
3128	my @queue;	3875	my @queue;
		3876	my $widget;
3129		3877
		3878	outer:
3130	while () {	3879	while () {
3131	if ($self->{realloc}) {	3880	if (my $realloc = delete $self->{realloc}) {
3132	#TODO use array-of-depth approach	3881	for $widget (values %$realloc) {
		3882	$widget->{visible} or next; # do not resize invisible widgets
3133		3883
3134	use sort 'stable';	3884	$queue{$widget+0}++ and next; # duplicates are common
3135		3885
3136	@queue = sort { $a->{visible} <=> $b->{visible} }	3886	push @{ $queue[$widget->{visible}] }, $widget;
3137	@queue, values %{delete $self->{realloc}};	3887	}
3138	}	3888	}
3139		3889
		3890	while () {
		3891	@queue or last outer;
		3892
3140	my $widget = pop @queue || last;	3893	$widget = pop @{ $queue[-1] || [] }
		3894	and last;
		3895
		3896	pop @queue;
		3897	}
3141		3898
3142	$widget->{visible} or last; # do not resize invisible widgets	3899	delete $queue{$widget+0};
3143		3900
3144	my ($w, $h) = $widget->size_request;	3901	my ($w, $h) = $widget->size_request;
3145		3902
3146	$w = List::Util::max $widget->{min_w}, $w + $widget->{padding_x} * 2;	3903	$w = max $widget->{min_w}, $w + $widget->{padding_x} * 2;
3147	$h = List::Util::max $widget->{min_h}, $h + $widget->{padding_y} * 2;	3904	$h = max $widget->{min_h}, $h + $widget->{padding_y} * 2;
		3905
		3906	$w = min $widget->{max_w}, $w if exists $widget->{max_w};
		3907	$h = min $widget->{max_h}, $h if exists $widget->{max_h};
3148		3908
3149	$w = $widget->{force_w} if exists $widget->{force_w};	3909	$w = $widget->{force_w} if exists $widget->{force_w};
3150	$h = $widget->{force_h} if exists $widget->{force_h};	3910	$h = $widget->{force_h} if exists $widget->{force_h};
3151		3911
3152	if ($widget->{req_w} != $w || $widget->{req_h} != $h	3912	if ($widget->{req_w} != $w || $widget->{req_h} != $h
…		…
3155	$widget->{req_h} = $h;	3915	$widget->{req_h} = $h;
3156		3916
3157	$self->{size_alloc}{$widget+0} = $widget;	3917	$self->{size_alloc}{$widget+0} = $widget;
3158		3918
3159	if (my $parent = $widget->{parent}) {	3919	if (my $parent = $widget->{parent}) {
3160	$self->{realloc}{$parent+0} = $parent;	3920	$self->{realloc}{$parent+0} = $parent
3161	#unshift @queue, $parent;	3921	unless $queue{$parent+0};
		3922
3162	$parent->{force_size_alloc} = 1;	3923	$parent->{force_size_alloc} = 1;
3163	$self->{size_alloc}{$parent+0} = $parent;	3924	$self->{size_alloc}{$parent+0} = $parent;
3164	}	3925	}
3165	}	3926	}
3166		3927
…		…
3178	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};	3939	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};
3179		3940
3180	$w = 0 if $w < 0;	3941	$w = 0 if $w < 0;
3181	$h = 0 if $h < 0;	3942	$h = 0 if $h < 0;
3182		3943
		3944	$w = max $widget->{min_w}, $w;
		3945	$h = max $widget->{min_h}, $h;
		3946
		3947	# $w = min $self->{w} - $widget->{x}, $w if $self->{w};
		3948	# $h = min $self->{h} - $widget->{y}, $h if $self->{h};
		3949
		3950	$w = min $widget->{max_w}, $w if exists $widget->{max_w};
		3951	$h = min $widget->{max_h}, $h if exists $widget->{max_h};
		3952
3183	$w = int $w + 0.5;	3953	$w = int $w + 0.5;
3184	$h = int $h + 0.5;	3954	$h = int $h + 0.5;
3185		3955
3186	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {	3956	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {
		3957	$widget->{old_w} = $widget->{w};
		3958	$widget->{old_h} = $widget->{h};
		3959
3187	$widget->{w} = $w;	3960	$widget->{w} = $w;
3188	$widget->{h} = $h;	3961	$widget->{h} = $h;
3189		3962
3190	$widget->emit (size_allocate => $w, $h);	3963	$widget->emit (size_allocate => $w, $h);
3191	}	3964	}
…		…
3206	glLoadIdentity;	3979	glLoadIdentity;
3207	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;	3980	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
3208	glMatrixMode GL_MODELVIEW;	3981	glMatrixMode GL_MODELVIEW;
3209	glLoadIdentity;	3982	glLoadIdentity;
3210		3983
		3984	{
		3985	package CFClient::UI::Base;
		3986
		3987	($draw_x, $draw_y, $draw_w, $draw_h) =
		3988	(0, 0, $self->{w}, $self->{h});
		3989	}
		3990
3211	$self->_draw;	3991	$self->_draw;
3212	}
3213
3214	#############################################################################
3215
3216	package CFClient::UI::SpellList;
3217
3218	our @ISA = CFClient::UI::FancyFrame::;
3219
3220	sub new {
3221	my $class = shift;
3222
3223	my $self = $class->SUPER::new (binding => [], commands => [], @_);
3224
3225	$self->add (new CFClient::UI::ScrolledWindow
3226	scrolled => $self->{spellbox} = new CFClient::UI::Table);
3227
3228	$self;
3229	}
3230
3231	# XXX: Do sorting? Argl...
3232	sub add_spell {
3233	my ($self, $spell) = @_;
3234	$self->{spells}->{$spell->{name}} = $spell;
3235
3236	$self->{spellbox}->add (0, $self->{tbl_idx}, new CFClient::UI::Face
3237	face => $spell->{face},
3238	can_hover => 1,
3239	can_events => 1,
3240	tooltip => $spell->{message});
3241
3242	$self->{spellbox}->add (1, $self->{tbl_idx}, new CFClient::UI::Label
3243	text => $spell->{name},
3244	can_hover => 1,
3245	can_events => 1,
3246	tooltip => $spell->{message},
3247	expand => 1);
3248
3249	$self->{spellbox}->add (2, $self->{tbl_idx}, new CFClient::UI::Label
3250	text => (sprintf "lvl: %2d sp: %2d dmg: %2d",
3251	$spell->{level}, ($spell->{mana} || $spell->{grace}), $spell->{damage}),
3252	expand => 1);
3253
3254	$self->{spellbox}->add (3, $self->{tbl_idx}++, new CFClient::UI::Button
3255	text => "bind to key",
3256	on_activate => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) });
3257	}
3258
3259	sub rebuild_spell_list {
3260	my ($self) = @_;
3261	$self->{tbl_idx} = 0;
3262	$self->add_spell ($_) for values %{$self->{spells}};
3263	}
3264
3265	sub remove_spell {
3266	my ($self, $spell) = @_;
3267	delete $self->{spells}->{$spell->{name}};
3268	$self->rebuild_spell_list;
3269	}
3270
3271	#############################################################################
3272
3273	package CFClient::UI::BindEditor;
3274
3275	our @ISA = CFClient::UI::FancyFrame::;
3276
3277	sub new {
3278	my $class = shift;
3279
3280	my $self = $class->SUPER::new (binding => [], commands => [], @_);
3281
3282	$self->add (my $vb = new CFClient::UI::VBox);
3283
3284
3285	$vb->add ($self->{rec_btn} = new CFClient::UI::Button
3286	text => "start recording",
3287	tooltip => "Start/Stops recording of actions."
3288	."All subsequent actions after the recording started will be captured."
3289	."The actions are displayed after the record was stopped."
3290	."To bind the action you have to click on the 'Bind' button",
3291	on_activate => sub {
3292	unless ($self->{recording}) {
3293	$self->start;
3294	} else {
3295	$self->stop;
3296	}
3297	});
3298
3299	$vb->add (new CFClient::UI::Label text => "Actions:");
3300	$vb->add ($self->{cmdbox} = new CFClient::UI::VBox);
3301
3302	$vb->add (new CFClient::UI::Label text => "Bound to: ");
3303	$vb->add (my $hb = new CFClient::UI::HBox);
3304	$hb->add ($self->{keylbl} = new CFClient::UI::Label expand => 1);
3305	$hb->add (new CFClient::UI::Button
3306	text => "bind",
3307	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
3308	on_activate => sub {
3309	$self->ask_for_bind;
3310	});
3311
3312	$vb->add (my $hb = new CFClient::UI::HBox);
3313	$hb->add (new CFClient::UI::Button
3314	text => "ok",
3315	expand => 1,
3316	tooltip => "This closes the binding editor and saves the binding",
3317	on_activate => sub {
3318	$self->hide;
3319	$self->commit;
3320	});
3321
3322	$hb->add (new CFClient::UI::Button
3323	text => "cancel",
3324	expand => 1,
3325	tooltip => "This closes the binding editor without saving",
3326	on_activate => sub {
3327	$self->hide;
3328	$self->{binding_cancel}->()
3329	if $self->{binding_cancel};
3330	});
3331
3332	$self->update_binding_widgets;
3333
3334	$self
3335	}
3336
3337	sub commit {
3338	my ($self) = @_;
3339	my ($mod, $sym, $cmds) = $self->get_binding;
3340	if ($sym != 0 && @$cmds > 0) {
3341	$::STATUSBOX->add ("Bound actions to '".CFClient::Binder::keycombo_to_name ($mod, $sym)
3342	."'. Don't forget 'Save Config'!");
3343	$self->{binding_change}->($mod, $sym, $cmds)
3344	if $self->{binding_change};
3345	} else {
3346	$::STATUSBOX->add ("No action bound, no key or action specified!");
3347	$self->{binding_cancel}->()
3348	if $self->{binding_cancel};
3349	}
3350	}
3351
3352	sub start {
3353	my ($self) = @_;
3354
3355	$self->{rec_btn}->set_text ("stop recording");
3356	$self->{recording} = 1;
3357	$self->clear_command_list;
3358	$::CONN->start_record if $::CONN;
3359	}
3360
3361	sub stop {
3362	my ($self) = @_;
3363
3364	$self->{rec_btn}->set_text ("start recording");
3365	$self->{recording} = 0;
3366
3367	my $rec;
3368	$rec = $::CONN->stop_record if $::CONN;
3369	return unless ref $rec eq 'ARRAY';
3370	$self->set_command_list ($rec);
3371	}
3372
3373	# if $commit is true, the binding will be set after the user entered a key combo
3374	sub ask_for_bind {
3375	my ($self, $commit) = @_;
3376
3377	CFClient::Binder::open_binding_dialog (sub {
3378	my ($mod, $sym) = @_;
3379	$self->{binding} = [$mod, $sym]; # XXX: how to stop that memleak?
3380	$self->update_binding_widgets;
3381	$self->commit if $commit;
3382	});
3383	}
3384
3385	# $mod and $sym are the modifiers and key symbol
3386	# $cmds is a array ref of strings (the commands)
3387	# $cb is the callback that is executed on OK
3388	# $ccb is the callback that is executed on CANCEL and
3389	# when the binding was unsuccessful on OK
3390	sub set_binding {
3391	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
3392
3393	$self->clear_command_list;
3394	$self->{recording} = 0;
3395	$self->{rec_btn}->set_text ("start recording");
3396
3397	$self->{binding} = [$mod, $sym];
3398	$self->{commands} = $cmds;
3399
3400	$self->{binding_change} = $cb;
3401	$self->{binding_cancel} = $ccb;
3402
3403	$self->update_binding_widgets;
3404	}
3405
3406	# this is a shortcut method that asks for a binding
3407	# and then just binds it.
3408	sub do_quick_binding {
3409	my ($self, $cmds) = @_;
3410	$self->set_binding (undef, undef, $cmds, sub {
3411	$::CFG->{bindings}->{$_[0]}->{$_[1]} = $_[2];
3412	});
3413	$self->ask_for_bind (1);
3414	}
3415
3416	sub update_binding_widgets {
3417	my ($self) = @_;
3418	my ($mod, $sym, $cmds) = $self->get_binding;
3419	$self->{keylbl}->set_text (CFClient::Binder::keycombo_to_name ($mod, $sym));
3420	$self->set_command_list ($cmds);
3421	}
3422
3423	sub get_binding {
3424	my ($self) = @_;
3425	return (
3426	$self->{binding}->[0],
3427	$self->{binding}->[1],
3428	[ grep { defined $_ } @{$self->{commands}} ]
3429	);
3430	}
3431
3432	sub clear_command_list {
3433	my ($self) = @_;
3434	$self->{cmdbox}->clear ();
3435	}
3436
3437	sub set_command_list {
3438	my ($self, $cmds) = @_;
3439
3440	$self->{cmdbox}->clear ();
3441	$self->{commands} = $cmds;
3442
3443	my $idx = 0;
3444
3445	for (@$cmds) {
3446	$self->{cmdbox}->add (my $hb = new CFClient::UI::HBox);
3447
3448	my $i = $idx;
3449	$hb->add (new CFClient::UI::Label text => $_);
3450	$hb->add (new CFClient::UI::Button
3451	text => "delete",
3452	tooltip => "Deletes the action from the record",
3453	on_activate => sub {
3454	$self->{cmdbox}->remove ($hb);
3455	$cmds->[$i] = undef;
3456	});
3457
3458
3459	$idx++
3460	}
3461	}	3992	}
3462		3993
3463	#############################################################################	3994	#############################################################################
3464		3995
3465	package CFClient::UI;	3996	package CFClient::UI;

Diff Legend

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