Agent-TCLI
7 results

 view release on metacpan or  search on metacpan

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 

use warnings;
use strict;
use Carp;
use Date::Parse;

use POE;
use Net::Jabber;
use Socket;
use Agent::TCLI::Control;
use Agent::TCLI::Request;
require Agent::TCLI::Transport::Base;

use Object::InsideOut qw( Agent::TCLI::Transport::Base );
use Params::Validate qw(validate_with);

sub VERBOSE () { 0 }

our $VERSION = '0.031.'.sprintf "%04d", (qw($Id: XMPP.pm 62 2007-05-03 15:55:17Z hacker $))[2];

=head1 INTERFACE

=head2 ATTRIBUTES

The following attributes are accessible through standard accessor/mutator
methods and may be set as a parameter to new unless otherwise noted.

=over

=item jid

xmpp id of user we're connecting as'
B<set_jid> will only accept SCALAR type values.

=cut
my @jid 	   :Field('All' => 'jid', 'Type' => 'Net::XMPP::JID' );

=item jserver

B<jserver> will only accept SCALAR type values.

=cut
my @jserver 	   :Field('All' => 'jserver' );

=item jpassword

The password for the transport to use to log in to the server.
B<jpassword> will only accept scalar type values.

=cut
my @jpassword  :Field('All' => 'jpassword');

=item xmpp_debug

Sets the debug (verbosity) level for the XMPP libraries

=cut
my @xmpp_debug			:Field  :All('xmpp_debug');

=item xmpp_process_time

Sets the time in seconds to wait before calling XMPP Process to look for
more XMPP data. Defaults to 1 and shouldn't be much larger.

=cut
my @xmpp_process_time	:Field
						:Arg('name'=>'xmpp_process_time', 'default'=> 1 )
						:Acc('xmpp_process_time');

=item peers

An array of peers
B<set_peers> will only accept ARRAYREF type values.

=cut
#my @peers 	   :Field('All' => 'peers', 'Type' => 'ARRAY' );

# Holds the XMPP connection session
my @xmpp	 	   :Field('Get' => 'xmpp');

=item connection_retries

A max number to retry connection before giving up.
B<connection_retries> will only accept NUMERIC type values.

=cut
my @connection_retries
			:Field
			:Arg('name'=>'connection_retries','default'=>10)
			:Acc('connection_retries')
			:Type('NUMERIC' );

=item connection_delay

How long to wait beteen connection attempts when failed. Defaults to 30 seconds.
B<connection_delay> will only accept NUMERIC type values.

=cut
my @connection_delay
			:Field
			:Arg('name'=>'connection_delay','default'=>30)
			:Acc('connection_delay')
			:Type('NUMERIC' );

=item roster

Holds the Net::XMPP::Roster if enabled. To enable the roster,
a paramater of 'roster' => 1, must be passed in with new.
B<roster> will contain a Net::XMPP::Roster object after initialization if enabled.

=cut
my @roster			:Field
					:All('roster');

=item server_time

The time at the server. Useful for determining if messages were sent before we started up.
B<server_time> should only contain hash values.

=cut
my @server_time		:Field
#					:Type('hash')
					:All('server_time');

=item group_mode

The default setting to determine how to interact with groups. Options are:
'all' - process everything said in room
'named' - process only when called by name: (name followed by colon).
'log' -	don't listen to anything, but log events there (which ones?)
'prefixed' - named + anything beginning with a designated prefix character
B<group_mode> should only contain scalar values.

=cut
my @group_mode		:Field
#					:Type('scalar')
					:Arg('name'=>'group_mode', 'Default' => 'named' )
					:Acc('group_mode');

=item group_prefix

The group_prefix used for group moded prefixed.
B<group_prefix> should only contain a single scalar value.

=cut
my @group_prefix	:Field
#					:Type('scalar')
					:Arg('name'=>'group_prefix', 'Default' => ':' )
					:Acc('group_prefix');


# Standard class utils are inherited

#u_ subs can't be private if used in %init_args
#named u_ to sort nicer in Eclipse

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 

	$self->Verbose('Shutdown');

	# This is to keep from reconnectiing when XMPP responds that it is disconnected.
	$self->connection_retries(0);

	if ( defined($self->control_options)
		&& exists( $self->control_options->{'packages'}  ))
	{
		# Shut down any packages.
		foreach my $package ( @{$self->control_options->{'packages'} })
		{
			$kernel->post( $package->name => '_shutdown'  );
		}

	}

	if ( $xmpp[$$self]->Connected )
	{
		$xmpp[$$self]->Disconnect;
		$self->Verbose("_shutdown: Disconnecting ");
	}
	# define xmpp
	# what about Disconnected????

	$self->xmpp->SetMessageCallBacks(
    	'normal'		=> undef,
	    'chat'			=> undef,
    	'groupchat'		=> undef,
    	'headline'		=> undef,
    	'error'			=> undef,
	);

	$self->xmpp->SetPresenceCallBacks(
    	available	=> undef,
		unavailable	=> undef,
	);

    $self->xmpp->SetIQCallBacks(
		'tcli:request'	=> {
			'get'	=>	undef,
			'set'	=>	undef,
			'result'=>	undef,
			},
	);


