server/ext/dm-support.ext

#! perl

use Coro::Debug;
use IO::Socket;

my %global; # for use by eval'ed commands

sub tcp_serve($) {
   my ($fh) = @_;

   binmode $fh, ":raw:perlio:utf8";

   my $buf;
   my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z);
   my (%l, @l); # for use by shell users

   print $fh <<EOF;
Welcome!
Remember that everything entered here will be in the main coro context within cf::!
You can freely use \$a .. \$z and \@l and \%l

Useful commands (note the '&'):

reload_perl &
reload_sound &
reload_config &
reload_regions &
reload_facedata &
reload_exp_table &
reload_materials &
reload_treasures &
reload_resources &
reload_archetypes &
ext::help::reload &
ext::books::reload &
ext::map_tags::reload &
ext::map_world::reload &
ext::player_env::reload &
ext::map_scheduler::reload &
# ext::map_scheduler::loadall & # debugging only!
until (Coro::AnyEvent::readable \$fh, 1) { Coro::Debug::command "ps" } &
({mallinfo})
({objinfo})
EOF
   print $fh "\n> ";

   my $iow; $iow = AE::io $fh, 0, sub {
      if (defined (my $cmd = <$fh>)) {
         $cmd =~ s/\s+$//;

         if ($cmd =~ /^\s*exit\b/i) {
            print $fh "will not exit() server.\n";
         } elsif ($cmd =~ s/^coro\s+// or $cmd =~ /^(?:ps|bt\s)/) {
            select $fh;
            Coro::Debug::command $cmd;
            select STDOUT;
         } else {
            my $sub = sub {
               package cf;
               select $fh;

               # compile first, then execute, as Coro does not support switching in eval string
               my $cb = eval "sub { $cmd \n}";

               my $t1 = EV::time;
               my @res = $@ ? () : eval { $cb->() };
               my $t2 = EV::time;

               print "\n",
                     "command: '$cmd'\n",
                     "execution time: ", $t2 - $t1, "\n";
               print "evaluation error: $@\n" if $@;
               print "result:\n", cf::dumpval @res > 1 ? \@res : $res[0] if @res;
               print "\n> ";

               select STDOUT;
            };

            if ($cmd =~ s/\s*&$//) {
               cf::async {
                  $Coro::current->desc ($cmd);
                  $sub->()
               };
            } else {
               $sub->();
            }
         }

         print $fh "\n> ";
      } else {
         undef $iow;
      }
   };
}

our $LISTENER;

# now a shell listening on a tcp-port - let the firewall decide access rights
if ($cf::CFG{perl_shell}) {
   if (my $listen = new IO::Socket::INET LocalAddr => $cf::CFG{perl_shell}, Listen => 1, ReuseAddr => 1, Blocking => 0) {
      $LISTENER = AE::io $listen, 0, sub { tcp_serve $listen->accept };
   }
}

Revision:	1.37
Committed:	Sun Nov 11 02:38:10 2012 UTC (13 years, 11 months ago) by root
Branch:	MAIN
CVS Tags:	rel-3_1, HEAD
Changes since 1.36:	+2 -2 lines
Log Message:	-Time::HiRes
#	User	Rev	Content
1	root	1.1	#! perl
2
3	root	1.10	use Coro::Debug;
4	root	1.1	use IO::Socket;
5
6			my %global; # for use by eval'ed commands
7
8			sub tcp_serve($) {
9			my ($fh) = @_;
10
11			binmode $fh, ":raw:perlio:utf8";
12
13			my $buf;
14	root	1.2	my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z);
15			my (%l, @l); # for use by shell users
16	root	1.1
17	root	1.12	print $fh <<EOF;
18	root	1.4	Welcome!
19			Remember that everything entered here will be in the main coro context within cf::!
20			You can freely use \$a .. \$z and \@l and \%l
21
22			Useful commands (note the '&'):
23
24			reload_perl &
25	root	1.28	reload_sound &
26	root	1.8	reload_config &
27	root	1.4	reload_regions &
28			reload_facedata &
29	root	1.32	reload_exp_table &
30			reload_materials &
31	root	1.4	reload_treasures &
32	root	1.35	reload_resources &
33	root	1.4	reload_archetypes &
34	root	1.6	ext::help::reload &
35			ext::books::reload &
36	root	1.9	ext::map_tags::reload &
37	root	1.5	ext::map_world::reload &
38	root	1.33	ext::player_env::reload &
39			ext::map_scheduler::reload &
40	root	1.24	# ext::map_scheduler::loadall & # debugging only!
41	root	1.34	until (Coro::AnyEvent::readable \$fh, 1) { Coro::Debug::command "ps" } &
42	root	1.27	({mallinfo})
43			({objinfo})
44	root	1.4	EOF
45	root	1.12	print $fh "\n> ";
46	root	1.1
47	root	1.25	my $iow; $iow = AE::io $fh, 0, sub {
48	root	1.1	if (defined (my $cmd = <$fh>)) {
49	root	1.4	$cmd =~ s/\s+$//;
50	root	1.1
51			if ($cmd =~ /^\s*exit\b/i) {
52	root	1.13	print $fh "will not exit() server.\n";
53	root	1.10	} elsif ($cmd =~ s/^coro\s+// or $cmd =~ /^(?:ps\|bt\s)/) {
54	root	1.13	select $fh;
55	root	1.10	Coro::Debug::command $cmd;
56	root	1.13	select STDOUT;
57	root	1.1	} else {
58	root	1.4	my $sub = sub {
59			package cf;
60			select $fh;
61
62	root	1.19	# compile first, then execute, as Coro does not support switching in eval string
63	root	1.18	my $cb = eval "sub { $cmd \n}";
64	root	1.4
65	root	1.37	my $t1 = EV::time;
66	root	1.4	my @res = $@ ? () : eval { $cb->() };
67	root	1.37	my $t2 = EV::time;
68	root	1.4
69			print "\n",
70			"command: '$cmd'\n",
71			"execution time: ", $t2 - $t1, "\n";
72			print "evaluation error: $@\n" if $@;
73			print "result:\n", cf::dumpval @res > 1 ? \@res : $res[0] if @res;
74			print "\n> ";
75	root	1.12
76			select STDOUT;
77	root	1.4	};
78
79			if ($cmd =~ s/\s*&$//) {
80	root	1.11	cf::async {
81			$Coro::current->desc ($cmd);
82			$sub->()
83			};
84	root	1.4	} else {
85			$sub->();
86			}
87	root	1.1	}
88
89	root	1.13	print $fh "\n> ";
90	root	1.1	} else {
91	root	1.16	undef $iow;
92	root	1.1	}
93	root	1.16	};
94	root	1.1	}
95
96	root	1.16	our $LISTENER;
97
98	root	1.1	# now a shell listening on a tcp-port - let the firewall decide access rights
99			if ($cf::CFG{perl_shell}) {
100	root	1.17	if (my $listen = new IO::Socket::INET LocalAddr => $cf::CFG{perl_shell}, Listen => 1, ReuseAddr => 1, Blocking => 0) {
101	root	1.25	$LISTENER = AE::io $listen, 0, sub { tcp_serve $listen->accept };
102	root	1.1	}
103			}
104	root	1.10