[ViewVC] Diff of: cvs/deliantra/Deliantra-Client/DC.pm

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.18 by root, Mon Apr 10 11:55:16 2006 UTC vs.
Revision 1.80 by elmex, Tue May 30 08:12:50 2006 UTC

…		…
1	=head1 NAME	1	=head1 NAME
2		2
3	Crossfire::Client - undocumented utility garbage for our crossfire client	3	CFClient - undocumented utility garbage for our crossfire client
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use Crossfire::Client;	7	use CFClient;
8		8
9	=head1 DESCRIPTION	9	=head1 DESCRIPTION
10		10
11	=over 4	11	=over 4
12		12
13	=cut	13	=cut
14		14
15	package Crossfire::Client;	15	package CFClient;
16		16
17	BEGIN {	17	BEGIN {
18	$VERSION = '0.1';	18	$VERSION = '0.1';
19		19
20	use XSLoader;	20	use XSLoader;
21	XSLoader::load "Crossfire::Client", $VERSION;	21	XSLoader::load "CFClient", $VERSION;
22	}	22	}
		23
		24	use utf8;
		25
		26	use Carp ();
		27	use AnyEvent ();
		28	use BerkeleyDB;
23		29
24	sub find_rcfile($) {	30	sub find_rcfile($) {
25	my $path;	31	my $path;
26		32
27	for (@INC) {	33	for (grep !ref, @INC) {
28	$path = "$_/Crossfire/resources/$_[0]";	34	$path = "$_/CFClient/resources/$_[0]";
29	return $path if -r $path;	35	return $path if -r $path;
30	}	36	}
31		37
32	die "FATAL: can't find required file $_[0]\n";	38	die "FATAL: can't find required file $_[0]\n";
33	}	39	}
62	}	68	}
63		69
64	close CFG;	70	close CFG;
65	}	71	}
66		72
67	package Crossfire::Client::Texture;	73	mkdir "$Crossfire::VARDIR/cfplus", 0777;
68		74
69	use Scalar::Util;	75	our $DB_ENV;
70		76
71	use SDL::OpenGL;	77	{
		78	use strict;
72		79
73	my @textures;	80	my $recover = $BerkeleyDB::db_version >= 4.4
		81	? eval "DB_REGISTER \| DB_RECOVER"
		82	: 0;
74		83
75	sub new {	84	$DB_ENV = new BerkeleyDB::Env
76	my ($class, %data) = @_;	85	-Home => "$Crossfire::VARDIR/cfplus",
		86	-Cachesize => 1_000_000,
		87	-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
		88	# -ErrPrefix => "DATABASE",
		89	-Verbose => 1,
		90	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN \| $recover,
		91	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE,
		92	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
		93	}
77		94
78	my $self = bless {	95	sub db_table($) {
79	internalformat => GL_RGBA,	96	my ($table) = @_;
80	format => GL_RGBA,	97
		98	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
		99
		100	new CFClient::Database
		101	-Env => $DB_ENV,
		102	-Filename => $table,
		103	# -Filename => "database",
		104	# -Subname => $table,
		105	-Property => DB_CHKSUM,
		106	-Flags => DB_CREATE \| DB_UPGRADE,
		107	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
		108	}
		109
		110	sub pod_to_pango($) {
		111	my ($pom) = @_;
		112
		113	$pom->present ("CFClient::PodToPango")
		114	}
		115
		116	sub pod_to_pango_list($) {
		117	my ($pom) = @_;
		118
		119	[
		120	map s/^(\s)// && [40 length $1, length $_ ? $_ : " "],
		121	split /\n/, $pom->present ("CFClient::PodToPango")
		122	]
		123	}
		124
		125	package CFClient::PodToPango;
		126
		127	use base Pod::POM::View::Text;
		128
		129	our $indent = 0;
		130
		131	*view_seq_code =
		132	*view_seq_bold = sub { "<b>$_[1]</b>" };
		133	*view_seq_italic = sub { "<i>$_[1]</i>" };
		134	*view_seq_space =
		135	*view_seq_link =
		136	*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
		137
		138	sub view_seq_text {
		139	my $text = $_[1];
		140	$text =~ s/\s+/ /g;
		141	CFClient::UI::Label::escape ($text)
		142	}
		143
		144	sub view_item {
		145	("\t" x ($indent / 4))
		146	. $_[1]->title->present ($_[0])
		147	. "\n"
		148	. $_[1]->content->present ($_[0])
		149	}
		150
		151	sub view_verbatim {
		152	(join "",
		153	map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
		154	split /\n/, CFClient::UI::Label::escape ($_[1]))
		155	. "\n"
		156	}
		157
		158	sub view_textblock {
		159	("\t" x ($indent / 2)) . "$_[1]\n\n"
		160	}
		161
		162	sub view_head1 {
		163	"\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
		164	. $_[1]->content->present ($_[0])
		165	};
		166
		167	sub view_head2 {
		168	"\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
		169	. $_[1]->content->present ($_[0])
		170	};
		171
		172	sub view_head3 {
		173	"\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
		174	. $_[1]->content->present ($_[0])
		175	};
		176
		177	sub view_over {
		178	local $indent = $indent + $_[1]->indent;
		179	$_[1]->content->present ($_[0])
		180	}
		181
		182	package CFClient::Database;
		183
		184	our @ISA = BerkeleyDB::Btree::;
		185
		186	sub get($$) {
		187	my $data;
		188
		189	$_[0]->db_get ($_[1], $data) == 0
81	%data,	190	? $data
82	}, $class;	191	: ()
83
84	push @textures, $self;
85	Scalar::Util::weaken $textures[-1];
86
87	$self->upload;
88
89	$self
90	}	192	}
91		193
92	sub new_from_image {	194	my %DB_SYNC;
93	my ($class, $image) = @_;
94		195
95	$class->new (image => $image)	196	sub put($$$) {
96	}	197	my ($db, $key, $data) = @_;
97		198
98	sub new_from_file {	199	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
99	my ($class, $path) = @_;
100		200
101	open my $fh, "<:raw", $path	201	$db->db_put ($key => $data)
102	or die "$path: $!";
103
104	local $/;
105	$class->new_from_image (<$fh>)
106	}	202	}
107		203
108	#sub new_from_surface {	204	package CFClient::Item;
109	# my ($class, $surface) = @_;
110	#
111	# $surface->rgba;
112	#
113	# $class->new (
114	# data => $surface->pixels,
115	# width => $surface->width,
116	# height => $surface->height,
117	# )
118	#}
119		205
120	sub new_from_text {	206	use strict;
121	my ($class, $text, $height) = @_;	207	use Crossfire::Protocol::Constants;
122		208
123	my ($w, $h, $data) = Crossfire::Client::font_render $text, $height;	209	sub desc_string {
124
125	$class->new (
126	width => $w,
127	height => $h,
128	data => $data,
129	internalformat => GL_ALPHA4,
130	format => GL_ALPHA,
131	)
132	}
133
134	sub new_from_opengl {
135	my ($class, $w, $h, $cb) = @_;
136
137	$class->new (width => $w, height => $h, rendercb => $cb)
138	}
139
140	sub upload {
141	my ($self) = @_;	210	my ($self) = @_;
142		211
143	return unless $SDL::App::USING_OPENGL;	212	my $desc =
		213	$self->{nrof} < 2
		214	? $self->{name}
		215	: "$self->{nrof} × $self->{name_pl}";
144		216
145	my $data;	217	$self->{flags} & F_OPEN
		218	and $desc .= " (open)";
		219	$self->{flags} & F_APPLIED
		220	and $desc .= " (applied)";
		221	$self->{flags} & F_UNPAID
		222	and $desc .= " (unpaid)";
		223	$self->{flags} & F_MAGIC
		224	and $desc .= " (magic)";
		225	$self->{flags} & F_CURSED
		226	and $desc .= " (cursed)";
		227	$self->{flags} & F_DAMNED
		228	and $desc .= " (damned)";
		229	$self->{flags} & F_LOCKED
		230	and $desc .= " *";
146		231
147	if (exists $self->{data}) {	232	$desc
148	$data = $self->{data};	233	}
149	} elsif (exists $self->{rendercb}) {
150	glViewport 0, 0, $self->{width}, $self->{height};
151	glMatrixMode GL_PROJECTION;
152	glLoadIdentity;
153	glOrtho 0, $self->{width}, 0, $self->{height}, -10000, 10000;
154	glMatrixMode GL_MODELVIEW;
155	glPushmatrix;
156	glLoadIdentity;
157	glClear GL_COLOR_BUFFER_BIT;
158		234
159	$self->{rendercb}->($self, $self->{width}, $self->{height});	235	sub weight_string {
160	} else {	236	my ($self) = @_;
161	my $pb = new Gtk2::Gdk::PixbufLoader;
162	$pb->write ($self->{image});
163	$pb->close;
164		237
165	$pb = $pb->get_pixbuf;	238	my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
166	$pb = $pb->add_alpha (0, 0, 0, 0);
167		239
168	$self->{width} = $pb->get_width;	240	$weight < 0 ? "?" : $weight * 0.001
169	$self->{height} = $pb->get_height;	241	}
170		242
171	$data = $pb->get_pixels;	243	sub update_widgets {
		244	my ($self) = @_;
		245
		246	my $button_cb = sub {
		247	my (undef, $ev, $x, $y) = @_;
		248
		249	if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
		250	my $targ = $::CONN->{player}{tag};
		251
		252	if ($self->{container} == $::CONN->{player}{tag}) {
		253	$targ = $::CONN->{open_container};
		254	}
		255
		256	$::CONN->send ("move $targ $self->{tag} 0")
		257	if $targ \|\| !($self->{flags} & F_LOCKED);
		258	} elsif ($ev->{button} == 1) {
		259	$::CONN->send ("examine $self->{tag}");
		260	} elsif ($ev->{button} == 2) {
		261	$::CONN->send ("apply $self->{tag}");
		262	} elsif ($ev->{button} == 3) {
		263	my @menu_items = (
		264	["examine", sub { $::CONN->send ("examine $self->{tag}") }],
		265	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
		266	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
		267	(
		268	$self->{flags} & F_LOCKED
		269	? (
		270	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
		271	)
		272	: (
		273	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
		274	["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
		275	)
		276	),
		277	);
		278
		279	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
		280	}
		281
		282	1
		283	};
		284
		285	my $tooltip_std = "<small>"
		286	. "Left click - examine item\n"
		287	. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
		288	. "Middle click - apply\n"
		289	. "Right click - further options"
		290	. "</small>\n";
		291
		292	$self->{face_widget} \|\|= new CFClient::UI::Face
		293	can_events => 1,
		294	can_hover => 1,
		295	anim => $self->{anim},
		296	animspeed => $self->{animspeed}, # TODO# must be set at creation time
		297	on_button_down => $button_cb,
		298	;
		299	$self->{face_widget}{face} = $self->{face};
		300	$self->{face_widget}{anim} = $self->{anim};
		301	$self->{face_widget}{animspeed} = $self->{animspeed};
		302	$self->{face_widget}->set_tooltip (
		303	"<b>Face/Animation.</b>\n"
		304	. "Item uses face #$self->{face}. "
		305	. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
		306	. "\n\n$tooltip_std"
		307	);
		308
		309	$self->{desc_widget} \|\|= new CFClient::UI::Label
		310	can_events => 1,
		311	can_hover => 1,
		312	ellipsise => 2,
		313	align => -1,
		314	on_button_down => $button_cb,
		315	;
		316	my $desc = CFClient::Item::desc_string $self;
		317	$self->{desc_widget}->set_text ($desc);
		318	$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
		319
		320	$self->{weight_widget} \|\|= new CFClient::UI::Label
		321	can_events => 1,
		322	can_hover => 1,
		323	ellipsise => 0,
		324	align => 0,
		325	on_button_down => $button_cb,
		326	;
		327	$self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
		328
		329	$self->{weight_widget}->set_tooltip (
		330	"<b>Weight</b>.\n"
		331	. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
		332	. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
		333	. "\n\n$tooltip_std"
		334	);
		335	}
		336
		337	package CFClient::Recorder;
		338
		339	our $RECORD_WINDOW;
		340
		341	my $CMDBOX;
		342	my $CURRENT_CMDS;
		343	my $REC_BTN;
		344
		345	my @ALLOWED_MODIFIER_KEYS = (
		346	(CFClient::SDLK_LSHIFT) => "LSHIFT",
		347	(CFClient::SDLK_LCTRL ) => "LCTRL",
		348	(CFClient::SDLK_LALT ) => "LALT",
		349	(CFClient::SDLK_LMETA ) => "LMETA",
		350
		351	(CFClient::SDLK_RSHIFT) => "RSHIFT",
		352	(CFClient::SDLK_RCTRL ) => "RCTRL",
		353	(CFClient::SDLK_RALT ) => "RALT",
		354	(CFClient::SDLK_RMETA ) => "RMETA",
		355	);
		356
		357	my %ALLOWED_MODIFIERS = (
		358	(CFClient::KMOD_LSHIFT) => "LSHIFT",
		359	(CFClient::KMOD_LCTRL ) => "LCTRL",
		360	(CFClient::KMOD_LALT ) => "LALT",
		361	(CFClient::KMOD_LMETA ) => "LMETA",
		362
		363	(CFClient::KMOD_RSHIFT) => "RSHIFT",
		364	(CFClient::KMOD_RCTRL ) => "RCTRL",
		365	(CFClient::KMOD_RALT ) => "RALT",
		366	(CFClient::KMOD_RMETA ) => "RMETA",
		367	);
		368
		369	my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
		370	my @DIRECT_BIND_KEYS = (
		371	CFClient::SDLK_F1,
		372	CFClient::SDLK_F2,
		373	CFClient::SDLK_F3,
		374	CFClient::SDLK_F4,
		375	CFClient::SDLK_F5,
		376	CFClient::SDLK_F6,
		377	CFClient::SDLK_F7,
		378	CFClient::SDLK_F8,
		379	CFClient::SDLK_F9,
		380	CFClient::SDLK_F10,
		381	CFClient::SDLK_F11,
		382	CFClient::SDLK_F12,
		383	CFClient::SDLK_F13,
		384	CFClient::SDLK_F14,
		385	CFClient::SDLK_F15,
		386	);
		387
		388	# this binding dialog asks for a key-combo to be pressed
		389	# and if successful it binds the modifier+symbol to the
		390	# supplied actions in $cmd.
		391	# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
		392	sub open_binding_dialog {
		393	my ($cmd) = @_;
		394
		395	my $w = new CFClient::UI::FancyFrame
		396	title => "Bind Action",
		397	x => "center",
		398	y => "center";
		399
		400	$w->add (my $vb = new CFClient::UI::VBox);
		401	$vb->add (new CFClient::UI::Label
		402	text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
		403	."You can only bind 0-9 and F1-F15 without modifiers."
		404	);
		405	$vb->add (my $entry = new CFClient::UI::Entry
		406	text => "",
		407	on_key_down => sub {
		408	my ($entry, $ev) = @_;
		409
		410	my $mod = $ev->{mod};
		411	my $sym = $ev->{sym};
		412
		413	# XXX: This seems a little bit hackisch to me, but i have to ignore them
		414	if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
		415	return;
		416	}
		417
		418	if ($mod == CFClient::KMOD_NONE
		419	and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
		420	and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
		421	{
		422	$::STATUSBOX->add (
		423	"Can't bind key ".CFClient::SDL_GetKeyName ($sym)
		424	." directly without modifier! It would damage the completer handling."
		425	);
		426	return;
		427	}
		428
		429	$entry->focus_out;
		430
		431	$::CFG->{bindings}->{$mod}->{$sym} = $cmd;
		432	$::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
		433
		434	$w->destroy
		435	});
		436
		437	$entry->focus_in;
		438	$w->show;
		439	}
		440
		441	sub keycombo_to_name {
		442	my ($mod, $sym) = @_;
		443
		444	my $mods = join '+',
		445	map { $ALLOWED_MODIFIERS{$_} }
		446	grep { $_ & $mod }
		447	keys %ALLOWED_MODIFIERS;
		448	$mods .= "+" if $mods ne '';
		449
		450	return $mods . CFClient::SDL_GetKeyName ($sym);
		451	}
		452
		453	sub clear_command_list {
		454	$CMDBOX->clear () if $CMDBOX;
		455	}
		456
		457	sub set_command_list {
		458	my ($list) = @_;
		459
		460	return unless $CMDBOX;
		461
		462	$CMDBOX->clear ();
		463	$CURRENT_CMDS = $list;
		464
		465	my $idx = 0;
		466
		467	for (@$list) {
		468	$CMDBOX->add (my $hb = new CFClient::UI::HBox);
		469
		470	my $i = $idx;
		471	$hb->add (new CFClient::UI::Button
		472	text => "delete",
		473	tooltip => "Deletes the action from the record",
		474	on_activate => sub {
		475	$CMDBOX->remove ($hb);
		476	$list->[$i] = undef;
		477	});
		478
		479	$hb->add (new CFClient::UI::Label text => $_);
		480
		481	$idx++
172	}	482	}
		483	}
173		484
174	($self->{name}) = @{glGenTextures 1};	485	# if $show is 1 the recorder will be shown
		486	sub start {
		487	my ($show) = @_;
175		488
176	glBindTexture GL_TEXTURE_2D, $self->{name};	489	$RECORD_WINDOW->show if $show;
177		490
178	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST;	491	$REC_BTN->set_text ("stop recording");
179	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST;#_MIPMAP_LINEAR;	492	$REC_BTN->{recording} = 1;
180	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP;	493	clear_command_list;
181	glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP;	494	$::CONN->start_record;
182		495	}
183	glGetError;	496
184	if (defined $data) {	497	# if $autobind is 1 the recorder will be automatically
185	glTexImage2D GL_TEXTURE_2D, 0,	498	# jump into the binding query and hide the recorder window
186	$self->{internalformat},	499	sub stop {
187	$self->{width}, $self->{height},	500	my ($autobind) = @_;
188	0,	501
189	$self->{format},	502	$REC_BTN->set_text ("start recording");
190	GL_UNSIGNED_BYTE,	503	$REC_BTN->{recording} = 0;
191	$data;	504
192	glGetError and die;	505	my $rec = $::CONN->stop_record;
193	} else {	506	return unless ref $rec eq 'ARRAY';
194	glCopyTexImage2D GL_TEXTURE_2D, 0,	507	set_command_list ($rec);
195	$self->{internalformat},	508
196	0, 0,	509	if ($autobind) {
197	$self->{width}, $self->{height},	510	open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
198	0;	511	$RECORD_WINDOW->hide;
199	glPopmatrix;
200	}	512	}
201	}	513	}
202		514
203	sub DESTROY {	515	sub make_window {
204	my ($self) = @_;	516	$RECORD_WINDOW = new CFClient::UI::FancyFrame
		517	req_y => 1,
		518	req_x => -1,
		519	title => "Action Recorder";
205		520
206	return unless exists $self->{name};	521	$RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
		522	$vb->add ($REC_BTN = new CFClient::UI::Button
		523	text => "start recording",
		524	tooltip => "Start/Stops recording of actions."
		525	."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
		526	."All subsequent actions after the recording started will be captured."
		527	."The actions are displayed after the record was stopped."
		528	."To bind the action you have to click on the 'Bind' button",
		529	on_activate => sub {
		530	my ($btn) = @_;
207		531
208	glDeleteTextures delete $self->{name};	532	unless ($btn->{recording}) {
209	}	533	start;
		534	} else {
		535	stop;
		536	}
		537	});
		538	$vb->add ($CMDBOX = new CFClient::UI::VBox);
		539	$vb->add (new CFClient::UI::Button
		540	text => "bind",
		541	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
		542	on_activate => sub {
		543	open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
		544	});
210		545
211	push @::GL_INIT, sub {	546	$RECORD_WINDOW
212	$_->upload	547	}
213	for grep $_, @textures;
214	};
215		548
216	1;	549	1;
217		550
218	=back	551	=back
219		552

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.18 by root, Mon Apr 10 11:55:16 2006 UTC vs. Revision 1.80 by elmex, Tue May 30 08:12:50 2006 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.18 by root, Mon Apr 10 11:55:16 2006 UTC vs.
Revision 1.80 by elmex, Tue May 30 08:12:50 2006 UTC