in reply to Re^2: Trying to thread a daemon with threads and Thread::Queue
in thread Trying to thread a daemon with threads and Thread::Queue

Try replacing your handledata() sub with this: 

sub handleData {
    my $tid = threads->tid();

    my $fno = $Q->dequeue();
    my $clientAddr = $Q->dequeue();
    next if $fno eq 'STOP';
    my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
    my $ipStr = inet_ntoa( $clientIp );
    open my $socket, '+<&=' . $fno or die $!;
    my $request = <$socket>;
    chomp $request;
    if ($request eq '<policy-file-request/>') {
        warn("($tid) : XML Policy file request from: $ipStr");
        print $socket $content.$NULLBYTE;
    }
    else {
        warn("($tid) : Connection from: $ipStr");
        print $socket "<data><ip>$ipStr</ip></data>".$NULLBYTE;
    }
    shutdown $socket, 2;
    close $socket;
    return 1;
}

[download]

I don't anticipate that it will perform better than your non-threaded solution for teh reasons I stated above. Create a new thread to reply with a single line of code is never going to be quicker than replying inline, but it might just work well enough to allow you to see that for yourself.

For the application as you've posted, I am quite certain that you will not improve your performance using threads this way.

You'd almost certainly be better off using IO::Socket::INET and setting the Listener option to allow the tcpip stack to queue inbound requests.

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
"Too many [] have been sedated by an oppressive environment of political correctness and risk aversion."

Replies are listed 'Best First'.
Re^4: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 29, 2008 at 04:01 UTC
    BrowserUK, an older post of yours on the subject (from 2006) enlightened me, and I was able to find out what the problem was and got a little progress. Thank you so much..
    Re^5: multithreaded tcp listener with IO::Socket

    You mentioned: "The main problem with this approach is that you have to ensure that the socket returned by accept() does not go out of scope (causing the socket to be closed), before the thread has had chance to reopen it. That's easily achieved by pushing a copy of the socket handle into a (non-shared) array in the accept thread, as well as queueing it."

    So I went ahead and took a look at your sample code (threads::Server) from the next reply on that same thread, here:
    Re^7: multithreaded tcp listener with IO::Socket

    I realized you're using an associative array (hash) in the main accept thread to store the main handle and keep the socket open, and also using a seperate queue (Qclean) in another routine ( while($Qclean->pending) ) to close the socket once the thread is done with it, iiuc..
    Only problem is that the "close delete $hash{$fno}" line didn't work for me, leaving the connection on the client side open, so instead I tried: 
    close $hash{ $fno };
delete $hash{ $fno };

    [download]
    And that worked, the request went through. But... The process just mysteriously died!!! No errors, no warnings in the log, nothing!

    I tried taking out the line "shutdown $socket, 2;" from the end of the handleConnection() sub, and reran it, then the process doesn't die for each request, but also the client still doesn't close :(

    Removed the line "shutdown $socket, 2;" from the sub, and added "shutdown $sockets{ $fileno }, 2;" right before the "close $sockets{ $fileno };" line in the main accept thread, then the process doesn't die after a request, but also leaves the client open :| I'm puzzled...
    Any ideas on this one?

    Below is my full code (revised and cleaned of some minor bugs). 
    #!/usr/bin/perl -w

use strict;
use warnings;
use IO::Socket;
use threads;
use Thread::Queue;

use POSIX qw(setsid);
use Proc::PID::File;
use Log::Dispatch;
use Log::Dispatch::File;
use Date::Format;
use File::Spec;
use FindBin qw($Bin);

sub dienice ($);

###
### Change default configuration here if needed
###

# Our server port (Any number between 1024 and 65535)
my $port = 9999;
my $timeout = 60;
# Number of listener threads to spawn
# (2 or 3 threads are sufficient to handle 100 concurrent connections 
+since our duty cycle is a few milliseconds)
my $listeners = 3;
# Want to log connections? 1 = yes, 0 = no
my $log_connections = 1;
# Want to log if script is executed when it's already running?
# (You might want to set it to 0 if you run periodically from cron - t
+oo redundant)
my $log_is_running = 1;

