File: 40profile.t

package info (click to toggle)
libdbi-perl 1.631-3
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 2,568 kB
  • ctags: 1,939
  • sloc: perl: 17,531; ansic: 601; makefile: 28; cpp: 4
file content (485 lines) | stat: -rw-r--r-- 16,526 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
#!perl -w
$|=1;

#
# test script for DBI::Profile
#

use strict;

use Config;
use DBI::Profile;
use DBI qw(dbi_time);
use Data::Dumper;
use File::Spec;
use Storable qw(dclone);

use Test::More;

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

    # tie methods (STORE/FETCH etc) get called different number of times
    plan skip_all => "test results assume perl >= 5.8.2"
        if $] <= 5.008001;

    # 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 => 60;
}

$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;

# log file to store profile results
my $LOG_FILE = "test_output_profile$$.log";
my $orig_dbi_debug = $DBI::dbi_debug;
DBI->trace($DBI::dbi_debug, $LOG_FILE);
END {
    return if $orig_dbi_debug;
    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, 'connect');
ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE}, 'Profile and DBI_PROFILE not set');


# can turn it on after the fact using a path number
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "4";
is_deeply sanitize_tree($dbh->{Profile}), bless {
	'Path' => [ '!MethodName' ],
} => 'DBI::Profile';

# using a package name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "/DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
	'Path' => [ ],
} => 'DBI::Profile';

# using a combined path and name
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
$dbh->{Profile} = "20/DBI::Profile";
is_deeply sanitize_tree($dbh->{Profile}), bless {
	'Path' => [ '!MethodName', '!Caller2' ],
} => 'DBI::Profile';

my $t_file = __FILE__;
$dbh->do("set foo=1"); my $line = __LINE__;
my $expected_caller = "40profile.t line $line";
$expected_caller .= " via ${1}40profile.t line 4"
    if $0 =~ /(zv\w+_)/;
print Dumper($dbh->{Profile});
is_deeply sanitize_tree($dbh->{Profile}), bless {
	'Path' => [ '!MethodName', '!Caller2' ],
	'Data' => { 'do' => {
	    $expected_caller => [ 1, 0, 0, 0, 0, 0, 0 ]
	} }
} => 'DBI::Profile'
    or warn Dumper $dbh->{Profile};


# can turn it on at connect
$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 });
is_deeply $dbh->{Profile}{Path}, [ '!Statement', '!MethodName' ];
cmp_ok(keys %{ $dbh->{Profile}{Data} },     '==', 1, 'on at connect, 1 key');
cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1, 'on at connect, 1 key'); # at least STORE
ok(ref $dbh->{Profile}{Data}{""}{STORE}, 'STORE is ref');

print "dbi_profile\n";
# Try to avoid rounding problem on double precision systems
#   $got->[5]      = '1150962858.01596498'
#   $expected->[5] = '1150962858.015965'
# by treating as a string (because is_deeply stringifies)
my $t1 = DBI::dbi_time() . "";
my $dummy_statement = "Hi mom";
my $dummy_methname  = "my_method_name";
my $leaf = dbi_profile($dbh, $dummy_statement, $dummy_methname, $t1, $t1 + 1);
print Dumper($dbh->{Profile});
cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 2, 'avoid rounding, 1 key');
cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1,
       'avoid rounding, 1 dummy statement');
is(ref($dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}), 'ARRAY',
   'dummy method name is array');

ok $leaf, "should return ref to leaf node";
is ref $leaf, 'ARRAY', "should return ref to leaf node";

my $mine = $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname};

is $leaf, $mine, "should return ref to correct leaf node";

print "@$mine\n";
is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ];

my $t2 = DBI::dbi_time() . "";
dbi_profile($dbh, $dummy_statement, $dummy_methname, $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);
for my $loop (1..50) { # enough work for low-res timers or v.fast cpus
    $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, 'profile data');
is(ref $data, 'ARRAY', 'ARRAY ref');
ok(@$data == 7, '7 elements');
ok((grep { defined($_)                } @$data) == 7, 'all 7 defined');
ok((grep { DBI::looks_like_number($_) } @$data) == 7, 'all 7 numeric');
my ($count, $total, $first, $shortest, $longest, $time1, $time2) = @$data;
ok($count > 3, 'count is 3');
ok($total > $first, ' total > first');
ok($total > $longest, 'total > longest') or
    warn "total $total > longest $longest: failed\n";
ok($longest > 0, 'longest > 0') or
    warn "longest $longest > 0: failed\n"; # XXX theoretically not reliable
ok($longest > $shortest, 'longest > shortest');
ok($time1 >= $^T, 'time1 later than start time');
ok($time2 >= $^T, 'time2 later than start time');
ok($time1 <= $time2, 'time1 <= time2');
my $next = int(dbi_time()) + 1;
ok($next > $time1, 'next > time1') or
    warn "next $next > first $time1: failed\n";
ok($next > $time2, 'next > time2') or
    warn "next $next > last $time2: failed\n";
if ($shortest < 0) {
    my $sys = "$Config{archname} $Config{osvers}"; # ie sparc-linux 2.4.20-2.3sparcsmp
    warn <<EOT;
Time went backwards at some point during the test on this $sys system!
Perhaps you have time sync software (like NTP) that adjusted the clock
by more than $shortest seconds during the test.
Also some multiprocessor systems, and some virtualization systems can exhibit
this kind of clock behaviour. Please retry.
EOT
    # don't treat small negative values as failure
    $shortest = 0 if $shortest > -0.8;
}


my $tmp = sanitize_tree($dbh->{Profile});
$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count
is_deeply $tmp, (bless {
	'Path' => [ '!Statement' ],
	'Data' => {
		''   => [ 6, 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'), 'profile';

print "Test profile format\n";
my $output = $dbh->{Profile}->format();
print "Profile Output\n$output";

# check that output was produced in the expected format
ok(length $output, 'non zero length');
ok($output =~ /^DBI::Profile:/, 'DBI::Profile');
ok($output =~ /\((\d+) calls\)/, 'some calls');
ok($1 >= $count, 'calls >= count');

# -----------------------------------------------------------------------------------

# try statement and method name and reference-to-scalar path
my $by_reference = 'foo';
$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
    RaiseError => 1,
    Profile => { Path => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ] }
});
$sql = "select name from .";
$sth = $dbh->prepare($sql);
$sth->execute();
$sth->fetchrow_hashref;
$by_reference = 'bar';
$sth->finish;
undef $sth; # DESTROY

$tmp = sanitize_tree($dbh->{Profile});
ok $tmp->{Data}{usrnam}{""}{foo}{STORE}, 'username stored';
$tmp->{Data}{usrnam}{""}{foo} = {};
# make test insentitive to number of local files
#warn Dumper($tmp);
is_deeply $tmp, bless {
    'Path' => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ],
    'Data' => {
        '' => { # because Profile was enabled by DBI just before Username was set
            '' => {
                'foo' => {
                    'STORE' => [ 3, 0, 0, 0, 0, 0, 0 ],
                }
            }
        },
	'usrnam' => {
	    '' => {
                'foo' => { },
	    },
	    'select name from .' => {
                'foo' => {
                    'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
                    'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
                    'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
                },
                'bar' => {
                    'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ],
                    'finish' => [ 1, 0, 0, 0, 0, 0, 0 ],
                },
	    },
	},
    },
} => 'DBI::Profile';

$tmp = [ $dbh->{Profile}->as_node_path_list() ];
is @$tmp, 8, 'should have 8 nodes';
sanitize_profile_data_nodes($_->[0]) for @$tmp;
#warn Dumper($dbh->{Profile}->{Data});
is_deeply $tmp, [
  [ [ 3, 0, 0, 0, 0, 0, 0 ], '', '', 'foo', 'STORE' ],
  [ [ 2, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'STORE' ],
  [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'connected' ],
  [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'DESTROY' ],
  [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'finish' ],
  [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'execute' ],
  [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'fetchrow_hashref' ],
  [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'prepare' ]
];


print "testing '!File', '!Caller' and their variants in Path\n";

$dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ];
$dbh->{Profile}->{Data} = undef;

my $file = (File::Spec->splitpath(__FILE__))[2]; # '40profile.t'
my ($line1, $line2);
sub a_sub {
    $sth = $dbh->prepare("select name from ."); $line2 = __LINE__;
}
a_sub(); $line1 = __LINE__;

$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});
#warn Dumper($tmp);
is_deeply $tmp, {
  "$file" => {
    "$file via $file" => {
      "$file line $line2" => {
        "$file line $line2 via $file line $line1" => [ 1, 0, 0, 0, 0, 0, 0 ]
      }
    }
  }
};


print "testing '!Time' and variants in Path\n";

undef $sth;
my $factor = 1_000_000;
$dbh->{Profile}->{Path} = [ '!Time', "!Time~$factor", '!MethodName' ];
$dbh->{Profile}->{Data} = undef;

# give up a timeslice in the hope that the following few lines
# run in well under a second even of slow/overloaded systems
$t1 = int(dbi_time())+1; 1 while int(dbi_time()-0.01) < $t1; # spin till just after second starts
$t2 = int($t1/$factor)*$factor;

$sth = $dbh->prepare("select name from .");
$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data});

# if actual "!Time" recorded is 'close enough' then we'll pass
# the test - it's not worth failing just because a system is slow
$t1 = (keys %$tmp)[0] if (abs($t1 - (keys %$tmp)[0]) <= 5);

is_deeply $tmp, {
    $t1 => { $t2 => { prepare => [ 1, 0, 0, 0, 0, 0, 0 ] }}
}, "!Time and !Time~$factor should work"
  or warn Dumper([$t1, $t2, $tmp]);


print "testing &norm_std_n3 in Path\n";

