Вот решил воложить свои ранние игры с протоколом ICQ Скрипт писался чисто в целях изучения протокола, поэтому тут нет подержки проксей и тд. Code: #!/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'){✓}else{waitpid($pid,0);} } exit;