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 body => sub {
   my ($ob) = @_;

   my @body_locations = ("in your range slot", "on your arm", "on your body", "on your head",
      "around your neck", "in your skill slot", "on your finger", "around your shoulders",
      "on your feet", "on your hands", "around your wrists", "around your waist");

   # Too hard to try and make a header that lines everything up, so just
   # give a description. (comment from C++)
   $ob->reply (undef, "The first column is the name of the body location.");
   $ob->reply (undef, "The second column is how many of those locations your body has.");
   $ob->reply (undef, "The third column is how many slots in that location are available.");

   for (0 .. scalar @body_locations - 1) {
      $ob->reply (undef, (sprintf "%-30s %5d %5d", $body_locations[$_], $ob->body_info($_), $ob->body_used($_)))
         if $ob->body_info($_) or $ob->body_used($_);
   }

   $ob->reply (undef, "You are not allowed to wear armor")
      unless $ob->flag (cf::FLAG_USE_ARMOUR);
   $ob->reply (undef, "You are not allowed to use weapons")
      unless $ob->flag (cf::FLAG_USE_WEAPON);

   1
};

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

   unless (length $arg) {
      my $ob = $pl->find_marked_object;

      $pl->reply (undef, $ob
         ? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
         : "You have no marked object.");
   } else {
      my $ob = $pl->find_best_object_match ($arg);

      return $pl->reply (undef, "Could not find an object that matches $arg")
         unless $ob;

      $pl->contr->mark ($ob);
      $pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
   }

   1
};

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

for my $cmd ("run", "fire") {
   my $oncmd = "${cmd}_on";
   cf::register_command $cmd => sub {
      my ($ob, $arg) = @_;

      return $ob->reply (undef, "Can't $cmd into a non adjacent square.")
         if $arg < 0 or $arg >= 9;

      $ob->contr->$oncmd (1);
      $ob->move ($arg);
      
      1
   };

   cf::register_command "${cmd}_stop" => sub {
      my ($ob) = @_;
      
      $ob->contr->$oncmd (0);

      1
   };
}

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

   my $map = $ob->map
      or return;
   $ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
   $ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
         $map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
      if $ob->flag (cf::FLAG_WIZ);
   $ob->reply (undef, $map->msg);

   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.30
