view release on metacpan or  search on metacpan

Connection.pm  view on Meta::CPAN

#                                                                   #
#    Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor.  #
#                       All rights reserved.                        #
#                                                                   #
#      This module is free software; you can redistribute or        #
#      modify it under the terms of Perl's Artistic License.        #
#                                                                   #
#####################################################################

package Net::IRC::Connection;

use Net::IRC::Event;
use Net::IRC::DCC;
use IO::Socket;
use IO::Socket::INET;
use Symbol;
use Carp;

# all this junk below just to conditionally load a module
# sometimes even perl is braindead...

eval 'use Time::HiRes qw(time)';
if(!$@) {
  sub time ();
  use subs 'time';
  require Time::HiRes;
  Time::HiRes->import('time');
}

use strict;

use vars (
	'$AUTOLOAD',
);


# The names of the methods to be handled by &AUTOLOAD.
my %autoloaded = ( 'ircname'  => undef,
		   'port'     => undef,
		   'username' => undef,
		   'socket'   => undef,
		   'verbose'  => undef,
		   'parent'   => undef,
                   'hostname' => undef,
		   'pacing'   => undef,
                   'ssl'      => undef,
		 );

# This hash will contain any global default handlers that the user specifies.

my %_udef = ();

# Creates a new IRC object and assigns some default attributes.
sub new {
  my $proto = shift;
  
  my $self = {                # obvious defaults go here, rest are user-set
    _debug      => $_[0]->{_debug},
    _port       => 6667,
    # Evals are for non-UNIX machines, just to make sure.
    _username   => eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh",
    _ircname    => $ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker",
    _nick       => $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot",
    _ignore     => {},
    _handler    => {},
    _verbose    =>  0,       # Is this an OK default?
    _parent     =>  shift,
    _frag       =>  '',
    _connected  =>  0,
    _maxlinelen =>  510,     # The RFC says we shouldn't exceed this.
    _lastsl     =>  0,
    _pacing     =>  0,       # no pacing by default
    _ssl	=>  0,       # no ssl by default
    _format     => { 'default' => "[%f:%t]  %m  <%d>", },
  };
  
  bless $self, $proto;
  # do any necessary initialization here
  $self->connect(@_) if @_;
  
  return $self;
}

# Takes care of the methods in %autoloaded
# Sets specified attribute, or returns its value if called without args.
sub AUTOLOAD {
    my $self = @_;  ## can't modify @_ for goto &name
    my $class = ref $self;  ## die here if !ref($self) ?
    my $meth;

    # -- #perl was here! --
    #  <Teratogen> absolute power corrupts absolutely, but it's a helluva lot
    #              of fun.
    #  <Teratogen> =)
    
    ($meth = $AUTOLOAD) =~ s/^.*:://;  ## strip fully qualified portion

    unless (exists $autoloaded{$meth}) {
	croak "No method called \"$meth\" for $class object.";
    }
    
    eval <<EOSub;
sub $meth {
    my \$self = shift;
	
    if (\@_) {
	my \$old = \$self->{"_$meth"};
	
	\$self->{"_$meth"} = shift;
	
	return \$old;
    }
    else {
	return \$self->{"_$meth"};
    }
}
EOSub
    
    # no reason to play this game every time
    goto &$meth;
}

# This sub is the common backend to add_handler and add_global_handler

Connection.pm  view on Meta::CPAN

# This sub will assign a user's custom function to a particular event which
# this connection might receive.  Same args as above.
sub add_handler {
  my ($self, $event, $ref, $rp) = @_;
  return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler');
}

# Hooks every event we know about...
sub add_default_handler {
  my ($self, $ref, $rp) = @_;
  foreach my $eventtype (keys(%Net::IRC::Event::_names)) {
    $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler');
  }
  return 1;
}

# Why do I even bother writing subs this simple? Sends an ADMIN command.
# Takes 1 optional arg:  the name of the server you want to query.
sub admin {
  my $self = shift;        # Thank goodness for AutoLoader, huh?
                           # Perhaps we'll finally use it soon.
  
  $self->sl("ADMIN" . ($_[0] ? " $_[0]" : ""));
}

# Toggles away-ness with the server.  Optionally takes an away message.
sub away {
    my $self = shift;
    $self->sl("AWAY" . ($_[0] ? " :$_[0]" : ""));
}

# Attempts to connect to the specified IRC (server, port) with the specified
#   (nick, username, ircname). Will close current connection if already open.
sub connect {
  my $self = shift;
  my ($password, $sock);
  
  if (@_) {
    my (%arg) = @_;
    
    $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'};
    $password = $arg{'Password'} if exists $arg{'Password'};
    $self->nick($arg{'Nick'}) if exists $arg{'Nick'};
    $self->port($arg{'Port'}) if exists $arg{'Port'};
    $self->server($arg{'Server'}) if exists $arg{'Server'};
    $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'};
    $self->username($arg{'Username'}) if exists $arg{'Username'};
    $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'};
    $self->ssl($arg{'SSL'}) if exists $arg{'SSL'};
  }
  
  # Lots of error-checking claptrap first...
  unless ($self->server) {
    unless ($ENV{IRCSERVER}) {
      croak "No server address specified in connect()";
    }
    $self->server( $ENV{IRCSERVER} );
  }
  unless ($self->nick) {
    $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) }
                || $ENV{USER} || $ENV{LOGNAME} || "WankerBot");
  }
  unless ($self->port) {
    $self->port($ENV{IRCPORT} || 6667);
  }
  unless ($self->ircname)  {
    $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] }
                   || "Just Another Perl Hacker");
  }
  unless ($self->username) {
    $self->username(eval { scalar getpwuid($>) } || $ENV{USER}
                    || $ENV{LOGNAME} || "japh");
  }
  
  # Now for the socket stuff...
  if ($self->connected) {
    $self->quit("Changing servers");
  }
  
  if($self->ssl) {
    require IO::Socket::SSL;
    
    $self->socket(IO::Socket::SSL->new(PeerAddr  => $self->server,
                                       PeerPort  => $self->port,
                                       Proto     => "tcp",
                                       LocalAddr => $self->hostname,
                                       ));
  } else {
    
    $self->socket(IO::Socket::INET->new(PeerAddr  => $self->server,
                                        PeerPort  => $self->port,
                                        Proto     => "tcp",
                                        LocalAddr => $self->hostname,
                                        ));
  }
  
  if(!$self->socket) {
    carp (sprintf "Can't connect to %s:%s!",
          $self->server, $self->port);
    $self->error(1);
    return;
  }
  
  # Send a PASS command if they specified a password. According to
  # the RFC, we should do this as soon as we connect.
  if (defined $password) {
    $self->sl("PASS $password");
  }
  
  # Now, log in to the server...
  unless ($self->sl('NICK ' . $self->nick()) and
          $self->sl(sprintf("USER %s %s %s :%s",
                            $self->username(),
                            "foo.bar.com",
                            $self->server(),
                            $self->ircname()))) {
    carp "Couldn't send introduction to server: $!";
    $self->error(1);
    $! = "Couldn't send NICK/USER introduction to " . $self->server;
    return;
  }
  
  $self->{_connected} = 1;
  $self->parent->addconn($self);
}

# Returns a boolean value based on the state of the object's socket.
sub connected {
  my $self = shift;
  
  return ( $self->{_connected} and $self->socket() );