#!/usr/bin/perl -w
#
# ircmap.pl - v0.95
#
# Make some pretty image with tree of IRC network
#
# (c) Petr Baudis <pasky@pasky.ji.cz> 2001
# No warranty, and so on... distributed under GPL.
# Get it on http://pasky.ji.cz/~pasky/irc
#
# Known problems: on EFnet, you have to set $unmask to 0,
#		  if you won't /oper this script ;-)
#		  (if you'll, please tell me and i will send
#		  you really _special_ version ;-)))
#
# $1 - irc server where we should connect to
# $2 - port of that server
# Defaults to TAIN's hub server
#
# Output: tree, then comments with prefix |, date with !, and lusers with &
#
# Note that this script is writing about his start and end to channel #debug.
# This channel is freely available and this output is done just for my curiosity
# and statistical reasons. Feel free removing it, but if it is not neccessary,
# please keep it there. Thank you. TODO: remove this in final version
#

use Data::Dumper;
use Socket;
use IO::Handle;

###############################################################################
#
# Defaults:
#
## Connection
$dserver = "irc.wilbury.sk";
$dport = "6667";
## Scanning
$unmask = 1;  # if 1, we'll try to unmask *.something servers (see bellow)
	      #       this can be a really BIG (2000% or more on IRCnet
	      #       [not a typo]) slowdown and make problems while desyncs
	      #       and so, but it is just lame w/o it :-)
	      # if 0, we'll leave them as they are - fast, robust and lame
## Appearance
$classic = 0; # if 1, we'll put the masked servers _under_ *.mask
	      #       |--*.sk
	      #       |   |--*.cz (desync)
	      #       |   `--nextra.irc.sk
	      #       |        `--...
              # if 0, we'll put the hub prior the *.mask (will be in brackets):
	      #       |--nextra.irc.sk (*.sk)
	      #       |    |--*.cz (desync)
	      #       |    `--...
	      # (note that some other mapping scripts are broken with this, but
	      # this one shouldn't be ;-) (thx 2 pht)
$brackets =1; # if 0, we'll follow the classic appearance, as above
              # if 1, we'll enclose the server name into []:
	      #       |--[nextra.irc.sk] *.sk
	      #       |    |--[*.cz] desync
	      #       |    `--[...]
$servern = 0; # if 0, we will not display anything more
              # if 1, we will display the server name (it looks like just a mess)

###############################################################################
#
# If you are not interested in code itself, you should stop here.
#
###############################################################################
#
# And now a bit of needed ugly stuff:
#

my $SOCK = IO::Handle->new();
$SOCK->autoflush(1);
$|=1;

$remote  = shift || $dserver;
$port    = shift || $dport;
$iaddr   = inet_aton($remote) || die "Server not found: $remote";
$paddr   = sockaddr_in($port, $iaddr);
$proto   = getprotobyname('tcp');

socket($SOCK, PF_INET, SOCK_STREAM, $proto) || die "Cannot create socket: $!";
connect($SOCK, $paddr) || die "Cannoct connect: $!";

rand_nick();

print $SOCK "USER mapper mapper mapper :IRC network map generator\015\012";
print $SOCK "NICK $nick\015\012";

# $lusers="&The IRC network status (in the time of scan's start):\n";

while (defined($IN=<$SOCK>)) {
#  print $IN;
  chomp($IN);
  @input=split(/ /, $IN);
  if ($input[1] =~ /^\d{3}$/) {
  if ($input[1] == 433) { rand_nick(); print $SOCK "NICK $nick\015\012";
#  } elsif ($input[1] > 250 and $input[1] < 255 or $input[1] == 266) {
#           $lusers.='&'.join(' ', splice(@input,3))."\n";
  } elsif ($input[1] == 376) { print $SOCK "PRIVMSG #debug :map on ($port/$unmask/$classic)\015\012"; last;
  } }
}
#$lusers=~ s/[\n^](.*):/$1/g;
    
$time_start=localtime();
$mask="*";
scan_links(); $root=$lroot;

if ($unmask) { for($msk=0; $msk<@masks; $msk++) {
  $mask=$masks[$msk];
  $lroot=undef;
  scan_links($mask);
  if ($lroot) { if ($classic) {
    $map->{$lroot}->{"root"}=$mask;
    push(@{$map->{$mask}->{"leaf"}}, $lroot);
  } else {
    $map->{$lroot}->{"root"}=$map->{$mask}->{"root"};
    $map->{$lroot}->{"mask"}=$mask;
    scan_mask($mask);
    $cnt=0;
    debugmsg("--find $mask\n");
    foreach $leafs (@{$map->{$map->{$mask}->{"root"}}->{"leaf"}}) {
      debugmsg("$leafs($cnt) ");
      if ($leafs eq $mask) {
        debugmsg("--found $mask - @{$map->{$map->{$mask}->{root}}->{leaf}}->[$cnt]-- ");
	@{$map->{$map->{$mask}->{"root"}}->{"leaf"}}->[$cnt]=$lroot;
      }
      $cnt++;
     }# print "\n";
  } }
  sleep(15);
} }

$time_end=localtime();

print $SOCK "PRIVMSG #debug :map off\015\012QUIT\015\012";
close ($SOCK) || die "Cannot close socket: $!";

# print Dumper($map);

###############################################################################
#
# Start printing the root branch
#

print "$root";
if ($servern) { print $servername->{$root}; }
print "\n";
print_branch($root, 0, qw(1));

print "
|
|--
|
!Generated between $time_start and $time_end
|
";# $lusers|
 print <<EOF;
