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 = "ewords('\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 = "ewords('\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;
