#!/usr/bin/perl
#
# ircmap.pl - v0.97
#
# 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>
#
# 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 ;-)))
#
# TODO: - optimalization stuff -- perform only one LINKS per mask
#	- nicer diagrams -- this is too messy
#	- sanization of the code ;-)
#	- ...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.
#
# 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.
#

use Socket;
use IO::Handle;

###############################################################################
#
# 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
## 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
$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)
$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'.

###############################################################################
#
# If you are not interested in code itself, you should stop here.
#
###############################################################################
#
# 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_file=shift;
  } elsif ($switch eq '-f') {
    $gif_form=shift;
  } elsif ($switch eq '-h') {
    print <<EOT;
ircmap (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[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 (0.97:$remote/$port/$unmask/$classic/$brackets/$servern/$gif_form)\015\012"; last;
  } }
}
    
$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++;
     }
  } }
  sleep(15);
} }

$time_end=localtime();

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

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

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;
|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/i 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 ($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;
}

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