oicq.pm

perl qq

        return @servers if @servers;
    }

    eval "no encoding;" if $] >= 5.008;
    foreach my $n (2..7, "") {
        my $ip = gethostbyname("sz$n.tencent.com");
        next unless $ip;
        push @servers, join('.', map(ord, split('', $ip)));
    }
    if (@servers) {
        # this unregistered ip seems to be for mobile numbers only
        push @servers, '218.17.209.22';
        return @servers;
    }
    return @ServerIPs;
}

sub connect {
    my ($self, $ip, $port) = @_;
    croak "Server IP not provided"  unless defined($ip) && $ip;
    $port = 8000 unless defined($port) && $port;

    my $socket = IO::Socket::INET->new(
            Proto => 'udp', PeerAddr => $ip, PeerPort => $port
    ) or croak("socket error: $@");

    $self->{SvrIP}   = $ip;
    $self->{SvrPort} = $port;
    $self->{Socket}  = $socket;
    return $socket;
}

sub login {
    my ($self, $id, $pw) = @_;
    unless($id||$pw){die"please input id or pass or mode\n"}
    $self->set_user($id, $pw);
    $self->{Key} = ""; 
    $self->{ConnectMode} = 'Normal';
    my $packet = $self->build_login_packet;
    my @servers = $self->get_servers();
    my $port = 8000;
 LOGIN: foreach my $svr (@servers) {
        print "Connecting to server $svr:$port...";
	CONNECT:my $socket = $self->connect($svr, $port);
        $socket->send($packet) && print "...";
        my $resp = undef;
        eval {
            local $SIG{ALRM} = sub { die $timeout_msg };
            alarm $timeout;
            $socket->recv($resp, 0x100, 0);
            alarm 0;
        };
        if ($@ eq $timeout_msg) {
            print "timeout.\n";
	    next LOGIN;
	    #goto CONNECT;
	}

        if (defined $resp && $resp) {
            my $event = Net::OICQ::ServerEvent->new($resp, $self);
            if (defined $event && $event->seq eq pack('n', $self->{Seq})) {
                $self->{LastSvrAck} = time;
                my $login = $event->login;
                if (defined $login) {
                    if ($login) {
                        print "\nlogin ok.\n";
			$select->add($socket);
                        last LOGIN;
                    } else {
                        $svr = $self->{SvrIP};
                        $port = $self->{SvrPort};
                        $socket = undef;
                        print "redirected.\n";
                        redo LOGIN;
                    }
                } else {
                    die "wrong passwd for $id\n";
                }
            } else {
                print "failed.\n";
            }
        } else {
            print "no response.\n";
        }
        $socket = undef;
        next LOGIN;
    }
    return 0 unless $self->{Key};

    # Make sure we logout when control-C is pressed
    $SIG{INT} = sub { $self->logout; exit 1 };
    # Prepare LogoutPacket for logout
    $self->{LogoutPacket} = $self->build_logout_packet;
    $self->{LastKeepaliveTime} = time;
    if (defined $handle_sub{'on_login'}){
	    my $exe=$handle_sub{'on_login'};
	    &$exe; 
    }
    return 1;
}

sub send2svr {
    my ($self, $cmd, $data) = @_;
    my $packet = $self->build_packet($cmd, $data);
    $self->{Socket}->send($packet);
    #$self->{LastKeepaliveTime} = time;
}


# get_friends_list provided by Chen Peng

sub get_friends_list {
    my ($self, $flag) = @_;
    defined $flag or $flag = "\0\0";
    $self->send2svr('get_friends_list', $flag);
}

