mirror of
https://framagit.org/bortzmeyer/echoping
synced 2024-11-16 21:25:37 +00:00
Unmaintained file suppressed
This commit is contained in:
Stephane Bortzmeyer
parent
0081704474
commit
333e4200fa
@ -36,15 +36,6 @@ the others take a much longer time (one second). With '-w 1' (wait one second
|
||||
between tests, the default), everything works fine: it seems the sockets on
|
||||
SunOS need time to recover :-)
|
||||
|
||||
A graphical interface:
|
||||
|
||||
If you have the Perl/Tk <http://pubweb.bnl.gov/~ptk/> package, you can
|
||||
use a (quite rough and completely unmaintained) windowing interface,
|
||||
"echoping.ptk". To use it, you should define FLUSH_OUTPUT at the
|
||||
beginning of echoping.c (this seems to work on only a few Unices,
|
||||
including DEC's OSF/1). This interface has not yet been updated for
|
||||
echoping 2's new features (like HTTP support).
|
||||
|
||||
To measure performances on the Internet you can also see:
|
||||
|
||||
Unix:
|
||||
|
||||
365
SRC/echoping.ptk
365
SRC/echoping.ptk
@ -1,365 +0,0 @@
|
||||
#!/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 "";
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user