#!/usr/bin/perl

use IO::Socket;

#(c)oded by Gar|k / ICQ check

$uin=$ARGV[0];
$password=$ARGV[1];


$maxtime=2; # такая тема: кароче если пасс не правльный то ответа от серва не приходит
	    # тоесть и прочитать его невозможно =( из-за этого прога тормозит аж на 30 секунд
	    # поэтому я сделал таймер на выполнение комманды
	    # 2 секунды вполне хватает на получение ответа от сервера

$pass=xorpas($password);

# возможные ошибки при авторизации
%AUTH_ER=(
"\x00\x01"=>'Invalid nick or password',
"\x00\x02"=>'Service temporarily unavailable',
"\x00\x03"=>'All other errors',
"\x00\x04"=>'Incorrect nick or password, re-enter',
"\x00\x05"=>'Mismatch nick or password, re-enter',
"\x00\x06"=>'Internal client error (bad input to authorizer)',
"\x00\x07"=>'Invalid account',
"\x00\x08"=>'Deleted account',
"\x00\x09"=>'Expired account',
"\x00\x0A"=>'No access to database',
"\x00\x0B"=>'No access to resolver',
"\x00\x0C"=>'Invalid database fields',
"\x00\x0D"=>'Bad database status',
"\x00\x0E"=>'Bad resolver status',
"\x00\x0F"=>'Internal error',
"\x00\x10"=>'Service temporarily offline',
"\x00\x11"=>'Suspended account',
"\x00\x12"=>'DB send error',
"\x00\x13"=>'DB link error',
"\x00\x14"=>'Reservation map error',
"\x00\x15"=>'Reservation link error',
"\x00\x16"=>'The users num connected from this IP has reached the maximum',
"\x00\x17"=>'The users num connected from this IP has reached the maximum (reservation)',
"\x00\x18"=>'Rate limit exceeded (reservation). Please try to reconnect in a few minutes',
"\x00\x19"=>'User too heavily warned',
"\x00\x1A"=>'Reservation timeout',
"\x00\x1B"=>'You are using an older version of ICQ. Upgrade required',
"\x00\x1C"=>'You are using an older version of ICQ. Upgrade recommended',
"\x00\x1D"=>'Rate limit exceeded. Please try to reconnect in a few minutes',
"\x00\x1E"=>'Can\'t register on the ICQ network. Reconnect in a few minutes',
"\x00\x20"=>'Invalid SecurID',
"\x00\x22"=>'Account suspended because of your age (age < 13)' );

# шаблоны пакетов	
$AUTH_FAILED="\x00\x01\x00..*\x00\x04\x00..*\x00\x08\x00\x02(..)"; # ошибка авторизции
$SRV_COOKIE= "\x00\x01...*\x00\x05...*\x00\x06...*"; # ответ сервара на правильный пароль

###
# справка, а то я сам долго впирался (тут все в 16-ричном виде)
#
# * BYTE is a 8 bit integer
# * WORD is a 2-byte integer (BE)
# * DWORD is a 4-byte integer (BE)
# * STRING is a succession of (ascii) characters without length-leading or null-char-ending
#
# FLAP --------------------------------+
#  2A    byte FLAP id byte
#  xx    byte FLAP channel
#  xx xx word FLAP datagram seq number
#  xx xx word FLAP data size
# -------------------------------------+
#
# TLV ---------------------------------+
#  xx xx word TLV type number
#  xx xx word TLV length value
# -------------------------------------+
#
# обясняю на примере:
# | 00 17 || 00 02 || 00 04 | - TLV(17) word client major versionr  
#   numer    length   value
###

# пакет отсылаемый серверу
$lp=length($pass);
$lu=length($uin);

$n=117; # длина пакета без пароля и юина
$n=$n+$lp+$lu;

