package Net::ICQ;
#
# Perl interface to the ICQ server.
#
# This program was made without any help from Mirabilis or their
# consent.  No reverse engineering or decompilation of any Mirabilis
# code took place to make this program.
#
# Copyright (c) 1998 Bek Oberin.  All rights reserved. 
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# Last updated by gossamer on Sat Oct  3 10:11:52 EST 1998
#

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

use Data::Dumper;
use IO::Socket::INET;
use IO::Select;
use Sys::Hostname;
use Symbol;
use Fcntl;

use Carp;                     # Regular Carp
#use Carp qw(verbose);         # This one's for debugging - uses line numbers

@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw();

$VERSION = "0.06";

=head1 NAME

Net::ICQ - Communicate with a ICQ server

=head1 SYNOPSIS

   use Net::ICQ;
     
   $ICQ = Net::ICQ->new();
   $ICQ->signon();

=head1 DESCRIPTION

C<Net::ICQ> is a class implementing a simple ICQ client in
Perl.

=cut

###################################################################
# Some constants                                                  #
###################################################################

# ICQ Ver 2.0
my $ICQ_Version_Major = 2;
my $ICQ_Version_Minor = 0;

my $Default_ICQ_Port = 4000;
my $Default_ICQ_Host = "icq1.mirabilis.com";

my $Config_File = $ENV{"HOME"} . "/.net-icqrc";

my $DEBUG = 1;

# Status types
my %user_status = (
   "ONLINE" => 0x00000000,
   "AWAY" => 0x01000000,
   "DND" => 0x11000000,
   "INVISIBLE" => 0x00010000,
   );
my %user_status_bynumber = reverse %user_status;

# Packet types
my %server_commands_bynumber = (
   0x00F0 => "GO_AWAY",
   0x0a00 => "ACK",	
   0x1801 => "INFO_REPLY",
   0x1C02 => "REPLY_X1",
   0x2201 => "EXT_INFO_REPLY",
   0x2800 => "SILENT_TOO_LONG",
   0x4600 => "NEW_USER_UIN",
   0x5a00 => "LOGIN_REPLY",
   0x6400 => "BAD_LOGIN",
   0x6e00 => "USER_ONLINE",
   0x7800 => "USER_OFFLINE",
   0x8200 => "QUERY_REPLY",
   0x8C00 => "USER_FOUND",
   0xA000 => "END_OF_SEARCH",
   0xA401 => "STATUS_UPDATE",
   0xB400 => "NEW_USER_REPLY",
   0xC201 => "SYSTEM_MESSAGE",
   0xC800 => "UPDATE_EXT_REPLY",
   0xDC00 => "RECEIVE_MESSAGE",
   0xE001 => "UPDATE_REPLY",
   0xE600 => "REPLY_X2",
   0xFA00 => "TRY_AGAIN",
   );
my %server_commands = reverse %server_commands_bynumber;

my %client_commands_bynumber = (
   0x0604 => "CONTACT_LIST",
   0x0A00 => "ACK",
   0x0A05 => "UPDATE_INFO",
   0x0E01 => "SEND_MESSAGE",
   0x1A04 => "SEARCH_UIN",
   0x2404 => "SEARCH_USER",
   0x2805 => "LOGIN_2",
   0x2E04 => "KEEP_ALIVE",
   0x3804 => "SEND_TEXT_CODE",
   0x3C05 => "ADD_TO_LIST",
   0x4204 => "CMD_X1",
   0x4C04 => "LOGIN_1",
   0x5604 => "MSG_TO_NEW_USER",
   0x5604 => "REQ_ADD_TO_LIST",
   0x6004 => "INFO_REQ",
   0x6A04 => "EXT_INFO_REQ",
   0x9C04 => "CHANGE_PASSWORD",
   0xA604 => "NEW_USER_INFO",
   0xB004 => "UPDATE_EXT_INFO",
   0xBA04 => "QUERY_SERVERS",
   0xC404 => "QUERY_ADDONS",
   0xD804 => "STATUS_CHANGE",
   0xE803 => "LOGIN",
   0xEC04 => "NEW_USER_1",
   0xFC03 => "NEW_USER_REG",
   );
my %client_commands = reverse %client_commands_bynumber;


###################################################################
# Functions under here are member functions                       #
###################################################################

=head1 CONSTRUCTOR

=item new ( [ USERNAME, PASSWORD [, STATUS [, HOST [, PORT ] ] ] ])

Opens a connection to the ICQ server.  Note this does not automatially
log you into the server, you'll need to call login().

C<USERNAME> defaults, in order, to the environment variables
C<ICQUSER>, C<USER> then C<LOGNAME>.

C<PASSWORD> defaults to the contents of the file C<$HOME/.icqpw>.

