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

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.76 by root, Mon May 29 21:20:15 2006 UTC vs.
Revision 1.214 by root, Wed Jan 18 00:51:22 2012 UTC

1	=head1 NAME	1	=head1 NAME
2		2
3	CFClient - undocumented utility garbage for our crossfire client	3	DC - undocumented utility garbage for our deliantra client
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use CFClient;	7	use DC;
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 CFClient;	15	package DC;
		16
		17	use Carp ();
		18
		19	our $VERSION;
16		20
17	BEGIN {	21	BEGIN {
18	$VERSION = '0.1';	22	$VERSION = '3.0';
19		23
20	use XSLoader;	24	use XSLoader;
21	XSLoader::load "CFClient", $VERSION;	25	XSLoader::load "Deliantra::Client", $VERSION;
22	}	26	}
23		27
24	use utf8;	28	use utf8;
		29	use strict qw(vars subs);
25		30
26	use Carp ();	31	use Socket ();
27	use AnyEvent ();	32	use AnyEvent ();
28	use BerkeleyDB;	33	use AnyEvent::Util ();
		34	use Pod::POM ();
		35	use File::Path ();
		36	use Storable (); # finally
		37	use Fcntl ();
		38	use JSON::XS qw(encode_json decode_json);
		39	use Guard qw(guard);
		40
		41	# modules to support other DC::* packages
		42	use List::Util ();
		43	use IO::AIO ();
		44	use Coro::AIO ();
		45	use AnyEvent::AIO ();
		46
		47	use Deliantra::Protocol::Constants ();
		48
		49	=item shorten $string[, $maxlength]
		50
		51	=cut
		52
		53	sub shorten($;$) {
		54	my ($str, $len) = @_;
		55	substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
		56	$str
		57	}
		58
		59	sub asxml($) {
		60	local $_ = $_[0];
		61
		62	s/&/&/g;
		63	s/>/>/g;
		64	s/</</g;
		65
		66	$_
		67	}
		68
		69	sub background(&;&) {
		70	my ($bg, $cb) = @_;
		71
		72	my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
		73	or die "unable to create background socketpair: $!";
		74
		75	my $pid = fork;
		76
		77	if (defined $pid && !$pid) {
		78	local $SIG{__DIE__};
		79
		80	open STDOUT, ">&", $fh_w;
		81	open STDERR, ">&", $fh_w;
		82	close $fh_r;
		83	close $fh_w;
		84
		85	$\| = 1;
		86
		87	eval { $bg->() };
		88
		89	if ($@) {
		90	my $msg = $@;
		91	$msg =~ s/\n+/\n/;
		92	warn "FATAL: $msg";
		93	DC::_exit 1;
		94	}
		95
		96	# win32 is fucked up, of course. exit will clean stuff up,
		97	# which destroys our database etc. _exit will exit ALL
		98	# forked processes, because of the dreaded fork emulation.
		99	DC::_exit 0;
		100	}
		101
		102	close $fh_w;
		103
		104	my $buffer;
		105
		106	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
		107	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
		108	undef $w;
		109	$cb->();
		110	return;
		111	}
		112
		113	while ($buffer =~ s/^(.*)\n//) {
		114	my $line = $1;
		115	$line =~ s/\s+$//;
		116	utf8::decode $line;
		117	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
		118	$cb->(JSON::XS->new->allow_nonref->decode ($1));
		119	} else {
		120	::message ({
		121	markup => "background($pid): " . DC::asxml $line,
		122	});
		123	}
		124	}
		125	});
		126	}
		127
		128	sub background_msg {
		129	my ($msg) = @_;
		130
		131	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
		132	$msg =~ s/\n//g;
		133	utf8::encode $msg;
		134	print $msg, "\n";
		135	}
		136
		137	package DC;
		138
		139	our $RC_THEME;
		140	our %THEME;
		141	our @RC_PATH;
		142	our $RC_BASE;
		143
		144	for (grep !ref, @INC) {
		145	$RC_BASE = "$_/Deliantra/Client/private/resources";
		146	last if -d $RC_BASE;
		147	}
