milkbone/plugins/Net-OSCAR/Net-OSCAR.pl

# -----------------------------------------------------------------------------
# Author(s)	:	Bill Atkins
# Title		:	Net-OSCAR initialization file
# Date		:	12.21.02
# Desc		:	initializes the Net-OSCAR plugin
# Notes		:	for more information see the plugin documentation
# License	:	it's on our TODO list...
# -----------------------------------------------------------------------------

package NetOSCAR;	

use Net::OSCAR qw(:all);
use Milkbone;
use Carp qw(longmess);

use strict;
use warnings;

my $signed_in = 0;
my $tick_count = 0;
my $i = 0;
my $should_die = 0;
my $is_away = 0;
my ($oscar, $away, $prof, $away_templ, $prof_templ, $user_prof, $user, $password, $waiting);
my (%away_sent, %prof_names, %away_names, %buddies, %chats);

my $tick_interval = 1;

register_hook("protocol_add_buddy",		sub { $oscar->add_buddy($ARGS{-group}, $ARGS{-buddy}); } );
register_hook("protocol_add_buddy_group",		sub { $oscar->add_buddy($ARGS{-group}); } );
register_hook("protocol_away_status",	sub { $is_away; } );
register_hook("protocol_chat_accept",		sub { $oscar->chat_accept($chats{$ARGS{-chat}}) });
register_hook("protocol_chat_decline",		sub { $oscar->chat_decline($chats{$ARGS{-chat}}); undef $chats{$ARGS{-chat}}; });
register_hook("protocol_chat_invite",		sub { $chats{$ARGS{-chat}}->invite(@ARGS{-user, -msg}) });
register_hook("protocol_chat_join",		sub { $oscar->chat_join($ARGS{-chat}) });
register_hook("protocol_chat_part",		sub { $chats{$ARGS{-chat}}->part; });
register_hook("protocol_chat_send",		sub { $chats{$ARGS{-chat}}->chat_send($ARGS{-msg}, !($ARGS{-reflect} or 1)) });
register_hook("protocol_commit_blist",	sub { $oscar->commit_buddylist; } );
register_hook("protocol_commit_info", \&commit_info);
register_hook("protocol_evil", 			sub { $oscar->evil($ARGS{-user}); });
register_hook("protocol_evil_status",		sub { return $oscar->buddy($ARGS{-user})->{evil}; } );
register_hook("protocol_get_away",		sub { $oscar->{away}; } );
register_hook("protocol_get_groups",	sub { [ $oscar->groups ]; } );
register_hook("protocol_get_prof",		sub { $oscar->{profile} } );
register_hook("protocol_get_realname",	\&get_realname );
register_hook("protocol_go_away",		sub { $is_away = 1; $oscar->set_away($away) if $is_away; } );
register_hook("protocol_idle_since",	sub { $oscar->buddy($ARGS{-who})->{idle}; } );
register_hook("protocol_is_away",		sub { return $oscar->buddy($ARGS{-user})->{away}; } );
register_hook("protocol_is_mobile",		sub { return $oscar->buddy($ARGS{-user})->{mobile}; } );
register_hook("protocol_is_on",			sub { $oscar->buddy($ARGS{-who})->{online} } );
register_hook("protocol_mod_away",		\&mod_away );
register_hook("protocol_mod_prof",		\&mod_prof );
register_hook("protocol_on_since",		sub { $oscar->buddy($ARGS{-who})->{onsince}; } );
register_hook("protocol_remove_buddy",	sub { $oscar->remove_buddy($ARGS{-group}, $oscar->buddy($ARGS{-buddy})->{screenname}); } );
register_hook("protocol_request_info",	sub { request_info($ARGS{-user}); });
register_hook("protocol_request_away",	sub { request_away($ARGS{-user}); });
register_hook("protocol_return",		sub { $oscar->set_away(''); %away_sent = (); $is_away = 0; } );
register_hook("protocol_send_im",		\&send_im );
register_hook("protocol_set_away",		\&set_away );
register_hook("protocol_set_typing_status",		sub { $oscar->set_typing($ARGS{-user}, $ARGS{-status}) });
register_hook("protocol_set_comment",		sub { $oscar->set_buddy_comment(@ARGS{-group, -user, -comment}); $oscar->commit_buddylist; });
register_hook("protocol_set_prof",		\&set_prof );
register_hook("protocol_signon",		\&signon);
register_hook("protocol_signed_in",		sub { $signed_in; } );
register_hook("protocol_signoff",		sub { $oscar->signoff; } );

register_hook("request_mod", sub{
		hook("protocol_mod_away", -name => "%v", -value => $Milkbone::VERSION);
		hook("protocol_mod_prof", -name => "%v", -value => $Milkbone::VERSION);
	} );



