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

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.24 by pippijn, Fri Mar 2 11:07:59 2007 UTC vs.
Revision 1.42 by root, Thu May 3 04:50:27 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->visible_name : $ob->region->name) . "]"	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		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	my @body_locations = ("in your range slot", "on your arm", "on your body", "on your head",
		119	"around your neck", "in your skill slot", "on your finger", "around your shoulders",
		120	"on your feet", "on your hands", "around your wrists", "around your waist");
		121
		122	# Too hard to try and make a header that lines everything up, so just
		123	# give a description. (comment from C++)
		124	$ob->reply (undef, "The first column is the name of the body location.");
		125	$ob->reply (undef, "The second column is how many of those locations your body has.");
		126	$ob->reply (undef, "The third column is how many slots in that location are available.");
		127
		128	for (0 .. scalar @body_locations - 1) {
		129	$ob->reply (undef, (sprintf "%-30s %5d %5d", $body_locations[$_], $ob->body_info($_), $ob->body_used($_)))
		130	if $ob->body_info($_) or $ob->body_used($_);
		131	}
		132
		133	$ob->reply (undef, "You are not allowed to wear armor")
		134	unless $ob->flag (cf::FLAG_USE_ARMOUR);
		135	$ob->reply (undef, "You are not allowed to use weapons")
		136	unless $ob->flag (cf::FLAG_USE_WEAPON);
		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	};
89	1	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
90	};	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	}
91		223
92	cf::register_command applymode => sub {	224	cf::register_command applymode => sub {
93	my ($ob, $arg) = @_;	225	my ($ob, $arg) = @_;
94	my @types = ("nochoice", "never", "always");
95	my $mapping = {
96	nochoice => 1,
97	never => 2,
98	always => 3,
99	};
100		226
101	my $oldmode = $ob->contr->unapply;	227	_set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);
102	my $oldmode_name = $types[$oldmode];
103
104	return $ob->reply (undef, "applymode is set to $oldmode_name")
105	unless $arg;
106
107	return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
108	unless $mapping->{$arg};
109
110	$ob->contr->unapply ($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, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);
113		228
114	1	229	1
115	};	230	};
116		231
117	cf::register_command petmode => sub {	232	cf::register_command petmode => sub {
118	my ($ob, $arg) = @_;	233	my ($ob, $arg) = @_;
119	my @types = ("normal", "sad", "defend", "arena");
120	my $mapping = {
121	normal => 1,
122	sad => 2,
123	defend => 3,
124	arena => 4,
125	};
126		234
127	my $oldtype = $ob->contr->petmode;	235	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
128	my $oldtype_name = $types[$oldtype];
129
130	return $ob->reply (undef, "petmode is set to $oldtype_name")
131	unless $arg;
132
133	return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
134	unless $mapping->{$arg};
135
136	$ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
137	# but $arg would be 0 if a user enters an incorrect value
138	$ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);
139		236
140	1	237	1
141	};	238	};
142		239
143	cf::register_command usekeys => sub {	240	cf::register_command usekeys => sub {
144	my ($ob, $arg) = @_;	241	my ($ob, $arg) = @_;
145	my @types = ("inventory", "keyrings", "containers");
146	my $mapping = {
147	inventory => 1,
148	keyrings => 2,
149	containers => 3,
150	};
151		242
152	my $oldtype = $ob->contr->usekeys;	243	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
153	my $oldtype_name = $types[$oldtype];
154
155	return $ob->reply (undef, "usekeys is set to $oldtype_name")
156	unless $arg;
157
158	return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
159	unless $mapping->{$arg};
160
161	$ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
162	# but $arg would be 0 if a user enters an incorrect value
163	$ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
164		244
165	1	245	1
166	};	246	};
167		247
168	cf::register_command afk => sub {	248	cf::register_command afk => sub {
…		…
190	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");	270	$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
191		271
192	1	272	1
193	};	273	};
194		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
195	cf::register_command 'output-count' => sub {	288	cf::register_command 'output-count' => sub {
196	my ($ob, $arg) = @_;	289	my ($ob, $arg) = @_;
197		290
198	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)	291	return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
199	unless $arg > 0;	292	unless $arg > 0;
200		293
		294	$arg = 4 if $arg < 4;
		295
201	$ob->contr->outputs_count ($arg);	296	$ob->contr->outputs_count ($arg);
202	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);	297	$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
203		298
204	1	299	1
205	};	300	};
206		301
207	cf::register_command 'output-sync' => sub {	302	cf::register_command 'output-sync' => sub {
208	my ($ob, $arg) = @_;	303	my ($ob, $arg) = @_;
209		304
210	return $ob->reply (undef, "Output sync time is presently " . $ob->contr->outputs_sync)	305	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
211	unless $arg > 0;	306	unless length $arg;
212		307
		308	$arg = 0.5 if $arg < 0.5;
		309
213	$ob->contr->outputs_sync ($arg);	310	$ob->contr->outputs_sync ($arg / $cf::TICK);
214	$ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync);	311	$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
215		312
216	1	313	1
217	};	314	};
218		315
219	# 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

Diff Legend

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

Comparing deliantra/server/ext/commands.ext (file contents): Revision 1.24 by pippijn, Fri Mar 2 11:07:59 2007 UTC vs. Revision 1.42 by root, Thu May 3 04:50:27 2007 UTC

Diff Legend

Comparing deliantra/server/ext/commands.ext (file contents):
Revision 1.24 by pippijn, Fri Mar 2 11:07:59 2007 UTC vs.
Revision 1.42 by root, Thu May 3 04:50:27 2007 UTC