Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

Non-threading Telnet/Mud client

by Preceptor (Deacon)
on Aug 30, 2002 at 10:34 UTC ( [id://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;

Replies are listed 'Best First'.
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
Domain Nodelet?
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?Last hourOther CB clients
Other Users?
Others admiring the Monastery: (5)
As of 2024-03-19 10:01 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found