echoping/SRC/echoping.ptk

#!/usr/local/bin/perl -w

require 5.003;
use Tk;
use Socket;

# Let's be paranoid
use strict;

require "newgetopt.pl";
&NGetOpt (("geometry=s", "font=s", "background=s", "bg=s", "foreground=s", "fg=s", "title=s"));

$ENV{'SHELL'} = "/bin/sh";

my $default_host;
if (@ARGV) {
	$default_host = shift (@ARGV);
	#TODO: shouldn't we try to echoping it right now?
}
else {
	$default_host = "fritz.globenet.org";
}
if (@ARGV) {
	print STDERR "Ignoring extra arguments \"" . join (' ', @ARGV) . "\"\n";
}

my $top = MainWindow->new;

if ($main::opt_geometry) {
        $top->geometry ($main::opt_geometry);
}
if ($main::opt_title) {
        $top->title ($main::opt_title);
}
else {
        $top->title ("EchoPing Driver");
}
#TODO: how to set background, font, etc for all the widgets?
if ($main::opt_bg) {
        $main::opt_background = $main::opt_bg;
}
if ($main::opt_background) {
	$top->configure (-background => $main::opt_background);
}
if ($main::opt_fg) {
        $main::opt_foreground = $main::opt_fg;
}
if ($main::opt_foreground) {
	$top->configure (-foreground => $main::opt_foreground);
}
if ($main::opt_font) {
	$top->configure (-font => $main::opt_font);
}

#TODO : on line help with context => 'connection refused' will give an explanation

$main::echoping = &find_pg ("echoping");
if (! $main::echoping) {
	print STDERR "Cannot find the echoping program in the path.\n";
	exit 1;
	#TODO: a nice pop-up window with an hypertext link to the FTP server :-)
}

my $message;
open (ECHOPING, "$main::echoping -v localhost 2>&1 |") || &panic ("Cannot echoping");
my $result = <ECHOPING>;
chop $result;
if ($result) { # Something was wrong
	if ($result =~ /Connection refused/) {
		$message = "localhost refused echo: egoist!";
		#TODO: better explanations
	}
	else {
		$message = "Problem localhost: $result";
	}
}
else {
	$message = <ECHOPING>;
}
close (ECHOPING);

# Some useful declarations
my $results;
my $number;
my $size;
my $delay;

my $frame1 = $top->Frame(-borderwidth => '2m');
$frame1->pack(-fill => 'x');

# Entry field
my $entry = $frame1->Entry(-relief => 'sunken', -width => 45);
my $label = $frame1->Label(-text => 'Enter host name');
$label->pack(-side => 'left');
$entry->pack(-side => 'left');
$entry->insert('insert', $default_host);
#$entry->selection ('range', 0, length ($default_host));
$entry->focus;
# I believe the following binding is necessary only on OSF/1?
$entry->bind('<Delete>' => 'Backspace');

# Doit button
my $doit = $frame1->Button(-text => 'Do it', 
	-command => sub {doit ($top, $entry, $results, 
		$number->get, $size->get, $delay->get, $main::text)});
$doit->pack(-side => 'left', -fill => 'x', -padx => '2m');
$top->bind ('<Return>' => sub {doit ($top, $entry, $results, 
	$number->get, $size->get, $delay->get, $main::text)});
my $cancel = $frame1->Button(-text => 'Cancel', 
	#-command => sub {$main::cancel_requested = 1;});
	#TODO: Cancel should test if an operation is in progress, otherwise, it will
	# be "recorded" for the next time.
	-command => sub {cancel_requested ($top, $results);});
$cancel->pack(-side => 'left', -fill => 'x', -padx => '2m');

