зеркало из https://github.com/mozilla/pjs.git
262 строки
7.4 KiB
Perl
262 строки
7.4 KiB
Perl
#
|
|
# The contents of this file are subject to the Mozilla Public
|
|
# License Version 1.1 (the "License"); you may not use this file
|
|
# except in compliance with the License. You may obtain a copy of
|
|
# the License at http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS
|
|
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
|
|
# implied. See the License for the specific language governing
|
|
# rights and limitations under the License.
|
|
#
|
|
# The Original Code is Mozilla page-loader test, released Aug 5, 2001
|
|
#
|
|
# The Initial Developer of the Original Code is Netscape
|
|
# Communications Corporation. Portions created by Netscape are
|
|
# Copyright (C) 2001 Netscape Communications Corporation. All
|
|
# Rights Reserved.
|
|
#
|
|
# Contributor(s):
|
|
# John Morrison <jrgm@netscape.com>, original author
|
|
#
|
|
#
|
|
package URLTimingDataSet;
|
|
use DBI;
|
|
use PageData; # list of test pages, etc.
|
|
use strict;
|
|
|
|
sub new {
|
|
my $proto = shift;
|
|
my $class = ref($proto) || $proto;
|
|
my $self = {
|
|
dataset => [],
|
|
results => [],
|
|
sorted => [],
|
|
average => undef,
|
|
avgmedian => undef, # note: average of individual medians
|
|
maximum => undef,
|
|
minimum => undef,
|
|
};
|
|
$self->{id} = shift || die "No id supplied";
|
|
$self->{table} = shift || "t" . $self->{id};
|
|
$self->{pages} = PageData->new;
|
|
bless ($self, $class);
|
|
$self->_grok();
|
|
return $self;
|
|
}
|
|
|
|
|
|
sub _grok {
|
|
my $self = shift;
|
|
my ($res);
|
|
|
|
# select the dataset from the db
|
|
$self->_select();
|
|
|
|
for (my $i=0; $i < $self->{pages}->length; $i++) {
|
|
my $name = $self->{pages}->name($i);
|
|
my $count = 0;
|
|
my @times = ();
|
|
my $nan = 0;
|
|
foreach my $ref (@{$self->{dataset}}) {
|
|
next if ($name ne $ref->{content});
|
|
$count++;
|
|
if ($ref->{c_part} eq "NaN") {
|
|
# we bailed out of this page load
|
|
$res = "NaN";
|
|
$nan = 1;
|
|
}
|
|
else {
|
|
my $s_intvl = $ref->{s_intvl};
|
|
my $c_intvl = $ref->{c_intvl};
|
|
my $errval = abs($s_intvl-$c_intvl)/(($s_intvl+$c_intvl)/2);
|
|
if ($errval > 0.08) { # one of them went wrong and stalled out (see [1] below)
|
|
$res = ($s_intvl <= $c_intvl) ? $s_intvl : $c_intvl;
|
|
} else {
|
|
$res = int(($s_intvl + $c_intvl)/2);
|
|
}
|
|
}
|
|
push @times, $res;
|
|
}
|
|
|
|
my $avg = int(_avg(@times));
|
|
my $med = _med(@times);
|
|
my $max = $nan ? "NaN" : _max(@times);
|
|
my $min = _min(@times);
|
|
push @{$self->{results}}, [ $i, $name, $count, $avg, $med, $max, $min, @times ];
|
|
}
|
|
|
|
$self->_get_summary();
|
|
$self->_sort_result_set();
|
|
|
|
}
|
|
|
|
sub _select {
|
|
my $self = shift;
|
|
|
|
my $dbh = DBI->connect("DBI:CSV:f_dir=./db", {RaiseError => 1, AutoCommit => 1})
|
|
or die "Cannot connect: " . $DBI::errstr;
|
|
|
|
my $sql = qq{
|
|
SELECT INDEX, S_INTVL, C_INTVL, C_PART, CONTENT, ID
|
|
FROM $self->{table}
|
|
WHERE ID = "$self->{id}"
|
|
};
|
|
|
|
my $sth = $dbh->prepare($sql);
|
|
$sth->execute();
|
|
|
|
while (my @data = $sth->fetchrow_array()) {
|
|
push @{$self->{dataset}},
|
|
{index => $data[0],
|
|
s_intvl => $data[1],
|
|
c_intvl => $data[2],
|
|
c_part => $data[3],
|
|
content => $data[4],
|
|
id => $data[5]
|
|
};
|
|
}
|
|
$sth->finish();
|
|
$dbh->disconnect();
|
|
}
|
|
|
|
sub _get_summary {
|
|
my $self = shift;
|
|
my (@avg, @med, @max, @min);
|
|
|
|
# how many pages were loaded in total ('sampled')
|
|
$self->{samples} = scalar(@{$self->{dataset}});
|
|
|
|
# how many cycles (should I get this from test parameters instead?)
|
|
$self->{count} = int(_avg( map($_->[2], @{$self->{results}}) ));
|
|
warn $self->{count};
|
|
|
|
# calculate overall average, average median, maximum, minimum, (RMS Error?)
|
|
for (@{$self->{results}}) {
|
|
push @avg, $_->[3];
|
|
push @med, $_->[4];
|
|
push @max, $_->[5];
|
|
push @min, $_->[6];
|
|
}
|
|
$self->{average} = int(_avg(@avg));
|
|
$self->{avgmedian} = int(_avg(@med)); # note: averaging individual medians
|
|
$self->{maximum} = _max(@max);
|
|
$self->{minimum} = _min(@min);
|
|
}
|
|
|
|
sub _sort_result_set {
|
|
my $self = shift;
|
|
# sort by median load time
|
|
# @{$self->{sorted}} = sort {$a->[4] <=> $b->[4]} @{$self->{results}};
|
|
# might be "NaN", but this is lame of me to be carrying around a string instead of undef
|
|
@{$self->{sorted}} =
|
|
sort {
|
|
if ($a->[4] eq "NaN" || $b->[4] eq "NaN") {
|
|
return $a->[4] cmp $b->[4];
|
|
} else {
|
|
return $a->[4] <=> $b->[4];
|
|
}
|
|
} @{$self->{results}};
|
|
}
|
|
|
|
sub as_string {
|
|
my $self = shift;
|
|
return $self->_as_string();
|
|
}
|
|
|
|
sub as_string_sorted {
|
|
my $self = shift;
|
|
return $self->_as_string(@{$self->{sorted}});
|
|
}
|
|
|
|
|
|
sub _as_string {
|
|
my $self = shift;
|
|
my @ary = @_ ? @_ : @{$self->{results}};
|
|
my $str;
|
|
for (@ary) {
|
|
my ($index, $path, $count, $avg, $med, $max, $min, @times) = @$_;
|
|
$str .= sprintf "%3s %-26s\t", $index, $path;
|
|
if ($count > 0) {
|
|
$str .= sprintf "%6s %6s %6s %6s ", $avg, $med, $max, $min;
|
|
foreach my $time (@times) {
|
|
$str .= sprintf "%6s ", $time;
|
|
}
|
|
}
|
|
$str .= "\n";
|
|
}
|
|
return $str;
|
|
}
|
|
|
|
#
|
|
# package internal helper functions
|
|
#
|
|
sub _num {
|
|
my @array = ();
|
|
for (@_) { push @array, $_ if /^[+-]?\d+\.?\d*$/o; }
|
|
return @array;
|
|
}
|
|
|
|
sub _avg {
|
|
my @array = _num(@_);
|
|
return "NaN" unless scalar(@array);
|
|
my $sum = 0;
|
|
for (@array) { $sum += $_; }
|
|
return $sum/scalar(@array);
|
|
}
|
|
|
|
sub _max {
|
|
my @array = _num(@_);
|
|
return "NaN" unless scalar(@array);
|
|
my $max = $array[0];
|
|
for (@array) { $max = ($max > $_) ? $max : $_; }
|
|
return $max;
|
|
}
|
|
|
|
sub _min {
|
|
my @array = _num(@_);
|
|
return "NaN" unless scalar(@array);
|
|
my $min = $array[0];
|
|
for (@array) { $min = ($min < $_) ? $min : $_; }
|
|
return $min;
|
|
}
|
|
|
|
# returns the floor(N/2) element of a sorted ascending array
|
|
sub _med {
|
|
my @array = _num(@_);
|
|
return "NaN" unless scalar(@array);
|
|
my $index = int((scalar(@array)-1)/2);
|
|
@array = sort {$a <=> $b} @array;
|
|
return $array[$index];
|
|
}
|
|
|
|
1; # return true
|
|
|
|
################################################################################
|
|
#
|
|
# [1] in looking at the test results, in almost all cases, the
|
|
# round-trip time measured by the server logic and the client logic
|
|
# would be almost the same value (which is what one would
|
|
# expect). However, on occasion, one of the them would be "out of
|
|
# whack", and inconsistent with the additional "layout" measure by the
|
|
# client.
|
|
#
|
|
# i.e., a set of numbers like these:
|
|
# c_part c_intvl s_intvl
|
|
# 800 1003 997
|
|
# 804 1007 1005
|
|
# 801 1001 1325 <--
|
|
# 803 1318 998 <--
|
|
# 799 1002 1007
|
|
# ...
|
|
#
|
|
# which looks like the server side would stall in doing the accept or
|
|
# in running the mod-perl handler (possibly a GC?). (The following
|
|
# c_intvl would then be out of whack by a matching amount on the next
|
|
# cycle).
|
|
#
|
|
# At any rate, since it was clear from comparing with the 'c_part'
|
|
# measure, which of the times was bogus, I just use an arbitrary error
|
|
# measure to determine when to toss out the "bad" value.
|
|
#
|