PANIC: underlying join failed threded tcp server

[rmahin]

Hello again PerlMonks, I got a lot of help with this server a while back on here and it has been working great; with on exception. Once in a while, very very rarely, we see the error "PANIC: Underlying join failed" while joining threads on our windows machines only (so far). I have been unable to find anything online anywhere that is helpful in troubleshooting. Found the threads.xs code online, and found the lines where it is dying

        /* Join the thread */
#ifdef WIN32
        if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJE
+CT_0) {
            /* Timeout/abandonment unexpected here; check $^E */
            Perl_croak(aTHX_ "PANIC: underlying join failed");
        };
#else
        if ((rc_join = pthread_join(thread->thr, &retval)) != 0) {
            /* In progress/deadlock/unknown unexpected here; check $! 
+*/
            errno = rc_join;
            Perl_croak(aTHX_ "PANIC: underlying join failed");
        };
#endif

but this is foreign to me, and have no idea what WaitForSingleObject is doing. Here is my server code. I have cut out the majority of the commands that can be issued because they don't seem to be the issue. If needed I can re-post later.

#! /usr/bin/perl
#*********************************************************************
+*
#* (C) Copyright IBM Corporation 1997, 2011.  All rights reserved.    
+*
#*                                                                    
+*
#* Name: rxd                                                          
+*
#>                                                                    
+*
#* Function: This program executes commands issued from a remote      
+*
#*  client.  The basic function is to open a socket and listen for    
+*
#*  any of the following commands:                                    
+*
#*                                                                    
+*
#<    CHDIR() changes the current directory to the directory in which 
+*
#*     this program was started.                                      
+*
#*                                                                    
+*
#*    CHDIR(Directory) changes the current directory to the new       
+*
#*     directory.                                                     
+*
#*                                                                    
+*
#*    CMD(Command) executes Command under a new invocation of the     
+*
#*     shell or command interpreter and does not wait for completion. 
+*
#*                                                                    
+*
#*    CMDF(Filespec Command) executes Command under a new invocation  
+*
#*     of the shell or command interpreter and writes the output to   
+*
#*     a file.                                                        
+*
#*                                                                    
+*
#*    COPY(SourceFile TargetFile) copies the source file on the       
+*
#*     remote system to the target file on the remote system.         
+*
#*                                                                    
+*
#*    DEL(Filespec) deletes the specified file(s).                    
+*
#*                                                                    
+*
#*    DIR() returns a list of files/directories in the current        
+*
#*     directory.                                                     
+*
#*                                                                    
+*
#*    DIR(Filespec) returns a list of files/directories matching the  
+*
#*     specified filespec.                                            
+*
#*                                                                    
+*
#*    ENV(Variable) returns the value of the requested environment    
+*
#*     variable.                                                      
+*
#*                                                                    
+*
#*    EXEC(Command) executes Command inline and returns the results.  
+*
#*                                                                    
+*
#*    FG(Command) executes Command inline in foreground and returns   
+*
#*     the command return code.                                       
+*
#*                                                                    
+*
#*    FGY(Command) executes Command inline in foreground with a 'y'   
+*
#*     piped to the command and returns the command return code.      
+*
#*                                                                    
+*
#*    GET(Filespec) copies the specified file in ASCII mode.          
+*
#*                                                                    
+*
#*    GETB(Filespec) copies the specified file in binary mode.        
+*
#*                                                                    
+*
#*    HALT() kill this daemon                                         
+*
#*                                                                    
+*
#*    HELP() returns the RXD help text.                               
+*
#*                                                                    
+*
#*    MSG(Text) displays the text on the remote system.               
+*
#*                                                                    
+*
#*    REN(Oldname Newname) renames the specified file.                
+*
#*                                                                    
+*
#*    PSWD(NewPassword) changes the command access password           
+*
#*                                                                    
+*
#*    PUT(Filespec) copies the specified file in ASCII mode.          
+*
#*                                                                    
+*
#*    PUTB(Filespec) copies the specified file in binary mode.        
+*
#*                                                                    
+*
#*    SKEW() returns the system time skew in seconds between the two  
+*
#*     systems.                                                       
+*
#*                                                                    
+*
#*    SYNC() synchronizes the system time on the remote system if     
+*
#*     it is Windows - date is NOT synchronized.                      
+*
#*                                                                    
+*
#*    SYS() returns the operating system descriptor.                  
+*
#*                                                                    
+*
#*    TIME() returns the system time in non-leap seconds since the    
+*
#*     begining of the epoch (00:00:00, January 1, 1970).             
+*
#*                                                                    
+*
#*  The use of parentheses in the command is optional.                
+*
#<                                                                    
+*
#* Usage: rxd [-d][-p Port][-s][-f] Password                          
+*
#*                                                                    
+*
#*  Use the rx remote client program to issue the command.            
+*
#*                                                                    
+*
#*  Password cannot contain embedded blanks.                          
+*
#*                                                                    
+*
#* Dependencies: UNIX, Windows                                        
+*
#*               Perl interpreter                                     
+*
#>                                                                    
+*
#* Written:  12/22/1997  CA Nichols                                   
+*
#*********************************************************************
+*
use strict;
use warnings;
use threads;
use threads::shared;
use IO::Handle;
use IO::Socket::INET;
use File::Find;
use File::Path;
use Digest::SHA;

