Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Multithreaded Socket Listener

by hoggle64 (Initiate)
on Nov 14, 2012 at 19:08 UTC ( #1003877=perlquestion: print w/ replies, xml ) Need Help??
hoggle64 has asked for the wisdom of the Perl Monks concerning the following question:

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"); } }

Comment on Multithreaded Socket Listener
Download Code
Re: Multithreaded Socket Listener
by karlgoethebier (Curate) on Nov 14, 2012 at 21:58 UTC

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

    Regards, Karl

    «The Crux of the Biscuit is the Apostrophe»

Re: Multithreaded Socket Listener
by Anonymous Monk on Nov 14, 2012 at 22:13 UTC

    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 :)

Re: Multithreaded Socket Listener
by Anonymous Monk on Nov 15, 2012 at 02:28 UTC
    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).
Re: Multithreaded Socket Listener
by zentara (Archbishop) on Nov 15, 2012 at 10:36 UTC
Re: Multithreaded Socket Listener
by hoggle64 (Initiate) on Nov 15, 2012 at 15:19 UTC
    thank you guys for posting answers.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://1003877]
Approved by muba
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (15)
As of 2014-11-26 15:21 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (171 votes), past polls