[Home] [Downloads] [Search] [Help/forum]

Gammon Forum

See www.mushclient.com/spam for dealing with forum spam. Please read the MUSHclient FAQ!

[Folder]  Entire forum
-> [Folder]  MUSHclient
. -> [Folder]  Perlscript
. . -> [Subject]  Perl version of Keldars ATCP plugin for IRE MUDs
Home  |  Users  |  Search  |  FAQ
Username:
Register forum user name
Password:
Forgotten password?

Perl version of Keldars ATCP plugin for IRE MUDs

It is now over 60 days since the last post. This thread is closed.     [Refresh] Refresh page


Posted by KP   (24 posts)  [Biography] bio
Date Sat 30 Jun 2007 03:06 PM (UTC)
Message
Seeing that there seem to be far too few people using perl with MUSHclient, I thought I'd try to give some starting help and basic ideas to play with. Here is my humble attempt to convert Keldar's lua plugin into perl. I've cut it down a bit, so everyone can use it the way they see fit. All you need to do, is to insert your code at the commented place. I'll make another post later on how to serialize and pass around bigger data structures with perl and MC.

Enjoy!


<muclient>
<plugin
   name="ATCP"
   author="Keldar / KP"
   id="24aac266a14ff47b5110f780"
   language="PerlScript"
   purpose="ATCP packet handling"
   save_state="y"
   date_written="2007-06-26 19:59:34"
   requires="4.00"
   version="1.0"
   >
<description trim="y">
<![CDATA[
Based on Keldars lua plugin.

Credit and a huge 'thank you' go to him for writing it. I only converted it to perl and tried to optimize it where possible.

]]>
</description>

</plugin>


<!--  Get our standard constants -->

<include name="constants.pl"/>

<!--  Script  -->


<script>
<![CDATA[

my $client_id =  "Muclient 4.0.0";

my $nexus_opts = [
  "hello $client_id",
  "auth 1",
  "char_name 1",
  "char_vitals 1",
  "room_brief 1",
  "room_exits 1",
];

my $codes = {
  IAC_WILL_ATCP => "\xFF\xFB\xC8",
  IAC_WONT_ATCP => "\xFF\xFC\xC8",
  IAC_DO_ATCP   => "\xFF\xFD\xC8",
  IAC_DONT_ATCP => "\xFF\xFE\xC8",
  IAC_SB_ATCP   => "\xFF\xFA\xC8",
  IAC_SE        => "\xFF\xF0",
  IAC_DO_EOR    => "\xFF\xFD\x19",
  IAC_WILL_EOR  => "\xFF\xFB\x19",
  IAC_GA        => "\xFF\xF9",
};

my $leftovers;

sub SendATCP {
  my $msg = shift;
  $world->SendPkt($codes->{IAC_SB_ATCP} . $msg . $codes->{IAC_SE});
}

sub OnPluginConnect {
  my $msg;
  foreach my $opt (@$nexus_opts) { $msg = $msg . $opt . "\n"; }
  chop $msg;
  $world->SendPkt($codes->{IAC_DO_ATCP} . $codes->{IAC_SB_ATCP} . $msg . $codes->{IAC_SE});
}

sub OnPluginPacketReceived {
  my $opacket = shift;     # $opacket will contain the original packet data as a backup (for debugging for example)
  my $ppacket = $opacket;  # $ppacket will contain the modified packet that we will send back to MC

  $world->Note("ATCP enabled.") if $ppacket =~ s/^(.*)$codes->{IAC_WILL_ATCP}(.*)$/$1$2/s;
  $world->Note("ATCP disabled.") if $ppacket =~ /$codes->{IAC_WONT_ATCP}/s;
  $ppacket =~ s/^(.*)$codes->{IAC_WILL_EOR}(.*)$/$1$2/s;

  my $parsed;  # this will be a hash reference containing all the parsed ATCP data
  ($ppacket,$parsed) = parseATCP($ppacket);
  if (exists $parsed->{'Auth.Request CH'}) {
    $world->Note("Authorization requested.");
    SendATCP('auth ' . atcp_auth($parsed->{'Auth.Request CH'}) . ' ' . $client_id);
  }
  $world->Note("Authorization accepted.") if exists $parsed->{'Auth.Request ON'};

  #
  # We are done with parsing and ready to return the modified packet.
  # $parsed contains all the ATCP data, that we were able to retrieve.
  # Insert your code here and do something with it.
  #
  
  return $ppacket;
}

sub parseATCP {
  my $packet = shift;
  my $parsed;
  $packet = $leftovers . $packet;
  $leftovers = '';
  while ($packet =~ s/$codes->{IAC_SB_ATCP}(.*?)$codes->{IAC_SE}//s) {
    my $match = $1;
    if ($match =~ /^(.*?)\n(.*)$/s) {
      my ($key,$val) = ($1,$2);
      if ($key =~ /^(Char.Name)\s(\w+)$/) {
        $parsed->{$1} = $2;
        $parsed->{'Char.Fullname'} = $val;
      } else {
        $parsed->{$key} = $val;
      }
    } elsif ($match =~ /^(Room.*?|Client.*?)\s(.*)$/s) {
      $parsed->{$1} = $2;
    } elsif ($match =~ /^(.+)$/) {
      $parsed->{$1} = '';
    }
  }
  $leftovers = $1 if $packet =~ s/(\xFF\xFA\xC8.*|\xFF\xFA?)$//s;
  return $packet, $parsed;
}

sub atcp_auth {
  my $seed = shift;
  my ($a,$i) = (17, 0);
  foreach my $n (unpack("U*",$seed)) {
    $n -= 96;
    $a += $i % 2 == 0 ? $n * ($i | 13) : -($n * ($i | 11));
    $i++;
  }
  return $a;
}

]]>
</script>