Committed:	Fri Mar 2 14:24:53 2007 UTC (19 years, 7 months ago) by pippijn
Branch:	MAIN
Changes since 1.29:	+1 -1 lines
Log Message:	allow for $arg == 0
#	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.27	cf::register_command body => sub {
93			my ($ob) = @_;
94
95			my @body_locations = ("in your range slot", "on your arm", "on your body", "on your head",
96			"around your neck", "in your skill slot", "on your finger", "around your shoulders",
97			"on your feet", "on your hands", "around your wrists", "around your waist");
98
99			# Too hard to try and make a header that lines everything up, so just
100			# give a description. (comment from C++)
101			$ob->reply (undef, "The first column is the name of the body location.");
102			$ob->reply (undef, "The second column is how many of those locations your body has.");
103			$ob->reply (undef, "The third column is how many slots in that location are available.");
104
105			for (0 .. scalar @body_locations - 1) {
106			$ob->reply (undef, (sprintf "%-30s %5d %5d", $body_locations[$_], $ob->body_info($_), $ob->body_used($_)))
107			if $ob->body_info($_) or $ob->body_used($_);
108			}
109
110			$ob->reply (undef, "You are not allowed to wear armor")
111			unless $ob->flag (cf::FLAG_USE_ARMOUR);
112			$ob->reply (undef, "You are not allowed to use weapons")
113			unless $ob->flag (cf::FLAG_USE_WEAPON);
114
115			1
116			};
117
118	pippijn	1.28	cf::register_command mark => sub {
119			my ($pl, $arg) = @_;
120
121	pippijn	1.30	unless (length $arg) {
122	pippijn	1.28	my $ob = $pl->find_marked_object;
123
124			$pl->reply (undef, $ob
125			? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
126			: "You have no marked object.");
127			} else {
128			my $ob = $pl->find_best_object_match ($arg);
129
130			return $pl->reply (undef, "Could not find an object that matches $arg")
131			unless $ob;
132
133	pippijn	1.29	$pl->contr->mark ($ob);
134	pippijn	1.28	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
135			}
136
137			1
138			};
139
140	pippijn	1.27	cf::register_command who => sub {
141			my ($ob, $arg) = @_;
142
143			$ob->speed_left ($ob->speed_left - 0.25);
144
145			$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
146
147			1
148			};
149
150	pippijn	1.28	for my $cmd ("run", "fire") {
151			my $oncmd = "${cmd}_on";
152			cf::register_command $cmd => sub {
153			my ($ob, $arg) = @_;
154
155			return $ob->reply (undef, "Can't $cmd into a non adjacent square.")
156			if $arg < 0 or $arg >= 9;
157
158			$ob->contr->$oncmd (1);
159			$ob->move ($arg);
160
161			1
162			};
163
164			cf::register_command "${cmd}_stop" => sub {
165			my ($ob) = @_;
166
167			$ob->contr->$oncmd (0);
168
169			1
170			};
171			}
172
173	pippijn	1.26	cf::register_command mapinfo => sub {
174			my ($ob) = @_;
175
176			my $map = $ob->map
177			or return;
178			$ob->reply (undef, (sprintf "%s (%s) %s", $map->name, $map->path, $ob->region->longname));
179			$ob->reply (undef, (sprintf "players: %d difficulty: %d size: %d start: %dx%d timeout: %d",
180			$map->players, $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout))
181			if $ob->flag (cf::FLAG_WIZ);
182			$ob->reply (undef, $map->msg);
183
184			1
185			};
186
187	pippijn	1.25	cf::register_command whereami => sub {
188			my ($ob) = @_;
189
190			my $reg = $ob->region;
191			$ob->reply (undef, (sprintf "You are %s.\n%s", $reg->longname, $reg->msg));
192
193			1
194			};
195
196	pippijn	1.23	cf::register_command applymode => sub {
197			my ($ob, $arg) = @_;
198			my @types = ("nochoice", "never", "always");
199			my $mapping = {
200			nochoice => 1,
201			never => 2,
202			always => 3,
203			};
204
205			my $oldmode = $ob->contr->unapply;
206			my $oldmode_name = $types[$oldmode];
207
208			return $ob->reply (undef, "applymode is set to $oldmode_name")
209			unless $arg;
210
211			return $ob->reply (undef, "applymode: Unknown options '$arg', valid options are @types")
212			unless $mapping->{$arg};
213
214			$ob->contr->unapply ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
215			# but $arg would be 0 if a user enters an incorrect value
216			$ob->reply (undef, "applymode" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $types[$ob->contr->unapply]);
217
218			1
219			};
220
221			cf::register_command petmode => sub {
222			my ($ob, $arg) = @_;
223			my @types = ("normal", "sad", "defend", "arena");
224			my $mapping = {
225			normal => 1,
226			sad => 2,
227			defend => 3,
228			arena => 4,
229			};
230
231			my $oldtype = $ob->contr->petmode;
232			my $oldtype_name = $types[$oldtype];
233
234			return $ob->reply (undef, "petmode is set to $oldtype_name")
235			unless $arg;
236
237			return $ob->reply (undef, "petmode: Unknown options '$arg', valid options are @types")
238			unless $mapping->{$arg};
239
240			$ob->contr->petmode ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
241			# but $arg would be 0 if a user enters an incorrect value
242			$ob->reply (undef, "petmode" . ($oldtype == $ob->contr->petmode ? "" : " now") . " set to " . $types[$ob->contr->petmode]);
243
244			1
245			};
246
247	pippijn	1.21	cf::register_command usekeys => sub {
248			my ($ob, $arg) = @_;
249			my @types = ("inventory", "keyrings", "containers");
250			my $mapping = {
251			inventory => 1,
252			keyrings => 2,
253			containers => 3,
254			};
255
256			my $oldtype = $ob->contr->usekeys;
257			my $oldtype_name = $types[$oldtype];
258
259			return $ob->reply (undef, "usekeys is set to $oldtype_name")
260			unless $arg;
261
262	pippijn	1.23	return $ob->reply (undef, "usekeys: Unknown options '$arg', valid options are @types")
263	pippijn	1.21	unless $mapping->{$arg};
264
265			$ob->contr->usekeys ($mapping->{$arg} - 1); # HACK: because of the $mapping->{$arg} check before, where $arg should not be 0
266			# but $arg would be 0 if a user enters an incorrect value
267			$ob->reply (undef, "usekeys" . ($oldtype == $ob->contr->usekeys ? "" : " now") . " set to " . $types[$ob->contr->usekeys]);
268	pippijn	1.22
269			1
270	pippijn	1.21	};
271
272	pippijn	1.19	cf::register_command afk => sub {
273			my ($ob, $arg) = @_;
274
275			$ob->contr->ns->afk ($ob->contr->ns->afk ? 0 : 1);
276			$ob->reply (undef, $ob->contr->ns->afk ? "You are now AFK" : "You are no longer AFK");
277	pippijn	1.22
278			1
279	pippijn	1.19	};
280
281	pippijn	1.21	cf::register_command sound => sub {
282			my ($ob, $arg) = @_;
283
284			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
285			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
286	pippijn	1.22
287			1
288	pippijn	1.21	};
289
290	pippijn	1.20	cf::register_command brace => sub {
291			my ($ob, $arg) = @_;
292
293			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
294			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
295	pippijn	1.22
296			1
297	pippijn	1.20	};
298
299	pippijn	1.24	cf::register_command 'output-count' => sub {
300			my ($ob, $arg) = @_;
301
302			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
303			unless $arg > 0;
304
305			$ob->contr->outputs_count ($arg);
306			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
307
308			1
309			};
310
311			cf::register_command 'output-sync' => sub {
312			my ($ob, $arg) = @_;
313
314			return $ob->reply (undef, "Output sync time is presently " . $ob->contr->outputs_sync)
315			unless $arg > 0;
316
317			$ob->contr->outputs_sync ($arg);
318			$ob->reply (undef, "Output sync time now set to " . $ob->contr->outputs_sync);
319
320			1
321			};
322
323	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
324			# some other level (which may also be 0), this does not get echoed,
325			# but it does get set.
326			cf::register_command wimpy => sub {
327			my ($ob, $arg) = @_;
328
329			my $wimpy = $ob->run_away;
330			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
331			if $arg eq "";
332
333			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
334			if $arg =~ /^\d+$/ and $arg <= 100;
335
336			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
337	pippijn	1.22
338			1
339	pippijn	1.20	};
340
341			cf::register_command peaceful => sub {
342			my ($ob, $arg) = @_;
343
344			$ob->reply (undef, "You cannot change your peaceful setting with this command."
345			." Please speak to the priest in the temple of Gorokh"
346			." if you want to become hostile or in temple of Valriel"
347			." if you want to become peaceful again.");
348
349			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
350			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
351	pippijn	1.22
352			1
353	pippijn	1.20	};
354
355	root	1.1	cf::register_command rename => sub {
356			my ($ob, $arg) = @_;
357
358			$ob->speed_left ($ob->speed_left - 0.25);
359
360			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
361			# compatibility syntax
362			rename_to $ob, $1, $2;
363			} elsif ($arg =~ /
364			^\s*
365			(?:
366			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
367			\s+)?
368			to \s+
369			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
370			\s*$
371			/x) {
372			# does not unquote $1 or $3
373			rename_to $ob, $2\|\|$1, $4\|\|$3;
374			} else {
375			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
376			}
377
378			1
379			};
380
381			cf::register_command uptime => sub {
382			my ($ob, $arg) = @_;
383
384			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
385			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
386			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
387
388			1
389			};
390
391	root	1.8	my %IN_MEMORY = (
392			cf::MAP_IN_MEMORY => "I",
393			cf::MAP_SWAPPED => "S",
394			cf::MAP_LOADING => "L",
395			);
396
397	root	1.7	cf::register_command maps => sub {
398			my ($ob, $arg) = @_;
399
400			no re 'eval'; $arg = qr<$arg>;
401
402	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
403	root	1.7
404	root	1.15	$ob->reply (undef, (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_BLACK \| cf::NDI_UNIQUE);
405	root	1.7
406			for (sort keys %cf::MAP) {
407			my $map = $cf::MAP{$_}
408			or next;
409
410			next unless $map->path =~ $arg;
411	root	1.17	next if $map->{deny_list};
412	root	1.7
413	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
414			$svd = "++" if $svd > 99;
415
416	root	1.14	$ob->reply (undef,
417			(sprintf $format,
418			(scalar $map->players),
419			$IN_MEMORY{$map->in_memory} \|\| "?",
420			$svd,
421			(int $map->reset_at - $cf::RUNTIME),
422	root	1.17	$map->visible_name),
423	root	1.14	cf::NDI_BLACK \| cf::NDI_UNIQUE);
424	root	1.7	}
425
426			1
427			};
428