server/ext/commands.ext

#! perl

use POSIX ();

# miscellaneous commands

sub rename_to($$$) {
   my ($ob, $from, $to) = @_;

   $to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
      or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");

   127 >= length $to
      or return $ob->message ("rename: new name must be <= 127 characters.");

   my $item;

   if (length $from) {
      $item = $ob->find_best_object_match ($from)
         or return $ob->message ("rename: could not find a matching item to rename.");
   } else {
      $item = $ob->find_marked_object ()
         or return $ob->message ("rename: no from name and no marked item found to rename.");
   }

  $item->custom_name (length $to ? $to : undef);

  if (length $to) {
     $item->custom_name ($to);
     $ob->message ("Your " . $item->base_name . " will now be called $to.");
  } else {
     $item->custom_name (undef);
     $ob->message ("You stop calling your " . $item->base_name . " with weird names.");
  }

  $ob->esrv_update_item (cf::UPD_NAME, $item);

  1
}

sub ext::schmorp_irc::users; # HACK: TODO: replace by signal

sub who_listing(;$) {
   my ($privileged) = @_;

   my ($numwiz, $numafk) = (0, 0);
   my @pl;

   foreach my $pl (cf::player::list) {
      my $ns = $pl->ns or next;
      my $ob = $pl->ob;

      next unless $ob->map
               && ($privileged || !$pl->hidden);

      $numwiz++ if $ob->flag (cf::FLAG_WIZ);
      $numafk++ if $ns->afk;

      push @pl, $pl;
   }

   (
      "Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
      (
         map {
            my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
    
            "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
            . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
            . ($ns->afk ? " [AFK]" : "")
            . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
            . " [" . $pl->ns->version . "]"
            . " [" . ($pl->peaceful || $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
            . (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
            . ($privileged ? " " . $pl->ns->host : "")
         } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
      ),
      eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
   )
}

cf::register_command who => sub {
   my ($ob, $arg) = @_;

   $ob->speed_left ($ob->speed_left - 0.25);

   $ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE | cf::NDI_DK_ORANGE);

   1
};

cf::register_command whereami => sub {
   my ($ob) = @_;

   my $reg = $ob->region;
   $ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));

   1
};

cf::register_command applymode => sub {
   my ($ob, $arg) = @_;
   my @types = ("nochoice", "never", "always");
   my $mapping = {
      nochoice => 1,
      never    => 2,
      always   => 3,
   };

   my $oldmode = $ob->contr->unapply;
   my $oldmode_name = $types[$oldmode];

   return $ob->reply (undef, "applymode is set to $oldmode_name")
      unless $arg;

   return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
      unless $mapping->{$arg};

   $ob->contr->unapply ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);

   1
};

cf::register_command petmode => sub {
   my ($ob, $arg) = @_;
   my @types = ("normal", "sad", "defend", "arena");
   my $mapping = {
      normal => 1,
      sad    => 2,
      defend => 3,
      arena  => 4,
   };

   my $oldtype = $ob->contr->petmode;
   my $oldtype_name = $types[$oldtype];

   return $ob->reply (undef, "petmode is set to $oldtype_name")
      unless $arg;

   return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
      unless $mapping->{$arg};

   $ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);

   1
};

cf::register_command usekeys => sub {
   my ($ob, $arg) = @_;
   my @types = ("inventory", "keyrings", "containers");
   my $mapping = {
      inventory  => 1,
      keyrings   => 2,
      containers => 3,
   };

   my $oldtype = $ob->contr->usekeys;
   my $oldtype_name = $types[$oldtype];

   return $ob->reply (undef, "usekeys is set to $oldtype_name")
      unless $arg;

   return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
      unless $mapping->{$arg};

   $ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
                                               # but $arg would be 0 if a user enters an incorrect value
   $ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);

   1
};

cf::register_command afk => sub {
   my ($ob, $arg) = @_;

   $ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
   $ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");

   1
};

cf::register_command sound => sub {
   my ($ob, $arg) = @_;

   $ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
   $ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");

   1
};