<!--  Plugin help  -->

<aliases>
  <alias
   script="OnHelp"
   match="ATCP:help"
   enabled="y"
  >
  </alias>
</aliases>

<script>
<![CDATA[
sub OnHelp
  {
  my ($sName, $sLine, $wildcards) = @_;
  $world->Note ($world->GetPluginInfo ($world->GetPluginID, 3));
  }
]]>
</script> 

</muclient>

[Go to top] top

Posted by Tsunami   USA  (204 posts)  [Biography] bio
Date Reply #1 on Sun 01 Jul 2007 05:14 PM (UTC)
Message
If you haven't used my updated version of his ATCP plugin, I suggest you use that to convert into Perl instead. Ked's has an authentication bug and some IAC handling bugs. I believe mine is posted near the end of the thread Ked's plugin is found in, or you can contact me.
[Go to top] top

Posted by KP   (24 posts)  [Biography] bio
Date Reply #2 on Mon 02 Jul 2007 12:25 AM (UTC)
Message
Hmm.. I think I ended up following the link to his website and downloading his plugin from there. After that, (having no knowledge of LUA at all) I tried to understand and convert the basic flow of it, additionally peeking into Whyte's IMTS source and sniffing Nexus communication, to see what they do different. So far, I had no problems with the script you see here.

I had a look at your plugin now too. You seem to have some cleaner regexes and a more compact structure of the code, but I couldn't find where you handle the received ATCP data and/or authenticate. Used v2.1.1 of your script from your site.
[Go to top] top

Posted by Tsunami   USA  (204 posts)  [Biography] bio
Date Reply #3 on Mon 02 Jul 2007 06:16 AM (UTC)
Message
Ah, wrong script actually. That's 6 months old or something I think? I'll repost the code here. The only bug I've noticed is that with certain packet lengths, the packet leftovers don't appear to be caught correctly. Happens quite rarely though, and I haven't been able to track it down. You can see the authentication function down there as well.



atcp = {}

--code adapted from Ked's ATCP script, at:
--<http://www.freewebs.com/keldar/atcp.htm>

atcp.IAC		= '\255'
atcp.WILL		= '\251'
atcp.WONT		= '\252'
atcp.ATCP		= '\200'

atcp.IAC_SE		= '\255\240'
atcp.IAC_SB_ATCP	= '\255\250\200'
atcp.IAC_WILL_ATCP	= '\255\251\200'
atcp.IAC_WONT_ATCP	= '\255\252\200'
atcp.IAC_DO_ATCP	= '\255\253\200'
atcp.IAC_DONT_ATCP	= '\255\254\200'

atcp.IAC_WILL_COMPRESS2	= '\255\251\086'