#
# Do not change the following unless you know what you're doing!!!
#
my $content = '<?xml version="1.0"?><cross-domain-policy><allow-access
+-from domain="*" to-ports="' . $port . '" /></cross-domain-policy>';
my $NULLBYTE = pack( 'c', 0 );

###
### Detect our base directory where we create the log and pid files
###
our $BASE_DIR = $Bin;
# Get script name, chop off any preceding path it was called with and 
+chop off its extension (ex: 'some/dir/script.pl' becomes 'script')
our $ME = $0; $ME =~ s|.*/||; $ME =~ s|\..*||;
our $LOG_FILE = "$ME.log";

###
### Setup a logging agent
###
my $log = new Log::Dispatch(
    callbacks => sub { my %h=@_; return Date::Format::time2str('%B %e 
+%T', time)." $ME\[$$]: ".$h{message}."\n"; }
);
$log->add( Log::Dispatch::File->new( name        => 'file1',
                                     min_level    => 'warning',
                                     mode        => 'append',
                                     filename    => File::Spec->catfil
+e($BASE_DIR, $LOG_FILE),
                                    )
);

###
### Fork and background daemon process
###
startDaemon();
$log->warning("Logging Started");

###
### Setup signal handlers to give us time to cleanup (and log) before 
+shutting down
###
my $running = 1;
$SIG{HUP}  = sub { $log->warning("Caught SIGHUP:  exiting gracefully")
+; $running = 0; };
$SIG{INT}  = sub { $log->warning("Caught SIGINT:  exiting gracefully")
+; $running = 0; };
$SIG{QUIT} = sub { $log->warning("Caught SIGQUIT:  exiting gracefully"
+); $running = 0; };
$SIG{TERM} = sub { $log->warning("Caught SIGTERM:  exiting gracefully"
+); $running = 0; };

my $Q = Thread::Queue->new;
my $Qclean = Thread::Queue->new;

###
### As long as the daemon is running, listen for and handle received c
+onnections
###
while ($running) {
    ###
    ### Spawn our listener threads and detach them since we don't want
+ return values and don't to wait for them to finish
    ### "detach" also allows automatic cleanup of the thread and recyc
+les its memory
    ###
    for (1..$listeners) {
        threads->create(\&handleConnection)->detach;
    }

    ###
    ### BEGIN LISTENING
    ###
    my $sock = new IO::Socket::INET(
                        LocalPort    => $port,
                        Proto        => 'tcp',
                        Listen        => SOMAXCONN,
                        ReuseAddr    => 1);
    $sock or dienice("Socket error :$!");

    $log->warning("Listening on port $port");

    ###
    ### Handle connections
    ###
    my %sockets = ();
    while ( my ($new_sock, $clientAddr) = $sock->accept() )
    {
        my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
        # put the connection on the queue for a reader thread
        my $fno = fileno($new_sock);
        $sockets{ $fno } = $new_sock;
        $Q->enqueue( "$fno\0$clientIp" );
        while( $Qclean->pending )
        {
            my $fileno = $Qclean->dequeue();
            close $sockets{ $fileno };
            delete $sockets{ $fileno };
        }
    }
}

###
### Mark a clean exit in the log
###
$log->warning("Logging Stopped");

###
### startDaemon
###
sub startDaemon {
    # fork a child process and have the parent process exit to disasso
+ciate the process from controlling terminal or login shell
    defined(my $pid = fork) or dienice("Can't fork: $!");
    exit if $pid;
    # setsid turns the process into a session and group leader to ensu
+re our process doesn't have a controlling terminal
    POSIX::setsid() or dienice("Can't start a new session: $!");

    # Get a PID file - or exit without error in case we're running per
+iodically from cron
#    if ( Proc::PID::File->running(dir => "$BASE_DIR", name => "$ME", 
+verify => "1") )
#    {
#        $log->warning("Daemon Already Running!") if ($log_is_running)
+;
#        exit(0);
#    }
}