cf::register_command brace => sub {
   my ($ob, $arg) = @_;

   $ob->contr->braced ($ob->contr->braced ? 0 : 1);
   $ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");

   1
};

cf::register_command 'output-count' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
      unless $arg > 0;

   $ob->contr->outputs_count ($arg);
   $ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);

   1
};

cf::register_command 'output-sync' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, "Output sync time is presently " . $ob->contr->outputs_sync)
      unless $arg > 0;

   $ob->contr->outputs_sync ($arg);
   $ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync);

   1
};

# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
# some other level (which may also be 0), this does not get echoed,
# but it does get set.
cf::register_command wimpy => sub {
   my ($ob, $arg) = @_;

   my $wimpy = $ob->run_away;
   return $ob->reply (undef, "Your current wimpy level is $wimpy.")
      if $arg eq "";

   return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
      if $arg =~ /^\d+$/ and $arg <= 100;

   $ob->reply (undef, "Incorrect parameters for wimpy: $arg");

   1
};

cf::register_command peaceful => sub {
   my ($ob, $arg) = @_;

   $ob->reply (undef, "You cannot change your peaceful setting with this command."
                     ." Please speak to the priest in the temple of Gorokh"
                     ." if you want to become hostile or in temple of Valriel"
                     ." if you want to become peaceful again.");

   #$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
   #$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");

   1
};

cf::register_command rename => sub {
   my ($ob, $arg) = @_;

   $ob->speed_left ($ob->speed_left - 0.25);

   if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>]*)> \s*$/x) {
      # compatibility syntax
      rename_to $ob, $1, $2;
   } elsif ($arg =~ /
               ^\s*
               (?:
                  (?: "((?:[^"]+|\\.)*)" | (\S+) )
               \s+)?
               to \s+
               (?: "((?:[^"]+|\\.)*)" | (\S+) )
               \s*$
            /x) {
      # does not unquote $1 or $3
      rename_to $ob, $2||$1, $4||$3;
   } else {
      $ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
   }

   1
};

cf::register_command uptime => sub {
   my ($ob, $arg) = @_;

   my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
   my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
   $ob->reply (undef, "server started $startup, uptime ${runtime}\d");

   1
};

my %IN_MEMORY = (
   cf::MAP_IN_MEMORY => "I",
   cf::MAP_SWAPPED   => "S",
   cf::MAP_LOADING   => "L",
);

cf::register_command maps => sub {
   my ($ob, $arg) = @_;

   no re 'eval'; $arg = qr<$arg>;

   my $format = "%2s %1s %3s %5s %.60s\n";

   $ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK | cf::NDI_UNIQUE);

   for (sort keys %cf::MAP) {
      my $map = $cf::MAP{$_}
         or next;

      next unless $map->path =~ $arg;
      next if $map->{deny_list};

      my $svd = int $cf::RUNTIME - $map->{last_save};
      $svd = "++" if $svd > 99;

      $ob->reply (undef,
                  (sprintf $format,
                   (scalar $map->players), 
                   $IN_MEMORY{$map->in_memory} || "?",
                   $svd,
                   (int $map->reset_at - $cf::RUNTIME),
                   $map->visible_name),
                  cf::NDI_BLACK | cf::NDI_UNIQUE);
   }

   1
};

