in reply to Re: Re: Re: Non-blocking pings on Win32
in thread Non-blocking pings on Win32

This is the code I have come up with. This is for a Win32 machine and I am using Win32::ODBC with MySQL. I have not coded it yet to be database independent but that will happen as I update the code but the thread processing works fine and I am able to scan a class A fairly efficiently. There seems to be a small memory leak in it but it does not affect the scan adversely. Memory grows very slowly over a large period of time. With the command line options though you can have the script scan ranges from a batch file or bash script exit and than do another range minimising the affects of the leak. 

#!/usr/bin/perl

#  Declare Pragmas.

use strict;

use threads;

#  Load modules.

use Getopt::Long qw(:config no_ignore_case bundling);
use Pod::Usage;

use Thread::Queue;

use Net::IP;
use Net::Ping;
use Socket;

use Win32::ODBC;

#  Declare Global Variabbles.

our $DSN          = 'network_scans';
our $EXIT_CODE    = '|#~THREAD_EXIT~#|';
our $HELP         = 0;
our $INPUT_DB     = 0;
our $INPUT_FILE   = 0;
our $IP_RANGE     = 0;
our $MANUAL       = 0;
our $OUTPUT_FILE  = 0;
our $PROTOCOL     = 'icmp';
our $THREAD_COUNT = 50;
our $VERBOSE      = 0;

#  Define Subroutines.

#  PingThread
#  This sub is the actual trhead that does the ping routines.

#  This subroutine was refined with help from:
#                                   http://perlmonks.org/index.pl?node
+_id=316601

sub PingThread{
    my $InputQueue  = shift;
    my $OutputQueue = shift;
    my $ExitCode    = shift;
    
    my $pingObj = Net::Ping->new($PROTOCOL , 2, 32);
    until ((my $IpAddress = $InputQueue->dequeue) eq "$ExitCode"){
        unless ($pingObj->ping($IpAddress, 1)){
            my $MachineName = uc(gethostbyaddr (inet_aton($IpAddress),
+ AF_INET)) or '[FAILED]';
                print "$IpAddress\tNo Response!\n" if $VERBOSE;
        } else {
            my $Host = uc(gethostbyaddr(inet_aton($IpAddress), AF_INET
+)) or '[FAILED]';
            $Host =~ s/(-UDP.*|\..*)//;
            if ($Host eq ''){
                $Host = "${IpAddress}\[\<NULL\>\]";
            }else{
                $Host = "${IpAddress}\[$Host\]";
            }
            $OutputQueue->enqueue($Host);
            print "$IpAddress\t$Host\n" if $VERBOSE;
        }
        threads->yield();
    }
    $pingObj->close();
}

sub ReadRange{
    my $IpRange    = shift;
    my $InputQueue = shift;
    
    my $ip = new Net::IP ($IpRange) or warn (Net::IP::Error());
    open (OUTPUT_FILE, "> $OUTPUT_FILE") or warn "Can open $OUTPUT_FIL
+E for writing: $!\n" if $OUTPUT_FILE;
    print OUTPUT_FILE "$IpRange\n" if $OUTPUT_FILE;
    do{
        my $IpAddress = $ip->ip();
        $InputQueue->enqueue($IpAddress);
    } while (++$ip);
    close OUTPUT_FILE if $OUTPUT_FILE;
}

sub ReadFile{
    my $Input_File = shift;
    my $InputQueue = shift;

    open (INPUT_FILE, "< $Input_File") || die "Could not open $Input_F
+ile: $!";
    while (<INPUT_FILE>){
        chomp;
        ReadRange($_, $InputQueue);
    }
    close INPUT_FILE    
}

sub ReadInput_DB{
    my $DSN        = shift;
    my $InputQueue = shift;

    my $db         = new ODBC($DSN);
    
    if ($db->Sql("SELECT * FROM subnets;")){
        print "Error submitting SQL statement: " . $db->Error() . "\n"
+;
    }else{
        while ($db->FetchRow()){
            my %Data = undef;
            %Data = $db->DataHash();
            my $range = "$Data{subnet}$Data{mask}";
            ReadRange ($range, $InputQueue);
        }
    }    
}

