serverevent.pm

perl qq

package Net::OICQ::ServerEvent;

# $Id: ServerEvent.pm,v 1.8 2003/10/17 20:01:52 tans Exp $

# Copyright (c) 2003 Shufeng Tan.  All rights reserved.
# 
# This package is free software and is provided "as is" without express
# or implied warranty.  It may be used, redistributed and/or modified
# under the terms of the Perl Artistic License (see
# http://www.perl.com/perl/misc/Artistic.html)

use 5.006;
use strict;
use warnings;
eval "no encoding; use bytes;" if $] >= 5.008;

use Crypt::OICQ qw(encrypt decrypt);
use Net::OICQ::Event;
our @ISA = qw(Net::OICQ::Event);

my @MsgPrecursors = ("\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x01",
		     "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01",
		     "..\x00\x00\x00\x01\x01\x00.\x00\x01");
my @AutoMsgPrecursors = ("\x00\x00\x00\x01\x00\x00\x00\x00\x02");

# Separators
my $FS = $Net::OICQ::FS;   # Field separator
my $RS = $Net::OICQ::RS;   # Record separator

my $InfoHeader = \@Net::OICQ::InfoHeader;

################################################added by alexe
my %im_type=(
	QQ_RECV_IM_TO_BUDDY => "\x00\x09",
	QQ_RECV_IM_TO_UNKNOWN => "\x00\x0a",
        QQ_RECV_IM_GROUP_IM => "\x00\x20",
	QQ_RECV_IM_ADD_TO_GROUP => "\x00\x21",
        QQ_RECV_IM_DEL_FROM_GROUP => "\x00\x22",
        QQ_RECV_IM_APPLY_ADD_TO_GROUP => "\x00\x23",
        QQ_RECV_IM_APPROVE_APPLY_ADD_TO_GROUP => "\x00\x24",
        QQ_RECV_IM_REJCT_APPLY_ADD_TO_GROUP => "\x00\x25",
        QQ_RECV_IM_CREATE_GROUP => "\x00\x26",
        QQ_RECV_IM_SYS_NOTIFICATION => "\x00\x30",
);
my %normal_im_type=(
        QQ_NORMAL_IM_TEXT => "\x00\x0b",
        QQ_NORMAL_IM_FILE_REQUEST => "\x00\x35",
        QQ_NORMAL_IM_FILE_APPROVE_UDP => "\x00\x37",
        QQ_NORMAL_IM_FILE_APPROVE_TCP => "\x00\x03",
        QQ_NORMAL_IM_FILE_REJECT_UDP => "\x00\x39",
        QQ_NORMAL_IM_FILE_REJECT_TCP => "\x00\x05",
        QQ_NORMAL_IM_FILE_NOTIFY => "\x00\x3b",
        QQ_NORMAL_IM_FILE_CANCEL => "\x00\x49",
        QQ_NORMAL_IM_FILE_PASV => "\x00\x3f",					
);
my %sub_group_cmd=(
	QQ_GROUP_CMD_CREATE_GROUP => "\x01",
        QQ_GROUP_CMD_MEMBER_OPT => "\x02",
        QQ_GROUP_CMD_MODIFY_GROUP_INFO => "\x03",
        QQ_GROUP_CMD_GET_GROUP_INFO => "\x04",
        QQ_GROUP_CMD_ACTIVATE_GROUP => "\x05",
        QQ_GROUP_CMD_SEARCH_GROUP => "\x06",
        QQ_GROUP_CMD_JOIN_GROUP => "\x07",
        QQ_GROUP_CMD_JOIN_GROUP_AUTH => "\x08",
        QQ_GROUP_CMD_EXIT_GROUP => "\x09",
        QQ_GROUP_CMD_SEND_MSG => "\x0a",
        QQ_GROUP_CMD_GET_ONLINE_MEMBER => "\x0b",
        QQ_GROUP_CMD_GET_MEMBER_INFO => "\x0c",						
);
###################################################################
sub new {
    my ($class, $packet, $oicq) = @_;
    my $self = {
        OICQ  => $oicq,
        Header => substr($packet, 0, 7),
    };
    bless $self, $class;
    my $cmdcode = $self->cmdcode;
    my $cmd     = $self->cmd;
    if ($cmd =~ /reg_new_id_/) {
        $oicq->log_t("Cmd $cmd ($cmdcode):\n", $oicq->hexdump($packet));
        return undef;
    }
    my $crypt = substr($packet, 7, -1);
    my $plain;
    if ($cmd eq 'login') {
        eval { $plain = decrypt(undef, $crypt, $oicq->{PWKey}) };
        $@ && $oicq->{Debug} && $oicq->log_t($@);
        unless (defined $plain) {
            eval { $plain = decrypt(undef, $crypt, $oicq->{RandKey}) };
        }
        $@ && $oicq->log_t($@);
    } else {
        eval { $plain = decrypt(undef, $crypt, $oicq->{Key}) };
    }
    $oicq->log_t("receive message($cmd):");
    $oicq->log($oicq->hexdump($plain));
    return undef unless defined $plain;
    $self->{Data} = $plain;
    return $self;
}