######################################################################
+##
######## ARGUMENT CHECKING
######################################################################
+#
if ( $^O eq 'os390' )
{
    require 5.008;
    require Encode;
    import Encode qw( from_to );
    require Encode::EBCDIC;
}

my $debug = 0;
my $port  = 1600;


while ( defined($ARGV[0]) and substr( $ARGV[0],0,1 ) eq "-" ) {
    if ( $ARGV[0] eq "-d" ) { $debug = 1; shift; next; }
    if ( $ARGV[0] eq "-p" ) { $port = $ARGV[1]; shift; shift; next; }
    if ( $ARGV[0] eq "-h" ) { usage(); exit 1; }
    print "Warning: Invalid argument '".$ARGV[0]."' ignored.\n";
    shift;
}

my $password = $ARGV[0] || "hot34tot";
######################################################################
+####
######## Thread-safe printing functions
######################################################################
+#
$|++;

my $semSTDOUT :shared;
sub tprint{
    lock $semSTDOUT;
    my $msg = shift;
    my $tid = shift || threads->tid();
    if($tid ne ""){$tid = "($tid)"};
    print "RXD+ $tid > $msg \n";
}
sub debug{
    if($debug){
        lock $semSTDOUT;
        my $msg = shift;
        my $tid = shift || threads->tid();
        if($tid == 0){ $tid = "MAIN";}
        if($tid ne ""){$tid = "($tid) "};

        print "DEBUG -- " . $tid . $msg . "\n";;
    }
}

sub usage
{
    print "Usage: rxd [-d][-p Port] Password\n";
}

######################################################################
+####


