[ViewVC] Diff of: cvs/deliantra/server/ext/commands.ext

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.10 by root, Mon Jan 1 17:50:26 2007 UTC vs.
Revision 1.39 by root, Mon Apr 2 19:56:11 2007 UTC

…		…
1	#! perl	1	#! perl # MANDATORY
2		2
3	use POSIX ();	3	use POSIX ();
4		4
5	# miscellaneous commands	5	# miscellaneous commands
6		6
7	sub rename_to($$$) {	7	sub rename_to($$$) {
8	my ($ob, $from, $to) = @_;	8	my ($ob, $from, $to) = @_;
9		9
10	$to =~ /^[a-zA-Z0-9.,=#\/%$!^]*$/	10	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
11	or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");	11	or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
12		12
13	127 >= length $to	13	127 >= length $to
14	or return $ob->message ("rename: new name must be <= 127 characters.");	14	or return $ob->message ("rename: new name must be <= 127 characters.");
15		15
17		17
18	if (length $from) {	18	if (length $from) {
19	$item = $ob->find_best_object_match ($from)	19	$item = $ob->find_best_object_match ($from)
20	or return $ob->message ("rename: could not find a matching item to rename.");	20	or return $ob->message ("rename: could not find a matching item to rename.");
21	} else {	21	} else {
22	$item = $ob->find_marked_object ()	22	$item = $ob->find_marked_object
23	or return $ob->message ("rename: no from name and no marked item found to rename.");	23	or return $ob->message ("rename: no from name and no marked item found to rename.");
24	}	24	}
25		25
26	$item->custom_name (length $to ? $to : undef);	26	$item->custom_name (length $to ? $to : undef);
27		27
…		…
68	"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)	68	"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
69	. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")	69	. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70	. ($ns->afk ? " [AFK]" : "")	70	. ($ns->afk ? " [AFK]" : "")
71	. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")	71	. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72	. " [" . $pl->ns->version . "]"	72	. " [" . $pl->ns->version . "]"
73	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->{path}->visible_name : $ob->map->region ? $ob->map->region->name : "the unknown") . "]"	73	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74	. (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)	74	. (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
75	. ($privileged ? " " . $pl->ns->host : "")	75	. ($privileged ? " " . $pl->ns->host : "")
76	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl	76	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77	),	77	),
78	eval { "* IRC: " . join ", ", ext::schmorp_irc::users },	78	eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
…		…
83	my ($ob, $arg) = @_;	83	my ($ob, $arg) = @_;
84		84
85	$ob->speed_left ($ob->speed_left - 0.25);	85	$ob->speed_left ($ob->speed_left - 0.25);
86		86
87	$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);	87	$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
		88
		89	1
		90	};
		91
		92	cf::register_command body => sub {
		93	my ($ob) = @_;
		94
		95	my @body_locations = ("in your range slot", "on your arm", "on your body", "on your head",
		96	"around your neck", "in your skill slot", "on your finger", "around your shoulders",
		97	"on your feet", "on your hands", "around your wrists", "around your waist");
		98
		99	# Too hard to try and make a header that lines everything up, so just
		100	# give a description. (comment from C++)
		101	$ob->reply (undef, "The first column is the name of the body location.");
		102	$ob->reply (undef, "The second column is how many of those locations your body has.");
		103	$ob->reply (undef, "The third column is how many slots in that location are available.");
		104
		105	for (0 .. scalar @body_locations - 1) {
		106	$ob->reply (undef, (sprintf "%-30s %5d %5d", $body_locations[$_], $ob->body_info($_), $ob->body_used($_)))
		107	if $ob->body_info($_) or $ob->body_used($_);
		108	}
		109
		110	$ob->reply (undef, "You are not allowed to wear armor")
		111	unless $ob->flag (cf::FLAG_USE_ARMOUR);
		112	$ob->reply (undef, "You are not allowed to use weapons")
		113	unless $ob->flag (cf::FLAG_USE_WEAPON);
		114
		115	1
		116	};
		117
		118	cf::register_command mark => sub {
		119	my ($pl, $arg) = @_;
		120
		121	if (length $arg) {
		122	my $ob = $pl->find_best_object_match ($arg);
		123
		124	return $pl->reply (undef, "Could not find an object that matches $arg")
		125	unless $ob;
		126
		127	$pl->contr->mark ($ob);
		128	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
		129	} else {
		130	my $ob = $pl->find_marked_object;
		131
		132	$pl->reply (undef, $ob
		133	? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
		134	: "You have no marked object.");
		135	}
		136
		137	1
		138	};
		139
		140	for my $cmd ("run", "fire") {
		141	my $oncmd = "${cmd}_on";
		142	cf::register_command $cmd => sub {
		143	my ($ob, $arg) = @_;
		144
		145	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
		146	if $arg < 0 or $arg >= 9;
		147
		148	$ob->contr->$oncmd (1);
		149	$ob->move_player ($arg);
		150
		151	1
		152	};
		153
		154	cf::register_command "${cmd}_stop" => sub {
		155	my ($ob) = @_;
		156
		157	$ob->contr->$oncmd (0);
		158
		159	1
		160	};
		161	}
		162
		163	cf::register_command mapinfo => sub {
		164	my ($ob) = @_;
		165
		166	my $map = $ob->map
		167	or return;
		168	$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
		169	$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
		170	$map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
		171	if $ob->flag (cf::FLAG_WIZ);
		172	$ob->reply (undef, $map->msg);
		173
		174	1
		175	};
		176
		177	cf::register_command whereami => sub {
		178	my ($ob) = @_;
		179
		180	my $reg = $ob->region;
		181	$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
		182
		183	1
		184	};
		185
		186	sub _set_mode($$$@) {
		187	my ($name, $ob, $arg, $slot, @choices) = @_;
		188
		189	my $oldmode = $ob->contr->$slot;
		190
		191	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
		192	unless $arg;
		193
		194	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
		195	or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
		196
		197	$ob->contr->$slot ($idx);
		198	$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
		199	}
		200
		201	cf::register_command applymode => sub {
		202	my ($ob, $arg) = @_;
		203
		204	_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
		205
		206	1
		207	};
		208
		209	cf::register_command petmode => sub {
		210	my ($ob, $arg) = @_;
		211
		212	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
		213
		214	1
		215	};
		216
		217	cf::register_command usekeys => sub {
		218	my ($ob, $arg) = @_;
		219
		220	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
		221
		222	1
		223	};
		224
		225	cf::register_command afk => sub {
		226	my ($ob, $arg) = @_;
		227
		228	$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
		229	$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
		230
		231	1
		232	};
		233
		234	cf::register_command sound => sub {
		235	my ($ob, $arg) = @_;
		236
		237	$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
		238	$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
		239
		240	1
		241	};
		242
		243	cf::register_command brace => sub {
		244	my ($ob, $arg) = @_;
		245
		246	$ob->contr->braced ($ob->contr->braced ? 0 : 1);
		247	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
		248
		249	1
		250	};
		251
		252	cf::register_command 'output-rate' => sub {
		253	my ($ob, $arg) = @_;
		254
		255	return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
		256	unless $arg > 0;
		257
		258	# minimum is 2k/s
		259	$ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
		260	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
		261
		262	1
		263	};
		264
		265	cf::register_command 'output-count' => sub {
		266	my ($ob, $arg) = @_;
		267
		268	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
		269	unless $arg > 0;
		270
		271	$ob->contr->outputs_count ($arg);
		272	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
		273
		274	1
		275	};
		276
		277	cf::register_command 'output-sync' => sub {
		278	my ($ob, $arg) = @_;
		279
		280	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
		281	unless length $arg;
		282
		283	$ob->contr->outputs_sync ($arg / $cf::TICK);
		284	$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
		285
		286	1
		287	};
		288
		289	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
		290	# some other level (which may also be 0), this does not get echoed,
		291	# but it does get set.
		292	cf::register_command wimpy => sub {
		293	my ($ob, $arg) = @_;
		294
		295	my $wimpy = $ob->run_away;
		296	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
		297	if $arg eq "";
		298
		299	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
		300	if $arg =~ /^\d+$/ and $arg <= 100;
		301
		302	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
		303
		304	1
		305	};
		306
		307	cf::register_command peaceful => sub {
		308	my ($ob, $arg) = @_;
		309
		310	$ob->reply (undef, "You cannot change your peaceful setting with this command."
		311	." Please speak to the priest in the temple of Gorokh"
		312	." if you want to become hostile or in temple of Valriel"
		313	." if you want to become peaceful again.");
		314
		315	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
		316	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
88		317
89	1	318	1
90	};	319	};
91		320
92	cf::register_command rename => sub {	321	cf::register_command rename => sub {
…		…
134	cf::register_command maps => sub {	363	cf::register_command maps => sub {
135	my ($ob, $arg) = @_;	364	my ($ob, $arg) = @_;
136		365
137	no re 'eval'; $arg = qr<$arg>;	366	no re 'eval'; $arg = qr<$arg>;
138		367
139	my $format = "%2s %1s %3s %5s %-60.60s\n";	368	my $format = "%2s %1s %3s %5s %.60s\n";
140		369
141	my $msg = sprintf $format, "Pl", "I", "Svd", "Reset", "Name";	370	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
142		371
143	for (sort keys %cf::MAP) {	372	for (sort keys %cf::MAP) {
144	my $map = $cf::MAP{$_}	373	my $map = $cf::MAP{$_}
145	or next;	374	or next;
146		375
147	next unless $map->path =~ $arg;	376	next unless $map->path =~ $arg;
		377	next if $map->{deny_list};
148		378
149	my $svd = int $cf::RUNTIME - $map->{last_save};	379	my $svd = int $cf::RUNTIME - $map->{last_save};
150	$svd = "++" if $svd > 99;	380	$svd = "++" if $svd > 99;
151		381
152	$msg .= sprintf $format,	382	$ob->reply (undef,
		383	(sprintf $format,
153	(scalar $map->players),	384	(scalar $map->players),
154	$IN_MEMORY{$map->in_memory} \|\| "?",	385	$IN_MEMORY{$map->in_memory} \|\| "?",
155	$svd,	386	$svd,
156	(int $map->reset_at - $cf::RUNTIME),	387	(int $map->reset_at - $cf::RUNTIME),
157	$map->{path}->visible_name;	388	$map->visible_name),
158	}	389	cf::NDI_BLACK \| cf::NDI_UNIQUE);
159
160	$ob->reply (undef, $msg);
161
162	1	390	}
163	};
164		391
		392	1
		393	};
		394

Diff Legend

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

Comparing deliantra/server/ext/commands.ext (file contents): Revision 1.10 by root, Mon Jan 1 17:50:26 2007 UTC vs. Revision 1.39 by root, Mon Apr 2 19:56:11 2007 UTC

Diff Legend

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.10 by root, Mon Jan 1 17:50:26 2007 UTC vs.
Revision 1.39 by root, Mon Apr 2 19:56:11 2007 UTC