I wrote a threaded app to ping lots of servers using the system command (Net::Ping failed when script was not executed as root, and Tye's post about uncommenting several lines of code where Net::Ping checks OS did not change Net-Ping's behavior either) The threaded version worked great for a small list of 10-30 servers. When I pushed it up to 200, it would sometimes just hang the entire system, and grew to about 157,000kb of memory (WinXP). I decided to time the two methods ( ie just using a single system command and reiterating over it vs the threaded version ) The threaded version failed during the Benchmark with a "Scalar's leaked: 1" when iteration were greater than 1. I went on to read on CPAN that certain subs may indeed have a leak, but it hadn't been resolved. *sigh* I wish I knew enough to help with that effort ) So, I decided to hack the Net::Ping module to see if could just send a simple ICMP raw echo myself. I just wanted a simple sub that would send a ICMP raw packet and then look for a return. At first, I used the IO::Socket::INET, I thought it would be a *simple* matter. Since I had built simple client servers using the examples in here and in serveral other books. NOT! Merlyn had a Suggestion on here last week about trying to do this. I tried to compile that links module (Net::RawIP), but it failed to compile :( . Below is the hacked version of Ping. It works fine when run as Administrator... but fails when run as "User" in Win32. I think the error is occuring in the send or the bind, but I can't determine which. I have tried debug statements everywhere... Can anyone tell me if there is a FIX to this? 
#!/perl/bin/perl -w
# myping.pl
# Useage:  myping.pl www.someplace.com
use IO::Socket::INET;
use strict;
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
               inet_aton inet_ntoa sockaddr_in );
use Carp;
use POSIX qw(ECONNREFUSED);
use Time::HiRes qw(time);
use FileHandle;
use constant ICMP_ECHOREPLY => 0; # ICMP packet types
use constant ICMP_ECHO      => 8;
use constant ICMP_STRUCT    => "C2 S3 A";  # Structure of a minimal IC
+MP packet
use constant SUBCODE        => 0; # No ICMP subcode for ECHO and ECHOR
+EPLY
use constant ICMP_FLAGS     => 0; # No special flags for send or recv
use constant ICMP_PORT      => 0; # No port with ICMP

my $cnt;
my $pid;
my $fh;
my $seq = 0;
my $proto_num;
my $data_size = 4;
my $data="";
my $wait = 500; # in milliseconds
my $wait_time = ($wait/1000);

for (1..$data_size){ $data .= chr($_ % 256); }

if ($^O =~ /Win32/i) {
  # Hack to avoid this Win32 spewage:
  # Your vendor has not defined POSIX macro ECONNREFUSED
  *ECONNREFUSED = sub {10061;}; # "Unknown Error" Special Win32 Respon
+se?
};

&ping($ARGV[0]);