######################################################################
+####
######## SEND\RECEIVE parsing functions
######################################################################
+#
sub receiveCommand{
    my $client = shift;
    debug("Waiting for command input");
    
    my $command = "";
    my $args = "";
    my $buffer = '';
    my $i = 0;
    while( my $num = sysread($client, $buffer, 100000, length($buffer)
+))  { #attempt to receive 100000 bytes at a time
        $i++;
        my $len = length($buffer);
        debug($num . " bytes received, bringing the total to " . $len)
+;

        $command = flagUnwrap("RX", $buffer);
        if( $command ne ""){
            last;
        }
        if($i > 999999999){ #infinite loop stopper
            debug("Terminating infinite loop, closing connection to $c
+lient"); # just in case, but sysread would probably block anyways
            last;
        }
    }
    if(length($buffer) < 300){
        debug("Raw text received = $buffer");
    }else{
        debug("Received " . length($buffer) . " bytes from RX");
    }
    return ($command);
    
}


sub sendResponse{
    my $msg = shift;
    my $rc = shift;
    my $client = shift;
    $msg = flagWrap("RESPONSE", $msg); 
    my $rcMSG = flagWrap("RETURN CODE", $rc);
    
    my $response = flagWrap("RXD", $msg . $rcMSG);
    my $len = length($response);
    if($len < 200){
        debug("Command complete, sending response '$response'");
    }else{
        debug("Command complete, sending $len bytes in response.");
    }
    tprint("Command completed with a return code of $rc", threads->tid
+());
    syswrite($client, $response, length($response)) or debug(">>ERROR<
+< Couldnt write to client");
    debug("sent");
}
######################################################################
+####




######################################################################
+####
######## Worker Thread subroutine
######################################################################
+#
sub processRequest {
    my $client;
    my $tid = threads->tid;
    my $fno = shift;

    # need to add a while loop to retry
    while (1) {
        last if (open $client, "+<&", $fno);
        sleep (1);
    }

    $client->autoflush(1);
    debug("Connected to client machine");
    my $response = "";
    my $returnCode = "";

    my $fullCMD = receiveCommand($client);
    my $pswd = flagUnwrap("PASSWORD", $fullCMD);
    my $command = uc(flagUnwrap("COMMAND", $fullCMD)); #Command ie EXE
+C
    my $args = flagUnwrap("ARGUMENTS", $fullCMD); #arguments for comma
+nd
    tprint("$command $args");
    my $additionalData = flagUnwrap("ADDITIONAL DATA", $fullCMD); #lik
+e a file
    my $shaValue = flagUnwrap("SHA VALUE", $fullCMD);
    my $readMoreSize = flagUnwrap("READ SIZE", $fullCMD); #indicating 
+a long file
    if($pswd eq $password){
        #debug($readMoreSize);
        if($readMoreSize ne ""){ #RX is going to try to send more stuf
+f!
            debug("Now waiting for the client to send $readMoreSize mo
+re bytes");
            my $i = 0;
            while(length($additionalData) < int($readMoreSize) and $i 
+< 9999999){
                $i++;
                my $num = sysread($client, $additionalData, $readMoreS
+ize, length($additionalData));
                my $len = length($additionalData);
                if(defined($num)){
                        debug($num . " bytes received, bringing the to
+tal to " . $len);
                }
            }
        }
        
        my $len = length($additionalData);
        if($len > 0){
            if($len < 200 and $additionalData !~ /\n/ms){
                tprint("Additional data received: $additionalData");
            }else{
                tprint("Received $len bytes of additional data");
            }
        }
        ($response, $returnCode) = executeCommand($command, $args, $ad
+ditionalData, $client, $shaValue);
    }else{
        $response = "Incorrect password specified";
        $returnCode = 1;
    }
     
    #since execprint needs to be able to send while simultaneously exe
+cuting the command
    #cannot store output in a string to send at once
    if ($command ne 'EXECPRINT' and $command ne 'GET' and $command ne 
+'GETB') {
        sendResponse($response, $returnCode, $client);
    }


    sleep 10;
    debug("Closing connection");
    shutdown($client, 2);
    close $client;
    
    # need to have thread return fd
    return ($fno);
}


sub executeCommand{
    my $rxdCMD = uc(shift);
    my $rxdArgs = shift;
    my $rxdData = shift;
    my $client = shift;
    my $shaValue = shift || "";
    my $resp = "";
    my $rc = 0;

    if($rxdCMD ne ""){
        debug("Processing command '$rxdCMD'");
        if ( $rxdCMD eq 'CMD' && $rxdArgs ne '' )    # CMD(Command)
        {
            if ( $^O eq "MSWin32" ) {
                system "start /b cmd.exe /c $rxdArgs";
                $rc = int($?>>8);
            }
            else {
                $rxdArgs =~ s/ \*/ \\\*/g;
                system "$rxdArgs &";
                $rc = int($?>>8);
            }

        }
        elsif ( $rxdCMD eq 'CMDF' && $rxdArgs ne '' )    # CMD(Command
+)
        {
            my ( $file, $argf ) = split ' ', $rxdArgs, 2;
            if ( $^O eq "MSWin32" ) {
                system "start /b cmd.exe /c $argf 2>>&1 > $file";
                $rc = int($?>>8);
            }
            else {
                $rxdArgs =~ s/ \*/ \\\*/g;
                system "$argf 2>&1 > $file &";
                $rc = int($?>>8);
            }
        
        }
        elsif ( $rxdCMD eq 'COPY' && $rxdArgs ne '' )   # COPY(Source 
+Target)
        {
            if ( $^O eq "MSWin32" ) {
                system "copy /y $rxdArgs";
                $rc = int($?>>8);
            }
            else {
                system "cp $rxdArgs";
                $rc = int($?>>8);
            }
        }

        elsif ( $rxdCMD eq 'DEL' && $rxdArgs ne '' )    # DEL(Filespec
+)
        {
            if ( $^O eq "MSWin32" ) {
                $rxdArgs =~ s/\\/\\\\/g;
            }
            my $err = 0;
            $err = unlink glob( $rxdArgs );
            if ( $err) { $resp = "File removed successfully"; }
            else{$resp = "File could not be removed";}
        }

        elsif($rxdCMD eq 'DIR'){
            my $cmd = '';
            if ( $^O eq "MSWin32" ) {
                $cmd = "dir /b /o-d $rxdArgs";
            }
            else {
                $cmd = "ls -t $rxdArgs";
            }
            debug("Executing `$cmd`");
            $resp = `$cmd 2>&1`;
            $rc = int($?>>8);
        }
                       
        elsif($rxdCMD eq 'ENV' && $rxdArgs ne ''){
            $resp = $ENV{$rxdArgs};
            $rc = int($?>>8);
        }
        elsif ( $rxdCMD eq 'EXEC' && $rxdArgs ne '' )   # EXEC(Command
+)
        {
            my $error = 0;
            if ( $^O eq "MSWin32" ) {
                $resp = `$rxdArgs 2>>&1`;
            }else {
                $rxdArgs =~ s/ \*/ \\\*/g;
                $resp = `$rxdArgs 2>&1`;
            }
            $rc = int($?>>8);
        }
        elsif ( $rxdCMD eq 'FG' && $rxdArgs ne '' )   # EXEC(Command)
        {
            if ( $^O eq "MSWin32" ) {
                system($rxdArgs);
            }
            else {
                $rxdArgs =~ s/ \*/ \\\*/g;
                system($rxdArgs);
            }
            $rc = int($?>>8);
        }
        else{
            $resp = "Unrecognized command. Pleas refer to the document
+ation for a list of possible commands.";
            $rc = 1;
        }


    }else{
        $rc = 1;
        $resp = "Command was not passed successfully.";
    }
        
    if($resp eq ''){
        if($rc){
            $resp = "Command was not completed successfully.";
        }else{
            $resp = "Command was completed successfully.";
        }
    }
    debug("Command execution completed!");
    return ($resp, $rc);
}

