server/ext/commands.ext

#! perl # mandatory depends=irc

use POSIX ();

# miscellaneous commands

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->gender ? " [f]" : " [m]")
             . ($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->tcpi_rtt * 1e-6)
             . ($privileged ? " " . $pl->ns->host : "")
          } sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
      ),
      eval { "* IRC: " . join ", ", ext::irc::users },
   )
}

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

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

   my $CHANNEL = {
      id      => "who",
      title   => "Players",
      reply   => undef,
      tooltip => "Shows players who are currently online",
   };

   $ob->send_msg ($CHANNEL => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE | cf::NDI_REPLY | cf::NDI_CLEAR | cf::NDI_DEF);
};

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_REPLY);
      } elsif (cf::player::find_active $login) {
         $pl->message ("$login is right here on this server!", cf::NDI_REPLY);
      } 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_REPLY);
      } else {
         $pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
      }
   } else {
      $pl->message ("Usage: seen <player>", cf::NDI_REPLY);
   }
};

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

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

   $reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
   for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
      my $msg = cf::object::slot_nonuse_name $_;
      $msg =~ s/^.*? a //;
      $reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
         if $ob->slot_info ($_) or $ob->slot_used ($_);
   }

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

   my $CHANNEL = {
      id      => "body",
      title   => "Body Parts",
      reply   => undef,
      tooltip => "Shows which body parts you posess and are available",
   };

   $ob->send_msg ($CHANNEL => $reply, cf::NDI_REPLY);
};

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.");
   }
};

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);
   };
   
   cf::register_command "${cmd}_stop" => sub {
      my ($ob) = @_;
      
      $ob->contr->$oncmd (0);
   };
}

our $MAPINFO_CHANNEL = {
   id      => "mapinfo",
   title   => "Map Info",
   reply   => undef,
   tooltip => "Information about the map",
};

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

   my $observe = $ob->contr->observe;

   my $map = $observe->map
      or return;

   my $msg = sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname;
   $msg .= sprintf "\n\nplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
              (scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
      if $ob->flag (cf::FLAG_WIZ);

   $ob->send_msg ($MAPINFO_CHANNEL => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
};

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

   my $reg = $ob->contr->observe->region;
   $ob->send_msg ($MAPINFO_CHANNEL => (sprintf "You are %s.\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY | cf::NDI_CLEAR);
};

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

   my %count;

   for my $pl (cf::player::list) {
      ++$count{$pl->ob->region->longname};
   }

   my $msg = "In the world currently there are:\n\n"
           . join "", map "$count{$_} player(s) $_\n\n", sort keys %count;

   $ob->send_msg ($MAPINFO_CHANNEL => $msg, cf::NDI_REPLY | cf::NDI_CLEAR);
};

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

   my $url = $cf::CFG->{hiscore_url};
   $ob->send_msg (log => "See $url", cf::NDI_REPLY);
};

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

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

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

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

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

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

   _set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
};

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

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...");
};

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.");
};

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 5k/s
   # maximum is 100k/s, this should be configurable
   $ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
   $ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
};

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

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

# 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");
};

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.");
};

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
}

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"');
   }
};

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->send_msg (log => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY);
};

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->send_msg ($MAPINFO_CHANNEL => (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_REPLY | cf::NDI_CLEAR);

   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->send_msg ($MAPINFO_CHANNEL =>
                  (sprintf $format,
                   (scalar $map->players), 
                   $IN_MEMORY{$map->in_memory} || "?",
                   $svd,
                   (int $map->reset_at - $cf::RUNTIME),
                   $map->visible_name)
      );
   }
};

