3 # This Source Code Form is subject to the terms of the Mozilla Public
4 # License, v. 2.0. If a copy of the MPL was not distributed with this
5 # file, You can obtain one at http://mozilla.org/MPL/2.0/.
9 use CGI
::Carp
qw(fatalsToBrowser);
10 use Time
::HiRes
qw(gettimeofday tv_interval);
11 use POSIX
qw(strftime);
14 # list of test pages, JS to insert, httpbase, filebase, etc.
17 use vars
qw(%params $req $cgi $dbh $pagedata
18 $gStartNow $gStartNowStr
19 $gResponseNow $gLogging);
21 $gStartNow = [gettimeofday]; # checkpoint the time
22 $gStartNowStr = strftime "%Y%m%d%H%M%S", localtime;
25 $req = new CGI::Request; # get the HTTP/CGI request
28 $pagedata = PageData->new;
33 #warn $params{index}, " ", $params{maxidx};
35 if (!defined($req->param('delay'))) {
36 # give the user a form to pick options (but note that going
37 # to "loader.pl?delay=1000" immediately starts the test run
40 elsif (!$req->param('id')) {
41 initialize(); # do redirect to start the cycle
43 elsif ($params{index} > $params{maxidx}) {
44 redirectToReport(); # the test is over; spit out a summary
45 markTestAsComplete(); # close the meta table entry
47 elsif (!isRequestStale()) {
48 outputPage(); # otherwise, keep dishing out pages
49 updateDataBase(); # client has the response; now write out stats to db
54 $dbh->disconnect() if $dbh; # not strictly required (ignored in some cases anyways)
56 #logMessage(sprintf("Page load server responded in %3d msec, total time %3d msec, pid: %d",
57 # 1000*tv_interval($gStartNow, $gResponseNow), 1000*tv_interval($gStartNow), $$))
58 # if $gResponseNow; # log only when a test page has been dished out
62 #######################################################################
65 print STDERR strftime("[%a %b %d %H:%M:%S %Y] ", localtime), @_, "\n"
71 my $limit = 30*60; # 30 minutes, although if we never stalled on mac I'd make it 3 minutes
72 my $ts = decodeHiResTime($params{s_ts});
73 my $delta = tv_interval($ts, $gStartNow);
74 return undef if $delta < $limit;
75 # otherwise, punt this request
76 print "Content-type: text/html\n\n";
78 <html><head><title>Page Loading Times Test</title></head><body>
79 <p><b>The timestamp on the request is too old to continue:<br>
80 s_ts=$params{s_ts} was $delta seconds ago. Limit is $limit seconds.</b></p>
83 return 1; # it's stale
91 # start the test by bouncing off of an echo page
92 my $script = $cgi->var("SCRIPT_NAME");
93 my $server = $cgi->var("SERVER_NAME");
94 my $proto = $ENV{SERVER_PORT
} == 443 ?
'https://' : 'http://';
95 my $me = $proto . $server . $script;
96 $script =~ /^(.*\/).*$/;
97 my $loc = "Location: ". $proto . $server . $1 . "echo.pl?";
98 for (qw(id index maxcyc delay replace nocache timeout)) {
99 $loc .= "$_=$params{$_}\&";
101 $loc .= "url=" . $me;
106 sub redirectToReport
{
107 # n.b., can also add '&sort=1' to get a time sorted list
108 my $proto = $ENV{SERVER_PORT
} == 443 ?
'https://' : 'http://';
109 my $loc = "Location: " . $proto . $cgi->var("SERVER_NAME");
110 $cgi->var("SCRIPT_NAME") =~ /^(.*\/).*$/;
111 $loc .= $1 . "report.pl?id=" . $params{id
};
112 # To use for a tinderbox, comment out the line above and uncomment this:
113 # $loc .= $1 . "dump.pl?id=" . $params{id} . "&purge=1";
119 # use the epoch time, in hex, plus a two-character random.
120 return sprintf "%8X%02X", time(), int(256*rand());
124 sub setDefaultParams
{
125 $params{id
} = $req->param('id') || generateTestId
(); # "unique" id for this run
126 $params{index} = $req->param('index') || 0; # request index for the test
127 $params{maxcyc
} = defined($req->param('maxcyc')) ?
128 $req->param('maxcyc') : 3; # max visits (zero-based count)
129 $params{delay
} = $req->param('delay') || 1000; # setTimeout on the next request (msec)
130 $params{replace
} = $req->param('replace') || 0; # use Location.replace (1) or Location.href (0)
131 $params{nocache
} = $req->param('nocache') || 0; # serve content via uncacheable path
132 $params{c_part
} = $req->param('c_part') || 0; # client time elapsed; page head to onload (msec)
133 $params{c_intvl
} = $req->param('c_intvl') || 0; # client time elapsed; onload to onload event (msec)
134 $params{c_ts
} = $req->param('c_ts') || 0; # client timestamp (.getTime()) (msec)
135 $params{content
} = $req->param('content') || "UNKNOWN"; # name of content page for this data
136 $params{s_ts
} = $req->param('s_ts') || undef; # server timestamp; no default
137 $params{timeout
} = $req->param('timeout') || 30000; # msec; timer will cancel stalled page loading
138 $params{maxidx
} = ($params{maxcyc
}+1) * $pagedata->length; # total pages loads to be done
139 $params{curidx
} = $params{index} % $pagedata->length; # current request index into page list
140 $params{curcyc
} = int(($params{index}-1) / $pagedata->length); # current "cycle" (visit)
145 my $relpath = $pagedata->url($params{curidx
});
146 my $file = $pagedata->filebase . $relpath;
147 open (HTML
, "<$file") ||
148 die "Can't open file: $file, $!";
150 my $hook = "<script xmlns='http://www.w3.org/1999/xhtml'>\n";
151 $hook .= "var g_moztest_Start = (new Date()).getTime();\n";
152 $hook .= "var g_moztest_ServerTime='" . encodeHiResTime
($gStartNow) . "';\n";
153 $hook .= "var g_moztest_Content='" . $pagedata->name($params{curidx
}) . "';\n";
154 $hook .= $pagedata->clientJS; # ... and the main body
155 $hook .= "var g_moztest_safetyTimer = ";
156 $hook .= "window.setTimeout(moztest_safetyValve, " . $params{timeout
} . ");";
157 $hook .= "</script>\n";
159 my $basepath = $pagedata->httpbase;
160 $basepath =~ s/^http:/https:/i
161 if $ENV{SERVER_PORT
} == 443;
162 #warn "basepath: $basepath";
163 $basepath =~ s
#^(.*?)(/base/)$#$1/nocache$2# if ($params{nocache});
164 $hook .= "<base href='". $basepath . $relpath .
165 "' xmlns='http://www.w3.org/1999/xhtml' />";
167 my $magic = $pagedata->magicString;
174 my $contentTypeHeader;
175 my $mimetype = $pagedata->mimetype($params{curidx
});
176 my $charset = $pagedata->charset($params{curidx
});
178 $contentTypeHeader = qq{Content
-type
: $mimetype; charset
="$charset"\n\n};
180 $contentTypeHeader = qq{Content
-type
: $mimetype\n\n};
182 #warn $contentTypeHeader; #XXXjrgm testing...
184 # N.B., these two cookie headers are obsolete, since I pass server info in
185 # JS now, to work around a bug in winEmbed with document.cookie. But
186 # since I _was_ sending two cookies as part of the test, I have to keep
187 # sending two cookies (at least for now, and it's not a bad thing to test)
188 #XXX other headers to test/use?
190 $gResponseNow = [gettimeofday
]; # for logging
191 { # turn on output autoflush, locally in this block
192 print "Set-Cookie: moztest_SomeRandomCookie1=somerandomstring\n";
193 print "Set-Cookie: moztest_SomeRandomCookie2=somerandomstring\n";
194 print $contentTypeHeader;
203 sub encodeHiResTime
{
205 return unless ref($timeref);
206 return $$timeref[0] . "-" . $$timeref[1];
210 sub decodeHiResTime
{
212 return [ split('-', $timestr) ];
216 sub elapsedMilliSeconds
{
217 my ($r_time, $timestr) = @_;
218 return "NaN" unless $timestr;
219 my $delta = tv_interval
( [ split('-', $timestr) ], $r_time );
220 my $delta = int(($delta*1000) - $params{delay
}); # adjust for delay (in msec)
226 connectToDataBase
(); # (may already be cached)
228 updateDataSetTable
() unless $params{c_part
} == -1; # the initial request
232 sub connectToDataBase
{
233 # don't reconnect if already connected. (Other drivers provide this
234 # for free I think, but not this one).
236 $dbh = DBI
->connect("DBI:CSV:f_dir=./db", {RaiseError
=> 1, AutoCommit
=> 1})
237 || die "Cannot connect: " . $DBI::errstr
;
243 # Holds the individual page load data for this id.
245 # (Of course, this should really be a single table for all datasets, but
246 # that was becoming punitively slow with DBD::CSV. I could have moved to
247 # a "real" database, but I didn't want to make that a requirement for
248 # installing this on another server and using this test (e.g., install a
249 # few modules and you can run this; no sql installation/maintenance required).
250 # At some point though, I may switch to some sql db, but hopefully still allow
251 # this to be used with a simple flat file db. (Hmm, maybe I should try a *dbm
252 # as a compromise (disk based but indexed)).
254 sub createDataSetTable
{
255 my $table = "t" . $params{id
};
256 return if -f
"db/$table"; # don't create it if it exists
257 logMessage
("createDataSetTable:\tdb/$table");
258 connectToDataBase
(); # cached
274 $sth = $dbh->prepare($sql);
282 # holds the information about all test runs
284 sub createMetaTable
{
286 return if -f
"db/$table"; # don't create it if it exists
287 logMessage
("createMetaTable:\tdb/$table");
299 CUR_CONTENT CHAR
(128),
307 REMOTE_USER CHAR
(16),
308 HTTP_USER_AGENT CHAR
(128),
309 REMOTE_ADDR CHAR
(15),
311 USER_COMMENT CHAR
(256)
314 $sth = $dbh->prepare($sql);
317 warn 'created meta table';
322 sub updateMetaTable
{
324 connectToDataBase
(); # if not already connected
326 my $table = "tMetaTable";
327 createMetaTable
($table); # just returns if already created
332 SELECT INDEX
, MAXCYC
, MAXIDX
, REPLACE
, NOCACHE
,
333 DELAY
, REMOTE_USER
, HTTP_USER_AGENT
, REMOTE_ADDR
335 WHERE ID
= '$params{id}'
337 $sth = $dbh->prepare($sql);
341 while (my @data = $sth->fetchrow_array()) {
342 push @dataset, {index => shift @data,
343 maxcyc
=> shift @data,
344 maxidx
=> shift @data,
345 replace
=> shift @data,
346 nocache
=> shift @data,
347 delay
=> shift @data,
348 remote_user
=> shift @data,
349 http_user_agent
=> shift @data,
350 remote_addr
=> shift @data
354 warn "More than one ID: $params{id} ??" if scalar(@dataset) > 1;
356 if (scalar(@dataset) == 0) {
357 # this is a new dataset and id
358 initMetaTableRecord
($table);
362 #XXX need to check that values are sane, and not update if they don't
363 # match certain params. This should not happen in a normal test run.
364 # However, if a test url was bookmarked or in history, I might get bogus
365 # data collected after the fact. But I have a stale date set on the URL,
366 # so that is good enough for now.
367 # my $ref = shift @dataset; # check some $ref->{foo}
377 WHERE ID
= '$params{id}'
379 $sth = $dbh->prepare($sql);
380 $sth->execute($gStartNowStr,
381 $params{index}-1, # (index-1) is complete; (index) in progress
382 ($params{curidx
}-1) % $pagedata->length,
392 sub markTestAsComplete
{
393 connectToDataBase
(); # if not already connected
394 my $table = "tMetaTable";
395 createMetaTable
($table); # just returns if already created
397 #XXX should probably check if this ID exists first
400 SET STATE
= "COMPLETE"
401 WHERE ID
= '$params{id}'
403 $sth = $dbh->prepare($sql);
409 sub initMetaTableRecord
{
410 # we know this record doesn't exist, so put in the initial values
441 $sth = $dbh->prepare($sql);
442 $sth->execute($gStartNowStr,
446 ($params{curidx
}-1) % $pagedata->length,
456 $cgi->var("REMOTE_USER"),
457 $cgi->var("HTTP_USER_AGENT"),
458 $cgi->var("REMOTE_ADDR"),
466 sub updateDataSetTable
{
468 my $table = "t" . $params{id
};
487 my $s_intvl = elapsedMilliSeconds
( $gStartNow, $params{s_ts
} );
489 $sth = $dbh->prepare($sql);
490 $sth->execute($gStartNowStr,
493 ($params{curidx
}-1) % $pagedata->length,
498 $req->param('content'),
506 my @prog = split('/', $0); my $prog = $prog[$#prog];
507 print "Content-type: text/html\n\n";
508 my $bgcolor = $ENV{SERVER_PORT
} == 443 ?
'#eebb66' : '#ffffff';
512 <title>Page Loading Times Test</title>
514 <body bgcolor="$bgcolor">
515 <h3>Page Loading Times Test</h3>
517 <p>Questions: <a href="mailto:jrgm\@netscape.com">John Morrison</a>
520 print " - ";
521 my $script = $cgi->var("SCRIPT_NAME");
522 my $server = $cgi->var("SERVER_NAME");
523 # pick the "other" protocol (i.e., test is inverted)
524 my $proto = $ENV{SERVER_PORT
} == 443 ?
'http://' : 'https://';
525 my $other = $proto . $server . $script;
526 if ($ENV{SERVER_PORT
} == 443) {
527 print "[ <a href='$other'>With no SSL</a> | <b>With SSL</b> ]<br>";
529 print "[ <b>With no SSL</b> | <a href='$other'>With SSL</a> ]<br>";
533 <form method="get" action="$prog" >
534 <table border="1" cellpadding="5" cellspacing="2">
537 Page-load to Page-load Delay (msec):<br>
541 <select name="delay">
543 <option value="500">500
544 <option selected value="1000">1000
545 <option value="2000">2000
546 <option value="3000">3000
547 <option value="4000">4000
548 <option value="5000">5000
554 Number of test cycles to run:<br>
558 <select name="maxcyc">
563 <option value="4" selected>5
571 How long to wait before cancelling (msec):<br>
572 (Don't change this unless on a very slow link, or very slow machine.)
575 <select name="timeout">
576 <option value="15000">15000
577 <option selected value="30000">30000
578 <option value="45000">45000
579 <option value="60000">60000
580 <option value="90000">90000
586 <input type="reset" value="reset">
589 <input type="submit" value="submit">
596 You can visit the content that will be loaded, minus the embedded
597 javascript, by clicking on any of the links below.
600 <table border="1" cellpadding="5" cellspacing="2">
605 my $base = $pagedata->httpbase;
606 $base =~ s/^http:/https:/i
607 if $ENV{SERVER_PORT
} == 443;
608 for ($i=0; $i<$pagedata->length; $i++) {
609 print "<td nowrap><a href='", $base, $pagedata->url($i), "'>";
610 print $pagedata->name($i);
612 print "</tr><tr>\n" if (($i+1)%4 == 0);
614 print "</tr>" if (($i+1)%4 != 0);
615 print "</table></form></body></html>\n";