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