Revision:	1.62
Committed:	Sat Sep 8 10:14:09 2007 UTC (16 years, 8 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_2
Changes since 1.61:	+37 -15 lines
Log Message:	this is a mess still, needs some redesigning
#	User	Rev	Content
1	root	1.47	#! perl # mandatory depends=irc
2	root	1.1
3			use POSIX ();
4
5			# miscellaneous commands
6
7	root	1.42	sub who_listing(;$$) {
8			my ($privileged, $select) = @_;
9	root	1.1
10			my ($numwiz, $numafk) = (0, 0);
11			my @pl;
12
13			foreach my $pl (cf::player::list) {
14	root	1.5	my $ns = $pl->ns or next;
15	root	1.1	my $ob = $pl->ob;
16
17			next unless $ob->map
18			&& ($privileged \|\| !$pl->hidden);
19
20			$numwiz++ if $ob->flag (cf::FLAG_WIZ);
21	root	1.5	$numafk++ if $ns->afk;
22	root	1.1
23			push @pl, $pl;
24			}
25
26			(
27			"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
28	root	1.42	(grep /$select/,
29			map {
30			my ($pl, $ob, $ns) = ($_, $_->ob, $_->ns);
31
32			"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
33	root	1.48	. ($pl->gender ? " [f]" : " [m]")
34	root	1.42	. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
35			. ($ns->afk ? " [AFK]" : "")
36			. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
37			. " [" . $pl->ns->version . "]"
38			. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->visible_name : $ob->region->name) . "]"
39	root	1.57	. (sprintf " [rtt %.3fs]", $pl->ns->tcpi_rtt * 1e-6)
40	root	1.42	. ($privileged ? " " . $pl->ns->host : "")
41			} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
42	root	1.1	),
43	root	1.45	eval { "* IRC: " . join ", ", ext::irc::users },
44	root	1.1	)
45			}
46
47			cf::register_command who => sub {
48			my ($ob, $arg) = @_;
49
50	root	1.42	$ob->speed_left ($ob->speed_left - 4);
51	root	1.1
52	root	1.62	my $CHANNEL = {
53			id => "who",
54			title => "Players",
55			reply => undef,
56			tooltip => "Shows players who are currently online",
57			};
58
59			$ob->send_msg ($CHANNEL => (join "\n\n", who_listing $ob->may ("extended_who"), $arg), cf::NDI_DK_ORANGE \| cf::NDI_REPLY \| cf::NDI_CLEAR \| cf::NDI_DEF);
60	root	1.1	};
61
62	root	1.40	cf::register_command seen => sub {
63			my ($pl, $args) = @_;
64
65			if (my ($login) = $args =~ /(\S+)/) {
66			if ($login eq $pl->name) {
67	root	1.62	$pl->message ("Very funny, $login. Ha. Ha.", cf::NDI_REPLY);
68	root	1.40	} elsif (cf::player::find_active $login) {
69	root	1.62	$pl->message ("$login is right here on this server!", cf::NDI_REPLY);
70	root	1.40	} elsif (cf::player::exists $login
71			and stat cf::player::path $login) {
72			my $time = (stat _)[9];
73
74			$pl->message ("$login was last seen here "
75			. (POSIX::strftime "%Y-%m-%d %H:%M:%S +0000", gmtime $time)
76	root	1.62	. " which was " . (int +(time - $time) / 3600) . " hours ago.", cf::NDI_REPLY);
77	root	1.40	} else {
78	root	1.62	$pl->message ("No player named $login is known to me.", cf::NDI_REPLY);
79	root	1.40	}
80			} else {
81	root	1.62	$pl->message ("Usage: seen <player>", cf::NDI_REPLY);
82	root	1.40	}
83			};
84
85	pippijn	1.27	cf::register_command body => sub {
86			my ($ob) = @_;
87
88			# Too hard to try and make a header that lines everything up, so just
89			# give a description. (comment from C++)
90	root	1.44	my $reply =
91	root	1.52	"The first column is the name of the body location.\n\n"
92			. "The second column is how many of those locations your body has.\n\n"
93			. "The third column is how many slots in that location are available.\n\n";
94	pippijn	1.27
95	root	1.52	$reply .= sprintf " %-20s %3s %5s\n", "Location", "You", "Avail";
96	root	1.43	for (0 .. cf::NUM_BODY_LOCATIONS - 1) {
97	root	1.44	my $msg = cf::object::slot_nonuse_name $_;
98			$msg =~ s/^.*? a //;
99	root	1.52	$reply .= sprintf " %-20s %3d %5d\n", $msg, $ob->slot_info ($_), $ob->slot_used ($_)
100	root	1.43	if $ob->slot_info ($_) or $ob->slot_used ($_);
101	pippijn	1.27	}
102
103	root	1.52	$reply .= "You are not allowed to wear armor\n\n"
104	pippijn	1.27	unless $ob->flag (cf::FLAG_USE_ARMOUR);
105	root	1.52	$reply .= "You are not allowed to use weapons\n\n"
106	pippijn	1.27	unless $ob->flag (cf::FLAG_USE_WEAPON);
107
108	root	1.62	my $CHANNEL = {
109			id => "body",
110			title => "Body Parts",
111			reply => undef,
112			tooltip => "Shows which body parts you posess and are available",
113			};
114
115			$ob->send_msg ($CHANNEL => $reply, cf::NDI_REPLY);
116	pippijn	1.27	};
117
118	pippijn	1.28	cf::register_command mark => sub {
119			my ($pl, $arg) = @_;
120
121	pippijn	1.32	if (length $arg) {
122	pippijn	1.28	my $ob = $pl->find_best_object_match ($arg);
123
124			return $pl->reply (undef, "Could not find an object that matches $arg")
125			unless $ob;
126
127	pippijn	1.29	$pl->contr->mark ($ob);
128	pippijn	1.28	$pl->reply (undef, (sprintf "Marked item %s", $ob->name, $ob->title));
129	pippijn	1.32	} else {
130			my $ob = $pl->find_marked_object;
131
132			$pl->reply (undef, $ob
133			? (sprintf "%s %s * is marked.", $ob->name, $ob->title)
134			: "You have no marked object.");
135	pippijn	1.28	}
136			};
137
138			for my $cmd ("run", "fire") {
139			my $oncmd = "${cmd}_on";
140			cf::register_command $cmd => sub {
141			my ($ob, $arg) = @_;
142
143	pippijn	1.34	$ob->reply (undef, "Can't $cmd into a non adjacent square.")
144	pippijn	1.28	if $arg < 0 or $arg >= 9;
145
146	pippijn	1.34	$ob->contr->$oncmd (1);
147			$ob->move_player ($arg);
148	pippijn	1.28	};
149	pippijn	1.34
150	pippijn	1.28	cf::register_command "${cmd}_stop" => sub {
151			my ($ob) = @_;
152
153			$ob->contr->$oncmd (0);
154			};
155			}
156
157	root	1.62	our $MAPINFO_CHANNEL = {
158			id => "mapinfo",
159			title => "Map Info",
160			reply => undef,
161			tooltip => "Information about the map",
162			};
163
164	pippijn	1.26	cf::register_command mapinfo => sub {
165			my ($ob) = @_;
166
167	root	1.56	my $observe = $ob->contr->observe;
168	root	1.55
169	root	1.56	my $map = $observe->map
170	pippijn	1.26	or return;
171	root	1.60
172			my $msg = sprintf "%s (%s) %s", $map->name, $map->path, $observe->region->longname;
173			$msg .= sprintf "\n\nplayers: %d difficulty: %d size: %d start: %dx%d timeout: %d",
174			(scalar $map->players), $map->difficulty, $map->width, $map->height, $map->enter_x, $map->enter_y, $map->timeout
175	pippijn	1.26	if $ob->flag (cf::FLAG_WIZ);
176	root	1.62
177			$ob->send_msg ($MAPINFO_CHANNEL => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
178	pippijn	1.26	};
179
180	pippijn	1.25	cf::register_command whereami => sub {
181			my ($ob) = @_;
182
183	root	1.50	my $reg = $ob->contr->observe->region;
184	root	1.62	$ob->send_msg ($MAPINFO_CHANNEL => (sprintf "You are %s.\n%s", $reg->longname, $reg->msg), cf::NDI_REPLY \| cf::NDI_CLEAR);
185	root	1.58	};
186
187			cf::register_command whereabouts => sub {
188			my ($ob, $arg) = @_;
189
190			my %count;
191
192			for my $pl (cf::player::list) {
193			++$count{$pl->ob->region->longname};
194			}
195
196			my $msg = "In the world currently there are:\n\n"
197	root	1.61	. join "", map "$count{$_} player(s) $_\n\n", sort keys %count;
198	root	1.58
199	root	1.62	$ob->send_msg ($MAPINFO_CHANNEL => $msg, cf::NDI_REPLY \| cf::NDI_CLEAR);
200	root	1.58	};
201
202			cf::register_command hiscore => sub {
203			my ($ob, $arg) = @_;
204	pippijn	1.25
205	root	1.58	my $url = $cf::CFG->{hiscore_url};
206	root	1.60	$ob->send_msg (log => "See $url", cf::NDI_REPLY);
207	pippijn	1.25	};
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
230			cf::register_command petmode => sub {
231			my ($ob, $arg) = @_;
232
233	root	1.31	_set_mode "petmode", $ob, $arg, petmode => qw(normal sad defend arena);
234	pippijn	1.23	};
235
236	pippijn	1.21	cf::register_command usekeys => sub {
237			my ($ob, $arg) = @_;
238
239	root	1.31	_set_mode "usekeys", $ob, $arg, usekeys => qw(inventory keyrings containers);
240	pippijn	1.21	};
241
242	root	1.51	cf::register_command hintmode => sub {
243			my ($ob, $arg) = @_;
244
245			_set_mode "hintmode", $ob, $arg, hintmode => qw(show mark hide);
246			};
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			};
254
255	pippijn	1.21	cf::register_command sound => sub {
256			my ($ob, $arg) = @_;
257
258			$ob->contr->ns->sound ($ob->contr->ns->sound ? 0 : 1);
259			$ob->reply (undef, $ob->contr->ns->sound ? "The sounds are enabled." : "Silence is golden...");
260			};
261
262	pippijn	1.20	cf::register_command brace => sub {
263			my ($ob, $arg) = @_;
264
265			$ob->contr->braced ($ob->contr->braced ? 0 : 1);
266			$ob->reply (undef, $ob->contr->braced ? "You are braced." : "Not braced.");
267			};
268
269	root	1.35	cf::register_command 'output-rate' => sub {
270			my ($ob, $arg) = @_;
271
272			return $ob->reply (undef, sprintf "Output rate is presently %dbps.", $ob->contr->ns->max_rate / $cf::TICK)
273			unless $arg > 0;
274
275	root	1.54	# minimum is 5k/s
276	root	1.57	# maximum is 100k/s, this should be configurable
277			$ob->contr->ns->max_rate ((List::Util::max 5000, List::Util::min 100000, $arg) * $cf::TICK);
278	root	1.36	$ob->reply (undef, sprintf "Output rate now set to %dbps.", $ob->contr->ns->max_rate / $cf::TICK);
279	root	1.35	};
280
281	pippijn	1.24	cf::register_command 'output-count' => sub {
282			my ($ob, $arg) = @_;
283
284			return $ob->reply (undef, "Output count is presently " . $ob->contr->outputs_count)
285			unless $arg > 0;
286
287	root	1.41	$arg = 4 if $arg < 4;
288
289	pippijn	1.24	$ob->contr->outputs_count ($arg);
290			$ob->reply (undef, "Output count now set to " . $ob->contr->outputs_count);
291			};
292
293			cf::register_command 'output-sync' => sub {
294			my ($ob, $arg) = @_;
295
296	root	1.38	return $ob->reply (undef, sprintf "Output sync time is presently %.1fs", $ob->contr->outputs_sync * $cf::TICK)
297			unless length $arg;
298	pippijn	1.24
299	root	1.41	$arg = 0.5 if $arg < 0.5;
300
301	root	1.38	$ob->contr->outputs_sync ($arg / $cf::TICK);
302			$ob->reply (undef, sprintf "Output sync time now set to %.1fs", $ob->contr->outputs_sync * $cf::TICK);
303	pippijn	1.24	};
304
305	pippijn	1.20	# XXX: This has a bug. After one sets his wimpy level to 0 and resets it to
306			# some other level (which may also be 0), this does not get echoed,
307			# but it does get set.
308			cf::register_command wimpy => sub {
309			my ($ob, $arg) = @_;
310
311			my $wimpy = $ob->run_away;
312			return $ob->reply (undef, "Your current wimpy level is $wimpy.")
313			if $arg eq "";
314
315			return $ob->run_away ($arg) && $ob->reply (undef, "Your new wimpy level is $arg.")
316			if $arg =~ /^\d+$/ and $arg <= 100;
317
318			$ob->reply (undef, "Incorrect parameters for wimpy: $arg");
319			};
320
321			cf::register_command peaceful => sub {
322			my ($ob, $arg) = @_;
323
324			$ob->reply (undef, "You cannot change your peaceful setting with this command."
325			." Please speak to the priest in the temple of Gorokh"
326			." if you want to become hostile or in temple of Valriel"
327			." if you want to become peaceful again.");
328
329			#$ob->contr->peaceful ($ob->contr->peaceful ? 0 : 1);
330			#$ob->reply (undef, $ob->contr->peaceful ? "You will attack other players." : "You will not attack other players.");
331	root	1.58	};
332
333			sub rename_to($$$) {
334			my ($ob, $from, $to) = @_;
335
336			$to =~ /^[a-zA-Z0-9.,=#\/%$!^ ]*$/
337			or return $ob->message ("rename: name must consist only of letters, digits, spaces and a few other things.");
338
339			127 >= length $to
340			or return $ob->message ("rename: new name must be <= 127 characters.");
341
342			my $item;
343
344			if (length $from) {
345			$item = $ob->find_best_object_match ($from)
346			or return $ob->message ("rename: could not find a matching item to rename.");
347			} else {
348			$item = $ob->find_marked_object
349			or return $ob->message ("rename: no from name and no marked item found to rename.");
350			}
351	pippijn	1.22
352	root	1.58	$item->custom_name (length $to ? $to : undef);
353
354			if (length $to) {
355			$item->custom_name ($to);
356			$ob->message ("Your " . $item->base_name . " will now be called $to.");
357			} else {
358			$item->custom_name (undef);
359			$ob->message ("You stop calling your " . $item->base_name . " with weird names.");
360			}
361
362			$ob->esrv_update_item (cf::UPD_NAME, $item);
363
364			1
365			}
366	pippijn	1.20
367	root	1.1	cf::register_command rename => sub {
368			my ($ob, $arg) = @_;
369
370			$ob->speed_left ($ob->speed_left - 0.25);
371
372			if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
373			# compatibility syntax
374			rename_to $ob, $1, $2;
375			} elsif ($arg =~ /
376			^\s*
377			(?:
378			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
379			\s+)?
380			to \s+
381			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
382			\s*$
383			/x) {
384			# does not unquote $1 or $3
385			rename_to $ob, $2\|\|$1, $4\|\|$3;
386			} else {
387			$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
388			}
389			};
390
391			cf::register_command uptime => sub {
392			my ($ob, $arg) = @_;
393
394			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
395			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
396	root	1.62	$ob->send_msg (log => "server started $startup, uptime ${runtime}\d", cf::NDI_REPLY);
397	root	1.1	};
398
399	root	1.8	my %IN_MEMORY = (
400			cf::MAP_IN_MEMORY => "I",
401			cf::MAP_SWAPPED => "S",
402			cf::MAP_LOADING => "L",
403			);
404
405	root	1.7	cf::register_command maps => sub {
406			my ($ob, $arg) = @_;
407
408			no re 'eval'; $arg = qr<$arg>;
409
410	root	1.13	my $format = "%2s %1s %3s %5s %.60s\n";
411	root	1.7
412	root	1.62	$ob->send_msg ($MAPINFO_CHANNEL => (sprintf $format, "Pl", "I", "Svd", "Reset", "Name"), cf::NDI_REPLY \| cf::NDI_CLEAR);
413	root	1.7
414			for (sort keys %cf::MAP) {
415			my $map = $cf::MAP{$_}
416			or next;
417
418			next unless $map->path =~ $arg;
419	root	1.17	next if $map->{deny_list};
420	root	1.7
421	root	1.10	my $svd = int $cf::RUNTIME - $map->{last_save};
422			$svd = "++" if $svd > 99;
423
424	root	1.62	$ob->send_msg ($MAPINFO_CHANNEL =>
425	root	1.14	(sprintf $format,
426			(scalar $map->players),
427			$IN_MEMORY{$map->in_memory} \|\| "?",
428			$svd,
429			(int $map->reset_at - $cf::RUNTIME),
430	root	1.62	$map->visible_name)
431			);
432	root	1.7	}
433			};
434