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

   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 "Welcome!\n",
             "Remember that everything entered here will be executed as a sync_job in cf::!\n",
             "You can freely use \$a .. \$z and \@l and \%l\n";
   print $fh "\n> ";

   Event->io (fd => $fh, poll => 'r', data => cf::WF_AUTOCANCEL, cb => sub {
      if (defined (my $cmd = <$fh>)) {
         my $old_fh = select $fh;

         if ($cmd =~ /^\s*exit\b/i) {
            print "will not exit() server.\n";
         } else {
            cf::sync_job {
               package cf;
               my @res = eval $cmd;
               warn "tcpshell evaluation error: $@" if $@;
               print $@ if $@;

               print cf::dumpval @res > 1 ? \@res : $res[0] if @res;
            };
         }

         print "\n> ";
         select $old_fh;
      } 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.2
Committed:	Tue Jan 9 15:36:18 2007 UTC (17 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.1:	+14 -7 lines
Log Message:	- better dm shell - minor cleanups - added cf::dumpval, cf::player::list_logins and $player->maps
#	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			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.2	print $fh "Welcome!\n",
18			"Remember that everything entered here will be executed as a sync_job in cf::!\n",
19			"You can freely use \$a .. \$z and \@l and \%l\n";
20			print $fh "\n> ";
21	root	1.1
22			Event->io (fd => $fh, poll => 'r', data => cf::WF_AUTOCANCEL, cb => sub {
23			if (defined (my $cmd = <$fh>)) {
24			my $old_fh = select $fh;
25
26			if ($cmd =~ /^\s*exit\b/i) {
27			print "will not exit() server.\n";
28			} else {
29	root	1.2	cf::sync_job {
30	root	1.1	package cf;
31	root	1.2	my @res = eval $cmd;
32			warn "tcpshell evaluation error: $@" if $@;
33			print $@ if $@;
34
35			print cf::dumpval @res > 1 ? \@res : $res[0] if @res;
36			};
37	root	1.1	}
38
39	root	1.2	print "\n> ";
40	root	1.1	select $old_fh;
41			} else {
42			$_[0]->w->cancel;
43			}
44			});
45			}
46
47			# now a shell listening on a tcp-port - let the firewall decide access rights
48			if ($cf::CFG{perl_shell}) {
49			if (my $listen = new IO::Socket::INET LocalAddr => $cf::CFG{perl_shell}, Listen => 1, ReuseAddr => 1) {
50			Event->io (fd => $listen, poll => 'r', data => cf::WF_AUTOCANCEL, cb => sub { tcp_serve $listen->accept });
51			}
52			}