C<HOST> and C<PORT> refer to the remote host to which a ICQ connection
is required.  Leave them blank unless you want to connect to a server
other than Mirabilis.

The constructor returns the open socket, or C<undef> if an error has
been encountered.

=cut

sub new {
   my $prototype = shift;
   my $uin = shift;
   my $password = shift;
   my $status = shift;
   my $host = shift;
   my $port = shift;

   my $class = ref($prototype) || $prototype;
   my $self  = {};

   $self->{"uin"} = $uin || $ENV{"ICQUSER"} || 
      croak "Unknown ICQ UIN - please specify";
   $self->{"password"} = $password ||
      croak "Unknown ICQ password - please specify";
   $self->{"host"} = $host || $ENV{"ICQHOST"} || $Default_ICQ_Host;
   $self->{"port"} = $port || $ENV{"ICQPORT"} || $Default_ICQ_Port;
   chomp($self->{"tty"} = `tty`);
   $self->{"status"} = $status || $user_status{"ONLINE"};

   $DEBUG && warn "CONSTRUCTOR:  Host: " . $self->{"host"} . ", Port: " . $self->{"port"} . "\n";
   $DEBUG && warn "CONSTRUCTOR:  UIN: " . $self->{"uin"} . ", Password: " . $self->{"password"} . "\n";

   # open the connection
   $self->{"socket"} = new IO::Socket::INET (
      PeerAddr => $self->{"host"},
      PeerPort => $self->{"port"},
      Proto => "udp",
      Type => SOCK_DGRAM,
   ) || croak "new: connect socket: $!";

   $self->{"select"} = new IO::Select [$self->{"socket"}];

   bless($self, $class);
   return $self;
}

#
# destructor
#
sub DESTROY {
   my $self = shift;

   shutdown($self->{"socket"}, 2);
   close($self->{"socket"});

   return 1;
}


=head1 OUTGOING - HIGH LEVEL FUNCTIONS

These are correspond with things you might want to do, rather
than the actual packets in the protocol.

=item login ( );

Logs you into the ICQ server, requests saved messages and other
standard login-type things.

=cut
sub login {
   my $self = shift;
   my ($data_pack);

   # construct the login packet data
   $data_pack = pack("Nna*N2nNcN3",
		     $self->{"socket"}->sockport,	       # PORT
		     (length($self->{"password"}) + 1)<<8, # PASSWD LEN (clobbers long passwds?)
		     $self->{"password"} . "\0",	          # PASSWORD
		     $self->{"socket"}->sockaddr,	       # USER_IP
		     defined($user_status_bynumber{$self->{"status"}}) 
		          ? $self->{"status"} : $user_status{"ONLINE"}, 
                                                 # STATUS 
		     ++$self->{"login_seq_num"},	          # LOGIN_SEQ_NUM
		     0x78000000, 			                   # X1
		     0x04,				                      # X2
		     0x02000000,			                   # X3
		     0x00000000,			                   # X4
		     0x08007800);			                   # X5
		     
   $self->send_message($self->construct_message("LOGIN", $data_pack));
   # TODO grok messages they send back!

   return 1;
}

=pod
=item search ( TEXT );

Search for a user.  You can search by UIN, email, nickname or
realname.

=cut

sub search {
   my $self = shift;
   my $searchtext = shift;

   if ($searchtext =~ /^\d+$/) {
      # all numbers, it's a UIN
      return $self->search_uin($searchtext);

   } elsif ($searchtext =~ /@/) {
      # it's an email address
      return $self->search_user('','','',$searchtext);

   } elsif ($searchtext =~ /^(\w+)\s+(\w+)/) {
      # alpha separated by space is prob'ly Firstname Lastname
      my $first_name = $1;
      my $last_name = $2;
      return $self->search_user('',$first_name, $last_name, '');

   } elsif ($searchtext =~ /^(\w+)\s+(\w+)/) {
      # alpha separated by comma is prob'ly Lastname, Firstname
      my $last_name = $1;
      my $first_name = $2;
      return $self->search_user('',$first_name, $last_name, '');

   } else {
      # assume it's a nickname we're searching
      return $self->search_user($searchtext,'','','');
   }

}

=head1 INCOMING - HIGH LEVEL FUNCTIONS

Copes with responses from the ICQ server.

=item incoming_packet_waiting ( );

Check if there's something from the server waiting to be processed.

=cut

sub incoming_packet_waiting {
   my $self = shift;

   return $self->{"select"}->can_read(0);
}

=pod
=item incoming_process_packet ( );

Do stuff.  

=cut

