DashProfiler::Core - DashProfiler core object and sampler factory

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

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

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

    flush_hook => sub {
        my ($self, $dbi_profile_name) = @_;
        warn $_ for $self->profile_as_text($dbi_profile_name);
        return $self->reset_profile_data($dbi_profile_name);
    },

  $sample_overhead_time = DashProfiler::Core->estimate_sample_overheads();

  ($sample_overhead_time, $sample_inner_time)
      = DashProfiler::Core->estimate_sample_overheads();

    previous statement      -------------                              
                                      |                                
    sampler called                    |                                
      sampler does work               |                                
      sampler reads time    -----     |                           
      sampler does work       |       |                           
      return sample object    |       |                           
                              |       |                           
    (measured statements)     |       |                           
                              |       |                           
    sample DESTROY'd          |       |                           
      sample does work        v       |                           
      sample reads time     -----     |     = sample_inner_time  
      sample does work                |                                
                                      v                                
    next statement          -------------   = sample_overhead_time       

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

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

  $core->profile_as_text();
  $core->profile_as_text( $dbi_profile_name );
  $core->profile_as_text( $dbi_profile_name, {
      path      => [ $self->{profile_name} ],
      format    => '%1$s: dur=%11$f count=%10$d (max=%14$f avg=%2$f)'."\n",
      separator => ">",
  } );

  $core->reset_profile_data( $dbi_profile_name );

  $core->visit_profile_nodes( $dbi_profile_name, sub { ... } )

  $core->propagate_period_count( $dbi_profile_name )

  $core->flush()
  $core->flush( $dbi_profile_name )

  $core->flush_if_due()

    $bool = $core->has_profile_data
    $bool = $core->has_profile_data( $dbi_profile_name )

  $core->start_sample_period

  0 = restart the period, silently
  1 = restart the period and issue a warning (this is the default)
  2 = continue the current period, silently
  3 = continue the current period and issue a warning
  4 = call end_sample_period(), silently
  5 = call end_sample_period() and issue a warning

  $core->end_sample_period

  0 = do nothing, silently (this is the default)
  1 = do nothing but warn
  2 = call start_sample_period(), silently
  3 = call start_sample_period() and warn

  $time = $core->period_start_time;

  $sampler_code_ref = $core->prepare( $context1 )
  $sampler_code_ref = $core->prepare( $context1, $context2 )
  $sampler_code_ref = $core->prepare( $context1, $context2, %meta )

  $sampler_code_ref->( $context2 )
  $sampler_code_ref->( $context2, $start_time )

    $ENV{DASHPROFILER_CORE_DEBUG} || $ENV{DASHPROFILER_DEBUG} || 0;

package DashProfiler::Core;

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

sub new {
    my ($class, $profile_name, $opt_params) = @_;
    $opt_params ||= {};
    croak "No profile_name given" unless $profile_name && not ref $profile_name;
    croak "$class->new($profile_name, $opt_params) options must be a hash reference"
        if ref $opt_params ne 'HASH';

    our $opt_defaults ||= {
        disabled => 0,
        sample_class => 'DashProfiler::Sample',
        dbi_profile_class => 'DBI::Profile',
        dbi_profile_args => {},
        flush_interval => 0,
        flush_hook => undef,
        granularity => 0,
        period_exclusive => undef,
        period_summary => undef,
        period_strict_start  => 0x01,
        period_strict_end    => 0x00,
        profile_as_text_args => undef,
        extra_info => undef, # for caller to hook in their own data
    };
    croak "Invalid options: ".join(', ', grep { !$opt_defaults->{$_} } keys %$opt_params)
        if keys %{ { %$opt_defaults, %$opt_params } } > keys %$opt_defaults;

    my $time = dbi_time();
    my $self = bless {
        profile_name         => $profile_name,
        in_use               => 0,
        in_use_warning_given => 0,
        dbi_handles_all      => {},
        dbi_handles_active   => {},
        flush_due_at_time    => undef,
        # for start_period
        period_count         => 0,
        period_start_time    => 0,
        period_accumulated   => 0,
        exclusive_sampler    => undef,
        %$opt_defaults,
        %$opt_params,
    } => $class;
    $self->{flush_due_at_time} = $time + $self->{flush_interval};

    lock_keys(%$self);

    _load_class($self->{sample_class});

    if (my $exclusive_name = $self->{period_exclusive}) {
        # create the sampler through which period_exclusive samples are added
        # by end_sample_period()
        $self->{exclusive_sampler} = $self->prepare($exclusive_name, $exclusive_name);
    }
    my $dbi_profile = $self->_mk_dbi_profile($self->{dbi_profile_class}, $self->{granularity});
    $self->attach_dbi_profile( $dbi_profile, "main", 0 );

    if (my $period_summary = $self->{period_summary}) {
        my $dbi_profile = $self->_mk_dbi_profile("DashProfiler::DumpNowhere", 0);
        my $dbh = $self->attach_dbi_profile( $dbi_profile, "period_summary", 0 );
        $self->{dbi_handles_all}{period_summary} = $dbh;
        # start_sample_period() will add handle to {dbi_handles_active}
    }

    # mark as in_use if disabled as this allows the sampler to be more efficient
    $self->{in_use} = -42 if $self->{disabled};

    return $self;
}