my $frame2 = $top->Frame(-borderwidth => '2m');
$frame2->pack(-fill => 'x');
#TODO: every number should be in the settings section at the beginning
$number = $frame2->Scale(-from => '1', -to => '10', -orient => 'horizontal', -label => 'Number of connections');
$number->set ('1');
$number->pack (-side => 'top', -fill => 'x');
$size = $frame2->Scale(-from => '1', -to => '1000', '-length' => '500', -orient => 'horizontal', -label => 'Size of packets');
$size->set ('256'); #TODO: finds a way to enter value directly
$size->pack (-side => 'top', -fill => 'x');
$delay = $frame2->Scale(-from => '0', -to => '20', '-length' => '500', -orient => 'horizontal', -label => 'Delay between connections');
$delay->set ('1');
$delay->pack (-side => 'top', -fill => 'x');

my $frame3 = $top->Frame(-borderwidth => '2m');
$frame3->pack (-fill => 'both', -expand => 'yes');

# Status text
$main::text = $frame3->Label(
        -justify    => 'center',
        -text       => "$message",
    );
$main::text->pack(-side => 'top', -fill => 'none', -expand => 'no');

# Results text with scrollbar
#TODO: nice tags and hypertext tags
$results = $frame3->Text(-relief => 'sunken', -state => 'disabled');
my $scrollbar = $frame3->Scrollbar(-command => ['yview', $results]);
$results->configure(-yscrollcommand => ['set', $scrollbar]);
$scrollbar->pack(-side => 'right', -fill => 'y');
$results->pack(-side => 'left', -expand => 'yes', -fill => 'both');

my $frame4 = $top->Frame(-borderwidth => '2m');
$frame4->pack(-fill => 'x');

# Quit button
my $quit = $frame4->Button(-text => 'Quit', -command => sub {exit 0;});
$quit->pack(-side => 'bottom', -fill => 'x');
#TODO: a "clear results" button and a "shrink results"

@main::to_disable = ($entry, $doit, $quit, $number, $size, $delay);
@main::to_mark = ($label, $frame1, $frame2, $frame3, $frame4);

#TODO: better resizing: the Quit button disappears when shrinking

MainLoop;

sub doit {
	my ($top_window, $entry, $text, $number, $size, $delay, $label) = @_;
	my ($date) = `date`;
	my $line;
	my $index;
	chop $date;
	my $host = $entry->get;
        &disable (@main::to_disable);
        &mark_used (@main::to_mark);
        &status ($label, "Looking up $host");
        $label->update;
	my ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname ($host);
	if (! $name) {
        	$text->configure (-state => 'normal');
        	$text->insert ('end', "\n----------\nHost $host unknown at $date\n\n");
        	$text->configure (-state => 'disabled');
       		&status ($label, "Idle");
         	&enable (@main::to_disable);
        	&mark_unused (@main::to_mark);
        	return;		
	}
	my $address = join ('.', unpack('C4', $addrs[0]));
	&status ($label, "Echopinging $name");
	open (HANDLE, "$main::echoping -v -n $number -s $size -w $delay $address 2>&1 |") || 
			&panic ("Cannot echoping");
	$main::handle = *HANDLE;
	$top_window->fileevent ("HANDLE", 'readable', [\&message_from_echoping, 
		 $top_window, $text, \*HANDLE]);        
        $text->configure (-state => 'normal');
        $text->insert ('end', "\n----------\n$main::echoping of $host ($name [" .
        		$address . "])\n" .
        	" (with $size bytes and $delay s interval)\n" .
        	" at $date:\n");
        $text->configure (-state => 'disabled');
}

