Author: jkeenan Date: Wed Jan 23 20:02:30 2008 New Revision: 25183 Added: branches/smoke/tools/util/mysmoke.cgi (contents, props changed) Modified: branches/smoke/lib/Parrot/Smoke/Server.pm
Log: Add tools/util/mysmoke.cgi, which is a first pass at refactoring smokeserv-server.pl by pulling subroutines into lib/Parrot/Smoke/Server.pm. Very rough -- but at least now I know how to fix https://rt.perl.org/rt3/Ticket/Display.html?id=45307. Modified: branches/smoke/lib/Parrot/Smoke/Server.pm ============================================================================== --- branches/smoke/lib/Parrot/Smoke/Server.pm (original) +++ branches/smoke/lib/Parrot/Smoke/Server.pm Wed Jan 23 20:02:30 2008 @@ -10,76 +10,55 @@ =cut package Parrot::Smoke::Server; - use strict; use warnings; - -use base qw( Exporter ); -use Algorithm::TokenBucket; use CGI; -use CGI::Carp qw<fatalsToBrowser>; -use Digest::MD5 qw<md5_hex>; -use Fcntl qw<:DEFAULT :flock>; +use CGI::Carp qw(fatalsToBrowser); use HTML::Template; -use Storable qw<store_fd fd_retrieve freeze>; use Time::Piece; use Time::Seconds; -our @EXPORT = (); -our @EXPORT_OK = qw( - require_compression_modules - process_upload - process_list -); -our %EXPORT_TAGS = (); - -# BASEHTTPDIR => "/", used both in script and subs -# -use constant { - VERSION => 0.4, - BASEHTTPDIR => "/", - BUCKET => "bucket.dat", - MAX_RATE => 1 / 30, # Allow a new smoke all 30s - BURST => 5, # Set max burst to 5 - MAX_SMOKES_OF_SAME_CATEGORY => 5, -}; - -##### PUBLICLY AVAILABLE SUBROUTINES ##### - -sub require_compression_modules { - no strict 'refs'; - eval { require Compress::Zlib } - or *Compress::Zlib::memGunzip = sub { return }; - eval { require Compress::Bzip2 } - or *Compress::Bzip2::memBunzip = sub { return }; -} - -sub process_upload { - my $CGI = shift; +# use Data::Dumper; - print $CGI->header; - - limit_rate(); - validate_params($CGI); - add_smoke($CGI); - clean_obsolete_smokes(); - - print "ok"; +sub new { + my $class = shift; + my $servconfigref = shift; + my %data = %{ $servconfigref }; + # disable file uploads; module default was 0 (mouse, p 87) + $CGI::DISABLE_UPLOADS = $data{DISABLE_UPLOADS}; + + # limit size of a POSTing; module default was -1 (mouse, p 87) + $CGI::POST_MAX = $data{POST_MAX}; # 100 KB + + # output an HTTP header only once per CGI object (mouse, p 117) + $CGI::HEADERS_ONCE = $data{HEADERS_ONCE}; + + $CGI::POST_MAX = $data{MAX_SIZE}; + + chdir $data{BASEDIR} or die "Couldn't chdir into $data{BASEDIR}: $!"; + + $SIG{PIPE} = "IGNORE"; + $data{q} = new CGI; + + return bless \%data, $class; +} + +sub print_header { + my $self = shift; + print $self->{q}->header( -type => "text/html" ); } sub process_list { - my $CGI = shift; + my $self = shift; my $t = shift; my $tmpl = HTML::Template->new( scalarref => \$t, die_on_bad_params => 0 ); - - print $CGI->header; - my $category = sub { return sprintf "%s / %s runcore on %s-%s-%s", $_[0]->{DEVEL} eq "devel" ? "repository snapshot" : "release", runcore2human( $_[0]->{runcore} ), $_[0]->{cpuarch}, $_[0]->{osname}, $_[0]->{cc},; }; - my @smokes = map { unpack_smoke($_) } glob "parrot-smoke-*.html"; + my @smokes = map { $self->unpack_smoke($_) } glob "parrot-smoke-*.html"; + my %branches; push @{ $branches{ $_->{branch} }{ $category->($_) } }, $_ for @smokes; @@ -110,236 +89,80 @@ keys %branches ] ); - print $tmpl->output; -} - -##### INTERNAL SUBROUTINES ##### - -# Rate limiting -sub limit_rate { - - # Open the DB and lock it exclusively. See perldoc -q lock. - sysopen my $fh, BUCKET, O_RDWR | O_CREAT - or die "Couldn't open \"@{[ BUCKET ]}\": $!\n"; - flock $fh, LOCK_EX - or die "Couldn't flock \"@{[ BUCKET ]}\": $!\n"; - - my $data = eval { fd_retrieve $fh }; - $data ||= [ MAX_RATE, BURST ]; - my $bucket = Algorithm::TokenBucket->new(@$data); - - my $exit; - unless ( $bucket->conform(1) ) { - print "Rate limiting -- please wait a bit and try again, thanks."; - $exit++; - } - $bucket->count(1); - seek $fh, 0, 0 or die "Couldn't rewind \"@{[ BUCKET ]}\": $!\n"; - truncate $fh, 0 or die "Couldn't truncate \"@{[ BUCKET ]}\": $!\n"; - - store_fd [ $bucket->state ] => $fh - or die "Couldn't serialize bucket to \"@{[ BUCKET ]}\": $!\n"; - - exit if $exit; -} - -sub validate_params { - my $CGI = shift; - - if ( not $CGI->param("version") or $CGI->param("version") != VERSION ) { - print "Versions do not match!"; - exit; - } - - if ( not $CGI->param("smoke") ) { - print "No smoke given!"; - exit; - } - - uncompress_smoke($CGI); - unless ( $CGI->param("smoke") =~ /^<!DOCTYPE html/ ) { - print "The submitted smoke does not look like a smoke!"; - exit; - } -} - -sub uncompress_smoke { - my $CGI = shift; - $CGI->param( "smoke", - Compress::Zlib::memGunzip( $CGI->param("smoke") ) - || Compress::Bzip2::memBunzip( $CGI->param("smoke") ) - || $CGI->param("smoke") ); -} - -sub add_smoke { - my $CGI = shift; - my $html = $CGI->param("smoke"); - - my $id = md5_hex $html; - if ( glob "parrot-smoke-*-$id.html" ) { - print "The submitted smoke was already submitted!"; - exit; - } - - my %smoke; - $html =~ /revision: (\d+)/ and $smoke{revision} = $1; - $html =~ /duration: (\d+)/ and $smoke{duration} = $1; - $html =~ /VERSION: ([\d\.]+)/ and $smoke{VERSION} = $1; - $html =~ /branch: ([\w\-]+)/ and $smoke{branch} = $1; - $html =~ /cpuarch: ([\w\d]+)/ and $smoke{cpuarch} = $1; - $html =~ /osname: ([\w\d]+)/ and $smoke{osname} = $1; - $html =~ /cc: ([\w\d]+)/ and $smoke{cc} = $1; - $html =~ /DEVEL: -?(\w+)/ and $smoke{DEVEL} = $1; - $html =~ /harness_args: (.+)$/m and $smoke{harness_args} = $1; - $html =~ /build_dir: (.+)$/m and $smoke{build_dir} = $1; - $html =~ -/summary="(\d+) test cases: (\d+) ok, (\d+) failed, (\d+) todo, (\d+) skipped and (\d+) unexpectedly succeeded"/ - and $smoke{summary} = { - total => $1, - ok => $2, - failed => $3, - todo => $4, - skipped => $5, - unexpect => $6, - }; - - if ( grep { not $smoke{$_} } qw<harness_args revision> ) { - print "The submitted smoke has an invalid format!"; - exit; - } - - $smoke{runcore} = runcore_from_args( $smoke{harness_args} ); - $smoke{revision} ||= 0; - $smoke{timestamp} = time; - $smoke{id} = $id; - my $filename = pack_smoke(%smoke); - - open my $fh, ">", $filename - or die "Couldn't open \"$filename\" for writing: $!\n"; - print $fh $html - or die "Couldn't write to \"$filename\": $!\n"; - close $fh - or die "Couldn't close \"$filename\": $!\n"; -} - -sub runcore_from_args { - local $_ = shift; - - /\b-g\b/ and return "goto"; - /\b-j\b/ and return "jit"; - /\b-C\b/ and return "cgp"; - /\b-S\b/ and return "switch"; - /\b-f\b/ and return "fast"; - return "default"; -} - -sub pack_smoke { - my %smoke = @_; - - my $summary = join( "-", map { $smoke{summary}{$_} } - qw<total ok failed todo skipped unexpect> ); - my $args = unpack( "H*", $smoke{harness_args} ); - -# 1 2 3 4 5 6 7 8 9 10 ... - my $str = -"parrot-smoke-<VERSION>-<DEVEL>-r<revision>-<branch>--<cpuarch>-<osname>-<cc>-<runcore>--<timestamp>-<duration>--$summary--$args--<id>.html"; - - $str =~ s/<(.+?)>/$smoke{$1}/g; - - $str; -} - -sub clean_obsolete_smokes { - my $category = sub { - return join "-", ( map { $_[0]->{$_} } - qw<branch cpuarch osname cc runcore harness_args> ), - $_[0]->{DEVEL} eq "devel" ? "dev" : "release",; - }; - - my %cats; - my @smokes = map { unpack_smoke($_) } glob "parrot-smoke-*.html"; - push @{ $cats{ $category->($_) } }, $_ for @smokes; - - $cats{$_} = [ - ( - sort { $b->{revision} <=> $a->{revision} || $b->{timestamp}[0] <=> $a->{timestamp}[0] } - @{ $cats{$_} } - )[ 0 .. MAX_SMOKES_OF_SAME_CATEGORY- 1 ] - ] - for keys %cats; - - my %delete = map { $_->{filename} => 1 } @smokes; - for ( map { @$_ } values %cats ) { - next unless $_; - - delete $delete{ $_->{filename} }; - } - - unlink keys %delete; + print $tmpl->output; } sub unpack_smoke { + my $self = shift; my $name = shift; - /^parrot-smoke-([\d\.]+) # 1 VERSION - -(\w+) # 2 DEVEL - -r(\d+) # 3 revision - -([\w\-]+) # 4 branch - --([\w\d]+) # 5 cpuarch - -([\w\d]+) # 6 osname - -([\w\d]+) # 7 cc - -(\w+) # 8 runcore - --(\d+) # 9 timestamp - -(\d+) # 10 duration - --(\d+) # 11 total - -(\d+) # 12 ok - -(\d+) # 13 failed - -(\d+) # 14 todo - -(\d+) # 15 skipped - -(\d+) # 16 unexpected - --([a-f0-9]+) # 17 harness_args - --([a-f0-9]+) # 18 id - .html$/x - and return { - VERSION => $1, - DEVEL => $2, - revision => $3, - branch => $4, - cpuarch => $5, - osname => $6, - cc => $7, - runcore => $8, - timestamp => [ - $9, + my $unpackref = {}; + if ($name =~ / + ^parrot-smoke-([\d\.]+) # 1 VERSION + -(\w+) # 2 DEVEL + -r(\d+) # 3 revision + -([\w\-]+) # 4 branch + --([\w\d]+) # 5 cpuarch + -([\w\d]+) # 6 osname + -([\w\d]+) # 7 cc + -(\w+) # 8 runcore + --(\d+) # 9 timestamp + -(\d+) # 10 duration + --(\d+) # 11 total + -(\d+) # 12 ok + -(\d+) # 13 failed + -(\d+) # 14 todo + -(\d+) # 15 skipped + -(\d+) # 16 unexpected + --([a-f0-9]+) # 17 harness_args + --([a-f0-9]+) # 18 id + .html$/x) { + $unpackref = { + VERSION => $1, + DEVEL => $2, + revision => $3, + branch => $4, + cpuarch => $5, + osname => $6, + cc => $7, + runcore => $8, + }; + my ($timestamp, $duration, $total, $ok, $failed, $todo, $skipped, + $unexpected, $harness_args, $id) = + ($9, $10, $11, $12, $13, $14, $15, $16, $17, $18); + $unpackref->{timestamp} = [ + $timestamp, do { - my $str = localtime($9)->strftime("%d %b %Y %H:%M %a"); + my $str = gmtime($timestamp)->strftime("%d %b %Y %H:%M %a"); $str =~ s/ / /g; # hack, to make the timestamps not break so the # smoke reports look good even on 640x480 $str; }, - ], - duration => sprintf( "%.02f", - Time::Seconds->new($10)->minutes ) . " min", - summary => [ - { - total => $11, - ok => $12, - failed => $13, - todo => $14, - skipped => $15, - unexpect => $16, - } - ], - percentage => sprintf( "%.02f", $12 / ( $11 || 1 ) * 100 ), - harness_args => pack( "H*", $17 ), - id => $18, - filename => $name, - link => BASEHTTPDIR . $name, - }; - return (); + ]; + $unpackref->{duration} = sprintf( "%.02f", + Time::Seconds->new($duration)->minutes ) . " min"; + $unpackref->{summary} = [ { + total => $total, + ok => $ok, + failed => $failed, + todo => $todo, + skipped => $skipped, + unexpect => $unexpected, + } ]; # Why a hashref as sole element inside array is not clear, but + # we get a fatal HTML::Template error otherwise. + $unpackref->{percentage} = + sprintf( "%.02f", $ok / ( $total || 1 ) * 100 ); + $unpackref->{harness_args} = pack( "H*", $harness_args ); + $unpackref->{id} = $id; + $unpackref->{filename} = $name; + $unpackref->{link} = $self->{BASEHTTPDIR} . $name; + return $unpackref; + } else { + return (); + } } sub runcore2human { @@ -351,16 +174,8 @@ fast => "fast", default => "default", ); - - $runcore{ $_[0] }; + return $runcore{ $_[0] }; } 1; -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4: - Added: branches/smoke/tools/util/mysmoke.cgi ============================================================================== --- (empty file) +++ branches/smoke/tools/util/mysmoke.cgi Wed Jan 23 20:02:30 2008 @@ -0,0 +1,173 @@ +#!/usr/local/bin/perl +# $Id: Server.pm 24998 2008-01-19 15:19:31Z jkeenan $ + +use strict; +use warnings; +use lib qw( lib ); +use Parrot::Smoke::Server; + +my %servconfig = ( + VERSION => 0.4, + MAX_SIZE => 2**20 * 3.0, # MiB limit + BASEDIR => "/tmp/parrot_smokes/", + BASEHTTPDIR => "/", + BUCKET => "bucket.dat", + MAX_RATE => 1 / 30, # Allow a new smoke all 30s + BURST => 5, # Set max burst to 5 + MAX_SMOKES_OF_SAME_CATEGORY => 5, + DISABLE_UPLOADS => 1, + POST_MAX => 102400, + HEADERS_ONCE => 1, +); + +my $serv = Parrot::Smoke::Server->new( \%servconfig ); +$serv->print_header(); +my $t = do { local $/; <DATA> }; +$serv->process_list($t); + + +1; + +__DATA__ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" + "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd";> +<html xmlns="http://www.w3.org/1999/xhtml"; xml:lang="en"> +<head> + <title>Parrot Smoke Reports</title> + <meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> + + <style type="text/css"> + body { + background-color: white; + margin: 0; + + font-family: sans-serif; + line-height: 1.3em; + font-size: 95%; + } + + h1, h2 { + background-color: #313052; + color: white; + padding: 10px; + } + + th { text-align: left; } + .indent0 { padding-top: 30px; border-bottom: 2px solid #313052; } + .indent1 { padding-top: 10px; border-bottom: 1px solid #313052; } + .indent2 { padding-left: 40px; } + .indent3 { padding-left: 80px; padding-bottom: 10px; } + + p, dl, pre, table { margin: 15px; } + dt { font-weight: bold; } + dd+dt { margin-top: 1em; } + .leftsep { padding-left: 10px; } + .num { text-align: right; } + + .details { display: none; } + .expander { color: blue; cursor: pointer; } /* hack? */ + + .tests_ok { color: #050; } + .tests_failed { color: #500; } + .tests_todo { color: #030; } + .tests_skipped { color: #555; } + .tests_unexpect { color: #550; } + </style> + + <script type="text/javascript">//<![CDATA[[ + function toggle_visibility (id) { + var elem = document.getElementById("details_" + id), + expander = document.getElementById("expander_" + id); + if(elem.className == "details") { + elem.className = ""; /* hack? */ + expander.innerHTML = "«"; + } else { + elem.className = "details"; + expander.innerHTML = "»"; + } + } + //]]></script> + +</head> + +<body> + <h1>Parrot Smoke Reports</h1> + + <p> + Here's a list of recently submitted <a + href="http://www.parrotcode.org/";>Parrot</a> smoke reports. These smokes are + automatically generated and show how various runcores are functioning across + a variety of platforms. Individual languages targetting parrot (e.g. tcl), + are also available. + </p> + + <p> + Submitting your own smoke is easy, + </p> + + <pre class="indent2">$ make smoke +</pre> + + <p> + should suffice. To test the languages that are shipped with parrot, change + to the languages directory and issue the same command. + </p> + + <p> + Note that old smoke reports are automatically deleted, so you may not want + to link directly to a smoke. + </p> + + <p> + Note: Timezone is UTC.<br /> + </p> + + <table> + <tmpl_loop name=branches> + <tr><th colspan="11" class="indent0"><tmpl_var name=name></th></tr> + <tmpl_loop name=categories> + <tr><th colspan="12" class="indent1"><tmpl_var name=catname></th></tr> + <tmpl_loop name=smokes> + <tr> + <td class="indent2">Parrot <tmpl_var name=VERSION></td> + <td> + <tmpl_if name=revision> + r<tmpl_var name=revision> + </tmpl_if> + </td> + <td class="leftsep"><tmpl_var name=timestamp></td> + <td class="leftsep"><tmpl_var name=harness_args></td> + <td class="leftsep num"><tmpl_var name=duration></td> + <td class="leftsep num"><tmpl_var name=percentage> % ok</td> + <tmpl_loop name=summary> + <td class="leftsep num tests_total"><tmpl_var name=total>:</td> + <td class="num tests_ok"><tmpl_var name=ok>,</td> + <td class="num tests_failed"><tmpl_var name=failed>,</td> + <td class="num tests_todo"><tmpl_var name=todo>,</td> + <td class="num tests_skipped"><tmpl_var name=skipped>,</td> + <td class="num tests_unexpect"><tmpl_var name=unexpect></td> + </tmpl_loop> + <td><span title="Details" class="expander" onclick="toggle_visibility('<tmpl_var name=id>')" id="expander_<tmpl_var name=id>">»</span></td> + <td><a style="text-decoration: none" href="<tmpl_var name=link>" title="Full smoke report">»</a></td> + </tr> + <tr class="details" id="details_<tmpl_var name=id>"> + <td colspan="12" class="indent3"> + <tmpl_loop name=summary> + <span class="tests_total"><tmpl_var name=total> test cases</span>:<br /> + <span class="tests_ok"><tmpl_var name=ok> ok</span>, + <span class="tests_failed"><tmpl_var name=failed> failed</span>, + <span class="tests_todo"><tmpl_var name=todo> todo</span>,<br /> + <span class="tests_skipped"><tmpl_var name=skipped> skipped</span> and + <span class="tests_unexpect"><tmpl_var name=unexpect> unexpectedly succeeded</span> + </tmpl_loop><br /> + <a href="<tmpl_var name=link>" title="Full smoke report">View full smoke report</a> + </td> + </tr> + </tmpl_loop> + </tmpl_loop> + </tmpl_loop> + </table> +</body> +</html> +