sub UpdateDB{
    my $DataQueue   = shift;
    my $ExitCode    = shift;
    
    until ((my $Machine = $DataQueue->dequeue) eq "$ExitCode") {
        my $db        = new ODBC($DSN);
        my ($IpAddress, $MachineName) = ($Machine=~/(.*)\[(.*)\]$/);
        $MachineName = "${IpAddress}${MachineName}" if ($MachineName e
+q '<NULL>');
        if ($db->Sql ("INSERT INTO computer_names (computer_name, last
+_ip_address) VALUES ('$MachineName','$IpAddress')")){
            if ($db->Sql("UPDATE computer_names SET last_ip_address = 
+'$IpAddress' WHERE computer_name='$MachineName';")){
                my $Error = $db->Error();;
                print $Error;
            }else{
                print "Updated $MachineName on $DSN\n" if $VERBOSE;
            }
        }else{
            print "Added $MachineName on $DSN\n" if $VERBOSE;
        }
        $db->Close();
        threads->yield();
    }
}

#  Process the config file if it exists



#  Process command line arguments
#  This code is based on suggestions from:
#                                   http://perlmonks.org/index.pl?node
+_id=300594

GetOptions    (
                            'dsn|d=s'        =>\$DSN,
                            'help|h|?'       =>\$HELP,
                            'Db|D'           =>\$INPUT_DB,
                            'input|in|i=s'   =>\$INPUT_FILE,
                            'Ip|I=s'         =>\$IP_RANGE,
                            'man|m'          =>\$MANUAL,
                            'output|out|o=s' =>\$OUTPUT_FILE,
                            'protocol|p=s'   =>\$PROTOCOL,
                            'threads|t=i'    =>\$THREAD_COUNT,
                            'verbose|v'      =>\$VERBOSE
                        );

pod2usage(1) if $HELP;
pod2usage(-exitstatus=>0 -verbose =>2) if $MANUAL;
pod2usage (1) unless (($INPUT_FILE or $IP_RANGE) or $INPUT_DB);

#  Verify DSN before continuing

my $db = new ODBC($DSN);
die "Error connecting to $DSN:".Win32::ODBC::Error()."\n" unless $db;
$db->Close();

#  Set up Variables for the threads.

my $InputQueue  = Thread::Queue->new;
my $OutputQueue = Thread::Queue->new;
my $DataThread  = threads->new(\&UpdateDB, $OutputQueue, $EXIT_CODE);
my @Threads;


#  Destroy variables when they are not needed.

undef $HELP;
undef $MANUAL;

#  Prepare the threads

foreach (1..$THREAD_COUNT){
    my $thread = threads->new(\&PingThread, $InputQueue, $OutputQueue,
+ $EXIT_CODE);
    push (@Threads, $thread);
    }

ReadInput_DB($DSN, $InputQueue) if $INPUT_DB;

#  Destroy variable when it is not needed.

undef $INPUT_DB;
    
ReadFile($INPUT_FILE, $InputQueue) if $INPUT_FILE;

#  Destroy variable when it is not needed.

undef $INPUT_FILE;

ReadRange($IP_RANGE, $InputQueue) if $IP_RANGE;

#  Destroy variable when it is not needed.

undef $IP_RANGE;

#  Bring the threads back in.

foreach my $count (1..$THREAD_COUNT){
    $InputQueue->enqueue($EXIT_CODE);
    print "Ending Ping Thread\n" if $VERBOSE;
}

foreach my $ithread (@Threads){
    $ithread->join();
}

#  Tell the updatedb thread to exit.

$OutputQueue->enqueue($EXIT_CODE);
print "Ending Data Thread\n" if $VERBOSE;
$DataThread->join();


__END__

=head1 NAME

scan

=head1 SYNOPSIS

B<scan.pl> [B<-i> I<Ip Address Range> B<-I> I<Input File> B<-d> I<DSN>
+ B<-h -m -v>]

=head1 DESCRIPTION

B<scan.pl> scans network addresses gather data on the computer state o
+f
the machines found on the network.  This is used as the scanning agent
+ for the
full Patch Adams suite of software to manage hotfixes. Output is store
+d in a database. The Ip Address can be supplied either via an I<Ip Ad
+dress Range> or via an I<Input File>. The database is connected using
+ an I<DSN> ODBC datasource.

=head1 OPTIONS

=over 4 

=item B<-I --input> I<Input File>

Reads the ip addresses from I<Input File>.

=item B<-i --ip> I<Ip Address Range>

Supplies an I<Ip Address Range>.

=item B<-d --dsn> I<DSN>

Uses the supplied I<DSN> for database connections.

=item B<-h|? --help>

Prints the basic help syntax.

=item B<-m --manual>

Prints the full manual page.

=back

=head1 FILES

=over 4

=item I<Input File>

I<Input File> is a user supplied file for input of Ip Addresses.

=item I<DSN>

I<DSN> is an ODBC data source used for storing the database informatio
+n generated by the scan.

=back

=head1 DIAGNOSTICS

=over 4

=item Error Message

Description

=back

=head1 REQUIRES

Perl 5.8.2, Thread::Queue , Net::Ping , Win32::ODBC , Win32::TieRegist
+ry ,  Pod::Usage

=head1 SEE ALSO

perl(1)

=head1 AUTHOR

=over 4

=item Jeff Thompson

Jeff Thompson I<jeff@ninthwave.us>

=item Gordon McKeown

Gordon McKeown I<perl@thefluffyone.net>

=back

=head1 VERSION CONTROL

=over 4

=item CREATED

28112003:10:32:00

=item VERSION

0.5

=back

=head1 ACKNOWLEDGEMENTS

=over 4

=item Perl Monks

L<http://perlmonks.org>

=item Perl Monks Offering Plate

L<http://perlmonks.org/index.pl?node=Offering%20Plate>

=item Perl Monks Discussion - Getopt::Long validation

L<http://perlmonks.org/index.pl?node_id=300594> With code supplied fro
+m jeffa L<http://jeffa.perlmonk.org/> used as the basis for argument 
+processing in this code.

=item Perl Monks Discussion - Self Extracting Cabinet File in Perl

L<http://perlmonks.org/index.pl?node_id=306580> With the insight of Li
+mbic~Region L<http://perlmonks.org/index.pl?node_id=180961> for resea
+rch on how cabinet.dll works. With some code suggestions from graff L
+<http://perlmonks.org/index.pl?node_id=44715> used in reflection of t
+he original methods.

=item Perl Monks Discussion - Non-blockin pings on Win32

L<http://perlmonks.org/index.pl?node_id=309673> With code supplied fro
+m meetraz L<http://perlmonks.org/index.pl?node_id=174574> and modifie
+d by NetWallah L<http://perlmonks.org/index.pl?node_id=159887>.  Thes
+e ideas became the basis of the use of threads.

=item Microsoft Cabinet SDK

L<http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnc
+absdk/html/cabdl.asp>

=item Stuart Caie's Cab extract

L<http://www.kyz.uklinux.net/cabextract.php>

=back

=cut

[download]

The Pod is not complete as I am still working on the script. I have to remove references to cab extract as I am doing that process in another script and I have to describe all command line options though it is fairly evident from the code what the options do.

One major note is we were getting responses where the ping replied by gethost returned null. I created a unique computer name based off that and am currently working on a clean up section that tries to identify the invidual devices.

Any additional clean up or efficiency suggestions would be appreciated.

"No matter where you go, there you are." BB

In Section Seekers of Perl Wisdom