Code Index:

package Net::ICQ
EOF

NAME

Net::ICQ - Pure Perl interface to an ICQ server

SYNOPSIS

  use Net::ICQ;

  $icq = Net::ICQ->new($uin, $password);
  $icq->connect();

  $icq->add_handler('SRV_SYS_DELIVERED_MESS', \&on_msg);

  $params = {
    'type'         => 1,
    'text'         => 'Hello world',
    'receiver_uin' => 1234
  };
  $icq->send_event('CMD_SEND_MESSAGE', $params);

  $icq->start();

DESCRIPTION

Net::ICQ is a class implementing an ICQ client interface in pure Perl.

CONSTRUCTOR

new (uin, password [, server [, port]])

Creates a new Net::ICQ object. A Net::ICQ object represents a single user logged into a specific ICQ server. The UIN and password to use are specified as the first two parameters. Server and port are optional, and default to 'icq.mirabilis.com' and '4000', respectively.

Also, environment variables will be checked as follows:
```
  uin      - ICQ_UIN
  password - ICQ_PASS
  server   - ICQ_SERVER
  port     - ICQ_PORT
```
Constructor parameters have the highest priority, then environment variables. The built-in defaults (for server and port only) have the lowest priority.

If either a UIN or password is not provided either directly or through environment variables, new() will return undef.

Note that after calling new() you must next call connect() before you can send and receive ICQ events.

METHODS

All of the following methods are instance methods; you must call them on a Net::ICQ object (for example, $icq->start).

connect

Connects the Net::ICQ object to the server.
disconnect

Disconnects the Net::ICQ object from the server.
connected

Returns true if the Net::ICQ object is connected to the server, and false if it is not.
start

If you're writing a fairly simple application that doesn't need to interface with other event-loop-based libraries, you can just call start() to begin communicating with the server.

Note that start() will not return until the Net::ICQ object is disconnected from the server, either by the server itself or by your event-handler code calling disconnect().
do_one_loop

If you don't want to (or can't) call the start() method, you must continuously call do_one_loop when your Net::ICQ object is connected to the server. It uses select() to wait for data from the server and other ICQ clients, so it won't use CPU power even if you call it in a tight loop. If you need to do other processing, you could call do_one_loop as infrequently as once every few seconds.

This method does one processing loop, which involves looking for incoming data from the network, calling registered event handlers, sending acknowledgements for received packets, transmitting outgoing data over the network, and sending keepalives to the server to tell it that we are still online. If it is not called often enough, you will not be notified of incoming events in a timely fashion, or the server might even think you have disconnected and start to ignore you.
add_handler(command_number, handler_ref)

Sets the handler function for a specific ICQ server event. command_number specifies the event to handle. You may use either the numeric code or the corresponding string code. See the SERVER EVENTS section below for the numeric and string codes for all the events, along with descriptions of each event's function and purpose. handler_ref is a code ref for the sub that you want to handle the event. See the HANDLERS section for how a handler works and what it needs to do.
send_event(command_number, params)

Sends an event to the server. command_number specifies the event to be sent. You may use either the numeric code or the corresponding string code. See the CLIENT EVENTS section below for the numeric and string codes for all the events, along with descriptions of each event's function and purpose. params is a reference to a hash containing the parameters for the event. See the CLIENT EVENTS section for an explanation of the correct parameters for each event.

CLIENT EVENTS

Client events are the messages an ICQ client, i.e. your code, sends to the server. They represent things such as a logon request, a message to another user, or a user search request. They are sometimes called 'commands' because they represent the 'commands' that an ICQ client can execute.

When you ask Net::ICQ to send an event with send_event() (described above), you need to provide 2 things: the event name, and the parameters.

Event name

The event name is the first parameter to send_event(), and it specifies which event you are sending. You may either specify the string code or the numeric code. The section CLIENT EVENT LIST below describes all the events and gives the codes for each. For example: when sending a text message to a user, you may give the event name as either the string 'CMD_SEND_MESSAGE' or the number 270.

The hash %Net::ICQ::cmd_codes maps string codes to numeric codes. keys(%Net::ICQ::cmd_codes) will produce a list of all the string codes.

Parameters

The parameters list is the second parameter to send_event(), and it specifies the data for the event. Every event has its own parameter list, but the general idea is the same. The parameters list is stored as a hashref, where the hash contains a key for each parameter. Almost all the events utilize a regular 1-level hash where the values are plain scalars, but a few events do require 2-level hash. The CLIENT EVENT LIST section lists the parameters for every client event.

For example: to send a normal text message with the text 'Hello world' to UIN 1234, the parameters would look like this:

  {
    'type'         => 1,
    'text'         => 'Hello world',
    'receiver_uin' => 1234
  }

A complete example

Here is the complete code using send_event() to send the message 'Hello world' to UIN 1234:

  $params = {
    'type'         => 1,
    'text'         => 'Hello world',
    'receiver_uin' => 1234
  };
  $icq->send_event('CMD_SEND_MESSAGE', $params);