sub incoming_process_packet {
   my $self = shift;

   my $server;
   my $message;
   
   $DEBUG && warn "INCOMING:  Reading incoming packet ...\n";

   my $sock = $self->{"socket"};

   unless ($sock->recv($message, 99999)) {
      croak "socket:  recv2:  $1";
   }
   $DEBUG && warn "INCOMING:  Got " . length($message) . " bytes.\n";

   my ($version_major, $version_minor, $command, $sequence_number) = 
      unpack("CCnn", $message);  

   if ($DEBUG) {
      my $command_hex = uc(sprintf("%#04x", $command));
      if (my $sc = $server_commands_bynumber{$command}) {
         warn "INCOMING:  Got command " .  
               $server_commands_bynumber{$command} . " ($command/$command_hex) sequence $sequence_number\n";
      } else {
         warn "INCOMING:  Got unknown command number $command/$command_hex sequence $sequence_number\n";
      }
   }

   $message = substr($message, 6); # skip over six bytes /Jah
   if ($command eq $server_commands{"ACK"}) {
      # ack is special case, we ignore it for the moment
      # TODO we should keep track of packets sent (hash, indexed
      #      by sequence number) and tick them off when they're
      #      ACK'd.  Then resend things if they aren't.  Tricky.
      $DEBUG && warn "INCOMING:  Got ACK for packet $sequence_number\n";
   } else {
      # common packet info
      $self->{'icq_packet_info'} = [$version_major, $version_minor, $command, $sequence_number];
      $DEBUG && warn "INCOMING: Sending ACK for packet $sequence_number\n";
      $self->send_ack($sequence_number);

      my $command_name = "receive_" . lc($server_commands_bynumber{$command});
      my $coderef = $self->can($command_name);
      if ($command_name && $coderef) {
         # we've found a method that can process this type of packet
         return $self->$command_name($message);
      } else {
         # TODO: can't cope - what do we do with this packet!!
      }
   }
}

=head1 OUTGOING - LOW LEVEL FUNCTIONS

These correspond directly with the packets available in the ICQ
protocol.

=item send_ack ( SEQUENCE_NUMBER );

Send an ACK to the server, confirming we got packet SEQUENCE_NUMBER.

=cut

sub send_ack {
   my $self = shift;
   my $seq_num = shift;

   return $self->send_message($self->construct_message("ACK", "", $seq_num));
}


=pod
=item send_keepalive ( );

Just tells the server this connection's still alive.  Send it every 
2 minutes or so.

=cut

sub send_keepalive {
   my $self = shift;
   my $uin = shift;
   my $message = shift;

   return $self->send_message($self->construct_message("KEEP_ALIVE"));

}

=pod
=item send_contactlist ( CONTACT_UIN_ARRAY );

Tell the server who we're watching for, by UIN.

=cut

sub send_contactlist {
   my $self = shift;
   my @uins = shift;

   my $data = pack("n", scalar(@uins));
   foreach (@uins) {
      $data .= pack("N", $_);
   }

   return $self->send_message($self->construct_message("CONTACT_LIST", $data));

}

=pod
=item send_message ( UIN, MESSAGE );

Send a message through the server to user UIN.

=cut

sub send_msg {
   my $self = shift;
   my $uin = shift;
   my $message = shift;

   return $self->send_message($self->construct_message("SEND_MESSAGE",
      pack("NCCna*", $uin, 1, 0, length($message) + 1, $message . "\0")));

}


=pod
=item send_url ( UIN, URL );

Send a message through the server to user UIN.

=cut

sub send_url {
   my $self = shift;
   my $uin = shift;
   my $message = shift;

   return $self->send_message($self->construct_message("SEND_MESSAGE",
      pack("NCCna*", $uin, 4, 0, length($message) + 1, $message . "\0")));

}

=pod
=item search_uin ( UIN );

Search for a user by UIN.

=cut
sub search_uin {
   my $self = shift;
   my $uin = shift;

   return $self->send_message($self->construct_message("SEARCH_UIN",
      pack("nN", ++$self->{"search_sequence_number"}, $uin)));
}

=pod
=item search_user ( UIN );

Search for a user by UIN.

=cut
sub search_user {
   my $self = shift;
   my $nick_name = shift;
   my $first_name = shift;
   my $last_name = shift;
   my $email = shift;

   return $self->send_message($self->construct_message("SEARCH_USER",
      pack("nna*na*na*na*", ++$self->{"search_sequence_number"},
            length($nick_name) + 1,
            $nick_name . "\0",
            length($first_name) + 1,
            $first_name . "\0",
            length($last_name) + 1,
            $last_name . "\0",
            length($email) + 1,
            $email . "\0")));

}

=pod
=item request_userinfo ( UIN );

Request basic information about user UIN.

=cut

sub request_userinfo {
   my $self = shift;
   my $uin = shift;

   return $self->send_message($self->construct_message("INFO_REQ",
      pack("nN", ++$self->{"info_sequence_number"}, $uin)));

}

