[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/i586-linux-thread-multi/DBI/ -> ProfileData.pm (source)

   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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1