#!/usr/bin/perl
#
# ircmap.pl - v0.99
#
# Make a pretty image with tree of some IRC network
#
# (c) Petr Baudis <pasky@pasky.ji.cz> 2001
#
# Other authors: yanek <janek@isse.lipniknb.cz>
#        Thanks: ZZyZZ, ArcAngel, Trabucc0, istari
#		 jv, pht, nico
#
# 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 ;-), ditto on Undernet
#		  - i suppose there are still bugs in the scanning code
#		    (a lot of them fixed in rel 0.99) - please report me
#		    them along with the dump of map ($debug=1, /tmp/dump-pid)
#		    and short explanation what should be connected, if
#		    possible. this is messy messy messy :-)
#		  - you won't be pleased by the result if neetwork will
#		    reroute while scanning - some links may be broken
#
# TODO: - optimalization stuff -- perform only one LINKS per mask
#	- or better complete rewrite - a lot of historic unnecessary stuff
#	- nicer diagrams -- this is too messy
#	- sanization of the code ;-)
#	- IRCnet services for scanning would be nice
#	- ...insert your wish here...
#
# Output: tree, then comments with prefix |, date with !, and lusers with &
#
#         if -g or $gif_output defined, graphviz diagram (see comment near
#	  $gif_output definition for details) will be produced too
#
# You shouldn't run this script as root for the obvious security reasons.
#
# You need to have (as with a lot of my other scripts) IHash.pm
# (case-insensitive hash support) module also now. Please download it at
# http://pasky.ji.cz/~pasky/cp/IHash.pm.
#
# 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.
#


###############################################################################
#
# Defaults:
#
## Connection
$remote = "irc.wilbury.sk";
$port = "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
	      # 0 is actually untested! 1 won't work with masks on ircu
## 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)
	      # $classic == 1 may be malfunctional currently... it is deprecated
	      # and untested now
$brackets =1; # if 0, we'll follow the classic appearance, as above
              # if 1, we'll enclose the server name into [] (not the root):
	      #       |--[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)
$gif_output="ircmap.gif";
	      # where to save gif diagram of the network...
$gif_form=undef;
	      # the form of generated diagram... Do NOT set this
	      # value unless you have GraphViz (http://www.research.att.com/sw/tools/graphviz/)
	      # installed... If you have, set it as 'neato' or 'dot'.

use lib "/home/pasky/perl.progs";
	      # replace with the dir where you've IHash.pm (http://pasky.ji.cz/~pasky/cp/IHash.pm)

###############################################################################
#
# If you are not interested in code itself, you should stop here.
#
###############################################################################
#
# Details:
$ve="0.99";
$ver="ircmap-$ve";
use Socket;
use IO::Handle;
use IHash;
$debug=0;
if ($debug) { use Data::Dumper; }
#
# And now a bit of needed ugly stuff:
#

while ($switch=shift) {
  if ($switch eq '-s') {
    $remote=shift;
  } elsif ($switch eq '-p') {
    $port=shift;
  } elsif ($switch eq '-g') {
    $gif_output=shift;
  } elsif ($switch eq '-f') {
    $gif_form=shift;
  } elsif ($switch eq '-h') {
    print <<EOT;
$ver (c) Peter Baudis <pasky\@pasky.ji.cz> 2001 - maps irc network
Usage: $0 [-s <server>] [-p <port>] [-g <gif_file>] [-f <gif_form>] [-h]

-s	Name of the server to connect to
-p	Port of the server to connect to
-g	Gif output file, if GraphViz available
-f	Diagram format - in fact this is the name of tool to produce the
	diagram with - it could be 'neato' or 'dot'... If you pass this
	option to the script, you are indicating that you have GraphViz.
	If you haven't it actually, do not use this option. You can
	actually get GraphViz from http://www.research.att.com/sw/tools/graphviz/.
	'dot' - hiearchical diagram, unfortunately it results in all the servers
	in the bottom of map and really lack of space there...
	'neato' - this diagram is dissolved all over the map, but it is painted
	by a bit silly algorithm so it overrides all around :(...
-h	This help

Any comments or bug reports please send at <pasky\@pasky.ji.cz>.
EOT
    exit;
  }
}

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

$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";

while (defined($IN=<$SOCK>)) {
  chomp($IN);
  @input=split(/ /, $IN);
  if ($input[0] eq "PING") {
    print $SOCK "PONG $input[1]\015\012";
  } elsif ($input[1] =~ /^\d{3}$/) {
  if ($input[1] == 433) { rand_nick(); print $SOCK "NICK $nick\015\012";
  } elsif ($input[1] == 376) {
    print $SOCK "JOIN #debug\015\012PRIVMSG #debug :map on ($ve:$remote/$port/$unmask/$classic/$brackets/$servern/$gif_form)\015\012"; last; # remove this if you want
  } }
}

$time_start=localtime();
$mask="*"; tie %map, "IHash";
scan_links(); $root=$lroot;

if ($unmask) { for($msk=0; $msk<@masks; $msk++) {
  $mask=$masks[$msk];
  debugmsg("\n-------------------------------------------------------\n$mask (@masks)\n\n");
  $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;
    $map{$mask}->{"unmask"}=$lroot;
    scan_mask($mask);
    $map{$lroot}->{"note"}=$map{$mask}->{"note"};
    debugmsg("--find $mask in @{$map{$map{$mask}->{root}}->{leaf}} (leafs of $map{$mask}->{root})\n");
    $cnt=0; foreach $leafs (@{$map{$map{$mask}->{"root"}}->{"leaf"}}) {
      if (lc($leafs) eq lc($mask)) {
        debugmsg("--found $mask - $map{$map{$mask}->{root}}->{leaf}->[$cnt] -> $lroot (@{$map{$mask}->{leaf}} vs @{$map{$lroot}->{leaf}}) -- ");
	$map{$map{$mask}->{"root"}}->{"leaf"}->[$cnt]=$lroot;
      }
      $cnt++;
    }
  } }
  sleep(15);
} }

