Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

comment on
( [id://3333]=superdoc: print w/replies, xml ) Need Help??
Do you play a Mud online? For unix, I only managed to find 'xtush' which was a mud client that suited me. Then I figured, that it would be fun to have a go at writing one in perl.
This is the framework, and, well it does work, but there are still a few things on the todo list.
Oh, and it also serves as an example of how you can use IO::Select to handle STDIN/STDOUT at the same time as a socket.
(For those who don't mud, an alias is pretty much the same as a shell alias, a trigger is an automatic command that responds to text sent fron the remote server)
Commands to the 'program' are sent just by typing _before_ you connect, or by prefixing with an 'Escape' when you are connected.
If you see/make any improvements (the signal handling doesn't seem to work the way I want it to), then please let me know :) 
#!/usr/bin/perl -w

use IO::Socket;
use IO::Select;
use Term::ReadKey;
use Text::ParseWords;

my $debug = 1;

my %command_list =
(
  'open' =>
  {
    argnumber     => 2,
    function     => 'OpenConn',
  },
  'close' =>
  {
    argnumber     => 0,
    function     => 'CloseConn',
  },
  'quit' => 
  {
    argnumber     => 0,
    function    => 'doQuit',
  },
  'alias' =>
  {
    argnumber => 0,
    function => 'AddAlias',
  },
  'unalias' =>
  {
    argnumber => 1,
    function => 'RemoveAlias',
  },
  'set' =>
  {
    argnumber => 1,
    function => 'doSet',
  },
  'trigger' =>
  {
    argnumber => 0,
    function => 'AddTrigger',
   },
   'untrigger' =>
   {
     argnumber => 1,
     function => 'RemoveTrigger',
   },
   'reload' =>
   {
     argnumber => 0,
     function => 'LoadDefs',
   },
);

my $host = "local";

my %aliases =   #init aliases to have nothing in them.
(
  'Global' =>
  {
    'test' => 'open localhost 25',
  },
  'localhost' =>
  {
    'test' => 'helo mephit',
  },
);

my %triggers = #init triggers to be empty
(
  'Global' =>
  {
     '^.*says.*' => 'say testing'
  },
);

#$SIG{'INT'} = 'IGNORE';
$SIG{'QUIT'} = 'doQuit';
$SIG{'TERM'} = 'doQuit';
$SIG{'HUP'} = 'CloseConn';

sub ProcessCommand  # takes a 'command' input and 
                    # figures out what to do with it.
{
  my $line = pop ( @_ );
  COMMANDLOOP: 
  foreach my $command ( keys ( %command_list ), keys ( %{$aliases{'Glo
+bal'}} ),
                        keys ( %{$aliases{$host}}) )
  {
    my $input_line = $line;
    if ( $debug ) { print "checking \"$command\" = \"$line\"\n"; }
    if ( $input_line =~ /^$command[ ,\n,\r]/ )
    {
      my @args = split (" ", $input_line );
      if ( $command_list{$command} )
      {
        if ( $debug ) { print "Calling function: ", 
                              $command_list{$command}{'function'}, 
                              " with args: @args[1..$#args] \n"; }

        if ( $#args < $command_list{$command}{'argnumber'} )
        {
          print "Not enough arguments to $command_list{$command}{'func
+tion'} ";
          print "- expecting $command_list{$command}{'argnumber'} \n";
        } # Tested arg numbers
        else  #we have enough arguments to send to the function.
        {
          &{$command_list{$command}{'function'}}(@args); 
        }
      } # if command_list ( command )
      else #it isn't a commmand, so it must be an alias.
      {
         if ( $debug ) { print "Running alias: \"$command\" \n"; }
         RunAlias($command, @args);
      }
      
      last COMMANDLOOP;
    } #if ( $input_line =~ /^$command / );
  } #foreach
} #ProcessCommand

my $std_prompt = "emud> ";  #displayed when not connected.
my $no_prompt = "";
my $prompt = $std_prompt;
my $connected = 0;
my $block_size = 1024;
my $mud_sock;  #will be instantiated with a socket, but not yet...
my $sock_read =  new IO::Select() ;
$sock_read -> add ( \*STDIN );  #yes, we do want to read from STDIN :)
STDOUT -> autoflush(1); #because remote machines don't always send ful
+l lines.

sub OpenConn()
{
  my $port = pop(@_);
  my $target = pop (@_);
  if ( $debug ) { print "attempting to connect to: $target on port $po
+rt\n"; }
  $mud_sock = new IO::Socket::INET ( proto => "tcp", PeerAddr => $targ
+et, 
                          PeerPort => $port ) || die $@;
  $mud_sock -> autoflush(1);
  $sock_read -> add ( $mud_sock ); # add this socket to our readable h
+andle set.
  if ( $debug ) { print "[Connected to host $target:$port]\n"; }
  $connected = 1;
  $prompt = $no_prompt;
  $host = $target;
}

sub CloseConn()
{
  if ( $connected )  
  { 
     print "Closing connection.\n";
     $sock_read -> remove ( $mud_sock );
     close ( $mud_sock );
     print "Remote Connection Closed.\n" ;
  }
  else
  {
    print "No connection open.\n";
  }
  $host = "local";
  $connected = 0;
  $prompt = $std_prompt;
}

#alias control.
#AddAlias adds something to the alias array.
#RunAlias... well runs it.
#Removealias deletes it.

sub AddAlias()
{
  my @params = ( @_ );
  shift(@params);
  my $category = 'Global';
  my $alias_name = "";
  $alias_name = shift ( @params );
  if ( $alias_name && $alias_name =~ /\(.*\)/ )
  {
    if ( $debug ) { print "Brackets on alias name. Assuming category.\
+n" }
    $category = $alias_name;
    $category =~ s/^\(//go;
    $category =~ s/\)$//go;
    $alias_name = shift ( @params );
  }
  my $alias_text = join ( " ", @params );
  if ( $alias_name )
  {
    if ( $alias_text )
    {
      if ( $aliases{$alias_name} )
      {
        print "changing alias $category:\"$alias_name\" to \"$alias_te
+xt\"\n";
      }
      else
      {
        print "adding alias $category:\"$alias_name\" as \"$alias_text
+\"\n";
      }
      $aliases{$category}{$alias_name} = $alias_text;
    }
    else
    {
      if ( $aliases{$alias_name} )
      {
        print "Alias \"$alias_name\" currently aliased to \"$aliases{$
+alias_name}\"\n"
      }
      else
      {
        print "No alias for \"$alias_name\"\n";
      }
    }
  }  #if alias_name
  else
  {
     print " ---> ", keys ( %aliases ),"\n";
     if ( $category eq 'Global' )
     {
       foreach my $category ( keys ( %aliases ) )
       {
         print "$category aliases:\n";
         foreach my $alias ( keys ( %{$aliases{$category}} ) )
         {
           print "    \"$alias\" = $aliases{$category}{$alias}\n";
         }
       }#foreach
     }
     else
     {
         print "$category aliases:\n";
         foreach my $alias ( keys ( %{$aliases{$category}} ) )
         {
           print "    \"$alias\" = $aliases{$category}{$alias}\n";
         }
     }
  } #else
}

sub RemoveAlias()
{
  shift(@_);
  my $category = 'Global';
  my $alias_to_remove = shift(@_);
  #if alias_to_remove is set, and it is of the form (var)
  if ( $alias_to_remove && $alias_to_remove =~ /\(.*\)/ )
  {
    if ( $debug ) { print "Brackets on alias name. Assuming category.\
+n" }
    $category = $alias_to_remove;
    $category =~ s/^\(//go;
    $category =~ s/\)$//go;
    $alias_to_remove = shift ( @_ );
  }
  if ( $aliases{$category}{$alias_to_remove} )
  {
    print "Deleting $category \"$alias_to_remove\"\n";
    delete ( $aliases{$category}{$alias_to_remove} );
  }
  else
  {
    print "No alias defined for \"$alias_to_remove.\"\n";
  }
}

sub RunAlias()
{
  my $aliastorun = shift ( @_ );
  my $text;
  if ( $debug ) { print "Running alias $aliastorun\n"; }
  if ( $host && $aliases{$host} && $aliases{$host}{$aliastorun} )
  {
    if ( $debug ) { print "Got a host ($host) alias.\n" } 
    $text = $aliases{$host}{$aliastorun};
  }
  else
  {
    if ( $debug ) { print "Got a general alias.\n" }
    $text = $aliases{"Global"}{$aliastorun}
  }
  if ( $debug ) { print "alias text: $text\n"; }
  if ( $connected )
  {
    print $mud_sock "$text\n";
  }
  else
  {
    my @newcmd = split (" ", $text );

    if ( $aliases{$newcmd[0]} )
    {
      print "WARNING: Cannot call an alias with an alias.\n";
    }
    else
    {
      ProcessCommand("$text\n");
    }
  }
}

sub AddTrigger()
{
  if ( $debug ) { print "Adding Trigger @_\n"; }
  my @params = ( @_ );
  $testline = join(" ", @params );
  @params = &quotewords('\s+',0,$testline);
  if ( $debug ) 
  {
    foreach my $word (@params)
    {
      print " -- $word\n";
    }
  }
  shift(@params);
  my $category = 'Global';
  my $trigger_name = "";
  $trigger_name = shift ( @params )  ;
  if ( $trigger_name && $trigger_name =~ /\(.*\)/ )
  {
    if ( $debug ) { print "Brackets on trigger name. Assuming category
+.\n" }
    $category = $trigger_name;
    $category =~ s/^\(//go;
    $category =~ s/\)$//go;
    $trigger_name = shift ( @params );
  }
  my $trigger_action = join ( " ", @params );
  if ( $trigger_name )
  {
      if ( $trigger_action )
    {
      if ( $triggers{$trigger_name} )
      {
        print "changing alias ($category) \"$trigger_name\" to \"$trig
+ger_action\"\n";
      }
      else
      {
        print "adding trigger ($category) \"$trigger_name\" as \"$trig
+ger_action\"\n";
      }
      $triggers{$category}{$trigger_name} = $trigger_action;
    }
    else
    {
      if ( $triggers{$trigger_name} )
      {
        print "Trigger \"$trigger_name\" currently \"$triggers{$trigge
+r_name}\"\n"
      }
      else
      {
        print "No such trigger: \"$trigger_name\"\n";
      }
    }
  }  #if trigger
  else
  {
     if ( $debug ) { print " ---> ", keys ( %triggers ),"\n"; }
     if ( $category eq 'Global' )
     {
       foreach my $category ( keys ( %triggers ) )
       {
         print "$category triggers:\n";
         foreach my $trigger ( keys ( %{$triggers{$category}} ) )
         {
           print "    \"$trigger\" = $triggers{$category}{$trigger}\n"
+;
         }
       }#foreach
     }
     else
     {
         print "$category triggers:\n";
         foreach my $trigger ( keys ( %{$triggers{$category}} ) )
         {
           print "    \"$trigger\" = $triggers{$category}{$trigger}\n"
+;
         }
     }
  } #else
}

sub RemoveTrigger()
{
  my @params = ( @_ );
  my $testline = join(" ", @params );
  @params = &quotewords('\s+',0, $testline);
  if ( $debug ) 
  {
    foreach my $word (@params)
    {
      print " -- $word\n";
    }
  }
  shift (@params);
  my $category = 'Global';
  my $trigger_to_remove = shift (@params);
  if ( $trigger_to_remove && $trigger_to_remove =~ /\(.*\)/ )
  {
    if ( $debug ) { print "Brackets on trigger name. Assuming category
+.\n" }
    $category = $trigger_to_remove;
    $category =~ s/^\(//go;
    $category =~ s/\)$//go;
    $trigger_to_remove = shift ( @params );
  }
  if ( $triggers{$category}{$trigger_to_remove} )
  {
    print "Deleting $category \"$trigger_to_remove\"\n";
    delete ( $triggers{$category}{$trigger_to_remove} );
  }
  else
  {
    print "No trigger defined for \"$trigger_to_remove.\"\n";
  }
}

sub LoadDefs()
{
    #open ( EMUD, "$ENV('HOME')/.emudrc" ) 
    open ( EMUD, ".emudrc" ) 
     || die "\$HOME/.emudrc does not exist.\n";
    while ( $line = <EMUD> )
    {
      ProcessCommand($line);
    }
}


sub doQuit()
{
  if ( $mud_sock )
  {
    CloseConn();
  }
  exit 0;
}

print $prompt;
while ( @ready = $sock_read -> can_read() )
{
  foreach my $handle ( @ready ) 
  {
    if ( $handle == \*STDIN )
    {
      my $line = <$handle>;
      if ( $line && ( ! $connected || unpack ( "C", $line ) == 27 ) ) 
+  
            # then we do commands.
      {
        if ( $connected ) { $line =~ s/^.//goi; } 
                  #if we're connected, then we got an ESC
        if ( $debug ) { print "Got client command: $line\n"; };
        ProcessCommand ( $line );
      } #if prefixed with esc
      else
      {   #it's just 'standard' IO to be sent to the remote target.
        if ( $line )
        {
          if ( $debug ) { print STDOUT "COMMAND: $line" };
          print STDOUT $line;
          print $mud_sock $line;
        }
      }
    }
    else
    {
      my $buff;
      my $result = $handle -> recv ( $buff, $block_size, 0 );
      print $buff;
      foreach my $trigger ( keys ( %{$triggers{'Global'}} ),
                            keys ( %{$triggers{$host}} ) )
      {
        if ( $debug ) { print "Processing trigger: \"$trigger\"\n"; }
        if ( $buff =~ /$trigger/ )
        {
          if ( $debug ) { print "$trigger matches $buff\n";}
          if ( $host && $triggers{$host} && $triggers{$host}{$trigger}
+ )
          {
            if ( $debug ) { print "Got a host ($host) trigger.\n"; }
            $text = $triggers{$host}{$trigger};
          }
          else
          {
            if ( $debug ) { print "Got a global trigger.\n"; }
            $text = $triggers{'Global'}{$trigger};
          }
          print STDOUT "$text\n";
          print $mud_sock "$text\n";
          last;
        }
      } #foreach
      if ( !$buff ) 
      {
        CloseConn();
      }     
    } #else
  } #foreach handle
  print $prompt;
} #while

exit;

[download]

In reply to Non-threading Telnet/Mud client by Preceptor

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others pondering the Monastery: (6)
As of 2024-04-18 06:31 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found