Author: timbo
Date: Fri May 7 05:28:40 2010
New Revision: 13959
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
Log:
Clear profile data at end of on_destroy method.
Tweaks to DBI/ProfileDumper/Apache.pm
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri May 7 05:28:40 2010
@@ -13,6 +13,8 @@
Changed DBI::ProfileDumper to rename any existing profile file by
appending .prev, instead of overwriting it.
+ Changed DBI::ProfileDumper::Apache to work in more configurations
+ including vhosts using PerlOptions +Parent.
=head2 Changes in DBI 1.611 (svn r13935) 29th April 2010
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Fri May 7 05:28:40 2010
@@ -704,7 +704,7 @@
sub new {
my $class = shift;
- my $profile = { @_ };
+ my $profile = { Trace => 0, @_ };
return bless $profile => $class;
}
@@ -721,7 +721,7 @@
$arg =~ s/^DBI::/2\/DBI::/
and carp "Automatically changed old-style DBI::Profile specification
to $arg";
- # it's a path/module/arg/arg/arg list
+ # it's a path/module/k1:v1:k2:v2:... list
my ($path, $package, $args) = split /\//, $arg, 3;
my @args = (defined $args) ? split(/:/, $args, -1) : ();
my @Path;
@@ -926,11 +926,13 @@
return unless $self->{Data};
my $detail = $self->format();
$ON_DESTROY_DUMP->($detail) if $detail;
+ $self->{Data} = undef;
}
sub DESTROY {
my $self = shift;
local $@;
+ DBI->trace_msg("profile data DESTROY\n",0) if $self->{Trace} >= 2;
eval { $self->on_destroy };
if ($@) {
chomp $@;
Modified: dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper/Apache.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper/Apache.pm Fri May 7 05:28:40 2010
@@ -166,53 +166,42 @@
use DBI::ProfileDumper;
use File::Spec;
-my $parent_pid = $$; # init to pid because we are currently the parent of the
children-to-be
+my $initial_pid = $$;
use constant MP2 => ($ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION}
== 2) ? 1 : 0;
-my $apache_server;
my $server_root_dir;
if (MP2) {
- require Apache2::Const;
- Apache2::Const->import(-compile => qw(OK DECLINED));
require Apache2::ServerUtil;
- $apache_server = Apache2::ServerUtil->server;
$server_root_dir = Apache2::ServerUtil::server_root();
}
else {
require Apache;
- require Apache::Constants;
- Apache::Constants->import(qw(OK DECLINED));
- $apache_server = "Apache";
$server_root_dir = eval { Apache->server_root_relative('') } || "/tmp";
}
-if (UNIVERSAL::can($apache_server, "push_handlers")) {
- $apache_server->push_handlers(PerlChildInitHandler => sub {
- $parent_pid = getppid();
- #warn "PerlChildInitHandler pid$$ has ppid $parent_pid";
- OK();
- });
-}
-
-sub dirname {
+sub _dirname {
my $self = shift;
- return $self->{Dir} if $self->{Dir};
- $self->{Dir} ||= $ENV{DBI_PROFILE_APACHE_LOG_DIR};
- return $self->{Dir} || File::Spec->catdir($server_root_dir, "logs");
+ return $self->{Dir} ||= $ENV{DBI_PROFILE_APACHE_LOG_DIR}
+ || File::Spec->catdir($server_root_dir, "logs");
}
+
sub filename {
my $self = shift;
my $filename = $self->SUPER::filename(@_);
+ return $filename if not $filename; # not set yet
+
# to be able to identify groups of profile files from the same set of
# apache processes, we include the parent pid in the file name
# as well as the pid.
- $filename .= ".$parent_pid.$$";
+ my $group_pid = ($$ eq $initial_pid) ? $$ : getppid();
+ $filename .= ".$group_pid.$$";
+
return $filename if File::Spec->file_name_is_absolute($filename);
- return File::Spec->catfile($self->dirname, $filename);
+ return File::Spec->catfile($self->_dirname, $filename);
}