package Net::ICQ; use strict; use vars qw( $VERSION @_table %cmd_codes %srv_codes %status_codes %privacy_codes %meta_codes %sex_codes %occupations %languages %_parsers %_msg_parsers %_meta_parsers %_builders %_msg_builders ); use Carp; use IO::Socket; use IO::Select; use Time::Local; use Math::BigInt; $VERSION = '0.16'; # "encryption" table (grumble grumble...) @_table = ( 0x59, 0x60, 0x37, 0x6B, 0x65, 0x62, 0x46, 0x48, 0x53, 0x61, 0x4C, 0x59, 0x60, 0x57, 0x5B, 0x3D, 0x5E, 0x34, 0x6D, 0x36, 0x50, 0x3F, 0x6F, 0x67, 0x53, 0x61, 0x4C, 0x59, 0x40, 0x47, 0x63, 0x39, 0x50, 0x5F, 0x5F, 0x3F, 0x6F, 0x47, 0x43, 0x69, 0x48, 0x33, 0x31, 0x64, 0x35, 0x5A, 0x4A, 0x42, 0x56, 0x40, 0x67, 0x53, 0x41, 0x07, 0x6C, 0x49, 0x58, 0x3B, 0x4D, 0x46, 0x68, 0x43, 0x69, 0x48, 0x33, 0x31, 0x44, 0x65, 0x62, 0x46, 0x48, 0x53, 0x41, 0x07, 0x6C, 0x69, 0x48, 0x33, 0x51, 0x54, 0x5D, 0x4E, 0x6C, 0x49, 0x38, 0x4B, 0x55, 0x4A, 0x62, 0x46, 0x48, 0x33, 0x51, 0x34, 0x6D, 0x36, 0x50, 0x5F, 0x5F, 0x5F, 0x3F, 0x6F, 0x47, 0x63, 0x59, 0x40, 0x67, 0x33, 0x31, 0x64, 0x35, 0x5A, 0x6A, 0x52, 0x6E, 0x3C, 0x51, 0x34, 0x6D, 0x36, 0x50, 0x5F, 0x5F, 0x3F, 0x4F, 0x37, 0x4B, 0x35, 0x5A, 0x4A, 0x62, 0x66, 0x58, 0x3B, 0x4D, 0x66, 0x58, 0x5B, 0x5D, 0x4E, 0x6C, 0x49, 0x58, 0x3B, 0x4D, 0x66, 0x58, 0x3B, 0x4D, 0x46, 0x48, 0x53, 0x61, 0x4C, 0x59, 0x40, 0x67, 0x33, 0x31, 0x64, 0x55, 0x6A, 0x32, 0x3E, 0x44, 0x45, 0x52, 0x6E, 0x3C, 0x31, 0x64, 0x55, 0x6A, 0x52, 0x4E, 0x6C, 0x69, 0x48, 0x53, 0x61, 0x4C, 0x39, 0x30, 0x6F, 0x47, 0x63, 0x59, 0x60, 0x57, 0x5B, 0x3D, 0x3E, 0x64, 0x35, 0x3A, 0x3A, 0x5A, 0x6A, 0x52, 0x4E, 0x6C, 0x69, 0x48, 0x53, 0x61, 0x6C, 0x49, 0x58, 0x3B, 0x4D, 0x46, 0x68, 0x63, 0x39, 0x50, 0x5F, 0x5F, 0x3F, 0x6F, 0x67, 0x53, 0x41, 0x25, 0x41, 0x3C, 0x51, 0x54, 0x3D, 0x5E, 0x54, 0x5D, 0x4E, 0x4C, 0x39, 0x50, 0x5F, 0x5F, 0x5F, 0x3F, 0x6F, 0x47, 0x43, 0x69, 0x48, 0x33, 0x51, 0x54, 0x5D, 0x6E, 0x3C, 0x31, 0x64, 0x35, 0x5A, 0x00, 0x00, ); %cmd_codes = ( CMD_ACK => 10, CMD_SEND_MESSAGE => 270, CMD_LOGIN => 1000, CMD_REG_NEW_USER => 1020, CMD_CONTACT_LIST => 1030, CMD_SEARCH_UIN => 1050, CMD_SEARCH_USER => 1060, CMD_KEEP_ALIVE => 1070, CMD_SEND_TEXT_CODE => 1080, CMD_ACK_MESSAGES => 1090, CMD_LOGIN_1 => 1100, CMD_MSG_TO_NEW_USER => 1110, CMD_INFO_REQ => 1120, CMD_EXT_INFO_REQ => 1130, CMD_CHANGE_PW => 1180, CMD_NEW_USER_INFO => 1190, CMD_UPDATE_EXT_INFO => 1200, CMD_QUERY_SERVERS => 1210, CMD_QUERY_ADDONS => 1220, CMD_STATUS_CHANGE => 1240, CMD_NEW_USER_1 => 1260, CMD_UPDATE_INFO => 1290, CMD_AUTH_UPDATE => 1300, CMD_KEEP_ALIVE2 => 1310, CMD_LOGIN_2 => 1320, CMD_ADD_TO_LIST => 1340, CMD_RAND_SET => 1380, CMD_RAND_SEARCH => 1390, CMD_META_USER => 1610, CMD_INVIS_LIST => 1700, CMD_VIS_LIST => 1710, CMD_UPDATE_LIST => 1720 ); %srv_codes = ( SRV_ACK => 10, SRV_GO_AWAY => 40, SRV_NEW_UIN => 70, SRV_LOGIN_REPLY => 90, SRV_BAD_PASS => 100, SRV_USER_ONLINE => 110, SRV_USER_OFFLINE => 120, SRV_QUERY => 130, SRV_USER_FOUND => 140, SRV_END_OF_SEARCH => 160, SRV_NEW_USER => 180, SRV_UPDATE_EXT => 200, SRV_RECV_MESSAGE => 220, SRV_X2 => 230, SRV_NOT_CONNECTED => 240, SRV_TRY_AGAIN => 250, SRV_SYS_DELIVERED_MESS => 260, SRV_INFO_REPLY => 280, SRV_INFO_FAIL => 300, SRV_EXT_INFO_REPLY => 290, SRV_STATUS_UPDATE => 420, SRV_SYSTEM_MESSAGE => 450, SRV_UPDATE_SUCCESS => 480, SRV_UPDATE_FAIL => 490, SRV_AUTH_UPDATE => 500, SRV_MULTI_PACKET => 530, SRV_X1 => 540, SRV_RAND_USER => 590, SRV_META_USER => 990 ); %status_codes = ( ONLINE => 0x0000, AWAY => 0x0001, DO_NOT_DISTURB_2 => 0x0002, NOT_AVAILABLE => 0x0004, NOT_AVAILABLE_2 => 0x0005, OCCUPIED => 0x0010, DO_NOT_DISTURB => 0x0013, FREE_FOR_CHAT => 0x0020, INVISIBLE => 0x0100 ); %privacy_codes = ( WEB_AWARE => 0x0001, SHOW_IP => 0x0002, TCP_MUST_AUTH => 0x1000, TCP_IF_ON_CONNECTLIST => 0x2000 ); %meta_codes = ( GENERAL_INFO => 0x03E9, WORK_INFO => 0x03F3, MORE_INFO => 0x03FD, ABOUT_INFO => 0x0406, ); %sex_codes = ( "UNSPECIFIED" => 0, "FEMALE" => 1, "MALE" => 2 ); %occupations = ( "Academic" => 1, "Administrative" => 2, "Art/Entertainment" => 3, "College Student" => 4, "Computers" => 5, "Community & Social" => 6, "Education" => 7, "Engineering" => 8, "Financial Services" => 9, "Government" => 10, "High School Student" => 11, "Home" => 12, "ICQ - Providing Help" => 13, "Law" => 14, "Managerial" => 15, "Manufacturing" => 16, "Medical/Health" => 17, "Military" => 18, "Non-Government Organization" => 19, "Professional" => 20, "Retail" => 21, "Retired" => 22, "Science & Research" => 23, "Sports" => 24, "Technical" => 25, "University Student" => 26, "Web Building" => 27, "Other Services" => 99, ); %languages = ( 1 => 'Arabic', 2 => 'Bhojpuri', 3 => 'Bulgarian', 4 => 'Burmese', 5 => 'Cantonese', 6 => 'Catalan', 7 => 'Chinese', 8 => 'Croatian', 9 => 'Czech', 10 => 'Danish', 11 => 'Dutch', 12 => 'English', 13 => 'Esperanto', 14 => 'Estonian', 15 => 'Farsi', 16 => 'Finnish', 17 => 'French', 18 => 'Gaelic', 19 => 'German', 20 => 'Greek', 21 => 'Hebrew', 22 => 'Hindi', 23 => 'Hungarian', 24 => 'Icelandic', 25 => 'Indonesian', 26 => 'Italian', 27 => 'Japanese', 28 => 'Khmer', 29 => 'Korean', 30 => 'Lao', 31 => 'Latvian', 32 => 'Lithuanian', 33 => 'Malay', 34 => 'Norwegian', 35 => 'Polish', 36 => 'Portuguese', 37 => 'Romanian', 38 => 'Russian', 39 => 'Serbian', 40 => 'Slovak', 41 => 'Slovenian', 42 => 'Somali', 43 => 'Spanish', 44 => 'Swahili', 45 => 'Swedish', 46 => 'Tagalog', 47 => 'Tatar', 48 => 'Thai', 49 => 'Turkish', 50 => 'Ukrainian', 51 => 'Urdu', 52 => 'Vietnamese', 53 => 'Yiddish', 54 => 'Yoruba', 55 => 'Afrikaans', 56 => 'Bosnian', 57 => 'Persian', 58 => 'Albanian', 59 => 'Armenian', 60 => 'Punjabi', 61 => 'Chamorro', 62 => 'Mongolian', 63 => 'Mandarin', 64 => 'Taiwaness', 65 => 'Macedonian', 66 => 'Sindhi', 67 => 'Welsh', 68 => 'Azerbaijani', 69 => 'Kurdish', 70 => 'Gujarati', 71 => 'Tamil', 72 => 'Belorussian', 73 => 'Unknown', );