#    $_[KERNEL]->alias_remove( $_[OBJECT]->get_alias );

}

sub Disconnected {
	my ($kernel,  $self, $count ) =
	  @_[KERNEL, OBJECT,   ARG0 ];

	# if connection retries is zero, then we shutdown with no delay.
	# This is important when we try to shutdown and the
	# xmpp->Disconnect is called. :)
	if ( !defined( $count )  && $connection_retries[$$self] > 0 )
	{
		$kernel->delay_set('Disconnected', $connection_delay[$$self], 1 );
		$self->Verbose("Disconnected: got XMPP disconnect waiting ".$connection_delay[$$self]." seconds" );
		return;
	}
	else
	{
		$count++;
		$self->Verbose("Disconnected: count ($count) \n" );
	}

	if ( $count >= $connection_retries[$$self] )
	{
  		$kernel->yield('_shutdown');
		$self->Verbose("Disconnected: SHUTDOWN in progress");
		return;
	}

	# make connection
	$self->Verbose("Disconnected: XMPP connecting to ".$jserver[$$self] );
	$xmpp[$$self]->Connect(
		hostname	=> $jserver[$$self],
	);
	if ( $xmpp[$$self]->Connected )
	{
		$kernel->yield('Login');
		$self->Verbose("Disconnected: Got connected ");
		return;
	}

	$kernel->delay_set('Disconnected', $connection_delay[$$self], $count );

} #end sub Disconnected

=item JoinPeerRooms

This POE event handler will go through each of the users in the peers array,
and if the peers is a groupchat, join the conference room. It will check to
make sure it is not already conencted (though this could be buggy). It does
not take any arguments.

=cut

sub JoinPeerRooms {
	my ($kernel,  $self, ) =
	  @_[KERNEL, OBJECT, ];
    $self->Verbose("JoinPeerRooms:  ",2);

	foreach my $user ( @{$self->peers} )
	{
		if ( $user->protocol =~ /groupchat/  )
		{
			if ( defined( $self->controls ) &&
				exists( $self->controls->{ $user->id.'-groupchat' } ) )
			{
				# should already be logged on?
			    $self->Verbose("JoinPeerRooms: already connected to ".$user->id ,2);
				return;
			}
			$kernel->yield('JoinChatRoom',
				$user->get_name,		# room name
				$user->get_domain,		# server
				$user->password,		# secret
			)
		}
	}
}

sub JoinChatRoom {
	my ($kernel,  $self, $room, $server, $secret) =
	  @_[KERNEL, OBJECT,  ARG0,    ARG1,   	ARG2];
    $self->Verbose("JoinChatroom: $room at $server ",2);

    $self->xmpp->MUCJoin(
    	'room'		=> $room,
		'server'	=> $server,
		'nick'		=> $self->jid->GetUserID,
		'password'	=> defined($secret) ? $secret : undef,
	);
}

sub Login {
	my ($kernel,  $self, ) =
	  @_[KERNEL, OBJECT, ];

	my $txt = '';

	# make connection
	$self->Verbose("login: XMPP connecting to ".$jserver[$$self] );
	$xmpp[$$self]->Connect(
		hostname	=> $jserver[$$self],
	);

	my @login;
	if ( $xmpp[$$self]->Connected()  )
	{
		#log in
		$self->Verbose("login: XMPP trying login as ".$self->jid()->GetUserID );
		@login = $xmpp[$$self]->AuthSend(
			username	=> $self->jid()->GetUserID,
			password	=> $jpassword[$$self],
			resource	=> $self->jid()->GetResource,
		);
		$self->Verbose("login: Did login for ".$self->jid()->GetUserID." Got ".$login[0] );

		if ( defined($login[0]) && $login[0] eq 'ok')
		{
		    $kernel->yield('Online');
		}
		elsif ( defined($login[1]) )
		{
			$txt .= "Login error-> ".$login[1];
		}
		else
		{
			$txt .= "Bad Login error-> ".$xmpp[$$self]->GetErrorCode();
		}
	}
	else
	{
		$txt .= "Connection error-> ".$xmpp[$$self]->GetErrorCode();
	}

	if ($txt ne '' )
	{
		$self->Verbose("login: ".$txt."\n",1,$xmpp[$$self]->GetErrorCode());
		$kernel->delay_set('Disconnected' => 10 , 1 );
	}

} # end sub login

