server/ext/commands.ext

#! perl # MANDATORY

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, $select) = @_;

   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)",
      (grep /$select/,
          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 - 4);

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

   1
};

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

   if (my ($login) = $args =~ /(\S+)/) {
      if ($login eq $pl->name) {
         $pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_UNIQUE);
      } elsif (cf::player::find_active $login) {
         $pl->message ("$login is right here on this server!", cf::NDI_UNIQUE);
      } elsif (cf::player::exists $login
               and stat cf::player::path $login) {
         my $time = (stat _)[9];

         $pl->message ("$login was last seen here "
                        . (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
                        . " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_UNIQUE);
      } else {
         $pl->message ("No player named $login is known to me.", cf::NDI_UNIQUE);
      }
   } else {
      $pl->message ("Usage: seen <player>", cf::NDI_UNIQUE);
   }
};

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) = @_;

   if (length $arg) {
      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));
   } else {
      my $ob = $pl->find_marked_object;

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

   1
};

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

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

      $ob->contr->$oncmd (1);
      $ob->move_player ($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
};

sub _set_mode($$$@) {
   my ($name, $ob, $arg, $slot, @choices) = @_;

   my $oldmode = $ob->contr->$slot;

   return $ob->reply (undef, "$name is set to $choices[$oldmode]")
      unless $arg;

   my ($idx) = grep $choices[$_] eq $arg, 0 .. $#choices
      or return $ob->reply (undef, "$name: Unknown options '$arg', valid options are @choices"), 1;

   $ob->contr->$slot ($idx);
   $ob->reply (undef, "$name" . ($oldmode == $ob->contr->unapply ? "" : " now") . " set to " . $choices[$ob->contr->$slot]);
}

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

   _set_mode "applymode", $ob, $arg, unapply => qw(nochoice never always);

   1
};

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

   _set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);

   1
};

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

   _set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);

   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-rate' => sub {
   my ($ob, $arg) = @_;

   return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
      unless $arg > 0;

   # minimum is 2k/s
   $ob->contr->ns->max_rate ((List::Util::max 2048, $arg) * $cf::TICK);
   $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);

   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;

   $arg = 4 if $arg < 4;

   $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, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
      unless length $arg;

   $arg = 0.5 if $arg < 0.5;

   $ob->contr->outputs_sync ($arg / $cf::TICK);
   $ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);

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