oicq.pm

perl qq

package Net::OICQ;

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

# Copyright (c) 2002 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;
use Carp;
use FileHandle;
use Digest::MD5;
use IO::Socket;
use IO::Select;
use Time::HiRes qw(gettimeofday);
eval "no encoding; use bytes;" if $] >= 5.008;

use Crypt::OICQ qw(encrypt decrypt);

our $timeout =5;
our $timeout_msg = "tImEoUt\n";
	
our $VERSION = '0.8';

#################### Begin OICQ protocol data ######################

# Byte 0x00 is always 0x02, i suspect it is protocol version

our $PROTO_VER = "\x02";

# Bytes 0x01-0x02 indicates packet source

# 0x01 0x00 for packets from server
# 0x06 0x2e for packets from GB client version 2000c build 630
# 0x07 0x2e for packets from En client version 2000c build 305
# 0x08 0x01 for packets from En client version 2000c build 630
# 0x09 0x09 for packets from GB client version 2000c build 1230b

our $SRC_SERVER = "\x01\x00";
our $SRC_CLIENT = "\x0b\x37"; # QQ 2003iii 0304

# Byte 0x03 is always 0x00, maybe reserved for future commands?
# Byte 0x04 is command

our %CmdCode = (
    logout             => "\0\x01",
    keep_alive         => "\0\x02",
    reg_new_id_2       => "\0\x03",
    update_info        => "\0\x04",
    search_users       => "\0\x05",
    get_user_info      => "\0\x06",
    add_contact_1      => "\0\x09",
    del_contact        => "\0\x0a",
    add_contact_2      => "\0\x0b",
    set_mode           => "\0\x0d",
    reg_new_id_1       => "\0\x11",
    ack_service_msg    => "\0\x12",
    send_msg           => "\0\x16",
    recv_msg           => "\0\x17",
    forbid_contact     => "\0\x1c",
    file_request_key   => "\0\x1d",###new added by alexe
    cell_phone_1       => "\0\x21",###new added by alexe
    login              => "\0\x22",
    get_friends_list   => "\0\x26",
    get_online_friends => "\0\x27",
    cell_phone_2       => "\0\x29",###new added by alexe
    group_cmd          => "\0\x30",###new added by alexe
    recv_service_msg   => "\0\x80",
    recv_friend_status => "\0\x81",
);
# Bytes 0x05-0x06 form a packet sequence number, a 16-bit integer

# Message precursor

my $MsgPrecursor = "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x01";

# Login modes
our %ConnectMode = (
    Normal    => "\x0a",
    Away      => "\x1e",
    Invisible => "\x28"
);

# System message code for 0x80 cmd
our %ServiceMsgCode = (
    '01' => 'User',
    '02' => 'ContactRequest',
    '06' => 'Broadcast'
);

# Separators
our $FS = "\x1e";   # Field separator
our $RS = "\x1f";   # Record separator

our @InfoHeader = qw(
    UserID Nickname Country Province PostCode Street Phone Age Sex Realname
    Email PagerCode PagerProvider PagerStationNum PagerNum PagerType
    Occupation Homepage Authorization unkn19 unkn20 Avatar
    MobilePhone MobileType Aboutme City unkn26 unkn27 unkn28 PublishMobile
    PublishContact School Horoscope Shengxiao BloodType unkn35 unkn36
);

# Some constants for constructing client packets
my $PacketHead = $PROTO_VER . $SRC_CLIENT;
my $PacketTail = "\x03";	
my $C_LOGIN_17_33 = pack('H*', join("", qw(
00 00 00 09 00 00 00 01 00 00 00 11 f3 c8 9b c5
1f 24 ce d2 9e fe de ba cc 52 b4 b3 02
)));

my $C_LOGIN_35_END = pack('H*', join("", qw(
4d ea b4 a9 e6 85 b0 46 bb 0b 66 a0 1a f4 b6 b2
)));
#########added by alexe
my $C_LOGIN_53_68_END = pack('H*', join("", qw(
82 2a 91 fd a5 ca 67 4c ac 81 1f 6f 52 05 a7 bf
)));
my $C_LOGIN_23_51 = pack('H*', join("", qw(
00 00 00 00 00 00 00 00 00 00 00 00 9a 93 fe 85
d3 d9 2a 41 c8 0d ff b6 40 b8 ac 32 01
)));
my $select =new IO::Select;
my %handle_sub;
#################################


#################### End OICQ protocol data ########################

