File Coverage

blib/lib/Net/ICQ.pm

Criterion	Covered	Total	%
statement	33	316	10.4
branch	5	80	6.2
condition	4	29	13.7
subroutine	8	34	23.5
pod	0	8	0.0
total	50	467	10.7

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',
);

=head1 NAME

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

=head1 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();

=head1 DESCRIPTION

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

=cut

=head1 CONSTRUCTOR

=over 4

=item *

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.

=back

=cut

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;
}


=head1 METHODS

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

=over 4

=item *

connect

Connects the Net::ICQ object to the server.

=cut

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);

}


=item *

disconnect

Disconnects the Net::ICQ object from the server.

=cut

sub disconnect {
  my ($self) = @_;

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


=item *

connected

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

=cut

sub connected {
  my ($self) = @_;

  return $self->{_connected};
}


=item *

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().

=cut

sub start {
  my ($self) = @_;

  while ($self->connected) {
    $self->do_one_loop();
  }
}


=item *

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.


=cut

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();
}


=item *

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.

=cut

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;
}


=item *

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.

=cut

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


=head1 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.

=head2 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 C<%Net::ICQ::cmd_codes> maps string codes to numeric
codes.  C will produce a list of
all the string codes.

=head2 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
  }

=head2 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);

=cut


%_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  into an array of  bytes and returns it.
# If  is too big, only the  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  into an array of bytes and returns it.  If
# 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 , starting at offset
#  and running for  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 , starting at offset
#  and running for  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  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
#  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;