[svn:dbi] r13959 - in dbi/trunk: . lib/DBI lib/DBI/ProfileDumper

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);
 }