=pod
=item request_userinfo_extended ( UIN );

Request extended information about user UIN.

=cut

sub request_userinfo_extended {
   my $self = shift;
   my $uin = shift;

   return $self->send_message($self->construct_message("EXT_INFO_REQ",
      pack("nN", ++$self->{"info_sequence_number"}, $uin)));

}

=pod
=item change_status ( STATUS );

Update your ICQ status.

=cut

sub change_status {
   my $self = shift;
   my $status = shift;

   # check it's a real status
   return undef unless defined($user_status{$status});

   return $self->send_message($self->construct_message("CHANGE_STATUS",
      $user_status{$status}));

}

=pod
=item change_password ( PASSWD );

Update your ICQ password?  What does this do?

=cut

sub change_password {
   my $self = shift;
   my $passwd = shift;

   return $self->send_message($self->construct_message("CHANGE_PASSWORD",
      pack("nna*", ++$self->{"password_change_sequence_number"},
                   length($passwd) + 1,
                   $passwd . "\0")));

}

=head1 INCOMING - LOW LEVEL FUNCTIONS

Copes with responses from the ICQ server at packet level.

=item receive_login_reply ( );

Receive the login packet from the ICQ socket and respond to it appropriately.

=cut
sub receive_login_reply {
   my $self = shift;
   my $message = shift;

   my ($user_uin, $user_ip, $login_seq) = unpack("N2n", $message); 
      # `unknown' fields ignored

   $DEBUG && print "DEBUG: receive_login_reply() got user_uin=" . 
                    dword_2_chars($user_uin) . 
                    "  user_ip=$user_ip  login_seq=$login_seq\n";

   return 1;
}

sub receive_reply_x2 {
   my $self = shift;
   my $message = shift;

   $self->send_message($self->construct_message("LOGIN_2", pack("C",0)));
   return 1;
}

sub receive_user_online {
   my $self = shift;
   my $message = shift;

   # TODO

}

sub receive_user_offline {
   my $self = shift;
   my $message = shift;

   # TODO

}

sub receive_user_found {
   my $self = shift;
   my $message = shift;

   # TODO

}

sub receive_receive_message {
   my $self = shift;
   my $message = shift;

   my ($remote_uin, $year, $month, $day, $hour, $minute, $type, $length, $text)=
      unpack("NnCCCCnna*", $message);  

  # TODO 
}

sub receive_end_of_search {
   my $self = shift;
   my $message = shift;

   # TODO

}

sub receive_info_reply {
   my $self = shift;
   my $message = shift;

   # TODO

}

sub receive_ext_info_reply {
   my $self = shift;
   my $message = shift;

   # TODO

}

sub receive_status_update {
   my $self = shift;
   my $message = shift;

   # TODO

}


=head1 MISC FUNCTIONS

These don't correspond with anything much.

=item version ( );

Returns version information for this module.

=cut

sub version {
   return "Net::ICQ version $VERSION";
}


###################################################################
# Functions under here are helper functions                       #
###################################################################

sub send_message {
   my $self = shift;
   my $message = shift;

   if (!defined(syswrite($self->{"socket"}, $message, length($message)))) {
      carp "syswrite: $!";
      return 0;
   }

   return 1;
   
}

sub construct_message {
   my $self = shift;
   my $command = shift;
   my $data = shift || '';  # Assume data is already packed or whatever
   my $seq_num = @_ ? shift : ++$self->{"sequence_number"}; # fixed /Jah - seqs can be 0

   $DEBUG && warn "construct_message:  command '$command', seq_num '$seq_num'\n";

   my $message = 
         pack("CCnnN", $ICQ_Version_Major, 
                       $ICQ_Version_Minor,
                       $client_commands{$command},
                       $seq_num,
  	               dword_2_chars($self->{"uin"}))
         . $data;

  return $message;
}

=pod

=item dword_2_chars ( DWORD )

Returns the passed DWORD converted to Intel endian character sequence.

=cut

sub dword_2_chars
{
    my $num = shift;
    my @buf;
    my $buf;

    $buf[0] = ($num>>24) & 0x000000FF;
    $buf[1] = ($num>>16) & 0x000000FF;
    $buf[2] = ($num>>8) & 0x000000FF;
    $buf[3] = ($num) & 0x000000FF;

    $buf  = $buf[3];
    $buf <<= 8;
    $buf |= $buf[2];
    $buf <<= 8;
    $buf |= $buf[1];
    $buf <<= 8;
    $buf |= $buf[0];

    return($buf);
}


=pod

=head1 AUTHOR

Bek Oberin <gossamer@tertius.net.au>

=head1 COPYRIGHT

Copyright (c) 1998 Bek Oberin.  All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

#
# End code.
#
1;