sub get_online_friends {
    my ($self) = @_;
    $self->send2svr('get_online_friends', "\x02\0\0\0\0");
}
############################new added by alexe
sub send_group_msg{
    my ($self,$group_id,$msg)=@_;
    my $msg_len=length($msg);
    my $end='0'x26;
    my $msg_data=pack("H2",'0a').pack('N',$group_id).pack('n',$msg_len+13).$msg.pack("H*",$end);
    $self->send2svr('group_cmd',$msg_data);
}
sub get_group_info{
    my($self,$int_group_id)=@_;
    my $data=pack("H2","04").pack('N',$int_group_id);
    $self->send2svr('group_cmd',$data);

}
sub search_group{
    my($self,$ext_group_id)=@_;
    my $data=pack("H4","0601").pack('N',$ext_group_id);
    $self->send2svr('group_cmd',$data);
}
sub group_online_uid{
    my ($self,$int_group_id)=@_;
    my $data=pack("H2","0b").pack('N',$int_group_id);
    $self->send2svr('group_cmd',$data);
}
sub execute{
	my($self,$exe,$arg)=@_;
	#print 'Executing ',$exe,":";
	#for( @$arg){
	#	print "$_ ";
	#}
	$self->$exe(split("\x0",join("\x0",@$arg)));
}
sub push_command{
    my($self,$name,$args)=@_;
    my $a=$self->{Command_Queue};
    push @$a,{
	    Executed=>0,
	    Seq=>0,
	    Cmd=>$name,
	    Ack=>0,
	    Time=>"",
	    Args=>$args,
    	    };
}
sub do_one_loop{
    my ($self)=@_;
    my $t0=gettimeofday;
    if (time - $self->{LastKeepaliveTime} >= 60){
    	$self->keepalive;
	return;}
    my @tmp=();
    my $q=$self->{Command_Queue};
    if(@$q>50){#when command_queue >50 clean queue.
            foreach (@$q){
                    if($$_{Ack} ne "1"){
                            push (@tmp,$_);
	                    }
            }
	    @$q=@tmp;
    }
    RECV:foreach my $handle ($select->can_read(0.2)) {
                  my $input = undef;
                  $handle->recv($input, 0x4000, 0);
                  $self->reply_process($input);
                  goto RECV;
            }									    
    foreach(@$q){
	if ($_){
		if($$_{Ack} ne "1"){
			if(time-$self->{Exe_time}<1){last;}
			if($$_{Executed} eq "1"){
				if(time-$$_{Time}>$timeout){#executed command without ack in timeout and execute again
	                                $self->{Exe_again}=$$_{Seq};
					$self->execute($$_{Cmd},$$_{Args});
                                        $$_{Time}=time;
					$self->{Exe_time}=time;
					#print "seq again:$$_{Seq} and time:",time,"\n";
                                        last;
	                                }
                                last;
			}				
			else{#new command to execute
				$$_{Seq}=$self->{Seq}+1;
                                $self->execute($$_{Cmd},$$_{Args});
                                $$_{Executed}=1;
                                $$_{Time}=time;
				$self->{Exe_time}=time;
				#print "seq:$$_{Seq} and time",time,"\n";
                                last;
			}			
		}
	}
    }
my $t00=gettimeofday;
#print "Loop time is:",$t00-$t0,"\n";
	    
}
sub add_handler{
    my($self,$cmd,$sub_cmd)=@_;     
    $handle_sub{$cmd}=$sub_cmd;
}
sub reply_process{
my ($self, $packet) = @_;
my $event= Net::OICQ::ServerEvent->new($packet, $self);
unless($event){return 0;}
$self->{LastSvrAck} = time;
my ($plain)=$event->process;
unless(ref $plain){return 0;}
foreach (keys %handle_sub){
	if ($$plain{'name'} eq $_){
		my $exe=$handle_sub{$_};
		&$exe($plain);
		last;
		}
	}		
}
##########################################
sub set_mode {
    my ($self, $mode_code) = @_;
    $self->send2svr('set_mode', $mode_code);
}

sub get_user_info {
    my ($self, $id) = @_;
    $self->send2svr('get_user_info', $id);
}

sub update_info {
    my ($self, $hashref) = @_;
    my $info = $self->{MyInfo};
    return unless defined $hashref and defined $info;
    my %new_info;
    # Use all upper-case letters for keys
    foreach my $k (keys %$hashref) {
	$new_info{uc($k)} = $hashref->{$k};
    }
    my @update;
    for (my $i = 1; $i < $#InfoHeader; $i++) {
        my $attr = uc($InfoHeader[$i]);
        push(@update, defined($new_info{$attr}) ? $new_info{$attr} : $info->[$i]);
    }
    $self->send2svr('update_info', join($RS, "", "", @update));
    return 1;
}

