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

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.13 by root, Fri Jan 5 21:56:14 2007 UTC vs.
Revision 1.44 by root, Mon May 7 07:47:32 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
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
…		…
38	1	38	1
39	}	39	}
40		40
41	sub ext::schmorp_irc::users; # HACK: TODO: replace by signal	41	sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42		42
43	sub who_listing(;$) {	43	sub who_listing(;$$) {
44	my ($privileged) = @_;	44	my ($privileged, $select) = @_;
45		45
46	my ($numwiz, $numafk) = (0, 0);	46	my ($numwiz, $numafk) = (0, 0);
47	my @pl;	47	my @pl;
48		48
49	foreach my $pl (cf::player::list) {	49	foreach my $pl (cf::player::list) {
…		…
59	push @pl, $pl;	59	push @pl, $pl;
60	}	60	}
61		61
62	(	62	(
63	"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",	63	"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
64	(	64	(grep /$select/,
65	map {	65	map {
66	my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);	66	my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67		67
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 },
79	)	79	)
80	}	80	}
81		81
82	cf::register_command who => sub {	82	cf::register_command who => sub {
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 - 4);
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"), $arg), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
		88
		89	1
		90	};
		91
		92	cf::register_command seen => sub {
		93	my ($pl, $args) = @_;
		94
		95	if (my ($login) = $args =~ /(\S+)/) {
		96	if ($login eq $pl->name) {
		97	$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
		98	} elsif (cf::player::find_active $login) {
		99	$pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
		100	} elsif (cf::player::exists $login
		101	and stat cf::player::path $login) {
		102	my $time = (stat _)[9];
		103
		104	$pl->message ("$login was last seen here "
		105	. (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
		106	. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
		107	} else {
		108	$pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
		109	}
		110	} else {
		111	$pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
		112	}
		113	};
		114
		115	cf::register_command body => sub {
		116	my ($ob) = @_;
		117
		118	# Too hard to try and make a header that lines everything up, so just
		119	# give a description. (comment from C++)
		120	my $reply =
		121	"The first column is the name of the body location.\n"
		122	. "The second column is how many of those locations your body has.\n"
		123	. "The third column is how many slots in that location are available.\n";
		124
		125	$reply .= sprintf "%-20s %3s %5s\n", "Location", "You", "Avail";
		126	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
		127	my $msg = cf::object::slot_nonuse_name $_;
		128	$msg =~ s/^.*? a //;
		129	$reply .= sprintf "%-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
		130	if $ob->slot_info ($_) or $ob->slot_used ($_);
		131	}
		132
		133	$reply .= "You are not allowed to wear armor\n"
		134	unless $ob->flag (cf::FLAG_USE_ARMOUR);
		135	$reply .= "You are not allowed to use weapons\n"
		136	unless $ob->flag (cf::FLAG_USE_WEAPON);
		137
		138	$ob->reply (undef, $reply);
		139
		140	1
		141	};
		142
		143	cf::register_command mark => sub {
		144	my ($pl, $arg) = @_;
		145
		146	if (length $arg) {
		147	my $ob = $pl->find_best_object_match ($arg);
		148
		149	return $pl->reply (undef, "Could not find an object that matches $arg")
		150	unless $ob;
		151
		152	$pl->contr->mark ($ob);
		153	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
		154	} else {
		155	my $ob = $pl->find_marked_object;
		156
		157	$pl->reply (undef, $ob
		158	? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
		159	: "You have no marked object.");
		160	}
		161
		162	1
		163	};
		164
		165	for my $cmd ("run", "fire") {
		166	my $oncmd = "${cmd}_on";
		167	cf::register_command $cmd => sub {
		168	my ($ob, $arg) = @_;
		169
		170	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
		171	if $arg < 0 or $arg >= 9;
		172
		173	$ob->contr->$oncmd (1);
		174	$ob->move_player ($arg);
		175
		176	1
		177	};
		178
		179	cf::register_command "${cmd}_stop" => sub {
		180	my ($ob) = @_;
		181
		182	$ob->contr->$oncmd (0);
		183
		184	1
		185	};
		186	}
		187
		188	cf::register_command mapinfo => sub {
		189	my ($ob) = @_;
		190
		191	my $map = $ob->map
		192	or return;
		193	$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
		194	$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
		195	$map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
		196	if $ob->flag (cf::FLAG_WIZ);
		197	$ob->reply (undef, $map->msg);
		198
		199	1
		200	};
		201
		202	cf::register_command whereami => sub {
		203	my ($ob) = @_;
		204
		205	my $reg = $ob->region;
		206	$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
		207
		208	1
		209	};
		210
		211	sub _set_mode($$$@) {
		212	my ($name, $ob, $arg, $slot, @choices) = @_;
		213
		214	my $oldmode = $ob->contr->$slot;
		215
		216	return $ob->reply (undef, "$name is set to $choices[$oldmode]")
		217	unless $arg;
		218
		219	my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
		220	or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;
		221
		222	$ob->contr->$slot ($idx);
		223	$ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
		224	}
		225
		226	cf::register_command applymode => sub {
		227	my ($ob, $arg) = @_;
		228
		229	_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
		230
		231	1
		232	};
		233
		234	cf::register_command petmode => sub {
		235	my ($ob, $arg) = @_;
		236
		237	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
		238
		239	1
		240	};
		241
		242	cf::register_command usekeys => sub {
		243	my ($ob, $arg) = @_;
		244
		245	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
		246
		247	1
		248	};
		249
		250	cf::register_command afk => sub {
		251	my ($ob, $arg) = @_;
		252
		253	$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
		254	$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
		255
		256	1
		257	};
		258
		259	cf::register_command sound => sub {
		260	my ($ob, $arg) = @_;
		261
		262	$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
		263	$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
		264
		265	1
		266	};
		267
		268	cf::register_command brace => sub {
		269	my ($ob, $arg) = @_;
		270
		271	$ob->contr->braced ($ob->contr->braced ? 0 : 1);
		272	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
		273
		274	1
		275	};
		276
		277	cf::register_command 'output-rate' => sub {
		278	my ($ob, $arg) = @_;
		279
		280	return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
		281	unless $arg > 0;
		282
		283	# minimum is 2k/s
		284	$ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
		285	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
		286
		287	1
		288	};
		289
		290	cf::register_command 'output-count' => sub {
		291	my ($ob, $arg) = @_;
		292
		293	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
		294	unless $arg > 0;
		295
		296	$arg = 4 if $arg < 4;
		297
		298	$ob->contr->outputs_count ($arg);
		299	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
		300
		301	1
		302	};
		303
		304	cf::register_command 'output-sync' => sub {
		305	my ($ob, $arg) = @_;
		306
		307	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
		308	unless length $arg;
		309
		310	$arg = 0.5 if $arg < 0.5;
		311
		312	$ob->contr->outputs_sync ($arg / $cf::TICK);
		313	$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
		314
		315	1
		316	};
		317
		318	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
		319	# some other level (which may also be 0), this does not get echoed,
		320	# but it does get set.
		321	cf::register_command wimpy => sub {
		322	my ($ob, $arg) = @_;
		323
		324	my $wimpy = $ob->run_away;
		325	return $ob->reply (undef, "Your current wimpy level is $wimpy.")
		326	if $arg eq "";
		327
		328	return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
		329	if $arg =~ /^\d+$/ and $arg <= 100;
		330
		331	$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
		332
		333	1
		334	};
		335
		336	cf::register_command peaceful => sub {
		337	my ($ob, $arg) = @_;
		338
		339	$ob->reply (undef, "You cannot change your peaceful setting with this command."
		340	." Please speak to the priest in the temple of Gorokh"
		341	." if you want to become hostile or in temple of Valriel"
		342	." if you want to become peaceful again.");
		343
		344	#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
		345	#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
88		346
89	1	347	1
90	};	348	};
91		349
92	cf::register_command rename => sub {	350	cf::register_command rename => sub {
…		…
136		394
137	no re 'eval'; $arg = qr<$arg>;	395	no re 'eval'; $arg = qr<$arg>;
138		396
139	my $format = "%2s %1s %3s %5s %.60s\n";	397	my $format = "%2s %1s %3s %5s %.60s\n";
140		398
141	$ob->reply (undef, sprintf $format, "Pl", "I", "Svd", "Reset", "Name");	399	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
142		400
143	for (sort keys %cf::MAP) {	401	for (sort keys %cf::MAP) {
144	my $map = $cf::MAP{$_}	402	my $map = $cf::MAP{$_}
145	or next;	403	or next;
146		404
147	next unless $map->path =~ $arg;	405	next unless $map->path =~ $arg;
		406	next if $map->{deny_list};
148		407
149	my $svd = int $cf::RUNTIME - $map->{last_save};	408	my $svd = int $cf::RUNTIME - $map->{last_save};
150	$svd = "++" if $svd > 99;	409	$svd = "++" if $svd > 99;
151		410
152	$ob->reply (undef, sprintf $format,	411	$ob->reply (undef,
		412	(sprintf $format,
153	(scalar $map->players),	413	(scalar $map->players),
154	$IN_MEMORY{$map->in_memory} \|\| "?",	414	$IN_MEMORY{$map->in_memory} \|\| "?",
155	$svd,	415	$svd,
156	(int $map->reset_at - $cf::RUNTIME),	416	(int $map->reset_at - $cf::RUNTIME),
157	$map->{path}->visible_name);	417	$map->visible_name),
158	}	418	cf::NDI_BLACK \| cf::NDI_UNIQUE);
159
160	1	419	}
161	};
162		420
		421	1
		422	};
		423

Diff Legend

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

Comparing deliantra/server/ext/commands.ext (file contents): Revision 1.13 by root, Fri Jan 5 21:56:14 2007 UTC vs. Revision 1.44 by root, Mon May 7 07:47:32 2007 UTC

Diff Legend

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.13 by root, Fri Jan 5 21:56:14 2007 UTC vs.
Revision 1.44 by root, Mon May 7 07:47:32 2007 UTC