Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

PANIC: underlying join failed threded tcp server

by rmahin (Beadle)
on Oct 17, 2012 at 21:10 UTC ( #999609=perlquestion: print w/ replies, xml ) Need Help??
rmahin has asked for the wisdom of the Perl Monks concerning the following question:

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.

Comment on PANIC: underlying join failed threded tcp server
Select or Download Code
Re: PANIC: underlying join failed threded tcp server
by BrowserUk (Pope) on Oct 17, 2012 at 21:22 UTC

    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.


    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    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.

    RIP Neil Armstrong

    .
      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.
        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.


        With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
        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.

        RIP Neil Armstrong

      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
        '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.


        With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
        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.

        RIP Neil Armstrong

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (13)
As of 2014-09-18 19:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

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











    Results (122 votes), past polls