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 Thu Sep  3 14:59:31 EST 1998
#

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

require Exporter;

use IO::Socket;
use Sys::Hostname;
use Symbol;
use Fcntl;
use Carp;

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

$VERSION = "0.02";

=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 = "icq.mirabilis.com";

my $Config_File = $ENV{"HOME"} . "/.icq";

my $DEBUG = 1;

# Status types
my %user_status;
$user_status{"ONLINE"} = pack("SSSS", 0, 0, 0, 0,);
$user_status{"AWAY"} = pack("SSSS", 1, 0, 0, 0,);
$user_status{"DND"} = pack("SSSS", 11, 0, 0, 0,);
$user_status{"INVISIBLE"} = pack("SSSS", 0, 1, 0, 0,);

# Packet types
my %packet;
$packet{"ACK"} = 0x0A00;
$packet{"ADD_TO_LIST"} = 0x3C05;
$packet{"CHANGE_PASSWORD"} = 0x9C04;
$packet{"CMD_X1"} = 0x4204;
$packet{"CONTACT_LIST"} = 0x0604;
$packet{"END_OF_SEARCH"} = 0xA000;
$packet{"EXT_INFO_REPLY"} = 0x2201;
$packet{"EXT_INFO_REQ"} = 0x6A04;
$packet{"INFO_REPLY"} = 0x1801;
$packet{"INFO_REQ"} = 0x6004;
$packet{"KEEP_ALIVE"} = 0x2E04;
$packet{"LOGIN"} = 0xE803;
$packet{"LOGIN_1"} = 0x4C04;
$packet{"LOGIN_2"} = 0x2805;
$packet{"LOGIN_REPLY"} = 0x5800;
$packet{"MSG_TO_NEW_USER"} = 0x5604;
$packet{"NEW_USER_1"} = 0xEC04;
$packet{"NEW_USER_INFO"} = 0xA604;
$packet{"NEW_USER_REG"} = 0xFC03;
$packet{"NEW_USER_REPLY"} = 0xB400;
$packet{"NEW_USER_UIN"} = 0x4600;
$packet{"QUERY_ADDONS"} = 0xC404;
$packet{"QUERY_REPLY"} = 0x8200;
$packet{"QUERY_SERVERS"} = 0xBA04;
$packet{"RECEIVE_MESSAGE"} = 0xDC00;
$packet{"REPLY_X1"} = 0x1C02;
$packet{"REPLY_X2"} = 0xE600;
$packet{"REQ_ADD_TO_LIST"} = 0x5604;
$packet{"SEARCH_UIN"} = 0x1A04;
$packet{"SEARCH_USER"} = 0x2404;
$packet{"SEND_MESSAGE"} = 0x0E01;
$packet{"SEND_TEXT_CODE"} = 0x3804;
$packet{"STATUS_CHANGE"} = 0xD804;
$packet{"STATUS_UPDATE"} = 0xA401;
$packet{"SYSTEM_MESSAGE"} = 0xC201;
$packet{"UPDATE_EXT_INFO"} = 0xB004;
$packet{"UPDATE_EXT_REPLY"} = 0xC800;
$packet{"UPDATE_INFO"} = 0x0A05;
$packet{"UPDATE_REPLY"} = 0xE001;
$packet{"USER_FOUND"} = 0x8C00;
$packet{"USER_ONLINE"} = 0x6E00;


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

=head1 CONSTRUCTOR

=item new ( [ USERNAME, PASSWORD [, 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 $arg_username = shift;
   my $arg_password = shift;
   my $arg_host = shift;
   my $arg_port = shift;

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

   warn "new\n" if $DEBUG > 1;

   # read config file first 'cause arguments override it
   my ($username, $password, $host, $port, $status, @contacts) = 
      &read_config_file;
   $self->{"username"} = $arg_username || $username || $ENV{"ICQUSER"} || $ENV{"USER"} || $ENV{"LOGNAME"} || "unknown";
   $self->{"password"} = $arg_password || $password;
   $self->{"host"} = $arg_host || $host || $Default_ICQ_Host;
   $self->{"port"} = $arg_port || $port || $Default_ICQ_Port;
   my $tty = `tty`;
   $self->{"tty"} = chomp($tty);
   $self->{"incoming_port"} = &find_incoming_port();
   $self->{"status"} = $status || $STATUS_ONLINE;

   # open the connection
   $self->{"socket"} = new IO::Socket::INET (
      PeerProto => "udp",
      PeerAddr => $self->{"host"},
      PeerPort => $self->{"port"},
   );
   croak "new: connect socket: $!" unless $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;

   &send_message(&construct_message("LOGIN"));
   &send_message(&construct_message("LOGIN_1"));
   &send_message(&construct_message("CONTACT_LIST"));
   # 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, '');

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

}

=pod
=item incoming_process ( );

Check if there's something from the server

=cut

sub incoming_process {
   my $self = shift;

   # read packet.  hand it off to the packet processors if we know 
   # about it, else fake it

}

=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 &send_message(&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 &send_message(&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("S", scalar(@UINS);
   foreach (@uins) {
      $data .= pack("L", $_);
   }

   return &send_message(&construct_message("CONTACT_LIST", $data));

}

=pod
=item send_message ( UIN, MESSAGE );

Send a message through the server to user UIN.

=cut

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

   return &send_message(&construct_message("SEND_MESSAGE",
      pack("LCCSa*", $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 &send_message(&construct_message("SEND_MESSAGE",
      pack("LCCSa*", $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 &send_message(&construct_message("SEARCH_UIN",
      pack("SL", ++$self->{"search_sequence_number"}, $searchtext)));
}

=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 &send_message(&construct_message("SEARCH_USER",
      pack("SSa*Sa*Sa*Sa*", ++$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 &send_message(&construct_message("INFO_REQ",
      pack("SL", ++$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 &send_message(&construct_message("EXT_INFO_REQ",
      pack("SL", ++$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 &send_message(&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 &send_message(&construct_message("CHANGE_PASSWORD",
      pack("SSa*", ++$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_ack ( );

=cut

sub receive_ack {
   my $self = shift;

   # xxx
}

# xxx 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)))) {
      warn "syswrite: $!";
      return 0;
   }

   return 1;
   
}

sub get_answer {
   my $self = shift;

   my $buffer = "";
   my $buff1;
   
   while (sysread($self->{"socket"}, $buff1, 999999) > 0) {
      $buffer .= $buff1;
   }

   return $buffer;

}

sub construct_message {
   my $self = shift;
   my $command = shift;
   my $data = shift;  # Assume data is already packed
   my $seq_num = shift || ++$self->{"sequence_number"};

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

  return $message;
}

sub deconstruct_message {
   # NB doesn't unpack params
   my $self = shift;
   my $message = shift;

   my ($version_major, $version_minor, $command, $sequence_number, $params) = 
      unpack("CCSSC*");

   return $command, $sequence_number, $params;
}

# Reads password from the file
sub find_password {
   my $password = "";

   open(PWD, $Password_File) || warn "Can't open password file '$Password_File': $!"; 
   $password = <PWD>;
   chomp($password);
   close(PWD);

   return $password;
}

# Searches for a port that the server can use to talk to us
sub find_incoming_port {
   my $port = 9381;

   return $port;
}

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