Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Non-threading Telnet/Mud client

by Preceptor (Chaplain)
on Aug 30, 2002 at 10:34 UTC ( #194052=CUFP: 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;

Comment on Non-threading Telnet/Mud client
Download Code
Re: Non-threading Telnet/Mud client
by jackdied (Monk) on Sep 04, 2002 at 21:23 UTC
    tinyfugue rocks
    TinyFugue
    It doesn't look like it has been updated since '99, but it was always considered the gold standard of mud clients when I played (early-mid nineties). It has good regular expression support. You have to code in its own mini-language, but back when I was in school people would write MEGS of source that we would swap around.

    I've only ever run it on a *NIX system, but it looks like it has windows ports too.

Re: Non-threading Telnet/Mud client
by brianarn (Chaplain) on Sep 05, 2002 at 16:33 UTC
    I find this as a great irony, because not two weeks ago I was looking for some sort of telnet solution to write my own mud client in Perl, but I wasn't sure of how to do the sockets etc. I found a simple solution of sorts in the Perl Cookbook, but it forks, and so I've had some cross-platform issues, mainly trying some of the stuff in Windows. Sometimes it works, sometimes it doesn't.

    I managed to get a basic client up and running right away, but yours seems to run a bit better than mine, at least when dealing with incomplete lines. I tried reading byte-by-byte at one point, but it did goofy stuff.

    The only pieces of advice or thoughts I have about your code is documentation - I'm a big fan of using things like Pod::Usage and Getopt::Long to add things like a -h option for usage, including more documentation on things like the trigger and untrigger commands. See The Dynamic Duo --or-- Holy Getopt::Long, Pod::UsageMan! for more info. Also, it seems like having things a bit more organized into sections would be useful, such as grouping all config variables into one chunk of code, putting all of the subs together, etc.

    I think it's a great piece of code, and I'd like to use a good deal of it to revamp my custom client (the only reason I'm not using something like tintin++ is because this Mud has all kinds of funky elements such as requiring a very specific string right at connection or I lose connection, and using a color encoding scheme that is nonstandard, so I have to use Perl to change it to ANSI)

    Thanks for sharing this awesome piece of code! =)

    ~Brian
      I looked at the perl cookbook, and thought 'eugh that's icky'. So had a try at improving it. Docs are always somethings i've been lazy at :) But you're right, and it's on the todo list ;p
      --
      It's not pessimism if there is a worse option, it's not paranoia when they are and it's not cynicism when you're right.
Re: Non-threading Telnet/Mud client
by strredwolf (Chaplain) on Sep 10, 2002 at 03:09 UTC
    A similar one, all in Tcl/TK, is Trebucket/Tk. This is one complicated peice of software, though!!!

    --
    $Stalag99{"URL"}="http://stalag99.keenspace.com";

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://194052]
Approved by beretboy
Front-paged by beretboy
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (6)
As of 2015-07-06 02:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (69 votes), past polls