Multithreaded Socket Listener

[hoggle64]

Hi guys, i've written a kind of socket listener to execute commands on remote machines. The listener waits for an incoming (HTTP) call and then basically executes a command.
My Problem is that I cannot manage it to be multithreaded. Your can fire 10 requests right away, but they will be processed one by one and not in parallel. I am using a browser to send the request.
I am already forking children to archieve this, but for some reason it won't work.

I know it's a big piece of code and looks ugly here. Sorry for this.
If somebody has a hint for me - I would be very thankful :O)

#!/usr/bin/perl


use lib "lib"; 
use warnings;
use Cwd;
use Time::Local;
use File::stat;
use Config::Properties;
use Log::Log4perl;
use IO::Socket;
# for OO version of gethostbyaddr
use Net::hostent;
use POSIX 'setsid';

# flush after every write
$| = 1;

# change to script directory in any case
my $script_dir = $0;
$script_dir =~ s/[\\|\/]PRTG_adapter\.pl$//;
chdir $script_dir;

# open central configuration
my $props_main = "conf\/main.cfg";
unless ( -e $props_main ) {
   print "cannot load main configuration(conf/main.cfg) !\n";
   exit 1;
}      
open my $fh, "<:encoding(UTF8)", $props_main  or die "unable to open c
+onfiguration file: $props_main";
# load properties
my $properties_main = Config::Properties->new();
$properties_main->load($fh);
close $fh;

# init log4perl
Log::Log4perl::init($properties_main->getProperty('log_config'));
my $logger = Log::Log4perl->get_logger('PRTG_adapter');
my $lock_file = $properties_main->getProperty('lock_file');

if ( $#ARGV == 0 ) {

   if ( $ARGV[0] eq 'start' ) {
      start();
   }
   elsif ( $ARGV[0] eq 'stop' ) {
      stop();
   }
   elsif ( $ARGV[0] eq 'status' ) {
      status();
   }
   elsif ( $ARGV[0] eq 'restart' ) {
      stop();
      start();
   }
   else {
      print "usage: PRTG_adapter.pl start|stop|status\n";
      exit 2;
   }
}
else {
   print "usage: PRTG_adapter.pl start|stop|status\n";
   exit 2;
}


sub start {
   print "starting process\n";
   # check if process is running already
   if ( -e $lock_file ) {
      eval {
         open FILE, "<$lock_file" or die $!;
      };
      if ($@) {
         print "cannot open the pid file: $@ !\n";
      }
      my $pid = <FILE>;
      close(FILE);
      my $exists = kill 0, $pid;
      if ( $exists ) {
         print "found a running process running with pid $pid !\n";
     exit 2;
      }
      else {
         print "found *NO* process running with pid $pid !\n";
     print "delete the lock file manually before you proceed.\n";
     print "lock file: $lock_file";
         exit 2;
      }
   }
   else {
      # fork a child
      my $child = fork();
      unless ( defined $child ) {
         print "cannot fork child process !\n";
         exit 2;
      }
      if ( $child ) {
         # parent is exiting now
         print "detaching child process\n";
         exit 0;
      }
      else {
         # detach child process from parent
         setsid;
         eval {
            open(FILE,">$lock_file");
         };
         if ($@) {
            print "cannot open the pid file for writing: $@ !\n";
         }
         print FILE $$;
         close(FILE);
      }
   }
}

sub stop {
   if ( -e $lock_file ) {
      eval {
         open FILE, "<$lock_file" or die $!;
      };
      if ($@) {
         print "cannot open the pid file: $@ !\n";
         exit 2;
      }
      my $pid = <FILE>;
      close(FILE);
      my $exists = kill 0, $pid;
      if ( $exists ) {
         print "found a running process running with pid $pid !\n";
         print "stopping process";
         for ( my $i = 1; $i <= 10; $i++ ) {
            $exists = kill 0, $pid;
            if ( $exists ) {
               print ".";
               kill("QUIT",$pid);
               kill("TERM",$pid);
               sleep 1;
            }
            else {
               print "\nprocess stopped.\n";
               unlink($lock_file);
               unless ( $ARGV[0] eq 'restart') {
                  exit 0;
               }
               return;
            }
         }
         print "\nprocess wont't stop !\n";
         exit 2;
      }
      else {
         print "found *NO* process running with pid $pid !\n";
         print "delete the lock file manually before you proceed.\n";
         print "lock file: $lock_file";
         exit 2;
      }
   }
   else {
      print "no lockfile existing!\n";
      exit 2;
   }
}

sub status {
   if ( -e $lock_file ) {
      eval {
         open FILE, "<$lock_file" or die $!;
      };
      if ($@) {
         print "cannot open the pid file: $@ !\n";
         exit 2;
      }
      my $pid = <FILE>;
      close(FILE);
      my $exists = kill 0, $pid;
      if ( $exists ) {
         print "process is running with pid " . $pid . "\n";
         exit 0;
      }
      else {
         print "lockfile found with pid " . $pid . ", BUT no process r
+unning !\n";
         exit 2;
      }
   }
   else {
      print "found no lockfile. service seems to be stopped\n";
      exit 0;
   }
}


# setup our tiny server
$logger->debug("initiating listener");

my $server = IO::Socket::INET->new( Proto     => "tcp",
                                    LocalPort => $properties_main->get
+Property('listener_port'),
                                    Listen    => "5",
                                    Reuse     => "1");
                                  
unless ( $server ) {
   $logger->error("can't setup server");
   exit 2;
}

$logger->info("Server $0 accepting clients at http://localhost:" . $pr
+operties_main->getProperty('listener_port'));

# start listening for requests
while ( $client = $server->accept() ) {

   $logger->debug("forking child now");
   
   # avoid zombies
   $SIG{CHLD} = 'IGNORE';
   
   my $child = fork();
      
   local $SIG{CHLD};
   
   if ( $child ) {
         # parent can close client now
         $logger->debug("this is parent process closing client now");
      $client->close();
      $logger->debug("parent closed client");
   }
   else {
       $logger->debug("this is child");
       my @resultfiles;
       my @max_exec_secs;
       $logger->debug("incoming request from " . $client->peerhost() .
+ "(Port: " . $client->peerport() . ")" );
       
    
       $client->autoflush(1);
       my $request = <$client>;
       $logger->debug("requested: " . $request );
       
       # if we receive a vaild request
       my $valid_request = $properties_main->getProperty('valid_reques
+t');
       if ( $request =~ m/$valid_request/ ) {
         
          # store the html result here
          my $html_output = "";
          
          # build a summary at the end
          my $counter = 0;
    
          # open properties file
          my $props_file = "properties/" . $1 . ".prop";
          $logger->debug("configuration to load: " . $props_file);
          
          if ( -e $props_file ) {
             $logger->debug( "found configuration." );
          }
          else {
             my $message = "error = no such configuration found(" . $p
+rops_file .") skipping.";
             $logger->warn( $message );
             print $client $message;
             close $client;
             next;
          }
          open my $fh, "<:encoding(UTF8)", $props_file  or die "unable
+ to open configuration file: $props_file";
    
          # load properties
          my $properties = Config::Properties->new();
          $properties->load($fh);
          close $fh;
    
          # build a list of files to check
          for (my $i=1; $i < 30; $i++) {
             my $current_resultfile   = "resultfile"   . $i;
             my $current_max_exec_sec = "max_exec_sec" . $i;
             if ( $properties->getProperty($current_resultfile) && $pr
+operties->getProperty($current_max_exec_sec) ) {
                $logger->debug( "commandline    : " . $properties->get
+Property($current_resultfile) );
                $logger->debug( "exec time limit: " . $properties->get
+Property($current_max_exec_sec) );
                if ( $properties->getProperty($current_max_exec_sec) >
+ 10 ) {
                    $logger->warn("max execution time limit of " . $pr
+operties->getProperty($current_max_exec_sec) . " is too high.");
                    $logger->warn("using 10 seconds instead");
                    push(@max_exec_secs , 10);
                }
                else {
                   push(@max_exec_secs , $properties->getProperty($cur
+rent_max_exec_sec));
                }
                push(@resultfiles   , $properties->getProperty($curren
+t_resultfile));
             }
             else {
                last;
             }
          }
           
          # if list of logsfiles is empty abort
          if ( $#resultfiles < 0 ) {
             my $message = "error = no files found to process. skippin
+g.";
             $logger->warn( $message );
             print $client $message;
             close $client;
             next;
          }
    
          # remove newlines in file list
          foreach $file (@resultfiles) {
             chomp($file);
          }
    
    
          # loop the resultfiles array
          for (my $i=0; $i <= $#resultfiles; $i++) {
             my $resultfile        = $resultfiles[$i];
             my $max_exec_sec      = $max_exec_secs[$i];
    
             # exit codes of commandline execution
             my $exitcode;
             my $exitcode_native;
             eval {
                # set alarm signal handler
                local $SIG{ALRM} = sub {die "execution timelimit excee
+ded $!"};
                # set alarm timeout to 2 seconds
                alarm($max_exec_sec);
                # execute external command here ! 
                my $command = $resultfile;
                # fetch output into array
                @data = `$command`;
                # save the exitcode(s)
                $exitcode = $?;
                $exitcode_native = ${^CHILD_ERROR_NATIVE};
                # unset alarm timer
                alarm(0);
                $logger->debug("returncode: " . $?);
                $logger->debug("child native exitcode: " . ${^CHILD_ER
+ROR_NATIVE});
                # verify successfull exection
                if ( $exitcode != 0 || $exitcode_native != 0) {
                   die "unsuccessfull execution $!";
                }
                # if we have been successfull
                else {
                   foreach my $line( @data ) {
                      chomp($line);
                      $logger->debug($line);
    
                      # check if the resultline matches our expected f
+ormat
                      if ( $line =~ / *([A-Za-z0-9_\-]+) += +([0-9]+) 
+*/) {
                         $logger->debug("variable: $1, value: $2");
                         $counter = $counter + $2;
                      }
                      else {
                         $logger->error("current item to process: $lin
+e");
                         die "unexpected output format";
                      }
                      
                      $html_output = $html_output .  $line . "\n";
                   }
                }
             };
             # catch errors
             if ( $@ ) { 
                # response timed out
                if ( $@ =~ /execution timelimit exceeded/ ) {
                   $message = "the external script takes too much time
+ to respond";
                   $logger->error($message);
                   $html_output = "error = " . $message ."\n";
                   last;
    
                }
                # exitcode not ok 
                elsif ( $@ =~ /unsuccessfull execution/ ) {
                   $message = "the external script returned an errorst
+atus";
                   $logger->error($message);
                   $logger->error("statuscode: $exitcode($exitcode_nat
+ive)");
                   $html_output = "error = " . $message ."\n";
                   last;
                }
                elsif ( $@ =~ /unexpected output format/ ) {
                   $message = "unexpected output format from external 
+script";
                   $logger->error($message);
                   $html_output = "error = " . $message ."\n";
                   last;
                }
                # another error occured
                else {
                   $message = "internal error calling external script"
+;
                   $logger->error($message);
                   $logger->error("statuscode: $exitcode($exitcode_nat
+ive)");
                   $html_output = "error = " . $message ."\n";
                   last;
                }
             }
          }
    
          # print the summmary
          unless ( $html_output =~ "error" ) {
             $html_output = $html_output .  "TOTAL = $counter\n";
          }
    
          # send html output to client
          print $client $html_output;
          $logger->debug("html output: " . $html_output);
       }
       else {
          print $client "error = invalid request";
          $logger->warn("received invalid request. Skipping");
       }
       $client->close();
       $server->close();
       undef(@resultfiles);
       CORE::exit(0);
   }
   if ( $child ) {
      # parent can close client now
         $logger->debug("Here is the parent process at the end of the 
+loop");
   }
}

[Anonymous Monk]

I know it's a big piece of code and looks ugly here. Sorry for this. If somebody has a hint for me - I would be very thankful :O)

It looks ugly anywhere :) seriously, subroutines should (for the most part) take arguments, not operate on global variables

You need more subroutines, there is way too much code outside of subroutines.

Instead of # build a list of files to check you need  my @resultfiles = files_to_check( $properties );

Your code contains exit 18 times -- way too many,

Your loop should be short, like

while( $client = $server->accept() ) {
    if( my $pid = fork() ){
        $logger->debug( "this is parent process closing client now" );
        $client->close();
        $logger->debug( "parent closed client" );
    } else {
        KidStuff( $client , $logger, $pid, ... );
    }
}

This might interest you A suicidal parent OR death of a forking server

That's about all I got, except, you say you're using a browser -- then you might as well use write a plain old "CGI" PSGI, say with cgi-app / mojo / dancer / catalyst... and make it multithreaded with Perlbal or any other applicable server (feature of PSGI), instead of reinventing this particular wheel

Also, see Proc::Background :)

[zentara]

See Simple threaded chat server

[Anonymous Monk]

You are re-inventing a well-worn wheel here ...

One process should sit in a select loop waiting for incoming requests, then it should enqueue those requests to send them to a phalanx of waiting servers that will each provide a response.

Wait! Wait! I just described FastCGI (and Plack).

[karlgoethebier]

Good evening, i assume you use this and perhaps you should look here.

Regards, Karl

[hoggle64]

thank you guys for posting answers.