Author: timbo
Date: Thu May 24 07:26:57 2007
New Revision: 9605
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Profile.pm
dbi/trunk/lib/DBI/ProfileData.pm
dbi/trunk/lib/DBI/ProfileDumper.pm
dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
Log:
Assorted minor changes and polish.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Thu May 24 07:26:57 2007
@@ -44,6 +44,7 @@
Added support for !Time and !Time~N to DBI::Profile Path.
DBI::ProfileDumper changes:
+ Don't write file if there's no profile data.
Use full natural precision (was using %.6f).
Optimized flush_to_disk().
Lock the data file while writing.
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Thu May 24 07:26:57 2007
@@ -273,7 +273,7 @@
my $response = eval {
if (my $check_request_sub = $self->check_request_sub) {
- $request = $check_request_sub->($request)
+ $request = $check_request_sub->($request, $self)
or die "check_request_sub failed";
}
@@ -667,6 +667,7 @@
=head2 check_request_sub
If defined, it must be a reference to a subroutine that will 'check' the
request.
+It is pass the request object and the executor as its only arguments.
The subroutine can either return the original request object or die with a
suitable error message (which will be turned into a Gofer response).
Modified: dbi/trunk/lib/DBI/Profile.pm
==============================================================================
--- dbi/trunk/lib/DBI/Profile.pm (original)
+++ dbi/trunk/lib/DBI/Profile.pm Thu May 24 07:26:57 2007
@@ -770,6 +770,7 @@
local $@;
eval { $self->on_destroy };
if ($@) {
+ chomp $@;
my $class = ref($self) || $self;
DBI->trace_msg("$class on_destroy failed: $@", 0);
}
Modified: dbi/trunk/lib/DBI/ProfileData.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileData.pm (original)
+++ dbi/trunk/lib/DBI/ProfileData.pm Thu May 24 07:26:57 2007
@@ -144,6 +144,7 @@
_header => {},
_nodes => [],
_node_lookup => {},
+ _sort => 'none',
@_
};
bless $self, $pkg;
@@ -192,6 +193,8 @@
last unless length $_;
/^(\S+)\s*=\s*(.*)/
or croak("Syntax error in header in $filename line $.: $_");
+ # XXX should compare new with existing (from previous file)
+ # and warn if they differ (diferent program or path)
$self->{_header}{$1} = $2 if $keep;
}
}
Modified: dbi/trunk/lib/DBI/ProfileDumper.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper.pm Thu May 24 07:26:57 2007
@@ -91,13 +91,16 @@
$profile->flush_to_disk()
-Flushes all collected profile data to disk and empties the Data hash.
-This method may be called multiple times during a program run.
+Flushes all collected profile data to disk and empties the Data hash. Returns
+the filename writen to. If there's no actual profile data then the file is not
+written and flush_to_disk() returns undef.
The file is locked while it's being written. A process 'consuming' the files
while they're being written to, should lock the file before reading and then
truncate() it before releasing the lock.
+This method may be called multiple times during a program run.
+
=head2 empty
$profile->empty()
@@ -208,18 +211,25 @@
# flush available data to disk
sub flush_to_disk {
my $self = shift;
+ my $class = ref $self;
my $filename = $self->filename;
+ my $data = $self->{Data};
+
+ if (1) { # make an option
+ return undef if not $data;
+ return undef if ref $data eq 'HASH' && !%$data;
+ }
my $fh = gensym;
if (($self->{_wrote_header}||'') eq $filename) {
# append more data to the file
# XXX assumes that Path hasn't changed
open($fh, ">>$filename")
- or croak("Unable to open '$filename' for profile output: $!");
+ or croak("Unable to open '$filename' for $class output: $!");
} else {
# create new file (overwrite existing)
open($fh, ">$filename")
- or croak("Unable to open '$filename' for profile output: $!");
+ or croak("Unable to open '$filename' for $class output: $!");
}
# lock the file (before checking size and writing the header)
flock($fh, LOCK_EX);
@@ -236,6 +246,8 @@
or croak("Error closing '$filename': $!");
$self->empty();
+
+ return $filename;
}
Modified: dbi/trunk/lib/DBI/ProfileDumper/Apache.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileDumper/Apache.pm (original)
+++ dbi/trunk/lib/DBI/ProfileDumper/Apache.pm Thu May 24 07:26:57 2007
@@ -156,8 +156,40 @@
use DBI::ProfileDumper;
use File::Spec;
+my $parent_pid = $$; # init to pid because we are currently the parent of the
children-to-be
+
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";
+}
+
+my $dest_dir = $ENV{DBI_PROFILE_APACHE_LOG_DIR} ||
File::Spec->catdir($server_root_dir, "logs");
+
+
+if (UNIVERSAL::can($apache_server, "push_handlers")) {
+ $apache_server->push_handlers(PerlChildInitHandler => sub {
+ $parent_pid = getppid();
+ warn "PerlChildInitHandler pid$$ has ppid $parent_pid";
+ # update dest_dir from DBI_PROFILE_APACHE_LOG_DIR now
+ $dest_dir = $ENV{DBI_PROFILE_APACHE_LOG_DIR} if
$ENV{DBI_PROFILE_APACHE_LOG_DIR};
+ OK();
+ });
+}
sub filename {
my $self = shift;
@@ -165,50 +197,21 @@
# 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.
- my $parent_pid = getppid();
- my $path = $self->fileabspath();
- return File::Spec->catfile($path, "$filename.$parent_pid.$$");
-}
-
-
-sub fileabspath {
- my ($self) = @_;
-
- # setup File per process
- my $path;
- if ($ENV{DBI_PROFILE_APACHE_LOG_DIR}) {
- $path = $ENV{DBI_PROFILE_APACHE_LOG_DIR};
- }
- else {
- eval {
- # can't cache, at least not during startup
- my $subdir = "logs";
- if (MP2) {
- require Apache2::RequestUtil;
- require Apache2::ServerUtil;
- $path =
Apache2::ServerUtil::server_root_relative(Apache2::RequestUtil->request()->pool,
$subdir)
- }
- else {
- require Apache;
- $path = Apache->server_root_relative($subdir);
- }
- };
- if ($@) { # probably due to not running inside Apache
- $path = "/tmp";
- warn "Can't determine path for $self (will use $path): $@";
- }
- }
- return $path;
+ $filename .= ".$parent_pid.$$";
+ return $filename if File::Spec->file_name_is_absolute($filename);
+ return File::Spec->catfile($dest_dir, $filename);
}
sub flush_to_disk {
my $self = shift;
- printf STDERR ref($self)." writing to %s\n", $self->filename()
- unless $self->{Quiet};
+ my $filename = $self->SUPER::flush_to_disk(@_);
+
+ print STDERR ref($self)." pid$$ written to $filename\n"
+ if $filename && not $self->{Quiet};
- return $self->SUPER::flush_to_disk(@_);
+ return $filename;
}
1;
