mirror of https://framagit.org/bortzmeyer/echoping
You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
366 lines
11 KiB
Perl
366 lines
11 KiB
Perl
#!/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 "";
|
|
}
|
|
|