view release on metacpan or  search on metacpan

lib/Apache2/ScoreboardDumper.pm  view on Meta::CPAN

package Apache2::ScoreboardDumper;

use strict;
use warnings;

our $VERSION = 0.01;

use Apache::Scoreboard;
use Apache2::RequestRec;
use Apache2::Log;
use Apache2::Const -compile => qw( DECLINED );

our %Key = (
    '_' => 'Waiting for Connection',
    'S' => 'Starting up',
    'R' => 'Reading Request',
    'W' => 'Sending Reply',
    'K' => 'Keepalive (read)',
    'D' => 'DNS Lookup',
    'C' => 'Closing connection',
    'L' => 'Logging',
    'G' => 'Gracefully finishing',
    'I' => 'Idle cleanup of worker',
    '.' => 'Open slot with no current process'
);

sub handler {
    my ( $class, $r ) = @_;

    # see if all the server slots are full
    my $image        = Apache::Scoreboard->image( $r->pool );
    my $servers_left = $image->server_limit - scalar( @{ $image->pids } );
    if ( $servers_left == 0 ) {

        my $dump_method = $r->dir_config( 'ScoreboardDumpMethod' ) || die 'ScoreboardDumpMethod not set';
        if ( $dump_method eq 'LockFreq' ) {

            # we are using locking
            my $lock_class = $r->dir_config( 'ScoreboardDumpLock' ) || die 'ScoreboardDumpLock not set';
            my $score_freq = $r->dir_config( 'ScoreboardDumpFreq' ) || die 'ScoreboardDumpLock not set';

            no strict 'refs';
            $lock_class->lock();
            my ( $count, $fulltime ) = $lock_class->getvars();
            my $now = time();
            if ( $now - $fulltime > $score_freq ) {
                $r->log->debug( "All Servers used enabling instrumentation at $now" );
                $fulltime = $now;
            }
            $lock_class->setvars( $count, $fulltime );
            $lock_class->unlock();

            # dump the scoreboard to the log
            $class->dump_scoreboard( $r, $image ) if $now == $fulltime;

        } elsif ( $dump_method eq 'Stochastic' ) {

            my $stoc_freq = $r->dir_config( 'ScoreboardDumpStochastic' ) || die 'ScoreboardDumpStochastic not set';
            if ( sprintf( '%.1f', rand( 1 ) ) <= $stoc_freq ) {

                # dump the scoreboard if less than specified value
                $class->dump_scoreboard( $r, $image );
            }

        } elsif ( $dump_method eq 'All' ) {
            $class->dump_scoreboard( $r, $image );
        }
    }

    return Apache2::Const::DECLINED;
}


sub dump_scoreboard {
    my ( $class, $r, $image ) = @_;

    my %worker_stats = map { $_ => 0 } keys %Key;
    my @worker_scores;