#!/usr/bin/perl
#
#  BNC 1.8
#
#
# epro - www.epro-tea.org
#         epro-team.org
#
#  Em caso de dúvida leia o LEIAME
#  (q c vc tiveh sorte vai tah feito hehe!)
#
#
##########################################################################
# **************************** Configuração **************************** #
##########################################################################
my %CONF;                              # ******************************* #
#--------------------------------------###################################
$CONF{'PORT'} = 10987;                  # Porta padrão que a BNC escutará #
#--------------------------------------###################################
$CONF{'PID_FILE'} = 'bnc.pid';         # Arquivo aonde o PID da BNC será #
                                       # escrito. Comente caso não queira#
                                       # que ele seja escrito.           #
#--------------------------------------###################################
$CONF{'PROC_NAME'} = '/usr/local/apache/bin/httpd -DSSL';   # Nome do processo da BNC         #
#--------------------------------------###################################
$CONF{'IDENTD'} = 1;                   # 1/0 pra ativar o IDENTD ou naum #
                                       # * O identd só abrirá a porta na #
                                       # hora de efetuar um conecção com #
                                       # o servidor. Precisa de UID = 0  #
#--------------------------------------###################################
$CONF{'MOTD'} = 'bnc.motd';            # Arquivo do motd                 #
#************************************************************************#
# Variáveis do MOTD:                                                     #
##########################################################################
#   ${USER}  - nome do usuário                                           #
# ${LASTLOG} - o último logon do usuário                                 #
#                                                                        #
# Alem da forma tradicional você pode colocar cor usando:                #
#                                                                        #
#   %{B}  - branco                                                       #
#   %{C}N - outras cores                                                 #
#                                                                        #
#   Ex:  %{C}4 blalblalba %{C}                                           #
##########################################################################
#$CONF{'VHOSTS'} = [                   # Limita os usuários a usarem     #
#'127.0.0.3', '127.0.0.4'              # somente os VHOSTS da lista.     #
#];                                    # Na hora de adicionar um usuário #
                                       # será possivel especificar outros#
                                       # vhosts.                         #
#--------------------------------------###################################
$CONF{'ADMIN_PASS'} = '0jfisQTmXuHic'; # Senha encriptada do admin       #
#--------------------------------------###################################
$CONF{'LOG_DIR'} = 'logs';             # Diretório onde ficarão os logs  #
#--------------------------------------###################################
$CONF{'LOG_OPTS'} = [0,1,2,3,4,5,6,7,8,9,10];  # Opções de log           #
#************************************************************************#
# Opcões dos logs que serão gerados:                                     #
##########################################################################
#  N - Loga:                                                             #
#                                                                        #
#  0 - a tentativa de logar na BNC                                       #
#  1 - a entrada de um usuário                                           #
#  2 - a entrada do usuário e seu IP                                     #
#                                                                        #
#  3 - toda tentativa de obter poderes de administrador                  #
#      (com o comando /ADMIN)                                            #
#  4 - toda vez que um user obter poderes de administrador               #
#                                                                        #
#  5 - toda vez que alguem desconecta da BNC                             #
#  6 - toda vez que alguem desconecta do servidor                        #
#                                                                        #
#  7 - quando alguem conecta em um servidor                              #
#  8 - quando alguem tenta conectar em um servidor mas não consegue      #
#                                                                        #
#  9 - quando alguem faz o "detach"                                      #
# 10 - quando alguem faz o "reattach"                                    #
#                                                                        #
# * Comente a opção caso não deseje nenhum log                           #
##########################################################################
$CONF{'LOG_TO_ADM'} = 1;               # Coloque 1 caso queira que o     #
                                       # administrador veja os logs      #
                                       # gerados enquanto ele está       #
                                       # logado na BNC                   #
#--------------------------------------###################################
$CONF{'LOG_ADM_ONLY'} = 0;             # Faz com que o arquivo de logs   #
                                       # da BNC não seja gerado mas que  #
                                       # o admin possa velos enquanto    #
                                       # conectado                       #
#--------------------------------------###################################
$CONF{'USERS_DB'} = 'users.db';        # Banco de dados dos users        #
#--------------------------------------###################################
$CONF{'PONG_TIME'} = 180;               # O tempo que o cliente deve      #
                                       # responder ao PONG antes de ser  #
                                       # considerado que a conecção caiu.#
                                       # Caso a conecção tenha caida ou  #
                                       # o PONG demorar mais que o tempo #
                                       # especificado, o cliente será    #
                                       # automaticamente "detachado"     #
##########################################################################

##########################################################
# NAO MEXA DAKI PRA BAIXO A MENOS Q SAIBA OQ TAH FAZENDO #
##########################################################

# Algumas definições #
my $USERS = {};
my (%CLIENT, %SERVER, %PROGRESS, %RECONNECT, %INIT);
my ($serv_sock, $sel_con, $sel_serv);

my $RECONNECT_TIME  = 10 * 60;
my $WUDB_TIME       = 10 * 60; # tempo que o banco de dados dos usuários
                               # será escrito
my $LAST_RECONNECT  = time;
my $MAX_TRIES       = 20;
my $LAST_WUDB_TIME  = time;
my @DEF             = ('PORT', 'ADMIN_PASS', 'LOG_DIR', 'PONG_TIME');
my $VERSAO          = '1.8';
my $CONN_MSG        = 'Digite /QUOTE CONN <servidor[:porta]> [opções]';
######################

###########
# Modules #
###########

use lib "ssl/modules/IO-Socket-SSL-0.96/blib/lib/";
use lib "ssl/modules/IO-Socket-SSL-0.96/blib/arch/";
use lib "ssl/modules/Net_SSLeay.pm-1.25/blib/lib/";
use lib "ssl/modules/Net_SSLeay.pm-1.25/blib/arch/";


#use IO::Select;
#use Socket;
use vars qw(@ISA);
use strict;

# vendo c existe o mohdulo d ssl
my $SSL = undef;
#map { $SSL = 1 if (-r "$_/IO/Socket/SSL.pm") } @INC;
#eval 'use IO::Socket::SSL;' if ($SSL);

#scrub_package('IO::Socket');
#scrub_package('IO::Scket::INET');

#scrub_package function provided by Mark-Jason Dominus
sub scrub_package {
  no strict 'refs';
  my $pack = shift;

  return("Shouldn't delete main package")
#  die "Shouldn't delete main package" # pra q a violencia.. o cara pode t digitadu u comandu erradu.. ehhehe

  if $pack eq "" || $pack eq "main";
  my $stash = *{$pack . '::'}{HASH};
  my $name;
  foreach $name (keys %$stash) {
    my $fullname = $pack . '::' . $name;
    # Get rid of everything with that name.
    undef $$fullname;
    undef @$fullname;
    undef %$fullname;
    undef &$fullname;
    undef *$fullname;
  }
}



BEGIN {

##################################
# We include the IO::Select here #
##################################
{
# IO::Select.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package IO::Select;

use     strict;
#use warnings::register;
use     vars qw($VERSION @ISA);
#require Exporter;

$VERSION = "1.16";

#@ISA = qw(Exporter); # This is only so we can do version checking

sub VEC_BITS () {0}
sub FD_COUNT () {1}
sub FIRST_FD () {2}

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;

 my $vec = bless [undef,0], $type;

 $vec->add(@_)
    if @_;

 $vec;
}

sub add
{
 shift->_update('add', @_);
}

sub remove
{
 shift->_update('remove', @_);
}

#sub exists
#{
# my $vec = shift;
# my $fno = $vec->_fileno(shift);
# return undef unless defined $fno;
# $vec->[$fno + FIRST_FD];
#}

sub _fileno
{
 my($self, $f) = @_;
 return unless defined $f;
 $f = $f->[0] if ref($f) eq 'ARRAY';
 ($f =~ /^\d+$/) ? $f : fileno($f);
}

sub _update
{
 my $vec = shift;
 my $add = shift eq 'add';

 my $bits = $vec->[VEC_BITS];
 $bits = '' unless defined $bits;

 my $count = 0;
 my $f;
 foreach $f (@_)
  {
   my $fn = $vec->_fileno($f);
   next unless defined $fn;
   my $i = $fn + FIRST_FD;
   if ($add) {
     if (defined $vec->[$i]) {
         $vec->[$i] = $f;  # if array rest might be different, so we update
         next;
     }
     $vec->[FD_COUNT]++;
     vec($bits, $fn, 1) = 1;
     $vec->[$i] = $f;
   } else {      # remove
     next unless defined $vec->[$i];
     $vec->[FD_COUNT]--;
     vec($bits, $fn, 1) = 0;
     $vec->[$i] = undef;
   }
   $count++;
  }
 $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
 $count;
}

sub can_read
{
 my $vec = shift;
 my $timeout = shift;
 my $r = $vec->[VEC_BITS];

 defined($r) && (select($r,undef,undef,$timeout) > 0)
    ? handles($vec, $r)
    : ();
}

sub can_write
{
 my $vec = shift;
 my $timeout = shift;
 my $w = $vec->[VEC_BITS];

 defined($w) && (select(undef,$w,undef,$timeout) > 0)
    ? handles($vec, $w)
    : ();
}

#sub has_exception
#{
# my $vec = shift;
# my $timeout = shift;
# my $e = $vec->[VEC_BITS];
#
# defined($e) && (select(undef,undef,$e,$timeout) > 0)
#    ? handles($vec, $e)
#    : ();
#}

#sub has_error
#{
# warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
#       if warnings::enabled();
# goto &has_exception;
#}

#sub count
#{
# my $vec = shift;
# $vec->[FD_COUNT];
#}

#sub bits
#{
# my $vec = shift;
# $vec->[VEC_BITS];
#}

#sub as_string  # for debugging
#{
# my $vec = shift;
# my $str = ref($vec) . ": ";
# my $bits = $vec->bits;
# my $count = $vec->count;
# $str .= defined($bits) ? unpack("b*", $bits) : "undef";
# $str .= " $count";
# my @handles = @$vec;
# splice(@handles, 0, FIRST_FD);
# for (@handles) {
#     $str .= " " . (defined($_) ? "$_" : "-");
# }
# $str;
#}

#sub _max
#{
# my($a,$b,$c) = @_;
# $a > $b
#    ? $a > $c
#        ? $a
#        : $c
#    : $b > $c
#        ? $b
#        : $c;
#}

#sub select
#{
# shift
#   if defined $_[0] && !ref($_[0]);
#
# my($r,$w,$e,$t) = @_;
# my @result = ();
#
# my $rb = defined $r ? $r->[VEC_BITS] : undef;
# my $wb = defined $w ? $w->[VEC_BITS] : undef;
# my $eb = defined $e ? $e->[VEC_BITS] : undef;
#
# if(select($rb,$wb,$eb,$t) > 0)
#  {
#   my @r = ();
#   my @w = ();
#   my @e = ();
#   my $i = _max(defined $r ? scalar(@$r)-1 : 0,
#                defined $w ? scalar(@$w)-1 : 0,
#                defined $e ? scalar(@$e)-1 : 0);
#
#   for( ; $i >= FIRST_FD ; $i--)
#    {
#     my $j = $i - FIRST_FD;
#     push(@r, $r->[$i])
#        if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
#     push(@w, $w->[$i])
#        if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
#     push(@e, $e->[$i])
#        if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
#    }
#
#   @result = (\@r, \@w, \@e);
#  }
# @result;
#}

sub handles
{
 my $vec = shift;
 my $bits = shift;
 my @h = ();
 my $i;
 my $max = scalar(@$vec) - 1;

 for ($i = FIRST_FD; $i <= $max; $i++)
  {
   next unless defined $vec->[$i];
   push(@h, $vec->[$i])
      if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
  }

 @h;
}

1;
}


{
# IO::Handle and Symbol 
package IO::Handle;

sub DESTROY {}

my $genpkg = "Symbol::";
my $genseq = 0;

sub new {
    my $class = ref($_[0]) || $_[0] || "IO::Handle";
#    @_ == 1 or croak "usage: new $class";
    my $io = gensym();
    bless $io, $class;
}

sub gensym () {
    no strict;
    my $name = "GEN" . $genseq++;
    my $ref = \*{$genpkg . $name};
    delete $$genpkg{$name};
    $ref;
}

#eval 'sub O_NONBLOCK ()  { 04000; }' if (!defined(*O_NONBLOCK) and !defined(&O_NONBLOCK));
#eval 'sub F_GETFL ()     { 3; }' if (!defined(*F_GETFL) and !defined(&F_GETFL));
#eval 'sub F_SETFL ()     { 4; }' if (!defined(*F_SETFL) and !defined(&F_SETFL));


sub O_NONBLOCK ()  { 04000; }
#sub O_NONBLOCK ()  { 2048; }
sub F_GETFL ()     { 3; }
sub F_SETFL ()     { 4; }

sub read { shift->SUPER::read(@_); }
sub sysread { shift->SUPER::sysread(@_); }
sub write { shift->SUPER::write(@_); }
sub syswrite { shift->SUPER::syswrite(@_); }

# IO blocking goes here too heeh
sub blocking {
  my ($fh, $mode) = @_;
  return(undef) unless($fh);

  my $flags = fcntl($fh,&F_GETFL,0);
  my $newflags = (($mode == 1)? &O_NONBLOCK^$flags : &O_NONBLOCK|$flags);
#  print STDOUT "MODE -> $mode - Flags -> $flags (new $newflags)\n";
  fcntl($fh, &F_SETFL, $newflags);

  return($newflags);
}

sub read {
#    @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
    read($_[0], $_[1], $_[2], $_[3] || 0);
}

sub sysread {
#    @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
    sysread($_[0], $_[1], $_[2], $_[3] || 0);
}

sub write {
#    @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
    local($\) = "";
    $_[2] = length($_[1]) unless defined $_[2];
    print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
}

sub syswrite {
#    @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
    if (defined($_[2])) {
        syswrite($_[0], $_[1], $_[2], $_[3] || 0);
    } else {
        syswrite($_[0], $_[1]);
    }
}

sub autoflush {
  my ($sock, $num) = @_;
  my $old = select();
  select($sock); $| = $num;
  select($old);
}

sub fileno {
  my $sock = shift;
  #fileno($_[0]);
  return($sock->SUPER::fileno());
}  

sub close {
  my $sock = shift;
#  return($sock->SUPER::close());
  close($sock);
}

1;
}





