# hires timestamp pid tid script lineno package subroutine args
1144302961.37707 3168( 38) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.29688 3216( 41) threadtest.pl( 29) (eval): n/a
1144302961.29714 3216( 41) threadtest.pl( 29) (eval): n/a
1144302961.29730 3216( 41) threadtest.pl( 29) (eval): n/a
1144302961.29743 3216( 41) threadtest.pl( 29) (eval): n/a
1144302961.29756 3216( 41) threadtest.pl( 29) (eval): n/a
1144302961.29769 3216( 41) threadtest.pl( 16) Win32::Console::WriteChar: n/a
1144302961.29782 3216( 41) threadtest.pl( 16) Win32::Console::WriteChar: n/a
1144302961.29795 3216( 41) threadtest.pl( 16) Win32::Console::WriteChar: n/a
1144302961.29818 3216( 41) threadtest.pl( 29) (eval): n/a
1144302961.35938 3216( 0) ( ) : n/a
1144302961.35980 3216( 0) ( ) : n/a
1144302961.40625 3216( 42) threadtest.pl( 29) (eval): n/a
1144302961.40652 3216( 42) threadtest.pl( 29) (eval): n/a
1144302961.40668 3216( 42) threadtest.pl( 29) (eval): n/a
1144302961.40681 3216( 42) threadtest.pl( 29) (eval): n/a
1144302961.40694 3216( 42) threadtest.pl( 29) (eval): n/a
1144302961.40706 3216( 42) threadtest.pl( 16) Win32::Console::WriteChar: n/a
1144302961.40719 3216( 42) threadtest.pl( 16) Win32::Console::WriteChar: n/a
1144302961.40732 3216( 42) threadtest.pl( 16) Win32::Console::WriteChar: n/a
1144302961.40754 3216( 42) threadtest.pl( 29) (eval): n/a
1144302961.49839 3168( 38) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.49881 3168( 38) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.49897 3168( 38) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50139 3168( 28) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50156 3168( 28) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50169 3168( 28) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50000 3168( 31) threadtest.pl( 29) (eval): n/a
1144302961.50016 3168( 31) threadtest.pl( 29) (eval): n/a
1144302961.50028 3168( 31) threadtest.pl( 29) (eval): n/a
1144302961.50041 3168( 31) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50054 3168( 31) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50066 3168( 31) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50000 3168( 7) threadtest.pl( 29) (eval): n/a
1144302961.50016 3168( 7) threadtest.pl( 29) (eval): n/a
1144302961.50028 3168( 7) threadtest.pl( 29) (eval): n/a
1144302961.50041 3168( 7) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50054 3168( 7) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50066 3168( 7) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50000 3168( 15) threadtest.pl( 29) (eval): n/a
1144302961.50016 3168( 15) threadtest.pl( 29) (eval): n/a
1144302961.50028 3168( 15) threadtest.pl( 29) (eval): n/a
1144302961.50041 3168( 15) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50053 3168( 15) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.50065 3168( 15) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.48975 3168( 6) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.48991 3168( 6) threadtest.pl( 19) Win32::Console::WriteChar: n/a
1144302961.49124 3168( 14) threadtest.pl( 19) Win32::Console::WriteChar: n/a
####
tperl -d:Ttrace threadtest.pl
####
package Devel::Ttrace;
use strict;
use warnings;
use Time::HiRes qw[ time ];
require IO::Socket::INET;
require threads;
my $socket = IO::Socket::INET->new( 'localhost:54321' );
sub DB::DB {
no warnings 'uninitialized';
my @caller = caller(1);
printf $socket "%15.5f %5d(%3d) %s(%5s) %s: %s\n",
time(),
$$,
threads->tid,
@caller[ 1, 2, 3 ],
'n/a'
;
}
1;
####
#!perl -slw
use strict;
use threads;
use Thread::Queue;
use Smart::Comments::Lite '0';
sub worker {
require IO::Socket::INET;
my $tid = threads->tid;
our $running:shared;
our $busy:shared;
our $die:shared;
my( $Qwork, $Qtrace ) = @_;
++$running;
while( my $fno = $Qwork->dequeue() ) {
##1 warn "$tid($fno): Client waiting on $fno\n";
my $client = IO::Socket::INET->new;
$client->fdopen( $fno, '+>' )
or die "$tid: Failed to reopen fileno: $fno";
##2 warn "$tid($fno): reopened $client\n";
++$busy;
##2 warn "$tid($fno): Reading from client\n";
while( my $data = <$client> ) {
chomp $data;
##2 warn "$tid($fno): Got '$data'\n";
$Qtrace->enqueue( $data );
}
##2 warn "$tid($fno): Client disconnected\n";
close $client;
shutdown( $client, 2 );
--$busy;
}
--$running;
}
our $START ||= 2;
our $MAX ||= 2000;
our $running:shared = 0;
our $busy:shared = 0;
our $die:shared = 0;
our $connects:shared=0;
## Use ctrl-break to terminate the server.
local $SIG{INT} = sub{
warn "SIGINT(2) terminating";
$die = 1;
};
my $Qwork = new Thread::Queue;
my $Qtrace = new Thread::Queue;
our %clients;
my @threads = map{
threads->create( \&worker, $Qwork, $Qtrace )
or warn( "Create thread $_ failed with $^E\n" ), ();
} 1 .. $START;
## This creates new threads if the current pool is running low
async{
until( $die ) {
if( ( $busy + 2 ) == $running and $running < $MAX ) {
push @threads, threads->create( \&worker, $Qwork, $Qtrace )
or warn( "Create thread $_ failed with $^E\n" ), ();
}
sleep 1;
}
};
## This reads and dumps the trace information to the screen.
async{
until( $die ) {
print $Qtrace->dequeue();
}
}
require IO::Socket::INET;
my $server = IO::Socket::INET->new(
LocalPort => 54321,
Listen => 1000,
Reuse => 1.
) or die $!, $^E;
## Currently, the client sockets are not cleaned up and will eventually run out of resource.
## Fixes welcome :)
my $fno;
while( not $die and ( my $client = $server->accept ) > 0 ) {
++$connects;
$clients{ $client->fileno } = $client;
$Qwork->enqueue( $client->fileno );
}
warn "\a*** Accept failed ***\a\n" and $die = 1;
close $server;
$Qwork->enqueue( undef ) for 1 .. $running;
sleep 1 while $running;
$_->join for @threads;