my @ServerIPs = qw(
    61.144.238.146     202.104.129.251    202.104.129.254     61.141.194.203
    202.104.129.252    202.104.129.253     61.144.238.145     218.17.209.22
);

# Constructor

sub new {
    my ($class) = @_;
    my $dir = ".oicq_data";
    if (-e $dir) {
        -d $dir or croak "$dir exists but is not a directory";
    } else {
        mkdir($dir) or croak "Failed to mkdir $dir: $!";
    }
    my $self = {
        Dir        => $dir,
        LastSvrAck => 0,
        Debug      => 0,  # 1 - trace packets, 2 - desect packets
	Print      =>1,
    };
    my $logfile = "oicq.log";
    my $log = new FileHandle ">>$logfile";
    defined($log) or croak "Failed to open >>$logfile";
    $log->autoflush;
    $self->{LogFile} = $logfile;
    $self->{Log} = $log;
    return bless($self, $class);
}

# Methods that do not require connection to a server

sub set_user {
    my ($self, $id, $pw) = @_;

    $self->{Id} = $id;
    $self->{Passwd} = $pw;
    $self->{_Id} = pack('N', $id);
    $self->{PWKey} = Digest::MD5::md5($pw);
    $self->{PWKey} = Digest::MD5::md5( $self->{PWKey});#added by alexe
    $self->{EventQueue} = [];
    $self->{Command_Queue}= [];
    $self->{Exe_again}="";
    $self->{Exe_time}=time;
    $self->{SearchCount} = 0;
    $self->{LogChat}   = 1;
    $self->{Info}      = {};      # use id as hash key
    $self->{Away}      = 0;
    $self->{LastAutoReply} = {};  # use id as hash key
    $self->{AutoAwayTime} = "";

    my $userdir = "$self->{Dir}/$id";
    -e $userdir or mkdir($userdir);
    if (-d $userdir) {
        foreach ($self->get_saved_ids) { $self->get_nickname($_) };
        my $logfile = "$userdir/user.log";
        my $log = new FileHandle(">>$logfile");
        if (defined $log) {
            $self->log_t("Switch log to $logfile") if $self->{Debug};
            $self->{Log} = undef;
            $self->{LogFile} = $logfile;
            $self->{Log} = $log;
            $log->autoflush;
        } else {
            $self->log_t("Failed to open >>$logfile");
        }
    } else {
        $self->log_t("Failed to mkdir $userdir");
    }
}

# Methods for building OICQ packets

sub build_packet {
    my ($self, $cmd, $data) = @_;
    croak "build_packet error: bad command: $cmd" unless exists $CmdCode{$cmd};
    my $crypt = encrypt(undef, $data, $self->{Key});
    my $packet;
    if($self->{Exe_again}){
	    $packet = $PacketHead . $CmdCode{$cmd} . pack('n',$self->{Exe_again}) .
	    $self->{_Id} . $crypt . $PacketTail;
	    $self->{Exe_again}="";
	    }
    else{
	$self->{Seq}++;
    	$packet = $PacketHead . $CmdCode{$cmd} . pack('n', $self->{Seq}) .
                 $self->{_Id} . $crypt . $PacketTail;
		 }
    return $packet;
}

sub rand_str {
    my $len = pop;
    join('', map(pack("C", rand(0xff)), 1..$len));
}

sub build_login_packet {
    my ($self) = @_;
    my $seq = "\0" . rand_str(1);
    $self->{Seq} = unpack('n', $seq);

    my $randkey = rand_str(16);
    $self->{RandKey} = $randkey;

    # 0x00-0x10
    my $data = encrypt(undef, "", $self->{PWKey}) . "\0";
    # 0x11-0x22    We use fake ip 0.0.0.0 and port 0000 added by alexe
    $data .= pack('Nn', 0x00000000, 0000);
    # 0x23-0x43
    $data .= $C_LOGIN_23_51 . $ConnectMode{"Normal"} .
             $C_LOGIN_53_68_END;

    $PacketHead . $CmdCode{'login'} . $seq . $self->{_Id} . $randkey .
    encrypt(undef, $data, $randkey) . $PacketTail;
}

sub build_logout_packet {
    my ($self) = @_;
    $PacketHead . $CmdCode{'logout'} . ("\xff" x 2) . $self->{_Id} .
    encrypt(undef, $self->{PWKey}, $self->{Key}) . $PacketTail;
}


# Tencent no longer allows getting new number this way
# So these two are pretty much useless

