[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package DBI::ProfileData; 2 use strict; 3 4 =head1 NAME 5 6 DBI::ProfileData - manipulate DBI::ProfileDumper data dumps 7 8 =head1 SYNOPSIS 9 10 The easiest way to use this module is through the dbiprof frontend 11 (see L<dbiprof> for details): 12 13 dbiprof --number 15 --sort count 14 15 This module can also be used to roll your own profile analysis: 16 17 # load data from dbi.prof 18 $prof = DBI::ProfileData->new(File => "dbi.prof"); 19 20 # get a count of the records (unique paths) in the data set 21 $count = $prof->count(); 22 23 # sort by longest overall time 24 $prof->sort(field => "longest"); 25 26 # sort by longest overall time, least to greatest 27 $prof->sort(field => "longest", reverse => 1); 28 29 # exclude records with key2 eq 'disconnect' 30 $prof->exclude(key2 => 'disconnect'); 31 32 # exclude records with key1 matching /^UPDATE/i 33 $prof->exclude(key1 => qr/^UPDATE/i); 34 35 # remove all records except those where key1 matches /^SELECT/i 36 $prof->match(key1 => qr/^SELECT/i); 37 38 # produce a formatted report with the given number of items 39 $report = $prof->report(number => 10); 40 41 # clone the profile data set 42 $clone = $prof->clone(); 43 44 # get access to hash of header values 45 $header = $prof->header(); 46 47 # get access to sorted array of nodes 48 $nodes = $prof->nodes(); 49 50 # format a single node in the same style as report() 51 $text = $prof->format($nodes->[0]); 52 53 # get access to Data hash in DBI::Profile format 54 $Data = $prof->Data(); 55 56 =head1 DESCRIPTION 57 58 This module offers the ability to read, manipulate and format 59 DBI::ProfileDumper profile data. 60 61 Conceptually, a profile consists of a series of records, or nodes, 62 each of each has a set of statistics and set of keys. Each record 63 must have a unique set of keys, but there is no requirement that every 64 record have the same number of keys. 65 66 =head1 METHODS 67 68 The following methods are supported by DBI::ProfileData objects. 69 70 =cut 71 72 73 our $VERSION = sprintf("2.%06d", q$Revision: 10007 $ =~ /(\d+)/o); 74 75 use Carp qw(croak); 76 use Symbol; 77 use Fcntl qw(:flock); 78 79 use DBI::Profile qw(dbi_profile_merge); 80 81 # some constants for use with node data arrays 82 sub COUNT () { 0 }; 83 sub TOTAL () { 1 }; 84 sub FIRST () { 2 }; 85 sub SHORTEST () { 3 }; 86 sub LONGEST () { 4 }; 87 sub FIRST_AT () { 5 }; 88 sub LAST_AT () { 6 }; 89 sub PATH () { 7 }; 90 91 92 my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK}) 93 ? $ENV{DBI_PROFILE_FLOCK} 94 : do { local $@; eval { flock STDOUT, 0; 1 } }; 95 96 97 =head2 $prof = DBI::ProfileData->new(File => "dbi.prof") 98 99 =head2 $prof = DBI::ProfileData->new(File => "dbi.prof", Filter => sub { ... }) 100 101 =head2 $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ]) 102 103 Creates a a new DBI::ProfileData object. Takes either a single file 104 through the File option or a list of Files in an array ref. If 105 multiple files are specified then the header data from the first file 106 is used. 107 108 =head3 Files 109 110 Reference to an array of file names to read. 111 112 =head3 File 113 114 Name of file to read. Takes precedence over C<Files>. 115 116 =head3 DeleteFiles 117 118 If true, the files are deleted after being read. 119 120 Actually the files are renamed with a C.deleteme> suffix before being read, 121 and then, after reading all the files, they're all deleted together. 122 123 The files are locked while being read which, combined with the rename, makes it 124 safe to 'consume' files that are still being generated by L<DBI::ProfileDumper>. 125 126 =head3 Filter 127 128 The C<Filter> parameter can be used to supply a code reference that can 129 manipulate the profile data as it is being read. This is most useful for 130 editing SQL statements so that slightly different statements in the raw data 131 will be merged and aggregated in the loaded data. For example: 132 133 Filter => sub { 134 my ($path_ref, $data_ref) = @_; 135 s/foo = '.*?'/foo = '...'/ for @$path_ref; 136 } 137 138 Here's an example that performs some normalization on the SQL. It converts all 139 numbers to C<N> and all quoted strings to C<S>. It can also convert digits to 140 N within names. Finally, it summarizes long "IN (...)" clauses. 141 142 It's aggressive and simplistic, but it's often sufficient, and serves as an 143 example that you can tailor to suit your own needs: 144 145 Filter => sub { 146 my ($path_ref, $data_ref) = @_; 147 local $_ = $path_ref->[0]; # whichever element contains the SQL Statement 148 s/\b\d+\b/N/g; # 42 -> N 149 s/\b0x[0-9A-Fa-f]+\b/N/g; # 0xFE -> N 150 s/'.*?'/'S'/g; # single quoted strings (doesn't handle escapes) 151 s/".*?"/"S"/g; # double quoted strings (doesn't handle escapes) 152 # convert names like log_20001231 into log_NNNNNNNN, controlled by $opt{n} 153 s/([a-z_]+)(\d{$opt{n},})/$1.('N' x length($2))/ieg if $opt{n}; 154 # abbreviate massive "in (...)" statements and similar 155 s!(([NS],){100,})!sprintf("$2,{repeated %d times}",length($1)/2)!eg; 156 } 157 158 It's often better to perform this kinds of normalization in the DBI while the 159 data is being collected, to avoid too much memory being used by storing profile 160 data for many different SQL statement. See L<DBI::Profile>. 161 162 =cut 163 164 sub new { 165 my $pkg = shift; 166 my $self = { 167 Files => [ "dbi.prof" ], 168 Filter => undef, 169 DeleteFiles => 0, 170 LockFile => $HAS_FLOCK, 171 _header => {}, 172 _nodes => [], 173 _node_lookup => {}, 174 _sort => 'none', 175 @_ 176 }; 177 bless $self, $pkg; 178 179 # File (singular) overrides Files (plural) 180 $self->{Files} = [ $self->{File} ] if exists $self->{File}; 181 182 $self->_read_files(); 183 return $self; 184 } 185 186 # read files into _header and _nodes 187 sub _read_files { 188 my $self = shift; 189 my $files = $self->{Files}; 190 my $read_header = 0; 191 my @files_to_delete; 192 193 my $fh = gensym; 194 foreach (@$files) { 195 my $filename = $_; 196 197 if ($self->{DeleteFiles}) { 198 my $newfilename = $filename . ".deleteme"; 199 if ($^O eq 'VMS') { 200 # VMS default filesystem can only have one period 201 $newfilename = $filename . 'deleteme'; 202 } 203 # will clobber an existing $newfilename 204 rename($filename, $newfilename) 205 or croak "Can't rename($filename, $newfilename): $!"; 206 # On a versioned filesystem we want old versions to be removed 207 1 while (unlink $filename); 208 $filename = $newfilename; 209 } 210 211 open($fh, "<", $filename) 212 or croak("Unable to read profile file '$filename': $!"); 213 214 # lock the file in case it's still being written to 215 # (we'll be foced to wait till the write is complete) 216 flock($fh, LOCK_SH) if $self->{LockFile}; 217 218 if (-s $fh) { # not empty 219 $self->_read_header($fh, $filename, $read_header ? 0 : 1); 220 $read_header = 1; 221 $self->_read_body($fh, $filename); 222 } 223 close($fh); # and release lock 224 225 push @files_to_delete, $filename 226 if $self->{DeleteFiles}; 227 } 228 for (@files_to_delete){ 229 # for versioned file systems 230 1 while (unlink $_); 231 if(-e $_){ 232 warn "Can't delete '$_': $!"; 233 } 234 } 235 236 # discard node_lookup now that all files are read 237 delete $self->{_node_lookup}; 238 } 239 240 # read the header from the given $fh named $filename. Discards the 241 # data unless $keep. 242 sub _read_header { 243 my ($self, $fh, $filename, $keep) = @_; 244 245 # get profiler module id 246 my $first = <$fh>; 247 chomp $first; 248 $self->{_profiler} = $first if $keep; 249 250 # collect variables from the header 251 local $_; 252 while (<$fh>) { 253 chomp; 254 last unless length $_; 255 /^(\S+)\s*=\s*(.*)/ 256 or croak("Syntax error in header in $filename line $.: $_"); 257 # XXX should compare new with existing (from previous file) 258 # and warn if they differ (diferent program or path) 259 $self->{_header}{$1} = unescape_key($2) if $keep; 260 } 261 } 262 263 264 sub unescape_key { # inverse of escape_key() in DBI::ProfileDumper 265 local $_ = shift; 266 s/(?<!\\)\\n/\n/g; # expand \n, unless it's a \\n 267 s/(?<!\\)\\r/\r/g; # expand \r, unless it's a \\r 268 s/\\\\/\\/g; # \\ to \ 269 return $_; 270 } 271 272 273 # reads the body of the profile data 274 sub _read_body { 275 my ($self, $fh, $filename) = @_; 276 my $nodes = $self->{_nodes}; 277 my $lookup = $self->{_node_lookup}; 278 my $filter = $self->{Filter}; 279 280 # build up node array 281 my @path = (""); 282 my (@data, $path_key); 283 local $_; 284 while (<$fh>) { 285 chomp; 286 if (/^\+\s+(\d+)\s?(.*)/) { 287 # it's a key 288 my ($key, $index) = ($2, $1 - 1); 289 290 $#path = $index; # truncate path to new length 291 $path[$index] = unescape_key($key); # place new key at end 292 293 } 294 elsif (s/^=\s+//) { 295 # it's data - file in the node array with the path in index 0 296 # (the optional minus is to make it more robust against systems 297 # with unstable high-res clocks - typically due to poor NTP config 298 # of kernel SMP behaviour, i.e. min time may be -0.000008)) 299 300 @data = split / /, $_; 301 302 # corrupt data? 303 croak("Invalid number of fields in $filename line $.: $_") 304 unless @data == 7; 305 croak("Invalid leaf node characters $filename line $.: $_") 306 unless m/^[-+ 0-9eE\.]+$/; 307 308 # hook to enable pre-processing of the data - such as mangling SQL 309 # so that slightly different statements get treated as the same 310 # and so merged in the results 311 $filter->(\@path, \@data) if $filter; 312 313 # elements of @path can't have NULLs in them, so this 314 # forms a unique string per @path. If there's some way I 315 # can get this without arbitrarily stripping out a 316 # character I'd be happy to hear it! 317 $path_key = join("\0",@path); 318 319 # look for previous entry 320 if (exists $lookup->{$path_key}) { 321 # merge in the new data 322 dbi_profile_merge($nodes->[$lookup->{$path_key}], \@data); 323 } else { 324 # insert a new node - nodes are arrays with data in 0-6 325 # and path data after that 326 push(@$nodes, [ @data, @path ]); 327 328 # record node in %seen 329 $lookup->{$path_key} = $#$nodes; 330 } 331 } 332 else { 333 croak("Invalid line type syntax error in $filename line $.: $_"); 334 } 335 } 336 } 337 338 339 340 =head2 $copy = $prof->clone(); 341 342 Clone a profile data set creating a new object. 343 344 =cut 345 346 sub clone { 347 my $self = shift; 348 349 # start with a simple copy 350 my $clone = bless { %$self }, ref($self); 351 352 # deep copy nodes 353 $clone->{_nodes} = [ map { [ @$_ ] } @{$self->{_nodes}} ]; 354 355 # deep copy header 356 $clone->{_header} = { %{$self->{_header}} }; 357 358 return $clone; 359 } 360 361 =head2 $header = $prof->header(); 362 363 Returns a reference to a hash of header values. These are the key 364 value pairs included in the header section of the DBI::ProfileDumper 365 data format. For example: 366 367 $header = { 368 Path => [ '!Statement', '!MethodName' ], 369 Program => 't/42profile_data.t', 370 }; 371 372 Note that modifying this hash will modify the header data stored 373 inside the profile object. 374 375 =cut 376 377 sub header { shift->{_header} } 378 379 380 =head2 $nodes = $prof->nodes() 381 382 Returns a reference the sorted nodes array. Each element in the array 383 is a single record in the data set. The first seven elements are the 384 same as the elements provided by DBI::Profile. After that each key is 385 in a separate element. For example: 386 387 $nodes = [ 388 [ 389 2, # 0, count 390 0.0312958955764771, # 1, total duration 391 0.000490069389343262, # 2, first duration 392 0.000176072120666504, # 3, shortest duration 393 0.00140702724456787, # 4, longest duration 394 1023115819.83019, # 5, time of first event 395 1023115819.86576, # 6, time of last event 396 'SELECT foo FROM bar' # 7, key1 397 'execute' # 8, key2 398 # 6+N, keyN 399 ], 400 # ... 401 ]; 402 403 Note that modifying this array will modify the node data stored inside 404 the profile object. 405 406 =cut 407 408 sub nodes { shift->{_nodes} } 409 410 411 =head2 $count = $prof->count() 412 413 Returns the number of items in the profile data set. 414 415 =cut 416 417 sub count { scalar @{shift->{_nodes}} } 418 419 420 =head2 $prof->sort(field => "field") 421 422 =head2 $prof->sort(field => "field", reverse => 1) 423 424 Sorts data by the given field. Available fields are: 425 426 longest 427 total 428 count 429 shortest 430 431 The default sort is greatest to smallest, which is the opposite of the 432 normal Perl meaning. This, however, matches the expected behavior of 433 the dbiprof frontend. 434 435 =cut 436 437 438 # sorts data by one of the available fields 439 { 440 my %FIELDS = ( 441 longest => LONGEST, 442 total => TOTAL, 443 count => COUNT, 444 shortest => SHORTEST, 445 key1 => PATH+0, 446 key2 => PATH+1, 447 key3 => PATH+2, 448 ); 449 sub sort { 450 my $self = shift; 451 my $nodes = $self->{_nodes}; 452 my %opt = @_; 453 454 croak("Missing required field option.") unless $opt{field}; 455 456 my $index = $FIELDS{$opt{field}}; 457 458 croak("Unrecognized sort field '$opt{field}'.") 459 unless defined $index; 460 461 # sort over index 462 if ($opt{reverse}) { 463 @$nodes = sort { 464 $a->[$index] <=> $b->[$index] 465 } @$nodes; 466 } else { 467 @$nodes = sort { 468 $b->[$index] <=> $a->[$index] 469 } @$nodes; 470 } 471 472 # remember how we're sorted 473 $self->{_sort} = $opt{field}; 474 475 return $self; 476 } 477 } 478 479 480 =head2 $count = $prof->exclude(key2 => "disconnect") 481 482 =head2 $count = $prof->exclude(key2 => "disconnect", case_sensitive => 1) 483 484 =head2 $count = $prof->exclude(key1 => qr/^SELECT/i) 485 486 Removes records from the data set that match the given string or 487 regular expression. This method modifies the data in a permanent 488 fashion - use clone() first to maintain the original data after 489 exclude(). Returns the number of nodes left in the profile data set. 490 491 =cut 492 493 sub exclude { 494 my $self = shift; 495 my $nodes = $self->{_nodes}; 496 my %opt = @_; 497 498 # find key index number 499 my ($index, $val); 500 foreach (keys %opt) { 501 if (/^key(\d+)$/) { 502 $index = PATH + $1 - 1; 503 $val = $opt{$_}; 504 last; 505 } 506 } 507 croak("Missing required keyN option.") unless $index; 508 509 if (UNIVERSAL::isa($val,"Regexp")) { 510 # regex match 511 @$nodes = grep { 512 $#$_ < $index or $_->[$index] !~ /$val/ 513 } @$nodes; 514 } else { 515 if ($opt{case_sensitive}) { 516 @$nodes = grep { 517 $#$_ < $index or $_->[$index] ne $val; 518 } @$nodes; 519 } else { 520 $val = lc $val; 521 @$nodes = grep { 522 $#$_ < $index or lc($_->[$index]) ne $val; 523 } @$nodes; 524 } 525 } 526 527 return scalar @$nodes; 528 } 529 530 531 =head2 $count = $prof->match(key2 => "disconnect") 532 533 =head2 $count = $prof->match(key2 => "disconnect", case_sensitive => 1) 534 535 =head2 $count = $prof->match(key1 => qr/^SELECT/i) 536 537 Removes records from the data set that do not match the given string 538 or regular expression. This method modifies the data in a permanent 539 fashion - use clone() first to maintain the original data after 540 match(). Returns the number of nodes left in the profile data set. 541 542 =cut 543 544 sub match { 545 my $self = shift; 546 my $nodes = $self->{_nodes}; 547 my %opt = @_; 548 549 # find key index number 550 my ($index, $val); 551 foreach (keys %opt) { 552 if (/^key(\d+)$/) { 553 $index = PATH + $1 - 1; 554 $val = $opt{$_}; 555 last; 556 } 557 } 558 croak("Missing required keyN option.") unless $index; 559 560 if (UNIVERSAL::isa($val,"Regexp")) { 561 # regex match 562 @$nodes = grep { 563 $#$_ >= $index and $_->[$index] =~ /$val/ 564 } @$nodes; 565 } else { 566 if ($opt{case_sensitive}) { 567 @$nodes = grep { 568 $#$_ >= $index and $_->[$index] eq $val; 569 } @$nodes; 570 } else { 571 $val = lc $val; 572 @$nodes = grep { 573 $#$_ >= $index and lc($_->[$index]) eq $val; 574 } @$nodes; 575 } 576 } 577 578 return scalar @$nodes; 579 } 580 581 582 =head2 $Data = $prof->Data() 583 584 Returns the same Data hash structure as seen in DBI::Profile. This 585 structure is not sorted. The nodes() structure probably makes more 586 sense for most analysis. 587 588 =cut 589 590 sub Data { 591 my $self = shift; 592 my (%Data, @data, $ptr); 593 594 foreach my $node (@{$self->{_nodes}}) { 595 # traverse to key location 596 $ptr = \%Data; 597 foreach my $key (@{$node}[PATH .. $#$node - 1]) { 598 $ptr->{$key} = {} unless exists $ptr->{$key}; 599 $ptr = $ptr->{$key}; 600 } 601 602 # slice out node data 603 $ptr->{$node->[-1]} = [ @{$node}[0 .. 6] ]; 604 } 605 606 return \%Data; 607 } 608 609 610 =head2 $text = $prof->format($nodes->[0]) 611 612 Formats a single node into a human-readable block of text. 613 614 =cut 615 616 sub format { 617 my ($self, $node) = @_; 618 my $format; 619 620 # setup keys 621 my $keys = ""; 622 for (my $i = PATH; $i <= $#$node; $i++) { 623 my $key = $node->[$i]; 624 625 # remove leading and trailing space 626 $key =~ s/^\s+//; 627 $key =~ s/\s+$//; 628 629 # if key has newlines or is long take special precautions 630 if (length($key) > 72 or $key =~ /\n/) { 631 $keys .= " Key " . ($i - PATH + 1) . " :\n\n$key\n\n"; 632 } else { 633 $keys .= " Key " . ($i - PATH + 1) . " : $key\n"; 634 } 635 } 636 637 # nodes with multiple runs get the long entry format, nodes with 638 # just one run get a single count. 639 if ($node->[COUNT] > 1) { 640 $format = <<END; 641 Count : %d 642 Total Time : %3.6f seconds 643 Longest Time : %3.6f seconds 644 Shortest Time : %3.6f seconds 645 Average Time : %3.6f seconds 646 END 647 return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST], 648 $node->[TOTAL] / $node->[COUNT]) . $keys; 649 } else { 650 $format = <<END; 651 Count : %d 652 Time : %3.6f seconds 653 END 654 655 return sprintf($format, @{$node}[COUNT,TOTAL]) . $keys; 656 657 } 658 } 659 660 661 =head2 $text = $prof->report(number => 10) 662 663 Produces a report with the given number of items. 664 665 =cut 666 667 sub report { 668 my $self = shift; 669 my $nodes = $self->{_nodes}; 670 my %opt = @_; 671 672 croak("Missing required number option") unless exists $opt{number}; 673 674 $opt{number} = @$nodes if @$nodes < $opt{number}; 675 676 my $report = $self->_report_header($opt{number}); 677 for (0 .. $opt{number} - 1) { 678 $report .= sprintf("#" x 5 . "[ %d ]". "#" x 59 . "\n", 679 $_ + 1); 680 $report .= $self->format($nodes->[$_]); 681 $report .= "\n"; 682 } 683 return $report; 684 } 685 686 # format the header for report() 687 sub _report_header { 688 my ($self, $number) = @_; 689 my $nodes = $self->{_nodes}; 690 my $node_count = @$nodes; 691 692 # find total runtime and method count 693 my ($time, $count) = (0,0); 694 foreach my $node (@$nodes) { 695 $time += $node->[TOTAL]; 696 $count += $node->[COUNT]; 697 } 698 699 my $header = <<END; 700 701 DBI Profile Data ($self->{_profiler}) 702 703 END 704 705 # output header fields 706 while (my ($key, $value) = each %{$self->{_header}}) { 707 $header .= sprintf(" %-13s : %s\n", $key, $value); 708 } 709 710 # output summary data fields 711 $header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time); 712 Total Records : %d (showing %d, sorted by %s) 713 Total Count : %d 714 Total Runtime : %3.6f seconds 715 716 END 717 718 return $header; 719 } 720 721 722 1; 723 724 __END__ 725 726 =head1 AUTHOR 727 728 Sam Tregar <sam@tregar.com> 729 730 =head1 COPYRIGHT AND LICENSE 731 732 Copyright (C) 2002 Sam Tregar 733 734 This program is free software; you can redistribute it and/or modify 735 it under the same terms as Perl 5 itself. 736 737 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |