Author: timbo
Date: Mon Mar 27 06:27:57 2006
New Revision: 3720
Modified:
dbi/trunk/t/40profile.t
Log:
Convert t/40profile.t to Test::More and better tests
Modified: dbi/trunk/t/40profile.t
==============================================================================
--- dbi/trunk/t/40profile.t (original)
+++ dbi/trunk/t/40profile.t Mon Mar 27 06:27:57 2006
@@ -1,22 +1,17 @@
#!perl -w
-use strict;
-
#
# test script for DBI::Profile
#
-# TODO:
-#
-# - fix dbi_profile, see below for test that produces a warning
-# and doesn't work as expected
-#
-# - add tests for the undocumented dbi_profile_merge
-#
-use DBI;
+use strict;
+
+use Config;
use DBI::Profile;
+use DBI;
+use Data::Dumper;
use File::Spec;
-use Config;
+use Storable qw(dclone);
BEGIN {
if ($DBI::PurePerl) {
@@ -25,10 +20,8 @@
}
}
-use Test;
-BEGIN { plan tests => 66 }
+use Test::More tests => 36;
-use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
@@ -37,44 +30,81 @@
DBI->trace(0, $LOG_FILE);
END { 1 while unlink $LOG_FILE; }
+
+print "Test enabling the profile\n";
+
# make sure profiling starts disabled
my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
ok($dbh);
ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE});
-$dbh->disconnect;
-undef $dbh;
+
# can turn it on after the fact using a path number
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "4";
-ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $dbh->{Profile}{Data}, 'HASH');
-ok(ref $dbh->{Profile}{Path}, 'ARRAY');
-$dbh->disconnect;
-undef $dbh;
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ DBIprofile_MethodName ],
+ 'Data' => { FETCH => [ 1, 0, 0, 0, 0, 0, 0 ] }
+} => 'DBI::Profile';
# using a package name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "DBI::Profile";
-ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $dbh->{Profile}{Data}, 'HASH');
-ok(ref $dbh->{Profile}{Path}, 'ARRAY');
-undef $dbh;
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ DBIprofile_Statement ],
+ 'Data' => { '' => [ 1, 0, 0, 0, 0, 0, 0 ] }
+} => 'DBI::Profile';
# using a combined path and name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "2/DBI::Profile";
-ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $dbh->{Profile}{Data}, 'HASH');
-ok(ref $dbh->{Profile}{Path}, 'ARRAY');
-undef $dbh;
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ DBIprofile_Statement ],
+ 'Data' => { '' => [ 1, 0, 0, 0, 0, 0, 0 ] }
+} => 'DBI::Profile';
+
# can turn it on at connect
-$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 });
-ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $dbh->{Profile}{Data}, 'HASH');
-ok(ref $dbh->{Profile}{Path}, 'ARRAY');
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 });
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ DBIprofile_Statement, DBIprofile_MethodName ],
+ 'Data' => {
+ '' => {
+ 'FETCH' => [ 3, 0, 0, 0, 0, 0, 0 ],
+ 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ]
+ }
+ }
+} => 'DBI::Profile';
+print "dbi_profile\n";
+my $t1 = DBI::dbi_time;
+dbi_profile($dbh, "Hi, mom", "my_method_name", $t1, $t1 + 1);
+is_deeply sanitize_tree($dbh->{Profile}), bless {
+ 'Path' => [ DBIprofile_Statement, DBIprofile_MethodName ],
+ 'Data' => {
+ '' => {
+ 'FETCH' => [ 5, 0, 0, 0, 0, 0, 0 ], # +2!
+ 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ]
+ },
+ "Hi, mom" => {
+ my_method_name => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+ }
+} => 'DBI::Profile';
+
+my $mine = $dbh->{Profile}{Data}{"Hi, mom"}{my_method_name};
+print "@$mine\n";
+is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ];
+
+my $t2 = DBI::dbi_time;
+dbi_profile($dbh, "Hi, mom", "my_method_name", $t2, $t2 + 2);
+print "@$mine\n";
+is_deeply $mine, [ 2, 3, 1, 1, 2, $t1, $t2 ];
+
+
+print "Test collected profile data\n";
+
+$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 });
# do a (hopefully) measurable amount of work
my $sql = "select mode,size,name from ?";
my $sth = $dbh->prepare($sql);
@@ -82,13 +112,14 @@
$sth->execute(".");
while ( my $hash = $sth->fetchrow_hashref ) {}
}
+$dbh->do("set foo=1");
print Dumper($dbh->{Profile});
# check that the proper key was set in Data
my $data = $dbh->{Profile}{Data}{$sql};
ok($data);
-ok(ref $data, 'ARRAY');
+is(ref $data, 'ARRAY');
ok(@$data == 7);
ok((grep { defined($_) } @$data) == 7);
ok((grep { DBI::looks_like_number($_) } @$data) == 7);
@@ -115,9 +146,20 @@
ok($next > $time2) or warn "next $next > last $time2: failed\n";
ok($time1 <= $time2);
-# collect output
+my $tmp = sanitize_tree($dbh->{Profile});
+$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count
+is_deeply $tmp, bless {
+ 'Path' => [ DBIprofile_Statement ],
+ 'Data' => {
+ '' => [ 7, 0, 0, 0, 0, 0, 0 ],
+ $sql => [ -1, 0, 0, 0, 0, 0, 0 ],
+ 'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ }
+} => 'DBI::Profile';
+
+print "Test profile format\n";
my $output = $dbh->{Profile}->format();
-print "Profile Output\n\n$output";
+print "Profile Output\n$output";
# check that output was produced in the expected format
ok(length $output);
@@ -125,80 +167,49 @@
ok($output =~ /\((\d+) calls\)/);
ok($1 >= $count);
-# try statement and method name path
-$dbh = DBI->connect("dbi:ExampleP:", '', '',
- { RaiseError => 1,
- Profile => 6 });
-ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $dbh->{Profile}{Data}, 'HASH');
-ok(ref $dbh->{Profile}{Path}, 'ARRAY');
-
-# do a little work
-$sql = "select name from .";
-$sth = $dbh->prepare($sql);
-$sth->execute();
-while ( my $hash = $sth->fetchrow_hashref ) {}
-undef $sth; # DESTROY
-# check that the resulting tree fits the expected layout
-$data = $dbh->{Profile}{Data};
-ok($data);
-ok(exists $data->{$sql});
-ok(keys %{$data->{$sql}}, 4);
-print "Profile Data keys: @{[ keys %{$data->{$sql}} ]}\n";
-ok(exists $data->{$sql}{prepare});
-ok(exists $data->{$sql}{execute});
-ok(exists $data->{$sql}{fetchrow_hashref});
-ok(exists $data->{$sql}{DESTROY});
-
-my $do_sql = "set foo=1";
-$dbh->do($do_sql); # check dbh do() gets associated with right statement
-ok(exists $data->{$do_sql}{do});
-# In perl 5.6 the sth DESTROY gets included. In perl 5.8 it doesn't.
-ok(keys %{$data->{$do_sql}},
- (exists $data->{$do_sql}{DESTROY}) ? 2 : 1);
-
-print "Profile Data keys: @{[ keys %{$data->{$do_sql}} ]}\n";
-
-
-# try a custom path
-$dbh = DBI->connect("dbi:ExampleP:dbname", 'usrname', '', {
- RaiseError=>1, Profile=> { Path => [
- '{Username}', '{AutoCommit}', 'foo', '{bar}', DBIprofile_Statement,
DBIprofile_MethodName,
- ] }
+# try statement and method name path
+$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
+ RaiseError => 1,
+ Profile => { Path => [ '{Username}', DBIprofile_Statement, 'foo',
DBIprofile_MethodName ] }
});
-ok(ref $dbh->{Profile}, "DBI::Profile");
-ok(ref $dbh->{Profile}{Data}, 'HASH');
-ok(ref $dbh->{Profile}{Path}, 'ARRAY');
-
-# do a little work
$sql = "select name from .";
$sth = $dbh->prepare($sql);
$sth->execute();
while ( my $hash = $sth->fetchrow_hashref ) {}
+undef $sth; # DESTROY
-print Dumper($dbh->{Profile});
-
-# check that the resulting tree fits the expected layout
-$data = $dbh->{Profile}{Data};
-ok($data);
-ok(exists $data->{usrname});
-ok(exists $data->{usrname}{1});
-ok(exists $data->{usrname}{1}{foo});
-ok(exists $data->{usrname}{1}{foo}{""});
-
-$data = $data->{usrname}{1}{foo}{""}; # $data now points deeper into the tree
-ok(exists $data->{$sql});
-ok(exists $data->{$sql}{prepare});
-ok(exists $data->{$sql}{execute});
-ok(exists $data->{$sql}{fetchrow_hashref});
-ok(ref $data->{$sql}{prepare}, 'ARRAY');
-ok(@{$data->{$sql}{prepare}} == 7);
-
-my $t1 = DBI::dbi_time;
-dbi_profile($dbh, "Hi, mom", "fetchhash_bang", $t1, $t1 + 1);
-ok(exists $data->{"Hi, mom"});
-
+$tmp = sanitize_tree($dbh->{Profile});
+# make test insentitive to number of local files
+$tmp->{Data}{usrnam}{'select name from .'}{foo}{fetchrow_hashref}[0] = -1;
+is_deeply $tmp, bless {
+ 'Path' => [ '{Username}', DBIprofile_Statement, 'foo',
DBIprofile_MethodName ],
+ 'Data' => {
+ '' => {
+ '' => {
+ 'foo' => {
+ 'FETCH' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ },
+ },
+ },
+ 'usrnam' => {
+ '' => {
+ 'foo' => {
+ 'FETCH' => [ 2, 0, 0, 0, 0, 0, 0 ],
+ 'STORE' => [ 2, 0, 0, 0, 0, 0, 0 ],
+ },
+ },
+ 'select name from .' => {
+ 'foo' => {
+ 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'fetchrow_hashref' => [ -1, 0, 0, 0, 0, 0, 0 ],
+ 'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
+ 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ]
+ },
+ },
+ },
+ },
+} => 'DBI::Profile';
print "dbi_profile_merge\n";
my $total_time = dbi_profile_merge(
@@ -207,8 +218,8 @@
[ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
);
$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
-ok("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00");
-ok($total_time, 0.93);
+is("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00");
+is($total_time, 0.93);
$total_time = dbi_profile_merge(
$totals=[], {
@@ -217,10 +228,32 @@
}
);
$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
-ok("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00");
-ok($total_time, 2.93);
+is("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00");
+is($total_time, 2.93);
DBI->trace(0, "STDOUT"); # close current log to flush it
ok(-s $LOG_FILE); # check that output went into the log file
exit 0;
+
+
+sub sanitize_tree {
+ my $data = shift;
+ return $data unless ref $data;
+ $data = dclone($data);
+ my $tree = (exists $data->{Path} && exists $data->{Data}) ? $data->{Data}
: $data;
+ _sanitize_node($_) for values %$tree;
+ return $data;
+}
+
+sub _sanitize_node {
+ my $node = shift;
+ if (ref $node eq 'HASH') {
+ _sanitize_node($_) for values %$node;
+ }
+ elsif (ref $node eq 'ARRAY') {
+ # sanitize the profile data node so tests
+ $_ = 0 for @[EMAIL PROTECTED]; # not 0
+ }
+ return;
+}