Revision:	1.25
Committed:	Fri Mar 2 11:13:50 2007 UTC (17 years, 2 months ago) by pippijn
Branch:	MAIN
Changes since 1.24:	+9 -0 lines
Log Message:	whereami in perl
#	User	Rev	Content
1	root	1.1	#! perl
2
3			use POSIX ();
4
5			# miscellaneous commands
6
7			sub rename_to($$$) {
8			my ($ob, $from, $to) = @_;
9
10	root	1.12	$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
11	root	1.1	or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
12
13			127 >= length $to
14			or return $ob->message ("rename: new name must be <= 127 characters.");
15
16			my $item;
17
18			if (length $from) {
19			$item = $ob->find_best_object_match ($from)
20			or return $ob->message ("rename: could not find a matching item to rename.");
21			} else {
22			$item = $ob->find_marked_object ()
23			or return $ob->message ("rename: no from name and no marked item found to rename.");
24			}
25
26			$item->custom_name (length $to ? $to : undef);
27
28			if (length $to) {
29			$item->custom_name ($to);
30			$ob->message ("Your " . $item->base_name . " will now be called $to.");
31			} else {
32			$item->custom_name (undef);
33			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
34			}
35
36			$ob->esrv_update_item (cf::UPD_NAME, $item);
37
38			1
39			}
40
41			sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42
43			sub who_listing(;$) {
44			my ($privileged) = @_;
45
46			my ($numwiz, $numafk) = (0, 0);
47			my @pl;
48
49			foreach my $pl (cf::player::list) {
50	root	1.5	my $ns = $pl->ns or next;
51	root	1.1	my $ob = $pl->ob;
52
53			next unless $ob->map
54			&& ($privileged \|\| !$pl->hidden);
55
56			$numwiz++ if $ob->flag (cf::FLAG_WIZ);
57	root	1.5	$numafk++ if $ns->afk;
58	root	1.1
59			push @pl, $pl;
60			}
61
62			(
63			"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
64			(
65			map {
66	root	1.5	my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
67	root	1.1
68			"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
69			. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
70	root	1.5	. ($ns->afk ? " [AFK]" : "")
71	root	1.1	. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
72	root	1.4	. " [" . $pl->ns->version . "]"
73	root	1.18	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
74	root	1.4	. (sprintf " [rtt %.3fs]", $pl->ns->rtt * 1e-6)
75			. ($privileged ? " " . $pl->ns->host : "")
76	root	1.1	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
77			),
78			eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
79			)
80			}
81
82			cf::register_command who => sub {
83			my ($ob, $arg) = @_;
84
85			$ob->speed_left ($ob->speed_left - 0.25);
86
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	pippijn	1.25	cf::register_command whereami => sub {
93			my ($ob) = @_;
94
95			my $reg = $ob->region;
96			$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
97
98			1
99			};
100
101	pippijn	1.23	cf::register_command applymode => sub {
102			my ($ob, $arg) = @_;
103			my @types = ("nochoice", "never", "always");
104			my $mapping = {
105			nochoice => 1,
106			never => 2,
107			always => 3,
108			};
109
110			my $oldmode = $ob->contr->unapply;
111			my $oldmode_name = $types[$oldmode];
112
113			return $ob->reply (undef, "applymode is set to $oldmode_name")
114			unless $arg;
115
116			return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
117			unless $mapping->{$arg};
118
119			$ob->contr->unapply ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
120			# but $arg would be 0 if a user enters an incorrect value
121			$ob->reply (undef, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);
122
123			1
124			};
125
126			cf::register_command petmode => sub {
127			my ($ob, $arg) = @_;
128			my @types = ("normal", "sad", "defend", "arena");
129			my $mapping = {
130			normal => 1,
131			sad => 2,
132			defend => 3,
133			arena => 4,
134			};
135
136			my $oldtype = $ob->contr->petmode;
137			my $oldtype_name = $types[$oldtype];
138
139			return $ob->reply (undef, "petmode is set to $oldtype_name")
140			unless $arg;
141
142			return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
143			unless $mapping->{$arg};
144
145			$ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
146			# but $arg would be 0 if a user enters an incorrect value
147			$ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);
148
149			1
150			};
151
152	pippijn	1.21	cf::register_command usekeys => sub {
153			my ($ob, $arg) = @_;
154			my @types = ("inventory", "keyrings", "containers");
155			my $mapping = {
156			inventory => 1,
157			keyrings => 2,
158			containers => 3,
159			};
160
161			my $oldtype = $ob->contr->usekeys;
162			my $oldtype_name = $types[$oldtype];
163
164			return $ob->reply (undef, "usekeys is set to $oldtype_name")
165			unless $arg;
166
167	pippijn	1.23	return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
168	pippijn	1.21	unless $mapping->{$arg};
169
170			$ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
171			# but $arg would be 0 if a user enters an incorrect value
172			$ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
173	pippijn	1.22
174			1
175	pippijn	1.21	};
176
177	pippijn	1.19	cf::register_command afk => sub {
178			my ($ob, $arg) = @_;
179
180			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
181			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
182	pippijn	1.22
183			1
184	pippijn	1.19	};
185
186	pippijn	1.21	cf::register_command sound => sub {
187			my ($ob, $arg) = @_;
188
189			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
190			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
191	pippijn	1.22
192			1
193	pippijn	1.21	};
194
195	pippijn	1.20	cf::register_command brace => sub {
196			my ($ob, $arg) = @_;
197
198			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
199			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
200	pippijn	1.22
201			1
202	pippijn	1.20	};
203
204	pippijn	1.24	cf::register_command 'output-count' => sub {
205			my ($ob, $arg) = @_;
206
207			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
208			unless $arg > 0;
209
210			$ob->contr->outputs_count ($arg);
211			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
212
213			1
214			};
215
216			cf::register_command 'output-sync' => sub {
217			my ($ob, $arg) = @_;
218
219			return $ob->reply (undef, "Output sync time is presently " . $ob->contr->outputs_sync)
220			unless $arg > 0;
221
222			$ob->contr->outputs_sync ($arg);
223			$ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync);
224
225			1
226			};
227
228	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
229			# some other level (which may also be 0), this does not get echoed,
230			# but it does get set.
231			cf::register_command wimpy => sub {
232			my ($ob, $arg) = @_;
233
234			my $wimpy = $ob->run_away;
235			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
236			if $arg eq "";
237
238			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
239			if $arg =~ /^\d+$/ and $arg <= 100;
240
241			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
242	pippijn	1.22
243			1
244	pippijn	1.20	};
245
246			cf::register_command peaceful => sub {
247			my ($ob, $arg) = @_;
248
249			$ob->reply (undef, "You cannot change your peaceful setting with this command."
250			." Please speak to the priest in the temple of Gorokh"
251			." if you want to become hostile or in temple of Valriel"
252			." if you want to become peaceful again.");
253
254			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
255			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
256	pippijn	1.22
257			1
258	pippijn	1.20	};
259
260	root	1.1	cf::register_command rename => sub {
261			my ($ob, $arg) = @_;
262
263			$ob->speed_left ($ob->speed_left - 0.25);
264
265			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
266			# compatibility syntax
267			rename_to $ob, $1, $2;
268			} elsif ($arg =~ /
269			^\s*
270			(?:
271			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
272			\s+)?
273			to \s+
274			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
275			\s*$
276			/x) {
277			# does not unquote $1 or $3
278			rename_to $ob, $2\|\|$1, $4\|\|$3;
279			} else {
280			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
281			}
282
283			1
284			};
285
286			cf::register_command uptime => sub {
287			my ($ob, $arg) = @_;
288
289			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
290			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
291			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
292
293			1
294			};
295
296	root	1.8	my %IN_MEMORY = (
297			cf::MAP_IN_MEMORY => "I",
298			cf::MAP_SWAPPED => "S",
299			cf::MAP_LOADING => "L",
300			);
301
302	root	1.7	cf::register_command maps => sub {
303			my ($ob, $arg) = @_;
304
305			no re 'eval'; $arg = qr<$arg>;
306
307	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
308	root	1.7
309	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
310	root	1.7
311			for (sort keys %cf::MAP) {
312			my $map = $cf::MAP{$_}
313			or next;
314
315			next unless $map->path =~ $arg;
316	root	1.17	next if $map->{deny_list};
317	root	1.7
318	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
319			$svd = "++" if $svd > 99;
320
321	root	1.14	$ob->reply (undef,
322			(sprintf $format,
323			(scalar $map->players),
324			$IN_MEMORY{$map->in_memory} \|\| "?",
325			$svd,
326			(int $map->reset_at - $cf::RUNTIME),
327	root	1.17	$map->visible_name),
328	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
329	root	1.7	}
330
331			1
332			};
333