# Default method for server data

sub default {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    my $ui = $oicq->{UI};
    if (defined $ui) {
        $ui->info("Server ack to ", $self->cmd, ": 0x",
                  unpack('H*', $self->{Data}), "\n");
    }
    return unless $oicq->{Debug};
    $oicq->log_t("Decryted data from server:\n", $oicq->hexdump($self->{Data}));
}

# Server replies with session key

sub login {
    my ($self) = @_;
    my $oicq  = $self->{OICQ};
    my $plain = $self->{Data};
    if (length($plain) < 0x11) {   # Server did not return a session key
        if (substr($plain, 0, 1) ne "\x01") {
            $oicq->log_t("wrong passwd for $oicq->{Id}, hexdump:\n",
                         $oicq->hexdump($plain));
            return undef;
        }
        if (substr($plain, 1, 4) ne $oicq->{_Id}) {
            $oicq->log_t("server reply to login request from ",
                         unpack('L', substr($plain, 1, 4)), ":\n",
                         $oicq->hexdump($plain));
            return undef;
        }
        # Find new server address
        $oicq->log_t("redirected to server $oicq->{SvrIP}:$oicq->{SvrPort}");
        $oicq->{SvrPort} = unpack('n', substr($plain, 9, 2));
        $oicq->{SvrIP} = join('.', map {ord} split('',  substr($plain, 5, 4)));
        $oicq->{Socket} = undef;
        return 0;
    }
    my $key = substr($plain, 1, 0x10);
    $oicq->{Key} = $key;
    return 1;
}

sub logout {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    $oicq->log("Impossible: logout packet from server?\n",
               $oicq->hexdump($self->{Data}));
    return;
}

# Server replies with user info
sub get_user_info {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    my $plain = $self->{Data};
    my @field = split(/$FS/, $plain);

    return unless defined $field[0];
    return if $field[0] =~ /^-/;

    $oicq->{MyInfo} = [@field] if $field[0] == $oicq->{Id};
    $oicq->{Info}->{$field[0]} = {} unless defined $oicq->{Info}->{$field[0]};
    my $hashref = $oicq->{Info}->{$field[0]};
    $hashref->{Nickname} = $field[1];
    $hashref->{Age}      = $field[7];
    $hashref->{Sex}      = $field[8];
    #$hashref->{Face}     = $oicq->get_face($field[21]);

    my $datfile = "$oicq->{Dir}/$oicq->{Id}/$field[0].dat";
    my $dat = new FileHandle(">$datfile");
    if (defined $dat) {
        print $dat "\$_ = {\n";
        for(my $j = 0; $j<=$#field; $j++) {
            printf $dat "%-15s => '%s',\n", $InfoHeader->[$j], $field[$j];
        }
        print $dat "};\n";
        $dat->close;
        my $ui = $oicq->{UI};
        if (defined $ui && defined $ui->{show_user_info}) {
            $ui->show_user_info(\@field);
            delete $ui->{show_user_info};
        }
    } else {
        $oicq->log_t("Failed to open user info file >$datfile");
    }
    my %usr_info_reply=(
	    name=>"usr_info",
	    uid=>$field[0],
	    usr_name=>"$field[1]",
	    usr_age=>"$field[7]",
	    usr_sex=>"$field[7]",
    );
    return \%usr_info_reply;
}

# Server ack
sub send_msg {
    my ($self) = @_;
    my $oicq = $self->{OICQ};
    my $plain = $self->{Data};
    my $text = $plain eq "\0" ?
                   "Message transmitted by server" :
                   "Server ack to send_msg: 0x" . unpack('H*', $plain);
    my $ui = $oicq->{UI};
    if (defined $ui) {
        $ui->info("$text\n");
    }
    if ($oicq->{Debug} or not defined $oicq->{UI}) {
        $oicq->log_t($text);
    }
    return 1;
}

