Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
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 cooling their heels in the Monastery: (5)
As of 2014-09-17 00:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (55 votes), past polls