###
### handleConnection
###
sub handleConnection {
    my $tid = threads->tid();
    $log->warning("Thread ($tid) started");
    while ( my $work = $Q->dequeue() )
    {
        my ( $fno, $clientIp ) = split ( chr(0), $work );
        my $clientIpStr = inet_ntoa( $clientIp );
        local $/ = $NULLBYTE;

        open my $socket, '+<&='.$fno or dienice("Thread ($tid) could n
+ot reopen socket: $!");
        my $request;
        if ( defined ( $request = <$socket> ) )
        {
            chomp $request;
            if ( $request eq '<policy-file-request/>' )
            {
                $log->warning("($tid) : XML Policy file request from: 
+$clientIpStr") if ($log_connections);
                print $socket $content.$NULLBYTE;
            }
            elsif ( $request =~ /<request>getmyip<\/request>/ )
            {
                $log->warning("($tid) : XML IP request from: $clientIp
+Str") if ($log_connections);
                print $socket "<data><ip>$clientIpStr</ip></data>".$NU
+LLBYTE;
            }
            else
            {
                $log->warning("($tid) : Ignoring unrecognized request 
+from: $clientIpStr") if ($log_connections);
            }
        }
        else
        {
            $log->warning("($tid) : Ignoring NULL connection from: $cl
+ientIpStr") if ($log_connections);
        }
        shutdown $socket, 2;
        close $socket;
        $Qclean->enqueue( $fno );
    }
    return 1;
}

###
### dienice
###
sub dienice ($) {
  my ($package, $filename, $line) = caller;
  # write die messages to the log before die'ing
  $log->critical("$_[0] at line $line in $filename");
  die $_[0];
}

    [download]
[reply]
[d/l]
[select]
      BrowserUK, an older post of yours on the subject (from 2006) enlightened me, and I was able to find out what the problem was and solved my issues. Thank you so much..

      Gah! You're too generous. I should have remembered and recognised that problem and saved you a couple of days. I'm glad you've achieved your goal.

      However, I still fail to see how spawning a new thread, or just transfering the socket to a thread pool is going to operate more quickly than just printing one short line, closing the connection and going back to the accept. Whilst a single push to a queue is going to be faster than IO to a socket, given that you're now setting up the listener queue, the tcp stack should be able to buffer the connections long enough to make the difference moot.

      Did you do any soak testing yet?

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
        Bleh! I updated my post after I realized another problem, and found you already replied back :|
        I can't do any testing yet, due to the problem I described in my previous (updated) reply..

        I am not really concerned about the speed of the response of the threaded version of this script vs. the non-threaded version. The whole idea was to allow handling multiple simultaneous connections/requests, in case one client is really lazy or slow, I don't want it to delay other clients/requests for several seconds.

        Still, I am curious to test it and see the difference, once I get it working :)
[reply]
Re^4: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 29, 2008 at 16:55 UTC
    Hmm. Have you managed to track down what code is executing when that silent abnormal termination occurs?
    Yep, with some extra logging..

    First, I added this in main to prevent the abend: 
    $SIG{PIPE} = sub { $log->warning("Caught SIGPIPE:  $!"); $running = 1;
+ };

    [download]
    Then added this in the handler thread: 
            $log->warning("In thread: Attempting to shutdown handle associ
+ated with fileno: $fno");
        shutdown ($socket, 2) or $log->warning ("In thread: Shutdown e
+rror: $!");
        $log->warning("In thread: Attempting to close handle associate
+d with fileno: $fno");
        close $socket or $log->warning ("In thread: close error: $!");
        $log->warning("In thread: Enqueing in Qclean fileno: $fno");
        $Qclean->enqueue( $fno );

    [download]
    I simulate a connection from client: 
    $ perl -e 'printf "<request>getmyip</request>%c",0' | ./nc myhost.com 
+9999

    [download]
    The connection is immediately closed as desired, but I get nothing back from the server for my request, when --according to the code in the thread-- I should be getting this back: 
    <data><ip>x.x.x.x</ip></data>

    [download]
    The output in the log: 
    August 29 09:12:44 xmlsockd-advanced[32652]: (1) : XML IP request from
+: x.x.x.x
August 29 09:12:44 xmlsockdx[32652]: In thread: Attempting to shutdown
+ handle associated with fileno: 5
August 29 09:12:44 xmlsockdx[32652]: In thread: Attempting to close ha
+ndle associated with fileno: 5
August 29 09:12:44 xmlsockdx[32652]: Caught SIGPIPE:  Broken pipe
August 29 09:12:44 xmlsockdx[32652]: In thread: close error: Broken pi
+pe

    [download]
    Caused by the close() call after shutdown() in the handler thread (the code you previously suggested), not the close() in Main!

    I go ahead and remove the close() call in the handler thread keeping only the shutdown() call, so it will look like this: 
    $log->warning("In thread: Attempting to shutdown handle associated wit
+h fileno: $fno");
shutdown ($socket, 2) or $log->warning ("In thread: shutdown error: $!
+");
$log->warning("In thread: Enqueing in Qclean fileno: $fno");
$Qclean->enqueue( $fno );

    [download]
    And in the main accept() loop I also remove the close() call, so it will look like this: 
        while ( $Qclean->pending )
    {
        my $fileno = $Qclean->dequeue();
        delete $sockets{ $fileno };
    }

    [download]
    Again, I simulate another connection from client via shell: 
    $ perl -e 'printf "<policy-file-request/>%c",0' | ./nc myhost.com 9999

    [download]
    I should've got this response: 
    <?xml version="1.0"?><cross-domain-policy><allow-access-from domain="*
+" to-ports="9999" /></cross-domain-policy>

    [download]
    But again, the connection is immediately closed on the client side before they even receive a response to their request as coded for in the handler thread..
    This is very bad!

    Now the log shows: 
    August 29 09:26:31 xmlsockd[7815]: (1) : XML IP request from: x.x.x.x
August 29 09:26:31 xmlsockd[7815]: In thread: Attempting to shutdown h
+andle associated with fileno: 5
August 29 09:26:31 xmlsockd[7815]: In thread: Enqueing in Qclean filen
+o: 5
August 29 09:26:31 xmlsockd[7815]: Caught SIGPIPE:  Broken pipe

    [download]
    Probably as I said previously, having the shutdown on the dup handle in the thread causes SIGPIPE to be thrown because the main handle is still open in the main accept() thread. And for whatever reason (which I am unaware of), whatever the handler thread wrote back on the socket prior to the shutdown is lost and is not sent to the client. Hmmm???

    However, if I _remove_ the shutdown() call from the handler thread (keeping only the "close $socket" line), the client's request gets back the proper response, only it doesn't get immediately closed (until another connection comes in as we previously established)

    In my tests (under win32), if I dont use shutdown in the hendler thread, the client connection stays open until the main thread gets around to closing its copy of the socket.
    Did you actually get a response back for your request when you have shutdown() in the handler thread?
    Are you ignoring SIGPIPE?

    Maybe Win32 doesn't blow up with SIGPIPE when a handle is closed somewhere in the code while it's still open elsewhere?
    Still, it certainly does on *nix according to my testing...
[reply]
[d/l]
[select]
      Are you ignoring SIGPIPE?

      There is no such concept as SIGPIPE under Win32. Hence why I said that I cannot help you debug this further, I simply cannot reproduce the failure here.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
Re^4: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 27, 2008 at 22:32 UTC
    tried the handleData() sub you suggested. Exhibits teh same exact problem as the one I described above... It was probably one of the very first versions I tried of that sub :/

    The socket doesn't receive anything, hangs, until on the client connect side I CTRL+C, then the server log would show just one log message "(3) : Connection from: x.x.x.x", and the server immediately dies with no errors/warnings right after.

    I will try IO::Socket, it's something I've been meaning to do.. Perhaps two different variations, one script as you describe, and another with threads and threads::shared, kind of like the 4th point discussed on this thread:
    Re: Passing an IO:Handle to a Thread

    My main concern behind the limitation of handling one connection at a time is the possibility of a really slow (or dysfunctional) client that takes too long to send its request (or doesn't send a request at all) after it connects to the server, making all other incoming connections queued as long as the connected (slow/dysfunctional) client has not timed out.

[reply]

      Sorry, I don't think I can help further. Your code with that change works for me here. I have stayed with (actually reverted to) 5.8.6 because I've had all kinds of unresolvable problems using threads with 5.8.8. Too many changes have been made for change sake. The once pretty reliable techniques I used successfully since 5.8.0 stop working. The current maintainer has his own agenda, which from my perspective comes down to complexity for its own sake.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
        Strange... The server I am testing on is running perl 5.8.5 Anyways, I think I might just try without Thread::Queue completely, perhaps just threads and threads::shared.
        A thought that comes to mind, is to keep the connection threads alive for a pre-defined number of connections, say $threadLifeTime = 100.

        I'll do some more reading and research to see if I can do without Thread::Queue.
[reply]
Re^4: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 28, 2008 at 21:09 UTC
    In an attempt to trace the problem, I modified my code a bit for the sub handleData()

    Here is the relative lines from the sub:
    my $tid = threads->tid();
my $fno = $Q->dequeue();
last if $fno eq 'STOP';
$log->warning("Thread ($tid) : fileno: $fno");
open my $socket, '+<&='.$fno or dienice("Thread ($tid) could not reope
+n socket: $!");

    [download]

    When I try to connect from client side, I see this in the server log:
    Thread (1) : fileno: 5
Thread (1) could not reopen socket: Bad file descriptor at line 152

    [download]
    Which is the "open my $socket, '+<&='.$fno" Line..
    If I try connecting again, the fileno is still 5, only the thread number changes (1..3 when running only 3 listener threads) and each thread is "terminated abnormally" due to this error.

    Other instance, I get this in the log (both lines returned on one connection only) 
    Thread (2) : fileno: ÆD²©ê
Thread (3) : fileno: 5

    [download]
    Or this: 
    Thread (1) : fileno: 5
Thread (2) : fileno: ÆýD²©ê

    [download]
    And the client gets nothing back to its request.

    Running:
    Perl 5.8.5 and Thread::Queue 2.11
    OS: Linux
[reply]
[d/l]
[select]

      Sorry, but you've posted several versions and partial version of your code in this thread and there is no way for me to guess which version the above is applied to. If you post the full version that demonstrates the problem I will take a look at it.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
Re^4: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 29, 2008 at 06:48 UTC
    Recoup on:
    Re^6: Trying to thread a daemon with threads and Thread::Queue

    The following part of the code (in the handleConnection() sub) has a serious flaw: 
            shutdown $socket, 2;

    [download]
    From: perldoc on shutdown()
    "It's also a more insistent form of close because it also disables the file descriptor in any forked copies in other processes."

    The thread tries to force closing the socket using shutdown() (after the thread is done with the connection) while the main accept thread still has it open, causing the script to abnormally terminate without any errors messages.
    Removing this line from the handleConnection() sub and keeping only "close socket;", re-running the script, then simulating a client connection and request returns the expected data, but the client sees the connection still open (because the socket wasn't closed from server)

    This is due to the construct of the main accept thread: 
    while ( my ($new_sock, $clientAddr) = $sock->accept() )
{
    my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
    # put the connection on the queue for a reader thread
    my $fno = fileno($new_sock);
    $sockets{ $fno } = $new_sock;
    $Q->enqueue( "$fno\0$clientIp" );
    while ( $Qclean->pending )
    {
        my $fileno = $Qclean->dequeue();
        $log->warning("Attempting to close handle associated with file
+no: $fileno");
        close $sockets{ $fileno };
        delete $sockets{ $fileno };
    }
}

    [download]
    Basically the while ( $Qclean->pending ) is not immediately triggerd (to close the socket in the main accept thread) because it is inside the while ( ... $sock->accept() ), and won't happen until another client connects, so the first client will just hang because it sees the socket on the server is still open.

    In other words, client-A connects and sends request, gets response, but the server doesn't close the socket, so the client stays connected even though the server is done sending.
    Then when client-B connects, Qclean is checked and sees the socket associated with client-A needs to be closed, so it goes ahead and closes it.

    I'm stumped... Any thoughts/ideas on how to fix this?

    Update:
    I tried adding this early in my script: 
    SIG{PIPE}='IGNORE';

    [download]
    After re-adding the shutdown() line before close() in the handleConnection() sub to avoid the script blowing up because of SIGPIPE: 
    shutdown $socket, 2;
close $socket;

    [download]
    But then the client doesn't get the response (what is written on the socket by the server thread from the handleConnection() sub), just a connection drop :S
[reply]
[d/l]
[select]
      The thread tries to force closing the socket using shutdown() (after the thread is done with the connection) while the main accept thread still has it open, causing the script to abnormally terminate without any errors messages.

      Hmm. Have you managed to track down what code is executing when that silent abnormal termination occurs?

      In my tests (under win32), if I dont use shutdown in the hendler thread, the client connection stays open until the main thread gets around to closing its copy of the socket. Which doesn't sound so bad until you realise that the main thread will never get around to closing the socket until it receives a new incoming connect to terminate the accept.

      So, you get a burst of incoming connects, queue up the file numbers and store the sockets in the main thread until the main threads timeslice ends. Then the child threads get a lookin, and process the requests, and close their copies of the handles.

      But, until the main thread both gets a timeslice, and receives new connect request all the clients your child threads processed are sitting there with open connections. As the main thread will be able to queue up (potentially) several hundred connections before it relinguishes its timeslice, and your child threads will process and close but not disconnect those same several hundred once they get timeslices, there is the potential for having several hundred clients hanging around waiting for a new client to connect before their connections will be terminated. If your traffic is in any way 'bursty', that could prove to be a big problem.

      If the abend is down to the main thread trying to close a socket that has already been closed--though I wouldn't have though that likely; There is not logic to the idea that shutdown would cause this failure, as this use is exactly what it is designed for--then it would be better to do the shutdown in the handler threads and just discard the sockets in the main thread rather than attempting to close them.

      Needless to say, but I will anyway :) I cannot reproduce your failure here, so you are going to have to explore the reason for the abend yourself.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
Re^4: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 30, 2008 at 02:19 UTC
    Meh, I just went with a totally different route..

    1. Setting up IO::Socket::INET in main, and passing the $main_sock to a pool on pre-forked threads which all handle the accept()

    2. Multiplexing with IO::Select in each thread to avoid the blocking nature of the accept() call. This provides us the advantage to pickup the faster client (the one who's able to send the request faster) and avoid a lazy client who takes their sweet time before they send their request (in the case of simultaneous connections/bursts)

    I mentioned previously that I simulated a pair of sequential connections a 100 times with the non-threaded/non-select script which took about 1.990 seconds.

    Doing the same simulation test on the new version of the script (a pre-forked pool of 3 threads and using the select method in each thread) took about 2.063 seconds.

    Therefore, IMHO, the overhead is very minimal, and quite a fair trade off for having the ability to handle multiple clients simultaneously.

    Only if I am wasn't so tired now, I would've quickly coded a script using threads to simulate maybe 20 or 30 simultaneous (asynchronous) connections a few times in a row and compare the results of the two versions of the script, even though I'm sure the threaded/non-blocking version would be way faster.

    Here's my new threaded version of the script. Comments/Suggestions welcome.. 
    #!/usr/bin/perl -w

use strict;
use warnings;
use IO::Socket;
use IO::Select;
use threads;

use POSIX qw(setsid);
use Proc::PID::File;
use Log::Dispatch;
use Log::Dispatch::File;
use Date::Format;
use File::Spec;
use FindBin qw($Bin);

sub dienice ($);

###
### Change default configuration here if needed
###

# Our server port (Any number between 1024 and 65535)
my $port = 9999;
# Number of listener threads to spawn
# (2 or 3 threads are sufficient to handle 100 concurrent connections 
+since our duty cycle is a few milliseconds)
my $listeners = 3;
# Want to log connections? 1 = yes, 0 = no
my $log_connections = 1;
# Want to log if script is executed when it's already running?
# (You might want to set it to 0 if you run periodically from cron - t
+oo redundant)
my $log_is_running = 1;

#
# Do not change the following unless you know what you're doing!!!
#
my $content = '<?xml version="1.0"?><cross-domain-policy><allow-access
+-from domain="*" to-ports="' . $port . '" /></cross-domain-policy>';
my $NULLBYTE = pack( 'c', 0 );

###
### Detect our base directory where we create the log and pid files
###
our $BASE_DIR = $Bin;
# Get script name, chop off any preceding path it was called with and 
+chop off its extension (ex: 'some/dir/script.pl' becomes 'script')
our $ME = $0; $ME =~ s|.*/||; $ME =~ s|\..*||;
our $LOG_FILE = "$ME.log";

###
### Setup a logging agent
###
my $log = new Log::Dispatch(
    callbacks => sub { my %h=@_; return Date::Format::time2str('%B %e 
+%T', time)." $ME\[$$]: ".$h{message}."\n"; }
);
$log->add( Log::Dispatch::File->new( name        => 'file1',
                                     min_level    => 'warning',
                                     mode        => 'append',
                                     filename    => File::Spec->catfil
+e($BASE_DIR, $LOG_FILE),
                                    )
);

###
### Fork and background daemon process
###
startDaemon();
$log->warning("Logging Started");

###
### Setup signal handlers to give us time to cleanup (and log) before 
+shutting down
###
my $running = 1;
$SIG{HUP}  = sub { $log->warning("Caught SIGHUP:  exiting gracefully")
+; $running = 0; };
$SIG{INT}  = sub { $log->warning("Caught SIGINT:  exiting gracefully")
+; $running = 0; };
$SIG{QUIT} = sub { $log->warning("Caught SIGQUIT:  exiting gracefully"
+); $running = 0; };
$SIG{TERM} = sub { $log->warning("Caught SIGTERM:  exiting gracefully"
+); $running = 0; };
$SIG{PIPE} = sub { $log->warning("Caught SIGPIPE (Ignoring):  $!"); $r
+unning = 1; };

if ( $running == 1 )
{
    ###
    ### BEGIN LISTENING
    ###
    my $main_sock = new IO::Socket::INET(
                        LocalPort    => $port,
                        Proto        => 'tcp',
                        Listen        => SOMAXCONN,
                        ReuseAddr    => 1);
    $main_sock or dienice("Socket error :$!");

    $log->warning("Listening on port $port");

    ###
    ### Spawn our listener threads and detach them since we don't want
+ return values and don't to wait for them to finish
    ### "detach" also allows automatic cleanup of the thread and recyc
+les its memory
    ###
    for (1..$listeners) {
        threads->create(\&handleConnection, $main_sock)->detach;
    }
    while ($running)
    {
        # Keep running
    }
}

###
### Mark a clean exit in the log
###
$log->warning("Logging Stopped");

###
### startDaemon
###
sub startDaemon {
    # fork a child process and have the parent process exit to disasso
+ciate the process from controlling terminal or login shell
    defined(my $pid = fork) or dienice("Can't fork: $!");
    exit if $pid;
    # setsid turns the process into a session and group leader to ensu
+re our process doesn't have a controlling terminal
    POSIX::setsid() or dienice("Can't start a new session: $!");

    # Get a PID file - or exit without error in case we're running per
+iodically from cron
#    if ( Proc::PID::File->running(dir => "$BASE_DIR", name => "$ME", 
+verify => "1") )
#    {
#        $log->warning("Daemon Already Running!") if ($log_is_running)
+;
#        exit(0);
#    }
}

###
### handleConnection
###
sub handleConnection {
    my $main_sock = shift;
    my $tid = threads->tid();
    $log->warning("Thread ($tid) started");

    # Multiplexing Using select (See: http://www.unix.com.ua/orelly/pe
+rl/advprog/ch12_03.htm)
    my $s = new IO::Select( $main_sock );
    my ($new_sock, $sock, $fno, $clientAddr, $clientPort, $clientIp, $
+clientIpStr, $request);
    my %clients = ();
    my @ready = ();
    while ( @ready = $s->can_read )
    {
        foreach $new_sock (@ready)
        {
            if ($new_sock == $main_sock)
            {
                ($sock, $clientAddr) = $main_sock->accept;
                ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr 
+);
                $clientIpStr = inet_ntoa( $clientIp );
                $fno = fileno($sock);
                $clients{ $fno } = $clientIpStr;
                $s->add($sock);
            } else {
                $fno = fileno($new_sock);
                $clientIpStr = $clients{ $fno };
                delete $clients{ $fno };
                local $/ = $NULLBYTE;
                if ( defined ( $request = <$new_sock> ) )
                {
                    chomp $request;
                    if ( $request eq '<policy-file-request/>' )
                    {
                        $log->warning("($tid) : XML Policy file reques
+t from: $clientIpStr") if ($log_connections);
                        print $new_sock $content.$NULLBYTE;
                    } elsif ( $request =~ /<request>getmyip<\/request>
+/ ) {
                        $log->warning("($tid) : XML IP request from: $
+clientIpStr") if ($log_connections);
                        print $new_sock "<data><ip>$clientIpStr</ip></
+data>".$NULLBYTE;
                    } else {
                        $log->warning("($tid) : Ignoring unrecognized 
+request from: $clientIpStr") if ($log_connections);
                    }
                }
                $s->remove($new_sock);
                close $new_sock;
            }
        }
    }
}

###
### dienice
###
sub dienice ($) {
  my ($package, $filename, $line) = caller;
  # write die messages to the log before die'ing
  $log->critical("$_[0] at line $line in $filename");
  die $_[0];
}

    [download]
[reply]
[d/l]

      This empty loop in your main thread: 

          while ($running)
    {
        # Keep running
    }

      [download]

      will consume as much cpu as the scheduler can give it. In essence, this means that when the main thread gets a timeslice, it will consume 100% of your cpu for its entire timeslice, doing absolutely nothing and preventing any other threads or processes getting a look in (unless you have multiple cores). Even if you have mutliple cores, this would just be 'busy work' consuming resources and power for no good reason.

      At the very least you should slow that loop down: 

      sleep 1 while $running;

      [download]

      Beyond that, what you have seems way too complex--mixing as it does fork, threads and select--and I seriously doubt that it will perform any better than a simple, single-threaded process. Of course, you can run your tests and 'prove' me wrong and I cannot argue with you. And after all, it's your code and you will have to maintain it.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
[select]
        the empty loop in the main thread: 
            while ($running)
    {
        # Keep running
    }

        [download]
        was to keep the script from ending (or code falling off the end of the script) soon after it spawns the threads... guess you're right..

        So what do you suggest I do to prevent the script from ending after the main thread spawns the threads ? sleep while ($running); ?
[reply]
[d/l]

In Section Seekers of Perl Wisdom