package IRC;

my $version = q$Id: IRC.pm,v 1.19 2001/12/15 00:02:03 bod Exp $;

=head1 NAME

IRC - Object interface to IRC communications

=head1 SYNOPSIS

use IRC;

=head1 DESCRIPTION

C<IRC> provides an object interface to IRC communication.

=cut

use Carp;
use IO::File;
use IO::Socket;

sub _connect
{
    my $self = shift;
    my $sock = IO::Socket::INET->new(
	    PeerAddr => $self->{server},
	    PeerPort => $self->{port},
	    Proto    => 'tcp',
	) or croak "connect failed ($@)";

    $sock->sockopt(SO_KEEPALIVE, 1);

    my $host = gethostbyaddr($sock->sockaddr, $sock->sockdomain)
	|| $sock->sockhost;

    delete $self->{nick};

    local $\ = "\r\n";
    $sock->print("USER $self->{login} $host $self->{server} :$self->{name}");
    $sock->print("NICK $self->{_pref_nick_}");
    $sock;
}

=head1 IRC OBJECT

=head2 CONSTRUCTOR

=over 4

=item new([I<ARGS>])

Creates a new connection to an IRC server and returns an C<IRC>
object.  The constructor can take the following optional arguments:

    Server	IRC server	[$IRCSERVER or irc.openprojects.net]
    Port	Port number	[ircd(6667)]
    Nick	Nickname	[program name]
    Login	User name	["]
    Name	IRC name	["]

Example:

    my $irc = IRC->new(Nick => 'bot', Name => 'a bot');

If an odd number of arguments is provided, the first is treated as
C<Server>.

=back

=cut

use constant DEFAULT_SERVER => 'irc.openprojects.net';

sub new
{
    my $class = shift;
   (my $prog = $0) =~ s!.*/!!;
    unshift @_, Server if @_ % 2; # allow IRC->new($server)
    my %opts = @_;
    my $self = {
	server	    => $opts{Server} || $ENV{IRCSERVER} || DEFAULT_SERVER,
	port	    => $opts{Port}   || 'ircd(6667)',
	_pref_nick_ => $opts{Nick}   || $prog,
	login	    => $opts{Login}  || $prog,
	name	    => $opts{Name}   || $prog,
    };

    $self->{_sock_} = _connect($self);
    bless $self, $class;
}

=head2 METHODS

=over 4

=item quote(I<ARG>, ...)

Send a raw IRC command to the server.  Multiple I<ARG>s are
concatenated.

=cut

sub quote
{
    my $self = shift;

    $self->{_sock_}->print(@_, "\r\n");
    $self;
}

=item quit([I<REASON>])

Leave this IRC server.  Further methods should not be applied to this
object.

=item join(I<CHANNEL>, [I<KEY>])

Attempt to join the given I<CHANNEL>, using I<KEY> if given.

=item part(I<CHANNEL>)

Leave the given I<CHANNEL>.

=cut

sub quit { shift->quote(QUIT, ' :', @_ ? "@_" : 'leaving') }
sub join { shift->quote(JOIN, " :@_") }
sub part { shift->quote(PART, " :@_") }

=item nick([I<NICK>])

Attempt to change nickname to I<NICK>.  If the requested I<NICK> is
already in use, underscores are added (up to a total length of 10
characters) and the command is retried.

If no I<NICK> is provided, the current value is returned.

=cut

sub nick
{
    my $self = shift;
    @_ ? $self->quote(NICK, ' :', $self->{_pref_nick_} = $_[0])
       : $self->{nick};
}

sub _split
{
    my $self = shift;
    my $type = shift;
    my $target = shift;
    local $_ = "@_";

    for (map { length() ? $_ : ' ' } split /\r?\n/)
    {
	$self->quote($type, ' ', $target, " :$_");
    }

    $self;
}

=item privmsg(I<CHANNEL>|I<NICK>, I<ARG>, ...)

=item notice(I<CHANNEL>|I<NICK>, I<ARG>, ...)

Send an IRC message to the given I<CHANNEL> or I<NICK>.  Multiple
messages are sent if the text resulting from concatenating the I<ARG>s
contains newlines.

=cut

sub privmsg { shift->_split(PRIVMSG, shift, @_) }
sub notice  { shift->_split(NOTICE,  shift, @_) }

=item action(I<CHANNEL>|I<NICK>, I<ARG>, ...)

Send an action to the given I<CHANNEL> or I<NICK>.

=cut

sub action { shift->quote("PRIVMSG ", shift, " :\x01ACTION ", @_, "\x01") };

=item invite(I<NICK>, I<CHANNEL>)

Invite I<NICK> to the given I<CHANNEL> (requires operator status on
channel).

=cut

sub invite { shift->quote("INVITE ", shift, " :@_") };

=item mode(I<CHANNEL>|I<NICK>, I<ARG>, ...)

Set channel or user modes.

=cut

sub mode { shift->quote("MODE @_") };

=item server([I<ARGS>])

Attempt to connect to a different server.  The method can take the
following optional arguments:

    Server	IRC server	[previous server]
    Port	Port number	[previous port]

If an odd number of arguments is provided, the first is treated as
C<Server>.

=cut

sub server
{
    my $self = shift;
    unshift @_, Server if @_ % 2;
    my %opts = @_;

    $self->{server} = $opts{Server} if $opts{Server};
    $self->{port}   = $opts{Port}   if $opts{Port};

    $self->quit('changing servers');
    $self->{_sock_} = $self->_connect;
    $self;
}

=item send(I<NICK>, I<FILE>)

Send (dcc) I<FILE> to I<NICK>.  The offer expires if not accepted
within 5 minutes.

=cut

sub send
{
    my ($self, $to, $file) = @_;
    my $fh = IO::File->new($file);

    unless ($fh)
    {
	carp "can't send file $file ($!)";
	return $self;
    }

    my $size = -s $fh;
    my $listen = IO::Socket::INET->new(
	    Proto   => 'tcp',
	    Listen  => 1,
	    Timeout => 300,
	) or croak "can't create a listening socket ($!)";

    $SIG{CHLD} = IGNORE; # say "no" to zombies

    my $port = $listen->sockport;
    my $addr = unpack 'N', $self->{_sock_}->sockaddr;
    my $pid = fork;

    croak "can't fork ($!)" unless defined $pid;
    unless ($pid)
    {
	# child
	@SIG{qw(INT HUP TERM)} = (DEFAULT) x 3;

	my $sock = $listen->accept
	    or croak "dcc send $file -> $to failed";

	my $total = 0;

	$listen->close;
	while ($size)
	{
	    my $buf;
	    my $out = $size > 1024 ? 1024 : $size;
	    $total += $out;

	    croak "read error on $file ($!)"
		unless $fh->read($buf, $out) == $out;

	    $sock->send($buf) or croak "send error for $file ($!)";
	    my $ack;
	    do {
		$sock->recv($buf, 4) or croak "ack error for $file ($!)";
		croak "ack mismatch for $file ($ack/$total)"
		    if ($ack = unpack 'N', $buf) > $total;
	    } while $ack != $total;

	    $size -= $out;
	}

	exit;
    }

    $self->privmsg($to, "\x01DCC SEND $file $addr $port $size\x01");
}

=item msg()

Return the next message from the server as an IRC::Msg object.

    while (my $msg = $irc->msg)
    {
	# handle message
    }

=back

=cut

sub msg
{
    my $self = shift;
    my $class = ref $self || IRC;
    local $_;

    while (defined ($_ = $self->{_sock_}->getline))
    {
	s/\r?\n//;

	my $msg = { orig => $_ };
	my $prefix = '';
	$prefix = $1 if s/^:(\S+)\s*//;
	@{$msg}{'from', 'user'} = split '!', $prefix, 2;

	next unless s/(\S+)\s*//;
	$msg->{cmd} = $1;
	$msg->{args} = [];
	push @{$msg->{args}}, $1 while s/^:(.*)// or s/(\S+)\s*//;

	if ($msg->{cmd} eq PING) # server ping
	{
	    $self->quote("PONG :$msg->{args}[0]");
	    next;
	}

	if ($msg->{cmd} =~ /^43[36]$/) # nick collision
	{
	    my $nick = $msg->{args}[1] . '_';
	    if (length $nick > 30)
	    {
		croak "can't get a nick"
		    unless exists $self->{nick};
	    }
	    else
	    {
		$self->quote("NICK :$nick");
	    }

	    next;
	}

	if ($msg->{cmd} =~ /^00[1-4]$/) # welcome messages
	{
	    $self->{nick} = $msg->{args}[0]
		unless exists $self->{nick};
	}

	if ($msg->{cmd} eq NICK)
	{
	    if ($msg->{from} eq $self->{nick})
	    {
		# nick change successful
		$self->{nick} = $msg->{args}[0];
	    }
	    elsif ($msg->{from} eq $self->{_pref_nick_})
	    {
		# reclaim preferred nick
		$self->nick($self->{_pref_nick_});
	    }
	}

	elsif ($msg->{cmd} eq QUIT)
	{
	    # reclaim preferred nick
	    $self->nick($self->{_pref_nick_})
		if $msg->{from} eq $self->{_pref_nick_};
	}

	elsif ($msg->{cmd} eq PRIVMSG or $msg->{cmd} eq NOTICE)
	{
	    $msg->{to} = shift @{$msg->{args}};
	    $_ = "@{$msg->{args}}";

	    $msg->{private} = $msg->{to} !~ /^[#&]/;
	    $msg->{hailed}  = $msg->{private} || /\b$self->{nick}\b/;
	    $msg->{to}      = $msg->{from} if $msg->{private};

	    if (s/^\x01([^\x01]+)\x01$/$1/) # CTCP message
	    {
		my $reply;
		$reply ||= $_        if /^PING\s+\S+$/;
		$reply ||= localtime if /^TIME$/;
		$reply ||= $version  if /^VERSION$/;

		if ($reply)
		{
		    # don't answer more than one CTCP message per sec
		    my $now = time;
		    $self->notice($msg->{to}, "\x01$reply\x01")
			if $self->{_ctcp_} < $now;

		    $self->{_ctcp_} = $now;
		}
	    }
	}

	$msg->{_irc_} = $self;
	return bless $msg, $class . '::Msg';
    }

    return undef;
}

package IRC::Msg;

=head1 IRC::Msg OBJECT

=head2 METHODS

=over 4

=item reply(I<ARG>, ...)

Reply to a privmsg either to the channel in which the message was
recieved, or the originating nick.

=cut

sub reply
{
    my $self = shift;

    $self->{_irc_}->privmsg($self->{to}, @_)
	if $self->{cmd} eq PRIVMSG; # musn't respond to these

    $self;
}

=item action(I<ARG>, ...)

Respond with an action either to the channel in which the message was
recieved, or the originating nick.

=cut

sub action
{
    my $self = shift;
    $self->{_irc_}->action($self->{to}, @_)
	if $self->{cmd} eq PRIVMSG;

    $self;
}

=item privmsg(I<ARG>, ...)

=item notice(I<ARG>, ...)

Respond to originating nick with with a privmsg or notice.

=cut

sub privmsg
{
    my $self = shift;
    $self->{_irc_}->privmsg($self->{from}, @_)
	if $self->{cmd} eq PRIVMSG;

    $self;
}

sub notice
{
    my $self = shift;
    $self->{_irc_}->notice($self->{from}, @_)
	if $self->{cmd} eq PRIVMSG;

    $self;
}

=item invite(I<CHANNEL>)

Invite originating nick to I<CHANNEL>.

=cut

sub invite
{
    my $self = shift;
    $self->{_irc_}->invite($self->{from}, @_)
	if $self->{cmd} eq PRIVMSG;

    $self;
}

=item send(I<FILE>, ...)

Send file to the originating nick of the privmsg.

=cut

sub send
{
    my $self = shift;
    $self->{_irc_}->send($self->{from}, @_)
	if $self->{cmd} eq PRIVMSG;

    $self;
}

=item match(I<PATTERN>, ...)

Returns the index of the first I<PATTERN> which match the nick/user or
undef if none.  Uses IRC-style patterns:

    <nick>!<user>@<host>

with asterisk (*) as a wildcard.

=back

=cut

sub match
{
    my $self = shift;

    return unless $self->user; # server notice
    my $trial = $self->from . '!' . $self->user;

    for (my $i = 0; $i < @_; $i++)
    {
       (my $pat = '^' . (quotemeta $_[$i]) . '$') =~ s/\\\*/.*/g;
       return wantarray ? $i : 1 if $trial =~ /$pat/;
    }

    return;
}

=head2 PROPERTIES

    cmd		IRC command
    from	originating nick
    user	originating user
    private	sent to nick, not channel
    to		channel or nick to reply to
    hailed	private message or nick mentioned
    args	message text
    orig	raw IRC message from the server

=cut

sub orig    { shift->{orig} }
sub from    { shift->{from} }
sub user    { shift->{user} }
sub cmd	    { shift->{cmd} }
sub private { shift->{private} }
sub to	    { shift->{to} }
sub hailed  { shift->{hailed} }
sub args    { my @a = @{shift->{args}}; wantarray ? @a : "@a" }

=head1 SIDE EFFECTS

This module traps SIGCHLD if you use the send method.

=head1 AUTHOR

Brendan O'Dea <bod@compusol.com.au>

=head1 COPYRIGHT

Copyright (c) 2000  Brendan O'Dea.  All rights reserved.

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

=cut

1;