sub message_from_echoping {
		my ($top_window, $text, $handle) = @_;
		my ($line) = scalar <$handle>;
		if (! defined ($line)) {
			$top_window->fileevent ($handle, 'readable', "");        
			close ($handle); 
			&end_of_echoping;      
			return;
		}
		chop $line;
       		#TODO: cancel will only be taken into account when there is something to read :-(
        	# may be more feedback would be good?
       		$text->configure (-state => 'normal');
                if ($main::cancel_requested) {
                        &cancel_requested ($top_window, $text); 
                        	# The only problem is that we lose the last line received 
                        	# but the test is here to have more opportunities to 
                        	# catch a cancel.
                }
		elsif ($line =~ /^This is /) {
			&status ($main::text, "Trying to connect");
		}
		elsif ($line =~ /^Trying to connect to internet address/) {
			&status ($main::text, "Trying to connect");
		}
		elsif ($line =~ /^Connected/) {
			&status ($main::text, "Connected");
		}
		elsif ($line =~ /^Sent/) {
			&status ($main::text, "Data sent");
		}
		elsif ($line =~ /^[0-9]+ bytes read/) {
			&status ($main::text, "Data sent");
		}
		elsif ($line =~ /^Checked/) {
			&status ($main::text, "Data received and checked");
		}
		elsif ($line =~ /^[a-z]+ time:/i) {
			&status ($main::text, "Sleeping");
			$text->insert ('end', $line . "\n");
		}
		elsif ($line =~ /^---/i) {
			&status ($main::text, "Sleeping");
			$text->insert ('end', $line . "\n");
		}
 		elsif ($line =~ /^$/) {
		}
		else {
			&status ($main::text, "Strange value");
			$text->insert ('end', "Strange text: " . $line . "\n");
		}
        	#$text->update;
        	#TODO: scroll to see the end since it doesn't seem automatic
        	$text->configure (-state => 'disabled');
 }

sub cancel_requested {
	my ($top_window, $text) = @_;
	$top_window->fileevent ($main::handle, 'readable', "");        
	close ($main::handle); 
        $text->configure (-state => 'normal');
        undef $main::cancel_requested;
        $text->insert ('end', "\nCancelled by user\n");
        $text->configure (-state => 'disabled');
        &enable (@main::to_disable);
        &mark_unused (@main::to_mark);
        &status ($main::text, "Idle");
}

sub end_of_echoping {
	my ($text, $line) = @_;
	&enable (@main::to_disable);
        &mark_unused (@main::to_mark);
        &status ($main::text, "Idle");
}

sub status {
	my ($label, $message) = @_;
	$label->configure (-text=>"Status: $message");
}

# Disable a list of widgets
sub disable {
        my (@widgets) = @_;
        my $w;
        for $w (@widgets) {
                $w->configure (-state=>'disabled', -cursor=>'watch');
        }
}

# Enable a list of widgets
sub enable {
        my (@widgets) = @_;
        my $w;
        for $w (@widgets) {
                $w->configure (-state=>'normal', -cursor=>'top_left_arrow');
        }
}

# Mark a list of widgets as used
sub mark_used {
        my (@widgets) = @_;
        my $w;
        for $w (@widgets) {
                $w->configure (-cursor=>'watch');
        }
}

# Mark a list of widgets as unused
sub mark_unused {
        my (@widgets) = @_;
        my $w;
        for $w (@widgets) {
                $w->configure (-cursor=>'top_left_arrow');
        }
}

# The "find_pg" (find program) code has been stolen from "aub"
# and lightly adapted.
sub find_pg {
#
# find_pg: find the specified executable on this machine, if possible.
#
# We try using which first, assuming that if the desired executable is in
# our path, it's the one we want.
#
# If it's not in our path, we try whereis, returning the first program
# whereis names for us which is executable.
#
# If we can't find what we need, we return an empty string.
#
# Bug: if the ".cshrc" of the user displays something, we're lost...

  my ($pg) = @_;
  my ($ex) = 1;
  my ($try, @found);
my ($pid);

  return $pg if ($pg =~ m/^\//);                # Absolute paths know best
  #chop($try = `which $pg`);
         die unless (defined ($pid = open(KID, "-|")));
         if ($pid) {           # parent
             while (<KID>) {
             $try = $_;
             }
             chop $try;
         } else {
             #$> = $<;
             #$) = $(;  # BUG: initgroups() not called
             exec '/usr/ucb/which', $pg;
             die "can't exec program: $!";
         }
         #print "\"", $try, "\"\n";
if ($try =~ m#^/#) {
	#print "Try est absolu\n";
	}
  return $try if ($try =~ m#^/#);

  chop($try = `whereis $pg`);
  if ($try =~ m/^$pg:\s+\//) {
    @found = split(/\s/, $try);
    $ex++ while (! -x $found[$ex]);
    return $found[$ex] unless ($found[$ex] eq "");
  }

  return "";
}