$time_end=localtime();

print $SOCK "PRIVMSG #debug :map off ($time_start - $time_end)\015\012"; # Remove this if neccessary
print $SOCK "QUIT :$ver\015\012";
close ($SOCK) || die "Cannot close socket: $!";

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

if ($debug) {
  open DBG, ">/tmp/dump-$$"; print DBG Dumper(%map);
}

if ($gif_form) {
  open GRAPH, "| $gif_form -Tgif -o $gif_output";
#  open GRAPH, ">map.graph";
  if ($gif_form eq 'dot') { print GRAPH "di"; }
  print GRAPH "graph ircmap {\nedge [color=\"green\"]\n";
  if ($gif_form eq 'neato') { print GRAPH "edge [w=5.0, len=1.5, fontsize=10]\nnode [fontsize=10]\n"; }
  print GRAPH "\"$root\" [label=\"$root (start)\"]\n";
}

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

if ($gif_output) {
  print GRAPH "}";
  close GRAPH;
}

print "
|
|--
|
!Generated between $time_start and $time_end
|
";# $lusers|
 print <<EOF;
|$ver (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 (see source for more).
|Any tips/fixes really welcomed. Tested on IRCnet and TAIN (hybrid net),
|known maybe 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);
  if ($mask eq '*') { $lmask=""; } else { $lmask=$mask; } # XXX: undernet workaround
  debugmsg("links $lmask $lmask");
  print $SOCK "LINKS $lmask $lmask\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] =~ /\*/ and !(member($input[3], @masks)+1)) { push(@masks, lc($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/\./\\./g; $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') {
      $rm=$input[3].'$'; $rm=~s/\./\\./g; $rm=~s/\*/.*/;
      if ($input[5] ne ":0" and ($input[4]=~/$remask/i and rmember($rm,@{$map{$mask}->{"leaf"}})+1)) {
        if ($map{$input[3]}->{unmask}) { debugmsg("$input[3] -unmask> $map{$input[3]}->{unmask}"); $input[3]=$map{$input[3]}->{unmask}; }
        $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 ($gif_output) {
      print GRAPH "\"$field\" [label=\"$field"; if ($map{$field}->{mask}) {
      print GRAPH " ($map{$field}->{mask})"; } print GRAPH "\"]\n";
      print GRAPH "\"$_[0]\" -"; if ($gif_form eq 'dot') { print GRAPH ">"; } else { print GRAPH "-"; }
      print GRAPH " \"$field\""; if ($map{$field}->{note}) {
      print GRAPH " [label=\"$map{$field}->{note}\"";
      if ($map{$field}->{note} eq "split") { print GRAPH " color=\"red\""; }
      elsif ($map{$field}->{note} eq "lagged") { print GRAPH " color=\"gray\""; }
      print GRAPH "]"; } print GRAPH "\n";
    }
    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;
}

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

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

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