# аааа длина пакета жопа аааа
$CLI_IDENT=
"\x2A\x01\x13\x5A\x00".h($n).			# FLAP channel 0x01 длина \ч83
"\x00\x00\x00\x01".				# dword 
"\x00\x01\x00".h($lu).$uin.			# TLV(1) string uin
"\x00\x02\x00".h($lp).$pass.			# TLV(2) array xor password
"\x00\x03\x00\x33".'ICQ Inc. - Product of ICQ (TM).2000b.4.65.1.3281.85'. # TLV(3) string client name,version
"\x00\x16\x00\x02\x01\x0A".			# TLV(16) word client id number 
"\x00\x17\x00\x02\x00\x04".			# TLV(17) word client major versionr
"\x00\x18\x00\x02\x00\x41".			# TLV(18) word client minor version
"\x00\x19\x00\x02\x00\x01".			# TLV(19) word client lesser version
"\x00\x1A\x00\x02\x0C\xD1".			# TLV(1A) word client build number
"\x00\x14\x00\x04\x00\x00\x00\x55".		# TLV(14) dword client distribution number
"\x00\x0F\x00\x02\x65\x6E".			# TLV(0F) string client language
"\x00\x0E\x00\x02\x75\x73";			# TLV(0E) string client country


# если чел в онлайне то его выбрасывает, это стремно =(
# поэтому мы не будет проверять тех, кто в сети

sub status {

my ($http,$zap,$s,$on);
$http = IO::Socket::INET->new( Proto => "tcp", PeerAddr => "status.icq.com", PeerPort => "80");

$zap="GET /online.gif?icq=$uin HTTP/1.1\n"
    ."User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)\n"
    ."Referer: www.icq.com\n"
    ."Host: status.icq.com\n"
    ."Accept: text/*;q=0,9\n"
    ."Connection: close\n\n";
     
print $http $zap;

$on=0;

while($s=<$http>)
	{
	chomp($s);
	if($s=~/online(.)\.gif/){$on=$1;close($http);}
	}
	
close($http);
return $on; }

# хз почему но так надо =) эт типа пакуем в hex чтоб в переменнлй правильно было не 1A а 0x1A
sub h
	{
	my $n=$_[0];
	return pack("H*",sprintf("%2.2x",$n)); 
	}

# пароль отправдяемый в сокете зашифрован тупо xor-ом
	
sub xorpas {
	my ($Password) = @_;
	my ($FinishedString);

	my @Pass = split (//, $Password);

	foreach (@Pass){$_ = ord($_);}

	my @encoding_table = (
		0xf3, 0x26, 0x81, 0xc4,
		0x39, 0x86, 0xdb, 0x92,
		0x71, 0xa3, 0xb9, 0xe6,
		0x53, 0x7a, 0x95, 0x7c);

	for (my $i = 0; $i < length($Password); $i++){
		$FinishedString .= chr($Pass[$i] ^ $encoding_table[$i]);
	}

	return ($FinishedString);
}


sub ex {$pack=$_[0];$c=0;next;}
sub check
	{
print "Status: ";
if(status==1){print "online\n";exit;}else{ print "offline\n"; }	

alarm($maxtime);

#print "start proc $i $pid\n";

$socket = IO::Socket::INET->new( Proto => "tcp", PeerAddr => "login.icq.com", PeerPort => "5190",Timeout => 5) || die("false\n");

$pack='';
$c=1;
$aut=0;
$n=0;

while($c==1)
	{
#	print "$n: ".length($socket)." $aut\n";
	
	if($aut==0) 
		{
		print $socket $CLI_IDENT;$aut=1;$n++;
		next;
		}

	$socket->recv($lol,32,0);chomp($lol);
	
	if(length($lol)==0){ ex('FALSE');}
	
	$pack.=$lol;
	
	if($pack=~/$AUTH_FAILED/){ex("ERROR: ".$AUTH_ER{$1});}
	if($pack=~/$SRV_COOKIE/) {ex("Password: $password");}
	
	$n++;
	}

print "$pack\n";

close($socket);
exit;
	}

for($i=0;$i<1;$i++)
	{
$pid=fork();
if($pid eq '0'){&check;}else{waitpid($pid,0);}
}


exit;