sub build_reg_1_packet {
    my ($self) = @_;
    my $randkey = rand_str(16);
    my $data = "";   # fixme
    $PacketHead . $CmdCode{'reg_new_id_1'} . pack('n', 1) . "\0"x4 .
    $randkey . encrypt(undef, $data, $randkey) . $PacketTail;
}

sub build_reg_2_packet {
    my ($self) = @_;
    my $randkey = rand_str(16);
    my $data = "";   # fixme
    $PacketHead . $CmdCode{'reg_new_id_2'} . pack('n', 2) . "\0"x4 .
    $randkey . encrypt(undef, $data, $randkey) . $PacketTail;
}

# Methods for logging and output

sub log {
    my $self = shift;
    my $log = $self->{Log};
    print $log @_;
}

sub logf {
    my $self = shift;
    my $log = $self->{Log};
    printf $log @_;
}

sub log_t {
    my ($self, @msg) = @_;
    my $log = $self->{Log};
    print $log substr(localtime, 4, 16), @msg, "\n";
}

sub hexdump {
    my $str = pop;
    return unless defined $str;
    my $res = "";
    my $len = length($str);
    for (my $i = 0; $i < $len; $i += 16) {
        my $s = substr($str, $i, 16);
        my $hex = unpack('H*', $s);
        $s =~ s/[\x00-\x1f]/./g;   # 0x00-0x1f will screw up terminal
        $hex =~ s/(\w\w)/$1 /g;
        $res .= sprintf("%-48s    %s\n", $hex, $s);
    }
    return $res;
}

sub dump_substr {
    my ($self, $data, $tmpl, $prefix, $begin, $len) = @_;
    my ($str, $end);
    if (defined($len)) {
        $str = substr($data, $begin, $len);
        $end = ($begin+$len < length($data)) ? $begin+$len-1 : length($data)-1;
    } else {
        $str = substr($data, $begin);
        $end = length($data)-1;
    }
    $self->logf("0x%02x-0x%02x %s: ", $begin, $end, $prefix);
    if ($tmpl =~ /\w/) {
        if ($tmpl eq 'H*') {
            $self->log("\n", $self->hexdump($str));
        } else {
            $self->log(unpack($tmpl, $str), "\n");
        }
    } else {
        $self->log("$str\n");
    }
}

sub desect {
    my $self = shift;
    return unless $self->{Debug} > 1;
    my $data = shift;
    foreach my $arg (@_) {
        $self->dump_substr($data, @{$arg});
    }
    return;
}

sub remove_saved_id {
    my ($self, $id) = @_;
    my $file = "$self->{Dir}/$self->{Id}/$id.dat";
    if (-e $file) {
        unlink($file);
        return 0 if -e $file;
        return 1;
    } else {
        return 0;
    }
}

sub get_saved_ids {
    my ($self) = @_;
    my $dir = "$self->{Dir}/$self->{Id}";
    my @ids = ();
    if (opendir(DIR, $dir)) {
        while(my $f = readdir(DIR)) {
            next unless $f =~ /^(\d+)\.dat$/;
            push @ids, $1;
        }
        closedir(DIR);
    }
    return @ids;
}

sub get_face {
    my $num = pop;
    sprintf('%d-%d', 1 + $num/3, 1 + $num % 3);
}

sub toggle_autoreply {
    my ($self) = @_;
    if ($self->{Away}) {
        $self->{Away} = 0;
        return "off";
    } else {
        $self->{Away} = 1;
        return "on";
    }
}

# Nickname can be updated by get_friends_list or get_user_info

sub get_nickname {
    my ($self, $id) = @_;
    if (defined $self->{Info}->{$id}) {
        if (defined $self->{Info}->{$id}->{Nickname}) {
            return $self->{Info}->{$id}->{Nickname};
        }
    } else {
        $self->{Info}->{$id} = {};
    }
    my $infofile = "$self->{Dir}/$self->{Id}/$id.dat";
    my $nick = "";
    if (open(INFO, $infofile)) {
        while(my $line = <INFO>) {
            if ($line =~ /^Nickname +=> *'(.*)'/) {
                $nick = $1;
                last;
            }
        }
        close(INFO);        
    }
    $self->{Info}->{$id}->{Nickname} = $nick;
    return $nick;
}

sub get_servers {
    my @servers;
    if (exists $ENV{OICQ_SVR} and $ENV{OICQ_SVR} =~ /\d+/) {
        my $svr = $ENV{OICQ_SVR};
        $svr =~ s/^\D+//;
        $svr =~ s/\D+$//;
        @servers = split(/[^\w\.]+/, $svr);