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 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.24
Committed:	Fri Mar 2 11:07:59 2007 UTC (17 years, 2 months ago) by pippijn
Branch:	MAIN
Changes since 1.23:	+24 -1 lines
Log Message:	output-count, output-sync 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.23	cf::register_command applymode => sub {
93			my ($ob, $arg) = @_;
94			my @types = ("nochoice", "never", "always");
95			my $mapping = {
96			nochoice => 1,
97			never => 2,
98			always => 3,
99			};
100
101			my $oldmode = $ob->contr->unapply;
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
114			1
115			};
116
117			cf::register_command petmode => sub {
118			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
127			my $oldtype = $ob->contr->petmode;
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
140			1
141			};
142
143	pippijn	1.21	cf::register_command usekeys => sub {
144			my ($ob, $arg) = @_;
145			my @types = ("inventory", "keyrings", "containers");
146			my $mapping = {
147			inventory => 1,
148			keyrings => 2,
149			containers => 3,
150			};
151
152			my $oldtype = $ob->contr->usekeys;
153			my $oldtype_name = $types[$oldtype];
154
155			return $ob->reply (undef, "usekeys is set to $oldtype_name")
156			unless $arg;
157
158	pippijn	1.23	return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
159	pippijn	1.21	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	pippijn	1.22
165			1
166	pippijn	1.21	};
167
168	pippijn	1.19	cf::register_command afk => sub {
169			my ($ob, $arg) = @_;
170
171			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
172			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
173	pippijn	1.22
174			1
175	pippijn	1.19	};
176
177	pippijn	1.21	cf::register_command sound => sub {
178			my ($ob, $arg) = @_;
179
180			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
181			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
182	pippijn	1.22
183			1
184	pippijn	1.21	};
185
186	pippijn	1.20	cf::register_command brace => sub {
187			my ($ob, $arg) = @_;
188
189			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
190			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
191	pippijn	1.22
192			1
193	pippijn	1.20	};
194
195	pippijn	1.24	cf::register_command 'output-count' => sub {
196			my ($ob, $arg) = @_;
197
198			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
199			unless $arg > 0;
200
201			$ob->contr->outputs_count ($arg);
202			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
203
204			1
205			};
206
207			cf::register_command 'output-sync' => sub {
208			my ($ob, $arg) = @_;
209
210			return $ob->reply (undef, "Output sync time is presently " . $ob->contr->outputs_sync)
211			unless $arg > 0;
212
213			$ob->contr->outputs_sync ($arg);
214			$ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync);
215
216			1
217			};
218
219	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
220			# some other level (which may also be 0), this does not get echoed,
221			# but it does get set.
222			cf::register_command wimpy => sub {
223			my ($ob, $arg) = @_;
224
225			my $wimpy = $ob->run_away;
226			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
227			if $arg eq "";
228
229			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
230			if $arg =~ /^\d+$/ and $arg <= 100;
231
232			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
233	pippijn	1.22
234			1
235	pippijn	1.20	};
236
237			cf::register_command peaceful => sub {
238			my ($ob, $arg) = @_;
239
240			$ob->reply (undef, "You cannot change your peaceful setting with this command."
241			." Please speak to the priest in the temple of Gorokh"
242			." if you want to become hostile or in temple of Valriel"
243			." if you want to become peaceful again.");
244
245			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
246			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
247	pippijn	1.22
248			1
249	pippijn	1.20	};
250
251	root	1.1	cf::register_command rename => sub {
252			my ($ob, $arg) = @_;
253
254			$ob->speed_left ($ob->speed_left - 0.25);
255
256			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
257			# compatibility syntax
258			rename_to $ob, $1, $2;
259			} elsif ($arg =~ /
260			^\s*
261			(?:
262			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
263			\s+)?
264			to \s+
265			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
266			\s*$
267			/x) {
268			# does not unquote $1 or $3
269			rename_to $ob, $2\|\|$1, $4\|\|$3;
270			} else {
271			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
272			}
273
274			1
275			};
276
277			cf::register_command uptime => sub {
278			my ($ob, $arg) = @_;
279
280			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
281			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
282			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
283
284			1
285			};
286
287	root	1.8	my %IN_MEMORY = (
288			cf::MAP_IN_MEMORY => "I",
289			cf::MAP_SWAPPED => "S",
290			cf::MAP_LOADING => "L",
291			);
292
293	root	1.7	cf::register_command maps => sub {
294			my ($ob, $arg) = @_;
295
296			no re 'eval'; $arg = qr<$arg>;
297
298	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
299	root	1.7
300	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
301	root	1.7
302			for (sort keys %cf::MAP) {
303			my $map = $cf::MAP{$_}
304			or next;
305
306			next unless $map->path =~ $arg;
307	root	1.17	next if $map->{deny_list};
308	root	1.7
309	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
310			$svd = "++" if $svd > 99;
311
312	root	1.14	$ob->reply (undef,
313			(sprintf $format,
314			(scalar $map->players),
315			$IN_MEMORY{$map->in_memory} \|\| "?",
316			$svd,
317			(int $map->reset_at - $cf::RUNTIME),
318	root	1.17	$map->visible_name),
319	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
320	root	1.7	}
321
322			1
323			};
324