6/tools/tools/tinderbox/www/index.cgi

   1 #!/usr/bin/perl -Tw
   2 #-
   3 # Copyright (c) 2003 Dag-Erling Coïdan Smørgrav
   4 # All rights reserved.
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions
   8 # are met:
   9 # 1. Redistributions of source code must retain the above copyright
  10 #    notice, this list of conditions and the following disclaimer
  11 #    in this position and unchanged.
  12 # 2. Redistributions in binary form must reproduce the above copyright
  13 #    notice, this list of conditions and the following disclaimer in the
  14 #    documentation and/or other materials provided with the distribution.
  15 # 3. The name of the author may not be used to endorse or promote products
  16 #    derived from this software without specific prior written permission.
  17 #
  18 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  19 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  20 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  21 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  22 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  23 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  27 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28 #
  29 # $FreeBSD$
  30 #
  31
  32 use 5.006_001;
  33 use strict;
  34 use POSIX qw(strftime);
  35
  36 my %CONFIGS;
  37 my %ARCHES;
  38
  39 my $DIR = ".";
  40
  41 sub success($) {
  42     my $log = shift;
  43
  44     local *FILE;
  45     if (open(FILE, "<", $log)) {
  46         while (<FILE>) {
  47             if (m/tinderbox run completed/) {
  48                 close(FILE);
  49                 return 1;
  50             }
  51         }
  52         close(FILE);
  53     }
  54     return undef;
  55 }
  56
  57 sub branch_sort($$) {
  58     my ($a, $b) = @_;
  59
  60     my @a = split('_', $a);
  61     my @b = split('_', $b);
  62     while (@a || @b) {
  63         ($a, $b) = (shift(@a), shift(@b));
  64         return 1 unless defined($a);
  65         return -1 unless defined($b);
  66         next if $a eq $b;
  67         if ($a =~ m/^\d+$/ && $b =~ m/^\d+$/) {
  68             return $a <=> $b;
  69         } else {
  70             return $a cmp $b;
  71         }
  72     }
  73     return 0;
  74 }
  75
  76 sub inverse_branch_sort($$) {
  77     my ($a, $b) = @_;
  78
  79     return branch_sort($b, $a);
  80 }
  81
  82 sub do_config($) {
  83     my $config = shift;
  84
  85     my %branches = %{$CONFIGS{$config}};
  86
  87     print "      <tr>
  88         <th>$config</th>
  89 ";
  90     foreach my $arch (sort(keys(%ARCHES))) {
  91         foreach my $machine (sort(keys(%{$ARCHES{$arch}}))) {
  92             if ($arch eq $machine) {
  93                 print "        <th>$arch</th>\n";
  94             } else {
  95                 print "        <th>$arch<br />$machine</th>\n";
  96             }
  97         }
  98     }
  99     print "      </tr>\n";
 100
 101     my $now = time();
 102
 103     foreach my $branch (sort(inverse_branch_sort keys(%branches))) {
 104         my $html =  "      <tr>
 105         <th>$branch</th>
 106 ";
 107         foreach my $arch (sort(keys(%ARCHES))) {
 108             foreach my $machine (sort(keys(%{$ARCHES{$arch}}))) {
 109                 my $log = "tinderbox-$config-$branch-$arch-$machine";
 110                 my $links = "";
 111                 if (-f "$DIR/$log.brief") {
 112                     my @stat = stat("$DIR/$log.brief");
 113                     my $class = success("$DIR/$log.brief") ? "ok" : "fail";
 114                     my $age = int(($now - $stat[9]) / 1800);
 115                     $age = 9
 116                         if ($age > 9);
 117                     $class .= "-$age";
 118                     $links .= "<span class='$class'>" .
 119                         strftime("%Y-%m-%d %H:%M&nbsp;UTC", gmtime($stat[9])) .
 120                         "</span><br />";
 121                     my $size = sprintf("[%.1f&nbsp;kB]", $stat[7] / 1024);
 122                     $links .= " <span class='tiny'>" .
 123                         "<a target='_top' href='$log.brief'>summary&nbsp;$size</a>" .
 124                         "</span><br />";
 125                 }
 126                 if (-f "$DIR/$log.full") {
 127                     my @stat = stat("$DIR/$log.full");
 128                     my $size = sprintf("[%.1f&nbsp;MB]", $stat[7] / 1048576);
 129                     $links .= " <span class='tiny'>" .
 130                         "<a target='_top' href='$log.full'>full&nbsp;log&nbsp;$size</a>" .
 131                         "</span><br />";
 132                 }
 133                 if ($links eq "") {
 134                     $html .= "        <td>n/a</td>\n";
 135                 } else {
 136                     $html .= "        <td>$links</td>\n";
 137                 }
 138             }
 139         }
 140         $html .= "      </tr>\n";
 141         print $html;
 142     }
 143 }
 144
 145 MAIN:{
 146     if ($ENV{'GATEWAY_INTERFACE'}) {
 147         $| = 1;
 148         print "Content-Type: text/html\n\n";
 149     } else {
 150         if ($0 =~ m|^(/[\w/._-]+)/[^/]+$|) {
 151             $DIR = $1;
 152         }
 153         open(STDOUT, ">", "$DIR/index.html")
 154             or die("index.html: $!\n");
 155     }
 156
 157     local *DIR;
 158     opendir(DIR, $DIR)
 159         or die("$DIR: $!\n");
 160     foreach (readdir(DIR)) {
 161         next unless m/^tinderbox-(\w+)-(\w+)-(\w+)-(\w+)\.(brief|full)$/;
 162         $CONFIGS{$1}->{$2} = $ARCHES{$3}->{$4} = 1;
 163     }
 164     closedir(DIR);
 165
 166     print "<?xml version='1.0' encoding='iso-8859-1'?>
 167 <!DOCTYPE html
 168      PUBLIC '-//W3C//DTD XHTML 1.0 Strict//EN'
 169      'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'>
 170 <html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en' lang='en'>
 171   <head>
 172     <title>FreeBSD tinderbox logs</title>
 173     <meta name='robots' content='nofollow' />
 174     <meta http-equiv='refresh' content='600' />
 175     <link rel='stylesheet' type='text/css' media='screen' href='tb.css' />
 176     <link rel='shortcut icon' type='image/png' href='daemon.png' />
 177   </head>
 178   <body>
 179     <!-- h1>FreeBSD tinderbox logs</h1 -->
 180
 181     <table border='1' cellpadding='3'>
 182 ";
 183     foreach my $config (sort(keys(%CONFIGS))) {
 184         next if $config =~ m/^update_/;
 185         do_config($config);
 186     }
 187     my $date = strftime("%Y-%m-%d %H:%M UTC", gmtime());
 188     print "
 189     </table>
 190     <!-- p class='update'>Last updated: $date</p -->
 191     <!-- p>
 192       <a target='_top' href='http://validator.w3.org/check/referer'><img
 193           src='valid-xhtml10.png'
 194           alt='Valid XHTML 1.0!' height='31' width='88' /></a>
 195       <a target='_top' href='http://jigsaw.w3.org/css-validator/check/referer'><img
 196           src='valid-css.png'
 197           alt='Valid CSS!' height='31' width='88' /></a>
 198     </p -->
 199   </body>
 200 </html>
 201 ";
 202     exit(0);
 203 }