view release on metacpan or  search on metacpan

lib/Apache/SmallProf.pm  view on Meta::CPAN

package Apache::SmallProf;

use strict;
use vars qw($VERSION @ISA);
use Apache::DB 0.16;
@ISA = qw(DB);

$VERSION = '0.16';

$Apache::Registry::MarkLine = 0;

BEGIN { 
	use constant MP2 => eval { 
        exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2
    };
	die "mod_perl is required to run this module: $@" if $@; 

	if (MP2) { 
		require APR::Pool;
		require Apache2::RequestUtil;
		require Apache2::RequestRec;
		require Apache2::ServerUtil;
	}
}

sub handler {
    my $r = shift;
    my $dir;
    
    if (MP2) { 
        $dir = Apache2::ServerUtil::server_root(); 
    }
    else { 
        $dir = $r->server_root_relative; 
    }

    my $sdir = $r->dir_config('SmallProfDir') || 'logs/smallprof';
	$dir = "$dir/$sdir"; 

    # Untaint $dir 
    $dir =~ m/^(.*?)$/; $dir = $1; 

    mkdir $dir, 0755 unless -d $dir;

    # Die if we can't make the directory 
	die "$dir does not exist: $!" if !-d $dir; 

    (my $uri = $r->uri) =~ s,/,::,g;
    $uri =~ s/^:+//;

    my $db = Apache::SmallProf->new(file => "$dir/$uri", dir => $dir);
    $db->begin;

	if (MP2) { 
		$r->pool->cleanup_register(sub { 
		local $DB::profile = 0;
		$db->end;
		0;
		});
	}
	else { 
		$r->register_cleanup(sub { 
		local $DB::profile = 0;
		$db->end;
		0;
		});
	}
    0;
}

package DB;

sub new {
    my $class = shift;
    my $self = bless {@_}, $class;

    Apache::DB->init;

    $self;
}

use strict;
use Time::HiRes qw(time);
$DB::profile = 0; #skip startup profiles

sub begin {
    $DB::trace = 1;

    $DB::drop_zeros = 0;
    $DB::profile = 1;
    if (-e '.smallprof') {
	do '.smallprof';
    }
    $DB::prevf = '';
    $DB::prevl = 0;
    my($diff,$cdiff);
    my($testDB) = sub {
	my($pkg,$filename,$line) = caller;
	$DB::profile || return;
	%DB::packages && !$DB::packages{$pkg} && return;