sub signon
{
	$oscar = new Net::OSCAR;
	$oscar->timeout(0.00001);
	$signed_in = 0;
	set_interval(0);
	$oscar->loglevel(OSCAR_DBG_PACKETS) if option("HeavyLogging");

	$oscar->set_callback_error(
	sub {
		my (undef, undef, $err, $desc, $fatal)= @_;
		hook("error", -short => $desc, -long => longmess($desc), -fatal => $fatal);
                $should_die = 1 if $fatal;
       	} );

	$oscar->set_callback_buddy_in(
	sub {
		if(!$buddies{$_[1]})
		{
			hook("buddy_in", -buddy => $_[1], -group => $_[2]);
			$buddies{$_[1]} = 1;
		}
		else
		{
			hook("buddy_info_changed", -buddy => $_[1], -group => $_[2]);
		}
	} );

	$oscar->set_callback_buddy_out(
	sub {
		hook("buddy_out", -buddy => $_[1], -group => $_[2]); 
		$buddies{$_[1]} = 0;
	} );

	$oscar->set_callback_evil(
	sub {
		hook("protocol_eviled", -user => $_[2]) if defined($_[2]); 
	} );

	$oscar->set_callback_im_in(
	sub {
		hook("msg_in", -user => $_[1], -msg => $_[2], -away => $_[3]) if $_[1]; 
		hook("msg_in_$_[1]", -user => $_[1], -msg => $_[2], -away => $_[3]);
		send_away($_[1]) if $is_away;
	} );

	$oscar->set_callback_typing_status(
	sub {
		# hook("protocol_typing_status_changed", -user => $_[1], -status => $_[2]); 
		hook("protocol_typing_status_changed_$_[1]", -status => $_[2]);
	} );

	$oscar->set_callback_signon_done(
	sub {

		hook("signed_in", -me => $user);

		$signed_in = 1;
	} );

	$oscar->set_callback_rate_alert(
	sub {
                if($_[1] == RATE_LIMIT)
                {
                    hook("error", 
                         -short => "You've exceeded one of AOL's rate limits.  You will be alerted when the rate limit ends.");
                    hook("rate_alert");
                    hook("tk_getmain")->after($_[2] * 2, sub { 
                        hook("error", -short => "Rate limit has expired.");
                    });
                }
	} );

	$oscar->set_callback_buddy_info(
	sub {
		my $prof = $_[2]->{profile};
		$prof = "Sorry, Milkbone users cannot see AOL profiles." if $_[2]->{aol} && !$prof;
		$_[1] =~ s/ //g;
		$_[1] =~ tr/A-Z/a-z/;
		hook("protocol_info_received_$_[1]", -profile => $prof, -away => $_[2]->{awaymsg}); 
		if($_[2]->{awaymsg})
		{
			$waiting = 0;
		}
		elsif(!$_[2]->{away})
		{
			$waiting = 0;
		}
	} );

	$oscar->set_callback_chat_im_in(
	sub {
		hook("protocol_chat_msg_in", -user => $_[1], -msg => $_[3], -chat => $_[2]->name);
		hook("protocol_chat_msg_in_" . $_[2]->name, -user => $_[1], -msg => $_[3]);
	} );

	$oscar->set_callback_chat_invite(
	sub {
		hook("protocol_chat_invited", -user => $_[1], -msg => $_[2], -url => $_[4]);
		$chats{$_[3]->{name}} = $_[3];
	} );

	$oscar->set_callback_chat_joined(
	sub {
		hook("protocol_chat_joined");
	} );

	$oscar->set_callback_chat_closed(
	sub {
		hook("protocol_chat_closed");
	} );

	$oscar->set_callback_chat_buddy_in(
	sub {
		hook("protocol_chat_buddy_in", -user => $_[1], -chat => $_[2]->name);
		print $oscar->buddy($_[1])->{comment};
	} );

	$oscar->set_callback_chat_buddy_out(
	sub {
		hook("protocol_chat_buddy_out", -user => $_[1], -chat => $_[2]->name);
	} );

	hook("tk_getmain")->after(30, \&tick) unless option("MOSHLoop");
        register_hook("tick", \&tick) if option("MOSHLoop");

        $should_die = 0;

	$oscar->signon(screenname => $ARGS{-user}, password => $ARGS{-pass}, port => option("Port"));
	($user, $password) = @ARGS{-user, -pass};
}

sub send_im
{
	$oscar->send_im(@ARGS{-dest, -msg, -away});
	hook("msg_sent_$ARGS{-dest}", -msg => $ARGS{-msg}, -away => $ARGS{-away});
}

sub tick
{
	return unless $oscar;
	$oscar->do_one_loop;
	hook("tk_getmain")->after(30, \&tick) unless $should_die || option("MOSHLoop");
}

sub request_info
{
	my ($other_user) = @_;

	$oscar->get_info($other_user);
	$waiting = 1;
}

sub request_away
{
	my ($other_user) = @_;

	$oscar->get_away($other_user);
	$waiting = 1;
}

sub send_away
{
	my $user = shift;
        my $timeout = option("AwayTimeout");
	$away_sent{$user} ||= 1;
	if (time - $away_sent{$user} > option("AwayTimeout"))
	{
		$oscar->send_im($user, $away, 1);
		$away_sent{$user} = time;
	}
}

sub set_away
{
	$away_templ = $ARGS{-data};
	$away = $away_templ;

	hook("request_mod");
	$away =~ s/\n/<br>/g;
	$oscar->set_away($away) if $is_away;
}

sub set_prof
{
	$prof_templ = $ARGS{-data};
	$prof = $prof_templ;

	hook("request_mod");
	$prof =~ s/\n/<br>/g;
	$oscar->set_info($prof);
}

sub mod_away
{
	$away_names{$ARGS{-name}} = $ARGS{-value};
	$away = $away_templ;

	$away =~ s/$_/$away_names{$_}/g for keys(%away_names);
}

sub mod_prof
{
	$prof_names{$ARGS{-name}} = $ARGS{-value};
	$prof = $prof_templ;

	$prof =~ s/$_/$prof_names{$_}/g for keys(%prof_names);
}

sub get_realname
{
 	return $oscar->buddy($ARGS{-user})->{screenname} 
	if defined($oscar->buddy($ARGS{-user})) and $oscar->buddy($ARGS{-user}) ne "";
	return $ARGS{-user};
}

sub commit_info
{
    $oscar->set_away($away) if $is_away; 
    $oscar->set_info($prof);
}

1;