maps/perl/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 $ob = $pl->ob;

      next unless $ob->map
               && ($privileged || !$pl->hidden);

      $numwiz++ if $ob->flag (cf::FLAG_WIZ);
      $numafk++ if $ob->flag (cf::FLAG_AFK);

      push @pl, $pl;
   }

   (
      "Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
      (
         map {
            my ($pl, $ob) = ($_, $_->ob);
    
            "* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
            . ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
            . ($ob->flag (cf::FLAG_AFK) ? " [AFK]" : "")
            . ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
            . " [" . $pl->socket->client . "]"
            . " [" . ($pl->peaceful || $privileged ? $ob->map->path : $ob->map->region ? $ob->map->region->name : "the unknown") . "]"
            . (sprintf " [rtt %.3fs/%.3f]", $pl->socket->rtt * 1e-6, $pl->socket->rttvar * 1e-6)
            . ($privileged ? " " . $pl->socket->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 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
};

Revision:	1.16
Committed:	Fri Dec 15 19:06:29 2006 UTC (17 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.15:	+3 -2 lines
Log Message:	new accessors
#	User	Rev	Content
1	root	1.1	#! perl
2
3	root	1.14	use POSIX ();
4
5	root	1.1	# miscellaneous commands
6
7			sub rename_to($$$) {
8			my ($ob, $from, $to) = @_;
9
10			$to =~ /^[a-zA-Z0-9.,=#\/%$!^]*$/
11			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	root	1.11	1
39	root	1.1	}
40
41	root	1.13	sub ext::schmorp_irc::users; # HACK: TODO: replace by signal
42
43	root	1.5	sub who_listing(;$) {
44	root	1.4	my ($privileged) = @_;
45
46			my ($numwiz, $numafk) = (0, 0);
47			my @pl;
48
49			foreach my $pl (cf::player::list) {
50			my $ob = $pl->ob;
51
52			next unless $ob->map
53			&& ($privileged \|\| !$pl->hidden);
54
55			$numwiz++ if $ob->flag (cf::FLAG_WIZ);
56			$numafk++ if $ob->flag (cf::FLAG_AFK);
57
58			push @pl, $pl;
59			}
60
61			(
62			"Total Players in The World. (" . (scalar @pl) . ") -- WIZ($numwiz) AFK($numafk) BOT(0)",
63	root	1.13	(
64			map {
65			my ($pl, $ob) = ($_, $_->ob);
66
67			"* " . $ob->name . "/" . $ob->level . " " . (length $pl->own_title ? $pl->own_title : "the " . $pl->title)
68			. ($pl->peaceful ? " [peaceful]" : " [HOSTILE]")
69			. ($ob->flag (cf::FLAG_AFK) ? " [AFK]" : "")
70			. ($ob->flag (cf::FLAG_WIZ) ? " [WIZ]" : "")
71	root	1.16	. " [" . $pl->socket->client . "]"
72	root	1.13	. " [" . ($pl->peaceful \|\| $privileged ? $ob->map->path : $ob->map->region ? $ob->map->region->name : "the unknown") . "]"
73	root	1.16	. (sprintf " [rtt %.3fs/%.3f]", $pl->socket->rtt * 1e-6, $pl->socket->rttvar * 1e-6)
74			. ($privileged ? " " . $pl->socket->host : "")
75	root	1.13	} sort { (lc $a->ob->name) cmp (lc $b->ob->name) } @pl
76			),
77			eval { "* IRC: " . join ", ", ext::schmorp_irc::users },
78	root	1.4	)
79			}
80
81	root	1.15	cf::register_command who => sub {
82	root	1.4	my ($ob, $arg) = @_;
83
84	root	1.15	$ob->speed_left ($ob->speed_left - 0.25);
85
86	root	1.12	$ob->reply (undef, (join "\n", who_listing $ob->may ("extended_who")), cf::NDI_UNIQUE \| cf::NDI_DK_ORANGE);
87	root	1.11
88			1
89	root	1.4	};
90
91	root	1.15	cf::register_command rename => sub {
92	root	1.1	my ($ob, $arg) = @_;
93
94	root	1.15	$ob->speed_left ($ob->speed_left - 0.25);
95
96	root	1.10	if ($arg =~ /^\s* (?: <([^>]+)> \s+)? to \s+ <([^>])> \s$/x) {
97	root	1.2	# compatibility syntax
98	root	1.1	rename_to $ob, $1, $2;
99			} elsif ($arg =~ /
100			^\s*
101			(?:
102			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
103			\s+)?
104			to \s+
105			(?: "((?:[^"]+\|\\.)*)" \| (\S+) )
106			\s*$
107			/x) {
108			# does not unquote $1 or $3
109			rename_to $ob, $2\|\|$1, $4\|\|$3;
110			} else {
111	root	1.4	$ob->reply (undef, 'Syntax error. Rename usage: rename ["oldname"] to "newname"');
112	root	1.1	}
113	root	1.11
114			1
115	root	1.1	};
116	root	1.11
117	root	1.15	cf::register_command uptime => sub {
118	root	1.14	my ($ob, $arg) = @_;
119
120			my $startup = POSIX::strftime "%Y-%m-%d %H:%M:%S %Z", localtime $cf::UPTIME;
121			my $runtime = sprintf "%.1f", (time - $cf::UPTIME) / 86400;
122			$ob->reply (undef, "server started $startup, uptime ${runtime}\d");
123
124			1
125			};
126