sub calculateSHA{
    my $file = shift;
    my $val = 0;
    open(my $fh, $file) or return "";
    eval{
        my $sha1 = Digest::SHA->new(256);
        $sha1->addfile($fh);
        $val = $sha1->hexdigest;
    };
    if($@){
        debug("An error occurred calculating the SHA-Value. Cannot ver
+ify integrity of file\n$@");
    }
    close($fh);
    return $val;
}

sub getDirs{
    my $args = shift;
    
    my $dir1 = "";
    my $dir2 = "";

    $dir2 = $2 if ($args =~ /"(.+)"\s+"(.+)"/i);
    if($dir2 eq ""){
        $dir1 = $args;
        # $dir2 = $dir1;
    }else{
        $dir1 = $1 if ($args =~ /"(.+)"\s+"(.+)"/i);
    }
    
    debug("Source file is: " . $dir1); 
    debug("Destination file is: " . $dir2); 
    
    
    return ($dir1, $dir2);
}


sub flagWrap {
    my $flag = shift;
    my $string = shift;
    my $flagPattern = '***';
    return $flagPattern . $flag . " BEGIN" . $flagPattern . $string . 
+$flagPattern . $flag . " END" . $flagPattern;
}

sub flagUnwrap{
    my $flag = shift;
    my $string = shift;
    my $flagPattern = '\*\*\*';
    my $regexH = $flagPattern . $flag . " BEGIN" . $flagPattern;
    my $regexT = $flagPattern . $flag . " END" . $flagPattern;
    if($string =~ /$regexH(.+)$regexT/ims){
        return $1;
    }else{
        return "";
    }
}


sub deltree{
    my $dir = shift;
    my $keep = shift;
    my $keepRoot = 0;
    debug("Removing directory '$dir'");
    if($keep eq "KEEP ROOT"){
        debug("Keeping the root directory");
        $keepRoot = 1;
    }

    unless(-d $dir){
        debug("Directory '$dir' does not exist to remove.");
        return 0;
    }

    my $command = '';
    if ( $^O eq "MSWin32" ) {
        if($dir !~ /^[A-Za-z]:(\\|\/).+/){# just checking for <drive><
+:><\ or />
            debug("Directory does not match standard windows folder fo
+rmat. Make sure the full path is specified.");
            return 0;
        }
        $command = "rmdir /s /q \"$dir\"";
        $command .= " && mkdir $dir" if($keepRoot);
    }
    else {
        if($dir !~ /^\//){# just checking it begins with a '/' to ensu
+re it is the full path. 
            debug("Directory does not match standard windows folder fo
+rmat. Make sure the full path is specified.");
            return 0;
        }
        $command = "rm -rf \"$dir\"";
        $command .= "/*" if($keepRoot);
        $command =~ s/\/\//\//g; #replace double slashes with a single
+ in case appending the "/*" created a double
    }
    debug("Executing command '$command'");
    system($command);
    my $rc = int($?>>8);
    debug("Command completed with return code '$rc', returning '" . !$
+rc . "'");
    return !$rc;
}
######################################################################
+####





######################################################################
+#######
######## MAIN THREAD    
my $lsn = new IO::Socket::INET(
    Listen => SOMAXCONN,
    LocalPort => $port,
    ReuseAddr => 1,
    Blocking => 1,
    
    ) or die "Failed to open listening port: $!\n";

print "RXD+ had been started on port $port\n";
debug("Password is '$password'");

#making the CWD the directory RXD is located in
use FindBin qw($Bin);
my $currentDir = $Bin;
if ($^O =~ /win/i) {
    $currentDir =~ tr/\//\\/;
} elsif (($^O !~ /win/i) && ($currentDir !~ /\//)) {
    $currentDir .= "/";
}

chdir($currentDir);

# create a cache hash
my %FDcache;

while(1) {
    my $client;
    my $fd;
        
    unless ($client = $lsn->accept) {
        tprint ("Could not connect to socket: " . $!);
        next;
    }
        
    # change filehandle to file descriptor
    $fd = fileno $client;
    unless(defined($fd)){close($client);next;}
    
    # add filehandle to cache hash
    # tprint("Caching file descriptor- $fd");
    $FDcache{$fd} = $client;
    
    #if(!defined($client)){tprint("Could not connect to client"); next
+;}
    debug("Creating a new thread");
    my $thd = threads->create('processRequest', $fd);
    unless(defined($thd)){close($client); next;}
    #$thd ->detach();
    debug("New thread created TID: " . $thd->tid());
    
    # wait to join and delete from hash
    foreach my $join (threads->list(threads::joinable)) {
        my $val = $join->join();
        # tprint("Deleting fd- $val");
        delete $FDcache{$val};
    }
    
}

sub shutdownRXD{
    tprint("Sutting down");
    exit 0; 
}
######################################################################
+#######


END{
    print "The RXD server has been shutdown.";
}

Any help you can give is much appreciated.

[BrowserUk]

Try replacing the join line(s) with:

my $val = eval{ $join->join() } or die "Join failed with '$!' : '$^E'"
+;

And then report back the error texts.

.

[rmahin]

Nevermind. Stressed it a bit more than normal, and got this message:

Join failed with 'Bad file descriptor' : 'The handle is invalid' at rx
+d.pl line
1128.
The RXD server has been shutdown.Perl exited with active threads:
        1 running and unjoined
        79 finished and unjoined
        0 running and detached

[BrowserUk]

'The handle is invalid' at rxd.pl line

The handle in question would have to be the thread handle itself; which suggests that it has some how become invalid between beong returned from threads->list(threads::joinable) and your calling join(). Which -- provided there are no other detach() than the one shown commented out -- should not be possible!

As a discovery measure, you could try calling the handle method pprint $join->_handle(); prior to doing the join and see what that yields?

The only other diagnostic measures I can think of, would entail adding some trace into the threads.xs module. If you're up for that, you could try adding:

printf( "thread handle:%x thread-id: %dx\n", thread->handle, GetThread
+Id( thread->handle ) );

just before the if(WaitForSingleObject()) call. It might add some info.

You should also add a call to GetLastError() and print out that and teh failing return code within the body of the if, prior to the PANIC.

[rmahin]

Will do. It's hard to recreate though so no guarantee when I'll be able to get this back to you. The same script has been running on 5 different machines (2 windows, 3 unix) for the past week and only one has had this error.

[BrowserUk]

It's hard to recreate though so no guarantee when I'll be able to get this back to you.

Understood. If it never happens again, nothing much to do; but if it does, it should yield a little more information that might help identify the cause.