view release on metacpan or  search on metacpan

lib/DashProfiler/Core.pm  view on Meta::CPAN

package DashProfiler::Core;

=head1 NAME

DashProfiler::Core - DashProfiler core object and sampler factory

=head1 SYNOPSIS

See L<DashProfiler::UserGuide> for a general introduction.

DashProfiler::Core is currently viewed as an internal class. The interface may change.
The DashProfiler and DashProfiler::Import modules are the usual interfaces.

=head1 DESCRIPTION

A DashProfiler::Core objects are the core of the DashProfiler, naturally.
They sit between the 'samplers' that feed data into a core, and the DBI::Profile
objects that aggregate those samples. A core may have multiple samplers and
multiple profiles.

=cut

use strict;

our $VERSION = sprintf("1.%06d", q$Revision: 48 $ =~ /(\d+)/o);

use DBI 1.57 qw(dbi_time dbi_profile_merge);
use DBI::Profile;
use DBI::ProfileDumper;
use Carp;

our $ENDING = 0;

BEGIN {
    # use env var to control debugging at compile-time
    my $debug = $ENV{DASHPROFILER_CORE_DEBUG} || $ENV{DASHPROFILER_DEBUG} || 0;
    eval "sub DEBUG () { $debug }; 1;" or die; ## no critic
}
END {
    $ENDING = 1;
}


BEGIN {
    # load Hash::Util for lock_keys()
    # if Hash::Util isn't available then install a stub for lock_keys()
    eval {
        require Hash::Util;
        Hash::Util->import('lock_keys');
    };
    die @$ if $@ && $@ !~ /^Can't locate Hash\/Util/;
    *lock_keys = sub { } if not defined &lock_keys;
}


# check for weaken support, used by ChildHandles
my $HAS_WEAKEN = eval {
    require Scalar::Util;
    # this will croak() if this Scalar::Util doesn't have a working weaken().
    Scalar::Util::weaken( my $test = [] );
    1;
};
*weaken = sub { croak "Can't weaken without Scalar::Util::weaken" }
    unless $HAS_WEAKEN;


# On 2GHz OS X 10.5.2 laptop:
#   sample_overhead_time = 0.000014s
#   sample_inner_time    = 0.000003s
my ($sample_overhead_time, $sample_inner_time) = estimate_sample_overheads();


=head1 CLASS METHODS

=head2 new

  $obj = DashProfiler::Core->new( 'foo' );

  $obj = DashProfiler::Core->new( 'bar', { ...options... } );

  $obj = DashProfiler::Core->new( extsys => {
      granularity => 10,
      flush_interval => 300,
  } );

Creates and returns a DashProfiler::Core object.

=head2 Options for new()

=head3 disabled

Set to a true value to prevent samples being added to this core. If true, the
prepare() method and the L<DashProfiler::Sample> new() method will return undef.

Default false.

Currently, any existing samples that were active will still be added when they
terminate. This behaviour may change.

See also L<DashProfiler::Import>.

=head3 dbi_profile_class

Specifies the class to use for creating DBI::Profile objects.
The default is C<DBI::Profile>. Alternatives include C<DBI::ProfileDumper>
and C<DBI::ProfileDumper::Apache>.

=head3 dbi_profile_args

Specifies extra arguments to pass the new() method of the C<dbi_profile_class>
(e.g., C<DBI::Profile>). The default is C<{ }>.

=head3 flush_interval

How frequently the DBI:Profiles associated with this core should be written out
and the data reset. Default is 0 - no regular flushing.

=head3 flush_hook

If set, this code reference is called when flush() is called and can influence
its behaviour. For example, this is the flush_hook used by L<DashProfiler::Auto>:

    flush_hook => sub {

lib/DashProfiler/Core.pm  view on Meta::CPAN

        my $t1 = dbi_time();         # time before sampling
        my $ps1 = $sampler->("c2");  # begin sample
        undef $ps1;                  # end sample
        $sum += (dbi_time() - $t1)   # time to perform full sample lifecycle
              - ($t1 - $t0);         # subtract cost of calling dbi_time()
    }
    # overhead is average of time spent calling sampler & DESTROY:
    $sample_overhead_time = $sum / $count; # ~0.000014s on 2GHz OS X 10.5.2 laptop
    $sample_inner_time    = ($profile->get_dbi_profile->{Data}{c1}{c2}[1] / $count);

    # we could also subtract the time accumulated by the samples, like this:
    #   $sample_overhead_time -= $sample_inner_time
    # but we don't because that's also a valid part of the overhead
    # because there are no statements between the sample creation and destruction.

    warn sprintf "sample_overhead_time=%.7fs (sample_inner_time=%.7fs)\n",
        $sample_overhead_time, $sample_inner_time if DEBUG();

    $profile->reset_profile_data;

    return  $sample_overhead_time unless wantarray;
    return ($sample_overhead_time, $sample_inner_time);
}