sub recv_msg {
    my ($self) = @_;
    my $oicq  = $self->{OICQ};
    my $plain = $self->{Data};
    return if length($plain) < 0x32;
    my $srcid = unpack('N', substr($plain, 0, 4));
    my $dstid = unpack('N', substr($plain, 4, 4));
    defined $oicq->{Info}->{$srcid} or $oicq->{Info}->{$srcid} = {};
    $oicq->{Info}->{$srcid}->{Client} = substr($plain, 0x14, 2);
###################################################################added by alexe
    my $seq=unpack('N', substr($plain, 8, 4));
    my $send_ip=unpack("N",substr($plain,0xc,4));
    my $send_port=unpack("n",substr($plain,0x10,2));
    my $im_type=substr($plain,0x12,2);
    foreach (keys %im_type){
    	if($im_type{$_} eq $im_type)
	{$im_type=$_;}
    }
    my ($send_time,$mesg_length,$mesg,$send_type,$send_uid);
    if ($im_type eq "QQ_RECV_IM_GROUP_IM"){
	$send_type="group";
	my $ext_group_id=unpack("N",substr($plain,0x14,4));
	my $group_type=unpack("H*",substr($plain,0x18,1));
	$send_uid=unpack("N",substr($plain,0x19,4));
	my $mesg_seq=unpack("n",substr($plain,0x1f,2));
	$send_time=unpack("N",substr($plain,0x21,4));
    	$mesg_length=unpack("n",substr($plain,0x29,2));
	$mesg = substr($plain,0x2b,$mesg_length-13);
    }
    elsif($im_type eq "QQ_RECV_IM_TO_BUDDY" or $im_type eq "QQ_RECV_IM_TO_UNKNOWN"){	
	 $send_type='buddy';
	my $send_ver=unpack("n",substr($plain,0x14,2));
	$send_uid=unpack("N",substr($plain,0x16,4));
	my $rec_uid=unpack("N",substr($plain,0x1a,4));
	my $normal_im_type=substr($plain,0x2e,2);
	foreach (keys %normal_im_type){
        	if($normal_im_type{$_} eq $normal_im_type)
	        {$normal_im_type=$_;}
    	}
	if ($normal_im_type eq "QQ_NORMAL_IM_TEXT"){
		my $mesg_seq=unpack("n",substr($plain,0x30,2));
		$send_time=unpack("N",substr($plain,0x32,4));
		my $send_icon=unpack("H*",substr($plain,0x37,1));
		my $font_attr=unpack("H*",substr($plain,0x3b,1));
		my $mesg_type=substr($plain,0x40,1);
		$mesg=substr($plain,0x41);
		unless ($mesg_type eq "0x02")
		{
			if( $font_attr eq "01"){
			$mesg=substr($plain,0x41,length($mesg)-13);}
		}
	}
    }
################################################by alexe
    if (defined $oicq->{Socket}) {
	#$oicq->push_command("ack_msg",[unpack('n',substr($self->{Header},5,2)),$plain]);
	my $aa=unpack('n',substr($self->{Header},5,2));
	$oicq->ack_msg($aa,$plain);
	my $q=$oicq->{Command_Queue};
	foreach (@$q){
        	if($aa eq $$_{Seq}){
			$$_{Executed}=0;
		}
	}
	my $chatbot = $oicq->{Info}->{$srcid}->{ChatBot};
        (defined $chatbot && -f $chatbot) or $chatbot = $oicq->{ChatBot};
        if (defined $chatbot && -f $chatbot) {
            eval { require $chatbot; on_message($oicq, $srcid, $mesg) };
            if ($@) {
               $oicq->log_t("on_message error: $@");
            }
        } else {
            $self->check_autoreply($oicq, $srcid, $mesg);
        }
    }
    my %recv_mesg_reply=(
	    name=>"recv_mesg",
	    mesg=>"$mesg",
	    srcid=>$srcid,
	    send_time=>$send_time,
	    type=>$send_type,
	    member_uid=>$send_uid,
    );
    return \%recv_mesg_reply;
}

# Extract message from decrypted data using MsgPrecursor
sub get_msg {
    my ($self, $plain) = @_;
    my $oicq = $self->{OICQ};
    foreach my $precursor (@MsgPrecursors) {
	if ($plain =~ /^$precursor(.*)$/s) {
	    return $1;
	}
    }
    foreach my $precursor (@AutoMsgPrecursors) {
        if ($plain =~ /^$precursor(.*)$/s) {
            return "Auto-Reply:\n" . $1;
	}
    }
    $oicq->log("Unable to get message from data:\n", $oicq->hexdump($plain));
    $plain =~ s/^(.{11})/'#'.unpack("H*", $1).'#'/se;
    return $plain;
}

sub check_autoreply {
    my ($self, $oicq, $dstid, $mesg) = @_;
    my $ui = $oicq->{UI};
    if (defined $ui) {
        $ui->beep;
        my $idletime = $ui->idle_time;
        if ($oicq->{AutoAwayTime} && $idletime > $oicq->{AutoAwayTime}) {