#!/usr/bin/perl use warnings; use strict; use CGI; use CGI::Carp qw; use Fcntl qw<:DEFAULT :flock>; use Storable qw; use Digest::MD5 qw; use HTML::Template; use Algorithm::TokenBucket; use File::Find; use Time::Piece; use Time::Seconds; # All dates should be displayed as UTC (Time::Piece honours $*ENV). $ENV{TZ} = "UTC"; require_compression_modules(); use constant { VERSION => 0.4, MAX_SIZE => 2**20 * 3.0, # MiB limit BASEDIR => "/var/www/iblech/stuff/pugs-smokes/", SMARTLINKS => "/var/www/iblech/stuff/pugs-util/smartlinks.pl", BASEHTTPDIR => "/iblech/stuff/pugs-smokes/", PUGS_SVN => "http://svn.pugscode.org/pugs", PUGS_SPEC => "/var/www/iblech/stuff/pugs-smokes/spec", 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, }; $CGI::POST_MAX = MAX_SIZE; chdir BASEDIR or die "Couldn't chdir into \"@{[ BASEDIR ]}\": $!\n"; my $CGI = CGI->new; if($CGI->param("upload")) { process_upload(); } else { process_list(); } exit; sub process_upload { print "Content-Type: text/plain\n\n"; limit_rate(); validate_params(); add_smoke(); clean_obsolete_smokes(); print "ok"; } sub validate_params { 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(); unless($CGI->param("smoke") =~ /^param("yml")) { print "Warning: No .yml sent!\n"; } } sub uncompress_smoke { $CGI->param("smoke", Compress::Zlib::memGunzip($CGI->param("smoke")) || Compress::Bzip2::memBunzip($CGI->param("smoke")) || $CGI->param("smoke")); $CGI->param("yml", Compress::Zlib::memGunzip($CGI->param("yml")) || Compress::Bzip2::memBunzip($CGI->param("yml")) || $CGI->param("yml")) if $CGI->param("yml"); } 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 add_smoke { my $html = $CGI->param("smoke"); my $yml = $CGI->param("yml"); my $id = md5_hex $html; if(glob "pugs-smoke-*-$id.html") { print "The submitted smoke was already submitted!"; exit; } my %smoke; $html =~ /pugs_versnum: ([\d.]+)/ and $smoke{pugs_version} = $1; $html =~ /pugs_revision: (\d+)/ and $smoke{pugs_revision} = $1; $html =~ /osname: ([\w\d]+)/ and $smoke{osname} = $1; $html =~ /duration: ([\d.]+) *(m|h|)/ and do { my $sec; if ($2 eq 'm') { $sec = 60 * $1; } elsif ($2 eq 'h') { $sec = 3600 * $1; } else { $sec = $1; } $smoke{duration} = $sec; }; $html =~ /pugs-path: (.+)$/m and $smoke{runcore} = pugspath2runcore($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, }; my @req_fields = qw< pugs_version osname duration summary runcore >; if(my @missing_fields = grep { not $smoke{$_} } @req_fields) { print <", $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"; if($yml) { open my $fh, ">", $yml_filename or die "Couldn't open \"$yml_filename\" for writing: $!\n"; print $fh $yml or die "Couldn't write to \"$yml_filename\": $!\n"; close $fh or die "Couldn't close \"$yml_filename\": $!\n"; make_synopses($filename, $yml_filename); } } sub make_synopses { my ($html_file, $yml_file) = @_; my $syn_dir = synopsis_name($html_file); # the output directory mkdir $syn_dir; system(PUGS_SPEC . '/update') and warn "Couldn't update synopses"; my $rev = get_revision($html_file); my @t_files = make_old_tests($syn_dir, $rev); if(@t_files and system(SMARTLINKS, '--test-res', $yml_file, '--out-dir', $syn_dir, '--syn-dir', PUGS_SPEC, '--fast', @t_files) == 0) { make_synopsis_index($syn_dir); } else { warn "Couldn't run smartlinks"; rmdir $syn_dir; # may help some broken links } } sub get_revision { my $html_file = shift; my $metadata = unpack_smoke($html_file); return $$metadata{'pugs_revision'}; } sub make_old_tests { my ($syn_dir, $revision) = @_; unless($revision =~ m/^\d+$/) { warn "Strange revision number in .yml; can't checkout tests"; return (); } system('svn', 'co', '-q', '-r' => $revision, PUGS_SVN . '/t', "$syn_dir/t") == 0 or do { warn "Couldn't check out tests"; return (); }; my @t_files = (); my $wanted = sub { if(m/\.t$/) { push @t_files, $File::Find::name; } }; find($wanted, "$syn_dir/t"); return @t_files; } sub make_synopsis_index { my $syn_dir = shift; local $_; my %spec = qw( 01 Overview 02 Syntax 03 Operator 04 Block 05 Rule 06 Subroutine 09 Structure 10 Package 11 Module 12 Object 13 Overload 17 Concurrency 22 CPAN 26 Documentation 29 Functions ); open my $fh, '>', "$syn_dir/index.html"; print $fh "Synopses with Smoke Results\n"; print $fh "\n$syn_dir

