view release on metacpan or  search on metacpan

t/42prof_data.t  view on Meta::CPAN

#!perl -w
$|=1;

use strict;

use DBI;
use Config;
use Test::More;
use Data::Dumper;

BEGIN {
    plan skip_all => 'profiling not supported for DBI::PurePerl'
        if $DBI::PurePerl;

    # clock instability on xen systems is a reasonably common cause of failure
    # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html
    # so we'll skip automated testing on those systems
    plan skip_all => "skipping profile tests on xen (due to clock instability)"
        if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64
        and $ENV{AUTOMATED_TESTING};

    plan tests => 31;
}

BEGIN {
    use_ok( 'DBI::ProfileDumper' );
    use_ok( 'DBI::ProfileData' );
}

my $sql = "select mode,size,name from ?";

my $prof_file = "dbi$$.prof";
my $prof_backup = $prof_file . ".prev";
END { 1 while unlink $prof_file;
      1 while unlink $prof_backup; }

my $dbh = DBI->connect("dbi:ExampleP:", '', '', 
                       { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" });
isa_ok( $dbh, 'DBI::db', 'Created connection' );

require DBI::Profile;
DBI::Profile->import(qw(dbi_time));

# do enough work to avoid 0's on systems that are very fast or have low res timers
my $t1 = dbi_time();
foreach (1..20) {
  $dbh->do("set dummy=$_");
  my $sth = $dbh->prepare($sql);
  for my $loop (1..90) {  
    $sth->execute(".");
    $sth->fetchrow_hashref;
    $sth->finish;
  }
  $sth->{Profile}->flush_to_disk();
}
$dbh->disconnect;
undef $dbh;
my $t2 = dbi_time();
note sprintf "DBI work done in %fs (%f - %f)", $t2-$t1, $t2, $t1;


# wrote the profile to disk?
ok(-s $prof_file, "Profile written to disk, non-zero size" );

# load up
my $prof = DBI::ProfileData->new(
    File => $prof_file,
    Filter => sub {
        my ($path_ref, $data_ref) = @_;
        $path_ref->[0] =~ s/set dummy=\d/set dummy=N/;
    },
);
isa_ok( $prof, 'DBI::ProfileData' );
cmp_ok( $prof->count, '>=', 3, 'At least 3 profile data items' );

# try a few sorts
my $nodes = $prof->nodes;
$prof->sort(field => "longest");
my $longest = $nodes->[0][4];
ok($longest);
$prof->sort(field => "longest", reverse => 1);
cmp_ok( $nodes->[0][4], '<', $longest );

$prof->sort(field => "count");
my $most = $nodes->[0];
ok($most);
$prof->sort(field => "count", reverse => 1);
cmp_ok( $nodes->[0][0], '<', $most->[0] );

# remove the top count and make sure it's gone
my $clone = $prof->clone();
isa_ok( $clone, 'DBI::ProfileData' );
$clone->sort(field => "count");
ok($clone->exclude(key1 => $most->[7]));