sub new { my ($class, $uin, $password, $server, $port) = @_; my ($params); $uin or $uin = $ENV{ICQ_UIN} or return; $password or $password = $ENV{ICQ_PASS} or return; $server or $server = $ENV{ICQ_SERVER} or $server = 'icq.mirabilis.com'; $port or $port = $ENV{ICQ_PORT} or $port = 4000; my $self = { _uin => $uin, _password => $password, _server => $server, _port => $port, _socket => undef, _select => undef, _events_incoming => [], # array _events_outgoing => [], _acks_incoming => [], # acks are processed immediately, so they get their own array _acks_outgoing => [], _handlers => {}, _last_keepalive => undef, _seen_seq => [], _debug => 0 }; $self->{_socket} = IO::Socket::INET->new( Proto => 'udp', PeerAddr => $self->{_server}, PeerPort => $self->{_port}, ) or croak("socket error: $@"); $self->{_select} = IO::Select->new($self->{_socket}); $self->{_last_keepalive} = time(); bless($self, $class); return $self; }

sub connect { my ($self) = @_; $self->{_session_id} = int(rand(0xFFFFFFFF)); $self->{_seq_num_1} = int(rand(0xFFFF)); $self->{_seq_num_2} = 0x1; $self->{_connected} = 1; # send a login event my $params = { password => $self->{_password}, client_ip => $self->{_socket}->sockaddr(), # FIX: deal with client_port correctly when TCP communication is implemented client_port => 0 }; $self->send_event('CMD_LOGIN', $params, 1); }

sub disconnect { my ($self) = @_; $self->send_event('CMD_SEND_TEXT_CODE', {text_code => 'B_USER_DISCONNECTED'}, 1); $self->_do_outgoing(); $self->{_connected} = 0; }

sub connected { my ($self) = @_; return $self->{_connected}; }

sub start { my ($self) = @_; while ($self->connected) { $self->do_one_loop(); } }

sub do_one_loop { my ($self) = @_; $self->_do_incoming(); $self->_do_acks(); $self->_do_multis(); $self->_do_keepalives(); $self->_do_timeouts(); $self->_do_handlers(); $self->_do_outgoing(); }

sub add_handler { my ($self, $command, $sub) = @_; my ($command_num); $command_num = exists $srv_codes{$command} ? $srv_codes{$command} : $command; print "=== add handler <", sprintf("%04X", $command_num), "> = $sub\n" if $self->{_debug}; $self->{_handlers}{$command_num} = $sub; }

sub send_event { my ($self, $command, $params, $priority) = @_; $command = $cmd_codes{$command} if exists ($cmd_codes{$command}); $self->_queue_event( { params => &{$_builders{$command}}($params), command => $command }, $priority ); }

%_parsers = ( # SRV_ACK 10 => sub { my ($event) = @_; delete $event->{params}; }, # SRV_GO_AWAY 40 => sub { my ($event) = @_; delete $event->{params}; }, # SRV_NEW_UIN 70 => sub { my ($event) = @_; delete $event->{params}; }, # SRV_LOGIN_REPLY 90 => sub { my ($event) = @_; my ($parsedevent); $parsedevent->{your_ip} = _bytes_to_int($event->{params}, 12, 4); $event->{params} = $parsedevent; }, # SRV_BAD_PASS 100 => sub { my ($event) = @_; delete $event->{params}; }, # SRV_USER_ONLINE 110 => sub { my ($event) = @_; my ($parsedevent); $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $parsedevent->{ip} = _bytes_to_int($event->{params}, 4, 4); $parsedevent->{port} = _bytes_to_int($event->{params}, 8, 4); $parsedevent->{real_ip} = _bytes_to_int($event->{params}, 12, 4); $parsedevent->{status} = _bytes_to_int($event->{params}, 17, 2); $parsedevent->{privacy} = _bytes_to_int($event->{params}, 19, 2); $event->{params} = $parsedevent; }, # SRV_USER_OFFLINE 120 => sub { my ($event) = @_; my ($parsedevent); $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $event->{params} = $parsedevent; }, # SRV_QUERY 130 => sub { #FIX : don't know what to do here .. }, # SRV_USER_FOUND 140 => sub { my ($event) = @_; my ($parsedevent, $offset, $length); $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $offset = 4; foreach ('nickname', 'firstname', 'lastname', 'email') { $length = _bytes_to_int($event->{params}, $offset, 2); $offset += 2; # Fixed: NN 06 jan 01 $parsedevent->{$_} = _bytes_to_str($event->{params}, $offset, $length - 1); $offset += $length; } $parsedevent->{authorize} = _bytes_to_str($event->{params}, $offset, 1); $event->{params} = $parsedevent; # AUTHORIZE can contain either 00 or 01: # 00 means that your client should request authorization before # adding this user to the contact list. # 01 means that authorization is not required to add him/her to # your contact list. }, # SRV_END_OF_SEARCH 160 => sub { my ($event) = @_; my ($parsedevent); $parsedevent->{too_many} = _bytes_to_int($event->{params}, 0, 1); $event->{params} = $parsedevent; }, # SRV_NEW_USER 180 => sub { #FIX : don't know what to do here .. }, # SRV_UPDATE_EXT 200 => sub { #FIX : don't know what to do here .. }, # SRV_RECV_MESSAGE 220 => sub { my ($event) = @_; my ($parsedevent, @time); # Remove the bytes storing the time of the message, which makes the # params look just like a regular online message (SRV_SYS_DELIVERED_MESS). # Then, we can use that handler directly instead of copying its code here. # Mirabilis really dropped the ball on this one, defining two separate # events where it should really just be one... @time = splice(@{$event->{params}}, 4, 6, ()); &{$_parsers{260}}($event); # we still need to insert the time $event->{params}->{time} = timelocal(0, # sec _bytes_to_int(\@time, 5, 1), # min _bytes_to_int(\@time, 4, 1), # hour _bytes_to_int(\@time, 3, 1), # day _bytes_to_int(\@time, 2, 1)-1, # mon (thanks Bek Oberin for the -1) _bytes_to_int(\@time, 0, 2) # year ); }, # SRV_X2 230 => sub { #FIX : don't know what to do here .. }, # SRV_NOT_CONNECTED 240 => sub { #FIX : don't know what to do here .. }, # SRV_TRY_AGAIN 250 => sub { #FIX : don't know what to do here .. }, # SRV_SYS_DELIVERED_MESS 260 => sub { my ($event) = @_; my ($parsedevent, @strings, @tmp); $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $parsedevent->{type} = _bytes_to_int($event->{params}, 4, 2); $parsedevent->{length} = _bytes_to_int($event->{params}, 6, 2); @strings = _bytes_to_strlist([@{$event->{params}}[8..@{$event->{params}}-1]]); if ($parsedevent->{type} == 1) { $parsedevent->{text} = $strings[0]; } elsif ($parsedevent->{type} == 4) { $parsedevent->{description} = $strings[0]; $parsedevent->{url} = $strings[1]; } elsif ($parsedevent->{type} == 6) { $parsedevent->{nickname} = $strings[0]; $parsedevent->{firstname} = $strings[1]; $parsedevent->{lastname} = $strings[2]; $parsedevent->{email} = $strings[3]; $parsedevent->{reason} = $strings[4]; } elsif ($parsedevent->{type} == 8) { } elsif ($parsedevent->{type} == 12) { $parsedevent->{nickname} = $strings[0]; $parsedevent->{firstname} = $strings[1]; $parsedevent->{lastname} = $strings[2]; $parsedevent->{email} = $strings[3]; } elsif ($parsedevent->{type} == 13) { $parsedevent->{name} = $strings[0]; $parsedevent->{unknown1} = $strings[1]; $parsedevent->{unknown2} = $strings[2]; $parsedevent->{email} = $strings[3]; $parsedevent->{unknown3} = $strings[4]; #always has value: 3 $parsedevent->{message} = $strings[5]; } elsif ($parsedevent->{type} == 14){ $parsedevent->{name} = $strings[0]; $parsedevent->{unknown1} = $strings[1]; $parsedevent->{unknown2} = $strings[2]; $parsedevent->{email} = $strings[3]; $parsedevent->{unknown3} = $strings[4]; #always has value: 3 $parsedevent->{message} = $strings[5]; } elsif ($parsedevent->{type} == 19) { $parsedevent->{contacts} = {}; shift @strings; # remove first element - number of contacts for (my $i=0; $i<@strings-1; $i+=2) { $parsedevent->{contacts}{$strings[$i]} = $strings[$i+1]; } } $event->{params} = $parsedevent; }, # SRV_INFO_REPLY 280 => sub { # (same as SRV_USER_FOUND, above) my ($event) = @_; my ($parsedevent, $offset, $length); $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $offset = 4; foreach ('nickname', 'firstname', 'lastname', 'email') { $length = _bytes_to_int($event->{params}, $offset, 2); $offset += 2; # Fixed: NN 06 jan 01 $parsedevent->{$_} = _bytes_to_str($event->{params}, $offset, $length - 1); $offset += $length; } $parsedevent->{authorize} = _bytes_to_str($event->{params}, $offset, 1); $event->{params} = $parsedevent; }, # SRV_EXT_INFO_REPLY 290 => sub { # Thanks to Nezar Nielsen for this bit. my ($event) = @_; my ($parsedevent, $offset, $length); $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); my $citylength = _bytes_to_int($event->{params}, 4, 2); $parsedevent->{city} = _bytes_to_str($event->{params}, 6, $citylength - 1); $offset = 6 + $citylength; $parsedevent->{country_code} = _bytes_to_int($event->{params}, $offset, 2); $offset += 2; $parsedevent->{country_status} = _bytes_to_int($event->{params}, $offset,1); $offset += 1; my $statelength = _bytes_to_int($event->{params}, $offset,2); $offset += 2; $parsedevent->{state} = _bytes_to_str($event->{params}, $offset,$statelength - 1); $offset += $statelength; $parsedevent->{age} = _bytes_to_int($event->{params}, $offset, 2); $offset += 2; $parsedevent->{sex} = _bytes_to_int($event->{params}, $offset, 1); $offset += 1; for('phone', 'home_page', 'about'){ my $length = _bytes_to_int($event->{params}, $offset, 2); $offset += 2; $parsedevent->{$_} = _bytes_to_str($event->{params}, $offset, $length - 1); $offset += $length; } # done parsing $event->{params} = $parsedevent; # And from the specification (pretty much), here is some extra info: # # The code used in COUNTRY_CODE is the international telephone prefix, e.g. # 01 00 (1) for the USA, 2C 00 (44) for the UK, 2E 00 (46) for Sweden, etc. # COUNTRY_STATUS is normally FE, unless the remote user has not entered a # country, in which case COUNTRY_CODE will be FF FF, and COUNTRY_STATUS # will be 9C. # The field AGE has the value FF FF if the user has not entered his/her age. # Values for SEX: # 00 = Not specified # 01 = Female # 02 = Male }, #SRV_INFO_FAIL 300 => sub { # thanks to Robin Fisher my ($event) = @_; my $parsedevent; $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $event->{params} = $parsedevent; }, # SRV_STATUS_UPDATE 420 => sub { # RTG 8/26/2000 my ($event) = @_; my $parsedevent; $parsedevent->{uin} = _bytes_to_int($event->{params}, 0, 4); $parsedevent->{status} = _bytes_to_int($event->{params}, 4, 2); $parsedevent->{privacy} = _bytes_to_int($event->{params}, 6, 2); $event->{params} = $parsedevent; }, # SRV_SYSTEM_MESSAGE 450 => sub { #FIX : don't know what to do here .. }, # SRV_UPDATE_SUCCESS 480 => sub { #FIX : don't know what to do here .. }, # SRV_UPDATE_FAIL 490 => sub { #FIX : don't know what to do here .. }, # SRV_AUTH_UPDATE 500 => sub { #FIX : don't know what to do here .. }, # SRV_X1 540 => sub { #FIX : don't know what to do here .. }, # SRV_RAND_USER 590 => sub { #FIX : don't know what to do here .. }, # SRV_META_USER 990 => sub { my ($event) = @_; my ($parsedevent, $params); $parsedevent->{subcmd} = _bytes_to_int($event->{params}, 0, 2); $parsedevent->{success} = (_bytes_to_int($event->{params}, 2, 1) == 10); @$params = @{$event->{params}}[3..@{$event->{params}}-1]; if (defined($_meta_parsers{$parsedevent->{subcmd}})){ $parsedevent->{body} = &{$_meta_parsers{$parsedevent->{subcmd}}}($params); } else { $parsedevent->{body} = {}; } $event->{params} = $parsedevent; } ); %_meta_parsers = ( #GENERAL_INFO 100 => sub { return {} }, #WORK_INFO 110 => sub { return {} }, #MORE_INFO 120 => sub { return {} }, #ABOUT_INFO 130 => sub { return {} }, 200 => sub { my ($params) = @_; my ($ret, $offset, $length); $ret->{uin} = _bytes_to_int($params, 0, 4); $offset = 4; foreach ('nickname', 'firstname', 'lastname', 'primary_email', 'secondary_email', 'old_email', 'city', 'state', 'phone', 'fax', 'street', 'cellular') { $length = _bytes_to_int($params, $offset, 2); $ret->{$_} = _bytes_to_str($params, $offset + 2, $length - 1); $offset += $length; } $ret->{zipcode} = _bytes_to_str($params, $offset, 4); $ret->{country} = _bytes_to_str($params, $offset+4, 2); $ret->{authorize} = _bytes_to_str($params, $offset+6, 1); $ret->{webaware} = _bytes_to_str($params, $offset+7, 1); $ret->{hideip} = _bytes_to_str($params, $offset+8, 1); return $ret; }, 230 => sub { my ($params) = @_; return _bytes_to_str($params, 2, _byte_to_int($params, 0, 2) - 1); }, 410 => sub { my ($params) = @_; my ($ret, $offset, $length); $ret->{uin} = _bytes_to_int($params, 0, 4); $offset = 4; foreach ('nickname', 'firstname', 'lastname', 'email') { $length = _bytes_to_int($params, $offset, 2); $ret->{$_} = _bytes_to_str($params, $offset + 2, $length - 1); $offset += $length; } $ret->{authorize} = _bytes_to_str($params, $offset, 1); return $ret; } ); %_builders = ( #CMD_ACK 10 => sub { }, #CMD_SEND_MESSAGE 270 => sub { my ($params) = @_; my ($ret, $body2); $ret = []; push @$ret, _int_to_bytes(4, $params->{receiver_uin}); push @$ret, _int_to_bytes(2, $params->{type}); $body2 = &{$_msg_builders{$params->{type}}}($params); push @$ret, _int_to_bytes(2, @$body2+1); push @$ret, @$body2; push @$ret, (0x0); return $ret; }, #CMD_LOGIN 1000 => sub { my ($params) = @_; return [ _int_to_bytes(4, time()), _int_to_bytes(4, $params->{client_port}), _int_to_bytes(2, length($params->{password})+1), _str_to_bytes($params->{password}, 1), _int_to_bytes(4, 0xD5), _str_to_bytes($params->{client_ip}), _int_to_bytes(1, 4), _int_to_bytes(4, $status_codes{ONLINE}), _int_to_bytes(2, 6), _int_to_bytes(2, 0), _int_to_bytes(4, 0), _int_to_bytes(4, 0x013F0002), _int_to_bytes(4, 0x50), _int_to_bytes(4, 3), _int_to_bytes(4, 0) ]; }, #CMD_REG_NEW_USER 1020 => sub { my ($params) = @_; return [ _int_to_bytes(2, length($params->{password})+1), _str_to_bytes($params->{password}, 1), _int_to_bytes(4, 0xA0), _int_to_bytes(4, 0x2461), _int_to_bytes(4, 0xA00000), _int_to_bytes(4, 0x0) ]; }, #CMD_CONTACT_LIST 1030 => sub { my ($params) = @_; my ($ret, $num); $num = $params->{num_contacts}; # FIX: this shouldn't croak! handle it gracefully.. croak ("120 contact limit, send more than one packet") if ($num > 120); $ret = []; push @$ret, _int_to_bytes(1, $num); for (my $i = 0; $i < $num; $i++){ push @$ret, _int_to_bytes(4, $params->{uins}[$i]); } return $ret; }, #CMD_SEARCH_UIN 1050 => sub { # thanks to Germain Malenfant for the fix my ($params) = @_; return [ _int_to_bytes(4, $params->{uin}) ]; }, #CMD_SEARCH_USER 1060 => sub { my ($params) = @_; return [ _int_to_bytes(2, length($params->{nick})+1), _str_to_bytes($params->{nick}, 1), _int_to_bytes(2, length($params->{first})+1), _str_to_bytes($params->{first}, 1), _int_to_bytes(2, length($params->{last})+1), _str_to_bytes($params->{last}, 1), _int_to_bytes(2, length($params->{email})+1), _str_to_bytes($params->{email}, 1), ]; }, #CMD_KEEP_ALIVE 1070 => sub { return [_int_to_bytes(4, int(rand(0xFFFFFFFF)))]; }, #CMD_SEND_TEXT_CODE 1080 => sub { my ($params) = @_; return [ _int_to_bytes(2, length($params->{text_code})+1), _str_to_bytes($params->{text_code}, 1), _int_to_bytes(2, 0x05) ]; }, #CMD_ACK_MESSAGES 1090 => sub { return [_int_to_bytes(4, int(rand(0xFFFFFFFF)))]; }, #CMD_LOGIN_1 1100 => sub { return [_int_to_bytes(4, int(rand(0xFFFFFFFF)))]; }, #CMD_MSG_TO_NEW_USER 1110 => sub { }, #CMD_INFO_REQ 1120 => sub { my ($params) = @_; return [_int_to_bytes(4, $params->{uin})]; }, #CMD_EXT_INFO_REQ 1130 => sub { my ($params) = @_; return [_int_to_bytes(4, $params->{uin})]; }, #CMD_CHANGE_PW 1180 => sub { }, #CMD_NEW_USER_INFO 1190 => sub { my ($params) = @_; return [ _int_to_bytes(2, length($params->{nick})+1), _str_to_bytes($params->{nick}, 1), _int_to_bytes(2, length($params->{first})+1), _str_to_bytes($params->{first}, 1), _int_to_bytes(2, length($params->{last})+1), _str_to_bytes($params->{last}, 1), _int_to_bytes(2, length($params->{email})+1), _str_to_bytes($params->{email}, 1), _int_to_bytes(1, 0x01), _int_to_bytes(1, 0x01), _int_to_bytes(1, 0x01) ]; }, #CMD_UPDATE_EXT_INFO 1200 => sub { }, #CMD_QUERY_SERVERS 1210 => sub { }, #CMD_QUERY_ADDONS 1220 => sub { }, #CMD_STATUS_CHANGE 1240 => sub { my ($params) = @_; return [_int_to_bytes(4, $params->{status})]; }, #CMD_NEW_USER_1 1260 => sub { }, #CMD_UPDATE_INFO 1290 => sub { my ($params) = @_; return [ _int_to_bytes(2, length($params->{nick})+1), _str_to_bytes($params->{nick}, 1), _int_to_bytes(2, length($params->{first})+1), _str_to_bytes($params->{first}, 1), _int_to_bytes(2, length($params->{last})+1), _str_to_bytes($params->{last}, 1), _int_to_bytes(2, length($params->{email})+1), _str_to_bytes($params->{email}, 1) ]; }, #CMD_AUTH_UPDATE 1300 => sub { }, #CMD_KEEP_ALIVE2 1310 => sub { return [_int_to_bytes(4, int(rand(0xFFFFFFFF)))]; }, #CMD_LOGIN_2 1320 => sub { }, #CMD_ADD_TO_LIST 1340 => sub { my ($params) = @_; return [_int_to_bytes(4, $params->{uin})]; }, #CMD_RAND_SET 1380 => sub { my ($params) = @_; return [_int_to_bytes(4, $params->{rand_group})]; }, #CMD_RAND_SEARCH 1390 => sub { my ($params) = @_; return [_int_to_bytes(2, $params->{rand_group})]; }, #CMD_META_USER 1610 => sub { my ($params) = @_; # Thanks to Nezar Nielsen for this handler (wow!) # (cleaned up and modified slightly by JLM 2/25/2001) # convert string to numeric code if necessary $params->{subcmd} = $meta_codes{$params->{subcmd}} if exists($meta_codes{$params->{subcmd}}); my $return=[]; push @$return, _int_to_bytes(2, $params->{subcmd}); if ($params->{subcmd} == $meta_codes{GENERAL_INFO}) { #1001 - serverresponse: 100 foreach ('nick', 'first', 'last', 'primary_email', 'secondary_email', 'old_email', 'city', 'state', 'phone', 'fax', 'street', 'cellular') { push @$return, _int_to_bytes(2, length($params->{$_} || '')+1); push @$return, _str_to_bytes($params->{$_} || '', 1); } # observe: this has changed since the spec was written, # zipcode is also sent as text with null-termination. push @$return, _int_to_bytes(2, length($params->{zipcode} || '')+1); push @$return, _str_to_bytes($params->{zipcode} || '',1); push @$return, _int_to_bytes(2, $params->{country} || 0); # timezone - don't know the spec for this push @$return, _int_to_bytes(1, $params->{timezone} || 0); push @$return, _int_to_bytes(1, $params->{authorize} || 0); push @$return, _int_to_bytes(1, $params->{webaware} || 0); push @$return, _int_to_bytes(1, $params->{hideip} || 0); } elsif ($params->{subcmd} == $meta_codes{WORK_INFO}) { #1011 - serverresponse: 110 # FIX: Does not work, allthough it sends the info exactly like ICQ 2000b # (which sends it through TCP). foreach ('city', 'state', 'phone', 'fax', 'addr') { push @$return, _int_to_bytes(2, length($params->{$_} || '')+1); push @$return, _str_to_bytes($params->{$_} || '', 1); } # i sniffed my client (ICQ 2000b), and i can see that it sends the zipcode # like the other null-terminated strings push @$return, _int_to_bytes(2, length($params->{zipcode} || '')+1); push @$return, _str_to_bytes($params->{zipcode} || '', 1); push @$return, _int_to_bytes(2, $params->{country} || 0); foreach ('company', 'dept', 'pos') { push @$return, _int_to_bytes(2, length($params->{$_} || '')+1); push @$return, _str_to_bytes($params->{$_} || '', 1); } # got occupation codes from the Icqlib source, and sniffed my way to see that # my icq client sends two bytes here with the number according to what i chose. push @$return, _int_to_bytes(2, $params->{occupation}); push @$return, _int_to_bytes(2, length($params->{url} || '') + 1); push @$return, _str_to_bytes($params->{url} || '', 1); } elsif ($params->{subcmd} == $meta_codes{MORE_INFO}) { #metauser code: 1021 - serverresponse: 120 push @$return, _int_to_bytes(2, $params->{age} || 0xFFFF); push @$return, _int_to_bytes(1, $sex_codes{uc($params->{sex})} || $sex_codes{UNSPECIFIED}); push @$return, _int_to_bytes(2, length($params->{url} || '')+1); push @$return, _str_to_bytes($params->{url} || '', 1); push @$return, _int_to_bytes(2, $params->{year}); push @$return, _int_to_bytes(1, $params->{month} || 1); push @$return, _int_to_bytes(1, $params->{day} || 1); # three spoken languages (or set to 0) push @$return, _int_to_bytes(1, $params->{lang1} || 0); push @$return, _int_to_bytes(1, $params->{lang2} || 0); push @$return, _int_to_bytes(1, $params->{lang3} || 0); } elsif ($params->{subcmd} == $meta_codes{ABOUT_INFO}) { #1030 - serverresponse: 130 push @$return, _int_to_bytes(2, length($params->{about} || '')+1); push @$return, _str_to_bytes($params->{about} || '',1); } return $return; }, #CMD_INVIS_LIST 1700 => sub { my ($params) = @_; my ($ret, $num); $num = $params->{num_contacts}; croak ("120 contact limit, send more than one packet") if ($num > 120); $ret = []; push @$ret, _int_to_bytes(1, $num); for (my $i = 0; $i < $num; $i++){ push @$ret, _int_to_bytes(4, $params->{uins}[$i]); } return $ret; }, #CMD_VIS_LIST 1710 => sub { my ($params) = @_; my ($ret, $num); $num = $params->{num_contacts}; croak ("120 contact limit, send more than one packet") if ($num > 120); $ret = []; push @$ret, _int_to_bytes(1, $num); for (my $i = 0; $i < $num; $i++){ push @$ret, _int_to_bytes(4, $params->{uins}[$i]); } return $ret; }, #CMD_UPDATE_LIST 1720 => sub { my ($params) = @_; return [ _int_to_bytes(4, $params->{uin}), _int_to_bytes(1, $params->{list}), _int_to_bytes(1, $params->{remadd}) ]; }, ); %_msg_builders = ( #MSG_TEXT 1 => sub { my ($params) = @_; return [_str_to_bytes($params->{text})]; }, #MSG_URL 4 => sub { my ($params) = @_; my (@ret, $first); $first = 1; foreach ('description', 'url'){ push @ret, (0xFE) if !$first; $first = 0 if $first; push @ret, _str_to_bytes($params->{$_}); } return \@ret; }, #MSG_AUTH_REQ 6 => sub { my ($params) = @_; my (@ret, $first); $first = 1; foreach ('nickname', 'firstname', 'lastname', 'email', 'reason'){ push @ret, (0xFE) if !$first; $first = 0 if $first; push @ret, _str_to_bytes($params->{$_}); } return \@ret; }, #MSG_AUTH 8 => sub { my ($params) = @_; my @ret = undef; return \@ret; }, #MSG_USER_ADDED message 12 => sub { my ($params) = @_; my (@ret, $first); $first = 1; foreach ('nickname', 'firstname', 'lastname', 'email'){ push @ret, (0xFE) if !$first; $first = 0 if $first; push @ret, _str_to_bytes($params->{$_}); } return \@ret; }, #MSG_CONTACTS message 19 => sub { my ($params) = @_; my (@ret, $num_uins); $num_uins = keys(%{$params->{contacts}}); push @ret, _str_to_bytes($num_uins); foreach (%{$params->{contacts}}) { push @ret, (0xFE); push @ret, _str_to_bytes($_); } return \@ret; } ); # == DEVELOPERS' NOTE == # (should this be in pod???) # # An event is stored as a hash ref (note: not a full blessed object). # Here are the fields (keys) in the hash and their descriptions: # # command - The numeric command code # seq_num_1 - Sequence number 1, which is incremented in every packet # seq_num_2 - Sequence number 2, which is incremented in most (?) packets # params - The raw array of bytes that make up the parameters # is_ack - Set to 1 if this is an ACK event, otherwise not present # is_multi - Set to 1 if this is a multi packet, otherwise not present # # The following fields exist only in outgoing events: # # send_last - time of the last resend, as time() (seconds since the epoch) # send_count - number of times the event has been sent to the server # send_now - set to 1 when the event is due to be resent # ==== # private methods # ==== # look for data coming from the server and build events out of it sub _do_incoming { my ($self) = @_; my ($raw, @packet, $event); while (IO::Select->select($self->{_select}, undef, undef, .00001)) { $self->{_socket}->recv($raw, 10000); @packet = split('', $raw); foreach (@packet) { $_ = ord($_); } # build the event $event = $self->_parse_packet(\@packet); # DEBUG: print out incoming packets if ($self->{_debug}) { print '<-- event #', $event->{seq_num_1}, ' '; _print_packet(\@packet); print " <", $event->{command},">\n"; } # put acks in separate array because they will be handled immediately. if ( $event->{is_ack} ) { push @{$self->{_acks_incoming}}, $event; } # stick everything that hasn't already been seen in the incoming events list else { my $not_in_array = 1; foreach my $seq ( @{$self->{_seen_seq}} ) { if ($seq == $event->{seq_num_1}) { $not_in_array = 0; last; } } if ($not_in_array) { push @{$self->{_events_incoming}}, $event; push @{$self->{_seen_seq}}, $event->{seq_num_1}; if (@{$self->{_seen_seq}} > 20) { shift @{$self->{_seen_seq}}; } } } # end else } # end while } # end sub _do_incoming # for each incoming ack, remove corresponding outgoing event from queue, # and send out acks for every non-ack event we received sub _do_acks { my ($self) = @_; my (@params); # incoming ACKs are received, delete corrosponding outgoing events foreach ( @{$self->{_acks_incoming}} ) { #DEBUG: print out incoming ACKS print " (ACK #", $_->{seq_num_1}, ")\n" if $self->{_debug}; # remove the matching outgoing event that got ACK from server if ( defined $self->{_events_outgoing}[0] && $_->{seq_num_1} == $self->{_events_outgoing}[0]{seq_num_1} ) { shift @{$self->{_events_outgoing}}; $self->{_seq_num_1}++; # increment seq_num_1 because event was sucessfully received $self->{_seq_num_2}++; # increment seq_num_1 because event was sucessfully received } } # end foreach # remove all incoming acks because they're all processed $self->{_acks_incoming} = []; # got some incoming events, send some loving ACKs home # to tell them events are successfully received. foreach ( @{$self->{_events_incoming}} ) { push @{$self->{_acks_outgoing}}, { command => 10, is_ack => 1, seq_num_1 => $_->{seq_num_1}, seq_num_2 => $_->{seq_num_2}, params => [_int_to_bytes(4, int(rand(0xFFFFFFFF)))] }; } # end foreach } # end sub _do_acks # split the sub-events out of all the multi events on the incoming # queue, put the sub-events on the queue, and remove the multi sub _do_multis { my ($self) = @_; my ($event, $i); $i = 0; # for every incoming packet foreach (@{$self->{_events_incoming}}) { # if it's not a multi, skip it if (!$_->{is_multi}) { $i++; next; } my (@newevents, $offset); #for each packet in the multi packet.. $offset = 1; for (my $i = 0; $i < _bytes_to_int($_->{params}, 0, 1); $i++) { # build the event my $packet_length = _bytes_to_int($_->{params}, $offset, 2); $offset += 2; my @packet = @{$_->{params}}[$offset..($offset + $packet_length)-1]; $offset += $packet_length; # build the event and queue it $event = $self->_parse_packet(\@packet); push @{$self->{_events_incoming}}, $event; # DEBUG: print out incoming packets if ($self->{_debug}) { print ' <+ multi #', $event->{seq_num_1}, ' '; _print_packet(\@packet); print " <", $event->{command},">\n"; } } # end for # remove the multi from the queue splice(@{$self->{_events_incoming}}, $i, 1); } # end foreach } # end sub _do_multis # if it's time, queue a keepalive packet as close to the head of the queue # as possible sub _do_keepalives { my ($self) = @_; my ($now); # grab current time $now = time(); # FIX: make the time configgable # Keepalive every 2 minutes, as recommanded by ICQ V5. if ($self->{_last_keepalive} + 2*60 < $now) { #DEBUG: print out keepalive print "=== queueing keepalive\n" if $self->{_debug}; $self->{_last_keepalive} = $now; $self->send_event('CMD_KEEP_ALIVE', undef, 1); } # end if } #end _do_keepalives # see if the top event needs to be resent, and remove it from the # outgoing queue if it's been resent too many times sub _do_timeouts { my ($self) = @_; # FIX: make the time configgable if ( defined $self->{_events_outgoing}[0] && $self->{_events_outgoing}[0]{send_last} + 10 <= time() ) { if ( $self->{_events_outgoing}[0]{send_count} >= 6 ) { # FIX: it would probably be wise to inform the programmer that # their event couldn't be sent. #DEBUG: print out timeout print "=== too many resends for ", $self->{_events_outgoing}[0]{seq_num_1}, "\n" if $self->{_debug}; # out of tries, you loose, next! shift @{$self->{_events_outgoing}}; } else { $self->{_events_outgoing}[0]{send_now} = 1; } } } # end sub _do_timeouts # call the handler for each event on the incoming queue sub _do_handlers { my ($self) = @_; foreach ( @{$self->{_events_incoming}} ) { # if a handler for this event has been registered if (exists $self->{_handlers}{$_->{command}} ) { # parse the raw event params &{$_parsers{$_->{command}}}($_) if ( exists $_parsers{$_->{command}} ); #call the handler &{$self->{_handlers}{$_->{command}}}($self, $_); } # end if } # end foreach # empty incoming queue $self->{_events_incoming} = []; } # send all outgoing acks, send the top event on the regular # outgoing queue if it's marked as ready to go sub _do_outgoing { my ($self) = @_; foreach (@{$self->{_acks_outgoing}}) { #DEBUG: print out sending acks print "--> ACK #", $_->{seq_num_1}, "\n" if $self->{_debug}; $self->_deliver_event($_); } # end foreach # clear outgoing ack array $self->{_acks_outgoing} = []; if ( $self->{_events_outgoing}[0] and $self->{_events_outgoing}[0]{send_now} ) { $self->{_events_outgoing}[0]{send_now} = 0; $self->{_events_outgoing}[0]{send_last} = time(); $self->{_events_outgoing}[0]{send_count}++; $self->{_events_outgoing}[0]{seq_num_1} = $self->{_seq_num_1}; $self->{_events_outgoing}[0]{seq_num_2} = $self->{_seq_num_2}; #DEBUG: print out outgoing event print "--> event #", $self->{_events_outgoing}[0]{seq_num_1}, " <" , $self->{_events_outgoing}[0]{command}, ">\n" if $self->{_debug}; $self->_deliver_event($self->{_events_outgoing}[0]); } # end if } # end sub _do_outgoing # adds an event to the queue, with an optional priority flag # (priority means the event is put as close to the head as # possible without interrupting a "live" event) sub _queue_event { my ($self, $event, $priority) = @_; $event->{send_count} = 0; # not resent at all yet $event->{send_last} = 0; # a time as far in the past as possible $event->{send_now} = 1; # send me right away when I get to the head of the queue if (!$priority) { # regular event; just slap it on the tail of the queue push @{$self->{_events_outgoing}}, $event; } else { # priority event; stick it on top, or just after that if top event is "live" if ( # top event not defined (queue empty) !defined $self->{_events_outgoing}[0] or # top event is defined but has not been sent out yet (not live) (defined $self->{_events_outgoing}[0] and $self->{_events_outgoing}[0]{send_count} == 0) ) { # then stick event on the head of the queue unshift @{$self->{_events_outgoing}}, $event; } else { # there is a live event on the top of the queue (we're waiting for it to be ACKed); # queue this event AFTER the live event so as not to interrupt it splice @{$self->{_events_outgoing}}, 1, 0, $event; } } } # takes an event, builds a UDP packet, and sends it to the server sub _deliver_event { my ($self, $event) = @_; my ($packet, $checkcode, $raw, $length); $packet = $self->_make_header($event); push @$packet, @{$event->{params}}; $checkcode = $self->_calc_checkcode($packet); $length = @$packet; $raw = $self->_encrypt($packet, $checkcode); # now $raw might have extra 0-bytes substr($raw, $length) = ''; # truncate data to correct length $self->{_socket}->send($raw); } # ICQ Packet Header (client side) # =============================== # Length Content (if fixed) Designation Description # ------ ------------------ ----------- ----------- # 2 bytes 05 00 VERSION Protocol version # 4 bytes 00 00 00 00 ZERO Just zeros, purpouse unknown # 4 bytes xx xx xx xx UIN Your (the client's) UIN # 4 bytes xx xx xx xx SESSION_ID Used to prevent 'spoofing'. See below. # 2 bytes xx xx COMMAND # 2 bytes xx xx SEQ_NUM1 Starts at a random number # 2 bytes xx xx SEQ_NUM2 Starts at 1 # 4 bytes xx xx xx xx CHECKCODE # variable xx ... PARAMETERS Parameters for the command being sent sub _make_header { my ($self, $event) = @_; my ($header); $header = []; push @$header, _int_to_bytes(2, 5); push @$header, _int_to_bytes(4, 0); push @$header, _int_to_bytes(4, $self->{_uin}); push @$header, _int_to_bytes(4, $self->{_session_id}); push @$header, _int_to_bytes(2, $event->{command}); push @$header, _int_to_bytes(2, $event->{seq_num_1}); push @$header, _int_to_bytes(2, $event->{seq_num_2}); push @$header, _int_to_bytes(4, 0); # checkcode gets set later return $header; } sub _calc_checkcode { my ($self, $packet) = @_; my ($number1, $number2, $r1, $r2, @checkcode); # NUMBER1 = B8 B4 B2 B6 $number1 = $packet->[8]; $number1 <<= 8; $number1 |= $packet->[4]; $number1 <<= 8; $number1 |= $packet->[2]; $number1 <<= 8; $number1 |= $packet->[6]; # PL = Packet length # R1 = A random number beetween 0x18 and PL # R2 = Another random number beetween 0 and 0xFF # (the max here may end up 1 too small.. who cares) $r1 = int(rand(@$packet - 0x18)) + 0x18; $r2 = int(rand(0xFF)); $number2 = $r1; $number2 <<= 8; $number2 |= $packet->[$r1]; $number2 <<= 8; $number2 |= $r2; $number2 <<=8; $number2 |= $_table[$r2]; $number2 ^= 0x00FF00FF; @checkcode = _int_to_bytes(4, $number1 ^ $number2); splice(@$packet, 0x14, 0x04, @checkcode); return _bytes_to_int(\@checkcode, 0, 4); } sub _encrypt { my ($self, $packet, $cc) = @_; my ($code, @plain, @dwords, $i, $raw, $cc_raw); $code = Math::BigInt->new(@$packet * 0x68656C6C + $cc); $code = $code->band(Math::BigInt->new(0xFFFFFFFF)); @plain = splice(@$packet, 0, 0xA, ()); $i = 0; while ($i < @$packet) { push @dwords, _bytes_to_int($packet, $i, 4); $i += 4; } $i = 0xA; foreach (@dwords) { $_ = Math::BigInt->new($_); $_ = $_->bxor(Math::BigInt->new($code + $_table[$i & 0xFF])); $i += 4; } $cc = (($cc & 0x0000001F) << 0x0C) | (($cc & 0x03E003E0) << 0x01) | (($cc & 0xF8000400) >> 0x0A) | (($cc & 0x0000F800) << 0x10) | (($cc & 0x041F0000) >> 0x0F); for ($i = 0; $i < 4; $i++) { $cc_raw .= chr($cc & 0xFF); $cc >>= 8; } $raw = ''; foreach (@plain) { $raw .= chr($_); } foreach (@dwords) { for ($i = 0; $i < 4; $i++) { $raw .= chr($_ & 0xFF); $_ >>= 8; } } substr($raw, 0x14, 4, $cc_raw); return $raw; } # ICQ Packet Header (server side) # =============================== # Length Content (if fixed) Designation Description # 2 bytes 05 00 VERSION Protocol version # 1 byte 00 ZERO Unknown # 4 bytes xx xx xx xx SESSION_ID Same as in your login packet. # 2 bytes xx xx COMMAND # 2 bytes xx xx SEQ_NUM1 Sequence 1 # 2 bytes xx xx SEQ_NUM2 Sequence 2 # 4 bytes xx xx xx xx UIN Your (the client's) UIN # 4 bytes xx xx xx xx CHECKCODE # variable xx ... PARAMETERS Parameters for the command being sent sub _parse_packet { my ($self, $packet) = @_; my ($event, @params); # Thanks to Robin Fisher for this fix for V3 packets. # if it's a version 3 packet, change the header to match a version 5 packet. # (apparently, the only difference in V5 is the addition of the session id) if (_bytes_to_int($packet, 0, 2) == 3) { print("OOPS: Server sent a V3 packet. Converting to V5.\n"); splice @$packet, 0, 2, (5, 0, 0, _int_to_bytes(4, $self->{_session_id})); } # sanity checks if (_bytes_to_int($packet, 3, 4) != $self->{_session_id}) { print("OOPS: Server told us the wrong session ID!\n") if $self->{_debug}; $self->disconnect; } if (_bytes_to_int($packet, 13, 4) != $self->{_uin}) { print("OOPS: Server told us the wrong UIN!\n") if $self->{_debug}; $self->disconnect; } # fill in the event's fields $event = {}; $event->{command} = _bytes_to_int($packet, 7, 2); $event->{seq_num_1} = _bytes_to_int($packet, 9, 2); $event->{seq_num_2} = _bytes_to_int($packet, 11, 2); $event->{is_ack} = 1 if $event->{command} == 10; $event->{is_multi} = 1 if $event->{command} == 530; @params = @$packet[21..@$packet-1]; $event->{params} = \@params; return $event; } # ==== # private functions # (they're not methods, so don't call them on a Net::ICQ object!) # ==== # _int_to_bytes(bytes, val) # # Converts <val> into an array of <bytes> bytes and returns it. # If <val> is too big, only the <bytes> least significant bytes are # returned. The array is in little-endian order. # # _int_to_bytes(2, 0x1234) == (0x34, 0x12) # _int_to_bytes(2, 0x12345) == (0x45, 0x23) sub _int_to_bytes { my ($bytes, $val) = @_; my (@ret); for (my $i=0; $i<$bytes; $i++) { push @ret, ($val >> ($i*8) & 0xFF); } return @ret; } # _str_to_bytes(str, add_zero) # # Converts <str> into an array of bytes and returns it. If <add_zero> # is true, makes the array null-terminated (adds a 0 as a the last byte). # # _str_to_bytes('foo') == ('f', 'o', 'o') # _str_to_bytes('foo', 1) == ('f', 'o', 'o', 0) sub _str_to_bytes { my ($string, $add_zero) = @_; my (@ret); # the ?: keeps split() from complaining about undefined values foreach (split('', defined($string) ? $string : '')) { push @ret, ord($_); } push @ret, 0 if $add_zero; return @ret; } # _bytes_to_int(array_ref, start, bytes) # # Converts the byte array referenced by <array_ref>, starting at offset # <start> and running for <bytes> values, into an integer, and returns it. # The bytes in the array must be in little-endian order. # # _bytes_to_int([0x34, 0x12, 0xAA, 0xBB], 0, 2) == 0x1234 # _bytes_to_int([0x34, 0x12, 0xAA, 0xBB], 2, 1) == 0xAA sub _bytes_to_int { my ($array, $start, $bytes) = @_; my ($ret); $ret = 0; for (my $i = $start+$bytes-1; $i >= $start; $i--) { $ret <<= 8; $ret |= ($array->[$i] or 0); } return $ret; } # _bytes_to_str(array_ref, start, bytes) # # Converts the byte array referenced by <array_ref>, starting at offset # <start> and running for <bytes> values, into a string, and returns it. # # _bytes_to_str([0x12, 'f', 'o', 'o', '!'], 1, 3) == 'foo' sub _bytes_to_str { # thanks to Dimitar Peikov for the fix my ($array, $start, $bytes) = @_; my ($ret); $ret = ''; for (my $i = $start; $i < $start+$bytes; $i++) { $ret .= $array->[$i] ? chr($array->[$i]) : ''; } return $ret; } # _bytes_to_strlist(array_ref) # # Converts the byte array referenced by <array_ref> into an array of # strings, and returns a reference to the array. # The strings in the byte array must be separated by the byte 0xFE, and the # end of the last string to be converted must be followed by the byte 0x00. # # _bytes_to_strlist(['a', 'b', 0xFE, 'x', 'y', 'z', 0x00]) == ['ab', 'xyz'] sub _bytes_to_strlist { my ($array) = @_; my (@ret, $str); $str = ''; foreach (@$array) { if ($_ == 0xFE) { push @ret, $str; $str = ''; } else { $str .= chr($_); } } # remove last 0 from the last string substr($str, -1, 1, ''); push @ret, $str; return @ret; } # print_packet(packet_ref) # # Dumps the ICQ packet contained in the byte array referenced by # <packet_ref> to STDOUT. The format is '[byte0 byte1 ...]' # where byte0 byte1 ... are all the actual bytes # that make up the packet, in 2-character 0-padded hex format. # For instance, a dump might begin like this: # [02 BD 14 4A ... sub _print_packet { my ($packet) = @_; print "["; foreach (@$packet) { print sprintf("%02X ", $_); } print "]"; } 1;