oicq.pm

MSN fast change name is new utility 4 you

    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);
        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, $mode) = @_;
    $self->set_user($id, $pw);
    $self->{Key} = ""; 

    if (defined $mode && exists $ConnectMode{$mode}) {
        $self->log_t("login as $id in $mode mode");
        $self->{ConnectMode} = $mode;
    } else {
        $self->log_t("login as $id, default to Normal mode");
        $self->{ConnectMode} = 'Normal';
    }
    my $packet = $self->build_login_packet;
    my @servers = $self->get_servers();
    my $port = 8000;
    my $timeout = 30;
    my $timeout_msg = "tImEoUt\n";
 LOGIN: foreach my $svr (@servers) {
        print "Connecting to server $svr:$port...";
        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;
        }

        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 "ok.\n";
                        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;

    return 1;
}

sub send2svr {
    my ($self, $cmd, $data) = @_;
    my $packet = $self->build_packet($cmd, $data);
    my $event = Net::OICQ::ClientEvent->new($packet, $self);
    unless (defined $event) {
        $self->log_t("Failed to create new ClientEvent\n");
        return undef;
    }
    $event->process;
    $self->{Socket}->send($packet);
}

# p2p functions not working yet

sub connect_p2p {
    my ($self, $dstid) = @_;
    defined $self->{Info}->{$dstid} or return;
    my $dst = $self->{Info}->{$dstid}->{Addr};
    defined $dst and $dst =~ /[1-9]/ or return;
    my $socket = IO::Socket::INET->new(
            Proto => 'udp', PeerAddr => $dst
    ) or return;
    $self->{Info}->{$dstid}->{Socket} = $socket;
    return $socket;
}

sub send_p2p {
    my ($self, $dstid, $cmd, $data) = @_;
    defined $self->{Info}->{$dstid} or return;
    my $info = $self->{Info}->{$dstid};
    defined $info->{Socket} or return;
    defined $info->{Key} or return;
    my $packet = $self->build_p2p_packet($dstid, $cmd, $data);
    $info->{Socket}->send($packet);
}

# 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");
}

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);
    my $data = $self->{_Id} .
               $dstid_ .
               $SRC_CLIENT .
               $self->{_Id} .
               $dstid_ .
               Digest::MD5::md5($dstid_ . $self->{Key}) .
               "\0\x0b" .
               pack('S', $self->{Seq}) .
               pack('N', time) .
               $MsgPrecursor .
               $msg;
    print "send_msg $dstid:\n", $self->hexdump($data) if $self->{Debug} > 1;
    $self->send2svr('send_msg', $data);
}

sub ack_msg {
    my ($self, $plain) = @_;
    foreach (1..3) {
        $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);
    }
}

sub process_packet {
    my ($self, $packet) = @_;

    my $ver = substr($packet, 0, 1);
    if ($ver ne $PROTO_VER) {
        $self->log_t('Unknown protocol version, ', unpack('H*', $ver));
        $self->log($self->hexdump($packet),"\n") if $self->{Debug};
        return;
    }

    my $src = substr($packet, 1, 2);
    my $event;
    if ($src eq $SRC_SERVER) {
        $event = Net::OICQ::ServerEvent->new($packet, $self);
        $self->{LastSvrAck} = time;
    } else {
        $event = Net::OICQ::ClientEvent->new($packet, $self);
    }

    return unless defined $event;

    if ($self->{Debug}) {
        $self->log_t('Seq=', unpack('H*', $event->seq),
                     ', Src=', unpack('H*', $src),
                     ', Cmd=', unpack('H*', $event->cmdcode),
                     " (", $event->cmd, ")");
    }

    return $event->process;
}

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