\n"; foreach my $pod (map { (split /\//, $_, 2)[1] } glob "$syn_dir/S??.html") { my $chapter = ($pod =~ /S(\d\d)/)[0]; print $fh "$chapter $spec{$chapter}
\n"; } print $fh "\n"; } sub clean_obsolete_smokes { my $category = sub { return join "-", (map { $_[0]->{$_} } qw), $_[0]->{pugs_revision} == 0 ? "release" : "dev", }; # @smokes is an AoH, with the hashes looking like # { pugs_revision => ..., timestamp => ... } my %cats; my @smokes = map { unpack_smoke($_) } glob "pugs-smoke-*.html"; push @{ $cats{$category->($_)} }, $_ for @smokes; $cats{$_} = [ (sort { $b->{pugs_revision} <=> $a->{pugs_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}}; } foreach my $html_file (keys %delete) { unlink $html_file; my $yml_file = yml_name($html_file); unlink $yml_file if(-e $yml_file); my $syn_dir = synopsis_name($html_file); system('rm', '-rf', $syn_dir) if(-d $syn_dir); } } sub process_list { my $tmpl = HTML::Template->new(filehandle => *DATA, die_on_bad_params => 0); print "Content-Type: text/html\n\n"; #$tmpl->output(print_to => *STDOUT); my $category = sub { return sprintf "%s / %s", $_[0]->{pugs_revision} == 0 ? "release" : "repository snapshot", $_[0]->{osname}; }; my @smokes = map { unpack_smoke($_) } glob "pugs-smoke-*.html"; my %runcores; push @{ $runcores{$_->{runcore}}{$category->($_)} }, $_ for @smokes; foreach my $runcore (keys %runcores) { foreach my $cat (keys %{ $runcores{$runcore} }) { $runcores{$runcore}{$cat} = [ map {{ %$_, timestamp => $_->{timestamp}[1] }} sort { $b->{pugs_revision} <=> $a->{pugs_revision} || lc $a->{osname} cmp lc $b->{osname} || $b->{timestamp}[0] <=> $a->{timestamp}[0] } @{ $runcores{$runcore}{$cat} } ]; } $runcores{$runcore} = [ map {{ catname => $_, smokes => $runcores{$runcore}{$_}, }} sort { lc $a cmp lc $b } keys %{ $runcores{$runcore} } ]; } $tmpl->param(runcores => [ map {{ name => $_, categories => $runcores{$_}, }} sort keys %runcores ]); print $tmpl->output; } sub pack_smoke { my %smoke = @_; return sprintf "pugs-smoke-%s-r%d-%s-%s--%d-%d--%d-%d-%d-%d-%d-%d--%s.html", (map { $smoke{$_} } qw), (map { $smoke{summary}{$_} } qw), $smoke{id}; } sub yml_name { my $name = shift; $name =~ s/\.html$/.yml/; return $name; } sub synopsis_name { my $name = shift; $name =~ s/\.html$/-synopses/; return $name; } sub unpack_smoke { my $name = shift; $name =~ /^pugs-smoke-([\d.]+)-r(\d+)-([\w\d]+)-(\w+)--(\d+)-(\d+)--(\d+)-(\d+)-(\d+)-(\d+)-(\d+)-(\d+)--([a-f0-9]+).html$/ and return { pugs_version => $1, pugs_revision => $2, osname => $3, runcore => runcore2human($4), timestamp => [ $5, do { my $str = localtime($5)->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($6)->minutes) . " min", summary => [{ total => $7, ok => $8, failed => $9, todo => $10, skipped => $11, unexpect => $12, }], percentage => sprintf("%.02f", $8 / ($7||1) * 100), id => $13, filename => $name, link => BASEHTTPDIR . $name, synopsis_link => -e synopsis_name($name) ? BASEHTTPDIR . synopsis_name($name) : "", }; return (); } sub pugspath2runcore { local $_ = shift; /JSPERL5/i and return "jsperl5"; /PIL2JS/i and return "pil2js"; /PIL-RUN/i and return "pilrun"; /PIR/i and return "pir"; # v6.pm smoke: "pugs-path: perl" /^perl$/ and return "perl5"; return "normal"; } sub runcore2human { local $_ = shift; $_ eq "jsperl5"and return "JSPERL5 (Perl 6 on JavaScript with Perl 5)"; $_ eq "pil2js" and return "PIL2JS (Perl 6 on JavaScript)"; $_ eq "pilrun" and return "PIL-Run (Perl 6 on Perl 5)"; $_ eq "pir" and return "PIR (Perl 6 on Parrot)"; $_ eq "perl5" and return "v6.pm (Perl 6 on Perl 5)"; $_ eq "normal" and return "Normal runcore (Perl 6 on Haskell)"; die; } # 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; } __DATA__ Pugs Smoke Reports

Pugs Smoke Reports

Here's a list of recently submitted Pugs smoke reports. These smokes are automatically generated and show how much a given backend (normal Haskell runcore, Perl 6 on Perl 5, Perl 6 on JavaScript, ...) supports of Pugs's testsuite.

Submitting your own smoke is easy, 

$ make smoke
$ ./util/smokeserv/smokeserv-client.pl ./smoke.html

should suffice. See the pugs::hack manpage and smokeserv's README for details.

Note that old smoke reports are automatically deleted, so you may not want to link directly to a smoke.

(Timezone is UTC.
Also note that, depending on the backend, the ext/ tests may or may not be run, causing durations and the ok percentage to not be comparable.
The percentage of passed tests is calculated using the total number of tests run -- for example, if a backend only ran three tests, which it passed, this page would report 100 % test passes.)

Pugs  r  % ok : , , , , » » SYN
test cases:
ok, failed, todo,
skipped and unexpectedly succeeded
View full smoke report
View corresponding synopses