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

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.21 by pippijn, Fri Mar 2 10:43:01 2007 UTC vs.
Revision 1.47 by root, Mon Jun 11 22:18:03 2007 UTC

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

Diff Legend

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

Comparing deliantra/server/ext/commands.ext (file contents): Revision 1.21 by pippijn, Fri Mar 2 10:43:01 2007 UTC vs. Revision 1.47 by root, Mon Jun 11 22:18:03 2007 UTC

Diff Legend

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.21 by pippijn, Fri Mar 2 10:43:01 2007 UTC vs.
Revision 1.47 by root, Mon Jun 11 22:18:03 2007 UTC