$dbh->{Profile} = '&norm_std_n3'; # assign as string to get magic
is_deeply $dbh->{Profile}{Path}, [
    \&DBI::ProfileSubs::norm_std_n3
];
$dbh->{Profile}->{Data} = undef;
$sql = qq{insert into foo20060726 (a,b) values (42,"foo")};
dbi_profile( { foo => $dbh, bar => undef }, $sql, 'mymethod', 100000000, 100000002);
$tmp = $dbh->{Profile}{Data};
#warn Dumper($tmp);
is_deeply $tmp, {
    'insert into foo<N> (a,b) values (<N>,"<S>")' => [ 1, '2', '2', '2', '2', '100000000', '100000000' ]
}, '&norm_std_n3 should normalize statement';


# -----------------------------------------------------------------------------------

print "testing code ref in Path\n";

sub run_test1 {
    my ($profile) = @_;
    $dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', {
        RaiseError => 1,
        Profile => $profile,
    });
    $sql = "select name from .";
    $sth = $dbh->prepare($sql);
    $sth->execute();
    $sth->fetchrow_hashref;
    $sth->finish;
    undef $sth; # DESTROY
    my $data = sanitize_profile_data_nodes($dbh->{Profile}{Data}, 1);
    return ($data, $dbh) if wantarray;
    return $data;
}

$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] });
is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 11, 0,0,0,0,0,0 ] } } };

$tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] });
is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 11, 0,0,0,0,0,0 ] } } };

$tmp = run_test1( { Path => [ 'foo', sub { \undef } ] });
is_deeply $tmp, { 'foo' => undef }, 'should be vetoed';

# check what code ref sees in $_
$tmp = run_test1( { Path => [ sub { $_ } ] });
is_deeply $tmp, {
  '' => [ 6, 0, 0, 0, 0, 0, 0 ],
  'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ]
}, '$_ should contain statement';

# check what code ref sees in @_
$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if $method =~ /^[A-Z]+$/; return (ref $h, $method) } ] });
is_deeply $tmp, {
  'DBI::db' => {
    'connected' => [ 1, 0, 0, 0, 0, 0, 0 ],
    'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ],
  },
  'DBI::st' => {
    'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
    'execute' => [ 1, 0, 0, 0, 0, 0, 0 ],
    'finish'  => [ 1, 0, 0, 0, 0, 0, 0 ],
  },
}, 'should have @_ as keys';

# check we can filter by method
$tmp = run_test1( { Path => [ sub { return \undef unless $_[1] =~ /^fetch/; return $_[1] } ] });
#warn Dumper($tmp);
is_deeply $tmp, {
    'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ],
}, 'should be able to filter by method';

DBI->trace(0, "STDOUT"); # close current log to flush it
ok(-s $LOG_FILE, 'output should go to log file');

# -----------------------------------------------------------------------------------

print "testing as_text\n";

# check %N$ indices
$dbh->{Profile}->{Data} = { P1 => { P2 => [ 100, 400, 42, 43, 44, 45, 46, 47 ] } };
my $as_text = $dbh->{Profile}->as_text({
    path => [ 'top' ],
    separator => ':',
    format    => '%1$s %2$d [ %10$d %11$d %12$d %13$d %14$d %15$d %16$d %17$d ]',
});
is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]", 'as_text');

# test sortsub
$dbh->{Profile}->{Data} = {
    A => { Z => [ 101, 1, 2, 3, 4, 5, 6, 7 ] },
    B => { Y => [ 102, 1, 2, 3, 4, 5, 6, 7 ] },
};
$as_text = $dbh->{Profile}->as_text({
    separator => ':',
    format    => '%1$s %10$d ',
    sortsub   => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
});
is($as_text, "B:Y 102 A:Z 101 ", 'as_text sortsub');

# general test, including defaults
($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] });
$as_text = $dbh->{Profile}->as_text();
$as_text =~ s/\.00+/.0/g;
#warn "[$as_text]";
is $as_text, q{foo > DESTROY > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > STORE > baz: 0.0s / 5 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > connected > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > execute > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > fetchrow_hashref > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > finish > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
foo > prepare > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s)
}, 'as_text general';

# -----------------------------------------------------------------------------------

print "dbi_profile_merge_nodes\n";
my $total_time = dbi_profile_merge_nodes(
    my $totals=[],
    [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
    [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
);
$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
is("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00",
   'merged nodes');
is($total_time, 0.93, 'merged time');

$total_time = dbi_profile_merge_nodes(
    $totals=[], {
	foo => [ 10, 1.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
        bar => [ 17, 1.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
    }
);
$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues
is("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00",
   'merged time foo/bar');
is($total_time, 2.93, 'merged nodes foo/bar time');

exit 0;


sub sanitize_tree {
    my $data = shift;
    my $skip_clone = shift;
    return $data unless ref $data;
    $data = dclone($data) unless $skip_clone;
    sanitize_profile_data_nodes($data->{Data}) if $data->{Data};
    return $data;
}

sub sanitize_profile_data_nodes {
    my $node = shift;
    if (ref $node eq 'HASH') {
        sanitize_profile_data_nodes($_) for values %$node;
    }
    elsif (ref $node eq 'ARRAY') {
        if (@$node == 7 and DBI::looks_like_number($node->[0])) {
            # sanitize the profile data node to simplify tests
            $_ = 0 for @{$node}[1..@$node-1]; # not 0
        }
    }
    return $node;
}