#!/usr/bin/perl

##------------------------------------------------------------------------------
##
## tubotron	    An application for displaying output from SpiNNaker systems
##
## Copyright (C)    The University of Manchester - 2009-2014
##
## Author           Steve Temple, APT Group, School of Computer Science
## Email            temples@cs.man.ac.uk
##
##------------------------------------------------------------------------------

# Copyright (c) 2009-2019 The University of Manchester
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.


use strict;
use warnings;

use Tk;

use IO::Socket::INET;

use SpiNN::Util qw/sllt_version/;


my $version = sllt_version ();

my $dns = 1;

my $logfile = "tubotron.log";
my $log_fh;

my $debug = 0;
my $max_lines = 10000;

my $port = 17892;
my $socket;
my $socket_fd;

my ($main, $top_label, $frame, $title);
my ($clear_menu, $save_menu, $open_menu, $close_menu);

my %submenu;
my @chips;

my $height = 10;
my $font = "Courier 10";

my $win_count = 0;
my $open_count = 0;

my %windows;
my %xbm;

my $include = ".*";


sub usage
{
    warn "usage: tubotron <args>\n";
    warn "  -port    <num>      - set UDP port number (default $port)\n";
    warn "  -height  <num>      - set window height (range 4-80, default 10)\n";
    warn "  -font    <font>     - set text font (eg \"Courier 12 bold\")\n";
    warn "  -lines   <num>      - set max lines kept in window (default 10k)\n";
    warn "  -include <regexp>   - only open windows matching <regexp>\n";
    warn "  -no-dns             - don't use DNS to translate source addresses\n";
    warn "  -debug              - set debug variable\n";
    warn "  -log                - log in $logfile\n";
    die  "  -version            - print version number\n";
}