|ircmap.pl (c) pasky <pasky\@pasky.ji.cz>
|Another author: yanek <janek\@isse.lipniknb.cz>
|
|Free to download under GPL at http://pasky.ji.cz/~pasky/irc
|
|Many thanks to jv, pht and nico.
|Any tips/fixes really welcomed. Tested on IRCnet and TAIN (hybrid net),
|known not to work on Undernet.
EOF

sub debugmsg {
#  my($msg);
#  $msg=join(" ", @_);
#  print $SOCK "PRIVMSG #debug :$msg\015\012";
#  print ">>> PRIVMSG #debug :$msg\015\012";
}

###############################################################################
#
# Generate a random nick
# @_: -nothing-
# uses (== writes to) the global variable $nick
#

sub rand_nick {
  $nick='q';
  for ($i=1; $i<9; $i++) { $nick.=chr(65+rand(31)); }
}

###############################################################################
#
# Scan the server's links
# @_: -nothing-
# uses the global variable $lroot and @masks
#

sub scan_links {
  my (@input, $IN);
  debugmsg("links $mask $mask");
  print $SOCK "LINKS $mask $mask\015\012";
  while (defined($IN=<$SOCK>)) {
#    print $IN;i
    chomp($IN);
    @input=split(/ /, $IN);
    debugmsg("got input - @input");
    if ($input[0] eq 'PING') { print $SOCK "PONG $input[1]\015\012";
                               $map->{$mask}->{"note"}="lagged"; last;
    } elsif ($input[1] eq '364') {
      if ($input[5] ne ":0") {
        $map->{$input[3]}->{"root"}=$input[4];
        push(@{$map->{$input[4]}->{"leaf"}}, $input[3]); 
	debugmsg("$input[3] <- $input[4]");
        if ( $input[3] =~ /\*/ ) { $masks[@masks]=$input[3]; debugmsg("$input[3] is a mask"); }
      } else {
        $lroot=$input[3];
	debugmsg("$lroot - found root");
      }
      if ($servern) {
        $servername->{$input[3]}=join(" ",splice(@input,6));
        $servername->{$input[3]}=~s/\r//;
      }
    } elsif ($input[1] eq '263') { sleep 5; print $SOCK "LINKS $mask $mask\015\012";
    } elsif ($input[1] eq '402') { $map->{$mask}->{"note"}="split"; last;
    } elsif ($input[1] eq '365') { last;
    } else { debugmsg("got unknown from server - $IN");
    }
  }
}

###############################################################################
#
# Scan the mask's downlinks
# @_: -nothing-
# uses the global variable $lroot and @masks
#

sub scan_mask {
  my (@input, $IN, $remask);
  $remask=$mask.'$'; $remask=~s/\./\\./; $remask=~s/\*/.*/;
  debugmsg("links $mask * [$lroot | $remask]");
  print $SOCK "LINKS $mask *\015\012";
  while (defined($IN=<$SOCK>)) {
#    print $IN;
    chomp($IN);
    @input=split(/ /, $IN);
    debugmsg("got input - @input");
    if ($input[0] eq 'PING') { print $SOCK "PONG $input[1]\015\012";
                               $map->{$mask}->{"note"}="lagged"; last;
    } elsif ($input[1] eq '364') {
      if ($input[5] ne ":0" and ($input[4]=~/$remask/ and member($input[3],@{$map->{$mask }->{"leaf"}})+1)) {
        $map->{$input[3]}->{"root"}=$input[4];
        push(@{$map->{$input[4]}->{"leaf"}}, $input[3]); 
	debugmsg("$input[3] <<- $input[4]");
      }
      if ($servern) {
        $servername->{$input[3]}=join(" ",splice(@input,6));
        $servername->{$input[3]}=~s/\r//;
      }
    } elsif ($input[1] eq '263') { sleep 5; print $SOCK "LINKS $mask *\015\012";
    } elsif ($input[1] eq '402') { $map->{$mask}->{"note"}="split"; last;
    } elsif ($input[1] eq '365') { last;
    } else { debugmsg("got unknown from server - $IN");
    }
  }
}

###############################################################################
#
# Paint the tree's branch - has to be re-entrant
# @_: <root-server> <level>
# uses the global variable @branches
#

sub print_branch {
  my ($field, $no);
  $no=0;
  foreach $field (@{$map->{$_[0]}->{"leaf"}}) {
    $no++; $branches[$_[1]]=0;
    spaces($_[1]);
    if ($no < @{$map->{$_[0]}->{"leaf"}})
    { $branches[$_[1]]=1; } else { $branches[$_[1]]=0; }
    if ($no < @{$map->{$_[0]}->{"leaf"}}) { print '|'; } else { print '`'; }
    if ($brackets) { print "--[$field] "; } else { print "--$field "; }
    if ($map->{$field}->{mask} || $map->{$field}->{note}) {
      if ($map->{$field}->{mask} && $map->{$field}->{note}) { $map->{$field}->{mask}.=' '; }
      if (! $brackets) { print '('; } print $map->{$field}->{mask}.$map->{$field}->{note};
      if (! $brackets) { print ')'; }
    }
    if ($servern) { print $servername->{$field}; }
    print "\n"; print_branch($field, $_[1]+1);
  }
}

###############################################################################
#
# Indent the tree's branch
# @_: <level>
#

sub spaces {
  my ($c);
  for ($c=0; $c<=$_[0]; $c++) {
    if ($c == 0) { print '  '; } else { print '    '; }
    if ($branches[$c]) { print '|'; }
  }
}

###############################################################################
#
# member of an array?
#

sub member {
  my($pos, $f);
  $f=shift;
  for ($pos=0; $pos<@_; $pos++) { if (uc( $_[$pos] )eq uc $f) { return $pos; } }
  debugmsg("-- $f not a member of @_");
  return -1;
}

###############################################################################
#
# No more interesting stuff :-(r)
#