server/ext/dm-support.ext

#! perl

use IO::Socket;
use Storable qw/nfreeze thaw/;

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

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

   select $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 <<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_regions &
reload_facedata &
reload_treasures &
reload_archetypes &
EOF
   print "\n> ";

   Event->io (fd => $fh, poll => 'r', data => 0, cb => sub {
      if (defined (my $cmd = <$fh>)) {
         $cmd =~ s/\s+$//;

         if ($cmd =~ /^\s*exit\b/i) {
            print "will not exit() server.\n";
         } else {
            my $sub = sub {
               package cf;
               select $fh;

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

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

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

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

         print "\n> ";
      } else {
         $_[0]->w->cancel;
      }
   });
}

# 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) {
      Event->io (fd => $listen, poll => 'r', data => cf::WF_AUTOCANCEL, cb => sub { tcp_serve $listen->accept });
   }
}
Revision:	1.4
Committed:	Tue Apr 17 10:38:28 2007 UTC (17 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.3:	+42 -12 lines
Log Message:	- rename load_xxx to reload_xxx, all of which are guarenteed to a) do their thing b) take no parameters c) almost certainly fail when not run asynchronously - considerably improve dmshell (and support postfix-'&' to move job in bg) example data and execution times on my system: reload_regions 0.0007s reload_facedata 0.69s reload_treasures 0.0156s reload_archetypes 0.035s all of them run without impeding the running server (unless the server starts to use e.g. an archetype refering another archetype not yet defined), exccept for reload_perl, which is very heavy.
#	User	Rev	Content
1	root	1.1	#! perl
2
3			use IO::Socket;
4			use Storable qw/nfreeze thaw/;
5
6			my %global; # for use by eval'ed commands
7
8			sub tcp_serve($) {
9			my ($fh) = @_;
10
11	root	1.4	select $fh;
12
13	root	1.1	binmode $fh, ":raw:perlio:utf8";
14
15			my $buf;
16	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);
17			my (%l, @l); # for use by shell users
18	root	1.1
19	root	1.4	print <<EOF;
20			Welcome!
21			Remember that everything entered here will be in the main coro context within cf::!
22			You can freely use \$a .. \$z and \@l and \%l
23
24			Useful commands (note the '&'):
25
26			reload_perl &
27			reload_regions &
28			reload_facedata &
29			reload_treasures &
30			reload_archetypes &
31			EOF
32			print "\n> ";
33	root	1.1
34	root	1.3	Event->io (fd => $fh, poll => 'r', data => 0, cb => sub {
35	root	1.1	if (defined (my $cmd = <$fh>)) {
36	root	1.4	$cmd =~ s/\s+$//;
37	root	1.1
38			if ($cmd =~ /^\s*exit\b/i) {
39			print "will not exit() server.\n";
40			} else {
41	root	1.4	my $sub = sub {
42			package cf;
43			select $fh;
44
45			# compile first, the execute, as Coro does not support switching in eval string
46			my $cb = eval "sub { $cmd }";
47
48			my $t1 = Time::HiRes::time;
49			my @res = $@ ? () : eval { $cb->() };
50			my $t2 = Time::HiRes::time;
51
52			print "\n",
53			"command: '$cmd'\n",
54			"execution time: ", $t2 - $t1, "\n";
55			warn "evaluation error: $@" if $@;
56			print "evaluation error: $@\n" if $@;
57			print "result:\n", cf::dumpval @res > 1 ? \@res : $res[0] if @res;
58			print "\n> ";
59			};
60
61			if ($cmd =~ s/\s*&$//) {
62			Coro::async_pool { $sub->() };
63			} else {
64			$sub->();
65			}
66	root	1.1	}
67
68	root	1.2	print "\n> ";
69	root	1.1	} else {
70			$_[0]->w->cancel;
71			}
72			});
73			}
74
75			# now a shell listening on a tcp-port - let the firewall decide access rights
76			if ($cf::CFG{perl_shell}) {
77			if (my $listen = new IO::Socket::INET LocalAddr => $cf::CFG{perl_shell}, Listen => 1, ReuseAddr => 1) {
78			Event->io (fd => $listen, poll => 'r', data => cf::WF_AUTOCANCEL, cb => sub { tcp_serve $listen->accept });
79			}
80			}