sub estimate_sample_overheads {
    my ($self, $count) = @_;
    $count ||= 1000;

    my $profile = __PACKAGE__->new('overhead',{ dbi_profile_class => 'DashProfiler::DumpNowhere' });
    my $sampler = $profile->prepare('c1');
    # It's okay that this is a tight loop so will tend to give lower times
    # than would be experienced in practice because, while we want to get as
    # close as possible to the true overhead, we don't want to overestimate it.
    my ($i, $sum) = ($count, 0);
    while ($i--) {
        my $t0 = dbi_time();         # to compare with t1 below
        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);
}

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

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

sub profile_as_text {
    my $self = shift;
    my $name = shift;
    my $default_args = $self->{profile_as_text_args} || {};
    my %args = (%$default_args, %{ shift || {} });

    $args{path}   ||= [ $self->{profile_name} ];
    $args{format} ||= '%1$s: dur=%11$f count=%10$d (max=%14$f avg=%2$f)'."\n";
    $args{separator} ||= ">";

    my $dbi_profile = $self->get_dbi_profile($name) or return;
    return $dbi_profile->as_text(\%args);
}

sub reset_profile_data {
    my ($self, $dbi_profile_name) = @_;
    my @dbi_profiles = $self->get_dbi_profile($dbi_profile_name);
    $_->empty for @dbi_profiles;
    $self->{period_count} = 0;
    return @dbi_profiles;
}


sub _visit_nodes {  # depth first with lexical ordering
    my ($self, $node, $path, $sub) = @_;
    croak "No sub ref given" unless ref $sub eq 'CODE';
    return unless $node;
    $path ||= [];
    if (ref $node eq 'HASH') {    # recurse
        $path = [ @$path, undef ];
        return map {
            $path->[-1] = $_;
            ($node->{$_}) ? $self->_visit_nodes($node->{$_}, $path, $sub) : ()
        } sort keys %$node;
    }
    return $sub->($node, $path);
}   

sub visit_profile_nodes {
    my ($self, $dbi_profile_name, $sub) = @_;
    my @dbi_profiles = $self->get_dbi_profile($dbi_profile_name);
    for my $dbi_profile (@dbi_profiles) {
        my $data = $dbi_profile->{Data}
            or next;
        $self->_visit_nodes($data, undef, $sub)
    }
    return;
}

sub propagate_period_count {
    my ($self, $dbi_profile_name) = @_;
    # force count of all nodes to be count of periods instead of samples
    my $count = $self->{period_count}
        or return 0;
    warn "propagate_period_count $self->{profile_name} count $count\n" if DEBUG();
    # force count of all nodes to be count of periods
    $self->visit_profile_nodes($dbi_profile_name, sub { return unless ref $_[0] eq 'ARRAY'; $_[0]->[0] = $count });
    return $count;
}

sub flush {
    my ($self, $dbi_profile_name) = @_;
    if (my $flush_hook = $self->{flush_hook}) {
        # if flush_hook returns true then don't call flush_to_disk
        my @ret = $flush_hook->($self, $dbi_profile_name);
        return @ret if @ret;
        # else fall through
    }
    my @dbi_profiles = $self->get_dbi_profile($dbi_profile_name);
    $_->flush_to_disk for (@dbi_profiles);
    return @dbi_profiles;
}

sub flush_if_due {
    my ($self) = @_;
    return unless $self->{flush_interval};
    return if time() < $self->{flush_due_at_time};
    $self->{flush_due_at_time} = time() + $self->{flush_interval};
    return $self->flush();
}

sub has_profile_data {
    my ($self, $dbi_profile_name) = @_;
    my @dbi_profiles = $self->get_dbi_profile($dbi_profile_name)
        or return undef; ## no critic
    keys %{$_->{Data}||{}} && return 1 for (@dbi_profiles);
    return 0;
}

sub start_sample_period {
    my $self = shift;
    # marks the start of a series of related samples, e.g, within one http request
    # see end_sample_period()
    if ($self->{period_start_time}) {
        if (my $strictness = $self->{period_strict_start}) {
            $strictness = $strictness->($self) if ref $strictness eq 'CODE';
            carp "start_sample_period() called for $self->{profile_name} without preceeding end_sample_period()"
                if $strictness & 0x01;
            return
                if $strictness & 0x02;
            $self->end_sample_period()
                if $strictness & 0x04;
        }
    }
    if (my $period_summary_h = $self->{dbi_handles_all}{period_summary}) {
        # ensure period_summary_h dbi profile will receive samples
        $self->{dbi_handles_active}{period_summary} = $period_summary_h;
        $period_summary_h->{Profile}->empty; # start period empty
    }
    $self->{period_accumulated} = 0;
    $self->{period_start_time}  = dbi_time();
    return;
}