=head1 OBJECT METHODS

=head2 attach_dbi_profile

  $core->attach_dbi_profile( $dbi_profile, $name );

Attaches a DBI Profile to a DashProfiler::Core object using the $name given.
Any later samples are also aggregated into this DBI Profile.

Not normally called directly. The new() method calls attach_dbi_profile() to
attach the "main" profile and the C<period_summary> profile, if enabled.

The $dbi_profile argument can be either a DBI::Profile object or a string
containing a DBI::Profile specification.

The get_dbi_profile($name) method can be used to retrieve the profile.

=cut

sub attach_dbi_profile {
    my ($self, $dbi_profile, $dbi_profile_name, $weakly) = @_;
    # wrap DBI::Profile object/spec with a DBI handle
    croak "No dbi_profile_name specified" unless defined $dbi_profile_name;
    local $ENV{DBI_AUTOPROXY};
    my $dbh = DBI->connect("dbi:DashProfiler:", "", "", {
        Profile => $dbi_profile,
        RaiseError => 1, PrintError => 1, TraceLevel => 0,
    });
    $dbh = tied %$dbh; # switch to inner handle
    $dbh->{Profile}->empty; # discard FETCH&STOREs etc due to connect()
    for my $handles ($self->{dbi_handles_all}, $self->{dbi_handles_active}) {
        # clean out any dead weakrefs
        defined $handles->{$_} or delete $handles->{$_} for keys %$handles;
        $handles->{$dbi_profile_name} = $dbh;
#       weaken($handles->{$dbi_profile_name}) if $weakly;   # not currently documented or used
    }
    return $dbh;
}


sub _attach_new_temporary_plain_profile {   # not currently documented or used
    my ($self, $dbi_profile_name) = @_;
    # create new DBI profile (with no time key) that doesn't flush anywhere
    my $dbi_profile = $self->_mk_dbi_profile("DashProfiler::DumpNowhere", 0);
    # attach to the profile, but only weakly
    $self->attach_dbi_profile( $dbi_profile, $dbi_profile_name, 1 );
    # return ref so caller can store till ready to discard
    return $dbi_profile;
}


sub _mk_dbi_profile {
    my ($self, $class, $granularity) = @_;

    _load_class($class);
    my $Path = $granularity ? [ "!Time~$granularity", "!Statement", "!MethodName" ]
                            : [                       "!Statement", "!MethodName" ];
    my $dbi_profile = $class->new(
        Path  => $Path,
        Quiet => 1,
        Trace => 0,
        File  => "dashprofile.$self->{profile_name}",
        %{ $self->{dbi_profile_args} },
    );

    return $dbi_profile;
};


=head2 get_dbi_profile

  $dbi_profile  = $core->get_dbi_profile( $dbi_profile_name );
  @dbi_profiles = $core->get_dbi_profile( '*' );

Returns a reference to the DBI Profile object that attached to the $core with the given name.
If $dbi_profile_name is undef then it defaults to "main".
Returns undef if there's no profile with that name atached.
If $dbi_profile_name is 'C<*>' then it returns all attached profiles.
See L</attach_dbi_profile>.

=cut

sub get_dbi_profile {
    my ($self, $name) = @_;
    my $dbi_handles = $self->{dbi_handles_all}
        or return;
    # we take care to avoid auto-viv here
    my $dbh = $dbi_handles->{ $name || 'main' };
    return $dbh->{Profile} if $dbh;
    return unless $name && $name eq '*';
    croak "get_dbi_profile('*') called in scalar context" unless wantarray;
    return map {
        ($_->{Profile}) ? ($_->{Profile}) : ()
    } values %$dbi_handles;
}