atcp.on		= false
atcp.lo_reg	= rex.new('(\255(\250(\200[^\255]*)?)?)$')
atcp.gag_reg1	= rex.new('^(\027[[0-9;]+m)*?\r\n.')
atcp.gag_reg2	= rex.new('\255\239(\r\n).')
atcp.leftovers	= false
atcp.values	= {}

atcp.options	= {
	{name='auth',			value='1'},
	{name='composer',		value='1'},
	{name='char_name',		value='1'},
	{name='topvote',		value='1'},
	{name='char_vitals',	value='1'},
	{name='room_brief',		value='1'},
	{name='room_exits',		value='1'}
}
	
--mediapak
--wiz
--filestore
--keepalive

--ATCP FUNCTIONS

function atcp.init()
	world.SendPkt(atcp.IAC_DO_ATCP)

	local msg = 'hello ' .. (config.atcp.id or VERSION_NAME)
	for _,option in ipairs(atcp.options) do
		msg = msg .. '\010' .. option.name .. ' ' .. option.value
	end
	
	if(#config.atcp.login > 0 and #config.atcp.password > 0) then
		msg = msg .. atcp.IAC_SE .. atcp.IAC_SB_ATCP .. 'login ' .. config.atcp.login .. ' ' .. config.atcp.password
	end
	
	world.SendPkt(atcp.IAC_SB_ATCP .. msg .. atcp.IAC_SE)
end
function atcp.close()
	world.SendPkt(atcp.IAC_DONT_ATCP)
end

function atcp.authenticate(seed)
	local a = 17
  
	for i=0,#seed - 1 do		
		if(math.fmod(i,2) == 0) then
			a = a + (string.byte(seed,i + 1) - 96) * (bit.bor(i,13))
		else
			a = a - (string.byte(seed,i + 1) - 96) * (bit.bor(i,11))
		end
	end

	return a
end

function atcp.retrieve_info(msg,capture)
	local ar = {}
	local d1 = string.find(msg,' ',0,true) or -2
	local d2 = string.find(msg,'\010',0,true) or d1 + 1
	
	if(d2 == -1) then
		capture[msg] = {}
		atcp.values[msg] = {}
		return capture
	elseif(d1 < 0) then
		d1 = d2 + 1
	end
	
	local d
	if(d1 < d2) then
		ar = utils.split(msg,' ',2)
		d = d1
	else
		ar = utils.split(msg,'\010',2)
		d = d2
	end
	
	local name = string.sub(msg,0,d - 1)
	capture[name] = utils.split(string.sub(msg,d + 1),'\010')
	atcp.values[name] = capture[name]
	
	return capture
end

function atcp.list()
	system.Note('ATCP VALUES')
	for name,value in pairs(atcp.values) do
		world.Note('  ' .. name)
		for _,val in ipairs(value) do
			world.Note('    ' .. val)
		end
	end
end

--PARSE FUNCTION

function atcp.parse(packet)
	local parsed = {}
	
  	if(atcp.leftovers) then
  		packet = atcp.leftovers .. packet
  		atcp.leftovers = false
	end
	
	--disable mccp
	if(config.atcp.use) then
		packet = string.gsub(packet, atcp.IAC_WILL_COMPRESS2, '')
	end
	
	packet = string.gsub(packet, '' .. atcp.IAC_SB_ATCP .. '(.-)' .. atcp.IAC_SE, 
		function(msg)
			if(config.atcp.use) then
				atcp.on = true
				parsed = atcp.retrieve_info(msg,parsed)
			end
			return ''
		end)
	
	packet = string.gsub(packet, atcp.IAC .. '(.)' .. atcp.ATCP, 
		function(code)		
			if(code == atcp.WILL) then
				if(config.atcp.use) then
					atcp.on = true
					atcp.init()
					
					if(CTRL_DEBUG) then
						system.DebugNote('ATCP PROTOCOL ON.')
					end
				end
				
				return ''
			 elseif(code == atcp.WONT) then
				if(config.atcp.use) then
					atcp.on = false
					atcp.close()
					
					if(CTRL_DEBUG) then
						system.DebugNote('ATCP PROTOCOL OFF.')
					end
				end
				
				return ''
			end
			
			return nil
		end)
	
	local start,_,matches = atcp.lo_reg:match(packet)
	if(matches) then
		atcp.leftovers = matches[1]
		packet = string.sub(packet,1,start)
	end
	
	return packet,parsed
end

--PLUGIN CALLBACKS

function OnPluginPacketReceived(packet)
  	local packet,parsed = atcp.parse(packet)
  	
	if(not config.atcp.use) then
		return packet
	end
  	
  	if(parsed['Auth.Request']) then  		
  		if(parsed['Auth.Request'][1] == 'CH') then
	  		world.SendPkt(atcp.IAC_SB_ATCP .. 'auth ' .. atcp.authenticate(parsed['Auth.Request'][2]) .. ' ' .. config.atcp.id .. atcp.IAC_SE)
	  		
	  		if(CTRL_DEBUG) then
	  			system.DebugNote('ATCP AUTHORIZATION SENT.')
	  		end
	  	elseif(parsed['Auth.Request'][1] == 'OFF') then
    		system.WarningNote('ATCP AUTHORIZATION FAILED.')
   		elseif(parsed['Auth.Request'][1] == 'ON') then
   			if(CTRL_DEBUG) then
    			system.DebugNote('ATCP AUTHORIZATION ACCEPTED.')
    		end
    	end
    end
    
    if(parsed['Char.Name']) then
		if(not parsed['Char.Name'][1] == config.basic.name) then
			system.WarningNote('CORRECTING CHAR NAME TO "' .. string.upper(parsed['Char.Name'][1]) .. '".')
			world.SetVariable('CharName',parsed['Char.Name'][1])
		end
			
		config.basic.name = parsed['Char.Name'][1]
		config.basic.title = parsed['Char.Name'][2]
	end
	
	if(parsed['Char.Vitals']) then
		character.health.max, character.mana.max, character.endurance.max, character.willpower.max, character.experience = string.match(parsed['Char.Vitals'][1],'^H:%d-/(%d-) M:%d-/(%d-) E:%d-/(%d-) W:%d-/(%d-) NL:(%d-)/%d-')
	end
	
	if(parsed['Client.VoteReminder']) then
		prompt.vote_reminder()
	end
	
	if(parsed['Client.Goodbye']) then
		system.Note(parsed['Client.Goodbye'][1])
	end
	
	--'Auth.Request'
	--'Char.Name'
	--'Char.Vitals'
	--'Client.Compose'
	--'Client.GoodBye'
	--'Client.JavaEnv'
	--'Client.VoteReminder'
	--'Room.Exits'
	--'Room.Brief'

	return packet
end
[Go to top] top

Posted by KP   (24 posts)  [Biography] bio
Date Reply #4 on Mon 02 Jul 2007 11:08 PM (UTC)
Message
Ah, thank you. Both the auth function and the leftovers regex are pretty much the same I use. As for the bug with catching the leftovers, I don't think it depends on the length of the packet, as the only case when you get any leftovers at all is when the packet is 999 characters long. Your catching regex seems to be correct. If you ever encounter that bug again, feel free to post the according packets here.
[Go to top] top

Posted by Tsunami   USA  (204 posts)  [Biography] bio
Date Reply #5 on Mon 02 Jul 2007 11:23 PM (UTC)

Amended on Mon 02 Jul 2007 11:26 PM (UTC) by Tsunami

Message
If you authenticate correctly, you'll receive the Auth.Request ON message. If you don't, you'll know there's likely a bug in the auth function.
[Go to top] top

The dates and times for posts above are shown in Universal Co-ordinated Time (UTC).

To show them in your local time you can join the forum, and then set the 'time correction' field in your profile to the number of hours difference between your location and UTC time.


8,465 views.

It is now over 60 days since the last post. This thread is closed.     [Refresh] Refresh page

Go to topic:           Search the forum


[Go to top] top

Quick links: MUSHclient. MUSHclient help. Forum shortcuts. Posting templates. Lua modules. Lua documentation.

Information and images on this site are licensed under the Creative Commons Attribution 3.0 Australia License unless stated otherwise.

[Home]


Written by Nick Gammon - 5K   profile for Nick Gammon on Stack Exchange, a network of free, community-driven Q&A sites   Marriage equality

Comments to: Gammon Software support
[RH click to get RSS URL] Forum RSS feed ( https://gammon.com.au/rss/forum.xml )

[Best viewed with any browser - 2K]    [Hosted at FutureQuest]