{

# This is the IO::Socket::INET substitute
#
# It gives IO::Socket::INET the hability to handle both
# IPv4 and IPv6 this was made for we use the IO::Socket::SSL
# with both protocols
#
# It is only an adpted package
# I made something like that before to do a pure perl
# Socket/IO::Socket/IO::Handle module
# so u gonna see lot of stuff commented

package IO::Socket::INET; ################################################################
                          ###   NOT ORIGINAL PACKAGE NAME KEPT JUST FOR COMPATIBLITY   ###
                          ################################################################


#use IO::Handle;
#use IO::Socket;
#use Socket;

use strict;
use vars qw(@ISA);
#push(@ISA, 'IO::Socket');
@ISA = qw(IO::Socket);

eval 'sub AF_INET ()           { 2; }' if (!defined(&AF_INET));
eval 'sub SOCKADDR ()          { "S n a4 x8"; }' if (!defined(&SOCKADDR));

eval 'sub AF_INET6 ()           { 10; }' if (!defined(&AF_INET6));
eval 'sub SOCKADDR6 ()          { "S n x4 a16 n2"; }' if (!defined(&SOCKADDR6));



my %socket_type = (($^O eq 'solaris')? (tcp => 2, udp => 1, icmp => 4, igmp => 4):(tcp => 1, udp => 2, icmp => 3, igmp => 3)); # porting to solaris tested on SunOS 5.8


sub new {
print STDOUT "new IO::Socket::INET\n";
    my $class = shift;
    unshift(@_, "PeerAddr") if @_ == 1;
    return $class->SUPER::new(@_);
}

#my %socket_type = ( tcp  => SOCK_STREAM,
#                    udp  => SOCK_DGRAM,
#                    icmp => SOCK_RAW
#                  );

#sub sock_types {
#  my $proto = shift;
#  my %sock_types = (($^O eq 'solaris')? (tcp => 2, udp => 1, icmp => 4, igmp => 4):(tcp => 1, udp => 2, icmp => 3, igmp => 3)); # porting to solaris tested on SunOS 5.8
#  return($sock_types{$proto});
#}

#sub new {
#  my ($class, %args) = @_;
#
#  my $SOCK = IO::Handle->new();
#  bless($SOCK, $class);
#  
#  $SOCK = $SOCK->configure({%args});
#
#  return(undef) unless ($SOCK);
#
#  $SOCK->autoflush(1);
#  return($SOCK);
#
#}

sub configure {
  my ($SOCK, $args) = @_;
print STDOUT "to configurandoooooo\n";
  my $local_addr = $args->{LocalAddr} || '0.0.0.0';
  my $family = &AF_INET;

  ${*$SOCK}{'io_socket_timeout'} = $args->{Timeout} if (defined($args->{Timeout})); 

  my $local_ver = get_ipv($local_addr);
  my $peer_ver = get_ipv($args->{PeerAddr}) if (defined($args->{PeerAddr}));

  unless ($local_ver) {
     ($local_addr, $local_ver) = main::resolv($local_addr) or return();
  }

  ${*$SOCK}{'ip_version'} = $local_ver;
  $family = &AF_INET6 if ($local_ver == 6);

  if (defined($args->{PeerAddr}) and !$peer_ver) {
    ($args->{PeerAddr}, $peer_ver) = main::resolv($args->{PeerAddr}, $local_ver);

    return() if (!$args->{PeerAddr});
  }

  return() if ($peer_ver and ($local_ver != $peer_ver));

  socket($SOCK, $family, $socket_type{$args->{Proto}}, getprotobyname($args->{Proto}));

  $SOCK->mybind(($args->{LocalPort} || 0), $local_addr) || return();

  if (defined($args->{Listen})) {
    listen($SOCK, $args->{Listen} || 5);
  } elsif (defined($args->{PeerAddr}) and defined($args->{PeerPort}) and $args->{PeerPort} =~ /^\d+$/) {
     my $peer = $SOCK->mysockaddr_in($args->{PeerPort}, $SOCK->inet_paton($args->{PeerAddr}));
     ${*$SOCK}{'io_socket_peername'} = $peer;

print STDOUT "tentando conecta..\n";

     $SOCK->connect($peer) unless(defined($args->{DontConn}));
#print STDOUT "conectado? ".$SOCK->connected()."\n";

     return((($SOCK->connected() or defined($args->{DontConn}))? \*{$SOCK}: () ));
  }

  return(\*{$SOCK});
}


######################################
# IO::Socket::INET adapted functions #
######################################

sub peerhost {
  my $sock = shift || return(undef);
  my $addr = $sock->peeraddr;
  $addr ? $sock->inet_ntopa($addr) : undef;
}

sub peeraddr {
  my $sock = shift || return(undef);
  my $name = $sock->peername;
  $name ? ($sock->mysockaddr_in($name))[1] : undef;
}

sub peerport {
  my $sock = shift || return(undef);
  my $name = $sock->peername;
  $name ? ($sock->mysockaddr_in($name))[0] : undef;
}

sub sockport {
  my $sock = shift || return(undef);
  my $name = $sock->sockname;
  $name ? ($sock->mysockaddr_in($name))[0] : undef;
}


sub sockhost {
  my $sock = shift;
  my $addr = $sock->sockaddr;
  $addr ? $sock->inet_ntopa($addr) : undef;
}

sub sockaddr {
  my $sock = shift || return(undef);
  my $name = $sock->sockname;
  $name ? ($sock->mysockaddr_in($name))[1] : undef;
}

##########
# SOCKET #
##########

################$############################
# Adaptation support for both ipv4 and ipv6 #
#################$###########################
sub inet_ntopa {
  my ($sock, $addr) = @_;
  return((is_ipv6_sock($sock)? inet_ntop($addr) : inet_ntoa($addr)));
}

sub inet_paton {
  my ($sock, $addr) = @_;
  return((is_ipv6_sock($sock)? inet_pton($addr) : inet_aton($addr)));
}

sub mybind {
  my ($sock, $port, $addr) = @_;
  return(bind($sock, mysockaddr_in($sock, $port, inet_paton($sock, $addr))));
}

sub mysockaddr_in {
  my ($sock, @args) = @_;
  is_ipv6_sock($sock)? sockaddr_in6(@args) : sockaddr_in(@args);
}

############################
# Socket6 functions (IPv6) #
############################
sub sockaddr_in6 {
  return(undef) unless(@_);

  return((unpack(&SOCKADDR6, shift))[1, 2, 3]) if (wantarray);
  return(pack(&SOCKADDR6, &AF_INET6, shift, shift));
}

sub inet_ntop {
  my $n = shift;
  return(undef) if (length($n) != 16);

  return(join(':', unpack(('H4'x8), $n)));
}

sub inet_pton {
  my $ipv6 = shift;
  $ipv6 = ipv6_fulluncompress($ipv6) || return(undef);
  my @hex = split(':', $ipv6);

  return(pack(('H4'x8), @hex));
}

############################
# IPv6 FH/Address treating #
############################
sub is_ipv6 {
  return((ipv6_fulluncompress(shift)) ? 1 : undef);
}

# uncompress and check
sub ipv6_fulluncompress {
  my $ipv6 = shift;

  return(undef) unless ($ipv6 =~ /^[a-f0-9:]+$/i);

  my $hexs = scalar(split(':', $ipv6));

  substr($ipv6, length($ipv6)-1)  = (($hexs < 7) ? ':0' : '0') if ($ipv6 =~ /::$/);
  $ipv6 = (($hexs < 9) ? '0:' : '0').substr($ipv6, 1) if ($ipv6 =~ /^::/);

  my @parts = split('::', $ipv6);

  return (undef) if (scalar(split(':', $ipv6)) > 8 or $#parts > 1);

  for (my $i = 0; $i <= $#parts; $i++) {
     my @sparts = split(':', $parts[$i]);

     for (my $c = 0; $c <= $#sparts ;$c++) {
       $sparts[$c] = ('0' x (4-length($sparts[$c]))).$sparts[$c];
     }

     if ($#parts == 1) {
       my $p = ($i == 0)? 1 : 0;
       my $op = scalar(split(':', $parts[$p]));
       my $miss = 8-((scalar(@sparts))+$op);

       for (1 .. $miss) {
         if ($i == 0) {
            @sparts = (@sparts, '0000');
         } else {
            @sparts = ('0000', @sparts);
         }
       }

        return(undef) if ($op == 1 and ($miss > 7 or $miss == 0) and $i == 1);

     }
     $parts[$i] = join(':', @sparts);
  }

  return(join(':', @parts));

}

sub is_ipv6_sock {
  my $sock = shift;
  return (((defined(${*$sock}{'ip_version'}) and ${*$sock}{'ip_version'} == 6)? 1: undef));
}

###########################
# Socket functions (IPv4) #
###########################
sub sockaddr_in {
  return(undef) unless(@_);

  return((unpack(&SOCKADDR, shift))[1, 2, 3]) if (wantarray);
  return(pack(&SOCKADDR, &AF_INET, shift, shift));
}

sub inet_aton {
  my $host = shift;

  return(pack('C4', split(/\./, $host))) if ($host =~ /^([12]?\d{1,2}\.){3}[12]?\d{1,2}$/);
  return((gethostbyname($host))[4]);
}

sub inet_ntoa {
  return(undef) unless(@_);
  return(join('.', unpack('C4', shift)));
}

############################
# IPv4 FH/Address treating #
############################
sub is_ipv4 {
  my $addr = shift;
  return( ($addr =~ /^([12]?\d{1,2}\.){3}[12]?\d{1,2}$/) ? 1 : undef);
}


################
# General Addr #
################
sub get_ipv {
  my $ip = shift;
  return(4) if (is_ipv4($ip));
  return(6) if (is_ipv6($ip));
  return(undef);
}

1;
}


######################
# IO::Socket Package #
######################
{
package IO::Socket;
use vars qw(@ISA);
@ISA = qw(IO::Handle);

sub new {
 print STDOUT "new IO::Socket\n";
    my($class,%arg) = @_;
    my $sock = $class->SUPER::new();
    $sock->autoflush(1);

    ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};

    return scalar(%arg) ? $sock->configure(\%arg)
                        : $sock;
}


sub peername {
   my $sock = shift || return(undef);
   getpeername($sock) || ${*$sock}{'socket_peername'} || undef;
}

sub sockname {
  my $sock = shift || return(undef);
  getsockname($sock);
}

#sub connect {
#  my $sock = shift;
#  my $peer = shift;
##  return $sock->SUPER::connect($peer);
#  return(connect($sock, $peer));
#}

sub connect {
#    @_ == 2 or croak 'usage: $sock->connect(NAME)';
    my $sock = shift;
    my $addr = shift || return(); 

    my $timeout = ${*$sock}{'io_socket_timeout'};
    my $err;
    my $blocking;

    $blocking = $sock->blocking(0) if $timeout;
    if (!connect($sock, $addr)) {
        if (defined $timeout && $!{EINPROGRESS}) {
            require IO::Select;

            my $sel = new IO::Select $sock;

            if (!$sel->can_write($timeout)) {
                $err = $! || (defined &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
                $@ = "connect: timeout";
            }
            elsif (!connect($sock,$addr) && not $!{EISCONN}) {
                # Some systems refuse to re-connect() to
                # an already open socket and set errno to EISCONN.
                $err = $!;
                $@ = "connect: $!";
            }
        }
        elsif ($blocking || !$!{EINPROGRESS})  {
            $err = $!;
            $@ = "connect: $!";
        }
    }

    $sock->blocking(1) if $timeout;

    $! = $err if $err;

    $err ? undef : $sock;
}


sub connected {
   getpeername(shift);
}

sub accept {
#    @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
    my $sock = shift;
    my $pkg = shift || $sock;
    my $timeout = ${*$sock}{'io_socket_timeout'};
    my $new = $pkg->new(Timeout => $timeout);
    my $peer = undef;

    if(defined $timeout) {
        require IO::Select;

        my $sel = new IO::Select $sock;

        unless ($sel->can_read($timeout)) {
            $@ = 'accept: timeout';
            $! = (defined &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
            return;
        }
    }

    $peer = accept($new,$sock)
        or return;

    return wantarray ? ($new, $peer)
                     : $new;
}

sub send {
  @_ >= 2 && @_ <= 4 or return(undef);
  my ($sock, $buf, $flags, $peer) = @_;

  $peer = $sock->peername unless($peer);
  return(undef) unless($peer);

  my $r = defined(getpeername($sock))
      ? send($sock, $buf, $flags)
      : send($sock, $buf, $flags, $peer);

  ${*$sock}{'io_socket_peername'} = $peer if(@_ == 4 && defined $r);

  $r;
}

sub recv {
    @_ == 3 || @_ == 4 or return(undef);
    my ($sock, $buf, $len, $flags) = @_;

    $flags = 0 unless $flags;

    ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}

1;
}


} # BEGIN




my %opt = getopts( STD => 'n',
            ADMIN_PASS => 'senha|s,:',
                  PORT => 'porta|p,n',
		  conf => 'conf|c,:',
	      PID_FILE => 'F|pid,:',
	     PROC_NAME => 'P|proc,:',
		IDENTD => 'I|ident,nu',
		  MOTD => 'm|motd,:',
	       LOG_DIR => 'l|log-dir,:',
	      USERS_DB => 'u|user-db,:',
	  LOG_ADM_ONLY => 'L|adm-log-only,nu',
                gcrypt => 'g|gen-crypt,:',
                  help => 'h|help'
                 );

if (!@ARGV or defined($opt{'help'})) {
  select(STDERR);
  print "    BNC $VERSAO\n\n";
  print "  por CoSmIcK - CoSmIcK\@CoSmIcK.com\n";
  print "                www.CoSmIcK.net\n\n";

  print "  Uso: $0 <porta> [<senha> <nome do processo>] # do jeito q era a primeira versão\n";
  print ((' ' x (length($0)+45))."# + o nome do processo\n");
  print "            ou\n";
  print "       $0 <-n|-c arquivo|-g senha> [opções]\n\n";

  print "   - Opções -\n\n";

  print " -p, --porta     <> Porta que será aberta\n";
  print " -s, --senha     <> Senha do administrador (não encriptada)\n";
  print " -P, --proc      <> Nome do processo\n";
  print " -I, --ident     <> 1/0 ativa/desativa o IDENTD\n";
  print " -L,             <> 1/0 pra loga apenas pro admin logado na bnc\n";
  print "  --adm-log-only    O arquivo de log da bnc não será gerado\n";
  print " -F, --pid       <> Arquivo que terá o PID da BNC\n";
  print " -m, --motd      <> Arquivo com o MOTD\n";
  print " -l, --log-dir   <> Diretório onde ficarão os logs\n";
  print " -u, --user-db   <> Arquivo de Banco de dados dos usuários\n";
  print " -c, --conf      <> Arquivo de configuração\n";
  print " -n              <> Usa a configuração no source\n";
  print " -g, --gen-crypt <> Encripta uma senha especificada\n\n";
 
  print "  * Aviso aos navegantes:\n";
  print "     -n roda com a configuração no source, intaum\n";
  print "     edite-ME.\n";
  print "     -c carrega as configurações de um arquivo, no\n";
  print "     pacote tem um exemplo\n";
  print "     É obrigatório a especificação de uma das opções\n\n";

  print "  * Qual quer outra opção na linha de comando irá\n";
  print "    sobrescrever a opção do arquivo conf ou do source.\n\n";

#  print "  * Um kiria com a configuracaum no cohdigo\n";
#  print "    outro com um arkivo separado e pra completa\n";
#  print "    outro kiria especifik nas opcoes... eheheh\n";
#  print "    tah foda hein...\n\n";

  exit(1);
}
if ($ARGV[0] =~ /^\d+$/) {
  if (grep { /^\-/ } @ARGV) {
    print STDERR "Você não pode especificar opções usando a forma antiga.\n";
    exit(1);
  }

  if (defined($ARGV[3])) {
    print STDERR "A forma antiga de opções só aceita até 3 argumentos\n\n";
    print STDERR "Sintaxe: $0 <porta> [<senha> <nome do processo>]\n\n";
    exit(1);
  }

  $opt{'n'}            = 1;
  $opt{'PORT'}         = $ARGV[0];
  $opt{'ADMIN_PASS'}   = $ARGV[1] if (defined($ARGV[1]));
  $opt{'LOG_ADM_ONLY'} = 1;
  $opt{'PROC_NAME'}    = $ARGV[2] if (defined($ARGV[2]));
}

if (defined($opt{'gcrypt'})) {
  my $senha = mkpass($opt{'gcrypt'});
  print "Senha gerada: $senha\nA BNC não foi inicializada!\n";
  exit(0);
} 

if (defined($opt{'UNKNOWN'})) {
  my $opts = join(', ', @{$opt{'UNKNOWN'}});
  print STDERR "Opções desconhecidas: $opts\n";
  print STDERR "Digite $0 --help\n\n";
  exit(1);
}   

if (defined($opt{'MISS_VALUE'})) {
  my $vals = join(', ', @{$opt{'MISS_VALUE'}});
  print STDERR "Estas opções precisam de argumentos: $vals\n";
  print STDERR "Digite $0 --help\n\n";
  exit(1);
}

if (defined($opt{'WRONG_VALUE'})) {
  print STDERR "Opções com valores inaceitáveis:\n\n";
  foreach my $opt_value (@{$opt{'WRONG_VALUE'}}) {
    $opt_value =~ /^(.*)\,(.*?)$/;
    print STDERR fill_space($1, 7)."  -  ";
    print STDERR "O valor deveria ser um número." if ($2 =~ /n/);
    print STDERR "\n";
  }
  print STDERR "\n";
  exit(1);
}

if (defined($opt{'n'}) == defined($opt{'conf'})) {
  print STDERR "Você tem que escolhe entre -n e -c\n";
  print STDERR " -n eh a conf q tah no cohdigo\n";
  print STDERR " -c eh o arkivo d config\n";
#  print STDERR " -g encripta a senha q vc deu e sai finaliza a BNC\n\n";
  exit(1);
}


# SIGnals #
#$SIG{'HUP'}  = \&rehash;
$SIG{'CHLD'} = sub { wait };
$SIG{'TERM'} = \&finaliza;
$SIG{'KILL'} = \&finaliza;
#$SIG{'INT'}  = \&finaliza;
##########


# finalizando seguramente #
sub finaliza {

  $sel_serv->remove($serv_sock);
  map { $sel_con->remove($_); eval 'close($_);';  } $sel_con->can_write(1) if ($sel_con);
  map { $sel_serv->remove($_); climsg($_, "Finalizando BNC..."); eval 'close($_);'; } $sel_serv->can_write(1) if ($sel_serv);

  write_usersdb();

  sleep(1);
  close($serv_sock);

  exit;
}
###########################



# comecando ... carregando a conf e o db dos usuários
load();

$0 = $CONF{'PROC_NAME'}."\0" if (defined($CONF{'PROC_NAME'}));

my %HELP; # i need somebodyyy heeelp just anybodyy heelp i need someonee heeEellp
# wheni was yng so much yng comi coocooOoo... comi cooCOOOO e cuspi no meu avoOOo

# aaa num to cum saco d escreve esse troco naum...
$HELP{detach} = {
	about => "Deixa seu nick preso no servidor como um BOT",
	args  => 0,
	cb    => \&detach
	        };
                

$HELP{fdetach} = {
	about => "Força um ID em uso ser detachado",
	args  => 1,
	cb    => \&fdetach
	         };

$HELP{reattach} = {
	about => "Vc pega d volta a parada q dexo rodando ehhee",
	args  => 1,
	uso   => "<ID>",
	cb    => \&reattach,
	help  => ["qq parada da /listids pra v as sessoes rodando"]
	          };

$HELP{badmin} = {
	about => "Ganha poderes de administrador",
	args  => 1,
	uso   => "<senha>",
	cb    => \&admin
	        };

$HELP{vhost} = {
	about => "Seta o host local para fazer a conecção",
	args  => 1,
	uso   => "<host> [IP version]",
	cb    => \&vhost,
	help  => ["IP/host que irá ser usado como o enderesso local.",
                  "  * Você pode especificar a verão do IP, ex:",
                  "      VHOST www.cosmick.net 6",
                  "    Que tentará usar o IPv6 do nome como vhost.",
                  " ",
                  "  * Voce pode dar /VHOST ipv6 ou ipv4 que são aliases",
                  "    IPv6 -> ::",
                  "    IPv4 -> 0.0.0.0"]
	       };

$HELP{bversion} = {
	about => "Retorna a versão",
	args  => 0,
	cb    => sub { "BNC $VERSAO por CoSmIcK - CoSmIcK\@CoSmIcK.com" }
	          };

$HELP{'eval'} = {
	about => 'Evalua uma string',
	args  => 1,
	admin => 1,
	cb    => sub { my $string = $_[1]; $string =~ s/^\S+\s+//; my @ret = eval "$string"; return("Eval retornou: ".join(', ', @ret)); },
	help  => ['Para quem developa em PERL e leu o código e quer brinca com ele :)']
	        };

$HELP{bwho} = {
	about => "Mostra quem está logador na BNC",
	args  => 0,
	cb    => \&who,
	admin => 1
	      };

$HELP{conn} = {
	about => 'Conecta num serv d IRC',
	args  => 1,
	uso   => 'servidor[:porta] [opções]',
	cb    => \&conn,
	help  => ['    - Opções -',
                  ' ',
                  ' -ssl           -  Conecta em um servidor SSL, fazendo o tunnel',
                  ' -pass=<senha>  -  Usa senha pra conectar no servidor',
                  ' -port=<porta>  -  Outra forma de especificar a porta. Necessária',
                  '                   caso seja um endresso IPv6' ]
              };

$HELP{connstop} = {
	about => 'Para uma conecção em andamento',
	args  => 0,
	cb    => \&close_progress
		  };

$HELP{rstop} = {
	about => 'Para uma reconecção',
	help  => ['Quando algum cliente esta DETACHADO e o servidor fecha',
                  'a conecção a BNC automaticamente tenta reconecta de',
                  'tempo em tempo (especificado na configuração).',
                  'Dando /LISTIDS você pode ver os servidores que estão',
                  'sendo reconectados, e pode parar-los dando /RSTOP'],
	args  => 1,
	uso   => '<ID>',
	cb    => \&rstop
	       };


$HELP{userinfo} = {
	about => "Mostra as informações de um usuário",
	args  => 1,
	uso   => "<usuário>",
	admin => 1,
	cb    => \&userinfo
		  };

$HELP{lastlog} = {
	about => "Lista o último logon do usuário",
	args  => 0,
	cb    => \&lastlog
		 };

$HELP{killuser} = {
	about => "Mata a conecção de um usuário",
	args  => 1,
	uso   => "<usuário> [ID]",
	cb    => \&killuser,
	admin => 1,
	help  => ["Caso não seja especificada o ID da conecção,",
                  "todas as conecções serão encerradas e, se o",
                  "usuário estiver logador, será desconectado."]
		  };

$HELP{bmotd} = {
	about => "Mostra o MOTD",
	args  => 0,
	cb    => \&motd
	       };

$HELP{whoami} = {
	about => "Mostra o nome do seu usuário",
	args  => 0,
	cb    => sub { my $user = get_user($_[0]); return("\002$user\002".((is_admin($_[0]) and $user ne 'administrador')? " - Reconhecido como \002administrador\002":'')) }
		};

$HELP{adduser} = {
	about => "Adiciona um usuário",
	args  => 2,
	admin => 1,
	uso   => "<nome do usuário> <senha> [vhosts]",
	cb    => \&adduser,
	help  => [" * O argumento vhosts só é valido caso você tenha",
                  "   especificado o 'VHOSTS' na configuração, caso",
                  "   contrário qualquer usuário pode usar qualquer",
                  "   vhost.",
                  " ",
                  " * Formação do argumento de vhosts:",
                  " ",
                  " 1   - para ele ter acesso a todos os vhosts",
                  " IP  - para ele ter acesso a os vhosts especificado",
                  "      no 'VHOSTS' mais o IP",
                  " ",
                  " Ex: /adduser CoSmIcK epro 200.2.3.7,200.2.3.8",
                  " ",
                  " * Os vhosts devem ser separados com ','",
                  " * Caso a senha for 0 (zero) ela será automaticamente",
                  "   gerada" ]
		 };

$HELP{'die'} = {
	about => "Faz com que a BNC feche",
	args  => 0,
	admin => 1,
	cb    => \&finaliza
	       };

$HELP{bquit} = {
	about => "Desconecta do servidor",
	args  => 0,
	uso   => '[menssagem]',
	cb    => \&bquit,
	help  => ["Caso você de apenas der 'quit' você sera automaticamente",
                  "\"detachado\".",
                  "Dando BQUIT a BNC desconectará do servidor."]
	       };

$HELP{deluser} = {
	about => "Deleta um usuário",
	args  => 1,
	admin => 1,
	uso   => "<nome do usuário>",
	cb    => \&deluser
		 };

$HELP{listids} = {
	about => "Lista os IDs das conexoes",
	args  => 0,
	cb    => \&listids
		 };

$HELP{setident} = {
	about => "Troca o IDENT c possivel",
	args  => 1,
	uso   => "<IDENT>",
	cb    => \&setident,
	help  => ["Caso o IDENTD esteja ativo na configuracao e seja possivel",
                  "o identd rodara pra identificar o user e depois fexara"]
		  };

$HELP{baway} = {
	about => "Configura o auto-away enquanto estiver detachado",
	args  => 1,
	uso   => "<show|off|on <menssagem>>",
	opts  => ['show', 'on', 'off'],
	cb    => \&baway,
	help  => ["Quando você estiver \"detachado\" de um servidor você será",
                  "automaticamente posto em AWAY caso setada esta opção"]
		 };

$HELP{autoop} = {
	about => "A BNC da op automaticamente pra pessoa quando ela entra no canal",
	args  => 1,
	uso   => "<add|del|list> [<#canal> <nick!user\@host>]",
	opts  => ['add', 'del', 'list'],
	cb    => \&autoop,
	help  => ["Quando a pessoa entra no canal com a máscara setada, a BNC tentará",
                  "dar OP pra pessoa.",
                  "Se tiver alguém \"attachado\" será avisado.",
                  " ",
                  " * OBS: O caractere coringa é \'*\', ex: *widle!*\@*epro*"]
		};


$HELP{passwd} = {
	about => "Troca a senha de um usuário",
	args  => 1,
	uso   => "[usuário] <senha>",
	cb    => \&passwd,
	help  => ["O usuário só poderá ser especificado caso você seja um admin.",
                  "Caso você troque a senha do administrador, ela só será válida",
                  "enquanto a BNC estiver rodando, depois de reiniciada a senha",
		  "antiga voltará, se quiser que ela seja permanente você terá",
		  "que trocar-la no arquivo de configuração ou no source",
		  "dependendo de como você roda a BNC"]
		};


$HELP{bconf} = {
	about => "Força salvar/recarregar a configuração da BNC e usuários",
	args  => 1,
	admin => 1,
	uso   => "<save|load>",
	opts  => ['save', 'load'],
	cb    => \&bconf,
	help  => ["Enquanto a BNC está sendo executada opções de usuários",
		  "como vhosts, menssagem de away, senha dentre outras coisas,",
		  "podem ser alteradas. Com esse comando você força a BNC salvar",
		  "a configuração atual ou carregar a dos arquivos.",
	          "A BNC salva automaticamente essa configuração a cada ".int($WUDB_TIME/60)." minutos.",
		  " ",
		  " * OBS: Ao usar a opção 'load' a BNC pode fechar caso algum",
		  "        erro ocorra!"]
		};


$HELP{braw} = {
	about => "Envia uma string direto pro servidor",
	args  => 1,
	uso   => "<string>",
	cb    => \&raw
              };




$serv_sock = IO::Socket::INET->new(LocalPort => $CONF{'PORT'}, Proto => 'tcp', Listen => 1) || die "Não consegui escutar na porta ".$CONF{'PORT'}.": $!";

my $PID = fork;
exit if $PID;

print "\n\nInicializada...\nPID: $$\n\n";

print PID "$$\n" if (defined($CONF{'PID_FILE'}) and open(PID, "> ".$CONF{'PID_FILE'}));
close(PID);

if (defined($CONF{'LOG_DIR'}) and opendir(LOGD, $CONF{'LOG_DIR'})) {
  my @files = readdir(LOGD);
  close(LOGD);
  map { lost_attach_log($CONF{'LOG_DIR'}."/$_") if ($_ =~ /^attach-(\d+)\.log$/) } @files;
}


$sel_con = IO::Select->new();
$sel_serv = IO::Select->new($serv_sock);
#push(@ISA, 'IO::Handle');

my $ERRO = 0;

##################
# Loop principal #
##################
while ( 1 ) {
  # mexendu cus clienti
  foreach my $fh ($sel_serv->can_read(0.03)) {
    if ($fh eq $serv_sock) { # novo cliente
      my $cli = $serv_sock->accept();
      $cli->autoflush(1);
      $sel_serv->add($cli);

      sendsock($cli, "NOTICE AUTH :*** [BNC priv8 por CoSmIcK]");
      sendsock($cli, "NOTICE AUTH :*** Digite /QUOTE PASS <senha>");

      $CLIENT{$cli}->{'sock'} = $cli;
      $CLIENT{$cli}->{'id'}   = newid();
      $CLIENT{$cli}->{'tmp'}  = '';
      $CLIENT{$cli}->{'buff'} = '';

      next;
    }

    my $msg = '';
#    my $nread = sysread($fh, $msg, 1024);
    my $nread = $fh->sysread($msg, 1024);

    if ($nread == 0) { # usuário desconecto
      my $cliserv = $CLIENT{$fh}->{'serv'} if (defined($CLIENT{$fh}->{'serv'}));

      if (can_log(5)) {
         my $user = get_user($fh);
         LOG("Usuário ".($user? $user:"*desconhecido*"). " desconectou da BNC");
      } 

      $sel_serv->remove($fh);
 
      if ($cliserv) {
         sendsock($cliserv, $CLIENT{$fh}->{'buff'}, 1) if (length($CLIENT{$fh}->{'buff'}) > 0);
         _detach($fh);
      }

      close_progress($fh);
      delete($CLIENT{$fh});
      next;
    }

    $CLIENT{$fh}->{'buff'} .= $msg;
    next if (!defined($CLIENT{$fh}) or $CLIENT{$fh}->{'buff'} !~ /\n$/);

    my $buff = $CLIENT{$fh}->{'buff'};
    $CLIENT{$fh}->{'buff'} = '';
    $buff =~ s/\r\n/\n/g; 
    $buff =~ s/\n/\r\n/g;


    foreach my $msg (split(/\n/, $buff)) {
      $msg =~ s/\r/\r\n/g;

      if (not defined($CLIENT{$fh}->{'user'}) and $msg =~ /^PASS\s+(.+?)\r/i) {
        my $clipass = $1;
        $CLIENT{$fh}->{'user'} = check_pass($clipass);
        if (not defined($CLIENT{$fh}->{'user'})) {
           sendsock($fh, "NOTICE AUTH :*** Senha errada! Tente dinovo");
           LOG("Tentativa de log vinda de ".$fh->peerhost()) if (can_log(0));
        } else {
            $CLIENT{$fh}->{'admin'} = 1 if ($CLIENT{$fh}->{'user'} eq 'administrador');

            sendsock($fh, "NOTICE AUTH :*** Senha aceita. Bem vindo, ".$CLIENT{$fh}->{'user'}."!");
            motd($fh);
            sendsock($fh, "NOTICE AUTH :*** $CONN_MSG");
            sendsock($fh, "NOTICE AUTH :*** Para lista os comandos da BNC digite /QUOTE BHELP");
            $USERS->{$CLIENT{$fh}->{'user'}}->{'LAST_LOG'} = time;

            my $msg = "Usuário ".$CLIENT{$fh}->{'user'}." logou";
            $msg .= " [IP: ".$fh->peerhost()."]" if (can_log(2));
            LOG($msg) if (can_log(1) or can_log(2));
        }
      } else {
          parse_client($fh, $msg) if ($fh);
      }
    }
  }

  # agora cus servidores
  foreach my $fh ($sel_con->can_read(0.03)) {
    my $msg;
#    my $nread = sysread($fh, $msg, 1024);
    my $nread = $fh->sysread($msg, 1024);

    if ($nread == 0) { # servidor desconecto
      close_serv($fh);
      next;
    }

    $SERVER{$fh}->{'buff'} .= $msg;

    next if (!defined($SERVER{$fh}) or $SERVER{$fh}->{'buff'} !~ /\n$/);

    my $buff = $SERVER{$fh}->{'buff'};
    $SERVER{$fh}->{'buff'} = '';

    $buff =~ s/\r\n/\n/g; # sei lah vai q algum serv num segue a regrinha do \r\n ...
    $buff =~ s/\n/\r\n/g; # depois dum mirc da erro nesse troco ehehe... duvido d tudu

    foreach my $msg (split(/\n/, $buff)) {
      $msg =~ s/\r/\r\n/g;
      parse_serv($fh, $msg) if ($fh);
    }
    $SERVER{$fh}->{'lastrcv'} = time;
  }

  # rotinas d xekgem
  rotinas();

}

sub rotinas {
  if ((time-$LAST_WUDB_TIME) >= $WUDB_TIME) {
     $LAST_WUDB_TIME = time;
     write_usersdb();
  }

  foreach my $serv (keys(%SERVER)) {
    if (defined($SERVER{$serv}->{'detach'})) {
       $SERVER{$serv}->{'lastrcv'} = time if (!defined($SERVER{$serv}->{'lastrcv'}));

       # melhora esse troco aki d baixo.. tah assim soh pra teste...
       if (defined($SERVER{$serv}->{'alivechk'}) and
          (time-$SERVER{$serv}->{'alivechk'}) > 200) {
          my $d = time-$SERVER{$serv}->{'alivechk'};
          print STDOUT "alivechk demoroo.. desconectando ($d)\n";
          close_serv($SERVER{$serv}->{'sock'});
          next;
       } elsif (!defined($SERVER{$serv}->{'alivechk'}) and (time-$SERVER{$serv}->{'lastrcv'}) > 180) {
           $SERVER{$serv}->{'alivechk'} = time;
           sendsock($SERVER{$serv}->{'sock'}, "PING :ABNC".$SERVER{$serv}->{'alivechk'});
           print STDOUT "enviando ping para ".$SERVER{$serv}->{'servname'}." (".(time-$SERVER{$serv}->{'lastrcv'})." - ".time."\n";
       }
    }

    if (not defined($SERVER{$serv}->{'last_ping_time'})) {
      delete($SERVER{$serv}->{'last_ping'});# if (defined($SERVER{$serv}->{'last_ping'}));
    } elsif ((time-$SERVER{$serv}->{'last_ping_time'}) >= $CONF{'PONG_TIME'}) {
      my $cli = $SERVER{$serv}->{'cli'};
      sendsock($SERVER{$serv}->{'sock'}, ":".$SERVER{$serv}->{'servname'}." PONG ".$SERVER{$serv}->{'servname'}." ".$SERVER{$serv}->{'last_ping'});

      sendsock($cli, "\002[ BNC\002 \003"."4ATENÇÃO\003 \002]\002: Se você puder ler esta menssagem é por que o PONG_TIME na configuração da BNC é muito curto ou você está realmente laggado, caso necessário aumente-o. Você está sendo \002DETACHADO\002 por que sua resposta ao PING do servidor demoro mais que \002".$CONF{'PONG_TIME'}."\002 segundos.");
      _detach($cli, 1);
      delete($SERVER{$serv}->{'last_ping_time'});
    }


  }

  
  foreach my $key (keys(%PROGRESS)) {
    $key = $CLIENT{$key}->{'sock'} if (defined($CLIENT{$key}));

    my $status = check_progress($key);

    connect_response($key) if ($status == 1);
    close_progress($key) if ($status != 0);
  }

  return() if ((time-$LAST_RECONNECT) < 10); # espera 10 segundos entre as reconexoes...

  foreach my $serv (keys(%RECONNECT)) {
    next if (defined($PROGRESS{$serv}));
    next if ((time-$RECONNECT{$serv}->{'last_try'}) < $RECONNECT_TIME);
    if ($RECONNECT{$serv}->{'tries'} == $MAX_TRIES) {
      delete($RECONNECT{$serv});
      next;
    }

    $RECONNECT{$serv}->{'last_try'} = time;
    $RECONNECT{$serv}->{'tries'}++;

    my ($servsock, $err) = _connect($serv, $RECONNECT{$serv}->{'serv'}, $RECONNECT{$serv}->{'porta'}, $RECONNECT{$serv}->{'user'}, $RECONNECT{$serv}->{'ident'}, $RECONNECT{$serv}->{'vhost'}, $RECONNECT{$serv}->{'ssl'});

    $PROGRESS{$serv}->{'conn_serv'} = $RECONNECT{$serv}->{'conn_serv'};
    $PROGRESS{$serv}->{'pass'}      = $RECONNECT{$serv}->{'pass'} if(defined($RECONNECT{$serv}->{'pass'}));

    $LAST_RECONNECT = time;
  }

}

sub close_cli {
  my $cli = shift;

  $sel_serv->remove($cli) if (grep { $_ eq $cli } $sel_serv->handles());

  $cli->close() if ($cli and ref($cli) =~ /^IO::Socket/ and $cli->connected());

  delete($CLIENT{$cli});
}


sub close_serv {
  my ($fh, $force) = @_;

  if (not defined($SERVER{$fh})) {
    print STDOUT "III FUDEU TUDU\n";
  }

  my $cliserv = $SERVER{$fh}->{'cli'} if (defined($SERVER{$fh}->{'cli'}));

  if ($cliserv) {
    unless ($force) {
      sendsock($cliserv, $SERVER{$fh}->{'buff'}."\r\n", 1) if (length($SERVER{$fh}->{'buff'}) > 0 );
      sendsock($cliserv, " ");
      climsg($cliserv, "O servidor fechou a conecção! $CONN_MSG");
    }
    close_channels($cliserv);
    delete($CLIENT{$cliserv}->{'serv'});
  } elsif (!$force) {
      foreach my $val ('user', 'tmp', 'nick', 'serv', 'porta', 'ident', 'canais', 'keys', 'vhost', 'tries', 'ssl', 'pass', 'id', 'conn_serv') {
        if (not defined($SERVER{$fh}->{$val})) {
          print STDOUT "valor $val .. num tem\n";
        } else {
           print STDOUT "DEFINIDO $val = ".$SERVER{$fh}->{$val}."\n";
        }
            
        $RECONNECT{$fh}->{$val} = $SERVER{$fh}->{$val} if (defined($SERVER{$fh}->{$val}));
      }
      $RECONNECT{$fh}->{'last_try'} = time;
      $RECONNECT{$fh}->{'tries'}    = 0 if (!defined($RECONNECT{$fh}->{'tries'}));
  }

  my $servname = $SERVER{$fh}->{'servname'};

  lost_attach_log($CONF{'LOG_DIR'}."/attach-".$SERVER{$fh}->{'id'}.".log");
  delete($SERVER{$fh});

  clean_init($servname) if ($servname);
  $sel_con->remove($fh);
}


###########
# Parsers #
###########
sub parse_serv {
  my ($serv, $msg) = @_;

  my $cliserv = $SERVER{$serv}->{'cli'} if (defined($SERVER{$serv}->{'cli'}));

  if ($msg =~ /^\:(.+?)\!.+?\@.+?\s+NICK\s+\:(.+?)\r/i
      and lc($1) eq lc($SERVER{$serv}->{'nick'})) {
    $CLIENT{$cliserv}->{'nick'} = $2 if ($cliserv);
    $SERVER{$serv}->{'nick'} = $2;
  } elsif ($msg =~ /^\:(\S+)\s+(00(1|2|3|4|5)|25(1|5)|37(2|5|6))\s+(\S+)\s+(.+?)\r/) {

    if (!defined($SERVER{$serv}->{'servname'})) {
      $CLIENT{$cliserv}->{'nick'} = $6 if ($cliserv);
      $SERVER{$serv}->{'nick'} = $6;
      $SERVER{$serv}->{'servname'} = $1;
    }

    if ($2 eq '001') {
      $INIT{$1} = '';
      sendsock($serv, "MODE ".$6) if ($SERVER{$serv}->{'detach'} == 1); # reconecto com o cliente detachado
    }

    $INIT{$1} .= "$2 \{\} $7\n";
  } elsif ($msg =~ /^\:(\S+)\!(\S+)\@(\S+)\s+(JOIN|PART|KICK)\s+(.+)\r/i) {
      my $nick = $1;
      my $ident = $2;
      my $host = $3;
      my $jpk = lc($4);
      my $canal = $5;
      if ($jpk eq 'kick') {
         $jpk = 'part';
         ($canal, $nick) = split(/ +/, $canal);
      }

      $canal =~ s/^://;
      $canal = $1 if ($canal =~ /^(.+?)\s+:.*/);

      if (lc($nick) eq lc($SERVER{$serv}->{'nick'})) {
        if ($jpk eq "join") {
          push(@{$SERVER{$serv}->{'canais'}}, $canal);
        } elsif ($jpk eq "part") {
            @{$SERVER{$serv}->{'canais'}} = grep { lc($_) ne lc($canal) } @{$SERVER{$serv}->{'canais'}};
        }
      } elsif ($jpk eq 'join') {
          my $suser = $SERVER{$serv}->{'user'};

          foreach my $chan_mask (@{$USERS->{$suser}->{'AUTO_OP'}}) {
            my ($cchan, $cmask) = split(/\004/, $chan_mask);
            next if (lc($canal) ne $cchan or !checkmask("$nick!$ident\@$host", $cmask));

            climsg($SERVER{$serv}->{'cli'}, "Dando OP para \002$nick\002 no canal \002$canal\002. Máscara: $cmask\n") if (defined($SERVER{$serv}->{'cli'}));
            sendsock($serv, "MODE $canal +o $nick");
          }
      }
  } elsif ($msg =~ /^(:.+?\s+)*PONG\s+.*?:ABNC/i) {
      print STDOUT "deletando alivechk ".$SERVER{$serv}->{'alivechk'}."\n";
      delete($SERVER{$serv}->{'alivechk'});
  } elsif ($msg =~ /^\:\S+\!\S+\@\S+\s+MODE\s+(.+?)\s+\+k\s+(.+)\r/i) {
     $SERVER{$serv}->{'keys'}->{lc($1)} = $2;
  }

  if (defined($SERVER{$serv}->{'detach'})) {
    if ($msg =~ /^PING\s+\:*(.+?)\r/i) {
      if (defined($SERVER{$serv}->{'servname'})) {
        sendsock($serv, ":".$SERVER{$serv}->{'servname'}." PONG ".$SERVER{$serv}->{'servname'}." :$1");
      } else {
         sendsock($serv, "PONG :$1");
      }
    } elsif ($msg =~ /^:(\S+)\!\S+\@\S+\s+PRIVMSG\s+(\S+)\s+:(.+?)\r/i) {
      my $mnick = $1;
      my $onde = $2;
      my $mmsg = $3;

      if ($mmsg =~ /^\001VERSION\001/i) {
        sendsock($serv, "NOTICE $mnick :\001VERSION BNC priv8 by \002"."CoSmIcK\002\001");
      } elsif ($mmsg =~ /^\001PING(.*)\001/i) {
          sendsock($serv, "NOTICE $mnick :\001PING$1\001");
      } elsif ($mmsg !~ /^\001.*\001$/ and lc($onde) eq lc($SERVER{$serv}->{'nick'})) { # c num for um ctcp
          PVT_LOG($serv, $msg);
      }
    } elsif ($msg =~ /^\:\S+\s+(\d+)\s+/) {
        my $code = $1;
        if ($code == 443) {
          sendsock($serv, "NICK ".int(rand(9999))."-".$SERVER{$serv}->{'nick'});
        } elsif ($code == 221) {
           while (my $canal = pop(@{$SERVER{$serv}->{'canais'}})) {
             my $send = "JOIN $canal";
             if (defined($SERVER{$serv}->{'keys'}) and defined($SERVER{$serv}->{'keys'}->{lc($canal)})) {
               $send .= ' :'.$SERVER{$serv}->{'keys'}->{lc($canal)};
             }
             sendsock($serv, $send);
           }
           sendsock($serv, "AWAY :".$USERS->{$SERVER{$serv}->{'user'}}->{'AWAY_MSG'});
           delete($SERVER{$serv}->{'tries'});
        }
    }
  } else {
     my $send = 1;
     if ($msg =~ /^PING\s+(.+?)\r/) {
       my $ping = $1;
       if (!defined($SERVER{$serv}->{'servname'})) {
         sendsock($serv, "PONG $ping");
         $send = 0;
       } else {
          $SERVER{$serv}->{'last_ping'} = $ping;
          $SERVER{$serv}->{'last_ping_time'} = time;
       }
     }

     sendsock($cliserv, $msg, 1) if ($send == 1);
  }

}

sub parse_client {
  my ($cli, $msg) = @_;

  if (not defined($CLIENT{$cli}->{'identuser'}) and
     $msg =~ /^USER\s+(\S+)\s+/i) {

     $CLIENT{$cli}->{'identuser'} = $1;
     $CLIENT{$cli}->{'ident'}     = $1;
     $CLIENT{$cli}->{'tmp'}      .= $msg;
     return();
  }

  if (not defined($CLIENT{$cli}->{'identnick'}) and
     $msg =~ /^NICK\s+(\S+)\r/i) {
     $CLIENT{$cli}->{'identnick'} = $1;
     $CLIENT{$cli}->{'nick'} = $1;
     return();
  }

  unless (get_user($cli)) {
    if ($msg =~ /^QUIT(\r|\s+.*)/i) {
      climsg($cli, "Fechando conecção...");
      close_cli($cli);
    }
    return(undef);
  }

  my $comando = $msg;
  $comando =~ s/\n$//;
  $comando =~ s/\r$//;
  my @args = split(/ +/, $comando);
  $comando = lc($args[0]);
  my $opt  = lc($args[1]);

  if (defined($HELP{$comando})) {
    if (!defined($args[$HELP{$comando}{'args'}])) {
       help($cli, $comando);
       return();
    }

    if(defined($HELP{$comando}{'admin'}) and !is_admin($cli)) {
      climsg($cli, "Comando restrito a administradores.");
      return();
    }

    if (defined($HELP{$comando}{'opts'}) and !grep { $opt eq $_ } @{$HELP{$comando}{'opts'}}) {
      climsg($cli, "Opção \002".uc($opt)."\002 não reconhecida pelo comando \002".uc($comando)."\002. Use: ".join(', ',  @{$HELP{$comando}{'opts'}}));
      return();
    }

    if (defined(&{$HELP{$comando}{'cb'}})) {
      my @ret = &{$HELP{$comando}{'cb'}}($cli, $msg, @args[1 .. $#args]);
      map { climsg($cli, $_) } @ret if (@ret);
      return(@ret? 1:undef);
    }
  }


  if ($comando eq 'bhelp') {
    if ($args[1]) {
      if (grep { $_ eq lc($args[1]) } keys(%HELP)) {
         help($cli, lc($args[1]));
      } else {
          climsg($cli, "Comando '\002".uc($args[1])."\002' não existe.");
      }
    } else {
       climsg($cli, "            \002Ajuda da BNC\002");
       climsg($cli, " ");
       map { climsg($cli, " \002".fill_space(uc($_), 10)."\002 - ".$HELP{$_}{about}) } (sort { reverse($a) cmp reverse($b) } keys(%HELP));
       climsg($cli, " ");
       climsg($cli,  "\002Digite\002: /QUOTE BHELP <commando>");
    }
  } else {
     if (defined($CLIENT{$cli}->{'serv'})) {
       $msg =~ s/^NOTICE\s+(\S+)\s+:\001VERSION (.+?)\001\r/NOTICE $1 :\001VERSION \002[BNC priv8]\002 $2\001\r/i if ($msg =~ /^NOTICE/i);
       if ($msg =~ /^QUIT(\r|\s+.*)/i) {
          _detach($cli, 1);
       } else {
          if ($msg =~ /^JOIN\s+(.+?)\s+\:*(.+?)\r/i) {
            my @chans = split(',', $1);
            my @keys = split(',', $2);
#            my $chan = lc($1);
#            my $key = $2;

            foreach my $key (@keys) {
              $key =~ s/\s+.+?$//;
              my $chan = lc(splice(@chans, 0, 1));
              $SERVER{$CLIENT{$cli}->{'serv'}}->{'keys'}->{$chan} = $key if (!grep { lc($_) eq $chan } @{$SERVER{$CLIENT{$cli}->{'serv'}}->{'canais'}}); 
              print STDOUT "canal - key -> *$chan* - *$key*\n";
            }
#            $SERVER{$CLIENT{$cli}->{'serv'}}->{'keys'}->{$chan} = $key if (!grep { lc($_) eq $chan } @{$SERVER{$CLIENT{$cli}->{'serv'}}->{'canais'}}); 
          }

          delete($SERVER{$CLIENT{$cli}->{'serv'}}->{'last_ping_time'}) if ($msg =~ /^PONG\s+/i or $msg =~ /^:.+?\s+PONG\s+.+?:/i);
          sendsock($CLIENT{$cli}->{'serv'}, $msg);
       } 
     } else {
        if ($comando eq 'nick') {
          my $new_nick = $args[1];
          sendsock($cli, ":".$CLIENT{$cli}->{'nick'}."!BNC\@CoSmIcK NICK ".$new_nick);
          $CLIENT{$cli}->{'nick'} = $new_nick;
        } elsif ($comando eq 'ping') {
#            sendsock($cli, ":PONG $args[1]");
            sendsock($cli, ":CoSmIcK.net PONG CoSmIcK.net $args[1]");
        } elsif (grep { $_ eq $comando } ('privmsg', 'mode', 'notice', 'topic', 'whois', 'join', 'part', 'kick') ) {
            climsg($cli, "Você não está conectado em um servidor comando (\002".uc($comando)."\002) ignorado! $CONN_MSG");
        } elsif ($comando eq 'quit') {
           $sel_serv->remove($cli);
           climsg($cli, "Quiting...");
           $cli->close();
        } elsif ($comando ne 'ison') {
            climsg($cli, "Comando \002".uc($comando)."\002 inexistente!");
        }
     }
  }
}

########################
# Funcoes dos comandos #
########################
sub bconf {
  my $cmd = lc($_[2]);

  my $ret;

  if ($cmd eq 'save') {
    my $err = write_usersdb();
    $ret = ( ($err eq '') ? 'Arquivo de configuração escrito.' : "Ocorreu um erro. $err" );
  } elsif ($cmd eq 'load') {
     load();
     $ret = "Configuração carregada!";
#  } else {
#     $ret = "Opção \002$cmd\002 desconhecida. Use: load ou save";
  }

  return($ret);
}

sub passwd {
  my ($cli, $msg, @args) = @_;

  my $cli_user = get_user($cli);

  my ($user, $pass) = ( ($#args == 0)? ($cli_user, $args[0]) :  @args );

  return("Não é possível alterar senha de outros usuários se você não for administrador") if ($cli_user ne $user and !is_admin($cli)); 

  $USERS->{$user}->{'SENHA'} = mkpass($pass);

  return("Senha do usuário \002$user\002 alterada!");
}

sub who {
  my @ret = ("  \002- Usuários logados -\002", " ");

  my $count = 0;
  foreach my $cli (keys(%CLIENT)) {
    next unless(defined($CLIENT{$cli}->{'sock'})); # ?
    my $sock = $CLIENT{$cli}->{'sock'};
    next unless ($sock);
    next unless ($sock->connected);
    my $user = get_user($cli);
    push(@ret, ($user? $user : "\002desconhecido\002"). " (ID: ".$CLIENT{$cli}->{'id'}." IP: ".$sock->peerhost.")" );
    $count++;
  }

  push(@ret, ' ', "Total de \002$count\002 cliente(s) conectado(s)");
  return(@ret);
}

sub killuser {
  my ($cli, $msg, $user, $id) = @_;

  return("Usuário inexistente!") unless(exist_user($user));

  my $ids = _listids($user);

  if (defined($id)) {
    return("Não existem conecções deste usuário") if (scalar(keys(%$ids)) == 0);

    return("O ID ($id) não existe ou não pertence a esse usuário.") unless (defined($ids->{$id}));

    my $sock = $ids->{$id}->{'servsock'};
    close($sock);
  } else {
     foreach my $uid (keys(%$ids)) {
       my $sock = $ids->{$uid}->{'servsock'};
       $sel_con->remove($sock);

       my $servname = $SERVER{$sock}->{'servname'};
       delete($SERVER{$sock});
       clean_init($servname) if ($servname);
          
       $sock->close();
     }
     while (my $luser = is_logged($user)) {
       $sel_serv->remove($luser);
       delete($CLIENT{$luser});
       $luser->close();
     }
  }
  return("Killado!");
}

sub userinfo {
  my ($cli, $msg, $user) = @_;

  return("Usuário inexistente!") unless(exist_user($user));

  my @vhosts;
  if(defined($CONF{'VHOSTS'})) {
     my @u_vhosts = @{$USERS->{$user}->{'VHOSTS'}} if (defined(@{$USERS->{$user}->{'VHOSTS'}}));
     @vhosts = @{$CONF{'VHOSTS'}};
     push(@vhosts, @u_vhosts) if (@u_vhosts);
     @vhosts = ("\002Todos\002") if (grep { $_ == 1 } @vhosts or $user eq 'administrador');
  } else {
      @vhosts = ("\002Todos\002");
  }

  my $ll = localtime($USERS->{$user}->{'LAST_LOG'}) if (defined($USERS->{$user}->{'LAST_LOG'}));
  my $ids = _listids($user);
  my $idsn = scalar(keys(%$ids));

  my @ret = ("       \002- User $user -\002",
             " ",
             "Último Logon:       ".($ll? $ll: "nunca logou").(is_logged($user)? ' (Está logado agora)':''),
             "Vhosts permitidos:  ".(join(', ', @vhosts)),
             "Último vhost usado: ".(defined($USERS->{$user}->{'LAST_VHOST'})? $USERS->{$user}->{'LAST_VHOST'}: "nuca conectou a um servidor"),
             "Atuais conecções:   $idsn".($idsn > 0? " (IDs: ".(join(', ', keys(%$ids))).")":'')
             );

  return(@ret);
}

sub conn {
  my ($cli, $msg, $serv, @opts) = @_;

  return("Você já está conectado em um servidor!") if (defined($CLIENT{$cli}->{'serv'}));

  my $porta = 6667;

  foreach my $opt (@opts) {
    $porta = $1 if ($opt =~ /^-port=(\d+)$/);
  }

  if ($serv =~ /^(.+?)\:(\d+)$/ and $1 !~ /\:/) {
    $serv  = $1;
    $porta = $2;
  }

  connect_serv($cli, $serv, $porta, [@opts]);
  return();
}

sub setident {
  my ($cli, $msg, $ident) = @_;

  return("O IDENTD não está habilitado na configuração.") if (!defined($CONF{'IDENTD'}) or $CONF{'IDENTD'} != 1);
 
  $CLIENT{$cli}->{ident} = $ident;
  return("IDENT alterado para \002$ident\002. Terá efeito na sua próxima conecção.");
}

sub baway {
  my ($cli, $msg, @args) = @_;
  $msg =~ s/^(\S+\s+){2}//;

  my $opt = lc($args[0]);
  my $user = get_user($cli);
  my $ret;

  if ($opt eq 'off') {
    $USERS->{$user}->{'AWAY_MSG'} = '';
    $ret = 'Auto-away desativado!';
  } elsif ($opt eq 'on') {
     if (length($msg) > 0) {
       $USERS->{$user}->{'AWAY_MSG'} = $msg;
       $ret = "Auto-away ativado: $msg";
     } else {
       $ret = "Você precisa especificar a menssagem!";
     }
  } elsif ($opt eq 'show') {
      if (length($USERS->{$user}->{'AWAY_MSG'}) > 0) {
        $ret = "Messagem de auto-away atual: ".$USERS->{$user}->{'AWAY_MSG'};
      } else {
        $ret = "Auto-away está desativado.";
      }
  }

  return($ret);
}

sub admin {
  my ($cli, $msg, $senha) = @_;
  my $user = get_user($cli) || return();

  return("Você já está reconhecido como administrador.") if (is_admin($cli));

  if (crypt($senha, $USERS->{'administrador'}->{'SENHA'}) eq $USERS->{'administrador'}->{'SENHA'}) {
    $CLIENT{$cli}->{'admin'} = 1;
    LOG("Usuário $user agora é reconhecido como administrador") if(can_log(4));
    return("Agora você está reconhecido como administrador.");
  }

  LOG("Usuário $user tentou obter poderes de administrador") if (can_log(3));
  return("Senha errada!");
}

sub lastlog {
  my $cli = shift;
  my $user = get_user($cli);

  my @ret = ("       - \002Listando últimos logons\002 -", " ");
  foreach my $luser (keys(%$USERS)) {
    next if ($luser ne $user and !is_admin($cli));
    my $ll = localtime($USERS->{$luser}->{'LAST_LOG'}) if (defined($USERS->{$luser}->{'LAST_LOG'}));
    push(@ret, fill_space($luser, 15)." - ".($ll? $ll: "nunca logou"));
  }    

  return(@ret);
}

sub vhost {
  my ($cli, $msg, $vhost, $ipv) = @_;

  $vhost = '0.0.0.0' if (lc($vhost) eq 'ipv4');
  $vhost = '::' if (lc($vhost) eq 'ipv6');

  my $user = get_user($cli) || return();

  my ($ip, $ver) = resolv($vhost, $ipv);
  return("Não consegui resolver o nome do vhost: $vhost (IPv$ver)") if (!$ip or ($ipv and $ipv != $ver));
        
  if(defined($CONF{'VHOSTS'}) and !is_admin($cli) and
     !grep { $_ eq 1 } @{$USERS->{$user}->{'VHOSTS'}} and
     (!(grep { $_ eq $ip or $_ eq $vhost } @{$CONF{'VHOSTS'}}) and
      !(grep { $_ eq $ip or $_ eq $vhost } @{$USERS->{$user}->{'VHOSTS'}})) ) {

     my @u_vhosts = @{$USERS->{$user}->{'VHOSTS'}} if (defined(@{$USERS->{$user}->{'VHOSTS'}}));
     my @vhosts = @{$CONF{'VHOSTS'}};
     push(@vhosts, @u_vhosts) if (@u_vhosts);

     return("Você já não tem permissão para usar este vhost.", "Vhosts permitidos: ".join(', ', @vhosts));
  }

  return("Você já está conectado em um servidor! O vhost naum pode ser mudado") if (defined($CLIENT{$cli}->{'serv'}));

  $CLIENT{$cli}->{'vhost'} = $vhost;
#  $CLIENT{$cli}->{'vhostipv'} = $ver; 

  return("Virtual Host mudado para: $vhost ($ip)");
}

sub reattach {
  my ($cli, $msg, $id) = @_;

  my $serv = getservbyid($cli, $id);

  return("ID \002$id\002 nao encontrado ou pertencente a outro usuário! Digite /QUOTE LISTIDS") unless ($serv);
  return("Servidor em uso, o REATTACH não é possível.") unless (defined($SERVER{$serv}->{'detach'}));
  return("Você já está conectado a um servidor. Use primeiro: /QUOTE DETACH")  if (defined($CLIENT{$cli}->{'serv'}));

  my $cli_nick = $CLIENT{$cli}->{'nick'};

  climsg($cli, "OK! Reatachando :)");

  $CLIENT{$cli}->{'serv'} = $serv;
  delete($SERVER{$serv}->{'detach'});
  $SERVER{$serv}->{'cli'} = $cli;

  sendsock($cli, ":$cli_nick!BNC\@priv8 NICK ".$SERVER{$serv}->{'nick'})
    if ($SERVER{$serv}->{'nick'} ne $cli_nick);

  $CLIENT{$cli}->{'nick'} = $SERVER{$serv}->{'nick'};
  $cli_nick = $SERVER{$serv}->{'nick'};

  foreach my $line (split(/\n/, $INIT{$SERVER{$serv}->{'servname'}})) {
    $line =~ s/\{\}/$cli_nick/;
    sendsock($cli, ":".$SERVER{$serv}->{'servname'}." ".$line);
  }

  foreach my $canal (@{$SERVER{$serv}->{'canais'}}) {
    sendsock($cli, ":$cli_nick!BNC\@priv8 JOIN $canal");
    sendsock($serv, "NAMES $canal");
    sendsock($serv, "TOPIC $canal");
#    sleep(2);
    select(undef, undef, undef, 1.5);
  }

  my $file = $CONF{'LOG_DIR'}."/attach-".$SERVER{$serv}->{'id'}.".log";

  if (open(PVTLOG, "< $file")) {
    while (my $msg = <PVTLOG>) {
      $msg =~ /^(\S+)\s+PRIVMSG\s+.+?:(.*)(\r|\n)/i;
      sendsock($cli, "$1 PRIVMSG $cli_nick :\002[BNC log]\002 $2");
    }
    close(PVTLOG);
    unlink($file);
  }

  my $user = get_user($cli);
  sendsock($CLIENT{$cli}->{'serv'}, "AWAY") if (defined($USERS->{$user}->{'AWAY_MSG'}) and length($USERS->{$user}->{'AWAY_MSG'}) > 0);

  LOG("Usuário ".$user." fez o reattach no servidor ".$SERVER{$serv}->{'conn_serv'}." (ID: $id)") if (can_log(10));

  return("Reattachado!");
}

sub adduser {
  my ($cli, $msg, $user, $senha, $vhosts) = @_;

  return("Usuário $user já existe!") if (exist_user($user));
  return("Erro: Arquivo de banco de dados dos usuários não definido na configuração.") unless (defined($CONF{'USERS_DB'}));

  my @vhosts = split(',', $vhosts);
#  return("Erro na formacão do vhost. Ele precisa ser um IP") if (@vhosts and grep { (!IO::Socket::INET::full_ipv6uncompress($_) or $_ !~ /^([12]?\d{1,2}\.){3}[12]?\d{1,2}$/) and $_ != 1 } @vhosts);

  return("Já existe um usuário com esta senha") if (check_pass($senha));

  my $gen = undef;
  if ($senha eq '0') {
    $gen = 1;
    $senha = genpass();
  }

  my $crypt = mkpass($senha);
  return(undef, $!) unless(open(USERS_DB, ">> ".$CONF{'USERS_DB'}));
  print USERS_DB "U: $user\nS: $crypt\nV: @vhosts\n";
  close(USERS_DB);

  $USERS->{$user}->{'SENHA'} = $crypt;
  @{$USERS->{$user}->{'VHOSTS'}} = @vhosts;

  return("Usuário \002$user\002 adicionado! ".($gen? "Senha gerada para o usuário: $senha" : ''));
}

sub mkpass {
  crypt(shift, join '', ('.', '/',0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]);
}

sub genpass {
  my $pass = '';
  for ( 1 .. 8 ) {
    $pass .= ('.', '/',0..9, 'A'..'Z', 'a'..'z')[rand 64];
  }
  return($pass);
}

sub deluser {
  my ($cli, $msg, $user) = @_;

  return("Impossível deletar o administrador.") if ($user eq 'administrador');
  return("Usuário inexistente!") unless(exist_user($user));

  killuser(undef, undef, $user);
  delete($USERS->{$user});
  write_usersdb();
  return("Usuário deletado.");
}

sub bquit {
  my ($cli, $msg) = @_;
  return("Você não está conectado em nenhum servidor.") if (!defined($CLIENT{$cli}->{'serv'}));

  $msg =~ /^\S+\s+(.+?)$/;
  my $quitmsg = $1;
  sendsock($CLIENT{$cli}->{'serv'}, "QUIT :$quitmsg");
  close_serv($CLIENT{$cli}->{'serv'}, 1);
  LOG("Usuário ".get_user($cli)." desconectou do servidor (".$SERVER{$CLIENT{$cli}->{'serv'}}->{'conn_serv'}.")") if (can_log(6));
  return("Desconectado do servidor!");
}

sub rstop {
  my ($cli, $msg, $id) = @_;

  my $user = get_user($cli);

  my $ids = _listids((is_admin($cli) ? undef:$user), 1);

  return("ID \002$id\002 inexistente!") unless(defined($ids->{$id}));
  return("ID \002$id\002 não está em status de reconecção.") if (defined($ids->{$id}->{'servsock'}));

  delete($RECONNECT{$ids->{$id}->{'key'}});
  close_progress($ids->{$id}->{'key'});

  return("Reconecção do ID \002$id\002 parada.");
}
 

sub listids {
  my $cli = shift;
  my $user = get_user($cli);
 
  my $ids = _listids((is_admin($cli) ? undef:$user), 1);

  return("Não existe nenhuma conecção com servidores.") if (scalar(keys(%$ids)) == 0);

  climsg($cli, "           - \002Listando IDs\002 -");
  climsg($cli, " ");

  foreach my $id (sort { $a <=> $b } (keys(%$ids))) {
    my $uso;
    my $servsock;
    if (defined($ids->{$id}->{'servsock'})) {
       $uso = (($ids->{$id}->{'uso'} == 0)? "Detached" : "Em uso");
       $servsock = $ids->{$id}->{'servsock'};
    } else {
      $uso = "\003"."4RECONECTANDO\003";
    }

    my $act_vhost = $servsock->sockhost() if ($servsock);
    climsg($cli, "\002$id\002 -> ".$ids->{$id}->{'nick'}.'@'.$ids->{$id}->{'conn_serv'}." (".$ids->{$id}->{'serv'}.":".$ids->{$id}->{'servport'}.") [User: ".$ids->{$id}->{'user'}." VHost: ".$ids->{$id}->{'vhost'}.( ($act_vhost and $act_vhost ne $ids->{$id}->{'vhost'})? " (Local IP: $act_vhost)" : '' )."] $uso");
  }

  return();
}

sub _listids {
  my ($user, $list_reconn) = @_;
  my $IDS = {};

  my %LIST = (%SERVER);
  %LIST = ((%LIST), (%RECONNECT)) if ($list_reconn and (scalar(keys(%RECONNECT))) > 0);
  

  foreach my $serv (keys(%LIST)) {
    my $suser = $LIST{$serv}->{'user'};
    next if (defined($user) and $suser ne $user);

    my $id = $LIST{$serv}->{'id'};
    $IDS->{$id}->{'uso'} = (defined($LIST{$serv}->{'detach'})? 0 : 1);
    $IDS->{$id}->{'key'} = $serv;

    foreach my $info ('nick', 'serv', 'porta/servport', 'vhost', 'cli/clisock', 'sock/servsock', 'user', 'conn_serv') {
      my $from = $info;
      my $to = $info;
      ($from, $to) = split('/', $info) if ($info =~ /\//);
      $IDS->{$id}->{$to} = $LIST{$serv}->{$from} if (defined($LIST{$serv}->{$from}));
    } 
  }

  return($IDS);
}

sub autoop {
  my ($cli, $msg, $adl, $chan, $mask) = @_;

  $adl = lc($adl);
  my $lchan = lc($chan);
  my $js = $lchan."\004".$mask;
  my $user = get_user($cli);

  if ($adl eq 'del' or $adl eq 'add') {
    return("É necessário a especificação do canal!") unless ($chan);
    return("VocÊ precisa definir o canal e máscara para usar o DEL e ADD.") if (!$mask);
    return("Máscara \002$mask\002 é inválida!") unless($mask =~ /.+?\!.+?\@.+?/);
  }

  return("Não existe nenhuma entrada de AUTOOP!") if (($adl eq 'del' or $adl eq 'list') and
                                                      (!defined($USERS->{$user}->{'AUTO_OP'}) or
                                                       scalar(@{$USERS->{$user}->{'AUTO_OP'}}) == 0)
                                                     );

  if ($adl eq 'add') {
    return("Já existe uma entrada com o mesmo canal e máscara.") if (grep { $_ eq $js } @{$USERS->{$user}->{'AUTO_OP'}});
    push(@{$USERS->{$user}->{'AUTO_OP'}}, $js);
    return("Entrada adicionada.");
  } elsif ($adl eq 'del') {
     my @new = grep { $_ ne $js } @{$USERS->{$user}->{'AUTO_OP'}};
     return("Não existe uma entrada com esse canal e máscara!") if (scalar(@new) == scalar(@{$USERS->{$user}->{'AUTO_OP'}}));
     @{$USERS->{$user}->{'AUTO_OP'}} = @new;
     return("Entrada deletada.");
  } elsif ($adl eq 'list') {
     climsg($cli, "     - \002Auto OP ".(defined($chan)? "para o canal $lchan" : '')." \002-");
     climsg($cli, ' ');
     foreach my $ent (@{$USERS->{$user}->{'AUTO_OP'}}) {
       my ($echan, $emask) = split("\004", $ent);
       next if ($chan and $lchan ne $echan);
       climsg($cli, "\002$echan\002 -> $emask");
     }
     return();
  }

}

sub detach {
  my $cli = shift;

  return("Você não está conectado em nenhum servidor") if (!defined($CLIENT{$cli}->{'serv'}));

  _detach($cli);
  return();
}

sub fdetach {
  my ($cli, $msg, $id) = @_;

  my $user = get_user($cli);
  my $ids = _listids((is_admin($cli) ? undef:$user));

  foreach my $fid (keys(%$ids)) {
    next if ($fid != $id);

    return("O ID \002$id\002 não está em uso!") if ($ids->{$id}->{'uso'} == 0);
    _detach($ids->{$id}->{'clisock'}, undef, 1);
    return("ID \002$id\002 detachado!");
  }

  return("ID não encontrado ou não pertence a você");
}

sub _detach {
  my ($cli, $desconn, $force) = @_;

  return(undef) unless (defined($CLIENT{$cli}->{'serv'}));

  $SERVER{$CLIENT{$cli}->{'serv'}}->{'detach'} = 1;

  climsg($cli, "Detachando....");
  close_channels($cli);

  climsg($cli, ($desconn? "Teh mais tardi!" : "Detachado!")." ID pra reattach: \002".$SERVER{$CLIENT{$cli}->{'serv'}}->{'id'}."\002");

  my $user = get_user($cli);
#  if ($user) {  
    sendsock($CLIENT{$cli}->{'serv'}, "AWAY :".$USERS->{$user}->{'AWAY_MSG'}) if (defined($USERS->{$user}->{'AWAY_MSG'}) and length($USERS->{$user}->{'AWAY_MSG'}) > 0);

    LOG("Usuário $user ".($force? "foi forçado a fazer" : "fez")." o detach no servidor ".$SERVER{$CLIENT{$cli}->{'serv'}}->{'conn_serv'}." (ID: ".$SERVER{$CLIENT{$cli}->{'serv'}}->{'id'}.")") if (can_log(9));
#  }

  delete($SERVER{$CLIENT{$cli}->{'serv'}}->{'cli'});
  if ($desconn) {
    close_cli($cli);
  } else {
     delete($CLIENT{$cli}->{'serv'});
     $CLIENT{$cli}->{'id'} = newid();
  }

}


########################
# Funcoes dos usuários #
########################
sub is_logged {
  my $user = shift;

  foreach my $cli (keys(%CLIENT)) {
    next unless (defined($CLIENT{$cli}->{'user'}));
    return($CLIENT{$cli}->{'sock'}) if ($CLIENT{$cli}->{'user'} eq $user);
  }

  return(undef);
}

sub is_admin {
  my $cli = shift;
  my $user = get_user($cli) || return(undef);

  return(1) if (defined($CLIENT{$cli}->{'admin'}));
  return(undef);
}

sub exist_user {
  my $user = shift;
  return((defined($USERS->{$user})? 1:undef));

}

sub get_user {
  my $cli = shift;
  return() unless ($cli);

  return($CLIENT{$cli}->{'user'}) if (defined($CLIENT{$cli}) and defined($CLIENT{$cli}->{'user'}));
  return();
}

sub check_pass {
  my $senha = shift;

  foreach my $user (keys(%$USERS)) {
    return($user) if (crypt($senha, $USERS->{$user}->{'SENHA'}) eq $USERS->{$user}->{'SENHA'});
  }

  return(undef);
}

############################################
# Configuração/Banco de dados dos usuários #
############################################
sub write_usersdb {
  return("Erro: Arquivo de banco de dados dos usuários não definido na configuração.") unless (defined($CONF{'USERS_DB'}));

  return("Erro: $!") unless(open(USERS_DB, "> ".$CONF{'USERS_DB'}));

  foreach my $user (keys(%$USERS)) {
#    next if ($user eq 'administrador');
    next if ($user eq '');

    print USERS_DB "U: $user\n";
    print USERS_DB "LV: ".$USERS->{$user}->{'LAST_VHOST'}."\n" if (defined($USERS->{$user}->{'LAST_VHOST'}));
    print USERS_DB "LL: ".$USERS->{$user}->{'LAST_LOG'}."\n" if (defined($USERS->{$user}->{'LAST_LOG'}));
    print USERS_DB "AM: ".$USERS->{$user}->{'AWAY_MSG'}."\n" if (defined($USERS->{$user}->{'AWAY_MSG'}));
    print USERS_DB "AO: ".join(' ', @{$USERS->{$user}->{'AUTO_OP'}})."\n" if (defined($USERS->{$user}->{'AUTO_OP'}));


    if ($user ne 'administrador') {
    print USERS_DB "S: ".$USERS->{$user}->{'SENHA'}."\n";
    print USERS_DB "V: ".join(' ', @{$USERS->{$user}->{'VHOSTS'}})."\n" if (defined($USERS->{$user}->{'VHOSTS'}));
    }

  }

  close(USERS_DB);

  return();
}

sub load {
#  write_usersdb() if (scalar(keys(%$USERS))) > 1);
#  %CONF  = ();
  $USERS = {};

  carrega_configuracao() or die "Nao consegui carrega o arquivo de configuração: $!";
  carrega_usuarios();
}

sub carrega_usuarios {
  $USERS->{'administrador'}->{'SENHA'}     = $CONF{'ADMIN_PASS'};
  @{$USERS->{'administrador'}->{'VHOSTS'}} = (1);
  $USERS->{'administrador'}->{'admin'}     = 1;

  return(undef) unless(open(USERS_DB, "< ".$CONF{'USERS_DB'}));

  my $USER = '';
  while (<USERS_DB>) {
    s/\n$//;
    s/\r$//;

    $USER                           = $1 if (/^U:\s+(.+)$/);
    next unless ($USER);
    @{$USERS->{$USER}->{'VHOSTS'}}  = split(/ +/, $1) if (/^V:\s+(.+)$/);
    $USERS->{$USER}->{'SENHA'}      = $1 if (/^S:\s+(.+)$/);
    $USERS->{$USER}->{'LAST_LOG'}   = $1 if (/^LL:\s+(.+)$/);
    $USERS->{$USER}->{'LAST_VHOST'} = $1 if (/^LV:\s+(.+)$/);
    $USERS->{$USER}->{'AWAY_MSG'}   = $1 if (/^AM:\s+(.+)$/);
    @{$USERS->{$USER}->{'AUTO_OP'}} = split(/ +/, $1) if (/^AO:\s+(.+)$/);
  }

  close(USERS_DB);
  return(1);
}

sub carrega_configuracao {

  if (defined($opt{'conf'})) {
    %CONF = ();
    open(BNC_CONF, "< ".$opt{'conf'}) || return(undef);

    while (my $linha = <BNC_CONF>) {
      next if ($linha =~ /^\s*#/);
      $linha =~ s/\n$//;
      $linha =~ s/\r$//;

      $linha =~ s/\t/ /g;
      $linha =~ s/^\s+//;
      next if ($linha eq '');

      my (@args) = split(/ +/, $linha);

      my $conf      = $args[0];
      my @conf_args = @args[1 .. $#args];

      if (grep { $_ eq $conf  } ('VHOSTS', 'LOG_OPTS') ) {
         $CONF{$conf} = [@conf_args];
      } else {
         $CONF{$conf} = $conf_args[0];
      }
    }
    close(BNC_CONF);
  }

  foreach my $opt (keys(%opt)) {
    next if ($opt ne uc($opt) or $opt eq 'STD');
    next if ($opt{$opt} eq '');
    $opt{$opt} = mkpass($opt{$opt}) if ($opt eq 'ADMIN_PASS');
    $CONF{$opt} = $opt{$opt};
  }

  # Conferindo a configuração
  foreach my $def (@DEF) {
    next if (defined($CONF{$def}));

    print STDERR "A opção '$def' não foi definida na configuração!\n";
    print STDERR "Impossível continuar.\n";
 
    exit(1);
  }

  # Conferindo parametros
  $CONF{'LOG_DIR'} =~ s/\/$// if ($CONF{'LOG_DIR'} ne '/');

  mkdir($CONF{'LOG_DIR'}, 0700) unless(-d $CONF{'LOG_DIR'});
  unless(-d $CONF{'LOG_DIR'}) {
    print STDERR "Diretório de log (".$CONF{'LOG_DIR'}.") não existe e foi impossível criar-lo\n";
    exit(1);
  }

  return(1);
}

######################
# Funcoes de sockets #
######################
sub climsg {
  my ($cli, $msg) = @_;

  return() if (not defined($CLIENT{$cli}));
  my $nick = $CLIENT{$cli}->{'nick'} if (defined($CLIENT{$cli}->{'nick'}));

  my $inicio =  (defined($nick)) ? ":BNC!CoSmIcK\@Team NOTICE $nick :" : "NOTICE AUTH :*** ";

  sendsock($cli, $inicio.$msg);
}

sub _connect {
  my ($key, $serv, $porta, $user, $ident, $vhost, $ssl) = @_;

  close_progress($key);
print STDOUT "my ($key, $serv, $porta, $user, $ident, $vhost, $ssl)\n";
  my %args = (PeerAddr => $serv, PeerPort => $porta, Proto => 'tcp', Timeout => 20, DontConn => 1);

  if (defined($CONF{'VHOSTS'})) {
    my @hosts = @{$CONF{'VHOSTS'}};
    push(@hosts, grep { $_ ne 1 } @{$USERS->{$user}->{'VHOSTS'}}) if (defined($USERS->{$user}->{'VHOSTS'}));
    $args{'LocalAddr'} = @hosts[int(rand($#hosts))];
  }

  if ($vhost) {
    $args{'LocalAddr'} = $vhost;
  } elsif (defined($USERS->{$user}->{'LAST_VHOST'})) {
     $args{'LocalAddr'} = $USERS->{$user}->{'LAST_VHOST'};
  }

  # nova forma
  if ($CONF{'IDENTD'} == 1) { 
    my $ipid = fork();
    unless ($ipid) {
       identd($ident);
       exit;
    }
    sleep(2);
  }

  delete($args{DontConn}) if ($ssl);
  my $servsock = ($ssl? IO::Socket::SSL->new(%args) : IO::Socket::INET->new(%args));

  my ($pid, $pipe, $err);

  if (!$ssl) { # com ssl a gente num vai pode fork :(
    ($pid, $pipe) = fork_connect($servsock);
  } else {
     $err = $!;
  }


  if ($pid or $ssl) {
    $PROGRESS{$key}->{'pid'}      = $pid;
    $PROGRESS{$key}->{'pipe'}     = $pipe;
    $PROGRESS{$key}->{'servsock'} = $servsock;
    $PROGRESS{$key}->{'ssl'}      = $ssl;
    $PROGRESS{$key}->{'serv'}     = $serv;
    $PROGRESS{$key}->{'porta'}    = $porta;
    $PROGRESS{$key}->{'vhost'}    = $args{'LocalAddr'};
    $PROGRESS{$key}->{'client'}   = 1 if (defined($CLIENT{$key}));
  } else {
     close($servsock) if($servsock);
     $err = "Não consegui dar fork()";
  }

  close_progress($key) unless($servsock);

  return($servsock, $err);
}

sub fork_connect {
  my $sock = shift;

  my $FCRDR = IO::Handle->new();
  my $FCWTR = IO::Handle->new();
  
  $FCWTR->autoflush(1);
  $FCRDR->autoflush(1);

  pipe($FCRDR, $FCWTR);
  my $sel = IO::Select->new($FCRDR);

  my $cpid = fork();
 
  unless ($cpid) {
    close($FCRDR);
    syswrite($FCWTR, "$$\n");

    if ($sock and defined(${*$sock}{'io_socket_peername'})) {
      $sock->connect(${*$sock}{'io_socket_peername'});
      syswrite($FCWTR,  ($sock->connected())? "1 \n" : "-1 $!\n");
    }
    sleep(1);
    exit;
  }
  close($FCWTR);


  if (scalar($sel->can_read(5)) == 0) {
    close($FCRDR);
    return();
  }

  chop(my $child_pid = <$FCRDR>);

#  print "cpid $child_pid fh $FCRDR\n";

  return($child_pid, $FCRDR);
}

sub close_progress {
  my ($key, $msg) = @_;

  return($msg? "Não existe nenhuma tentativa de conecção em andamento." : ()) unless(defined($PROGRESS{$key}));

  kill(9, $PROGRESS{$key}->{'pid'}) if (defined($PROGRESS{$key}->{'pid'}) and kill(0, $PROGRESS{$key}->{'pid'}));
  close($PROGRESS{$key}->{'pipe'}) if (defined($PROGRESS{$key}->{'pipe'}));

  delete($PROGRESS{$key});
  return("Conecção parada!") if ($msg);
}


sub connect_serv {
  my ($cli, $serv, $porta, $opts) = @_;

  if (defined($PROGRESS{$cli})) {
    sendsock($cli, "Já existe uma conecção em andamento. Para parar-la digite: /CONNSTOP");
    return();
  }

  my ($ssl, $pass);
  foreach my $opt (@{$opts}) {
    if ($opt eq '-ssl') {
      $ssl = 1;
   
    } elsif ($opt =~ /^-pass=(.+)/) {
       $pass = $1;
    }
  }

  if ($ssl and !$SSL) {
    sendsock($cli, "Erro: Suporte para SSL não foi instalado (IO::Socket::SSL)");
    sendsock($cli, "      Você não será capaz de usar a opção '-ssl'");
    return(undef);
  }

  my $user = get_user($cli);

  my ($lip, $lver) = resolv($CLIENT{$cli}->{'vhost'} || $USERS->{$user}->{'LAST_VHOST'} || '0.0.0.0' );
  my ($ip, $ver) = resolv($serv, $lver);

#  my ($ip, $ver) = resolv($serv);

  if (!$ip or $lver != $ver ) {
    sendsock($cli, "Não consegui resolver o nome $serv (IPv$lver)");
    return(undef);
  }

  sendsock($cli, "NOTICE AUTH :*** Conectando agora em $serv ($ip) na porta $porta. ".($ssl? '': "Digite: /CONNSTOP para parar a conecção"));

  my ($servsock, $err) = _connect($cli, $ip, $porta, $user, $CLIENT{$cli}->{'ident'}, $CLIENT{$cli}->{'vhost'}, $ssl);

  unless ($servsock) {
    climsg($cli, "Erro: $err");
    return(undef);
  }

  $PROGRESS{$cli}->{'client'}    = 1;
  $PROGRESS{$cli}->{'conn_serv'} = $serv;
  $PROGRESS{$cli}->{'pass'}      = $pass if ($pass);

  return(1);
}

sub check_progress {
  my $key = shift;

  return(-1) unless(defined($PROGRESS{$key}));

  my $sock = $PROGRESS{$key}->{'servsock'};
  my $sel = IO::Select->new($sock);
  return( ($sel->can_write(0) or $sel->can_read(0))? 1 : 0 );
}

sub connect_response {
  my $key = shift;

  my $client   = 1 if (defined($PROGRESS{$key}->{'client'}));
  my %CR       = ($client? (%CLIENT) : (%RECONNECT));
  return(undef) if (!defined($CR{$key}));
  my $user     = $CR{$key}->{'user'};
  my $pass     = $CR{$key}->{'pass'} if(defined($PROGRESS{$key}->{'pass'}));
  my $servsock = $PROGRESS{$key}->{'servsock'};
  my $porta    = $PROGRESS{$key}->{'porta'};
  my $serv     = $PROGRESS{$key}->{'serv'};
  my $ssl      = $PROGRESS{$key}->{'ssl'};
  my $conn_serv= $PROGRESS{$key}->{'conn_serv'};

  
  my $msg;

  my $sel = IO::Select->new($servsock);
  if ($sel->can_read(0)) {
    my $nread = $servsock->sysread($msg, 1024);

    if (not defined($CR{$key})) {
      close($servsock) if ($nread != 0);
      return();
    }

    if ($nread == 0) {
       my $err;

       my $sel = IO::Select->new($PROGRESS{$key}->{'pipe'});
       if (my ($pipe) = $sel->can_read(2)) {
          sysread($pipe, $err, 1024);
          $err =~ s/^\S+\s+//;
          $err =~ s/\n$//;
       }

       if ($client) {
         climsg($key, "Não consegui conectar em $conn_serv:$porta".((defined($PROGRESS{$key}->{'vhost'}))? " usando vhost ".$PROGRESS{$key}->{'vhost'} : '').(($err ne '')? " (Erro: $err)" : ''));
         LOG("Usuário $user tentou conectar no servidor $conn_serv:$porta") if (can_log(8));
       }

       return(undef);
    }
  }

  return() if (!$servsock or !$servsock->connected());

  $servsock->autoflush(1);
  $sel_con->add($servsock);


  if ($client) {
    $USERS->{$user}->{'LAST_VHOST'} = ($PROGRESS{$key}->{'vhost'} || $servsock->sockhost) if($user eq 'administrador' or !is_admin($key));
    LOG("Usuário $user conectou no servidor $conn_serv:$porta") if (can_log(7));

    $CLIENT{$key}->{'serv'}       = $servsock;
    $SERVER{$servsock}->{'cli'}   = $key;
    $SERVER{$servsock}->{'id'}    = $CR{$key}->{'id'};

    sendsock($key, "NOTICE AUTH :*** Conectado!");
  } else {
    foreach my $val (keys(%{$RECONNECT{$key}})) {
      next if ($val eq 'last_try');
      $SERVER{$servsock}->{$val} = $RECONNECT{$key}->{$val};
    }

    $SERVER{$servsock}->{'id'}     = newid();
    $SERVER{$servsock}->{'detach'} = 1;

    delete($RECONNECT{$key});
  }


  if ($pass) {
    sendsock($servsock, "PASS $pass");
    $SERVER{$servsock}->{'pass'} = $pass;
  }

  sendsock($servsock, "NICK ".$CR{$key}->{'nick'});
  sendsock($servsock, $CR{$key}->{'tmp'});


  $SERVER{$servsock}->{'nick'}  = $CR{$key}->{'nick'};
  $SERVER{$servsock}->{'tmp'}   = $CR{$key}->{'tmp'};
  $SERVER{$servsock}->{'ident'} = $CR{$key}->{'ident'};
  $SERVER{$servsock}->{'ssl'}   = 1 if (defined($PROGRESS{$key}->{'ssl'}));
  $SERVER{$servsock}->{'conn_serv'}  = $conn_serv;
  $SERVER{$servsock}->{'sock'}  = $servsock;
  $SERVER{$servsock}->{'serv'}  = $serv;
#  $SERVER{$servsock}->{'vhost'} = $servsock->sockhost;
  $SERVER{$servsock}->{'vhost'} = $CR{$key}->{'vhost'};

  $SERVER{$servsock}->{'porta'} = $porta;
  $SERVER{$servsock}->{'user'}  = $user;
  $SERVER{$servsock}->{'buff'}  = $msg;

}

sub conn_response {
  my $cli = shift;

  my $servsock = $PROGRESS{$cli}->{'servsock'};
  my $pass     = $PROGRESS{$cli}->{'pass'} if(defined($PROGRESS{$cli}->{'pass'}));
  my $user     = $PROGRESS{$cli}->{'user'};
  my $porta    = $PROGRESS{$cli}->{'porta'};
  my $serv     = $PROGRESS{$cli}->{'serv'};
  my $ssl      = $PROGRESS{$cli}->{'ssl'};

  my $msg;
  my $nread = $servsock->sysread($msg, 1024);

  if ($nread == 0) {
     my $err;

     my $sel = IO::Select->new($PROGRESS{$cli}->{'pipe'});
     if (my ($pipe) = $sel->can_read(2)) {
        sysread($pipe, $err, 1024);
        $err =~ s/^\S+\s+//;
        $err =~ s/\n$//;
     }

     climsg($cli, "Não consegui conectar em $serv:$porta".((defined($PROGRESS{$cli}->{'vhost'}))? " usando vhost ".$PROGRESS{$cli}->{'vhost'} : '').(($err ne '')? " (Erro: $err)" : ''));
     LOG("Usuário $user tentou conectar no servidor $serv:$porta") if (can_log(8));

     return(undef)
  }

  $servsock->autoflush(1);
  $sel_con->add($servsock);

  $USERS->{$user}->{'LAST_VHOST'} = ($PROGRESS{$cli}->{'vhost'} || $servsock->sockhost) if($user eq 'administrador' or !is_admin($cli));

  LOG("Usuário $user conectou no servidor $serv:$porta") if (can_log(7));

  sendsock($servsock, "PASS $pass") if ($pass);
  sendsock($servsock, "NICK ".$CLIENT{$cli}->{'nick'});
  sendsock($servsock, $CLIENT{$cli}->{'tmp'});


  $CLIENT{$cli}->{'serv'}       = $servsock;
  $SERVER{$servsock}->{'sock'}  = $servsock;
  $SERVER{$servsock}->{'id'}    = $CLIENT{$cli}->{'id'};
  $SERVER{$servsock}->{'cli'}   = $cli;
  $SERVER{$servsock}->{'nick'}  = $CLIENT{$cli}->{'nick'};
  $SERVER{$servsock}->{'host'}  = $serv;
  $SERVER{$servsock}->{'vhost'} = $servsock->sockhost;
  $SERVER{$servsock}->{'porta'} = $porta;
  $SERVER{$servsock}->{'user'}  = $user;
  $SERVER{$servsock}->{'buff'}  = $msg;
  $SERVER{$servsock}->{'tmp'}   = $CLIENT{$cli}->{'tmp'};
  $SERVER{$servsock}->{'ident'} = $CLIENT{$cli}->{'ident'};
  $SERVER{$servsock}->{'ssl'}   = $ssl;
  $SERVER{$servsock}->{'pass'}  = $pass;
  $SERVER{$servsock}->{'conn_serv'}  = $PROGRESS{$cli}->{'conn_serv'};


  sendsock($cli, "NOTICE AUTH :*** Conectado!");
  return(1);
}

sub identd {
  my $ident = shift;

  my $identd = IO::Socket::INET->new(LocalAddr => '::', LocalPort => 113, Proto => 'tcp', Listen => 1);
  $identd = IO::Socket::INET->new(LocalAddr => '0.0.0.0', LocalPort => 113, Proto => 'tcp', Listen => 1) unless($identd);

  return() unless($identd);

  my $sel = IO::Select->new($identd);

  return() unless($sel->can_read(20));

  my $newcon = $identd->accept();

  my $msg;
  $newcon->sysread($msg, 1024);

  $msg =~ s/\n$//;
  $msg =~ s/\r$//;
  $msg =~ s/\s+$//;
  sendsock($newcon, "$msg : USERID : UNIX :$ident");
  
  $newcon->close();
  $identd->close();
}

sub sendsock {
  my ($sock, $msg, $org) = @_;
  $msg .= "\r\n" if ($msg !~ /\n$/ and !$org);
 
  $sock->syswrite($msg, length($msg)) if ($sock and $sock->connected());
  $SERVER{$sock}->{'lastsnd'} = time if (defined($SERVER{$sock}));
}

sub close_channels {
  my $cli = shift;

  foreach my $canal (@{ $SERVER{$CLIENT{$cli}->{'serv'}}->{'canais'} }) {
    sendsock($cli, ":".$CLIENT{$cli}->{'nick'}."!BNC\@priv8 PART $canal");
  }
}

#################
# DNS functions #
#################
sub resolv {
  my ($host, $inet) = @_;
   
  $inet ||= 4;

  return ( wantarray? ($host, 4) : $host ) if (IO::Socket::INET::is_ipv4($host));
  return ( wantarray? ($host, 6) : $host ) if (IO::Socket::INET::is_ipv6($host));


  my $ipaddr = undef;

#  my $type = 'A' x ($inet-3+(int($inet/6)));

  # parece q o dns_resolv ainda num tah totalmente confiavel
  my $ip = (($inet == 4)? join('.',unpack('C4',(gethostbyname($host))[4])) :  dns_resolv($host, 'AAAA') );

  return ( resolv($host, 6) ) if (!$ip and $inet != 6);

  return ( wantarray? ($ip, $inet) : $ip );
}

sub dns_resolv {
  my ($host, $type) = @_;

  my @DNS_HOSTS;
  open(RSL, '/etc/resolv.conf');
  while(<RSL>) {
    push (@DNS_HOSTS, $1) if (/^\s*nameserver\s+(.+?)\s*\r*\n/);
  }
  close(RSL);

  my $res = undef;
  foreach my $DNS_HOST (@DNS_HOSTS) {
    $res = _dns_resolv($host, $type, $DNS_HOST);
    last if ($res);
  }

  return($res);
}

#########################################
# _dns_resolv and get_domain functions  #
# stolen from a great code.             #
# hole code is pasted after the __END__ #
# The original comments were kept!      #
#########################################
sub _dns_resolv {
   my ($host, $type, $dns_host) = @_;

   $type ||= 'A';

   my %type_table = ('A'     => 1,
#                     'NS'    => 2,
#                     'CNAME' => 5,
#                     'SOA'   => 6,
#                     'MB'    => 7,
#                     'MG'    => 8,
#                     'MR'    => 9,
#                     'NULL'  => 10,
#                     'WKS'   => 11,
                     'PTR'   => 12,
#                     'HINFO' => 13,
#                     'MINFO' => 14,
#                     'MX'    => 15,
#                     'TXT'   => 16,
                     'AAAA'  => 28,
                     'ANY'   => 255
                    );
   
   my $socket = IO::Socket::INET->new(PeerAddr => $dns_host, PeerPort => 53, Proto => 'udp', Timeout => 10) || return(undef);
#select(undef, undef, undef, 0.7);
#select(STDOUT);
#print STDOUT "eh.. to aki.. conectei na parada...\n";
   my $query = pack("B* n4 a* C n2", sprintf("%.23d%d%.5d",0,1,0), 1,0,0,0, join('', (map { pack('C', length($_)).$_ } (split(/\./, $host)))), 0, $type_table{uc($type)}, 1);

   $socket->send($query);

   my $data;
   my $sel = IO::Select->new($socket);
   if ($sel->can_read(6)) {
     $socket->recv($data, 10000, 0) || return(undef); # 10000
   } else { 
      return(undef);
   }

   my ($question_count, $response_count, $rest) = (unpack('nnnnnna*', $data))[2, 3, 6];

   foreach my $count ($question_count){
     my $domain;
     ($domain, $rest) = get_domain($rest, $data);
     my ($type, $class) = unpack('nn', $rest);
     substr($rest, 0, 4) = '';
   }

   my ($rdata, $type);
   for (1 .. $response_count){
      my ($domain, $class, $ttl, $rdata_length);

      ($domain, $rest) = get_domain($rest, $data);
      ($type, $class, $ttl, $rdata_length) = unpack('nnNn', $rest);
      substr($rest, 0, 10) = '';

      $rdata = substr($rest, 0, $rdata_length);
      substr($rest, 0, $rdata_length) = '';
   }

   my $rtype;
   foreach my $typet (keys(%type_table)) {
     if ($type_table{$typet} == $type) {
       $rtype = $typet;
       last;
     }
   }

   my $rdata_for_print = undef;

   if ( $rtype eq 'A' ){
     # A ¥ì¥³¡¼¥É (IPv4 ÍÑ IP ¥¢¥É¥ì¥¹)
     $rdata_for_print = inet_ntoa($rdata);

   } elsif ( $rtype eq 'AAAA' ){
       # AAAA ¥ì¥³¡¼¥É (IPv6 ÍÑ IP ¥¢¥É¥ì¥¹)
       my @couple_of_bytes = map { $_ = sprintf("%02lX", unpack('C', $_)) } split(//, $rdata);
       my @hexs;
       while (@couple_of_bytes>0){
         push(@hexs, "$couple_of_bytes[0]$couple_of_bytes[1]");
         shift @couple_of_bytes;
         shift @couple_of_bytes;
       }
       $rdata_for_print = join(':', @hexs);
       $rdata_for_print =~ s/0000:/0:/g;
       $rdata_for_print =~ s/:::+/::/g;
       $rdata_for_print =~ s/:0+([1-9a-f])/:$1/ig;

   } 

   return($rdata_for_print);
}

sub get_domain {
    my ($data, $org_data) = @_;
    my @domains = ();

    while (1){
        my $len = unpack('C', $data);

        if ( ( $len & 0xc0 ) ==  0xc0 ){
            # ¾å°Ì 2¥Ó¥Ã¥È¤¬Î©¤Ã¤Æ¤¤¤¿¤é¡¢¤â¤¦ 1¥Ð¥¤¥ÈÆɤߤ³¤à (¹ç·× 16¥Ó¥Ã¥È)¡£
            # ¤½¤·¤Æ¾å°Ì 2¥Ó¥Ã¥È¤òÍî¤È¤·¡¢»Ä¤ê 14¥Ó¥Ã¥È¤ò DNS ¥µ¡¼¥Ð¤«¤é
            # ÊÖ¤µ¤ì¤¿ UDP ¥Ç¡¼¥¿¥°¥é¥àÀèƬ¤«¤é¤Î¥ª¥Õ¥»¥Ã¥È¤È¤·¤ÆºÆµ¢¤¹¤ë¡£

            my $offset = unpack('n', $data) ^ 0xc000;
            my $new_data = substr($org_data, $offset);
            substr($data, 0, 2) = '';

            my ($domain_part)  = get_domain($new_data, $org_data);
            push(@domains, $domain_part);
            last;

        } else {
            # ¾å°Ì 2¥Ó¥Ã¥È¤¬Î©¤Ã¤Æ¤¤¤Ê¤¤¤Î¤Ç¡¢¥«¥¦¥ó¥¿¤È¤·¤Æ°·¤¦¡£
            substr($data, 0, 1) = '';
        }

        if ( $len == 0 ){
            last;
        } else {
            push(@domains, unpack("a$len", $data));
            substr($data, 0, $len) = '';
        }
    }

    # ¤³¤Î»þÅÀ¤Ç @domains = ('foo', 'example', 'com') ¤Î¤è¤¦¤Ë¤Ê¤Ã¤Æ¤¤¤ë¡£
    my $ret_domain = join('.', @domains);
    return ($ret_domain, $data);
}

##################
# Funções de log #
##################
sub LOG {
  my $msg = shift;
  my $lt = localtime(time);

  to_admin($msg) if ((defined($CONF{'LOG_TO_ADM'}) and $CONF{'LOG_TO_ADM'} == 1) or
                     (defined($CONF{'LOG_ADM_ONLY'}) and $CONF{'LOG_ADM_ONLY'} == 1));

  return(1) if (defined($CONF{'LOG_ADM_ONLY'}) and $CONF{'LOG_ADM_ONLY'} == 1);

  return(undef) unless (defined($CONF{'LOG_DIR'}));
  my $logfile = $CONF{'LOG_DIR'}."/bnc.log";
 
  open(LOG, ">> $logfile") || return(undef);
  print LOG "[$lt] $msg\n";
  close(LOG);

}

sub to_admin {
  my $msg = shift;

  foreach my $cli (keys(%CLIENT)) {
    next unless (is_admin($cli));

    my $sock = $CLIENT{$cli}->{'sock'};
    climsg($sock, "\002[Admin LOG]\002: $msg");
  }
}

sub can_log {
  my $n = shift;

  return(undef) unless(defined($CONF{'LOG_OPTS'}));

  return(1) if (grep { $_ == $n } @{$CONF{'LOG_OPTS'}});
  return(undef);
}

sub PVT_LOG {
  my ($serv, $msg) = @_;

  return(undef) unless (defined($CONF{'LOG_DIR'}));

  my $file = $CONF{'LOG_DIR'}.'/attach-'.$SERVER{$serv}->{'id'}.'.log';
  open(PVTLOG, ">> $file") || return(undef);
  print PVTLOG $msg;
  close(PVTLOG);
}

sub lost_attach_log {
  my $file = shift;

  my $new_file;
  for (my $c = 0; ; $c++) {
    $new_file = $file.".lost.$c";
    last unless (-e $new_file);
  }

  rename($file, $new_file);
}

########
# MISC #
########

sub checkmask {
  my ($mask1, $mask2) = @_;

  # M eheh pra cuncertan um trocinhu .. no caso de t * no final do host
  $mask1 = "M".$mask1."M";
  $mask2 = "M".$mask2."M";

  $mask1 =~ s/\*/\.\*\?/g;
  $mask2 =~ s/\*/\.\*\?/g;

  return(($mask1 =~ /^$mask2$/) ? 1 : undef);
}

sub clean_init {
  my $servname = shift;

  my $apaga = 1;
  foreach my $serv (keys(%SERVER)) {
    next if (!defined($SERVER{$serv}->{'servname'}) or $SERVER{$serv}->{'servname'} ne $servname);
    $apaga = undef;
    last;
  }

  delete($INIT{$servname}) if ($apaga == 1);
  return($apaga);
}

sub motd {
  my $cli = shift;
  return() if (!defined($CONF{'MOTD'}) and !(-e $CONF{'MOTD'}));

  open(MOTD, $CONF{'MOTD'}) or return();

  my $USER = get_user($cli);
  my $ll = localtime($USERS->{$USER}->{'LAST_LOG'}) if (defined($USERS->{$USER}->{'LAST_LOG'}));
  my $LASTLOG = ($ll? $ll:"nunca logou");

 
  while (<MOTD>) {
    s/\n$//;
    s/\r$//;
    s/\${USER\}/$USER/g;
    s/\$\{LASTLOG\}/$LASTLOG/g;
    s/\%\{B\}/\002/g;
    s/\%\{C\}/\003/g;

    $_ = ' ' if ($_ eq '');
    climsg($cli, $_);
  }
  close(MOTD);

  return();
}
   
sub help {
  my ($cli, $cmd) = @_;
  climsg($cli, "\002 - ".uc($cmd)." - \002");
  climsg($cli, " ");
  climsg($cli, "   \002Sobre\002: ".$HELP{$cmd}{'about'});
  climsg($cli, " ");

  if (defined($HELP{$cmd}{'help'})) {
     my $first = 1;
     foreach my $help (@{$HELP{$cmd}{'help'}}) {
       if ($first == 1) {
         climsg($cli, "   \002Ajuda\002: $help");
         $first = 0;
       } else {
         climsg($cli, (' ' x 10).$help);
       }
     }
     climsg($cli, ' ');
  }

  if (defined($HELP{$cmd}{'uso'})) {
    climsg($cli, " \002Sintaxe\002: /QUOTE ".uc($cmd)." ".$HELP{$cmd}{'uso'});
    climsg($cli, " ");
  }

}

sub fill_space {
  my ($chars, $max) = @_;
  my $filled = length($chars);
  my $space_n  = $max-$filled;
  return($chars) if ($space_n <= 0);

  my $space = " " x $space_n;

  return($space.$chars);
}

sub getservbyid {
  my ($cli, $id) = @_;

  return(undef) unless(defined($CLIENT{$cli}->{'user'}));
  my $user = $CLIENT{$cli}->{'user'};
  my $admin = is_admin($cli);

  foreach my $serv (keys(%SERVER)) {
    return($SERVER{$serv}->{'sock'}) if ($SERVER{$serv}->{'id'} == $id and ($SERVER{$serv}->{'user'} eq $user or $admin == 1));
  }

  return(undef);
}
 

sub newid {
  my %ALL = ((%SERVER), (%CLIENT), (%RECONNECT));

  my $id;
  for ($id = 1; ; $id++) {
    last if (!grep { defined($ALL{$_}->{'id'}) and $ALL{$_}->{'id'} == $id } keys(%ALL));
  }
  undef(%ALL);

  return($id);
}

# Tirei o getops do meu TocToc ehjeheh
# tah mei horrivel essa funcaum eheh depois refaco
## yeahh i know this function needs to be recoded
# I preffer to do it my way :)
sub getopts {
  # eheh a little explanation
  # the key is the same used in the return
  # the value gonna be the options to be taken from @ARGV
  # separeted by |
  # after the "," you can give these options:
  #
  # : - take next ARGV as value
  # n - numeral value
  # i - IPv4 address
  # u - delete option if it got none argument (usefull for
  #     arguments which can be 0)
  #
  # by now ... just this one is fine :) if none options specified
  # the return gonna be 1 or 0
  #
  # the key STD should has only the options made by one letter
  # like the Getopts::Std, eg:
  #
  # my %opts = getopts(a => "a", b => "b", c => "c,:", d => "d");
  #                     =
  # my %opts = getopts(STD => "abc:d");
  #
  # @{$opts{UNKNOWN}} gonna have the unknown options given by the user
  # @{$opts{MISS_VALUE}} gonna have the options which need some value
  # and it has been not given

  my %opts = @_;

  my %ret;

  if (defined($opts{STD})) {
     my @opts = split('', $opts{STD});

     for (my $c = 0; $c <= $#opts; $c++) {
       my $arg = $opts[$c];
       my $next_arg = $opts[$c+1];
       next if ($arg eq ":");
       $opts{$arg} = $arg;
       $opts{$arg} .= ",:" if ($next_arg eq ":");
     }

     delete($opts{STD});
  }

  for (my $ca = 0; $ca <= $#ARGV; $ca++) {
     my $arg = $ARGV[$ca];
     my $rarg = $arg;
     last if ($arg eq "--");
     my $next_arg = $ARGV[$ca+1];

     # if not an argument it is some value
     my ($is_arg, $next_is_arg) = (0, 0);
     $is_arg = 1 if ($arg =~ /^-{1,2}/);
     $arg =~ s/^-{1,2}//;
     $next_is_arg = 1 if ($next_arg =~ /^-{1,2}/);
     $next_arg =~ s/^-{1,2}//;

     next if ($is_arg == 0);

     my $value;
     if ($arg =~ /^(.+?)\=(.*)$/) {
        $arg = $1;
        $value = $2;
     }

     my $found = 0;
     foreach my $opt (keys(%opts)) {
        my $opt_value = $opts{$opt};

        my $get_value = 0; # if get_value == 0 is a true/false (1/0) return

        $get_value = 1 if ($opt_value =~ /\,(.*)$/);
        my @types = split('', $1);

        $opt_value =~ s/\,.*$//;


        my @get_opts = split(/\|/, $opt_value);

        if (grep { $_ eq $arg } @get_opts) {
           #delete($opts{$opt}); nahh the last value is great for me
           $found = 1;
           if ($get_value == 0) {
              $ret{$opt} = 1;
           } else {
               my $ret_value = ((defined($value)) ? $value : (defined($next_arg) ? $next_arg : undef));
               if (defined($ret_value)) {
                  if (!@types or grep { $_ eq ":" } @types) {
                    $ret{$opt} = $ret_value;
                  } else {
                     my @wrong;
                     foreach my $type (@types) {
                       my $ok = 1;
                       $ok = 0 if (
                          ($type eq "n" and $ret_value !~ /^\d+$/) or
                          ($type eq "i" and $ret_value !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/));
                          # i thing thats only by now
                       push(@wrong, $type) if ($ok == 0);
                     }

                     if (@wrong) {

                       push(@{$ret{WRONG_VALUE}}, $rarg.','.join('', @wrong)); } else {
                         $ret{$opt} = $ret_value;
                     }
                  }
#               if (defined($value)) {
#                  $ret{$opt} = $value;
#               } elsif ($next_is_arg == 0 and defined($next_arg)) {
#                   $ret{$opt} = $next_arg;
               } else {
                   push(@{$ret{MISS_VALUE}}, $rarg);
               }
           }
        } else {
           delete($ret{$opt}) if (not defined($ret{$opt}) and grep { $_ eq 'u' } @types);
        }
     }
     push(@{$ret{UNKNOWN}}, $rarg) if ($found == 0);
  }

  return(%ret);
}


__END__

I reeaaly liked that code
so i pasted it here
thats where i get the resolv stuff

<--- cute here -->
#!/usr/local/bin/perl -w

# $Id: resolver-1.pl,v 1.2 2003/10/04 15:23:24 68user Exp $

#-------------------------------------------------------------
package QR;

sub Query    { 0 }
sub Response { 1 }

my %qr_table = (0 => '¼ÁÌä',
                1 => '±þÅú'
                );

sub getName {
    my ($code) = @_;
    defined $qr_table{$code} ? $qr_table{$code} : '??';
}

#-------------------------------------------------------------
package OPCODE;

sub StandardQuery       { 0 };
sub InverseQuery        { 1 };
sub ServerStatusRequest { 2 };

my %opcode_table = (0 => 'ɸ½à¾È²ñ',
                    1 => 'µÕ¾È²ñ',
                    2 => '¥µ¡¼¥Ð¥¹¥Æ¡¼¥¿¥¹¾È²ñ',
                    );

sub getName {
    my ($code) = @_;
    defined $opcode_table{$code} ? $opcode_table{$code} : '??';
}

#-------------------------------------------------------------
package AA;

my %aa_table = (0 => '¸¢°Ò¤Î¤Ê¤¤²óÅú',
                1 => '¸¢°Ò¤Î¤¢¤ë²óÅú',
                );

sub getName {
    my ($code) = @_;
    defined $aa_table{$code} ? $aa_table{$code} : '??';
}

#-------------------------------------------------------------
package TC;

sub NotTruncated { 0 }
sub Truncated    { 1 }

my %tc_table = (0 => 'Èóʬ³ä',
                1 => 'ʬ³ä',
                );

sub getName {
    my ($code) = @_;
    defined $tc_table{$code} ? $tc_table{$code} : '??';
}

#-------------------------------------------------------------
package RD;

sub RecursionNotDesire { 0 }
sub RecursionDesire    { 1 }

my %rd_table = (0 => 'ÈóºÆµ¢Í×µá',
                1 => 'ºÆµ¢Í×µá',
                );

sub getName {
    my ($code) = @_;
    defined $rd_table{$code} ? $rd_table{$code} : '??';
}


#-------------------------------------------------------------
package RA;

my %ra_table = (0 => 'ºÆµ¢²Äǽ',
                1 => 'ºÆµ¢ÉÔ²Äǽ',
);

sub getName {
    my ($code) = @_;
    defined $ra_table{$code} ? $ra_table{$code} : '??';
}

#-------------------------------------------------------------
package RCODE;

my %rcode_table = (0 => '¥¨¥é¡¼¤Ê¤·',
                   1 => '¥Õ¥©¡¼¥Þ¥Ã¥È¥¨¥é¡¼',
                   2 => '¥µ¡¼¥Ð¦¥¨¥é¡¼',
                   3 => '¥Í¡¼¥à¥¨¥é¡¼',
                   4 => '̤¼ÂÁõ',
                   5 => 'µñÈÝ',
);

sub getName {
    my ($code) = @_;
    defined $rcode_table{$code} ? $rcode_table{$code} : "??";
}

#-------------------------------------------------------------
package TYPE;

sub A     { 1  }
sub NS    { 2  }
sub CNAME { 5  }
sub SOA   { 6  }
sub MB    { 7  }
sub MG    { 8  }
sub MR    { 9  }
sub NULL  { 10 }
sub WKS   { 11 }
sub PTR   { 12 }
sub HINFO { 13 }
sub MINFO { 14 }
sub MX    { 15 }
sub TXT   { 16 }
sub AAAA  { 28 }
sub ANY   { 255 }

my %type_table = (1   => 'A',
                  2   => 'NS',
                  5   => 'CNAME',
                  6   => 'SOA',
                  7   => 'MB',
                  8   => 'MG',
                  9   => 'MR',
                  10  => 'NULL',
                  11  => 'WKS',
                  12  => 'PTR',
                  13  => 'HINFO',
                  14  => 'MINFO',
                  15  => 'MX',
                  16  => 'TXT',
                  28  => 'AAAA',
                  255 => 'ANY',
                  );

my %type_code2name;
my %type_name2code;
foreach my $code (keys %type_table){
    my ($name) = $type_table{$code};
    $type_code2name{$code} = $name;
    $type_name2code{$name} = $code;
}

sub getName {
    my ($code) = @_;
    return $type_code2name{$code};
}

sub getCode {
    my ($name) = @_;
    $name =~ tr/a-z/A-Z/;
    return $type_name2code{$name};
}


#-------------------------------------------------------------
package CLASS;

sub Internet { 1 }
sub CSNET    { 2 }
sub CHAOS    { 3 }
sub Hesiod   { 4 }
sub Any      { 5 }

my %class_table = (1 => 'INTERNET',
                   2 => 'CSNET',
                   3 => 'CHAOS',
                   4 => 'HESIOD',
                   5 => 'ANY',
                   );

my %class_name2code;
foreach my $code (keys %class_table){
    my ($name) = $class_table{$code};
    $class_name2code{$name} = $code;
}

sub getName {
    my ($code) = @_;
    return $class_table{$code};
}

sub getCode {
    my ($name) = @_;
    $name =~ tr/a-z/A-Z/;
    return $class_name2code{$name};
}




#-------------------------------------------------------------
package main;

use strict;
use Socket;

if ( @ARGV < 2 || 4 < @ARGV ){
    print "¤ª¼êÀ½¥ê¥¾¥ë¥Ð\n";
    print "½ñ¼°: DNS¥µ¡¼¥Ð̾ ̾Á°²ò·è¥Û¥¹¥È̾ [¾È²ñ¥¿¥¤¥×] [¾È²ñ¥¯¥é¥¹]\n";
    print "    ¾È²ñ¥¿¥¤¥×: A, NS, CNAME, MX, TXT, AAAA ¤Ê¤É¡£¾Êά»þ¤Ï A¡£\n";
    print "    ¾È²ñ¥¯¥é¥¹: Internet, CHAOS ¤Ê¤É¡£¾Êά»þ¤Ï Internet¡£\n";
    exit;
}

                # ÀܳÀè¥Û¥¹¥È̾¤ò¼èÆÀ
my $dns_host = shift @ARGV;

                # ̾Á°²ò·è¤ò¹Ô¤¦¥Û¥¹¥È̾¤ò¼èÆÀ
my $query_host = shift @ARGV;

my $type_arg  = shift @ARGV || 'A';
my $class_arg = shift @ARGV || 'INTERNET';

my $type  = TYPE::getCode($type_arg);
if ( ! defined $type ){
    print "¥¿¥¤¥× $type_arg ¤ÏÉÔÀµ¤Ç¤¹¡£\n";
    exit 1;
}
my $class = CLASS::getCode($class_arg);
if ( ! defined $class ){
    print "¥¯¥é¥¹ $class_arg ¤ÏÉÔÀµ¤Ç¤¹¡£\n";
    exit 1;
}

                # ÀܳÀè¥Ý¡¼¥ÈÈÖ¹æ¤ò¼èÆÀ
my $dns_port =  getservbyname('domain', 'udp') || 53;

                # ¥Û¥¹¥È̾¤ò¡¢IP ¥¢¥É¥ì¥¹¤Î¹½Â¤ÂΤËÊÑ´¹
my $iaddr = inet_aton($dns_host)
        or die "$dns_host ¤Ï¸ºß¤·¤Ê¤¤¥Û¥¹¥È¤Ç¤¹¡£\n";

                # ¥Ý¡¼¥ÈÈÖ¹æ¤È IP ¥¢¥É¥ì¥¹¤ò¹½Â¤ÂΤËÊÑ´¹
my $sock_addr = pack_sockaddr_in($dns_port, $iaddr);

                # ¥½¥±¥Ã¥ÈÀ¸À®
socket(SOCKET, PF_INET, SOCK_DGRAM, 0)
        or die "¥½¥±¥Ã¥È¤òÀ¸À®¤Ç¤­¤Þ¤»¤ó¡£$!";

my $query = make_query($type, $class);

if ( ! send(SOCKET, $query, 0, $sock_addr) ){
    die "send ¤Ë¼ºÇÔ¤·¤Þ¤·¤¿ $!";
}

my $rcv_data;
recv(SOCKET, $rcv_data, 10000, 0) || die "$!";

parse_response($rcv_data);

exit 0;



#-------------------------------------------------------------
# DNS ¥µ¡¼¥Ð¤ËÁ÷¤ë query ¤òºîÀ®¤·¡¢ÊÖ¤¹¡£

sub make_query {
    my ($type, $class) = @_;

    # ¼±ÊÌ»ÒÀßÄê
    my $id = pack('B16', '0000000000000000');

    # ¥Õ¥é¥°¤ò¹½À®¤¹¤ë³ÆÍ×ÁǤòÀßÄê
    my $qr     = QR::Query;             # 0:¼ÁÌä
    my $opcode = OPCODE::StandardQuery; # 0:ɸ½à¾È²ñ
    my $aa     = 0;                     # Authoritative Answer (±þÅú»þ¤Ë¥»¥Ã¥È)
    my $tc     = TC::NotTruncated;      # 0:Èóʬ³ä
    my $rd     = RD::RecursionDesire;   # 1:ºÆµ¢¾È²ñ
    my $ra     = 0;                     # Recursion Available (±þÅú»þ¤Ë¥»¥Ã¥È)
    my $rcode  = 0;                     # Response Code (±þÅú»þ¤Ë¥»¥Ã¥È)

    # ¥Õ¥é¥° (0 ¤È 1 ¤Îʸ»úÎó)
    my $flg_binary = sprintf("%d%04d%d%d%d%d%03d%d",
                             $qr,
                             $opcode,
                             $aa,
                             $tc,
                             $rd,
                             $ra,
                             0,
                             $rcode);

    # ¥Õ¥é¥° (2¥Ð¥¤¥È¤Î¥Ð¥¤¥Ê¥ê)
    my $flg = pack("B16", $flg_binary);

    # ¼ÁÌä¿ô¤Î¤ß 1¡£²óÅú¿ô¡¢¸¢°Ò¿ô¡¢ÄɲþðÊó¿ô¤Ï¤¤¤º¤ì¤â 0¡£
    my $question_count = pack('n', 1);
    my $response_count  = pack('n', 0);
    my $auth_count = pack('n', 0);
    my $ext_count = pack('n', 0);

    # foo.example.com ¤È¤¤¤¦¥Û¥¹¥È̾¤ò 3foo7example3com ¤È¤¤¤¦·Á¤ËÊÑ´¹¡£
    my $query_name = &make_domain($query_host);

    # ¾È²ñ¥¿¥¤¥×¡¦¾È²ñ¥¯¥é¥¹¤òÀßÄê
    my $query_type  = pack('n', $type);
    my $query_class = pack('n', $class);

    # ¼ÁÌä¤Ï¡Ö¾È²ñ̾+¾È²ñ¥¿¥¤¥×+¾È²ñ¥¯¥é¥¹¡×¤«¤é¤Ê¤ë¡£
    my $question = $query_name.$query_type.$query_class;

    # ¥ê¥¯¥¨¥¹¥È¤Ï¡Ö¼±ÊÌ»Ò+¥Õ¥é¥°+¼ÁÌä¿ô+²óÅú¿ô+¸¢°Ò¿ô+ÄɲþðÊó¿ô+¼ÁÌä¡×¤«¤é¤Ê¤ë¡£
    my $request = $id.$flg.$question_count.$response_count.$auth_count.$ext_count.$question;

    return $request;
}




#-------------------------------------------------------------
# DNS ¥µ¡¼¥Ð¤«¤éÊÖ¤µ¤ì¤¿¥Ç¡¼¥¿¤ò²òÀϤ·¡¢É½¼¨¡£

sub parse_response {
    my ($org_dgram) = @_;

    my $hr_line = "=========================================\n";

    # ¼±Ê̻ҡ¦¥Õ¥é¥°¡¦¼ÁÌä¿ô¡¦²óÅú¿ô¡¦¸¢°Ò¿ô¡¦ÄɲþðÊó¿ô¤òɽ¼¨

    my ($id, $flg, $question_count, $response_count, $auth_count, $ext_count, $rest)
      = unpack('nnnnnna*', $org_dgram);

    # ¥Õ¥é¥°¤ò³Æ¥Ó¥Ã¥È¤Ëʬ²ò
    my $qr     = ($flg >>15) & 0x01; # ºÇ¾å°Ì  1¥Ó¥Ã¥ÈÌܤ«¤é 1¥Ó¥Ã¥È¼èÆÀ
    my $opcode = ($flg >>11) & 0x07; # ºÇ¾å°Ì  2¥Ó¥Ã¥ÈÌܤ«¤é 3¥Ó¥Ã¥È¼èÆÀ
    my $aa     = ($flg >>10) & 0x01; # ºÇ¾å°Ì  5¥Ó¥Ã¥ÈÌܤ«¤é 1¥Ó¥Ã¥È¼èÆÀ
    my $tc     = ($flg >> 9) & 0x01; # ºÇ¾å°Ì  6¥Ó¥Ã¥ÈÌܤ«¤é 1¥Ó¥Ã¥È¼èÆÀ
    my $rd     = ($flg >> 8) & 0x01; # ºÇ¾å°Ì  7¥Ó¥Ã¥ÈÌܤ«¤é 1¥Ó¥Ã¥È¼èÆÀ
    my $ra     = ($flg >> 7) & 0x01; # ºÇ¾å°Ì  8¥Ó¥Ã¥ÈÌܤ«¤é 1¥Ó¥Ã¥È¼èÆÀ
    my $rcode  =  $flg       & 0x0f; # ºÇ¾å°Ì 12¥Ó¥Ã¥ÈÌܤ«¤é 4¥Ó¥Ã¥È¼èÆÀ

    printf "¼±ÊÌ»Ò(Id): 0x%04lx\n", $id;
    printf "¥Õ¥é¥°: 0x%04lx\n", $flg;
    printf "    QR (Query/Response): %s (%s)\n", $qr, QR::getName($qr);
    printf "    OPCODE: %s (%s)\n", $opcode, OPCODE::getName($opcode);
    printf "    AA (Authoritative Answer): %s (%s)\n", $aa, AA::getName($aa);
    printf "    TC (TrunCation): %s (%s)\n", $tc, TC::getName($tc);
    printf "    RD (Recursion Desired): %s (%s)\n", $rd, RD::getName($rd);
    printf "    RA (Recursion Available): %s (%s)\n", $ra, RA::getName($ra);
    printf "    RCODE (Response code): %s (%s)\n", $rcode, RCODE::getName($rcode);
    printf "¼ÁÌä¿ô: $question_count\n";
    printf "²óÅú¿ô: $response_count\n";
    printf "¸¢°Ò¿ô: $auth_count\n";
    printf "ÄɲþðÊó¿ô: $ext_count\n";
    print $hr_line;

    # ¼ÁÌä¤Î¿ô¤À¤±¼ÁÌä¤ò²òÀϤ·¡¢É½¼¨

    foreach my $count ($question_count){
        my $domain;
        ($domain, $rest) = get_domain($rest, $org_dgram);
        my ($type, $class) = unpack('nn', $rest);
        substr($rest, 0, 4) = '';

        printf "¼ÁÌä: ¥É¥á¥¤¥ó̾: %s\n", $domain;
        printf "¼ÁÌä: ¥¿¥¤¥×: %d (%s)\n", $type, TYPE::getName($type);
        printf "¼ÁÌä: ¥¯¥é¥¹: %d (%s)\n", $class, CLASS::getName($class);
        print $hr_line;
    }

    my @rrs = (
               ['²óÅú', $response_count],
               ['¸¢°Ò', $auth_count],
               ['ÄɲþðÊó', $ext_count],
              );

    foreach my $ref_array (@rrs){
        my ($desc, $count) = @$ref_array;

        foreach (1 .. $count){
            my $domain;

            ($domain, $rest) = get_domain($rest, $org_dgram);
            my ($type, $class, $ttl, $rdata_length) = unpack('nnNn', $rest);
            substr($rest, 0, 10) = '';

            printf "$desc($_): ¥É¥á¥¤¥ó̾: %s\n", $domain;
            printf "$desc($_): ¥¿¥¤¥×: %d (%s)\n", $type, TYPE::getName($type);
            printf "$desc($_): ¥¯¥é¥¹: %d (%s)\n", $class, CLASS::getName($class);
            printf "$desc($_): À¸Â¸»þ´Ö(TTL): $ttl (ÉÃ)\n";
            printf "$desc($_): ¥ê¥½¡¼¥¹¥Ç¡¼¥¿Ä¹: $rdata_length (¥Ð¥¤¥È)\n";
        
            # ¥ê¥½¡¼¥¹¥Ç¡¼¥¿¼èÆÀ
            my ($rdata) = substr($rest, 0, $rdata_length);
            substr($rest, 0, $rdata_length) = '';

            # ¥¿¥¤¥×¤Ë±þ¤¸¤Æ¥ê¥½¡¼¥¹¥Ç¡¼¥¿¤Î²òÀÏÊýË¡¤òÊѤ¨¤ë

            my $rdata_for_print;

            if ( $type == TYPE::A ){
                # A ¥ì¥³¡¼¥É (IPv4 ÍÑ IP ¥¢¥É¥ì¥¹)
                $rdata_for_print = inet_ntoa($rdata);

            } elsif ( $type == TYPE::AAAA ){
                # AAAA ¥ì¥³¡¼¥É (IPv6 ÍÑ IP ¥¢¥É¥ì¥¹)
                my @couple_of_bytes = map { $_ = sprintf("%02lX", unpack('C', $_)) } split(//, $rdata);
                my @hexs;
                while (@couple_of_bytes>0){
                    push(@hexs, "$couple_of_bytes[0]$couple_of_bytes[1]");
                    shift @couple_of_bytes;
                    shift @couple_of_bytes;
                }
                $rdata_for_print = join(':', @hexs);
                $rdata_for_print =~ s/0000:/:/g;
                $rdata_for_print =~ s/:::+/::/g;
                $rdata_for_print =~ s/:0+([1-9A-F])/:$1/g;

            } elsif ( $type == TYPE::MX ){
                # MX ¥ì¥³¡¼¥É
                my ($preference, $mx) = unpack('na*', $rdata);
                my ($mx_domain) = get_domain($mx, $org_dgram);
                $rdata_for_print = "Preference: $preference  MX: $mx_domain";

            } elsif ( $type == TYPE::NS ){
                # ¸¢°Ò¤¢¤ë¥Í¡¼¥à¥µ¡¼¥Ð
                my ($ns_domain) = get_domain($rdata, $org_dgram);
                $rdata_for_print = $ns_domain;

            } elsif ( $type == TYPE::PTR ){
                # µÕ°ú¤­
                my ($ptr_domain) = get_domain($rdata, $org_dgram);
                $rdata_for_print = $ptr_domain;

            } elsif ( $type == TYPE::CNAME ){
                # ÊÌ̾
                my ($cname_domain) = get_domain($rdata, $org_dgram);
                $rdata_for_print = $cname_domain;

            } elsif ( $type == TYPE::TXT ){
                # ¥Æ¥­¥¹¥È
                $rdata_for_print = $rdata;

            } else {
                $rdata_for_print = '¤³¤Î¥¿¥¤¥×¤Î¥ê¥½¡¼¥¹²òÀϤÏ̤¼ÂÁõ¤Ç¤¹';
            }

            printf "$desc($_): ¥ê¥½¡¼¥¹¥Ç¡¼¥¿: %s\n", $rdata_for_print;

            print $hr_line;
        }
    }
}



#-------------------------------------------------------------
# foo.example.com ¤Î¤è¤¦¤Ê¥Û¥¹¥È̾¤ò 3foo7example3com0 ¤È¤¤¤¦
# ·Á¤ËÊÑ´¹¤·¡¢ÊÖ¤¹¡£

sub make_domain {
    my ($org_host) = @_;
    my $host = '';
    foreach ( split(/\./, $org_host) ){
        $host .= pack('C', length($_)) . $_;
    }
    $host .= pack('C', 0);
    return $host;
}



#-------------------------------------------------------------
# 3foo7example3com0 ¤È¤¤¤¦¤è¤¦¤Ê¥Ç¡¼¥¿¤ò foo.example.com ¤Î
# ¤è¤¦¤Ê¥Û¥¹¥È̾¤ËÊÑ´¹¤·¡¢ÊÖ¤¹¡£
#
# °ú¿ô $data ¤Ï 3foo7example3com0 ¤È¤¤¤¦¥Ç¡¼¥¿¤ò»Ø¤¹¡£
# °ú¿ô $org_data ¤Ï DNS ¥µ¡¼¥Ð¤«¤éÊÖ¤µ¤ì¤¿ UDP ¥Ç¡¼¥¿¥°¥é¥àÁ´ÂΡ£
# 
# Ìá¤êÃÍ¤Ï 2¤Ä¡£
#   1. ²òÀϤ·¤¿¥Û¥¹¥È̾
#   2. $data ¤«¤éÀèƬ¤Î 3foo7example3com0 ¤ò¼è¤ê½ü¤¤¤¿»Ä¤ê¤ÎÉôʬ

sub get_domain {
    my ($data, $org_data) = @_;
    my @domains = ();

    while (1){
        my $len = unpack('C', $data);

        if ( ( $len & 0xc0 ) ==  0xc0 ){
            # ¾å°Ì 2¥Ó¥Ã¥È¤¬Î©¤Ã¤Æ¤¤¤¿¤é¡¢¤â¤¦ 1¥Ð¥¤¥ÈÆɤߤ³¤à (¹ç·× 16¥Ó¥Ã¥È)¡£
            # ¤½¤·¤Æ¾å°Ì 2¥Ó¥Ã¥È¤òÍî¤È¤·¡¢»Ä¤ê 14¥Ó¥Ã¥È¤ò DNS ¥µ¡¼¥Ð¤«¤é
            # ÊÖ¤µ¤ì¤¿ UDP ¥Ç¡¼¥¿¥°¥é¥àÀèƬ¤«¤é¤Î¥ª¥Õ¥»¥Ã¥È¤È¤·¤ÆºÆµ¢¤¹¤ë¡£

            my $offset = unpack('n', $data) ^ 0xc000;
            my $new_data = substr($org_data, $offset);
            substr($data, 0, 2) = '';

            my ($domain_part)  = get_domain($new_data, $org_data);
            push(@domains, $domain_part);
            last;

        } else {
            # ¾å°Ì 2¥Ó¥Ã¥È¤¬Î©¤Ã¤Æ¤¤¤Ê¤¤¤Î¤Ç¡¢¥«¥¦¥ó¥¿¤È¤·¤Æ°·¤¦¡£
            substr($data, 0, 1) = '';
        }

        if ( $len == 0 ){
            last;
        } else {
            push(@domains, unpack("a$len", $data));
            substr($data, 0, $len) = '';
        }
    }

    # ¤³¤Î»þÅÀ¤Ç @domains = ('foo', 'example', 'com') ¤Î¤è¤¦¤Ë¤Ê¤Ã¤Æ¤¤¤ë¡£
    my $ret_domain = join('.', @domains);
    return ($ret_domain, $data);
}