29		148
30	sub find_rcfile($) {	149	sub find_rcfile($) {
31	my $path;	150	my $path;
32		151
33	for (grep !ref, @INC) {	152	for (@RC_PATH, "") {
34	$path = "$_/CFClient/resources/$_[0]";	153	$path = "$RC_BASE/$_/$_[0]";
35	return $path if -r $path;	154	return $path if -e $path;
36	}	155	}
37		156
38	die "FATAL: can't find required file $_[0]\n";	157	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
		158	}
		159
		160	sub load_json($) {
		161	my ($file) = @_;
		162
		163	open my $fh, $file
		164	or return;
		165
		166	local $/;
		167	eval { JSON::XS->new->utf8->relaxed->decode (<$fh>) }
		168	}
		169
		170	sub set_theme($) {
		171	return if $RC_THEME eq $_[0];
		172	$RC_THEME = $_[0];
		173
		174	# kind of hacky, find the main theme file, then load all theme files and merge them
		175
		176	%THEME = ();
		177	@RC_PATH = "theme-$RC_THEME";
		178
		179	my $theme = load_json find_rcfile "theme.json"
		180	or die "FATAL: theme resource file not found";
		181
		182	@RC_PATH = @{ $theme->{path} } if $theme->{path};
		183
		184	for (@RC_PATH, "") {
		185	my $theme = load_json "$RC_BASE/$_/theme.json"
		186	or next;
		187
		188	%THEME = ( %$theme, %THEME );
		189	}
39	}	190	}
40		191
41	sub read_cfg {	192	sub read_cfg {
42	my ($file) = @_;	193	my ($file) = @_;
43		194
44	open CFG, $file	195	$::CFG = (load_json $file) \|\| (load_json "$file.bak");
		196	}
		197
		198	sub write_cfg {
		199	my $file = "$Deliantra::VARDIR/client.cf";
		200
		201	$::CFG->{VERSION} = $::VERSION;
		202	$::CFG->{layout} = DC::UI::get_layout ();
		203
		204	open my $fh, ">:utf8", "$file~"
45	or return;	205	or return;
46		206	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
47	my $CFG;
48
49	local $/;
50	$CFG = eval <CFG>;
51
52	$::CFG = $CFG;
53
54	close CFG;	207	close $fh;
55	}
56		208
57	sub write_cfg {	209	rename $file, "$file.bak";
58	my ($file) = @_;	210	rename "$file~", $file;
		211	}
59		212
60	open CFG, ">$file"	213	sub upgrade_cfg() {
		214	my %DEF_CFG = (
		215	config_autosave => 1,
		216	sdl_mode => undef,
		217	fullscreen => 1,
		218	fast => 0,
		219	force_opengl11 => undef,
		220	disable_alpha => 0,
		221	smooth_movement => 1,
		222	smooth_transitions => 1,
		223	texture_compression => 1,
		224	map_scale => 1,
		225	fow_enable => 1,
		226	fow_intensity => 0,
		227	fow_texture => 0,
		228	map_smoothing => 1,
		229	gui_fontsize => 1,
		230	log_fontsize => 0.7,
		231	gauge_fontsize => 1,
		232	gauge_size => 0.35,
		233	stat_fontsize => 0.7,
		234	mapsize => 100,
		235	audio_enable => 1,
		236	audio_hw_channels => 0,
		237	audio_hw_frequency => 0,
		238	audio_hw_chunksize => 0,
		239	audio_mix_channels => 8,
		240	effects_enable => 1,
		241	effects_volume => 1,
		242	bgm_enable => 1,
		243	bgm_volume => 0.5,
		244	output_rate => "",
		245	pickup => Deliantra::Protocol::Constants::PICKUP_SPELLBOOK
		246	\| Deliantra::Protocol::Constants::PICKUP_SKILLSCROLL
		247	\| Deliantra::Protocol::Constants::PICKUP_VALUABLES,
		248	inv_sort => "mtime",
		249	default => "profile", # default profile
		250	show_tips => 1,
		251	logview_max_par => 1000,
		252	shift_fire_stop => 0,
		253	uitheme => "wood",
		254	map_shift_x => -24, # arbitrary
		255	map_shift_y => +24, # arbitrary
		256	#db_schema => 0,
		257	);
		258
		259	while (my ($k, $v) = each %DEF_CFG) {
		260	$::CFG->{$k} = $v unless exists $::CFG->{$k};
		261	}
		262	}
		263
		264	sub http_proxy {
		265	my @proxy = win32_proxy_info;
		266
		267	if (@proxy) {
		268	"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
		269	} elsif (exists $ENV{http_proxy}) {
		270	$ENV{http_proxy}
		271	} else {
		272	()
		273	}
		274	}
		275
		276	sub set_proxy {
		277	my $proxy = http_proxy
61	or return;	278	or return;
62		279
		280	$ENV{http_proxy} = $proxy;
		281	}
		282
		283	sub lwp_useragent {
		284	require LWP::UserAgent;
63	{	285
64	require Data::Dumper;	286	DC::set_proxy;
65	local $Data::Dumper::Purity = 1;
66	$::CFG->{VERSION} = $::VERSION;
67	print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]);
68	}
69		287
70	close CFG;	288	my $ua = LWP::UserAgent->new (
		289	agent => "deliantra $VERSION",
		290	keep_alive => 1,
		291	env_proxy => 1,
		292	timeout => 30,
		293	);