sub Online {
	my ($kernel,  $self,  ) =
	  @_[KERNEL, OBJECT,  ];
	$self->Verbose("Online: \n" ,1);

	my %server_time = $self->xmpp->TimeQuery('mode'=>'block');
	$self->Verbose("Online: server_time($server_time{display})", 1,\%server_time );

lib/Agent/TCLI/Transport/XMPP.pm  view on Meta::CPAN 

	# This is used to package up a simple request easily

	my $input = $node->GetBody;
	$self->Verbose("GetRequestForNode: input($input)\n",2);

	my $request = Agent::TCLI::Request->new({
					'sender'	=> $self->alias,
					'postback'	=> 'PostResponse',
					'input'		=> $input,

					'response_verbose' => 1,

					'verbose'		=> $self->verbose,
					'do_verbose'	=> $self->do_verbose,
	});

	$request->set_recv($node);

	return( $request );
}

sub recvmsg {
 my ($kernel,  $self, $jSessionID, $response) =
	  @_[KERNEL, OBJECT,        ARG0,      ARG1 ];
	my $msg = $response->[1];
	$self->Verbose("recvmsg: got message from ".
  	$msg->GetFrom('jid')->GetJID('full')." ",1);

	my $control = $self->GetControlForNode( $msg );

	return unless $control;

	my $request = $self->GetRequestForNode($msg);

	# The control is transport agnostic. All it needs to know
	# is the input and what is stored in the control and request.
	$self->Verbose("recvmsg: sending to contol \n",2);

	$kernel->post( $control->id() => 'Execute' => $request );
}

sub recvmsgGroupchat {
	my ($kernel,  $self, $jSessionID, $packet) =
	@_[KERNEL, OBJECT,        ARG0,      ARG1 ];
	my $msg = $packet->[1];
	$self->Verbose("recvmsgGroupchat: msg dump",3,$msg);

	if ( $msg->GetFrom eq $jid[$$self] )
	{
		$self->Verbose("recvmsgGroupchat: ignoring from me \n",2);
		return;
	}

	if ($msg->DefinedX('jabber:x:delay') )
	{
		$self->Verbose("recvmsgGroupchat: delayed message, ignoring \n",2);
		return;
	}

#	# The server will hold older messages. We need to ignore these.
#	# Giving a 10 second window for past.
#	my $msgtime = str2time( $msg->GetTimeStamp );
#	$self->Verbose("recvmsgGroupchat: ts (".$msg->GetTimeStamp.") msgtime (".$msgtime.") time(".time().")  ");
#	if ( $msgtime < time - 10 )
#	{
#		$self->Verbose("recvmsgGroupchat: ignoring past messages \n");
#		return;
#	}

	my $control = $self->GetControlForNode( $msg );
	return unless $control;

	my $input = $msg->GetBody;
	$self->Verbose("recvmsgGroupchat: got input($input)\n",4);

	# currently, this is what we're joining the chatroom as.
	my $me = $jid[$$self]->GetUserID;

	# Figure out if we're addressed in this input depends on mode.
	my $doit = 0;
	if ( $group_mode[$$self] eq 'log' )
	{
		$self->Verbose("recvmsgGroupchat:log ignoring ");
		return;
	}
	elsif ( $group_mode[$$self] eq 'all' )
	{
		$self->Verbose("recvmsgGroupchat:all input($input) ");
	}
	elsif ( $group_mode[$$self] =~ /named|prefixed/ )
	{
		if ( $input =~ /$me:/i  )
		{
			my ($ignore, $myinput) = split(/$me:/, $input, 2);
			#put input without our name into body.
			$msg->SetBody($myinput);
			$self->Verbose("recvmsgGroupchat:named input($input) ");
		}
		elsif ( $input =~ /$group_prefix[$$self]/i &&
			$group_mode[$$self] eq 'prefixed' )
		{
			my ($ignore, $myinput) = split(/$group_prefix[$$self]/, $input, 2);
			#put input without prefix into body.
			$msg->SetBody($myinput);
			$self->Verbose("recvmsgGroupchat:prefixed input($input) ");
		}
		else
		{
			$self->Verbose("recvmsgGroupchat:named-prefixed not for me ignoring");
			return;
		}
	}
	else
	{
		$self->Verbose("recvmsgGroupchat: mode error ignoring");
		return;
	}

#	if ( $input =~ /$me:/i )
#	{
#		$input =~ s/\s*($me):\s*//;



( run in 1.995 second using v1.01-cache-2.11-cpan-5837b0d9d2c )