view release on metacpan or  search on metacpan

Amethyst/Connection/Anarres.pm  view on Meta::CPAN

package Amethyst::Connection::Anarres;

use strict;
use vars qw(@ISA);
use POE;
use Data::Dumper;
use Parse::Lex;
use Amethyst::Connection;
use Amethyst::Message;

@ISA = qw(Amethyst::Connection);

# Offsets into the IST_COMPUTER format for machine readable messages.
sub MS_CLASS	() { 0; }
sub MS_CONTENT	() { 1; }	# Might be removed
sub MS_FORMAT	() { 2; }
sub MS_SOURCE	() { 3; }
sub MS_ARGBASE	() { 4; }

# Token type and value, from Parse::Lex->analyze
sub MT_TYPE		() { 0; }
sub MT_VALUE	() { 1; }

sub unescape_string {
	my ($token, $string) = @_;

	$string =~ s/^"//;
	$string =~ s/"$//;
	$string =~ s/\\a/\a/g;
	$string =~ s/\\n/\n/g;
	$string =~ s/\\r/\r/g;
	$string =~ s/\\b/\b/g;
	$string =~ s/\\t/\t/g;
	$string =~ s/\\t/\t/g;
	# $string =~ s/\\v/\v/g;
	$string =~ s/\\\\/\\/g;
	$string =~ s/\\//g;

	return $string;
}

sub handler_init {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];

	my @INTEGER = qw(INTEGER [0-9]+);
	my @OBJECT = ('OBJECT', '(?:/[^#:=]+)+(?:#[0-9]+)?(?:=[^:]+)?');
	my @STRING = ('STRING', [ '"', '(?s:[^"\\\\]+|\\\\.)*', '"', ], \&unescape_string);
	my @DTUPLE = qw(DTUPLE [a-z][a-z\.]+[a-z]);
	my @ERROR = ('ERROR', '(?s:.*)', sub { die "Can't analyse $_[1]";});

	my $clexer = new Parse::Lex(
	                @INTEGER,
					@OBJECT,
					@STRING,
					@DTUPLE,
					@ERROR  
						);
	$clexer->skip(':');

	$heap->{ConnectionLexer} = $clexer;

	$heap->{Keepalive} = 60;

	$session->register_state('mung', __PACKAGE__, 'handler_mung');
}

sub handler_login {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];

	$kernel->yield('write', $heap->{Args}->{Login}, $heap->{Args}->{Password});
	# $kernel->yield('write', 'set PS1=', 'set TERM=none');
	$kernel->yield('write', 'config', 'if', 'prompt', 'mp off', 'q');
	$kernel->yield('write', 'channel -1 all');
	$kernel->yield('write', '');
}

sub handler_logout {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
	$kernel->yield('write', 'quit');
}

sub handler_send {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
	my @messages = @_[ARG0..$#_];
	my @out = ();

	foreach my $message (@messages) {
		my $out;
		
		if ($message->channel eq CHAN_PRIVATE) {
			$out = "tell " . $message->user . " ";
		}
		elsif ($message->channel eq '_world') {
			$out = ($message->action == ACT_EMOTE) ? ":" : "'";
		}
		else {
			if ($heap->{Args}->{Channel}) {
				$out = "channel $heap->{Args}->{Channel} ";
			}
			else {
				$out = "channel  " . $message->channel . " ";
			}
			$out .= ": " if $message->action == ACT_EMOTE;
		}

		$out .= $message->content;