71	}	294	}
72		295
73	mkdir "$Crossfire::VARDIR/cfplus", 0777;	296	sub lwp_check($) {
74
75	{
76	use strict;
77
78	our $DB_ENV = new BerkeleyDB::Env
79	-Home => "$Crossfire::VARDIR/cfplus",
80	-Cachesize => 1_000_000,
81	-ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt",
82	# -ErrPrefix => "DATABASE",
83	-Verbose => 1,
84	-Flags => DB_CREATE \| DB_RECOVER \| DB_INIT_MPOOL \| DB_INIT_LOCK \| DB_INIT_TXN,
85	-SetFlags => DB_AUTO_COMMIT \| DB_LOG_AUTOREMOVE \| DB_TXN_WRITE_NOSYNC,
86	or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error";
87	}
88
89	sub db_table($) {
90	my ($table) = @_;	297	my ($res) = @_;
91		298
92	$table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;	299	$res->is_error
		300	and die $res->status_line;
93		301
94	new CFClient::Database	302	$res
95	-Env => $DB_ENV,
96	-Filename => $table,
97	# -Filename => "database",
98	# -Subname => $table,
99	-Property => DB_CHKSUM,
100	-Flags => DB_CREATE \| DB_UPGRADE,
101	or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"
102	}	303	}
103		304
104	sub pod_to_pango($) {	305	sub fh_nonblocking($$) {
105	my ($pom) = @_;	306	my ($fh, $nb) = @_;
106		307
107	$pom->present ("CFClient::PodToPango")	308	if ($^O eq "MSWin32") {
108	}	309	$nb = (! ! $nb) + 0;
109		310	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
110	sub pod_to_pango_list($) {	311	} else {
111	my ($pom) = @_;	312	fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
112
113	[	313	}
114	map s/^(\s)// && [40 length $1, length $_ ? $_ : " "],
115	split /\n/, $pom->present ("CFClient::PodToPango")
116	]
117	}	314	}
118		315
119	package CFClient::PodToPango;	316	package DC::Layout;
120		317
121	use base Pod::POM::View::Text;	318	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
122		319	glyph_cache_restore;
123	our $indent = 0;
124
125	*view_seq_code =
126	*view_seq_bold = sub { "<b>$_[1]</b>" };
127	*view_seq_italic = sub { "<i>$_[1]</i>" };
128	*view_seq_space =
129	*view_seq_link =
130	*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) };
131
132	sub view_seq_text {
133	my $text = $_[1];
134	$text =~ s/\s+/ /g;
135	CFClient::UI::Label::escape ($text)
136	}
137
138	sub view_item {
139	("\t" x ($indent / 4))
140	. $_[1]->title->present ($_[0])
141	. "\n"
142	. $_[1]->content->present ($_[0])
143	}
144
145	sub view_verbatim {
146	(join "",
147	map +("\t" x ($indent / 2)) . "<tt>$_</tt>\n",
148	split /\n/, CFClient::UI::Label::escape ($_[1]))
149	. "\n"
150	}
151
152	sub view_textblock {
153	("\t" x ($indent / 2)) . "$_[1]\n\n"
154	}
155
156	sub view_head1 {
157	"\n\n<span foreground='#ffff00' size='x-large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
158	. $_[1]->content->present ($_[0])
159	};	320	};
160		321
161	sub view_head2 {	322	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
162	"\n<span foreground='#ccccff' size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"	323	glyph_cache_backup;
163	. $_[1]->content->present ($_[0])
164	};	324	};
165
166	sub view_head3 {
167	"\n<span size='large'>" . $_[1]->title->present ($_[0]) . "</span>\n\n"
168	. $_[1]->content->present ($_[0])
169	};
170
171	sub view_over {
172	local $indent = $indent + $_[1]->indent;
173	$_[1]->content->present ($_[0])
174	}
175
176	package CFClient::Database;
177
178	our @ISA = BerkeleyDB::Btree::;
179
180	sub get($$) {
181	my $data;
182
183	$_[0]->db_get ($_[1], $data) == 0
184	? $data
185	: ()
186	}
187
188	my %DB_SYNC;
189
190	sub put($$$) {
191	my ($db, $key, $data) = @_;
192
193	$DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync });
194
195	$db->db_put ($key => $data)
196	}
197
198	package CFClient::Item;
199
200	use strict;
201	use Crossfire::Protocol::Constants;
202
203	sub desc_string {
204	my ($self) = @_;
205
206	my $desc =
207	$self->{nrof} < 2
208	? $self->{name}
209	: "$self->{nrof} × $self->{name_pl}";
210
211	$self->{flags} & F_OPEN
212	and $desc .= " (open)";
213	$self->{flags} & F_APPLIED
214	and $desc .= " (applied)";
215	$self->{flags} & F_UNPAID
216	and $desc .= " (unpaid)";
217	$self->{flags} & F_MAGIC
218	and $desc .= " (magic)";
219	$self->{flags} & F_CURSED
220	and $desc .= " (cursed)";
221	$self->{flags} & F_DAMNED
222	and $desc .= " (damned)";
223	$self->{flags} & F_LOCKED
224	and $desc .= " *";
225
226	$desc
227	}
228
229	sub weight_string {
230	my ($self) = @_;
231
232	my $weight = ($self->{nrof} \|\| 1) * $self->{weight};
233
234	$weight < 0 ? "?" : $weight * 0.001
235	}
236
237	sub update_widgets {
238	my ($self) = @_;
239
240	my $button_cb = sub {
241	my (undef, $ev, $x, $y) = @_;
242
243	if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
244	my $targ = $::CONN->{player}{tag};
245
246	if ($self->{container} == $::CONN->{player}{tag}) {
247	$targ = $::CONN->{open_container};
248	}
249
250	$::CONN->send ("move $targ $self->{tag} 0");
251	} elsif ($ev->{button} == 1) {
252	$::CONN->send ("examine $self->{tag}");
253	} elsif ($ev->{button} == 2) {
254	$::CONN->send ("apply $self->{tag}");
255	} elsif ($ev->{button} == 3) {
256	my @menu_items = (
257	["examine", sub { $::CONN->send ("examine $self->{tag}") }],
258	["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
259	["apply", sub { $::CONN->send ("apply $self->{tag}") }],
260	(
261	$self->{flags} & F_LOCKED
262	? (
263	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
264	)
265	: (
266	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
267	["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }],
268	)
269	),
270	);
271
272	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
273	}
274
275	1
276	};
277
278	my $tooltip_std = "<small>"
279	. "Left click - examine item\n"
280	. "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n"
281	. "Middle click - apply\n"
282	. "Right click - further options"
283	. "</small>\n";
284
285	$self->{face_widget} \|\|= new CFClient::UI::Face
286	can_events => 1,
287	can_hover => 1,
288	anim => $self->{anim},
289	animspeed => $self->{animspeed}, # TODO# must be set at creation time
290	on_button_down => $button_cb,
291	;
292	$self->{face_widget}{face} = $self->{face};
293	$self->{face_widget}{anim} = $self->{anim};
294	$self->{face_widget}{animspeed} = $self->{animspeed};
295	$self->{face_widget}->set_tooltip (
296	"<b>Face/Animation.</b>\n"
297	. "Item uses face #$self->{face}. "
298	. ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ")
299	. "\n\n$tooltip_std"
300	);
301
302	$self->{desc_widget} \|\|= new CFClient::UI::Label
303	can_events => 1,
304	can_hover => 1,
305	ellipsise => 2,
306	align => -1,
307	on_button_down => $button_cb,
308	;
309	my $desc = CFClient::Item::desc_string $self;
310	$self->{desc_widget}->set_text ($desc);
311	$self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
312
313	$self->{weight_widget} \|\|= new CFClient::UI::Label
314	can_events => 1,
315	can_hover => 1,
316	ellipsise => 0,
317	align => 0,
318	on_button_down => $button_cb,
319	;
320	$self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
321
322	$self->{weight_widget}->set_tooltip (
323	"<b>Weight</b>.\n"
324	. ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ")
325	. ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ")
326	. "\n\n$tooltip_std"
327	);
328	}
329
330	package CFClient::Recorder;
331
332	our $RECORD_WINDOW;
333
334	my $CMDBOX;
335	my $CURRENT_CMDS;
336	my $REC_BTN;
337
338	my @ALLOWED_MODIFIER_KEYS = (
339	(CFClient::SDLK_LSHIFT) => "LSHIFT",
340	(CFClient::SDLK_LCTRL ) => "LCTRL",
341	(CFClient::SDLK_LALT ) => "LALT",
342	(CFClient::SDLK_LMETA ) => "LMETA",
343
344	(CFClient::SDLK_RSHIFT) => "RSHIFT",
345	(CFClient::SDLK_RCTRL ) => "RCTRL",
346	(CFClient::SDLK_RALT ) => "RALT",
347	(CFClient::SDLK_RMETA ) => "RMETA",
348	);
349
350	my %ALLOWED_MODIFIERS = (
351	(CFClient::KMOD_LSHIFT) => "LSHIFT",
352	(CFClient::KMOD_LCTRL ) => "LCTRL",
353	(CFClient::KMOD_LALT ) => "LALT",
354	(CFClient::KMOD_LMETA ) => "LMETA",
355
356	(CFClient::KMOD_RSHIFT) => "RSHIFT",
357	(CFClient::KMOD_RCTRL ) => "RCTRL",
358	(CFClient::KMOD_RALT ) => "RALT",
359	(CFClient::KMOD_RMETA ) => "RMETA",
360	);
361
362	my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/;
363	my @DIRECT_BIND_KEYS = (
364	CFClient::SDLK_F1,
365	CFClient::SDLK_F2,
366	CFClient::SDLK_F3,
367	CFClient::SDLK_F4,
368	CFClient::SDLK_F5,
369	CFClient::SDLK_F6,
370	CFClient::SDLK_F7,
371	CFClient::SDLK_F8,
372	CFClient::SDLK_F9,
373	CFClient::SDLK_F10,
374	CFClient::SDLK_F11,
375	CFClient::SDLK_F12,
376	CFClient::SDLK_F13,
377	CFClient::SDLK_F14,
378	CFClient::SDLK_F15,
379	);
380
381	# this binding dialog asks for a key-combo to be pressed
382	# and if successful it binds the modifier+symbol to the
383	# supplied actions in $cmd.
384	# (Bindings are stored in $::CFG->{bindings}->{$mod}->{$sym})
385	sub open_binding_dialog {
386	my ($cmd) = @_;
387
388	my $w = new CFClient::UI::FancyFrame
389	title => "Bind Action";
390
391	$w->add (my $vb = new CFClient::UI::VBox);
392	$vb->add (new CFClient::UI::Label
393	text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key."
394	."You can only bind 0-9 and F1-F15 without modifiers."
395	);
396	$vb->add (my $entry = new CFClient::UI::Entry
397	text => "",
398	on_key_down => sub {
399	my ($entry, $ev) = @_;
400
401	my $mod = $ev->{mod};
402	my $sym = $ev->{sym};
403
404	# XXX: This seems a little bit hackisch to me, but i have to ignore them
405	if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) {
406	return;
407	}
408
409	if ($mod == CFClient::KMOD_NONE
410	and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})}
411	and not grep { $sym == $_ } @DIRECT_BIND_KEYS)
412	{
413	$::STATUSBOX->add (
414	"Can't bind key ".CFClient::SDL_GetKeyName ($sym)
415	." directly without modifier! It would damage the completer handling."
416	);
417	return;
418	}
419
420	$entry->focus_out;
421
422	$::CFG->{bindings}->{$mod}->{$sym} = $cmd;
423	$::STATUSBOX->add ("Bound actions to '".keycombo_to_name ($mod, $sym)."'. Don't forget 'Save Config'!");
424
425	$w->destroy
426	});
427
428	$entry->focus_in;
429	$w->center;
430	$w->show;
431	}
432
433	sub keycombo_to_name {
434	my ($mod, $sym) = @_;
435
436	my $mods = join '+',
437	map { $ALLOWED_MODIFIERS{$_} }
438	grep { $_ & $mod }
439	keys %ALLOWED_MODIFIERS;
440	$mods .= "+" if $mods ne '';
441
442	return $mods . CFClient::SDL_GetKeyName ($sym);
443	}
444
445	sub clear_command_list {
446	$CMDBOX->clear () if $CMDBOX;
447	}
448
449	sub set_command_list {
450	my ($list) = @_;
451
452	return unless $CMDBOX;
453
454	$CMDBOX->clear ();
455	$CURRENT_CMDS = $list;
456
457	my $idx = 0;
458
459	for (@$list) {
460	$CMDBOX->add (my $hb = new CFClient::UI::HBox);
461
462	my $i = $idx;
463	$hb->add (new CFClient::UI::Button
464	text => "delete",
465	tooltip => "Deletes the action from the record",
466	on_activate => sub {
467	$CMDBOX->remove ($hb);
468	$list->[$i] = undef;
469	});
470
471	$hb->add (new CFClient::UI::Label text => $_);
472
473	$idx++
474	}
475	}
476
477	# if $show is 1 the recorder will be shown
478	sub start {
479	my ($show) = @_;
480
481	$RECORD_WINDOW->show if $show;
482
483	$REC_BTN->set_text ("stop recording");
484	$REC_BTN->{recording} = 1;
485	clear_command_list;
486	$::CONN->start_record;
487	}
488
489	# if $autobind is 1 the recorder will be automatically
490	# jump into the binding query and hide the recorder window
491	sub stop {
492	my ($autobind) = @_;
493
494	$REC_BTN->set_text ("start recording");
495	$REC_BTN->{recording} = 0;
496
497	my $rec = $::CONN->stop_record;
498	return unless ref $rec eq 'ARRAY';
499	set_command_list ($rec);
500
501	if ($autobind) {
502	open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
503	$RECORD_WINDOW->hide;
504	}
505	}
506
507	sub make_window {
508	$RECORD_WINDOW = new CFClient::UI::FancyFrame
509	req_y => 1,
510	req_x => -1,
511	title => "Action Recorder";
512
513	$RECORD_WINDOW->add (my $vb = new CFClient::UI::VBox);
514	$vb->add ($REC_BTN = new CFClient::UI::Button
515	text => "start recording",
516	tooltip => "Start/Stops recording of actions."
517	."(CTRL+Insert Starts the recorder, Insert Stops recorder and binds automatically)"
518	."All subsequent actions after the recording started will be captured."
519	."The actions are displayed after the record was stopped."
520	."To bind the action you have to click on the 'Bind' button",
521	on_activate => sub {
522	my ($btn) = @_;
523
524	unless ($btn->{recording}) {
525	start;
526	} else {
527	stop;
528	}
529	});
530	$vb->add ($CMDBOX = new CFClient::UI::VBox);
531	$vb->add (new CFClient::UI::Button
532	text => "bind",
533	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
534	on_activate => sub {
535	open_binding_dialog ([ grep { defined $_ } @$CURRENT_CMDS ]);
536	});
537
538	$RECORD_WINDOW
539	}
540		325
541	1;	326	1;
542		327
543	=back	328	=back
544		329

Diff Legend

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

Comparing deliantra/Deliantra-Client/DC.pm (file contents): Revision 1.76 by root, Mon May 29 21:20:15 2006 UTC vs. Revision 1.214 by root, Wed Jan 18 00:51:22 2012 UTC

Diff Legend

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.76 by root, Mon May 29 21:20:15 2006 UTC vs.
Revision 1.214 by root, Wed Jan 18 00:51:22 2012 UTC