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
};

# 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.23
Committed:	Fri Mar 2 10:54:59 2007 UTC (17 years, 2 months ago) by pippijn
Branch:	MAIN
Changes since 1.22:	+52 -1 lines
Log Message:	- petmode, applymode in perl - echo something back to the user when he does "fix_me"
#	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			# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
196			# some other level (which may also be 0), this does not get echoed,
197			# but it does get set.
198			cf::register_command wimpy => sub {
199			my ($ob, $arg) = @_;
200
201			my $wimpy = $ob->run_away;
202			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
203			if $arg eq "";
204
205			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
206			if $arg =~ /^\d+$/ and $arg <= 100;
207
208			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
209	pippijn	1.22
210			1
211	pippijn	1.20	};
212
213			cf::register_command peaceful => sub {
214			my ($ob, $arg) = @_;
215
216			$ob->reply (undef, "You cannot change your peaceful setting with this command."
217			." Please speak to the priest in the temple of Gorokh"
218			." if you want to become hostile or in temple of Valriel"
219			." if you want to become peaceful again.");
220
221			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
222			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
223	pippijn	1.22
224			1
225	pippijn	1.20	};
226
227
228	root	1.1	cf::register_command rename => sub {
229			my ($ob, $arg) = @_;
230
231			$ob->speed_left ($ob->speed_left - 0.25);
232
233			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
234			# compatibility syntax
235			rename_to $ob, $1, $2;
236			} elsif ($arg =~ /
237			^\s*
238			(?:
239			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
240			\s+)?
241			to \s+
242			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
243			\s*$
244			/x) {
245			# does not unquote $1 or $3
246			rename_to $ob, $2\|\|$1, $4\|\|$3;
247			} else {
248			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
249			}
250
251			1
252			};
253
254			cf::register_command uptime => sub {
255			my ($ob, $arg) = @_;
256
257			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
258			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
259			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
260
261			1
262			};
263
264	root	1.8	my %IN_MEMORY = (
265			cf::MAP_IN_MEMORY => "I",
266			cf::MAP_SWAPPED => "S",
267			cf::MAP_LOADING => "L",
268			);
269
270	root	1.7	cf::register_command maps => sub {
271			my ($ob, $arg) = @_;
272
273			no re 'eval'; $arg = qr<$arg>;
274
275	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
276	root	1.7
277	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
278	root	1.7
279			for (sort keys %cf::MAP) {
280			my $map = $cf::MAP{$_}
281			or next;
282
283			next unless $map->path =~ $arg;
284	root	1.17	next if $map->{deny_list};
285	root	1.7
286	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
287			$svd = "++" if $svd > 99;
288
289	root	1.14	$ob->reply (undef,
290			(sprintf $format,
291			(scalar $map->players),
292			$IN_MEMORY{$map->in_memory} \|\| "?",
293			$svd,
294			(int $map->reset_at - $cf::RUNTIME),
295	root	1.17	$map->visible_name),
296	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
297	root	1.7	}
298
299			1
300			};
301