sub process_args
{
    my $warn;

    while ($#ARGV >= 0)
    {
	my $arg = shift @ARGV;

	if ($arg eq "-log")
	{
	    die "can't open '$logfile'\n" unless open $log_fh, ">", $logfile;
	    binmode ($log_fh, ":unix");
	}
	elsif ($arg eq "-debug")
	{
	    $debug++;
	}
	elsif ($arg eq "-lines")
	{
	    die "max_lines not specified\n" unless defined $ARGV[0] &&
		$ARGV[0] =~ /^\d+$/;
	    $max_lines = shift @ARGV;
	}
	elsif ($arg eq "-font")
	{
	    die "font not specified\n" unless defined $ARGV[0];
	    $font = shift @ARGV;
	}
	elsif ($arg eq "-net")
	{
	    $warn = 1;
	}
	elsif ($arg eq "-no-dns")
	{
	    $dns = 0;
	}
	elsif ($arg eq "-version")
	{
	    die "tubotron - v$version\n";
	}
	elsif ($arg eq "-height")
	{
	    die "bad height\n" unless defined $ARGV[0] && $ARGV[0] =~ /^\d+$/
		&& $ARGV[0] >= 4 && $ARGV[0] <= 80;
	    $height = shift @ARGV;
	}
	elsif ($arg eq "-port")
	{
	    die "port not specified\n" unless defined $ARGV[0] &&
		$ARGV[0] =~ /^\d+$/;
	    $port = shift @ARGV;
	}
	elsif ($arg eq "-include")
	{
	    die "include not specified\n" unless defined $ARGV[0];
	    $include = shift @ARGV;
	}
	else
	{
	    usage ();
	}
    }

    warn "Option \"-net\" is no longer needed!\n" if $warn;
    warn "Using include regex \"$include\"\n" unless $include eq ".*";
}


#------------------------------------------------------------------------------


sub open_input
{
    $socket = new IO::Socket::INET (LocalPort => $port,
				    Proto => "udp",
				    Blocking => 0);

    die "failed to create socket: $!\n" unless $socket;

    $socket_fd = fileno ($socket);
}


sub read_bitmaps
{
    my ($name, $xbm, $col);

    while (<DATA>)
    {
	$xbm .= $_;
	if (/define\s+(\S+)_width/)
	{
	    $name = $1;
	    $col = "black";
	    $col = $1 if $name =~ /_([a-z]+)$/;
	}
	elsif (/;$/)
	{
	    $xbm{$name} = $main->Bitmap ($name, -data => $xbm, -fore => $col);
	    $xbm = "";
	}
    }
}


sub quit
{
    close $log_fh if defined $log_fh;
    $main->destroy;
}


sub win_status
{
    my $p = ($win_count == 1) ? "" : "s";
    my $c = $win_count - $open_count;

    $top_label->configure (-text =>
        "$win_count window$p ($open_count open, $c closed)");
}


sub clear_all
{
    for my $name (keys %windows)
    {
	my $text = $windows{$name}->{text};
	$text->delete ("0.0", "end");
    }
}


sub clear_win
{
    my $name = shift;

    my $text = $windows{$name}->{text};
    $text->delete ("0.0", "end");
}


sub save_win
{
    my $name = shift;

    my $text = $windows{$name}->{text};

    $name .= ".txt";

    if (open my $fh, ">", $name)
    {
	print $fh $text->get ("0.0", "end");
	close $fh;
    }
    else
    {
	warn "Can't open '$name'\n";
    }
}


sub save_all
{
    for my $name (keys %windows)
    {
	my $text = $windows{$name}->{text};

	$name .= ".txt";

	if (open my $fh, ">", $name)
	{
	    print $fh $text->get ("0.0", "end");
	    close $fh;
	}
	else
	{
	    warn "Can't open '$name'\n";
	}
    }
}


sub close_win
{
    my $win = shift;

    return if $windows{$win}->{closed};

    my ($chip, $core) = $win =~ /(.+),(\d+)$/;

    my $list = $submenu{$chip}->{list};

    my $e = 0;
    while ($e <= $#$list)
    {
	last if $list->[$e] == $core;
	$e++;
    }

    $windows{$win}->{frame}->packForget;
    $windows{$win}->{closed} = 1;

    $submenu{$chip}->{open}->entryconfigure  ($e, -state => "active");
    $submenu{$chip}->{close}->entryconfigure ($e, -state => "disabled");

    $open_count--;
    win_status ();
}


sub open_win
{
    my $win = shift;

    return unless $windows{$win}->{closed};

    my ($chip, $core) = $win =~ /(.+),(\d+)$/;

    my $list = $submenu{$chip}->{list};

    my $e = 0;
    while ($e <= $#$list)
    {
	last if $list->[$e] == $core;
	$e++;
    }

    $windows{$win}->{frame}->pack (-fill => "both", -expand => 1);
    $windows{$win}->{closed} = 0;

    $submenu{$chip}->{open}->entryconfigure  ($e, -state => "disabled");
    $submenu{$chip}->{close}->entryconfigure ($e, -state => "active");

    $open_count++;
    win_status ();
}


sub open_all
{
    open_win ($_) for (keys %windows)
}


sub close_all
{
    close_win ($_) for (keys %windows)
}


sub main_window
{
    $main = MainWindow->new (-title => "Tubotron $version (Port $port)");

    $frame = $main->Frame (-border => 2, -relief => "groove");

    my $clear_but = $frame->Menubutton (-text => "Clear", -border => 2,
	-relief => "raised", -width => 6);

    my $save_but = $frame->Menubutton (-text => "Save", -border => 2,
	-relief => "raised", -width => 6);

    my $open_but = $frame->Menubutton (-text => "Open", -border => 2,
	-relief => "raised", -width => 6);

    my $close_but = $frame->Menubutton (-text => "Close", -border => 2,
	-relief => "raised", -width => 6);

    my $quit_but = $frame->Button (-text => "Quit", -command => \&quit);

    $top_label = $frame->Label (-fg => "blue", -anchor => "w",
				-text => "Waiting ...");

    $clear_but->pack (-side => "left");
    $save_but->pack  (-side => "left");
    $open_but->pack  (-side => "left");
    $close_but->pack (-side => "left");

    $top_label->pack (-side => "left", -expand => 1, -fill => "x", -padx => 10);
    $quit_but->pack  (-side => "right");

    $clear_menu = $clear_but->Menu (-tearoff => 0);
    $save_menu  = $save_but->Menu  (-tearoff => 0);
    $open_menu  = $open_but->Menu  (-tearoff => 0);
    $close_menu = $close_but->Menu (-tearoff => 0);

    $clear_menu->command (-label => "--- ALL ---", -command => \&clear_all);
    $save_menu->command  (-label => "--- ALL ---", -command => \&save_all);
    $open_menu->command  (-label => "--- ALL ---", -command => \&open_all);
    $close_menu->command (-label => "--- ALL ---", -command => \&close_all);

    $clear_but->configure (-menu => $clear_menu);
    $save_but->configure  (-menu => $save_menu);
    $open_but->configure  (-menu => $open_menu);
    $close_but->configure (-menu => $close_menu);

    $frame->pack (-fill => "x");

    $main->after (5, \&poll_net);
}



sub new_window
{
    my $win = shift;

    my ($chip, $core) = $win =~ /(.+:\d+,\d+),(\d+)$/;

    my $frame = $main->Frame;
    my $head = $frame->Frame;
    my $label = $head->Label (-text => $win, -anchor => "w", -bg => "gray");
    my $clear = $head->Button (-image => $xbm{clear_black},
				-command => [\&clear_win, $win]);
    my $close = $head->Button (-image => $xbm{close_red},
				-command => [\&close_win, $win]);
    my $text = $frame->Scrolled ("Text", -scrollbars => "oe", -wrap => "none",
				 -height => $height, -width => 80,
				 -font => $font);

    $windows{$win}->{frame} = $frame;
    $windows{$win}->{text} = $text;
    $windows{$win}->{closed} = 0;
    $windows{$win}->{height} = $height;
    $windows{$win}->{lines} = 0;

    $label->pack (-side => "left", -fill => "x", -expand => 1);
    $close->pack (-side => "right");
    $clear->pack (-side => "right");
    $head->pack (-fill => "x", -expand => 0);
    $text->pack (-fill => "both", -expand => 1);
    $frame->pack (-fill => "both", -expand => 1);

    unless (exists $submenu{$chip})
    {
	$submenu{$chip}->{list} = [];

	my $i = 0;

	while ($i <= $#chips)
	{
	    last if $chip lt $chips[$i];
	    $i++;
	}

	splice @chips, $i, 0, $chip;

	my $clr = $submenu{$chip}->{clear} = $clear_menu->Menu (-tearoff => 0);
	my $sav = $submenu{$chip}->{save}  = $save_menu->Menu  (-tearoff => 0);
	my $opn = $submenu{$chip}->{open}  = $open_menu->Menu  (-tearoff => 0);
	my $cls = $submenu{$chip}->{close} = $close_menu->Menu (-tearoff => 0);

	$i++; # Move past "ALL" menu item

	$clear_menu->insert ($i, "cascade", -label => "$chip", -menu => $clr);
	$save_menu->insert  ($i, "cascade", -label => "$chip", -menu => $sav);
	$open_menu->insert  ($i, "cascade", -label => "$chip", -menu => $opn);
	$close_menu->insert ($i, "cascade", -label => "$chip", -menu => $cls);

	$clear_menu->entryconfigure ($chip, -menu => $clr);
	$save_menu->entryconfigure  ($chip, -menu => $sav);
	$open_menu->entryconfigure  ($chip, -menu => $opn);
	$close_menu->entryconfigure ($chip, -menu => $cls);
    }

    my $list = $submenu{$chip}->{list};
    my $i = 0;

    while ($i <= $#$list)
    {
	last if $core < $list->[$i];
	$i++;
    }

    splice @$list, $i, 0, $core;

    $windows{$win}->{menu_entry} = $i;

    $submenu{$chip}->{clear}->insert ($i, "command", -label => "Core $core",
				      -command => [\&clear_win, $win]);
    $submenu{$chip}->{save}->insert ($i, "command", -label => "Core $core",
				     -command => [\&save_win, $win]);
    $submenu{$chip}->{open}->insert ($i, "command", -label => "Core $core",
				     -command => [\&open_win, $win],
				     -state => "disabled");
    $submenu{$chip}->{close}->insert ($i, "command", -label => "Core $core",
				      -command => [\&close_win, $win]);

    $win_count++;
    $open_count++;

    win_status ();

    return $text;
}


sub add_text
{
    my ($win, $data) = @_;

    return unless $win =~ /$include/;

    my $text = $windows{$win}->{text};

    $text = new_window ($win) unless defined $text;

    $text->insert ("end", $data);
    $text->see ("end");

    return if $max_lines == 0;

    my ($offset, $index) = (0, 0);

    while (($index = index ($data, "\n", $offset)) != -1)
    {
	$offset = $index + 1;
	$windows{$win}->{lines}++;
    }

    while ($windows{$win}->{lines} > $max_lines)
    {
	$windows{$win}->{text}->delete ("1.0", "2.0");
	$windows{$win}->{lines}--;
    }
}


my %hosts;


sub poll_net
{
    $main->after (5, \&poll_net);

    my $rm = "";
    vec ($rm, $socket_fd, 1) = 1;

    my $n = select ($rm, undef, undef, 0);
    return if $n == 0;

    my $buf;
    my $addr = recv ($socket, $buf, 65536, 0);

    unless (defined $addr)
    {
	warn "!! recv failed\n";
	return;
    }

    my ($port, $ip) = sockaddr_in ($addr);
    my $name = $hosts{$ip};

    unless ($name)
    {
	if ($dns)
	{
	    $name = gethostbyaddr ($ip, 2);
	    $name = "NoDNS" unless $name;
	}
	else
	{
	    $name = inet_ntoa ($ip);
	}
	$hosts{$ip} = $name;
    }

    my ($pad, $flags, $tag, $dp, $sp, $da, $sa, $cmd, $seq, $text) =
	  unpack "v C C C C v v v v a*", $buf;

    my $x = $sa >> 8;
    my $y = $sa & 255;

    if ($cmd == 64) # !! TUBE
    {
	my $win = "$name:$x,$y,$sp";
	add_text ($win, $text);
	print $log_fh "$win <$text>\n" if defined $log_fh;
    }
    else
    {
	warn "!! bad command ($cmd)\n";
    }

    if ($debug)
    {
	my $len = length $text;
	my $sep = (chomp $text) ? "\n" : "";

	printf "# F=0x%02x T=0x%02x DP=0x%02x DA=0x%04x SP=0x%02x SA=0x%04x SEQ=$seq CMD=$cmd",
	$flags, $tag, $dp, $da, $sp, $sa;
	printf " LEN=%d\n%s$sep\n", $len, $text;
    }
}


process_args ();

open_input ();

main_window ();

read_bitmaps ();

Tk::MainLoop ();


__DATA__
#define close_red_width 14
#define close_red_height 14
static char close_red_bits[] = {
   0x00, 0x00, 0x06, 0x18, 0x0e, 0x1c, 0x1c, 0x0e, 0x38, 0x07, 0xf0, 0x03,
   0xe0, 0x01, 0xe0, 0x01, 0xf0, 0x03, 0x38, 0x07, 0x1c, 0x0e, 0x0e, 0x1c,
   0x06, 0x18, 0x00, 0x00};
#define clear_black_width 14
#define clear_black_height 14
static char clear_black_bits[] = {
   0xff, 0x3f, 0xff, 0x3f, 0x03, 0x30, 0x03, 0x30, 0x03, 0x30, 0x03, 0x30,
   0x03, 0x30, 0x03, 0x30, 0x03, 0x30, 0x03, 0x30, 0x03, 0x30, 0x03, 0x30,
   0xff, 0x3f, 0xff, 0x3f};