sub set_passwd {
    my ($self, $newpw) = @_;
    return unless defined $self->{MyInfo};
    my @info = @{$self->{MyInfo}};
    pop @info; shift @info;
    $self->send2svr('update_info', join($RS, $self->{Passwd}, $newpw, @info));
    return 1;
}

sub accept_contact {
    my ($self, $id) = @_;
    $self->send2svr('add_contact_2', $id.$RS."0");
}

sub reject_contact {
    my ($self, $id) = @_;
    $self->send2svr('add_contact_2', $id.$RS."1");
}

sub add_contact {
    my ($self, $id) = @_;
    $self->send2svr('add_contact_1', "$id");
    $self->{ContactId} = $id;
}

sub add_contact_2 {
    my ($self, $msg) = @_;
    my $mmid = $self->{ContactId};
    return unless defined $mmid;
    $self->send2svr('add_contact_2', "$mmid".$RS."2".$RS."$msg");
    delete $self->{ContactId};
}

sub del_contact {
    my ($self, $id) = @_;
    $self->send2svr('del_contact', "$id");
}

sub forbid_contact {
    my ($self, $id) = @_;
    $self->send2svr('forbid_contact', "$id");
}

# send_msg is also used for auto-reply but does not use AutoMsgPrecursor
# I don't think this is a bug, it is a feature.
sub send_msg {
    my ($self, $dstid, $msg) = @_;
    #use bytes;
    $self->log_t("Sent message to $dstid:\n", $msg) if $self->{LogChat} or $self->{Debug};
    my $dstid_ = pack('N', $dstid);
###########################################added by alexe
    my $tail="\x00\x0a\x8b\x45\x13\x00\x86\x22\xcb\xce\xcc\xe5\x0d";##font attr
    my $data = $self->{_Id}.
    		 pack("N", $dstid).
               $SRC_CLIENT.
	       $self->{_Id}.
	       pack("N", $dstid).
               Digest::MD5::md5($dstid_. $self->{Key}).
               "\0\x0b".
               pack("n", $self->{Seq}).
               pack('N', time).
               $MsgPrecursor.
               $msg.
	       $tail;
	       #pack("H*","0"x26);
############################################################	       
    print "send_msg $dstid:\n", $self->hexdump($data) if $self->{Debug} > 1;
    $self->send2svr('send_msg', $data);
}

sub ack_msg {
    my ($self,$seq,$plain) = @_;
    #print "Send ack`s seq:$seq\n";
    $self->{Exe_time}=time;
    if($seq>$self->{Seq}){
	   $self->{Seq}=$seq;
   } 
    foreach (1..3) {
	$self->{Exe_again}=$seq;
    	$self->send2svr('recv_msg', substr($plain,0,12));
	}
}

sub ack_service_msg {
    my ($self, $code, $srcid, $seq) = @_;
    $self->send2svr('ack_service_msg', "$code$FS$srcid$FS$seq");
}

sub keepalive {
    my ($self) = @_;
    $self->send2svr('keep_alive', $self->{Id});
    $self->{LastKeepaliveTime} = time;
}

sub search_user {
    my ($self, $id) = @_;
    $self->send2svr('search_users', join($RS, '0', $id, '-','-','0'));
}

sub list_online_users {
    my ($self, $num) = @_;
    defined $num or $num = 1;
    my $begin = $self->{SearchCount};
    $self->{SearchCount} += $num; 
    my $end = $self->{SearchCount} -1;
    foreach my $p ($begin .. $end) {
        $self->send2svr('search_users', "1".$RS."$p");
    }
}

sub logout {
    my $self = shift;
    defined($self->{LogoutPacket}) && $self->{LogoutPacket} || return;
    my $packet = $self->{LogoutPacket};
    foreach (1..3) {
        $self->{Socket}->send($packet);
    }
    exit;
}


1;

__END__

=head1 NAME

Net::OICQ - Perl interface to an OICQ server

=head1 SYNOPSIS

  use Net::OICQ;
  $oicq = new Net::OICQ;

=head1 DESCRIPTION

=head2 EXPORT

None by default.

=head1 AUTHOR

Shufeng Tan <lt>[e-mail]<gt>

=head1 SEE ALSO

L<perl>.

=cut