sub end_sample_period {
    my $self = shift;

    if (not $self->{period_start_time}) {
        if (my $strictness = $self->{period_strict_end}) {
            $strictness = $strictness->($self) if ref $strictness eq 'CODE';
            carp "end_sample_period() called for $self->{profile_name} without preceeding start_sample_period()"
                if $strictness & 0x01;
            $self->start_sample_period()
                if $strictness & 0x02;
        }
        # return if we didn't start a period
        return if not $self->{period_start_time};
    }

    $self->{period_count}++;

    # disconnect period_summary dbi profile from receiving any more samples
    my $period_summary_dbh = delete $self->{dbi_handles_active}{period_summary};
    my $period_summary_profile = $period_summary_dbh->{Profile};

    if (my $exclusive_sampler = $self->{exclusive_sampler}) {
        # Calculate how much time between $self->{period_start_time} and now
        # is not accounted for by $self->{period_accumulated}.
        # Add a sample with the start time forced to be period_start_time
        # shifted forward by the accumulated sample durations + sampling overheads.
        # This accounts for all the time between start_sample_period and
        # end_sample_period that hasn't been accounted for by normal samples.

        # calculate overhead of taking samples
        my $overhead;
        if ($period_summary_profile) {
            # if period_summary is enabled then we can use the count of
            # samples this period to scale the overhead correctly
            dbi_profile_merge(my $total=[], $period_summary_profile->{Data});
            # scale overhead by number of samples in period
            $overhead = $sample_overhead_time * $total->[0];
        }
        else {
            # if period_summary is not enabled then we can't do much
            $overhead = $sample_overhead_time;
        }

        warn sprintf "%s period end: overhead %.6fs (%.0f * %.6fs)\n",
                $self->{profile_name}, $overhead, $overhead/$sample_overhead_time, $sample_overhead_time
            if DEBUG() && DEBUG() >= 3;

        $exclusive_sampler->(undef, $self->{period_start_time} + $self->{period_accumulated} + $overhead);

        # sample gets destroyed, and so counted, immediately.
    }

    $self->{period_start_time} = 0;
    # $self->{period_accumulated} will be reset by start_sample_period()

    return $period_summary_profile;
}

sub period_start_time {
    return shift->{period_start_time};
}

sub prepare {
    my ($self, $context1, $context2, %meta) = @_;
    # return undef if profile exists but is disabled
    return undef if $self->{disabled}; ## no critic

    # return a light wrapper around the profile, containing the context1
    my $sample_class = $meta{sample_class} || $self->{sample_class};
    # use %meta to carry context info into sample object factory
    $meta{_dash_profile} = $self;
    $meta{_context1}     = $context1;
    $meta{_context2}     = $context2;
    # skip method lookup
    my $coderef = $sample_class->can("new") || "new";
    return sub { # closure over $sample_class, %meta and $coderef
        $sample_class->$coderef(\%meta, @_)
    };
}


sub DESTROY {
    my $self = shift;
    # global destruction shouldn't be relied upon because often the
    # dbi profile data will have been already destroyed
    $self->end_sample_period() if $self->{period_start_time};
    $self->flush if $self->has_profile_data("*");
}


sub _load_class {
    my ($class) = @_;
    ## no critic
    no strict 'refs';
    return 1 if keys %{"$class\::"}; # already loaded
    (my $file = $class) =~ s/::/\//g;
    require "$file.pm";
}

# --- DBI::ProfileDumper subclass that doesn't flush_to_disk
#     Used by period_summary
{
    package DashProfiler::DumpNowhere;
    use strict;
    use base qw(DBI::ProfileDumper);
    sub flush_to_disk { return }
}


# --- ultra small 'null' driver for DBI ---
#     This is really just for the custom dbh DESTROY method below

{
    package DBD::DashProfiler;
    our $drh;       # holds driver handle once initialised
    sub driver{
        return $drh if $drh;
        my ($class, $attr) = @_;
        $DBD::DashProfiler::db::imp_data_size = 0;
        $DBD::DashProfiler::dr::imp_data_size = 0;
        return DBI::_new_drh($class."::dr", {
            Name => 'DashProfiler', Version => $DashProfiler::Core::VERSION,
        });
    }
    sub CLONE { undef $drh }
}
{   package DBD::DashProfiler::dr;
    our $imp_data_size = 0;
    sub DESTROY { undef }
}
{   package DBD::DashProfiler::db;
    our $imp_data_size = 0;
    use strict;
    sub STORE {
        my ($dbh, $attrib, $value) = @_;
        $value = ($value) ? -901 : -900 if $attrib eq 'AutoCommit';
        return $dbh->SUPER::STORE($attrib, $value);
    }
    sub DESTROY {
        my $dbh = shift;
        $dbh->{Profile} = undef; # don't profile the DESTROY
        return $dbh->SUPER::DESTROY;
    }
}
{   package DBD::DashProfiler::st;
    our $imp_data_size = 0;
}
# fake the %INC entry so DBI install_driver won't try to load it
BEGIN { $INC{"DBD/DashProfiler.pm"} = __FILE__ }



1;