sub ping
{

    my $to_ip = shift;
    my ($name) = gethostbyname("localhost");
    my $ip = gethostbyname("$name");
    my $timeout = 1;

  my ($saddr,             # sockaddr_in with port and ip
      $checksum,          # Checksum of ICMP packet
      $msg,               # ICMP packet to send
      $len_msg,           # Length of $msg
      $rbits,             # Read bits, filehandles for reading
      $nfound,            # Number of ready filehandles found
      $finish_time,       # Time ping should be finished
      $done,              # set to 1 when we are done
      $ret,               # Return value
      $recv_msg,          # Received message including IP header
      $from_saddr,        # sockaddr_in of sender
      $from_port,         # Port packet was sent from
      $from_ip,           # Packed IP of sender
      $from_type,         # ICMP type
      $from_subcode,      # ICMP subcode
      $from_chk,          # ICMP packet checksum
      $from_pid,          # ICMP packet id
      $from_seq,          # ICMP packet sequence
      $from_msg           # ICMP message
      );
 $to_ip = inet_aton("$to_ip");
 $proto_num = (getprotobyname('icmp'))[2] || croak("Can't get icmp pro
+tocol by name");
    $pid = $$ & 0xffff;           # Save lower 16 bits of pid
 
  $fh = FileHandle->new();

 socket($fh, PF_INET, SOCK_RAW, $proto_num) ||croak("icmp socket error
+ - $!");

### COMPLAINS HERE WHEN NOT RUN AS ADMIIN ###
 bind($fh, sockaddr_in(0,$ip)) || croak ("can't bind");

  $seq = ($seq + 1) % 65536; # Increment sequence
  $checksum = 0;                          
  $msg = pack(ICMP_STRUCT . $data_size, ICMP_ECHO, SUBCODE,
              $checksum, $pid, $seq, $data);
  $checksum = &checksum($msg);

  $msg = pack(ICMP_STRUCT . $data_size, ICMP_ECHO, SUBCODE,
              $checksum, $pid, $seq, $data );

  $len_msg = length($msg);

### I GET A VALID RETURN FOR $saddr ###
  $saddr = sockaddr_in(ICMP_PORT, $to_ip);

### BUT I THINK THIS IS WHERE THERE ERROR IS OCCURING  ###
  send($fh, $msg, ICMP_FLAGS,$saddr) || die "can't send! $!\n"; # Send
+ the message
  $rbits = "";
  vec($rbits, $fh->fileno(), 1) = 1;     # Set up Bits
  $ret = 0;
  $done = 0;
  $finish_time = &time() + $timeout;      # Must be done by this time
  while (!$done && $timeout > 0)          # Keep trying if we have tim
+e
  {
    #select the socket and look for info... time out if you don't see 
+it
    #I set the timeout to 500 ms for local tests... 
    $nfound = select($rbits, undef, undef, $wait_time ); # LOOK for RB
+ITS
    $timeout = $finish_time - &time();   
    if (!defined($nfound))  #we didn't see anything on that socket    
+            
    {
      $ret = undef;
      $done = 1;
    }
    elsif ($nfound)                     # Got a packet - open to see i
+f it is ours
    {
      $recv_msg = "";
      $from_saddr = recv($fh, $recv_msg, 1500, ICMP_FLAGS);
      ($from_port, $from_ip) = sockaddr_in($from_saddr);
      ($from_type, $from_subcode, $from_chk,
       $from_pid, $from_seq, $from_msg) =
         unpack(ICMP_STRUCT . $data_size,
                substr($recv_msg, length($recv_msg) - $len_msg,
                       $len_msg));
      if (($from_type == ICMP_ECHOREPLY ) &&
          (!$source_verify || $from_ip eq $ip) &&
          ($from_pid == $pid) && # Does the packet check out?
          ($from_seq == $seq))  # clos enough then..
      {
        $ret = 1;    
        $done = 1;
      $from_ip = inet_ntoa($from_ip);
      print STDOUT "Recieved reply from: $from_ip";
      }
    }
    else                            # Or, we timed out
    {                        
      $done = 1;
    print "Timed out";
    }
  }
  return $ret;
}
## ALMOST WORD FOR WORD OUT OF STEVEN's BOOK
sub checksum
{
  my (
      $msg            # The message to checksum
      ) = @_;
  my ($len_msg,       # Length of the message
      $num_short,     # The number of short words in the message
      $short,         # One short word
      $chk            # The checksum
      );

  $len_msg = length($msg);
  $num_short = int($len_msg / 2);
  $chk = 0;
  foreach $short (unpack("S$num_short", $msg))
  {
    $chk += $short;
  }                                           # Add the odd byte in
  $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_ms
+g % 2;
  $chk = ($chk >> 16) + ($chk & 0xffff);      # Fold high into low
  return(~(($chk >> 16) + $chk) & 0xffff);    # Again and complement
}

[download]
and here is the timed code where the threads die 
#!/perl/bin/perl -w
use threads qw(yield);
use strict;
use Benchmark;

my @childs; 
my $child; 
my (@rv, @RV);
my @list;
my $list;

@list = qw ( www.perl.org 
www.ibm.com www.coke.com www.oracle.com www.hp.com );
#Dies if you iterate more than once :(
timethese (1 , {
    'threaded' => sub {
foreach $list (@list){

    push @childs, threads->create( "ping" , "$list" );
}
foreach $child (@childs){
    $child->join();
    }
undef @childs;
},
'non-threaded' => sub {

foreach (@list){
    ping($_);
    }
    }
});

sub ping {
 my $ip = shift;
 @rv = `ping -n 1 -w 500 $ip`;
 foreach(@rv){ return "$ip up\n" if /\(0% loss\)/g;
    return "$ip down\n" if /\(100% loss\)/g; }
}

[download]
Thanks for taking a look! James

In reply to Socket problem - when running Win32 app as someone different than Admin by JamesNC

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.