web/build.pl

   1 #!/usr/bin/perl -w
   2 # This CGI script presents the results of the build_farm build
   3 #
   4 # Copyright (C) Andrew Tridgell <tridge@samba.org>     2001-2005
   5 # Copyright (C) Andrew Bartlett <abartlet@samba.org>   2001
   6 # Copyright (C) Vance Lankhaar  <vance@samba.org>      2002-2005
   7 # Copyright (C) Martin Pool <mbp@samba.org>            2001
   8 #
   9 #   This program is free software; you can redistribute it and/or modify
  10 #   it under the terms of the GNU General Public License as published by
  11 #   the Free Software Foundation; either version 2 of the License, or
  12 #   (at your option) any later version.
  13 #
  14 #   This program is distributed in the hope that it will be useful,
  15 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 #   GNU General Public License for more details.
  18 #
  19 #   You should have received a copy of the GNU General Public License
  20 #   along with this program; if not, write to the Free Software
  21 #   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 # TODO: Allow filtering of the "Recent builds" list to show
  24 # e.g. only broken builds or only builds that you care about.
  25
  26
  27 use strict qw{vars};
  28 use FindBin qw($RealBin);
  29
  30 use lib "$RealBin";
  31 use util;
  32 use history;
  33 use POSIX;
  34 use Data::Dumper;
  35 use CGI;
  36 use File::stat;
  37
  38 my $WEBDIR = "$RealBin";
  39 my $BASEDIR = "$WEBDIR/..";
  40 my $CACHEDIR = "$WEBDIR/../cache";
  41
  42 my $req = new CGI;
  43
  44 my $HEADCOLOR = "#a0a0e0";
  45 my $OLDAGE = 60*60*4;
  46 my $DEADAGE = 60*60*24*4;
  47
  48 ##############################################
  49 # this defines what it is possible to build
  50 # and what boxes. Should be in a config file
  51 my @compilers = util::load_list("$WEBDIR/compilers.list");
  52 my (%hosts) = util::load_hash("$WEBDIR/hosts.list");
  53 my @hosts = sort { $hosts{$a} cmp $hosts{$b} } keys %hosts;
  54 my (%trees) = util::load_hash("$WEBDIR/trees.list");
  55 # these aren't really trees... they're just things we want in the menu.
  56 # (for recent checkins)
  57 my @pseudo_trees = util::load_list("$WEBDIR/pseudo.list");
  58
  59 # this is automatically filled in
  60 my (@deadhosts) = ();
  61
  62 ###############################################
  63 # work out a URL so I can refer to myself in links
  64 my $myself = $req->self_url;
  65 if ($myself =~ /(.*)[?].*/) {
  66     $myself = $1;
  67 }
  68 if ($myself =~ /http:\/\/.*\/(.*)/) {
  69     $myself = $1;
  70 }
  71
  72 # for now, hard code the self url - need to sanitize self_url
  73 $myself = "http://build.samba.org/";
  74
  75 my $cgi_headers_done = 0;
  76
  77 ################################################
  78 # start CGI headers
  79 sub cgi_headers() {
  80     if ($cgi_headers_done) {
  81         return;
  82     }
  83     $cgi_headers_done = 1;
  84
  85     print "Content-type: text/html\r\n";
  86     #print "Content-type: application/xhtml+xml\r\n";
  87
  88     util::cgi_gzip();
  89
  90     print util::FileLoad("$BASEDIR/web/header.html");
  91     print '<title>samba.org build farm</title>';
  92     print util::FileLoad("$BASEDIR/web/header2.html");
  93     main_menu();
  94     print util::FileLoad("$BASEDIR/web/header3.html");
  95 }
  96
  97 ################################################
  98 # start CGI headers for diffs
  99 sub cgi_headers_diff() {
 100     print "Content-type: application/x-diff\r\n";
 101     print "\n";
 102 }
 103
 104 ################################################
 105 # start CGI headers for text output
 106 sub cgi_headers_text() {
 107         print "Content-type: text/plain\r\n";
 108         print "\r\n";
 109 }
 110
 111 ################################################
 112 # end CGI
 113 sub cgi_footers() {
 114   print util::FileLoad("$BASEDIR/web/footer.html");
 115 }
 116
 117 ################################################
 118 # print an error on fatal errors
 119 sub fatal($) {
 120     my $msg=shift;
 121
 122     cgi_headers();
 123     print "<h1>ERROR: $msg</h1>\n";
 124     cgi_footers();
 125     exit(0);
 126 }
 127
 128 ################################################
 129 # get a param from the request, after sanitizing it
 130 sub get_param($) {
 131     my $param = shift;
 132
 133
 134     if (!defined $req->param($param)) {
 135         return wantarray ? () : undef;
 136     }
 137
 138     my @result = ();
 139     if (wantarray) {
 140             @result = $req->param($param);
 141     }
 142     else {
 143             $result[0] = $req->param($param);
 144     }
 145
 146     for (my $i = 0; $i <= $#result; $i++) {
 147             $result[$i] =~ s/ /_/g;
 148     }
 149
 150     foreach (@result) {
 151             if ($_ =~ m/[^a-zA-Z0-9\-\_\.]/) {
 152                     fatal("Parameter $param is invalid");
 153                     return wantarray ? () : undef;
 154             }
 155     }
 156
 157     return wantarray ? @result : $result[0];
 158 }
 159
 160 ################################
 161 # get the name of the build file
 162 sub build_fname($$$$)
 163 {
 164     my $tree=shift;
 165     my $host=shift;
 166     my $compiler=shift;
 167     my $rev=shift;
 168     if ($rev) {
 169             return "oldrevs/build.$tree.$host.$compiler-$rev";
 170     }
 171     return "build.$tree.$host.$compiler";
 172 }
 173
 174 ###########################################
 175 # get a list of old builds and their status
 176 sub get_old_revs($$$)
 177 {
 178     my $tree=shift;
 179     my $host=shift;
 180     my $compiler=shift;
 181     my @list = split('\n', `ls oldrevs/build.$tree.$host.$compiler-*.log`);
 182     my %ret;
 183     for my $l (@list) {
 184             if ($l =~ /-(\d+).log$/) {
 185                     my $rev = $1;
 186                     $ret{$rev} = build_status($host, $tree, $compiler, $rev);
 187             }
 188     }
 189
 190     return %ret;
 191 }
 192
 193 ##############################################
 194 # get the age of build from mtime
 195 sub build_age($$$$)
 196 {
 197     my $host=shift;
 198     my $tree=shift;
 199     my $compiler=shift;
 200     my $rev=shift;
 201     my $file=build_fname($tree, $host, $compiler, $rev);
 202     my $age = -1;
 203     my $st;
 204
 205     $st = stat("$file.log");
 206     if ($st) {
 207         $age = time() - $st->mtime;
 208     }
 209
 210     return $age;
 211 }
 212
 213 ##############################################
 214 # get the svn revision of build
 215 sub build_revision($$$$)
 216 {
 217     my $host=shift;
 218     my $tree=shift;
 219     my $compiler=shift;
 220     my $rev=shift;
 221     my $file=build_fname($tree, $host, $compiler, $rev);
 222     my $log;
 223     my $ret = 0;
 224
 225     if ($rev) {
 226             return $rev;
 227     }
 228
 229     my $st1 = stat("$file.log");
 230
 231     if (!$st1) {
 232             return $ret;
 233     }
 234     my $st2 = stat("$CACHEDIR/$file.revision");
 235
 236     if ($st1 && $st2 && $st1->mtime <= $st2->mtime) {
 237             return util::FileLoad("$CACHEDIR/$file.revision");
 238     }
 239
 240     $log = util::FileLoad("$file.log");
 241
 242     if ($log =~ /BUILD REVISION:(.*)/) {
 243         $ret = $1;
 244     }
 245
 246     util::FileSave("$CACHEDIR/$file.revision", "$ret");
 247
 248     return $ret;
 249 }
 250
 251 #############################################
 252 # get the overall age of a host
 253 sub host_age($)
 254 {
 255         my $host = shift;
 256         my $ret = -1;
 257         for my $compiler (@compilers) {
 258                 for my $tree (keys %trees) {
 259                         my $age = build_age($host, $tree, $compiler, "");
 260                         if ($age != -1 && ($age < $ret || $ret == -1)) {
 261                                 $ret = $age;
 262                         }
 263                 }
 264         }
 265         return $ret;
 266 }
 267
 268 #############################################
 269 # show an age as a string
 270 sub red_age($)
 271 {
 272         my $age = shift;
 273
 274         if ($age > $OLDAGE) {
 275                 return sprintf("<span class=\"old\">%s</span>",  util::dhm_time($age));
 276         }
 277         return util::dhm_time($age);
 278 }
 279
 280
 281 ##############################################
 282 # get status of build
 283 sub build_status($$$$)
 284 {
 285     my $host=shift;
 286     my $tree=shift;
 287     my $compiler=shift;
 288     my $rev=shift;
 289     my $file=build_fname($tree, $host, $compiler, $rev);
 290     my $cachefile="$CACHEDIR/" . $file . ".status";
 291     my ($cstatus, $bstatus, $istatus, $tstatus, $sstatus);
 292     $cstatus = $bstatus = $istatus = $tstatus = $sstatus =
 293       "<span class=\"status unknown\">?</span>";
 294
 295     my $log;
 296     my $ret;
 297
 298     my $st1 = stat("$file.log");
 299     if (!$st1) {
 300             return "Unknown Build";
 301     }
 302     my $st2 = stat("$cachefile");
 303
 304     if ($st1 && $st2 && $st1->mtime <= $st2->mtime) {
 305         return util::FileLoad($cachefile);
 306     }
 307
 308     $log = util::FileLoad("$file.log");
 309
 310     if ($log =~ /TEST STATUS:(.*)/) {
 311         if ($1 == 0) {
 312             $tstatus = "<span class=\"status passed\">ok</span>";
 313         } else {
 314             $tstatus = "<span class=\"status failed\">$1</span>";
 315         }
 316     }
 317
 318     if ($log =~ /INSTALL STATUS:(.*)/) {
 319         if ($1 == 0) {
 320             $istatus = "<span class=\"status passed\">ok</span>";
 321         } else {
 322             $istatus = "<span class=\"status failed\">$1</span>";
 323         }
 324     }
 325
 326     if ($log =~ /BUILD STATUS:(.*)/) {
 327         if ($1 == 0) {
 328             $bstatus = "<span class=\"status passed\">ok</span>";
 329         } else {
 330             $bstatus = "<span class=\"status failed\">$1</span>";
 331         }
 332     }
 333
 334     if ($log =~ /CONFIGURE STATUS:(.*)/) {
 335         if ($1 == 0) {
 336             $cstatus = "<span class=\"status passed\">ok</span>";
 337         } else {
 338             $cstatus = "<span class=\"status failed\">$1</span>";
 339         }
 340     }
 341
 342     if ($log =~ /(PANIC|INTERNAL ERROR):.*/ ) {
 343         $sstatus = "/<span class=\"status panic\">PANIC</span>";
 344     } else {
 345         $sstatus = "";
 346     }
 347
 348     if ($log =~ /CC_CHECKER STATUS: (.*)/ && $1 > 0) {
 349         $sstatus .= "/<span class=\"status checker\">$1</span>";
 350     }
 351
 352     $ret = "<a href=\"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler";
 353     if ($rev) {
 354             $ret .= ";revision=$rev";
 355     }
 356     $ret .= "\">$cstatus/$bstatus/$istatus/$tstatus$sstatus</a>";
 357
 358     util::FileSave("$CACHEDIR/$file.status", $ret);
 359
 360     return $ret;
 361 }
 362
 363 ##############################################
 364 # translate a status into a set of int representing status
 365 sub build_status_vals($) {
 366     my $status = strip_html(shift);
 367
 368     $status =~ s/ok/0/g;
 369     $status =~ s/\?/0/g;
 370     $status =~ s/PANIC/1/g;
 371
 372     return split m%/%, $status;
 373 }
 374 ##############################################
 375 # get status of build
 376 sub err_count($$$$)
 377 {
 378     my $host=shift;
 379     my $tree=shift;
 380     my $compiler=shift;
 381     my $rev=shift;
 382     my $file=build_fname($tree, $host, $compiler, $rev);
 383     my $err;
 384
 385     my $st1 = stat("$file.err");
 386     if ($st1) {
 387             return 0;
 388     }
 389     my $st2 = stat("$CACHEDIR/$file.errcount");
 390
 391     if ($st1 && $st2 && $st1->mtime <= $st2->mtime) {
 392             return util::FileLoad("$CACHEDIR/$file.errcount");
 393     }
 394
 395     $err = util::FileLoad("$file.err");
 396
 397     if (! $err) { return 0; }
 398
 399     my $ret = util::count_lines($err);
 400
 401     util::FileSave("$CACHEDIR/$file.errcount", "$ret");
 402
 403     return $ret;
 404 }
 405
 406
 407
 408 ##############################################
 409 # view build summary
 410 sub view_summary($) {
 411     my $i = 0;
 412     my $list = `ls *.log`;
 413     my $cols = 2;
 414     my $broken = 0;
 415
 416     # either "text" or anything else.
 417     my $output_type = shift;
 418
 419     # set up counters
 420     my %broken_count;
 421     my %panic_count;
 422     my %host_count;
 423
 424     # zero broken and panic counters
 425     for my $tree (keys %trees) {
 426         $broken_count{$tree} = 0;
 427         $panic_count{$tree} = 0;
 428         $host_count{$tree} = 0;
 429     }
 430
 431     #set up a variable to store the broken builds table's code, so we can output when we want
 432     my $broken_table = "";
 433     my $host_os;
 434     my $last_host = "";
 435
 436     # for the text report, include the current time
 437     if ($output_type eq 'text') {
 438             my $time = gmtime();
 439             print "Build status as of $time\n\n";
 440     }
 441
 442     for my $host (@hosts) {
 443             for my $compiler (@compilers) {
 444                     for my $tree (keys %trees) {
 445                             my $status = build_status($host, $tree, $compiler, "");
 446                             next if $status =~ /^Unknown Build/;
 447                             my $age = build_age($host, $tree, $compiler, "");
 448
 449                             if ($age != -1 && $age < $DEADAGE) {
 450                                     $host_count{$tree}++;
 451                             }
 452
 453                             if ($age < $DEADAGE && $status =~ /status failed/) {
 454                                     $broken_count{$tree}++;
 455                                     if ($status =~ /PANIC/) {
 456                                             $panic_count{$tree}++;
 457                                     }
 458                             }
 459                     }
 460             }
 461     }
 462
 463     if ($output_type eq 'text') {
 464             print "Build counts:\n";
 465             printf "%-12s %-6s %-6s %-6s\n", "Tree", "Total", "Broken", "Panic";
 466     }
 467     else {
 468             print <<EOHEADER;
 469 <div id="build-counts" class="build-section">
 470 <h2>Build counts:</h2>
 471 <table class="real">
 472   <thead>
 473     <tr>
 474       <th>Tree</th><th>Total</th><th>Broken</th><th>Panic</th>
 475     </tr>
 476   </thead>
 477   <tbody>
 478 EOHEADER
 479     }
 480
 481
 482     for my $tree (sort keys %trees) {
 483             if ($output_type eq 'text') {
 484                     printf "%-12s %-6s %-6s %-6s\n", $tree, $host_count{$tree},
 485                             $broken_count{$tree}, $panic_count{$tree};
 486             }
 487             else {
 488                     print "    <tr><td><a href=\"$myself?function=Recent+Builds;tree=$tree\" title=\"View recent builds for $tree\">$tree</a></td><td>$host_count{$tree}</td><td>$broken_count{$tree}</td>";
 489                     my $panic = "";
 490                     if ($panic_count{$tree}) {
 491                             $panic = " class=\"panic\"";
 492                     }
 493                     print "<td$panic>$panic_count{$tree}</td></tr>\n";
 494             }
 495     }
 496
 497     if ($output_type eq 'text') {
 498             print "\n";
 499     }
 500     else {
 501             print "  </tbody>\n</table></div>\n";
 502     }
 503 }
 504
 505 ##############################################
 506 # Draw the "recent builds" view
 507
 508 sub view_recent_builds() {
 509     my $i = 0;
 510
 511     my $cols = 2;
 512
 513     my $broken = 0;
 514
 515     my $host_os;
 516     my $last_host = "";
 517     my @all_builds = ();
 518
 519     my $sort = { revision => sub { $$b[6] <=> $$a[6] },
 520                  age =>      sub { $$a[0] <=> $$b[0] },
 521                  host =>     sub { $$a[2] cmp $$b[2] },
 522                  platform => sub { $$a[1] cmp $$b[1] },
 523                  compiler => sub { $$a[3] cmp $$b[3] },
 524                  status =>   sub {
 525                          my (@bstat) = build_status_vals($$b[5]);
 526                          my (@astat) = build_status_vals($$a[5]);
 527
 528                          # handle panic
 529                          if (defined $bstat[4] && !defined $astat[4]) {
 530                                  return 1;
 531                          }
 532                          elsif (!defined $bstat[4] && defined $astat[4]) {
 533                                  return -1;
 534                          }
 535                          return ($bstat[0] <=> $astat[0] || # configure
 536                                  $bstat[1] <=> $astat[1] || # compile
 537                                  $bstat[2] <=> $astat[2] || # install
 538                                  $bstat[3] <=> $astat[3]    # test
 539                                 );
 540                  }
 541                };
 542
 543     my $tree=get_param("tree");
 544     my $sort_by=get_param("sortby") || "revision"; # default to revision
 545
 546     util::InArray($tree, [keys %trees]) || fatal("not a build tree");
 547     util::InArray($sort_by, [keys %$sort]) || fatal("not a valid sort");
 548
 549     for my $host (@hosts) {
 550       for my $compiler (@compilers) {
 551           my $status = build_status($host, $tree, $compiler, "");
 552           my $age = build_age($host, $tree, $compiler, "");
 553           my $revision = build_revision($host, $tree, $compiler, "");
 554           push @all_builds, [$age, $hosts{$host}, "<a href=\"$myself?function=View+Host;host=$host;tree=$tree;compiler=$compiler#$host\">$host</a>", $compiler, $tree, $status, $revision]
 555                 unless $age == -1 or $age >= $DEADAGE;
 556       }
 557     }
 558
 559     @all_builds = sort { $sort->{$sort_by}() || $sort->{age}() } @all_builds;
 560
 561     my $sorturl = "$myself?tree=$tree;function=Recent+Builds";
 562
 563     print <<EOHEADER;
 564
 565     <div id="recent-builds" class="build-section">
 566     <h2>Recent builds of $tree</h2>
 567       <table class="real">
 568         <thead>
 569           <tr>
 570             <th><a href="$sorturl;sortby=age" title="Sort by build age">Age</a></th>
 571             <th><a href="$sorturl;sortby=revision" title="Sort by build revision">Revision</a></th>
 572             <th>Tree</th>
 573             <th><a href="$sorturl;sortby=platform" title="Sort by platform">Platform</a></th>
 574             <th><a href="$sorturl;sortby=host" title="Sort by host">Host</a></th>
 575             <th><a href="$sorturl;sortby=compiler" title="Sort by compiler">Compiler</a></th>
 576             <th><a href="$sorturl;sortby=status" title="Sort by build status">Status</a></th>
 577
 578           </tr>
 579         </thead>
 580         <tbody>
 581 EOHEADER
 582
 583     for my $build (@all_builds) {
 584         my $age = $$build[0];
 585         my $rev = $$build[6];
 586         print "    <tr><td>",
 587           join("</td><td>" , util::dhm_time($age),
 588                $rev, @$build[4, 1, 2, 3, 5]),
 589           "</td></tr>\n";
 590     }
 591     print "  </tbody>\n</table>\n</div>\n";
 592 }
 593
 594
 595 ##############################################
 596 # Draw the "dead hosts" table
 597 sub draw_dead_hosts {
 598     my $output_type = shift;
 599     my @deadhosts = @_;
 600
 601     # don't output anything if there are no dead hosts
 602     if ($#deadhosts < 0) {
 603       return;
 604     }
 605
 606     # don't include in text report
 607     if ($output_type eq 'text') {
 608             return;
 609     }
 610
 611         print <<EOHEADER;
 612 <div class="build-section" id="dead-hosts">
 613 <h2>Dead Hosts:</h2>
 614 <table class="real">
 615 <thead>
 616 <tr><th>Host</th><th>OS</th><th>Min Age</th></tr>
 617 </thead>
 618 <tbody>
 619 EOHEADER
 620
 621     for my $host (@deadhosts) {
 622         my $age = host_age($host);
 623         print "    <tr><td>$host</td><td>$hosts{$host}</td><td>", util::dhm_time($age), "</td></tr>";
 624     }
 625
 626
 627     print "  </tbody>\n</table>\n</div>\n";
 628 }
 629
 630 ##############################################
 631 # show the available old revisions, if any
 632 sub show_oldrevs($$$)
 633 {
 634     my $tree=shift;
 635     my $host=shift;
 636     my $compiler=shift;
 637     my %revs = get_old_revs($tree, $host, $compiler);
 638     my @revs = sort { $revs{$b} cmp $revs{$a} } keys %revs;
 639
 640     return if ($#revs < 1);
 641
 642     print "<h2>Older builds:</h2>\n";
 643
 644     print "
 645 <table class=\"real\">
 646 <tr><th>Revision</th><th>Status</th></tr>
 647 ";
 648
 649     my $lastrev = "";
 650
 651     for my $rev (@revs) {
 652             my $s = $revs{$rev};
 653             $s =~ s/$rev/0/;
 654             next if ($s eq $lastrev);
 655             $lastrev = $s;
 656             print "<tr><td>$rev</td><td>$revs{$rev}</td></tr>\n";
 657     }
 658     print "</table>\n";
 659 }
 660
 661 ##############################################
 662 # view one build in detail
 663 sub view_build() {
 664     my $tree=get_param("tree");
 665     my $host=get_param("host");
 666     my $compiler=get_param("compiler");
 667     my $rev=get_param('revision');
 668
 669     # ensure the params are valid before using them
 670     util::InArray($host, [keys %hosts]) || fatal("unknown host");
 671     util::InArray($compiler, \@compilers) || fatal("unknown compiler");
 672     util::InArray($tree, [keys %trees]) || fatal("not a build tree");
 673
 674     my $file=build_fname($tree, $host, $compiler, $rev);
 675     my $log;
 676     my $err;
 677     my $uname="";
 678     my $cflags="";
 679     my $config="";
 680     my $age = build_age($host, $tree, $compiler, $rev);
 681     my $revision = build_revision($host, $tree, $compiler, $rev);
 682     my $status = build_status($host, $tree, $compiler, $rev);
 683
 684     $rev = int($rev) if $rev;
 685
 686     $log = util::FileLoad("$file.log");
 687     $err = util::FileLoad("$file.err");
 688
 689     if ($log) {
 690         $log = util::cgi_escape($log);
 691
 692         if ($log =~ /(.*)/) { $uname=$1; }
 693         if ($log =~ /CFLAGS=(.*)/) { $cflags=$1; }
 694         if ($log =~ /configure options: (.*)/) { $config=$1; }
 695     }
 696
 697     if ($err) {
 698         $err = util::cgi_escape($err);
 699     }
 700
 701     print "<h2>Host information:</h2>\n";
 702
 703     print util::FileLoad("../web/$host.html");
 704
 705     print "
 706 <table class=\"real\">
 707 <tr><td>Host:</td><td><a href=\"$myself?function=View+Host;host=$host;tree=$tree;compiler=$compiler#$host\">$host</a> - $hosts{$host}</td></tr>
 708 <tr><td>Uname:</td><td>$uname</td></tr>
 709 <tr><td>Tree:</td><td>$tree</td></tr>
 710 <tr><td>Build Revision:</td><td>" . $revision . "</td></tr>
 711 <tr><td>Build age:</td><td class=\"age\">" . red_age($age) . "</td></tr>
 712 <tr><td>Status:</td><td>$status</td></tr>
 713 <tr><td>Compiler:</td><td>$compiler</td></tr>
 714 <tr><td>CFLAGS:</td><td>$cflags</td></tr>
 715 <tr><td>configure options:  </td><td>$config</td></tr>
 716 </table>
 717 ";
 718
 719     show_oldrevs($tree, $host, $compiler);
 720
 721
 722     # check the head of the output for our magic string
 723     my $plain_logs = (defined get_param("plain") &&
 724                       get_param("plain") =~ /^(yes|1|on|true|y)$/i);
 725     my $rev_var = "";
 726     if ($rev) {
 727             $rev_var = ";revision=$rev";
 728     }
 729
 730     print "<div id=\"log\">\n";
 731
 732     if (!$plain_logs) {
 733
 734             print "<p>Switch to the <a href=\"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler$rev_var;plain=true\" title=\"Switch to bland, non-javascript, unstyled view\">Plain View</a></p>";
 735
 736             print "<div id=\"actionList\">\n";
 737             # These can be pretty wide -- perhaps we need to
 738             # allow them to wrap in some way?
 739             if ($err eq "") {
 740                     print "<h2>No error log available</h2>\n";
 741             } else {
 742                     print "<h2>Error log:</h2>\n";
 743                     print make_collapsible_html('action', "Error Output", "\n$err", "stderr-0");
 744             }
 745
 746             if ($log eq "") {
 747                     print "<h2>No build log available</h2>\n";
 748             } else {
 749                     print "<h2>Build log:</h2>\n";
 750                     print_log_pretty($log);
 751             }
 752
 753             print "<p><small>Some of the above icons derived from the <a href=\"http://www.gnome.org\">Gnome Project</a>'s stock icons.</p>";
 754             print "</div>\n";
 755     }
 756     else {
 757             print "<p>Switch to the <a href=\"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler$rev_var\" title=\"Switch to colourful, javascript-enabled, styled view \">Enhanced View</a></p>";
 758             if ($err eq "") {
 759                     print "<h2>No error log available</h2>\n";
 760             } else {
 761                     print "<h2>Error log:</h2>\n";
 762                     print "<div id=\"errorLog\"><pre>" . join('', $err) . "</pre></div>\n";
 763             }
 764             if ($log eq "") {
 765                     print "<h2>No build log available</h2>n";
 766             }
 767             else {
 768                     print "<h2>Build log:</h2>\n";
 769                     print "<div id=\"buildLog\"><pre>" . join('', $log) . "</pre></div>\n";
 770             }
 771     }
 772
 773     print "</div>\n";
 774 }
 775
 776 ##################################################
 777 # print the host's table of information
 778 sub view_host() {
 779
 780         my $output_type = "html";
 781
 782         if ($output_type eq 'text') {
 783                 print "Host summary:\n";
 784         }
 785         else {
 786                 print "<div class=\"build-section\" id=\"build-summary\">\n";
 787                 print "<h2>Host summary:</h2>\n";
 788         }
 789
 790         my $list = `ls *.log`;
 791
 792         my (@requested_hosts) = get_param('host');
 793
 794         foreach (@requested_hosts) {
 795                 util::InArray($_, [keys %hosts]) || fatal("unknown host");
 796         }
 797
 798         for my $host (@requested_hosts) {
 799                 # make sure we have some data from it
 800                 if (! ($list =~ /$host/)) {
 801                         if ($output_type ne 'text') {
 802                                 print "<!-- skipping $host -->\n";
 803                         }
 804                         next;
 805                 }
 806
 807                 my $row = 0;
 808
 809                 for my $compiler (@compilers) {
 810                         for my $tree (sort keys %trees) {
 811                                 my $age = build_age($host, $tree, $compiler, "");
 812                                 my $warnings = err_count($host, $tree, $compiler, "");
 813                                 if ($age != -1 && $age < $DEADAGE) {
 814                                         my $status = build_status($host, $tree, $compiler, "");
 815                                         if ($row == 0) {
 816                                                 if ($output_type eq 'text') {
 817                                                         printf "%-12s %-10s %-10s %-10s %-10s\n",
 818                                                                 "Tree", "Compiler", "Build Age", "Status", "Warnings";
 819
 820                                                 }
 821                                                 else {
 822                                                         print <<EOHEADER;
 823 <div class="host summary">
 824   <a id="$host" name="$host" />
 825   <h3>$host - $hosts{$host}</h3>
 826   <table class="real">
 827     <thead>
 828       <tr>
 829         <th>Target</th><th>Build&nbsp;Age</th><th>Status<br />config/build<br />install/test</th><th>Warnings</th>
 830       </tr>
 831     </thead>
 832     <tbody>
 833 EOHEADER
 834                                                 }
 835                                         }
 836
 837                                         if ($output_type eq 'text') {
 838                                                 printf "%-12s %-10s %-10s %-10s %-10s\n",
 839                                                         $tree, $compiler, util::dhm_time($age),
 840                                                                 strip_html($status), $warnings;
 841                                         }
 842                                         else {
 843                                                 print "    <tr><td><span class=\"tree\">$tree</span>/$compiler</td><td class=\"age\">" . red_age($age) . "</td><td class=\"status\">$status</td><td>$warnings</td></tr>\n";
 844                                         }
 845                                         $row++;
 846                                 }
 847                         }
 848                 }
 849                 if ($row != 0) {
 850                         if ($output_type eq 'text') {
 851                                 print "\n";
 852                         }
 853                         else {
 854                                 print "  </tbody>\n</table></div>\n";
 855                         }
 856                 } else {
 857                         push(@deadhosts, $host);
 858                 }
 859         }
 860
 861
 862         if ($output_type ne 'text') {
 863                 print "</div>\n\n";
 864         }
 865
 866         draw_dead_hosts($output_type, @deadhosts);
 867
 868 }
 869
 870 ##############################################
 871 # prints the log in a visually appealing manner
 872 sub print_log_pretty() {
 873   my $log = shift;
 874
 875   # do some pretty printing for the actions
 876   my $id = 1;
 877   $log =~ s{ (
 878              Running\ action\s+([\w\-]+)
 879              .*?
 880              ACTION\ (PASSED|FAILED):\ ([\w\-]+)
 881              )
 882             }{ my $output = $1;
 883                my $actionName = $2;
 884                my $status = $3;
 885
 886                # handle pretty-printing of static-analysis tools
 887                if ($actionName eq 'cc_checker') {
 888                  $output = print_log_cc_checker($output);
 889                }
 890
 891                make_collapsible_html('action', $actionName, $output, $id++,
 892                                      $status)
 893        }exgs;
 894
 895   # $log is already CGI-escaped, so handle '>' in test name by handling &gt;
 896   $log =~ s{
 897               --==--==--==--==--==--==--==--==--==--==--.*?
 898               Running\ test\ ([\w\-=,_:\ /.&;]+)\ \(level\ (\d+)\ (\w+)\).*?
 899               --==--==--==--==--==--==--==--==--==--==--
 900               (.*?)
 901               ==========================================.*?
 902               TEST\ (FAILED|PASSED|SKIPPED):(\ \(status\ (\d+)\))?.*?
 903               ==========================================\s+
 904              }{make_collapsible_html('test', $1, $4, $id++, $5)}exgs;
 905
 906   print "<tt><pre>" .join('', $log) . "</pre></tt><p>\n";
 907 }
 908
 909 ##############################################
 910 # generate pretty-printed html for static analysis tools
 911 sub print_log_cc_checker($) {
 912   my $input = shift;
 913   my $output = "";
 914
 915   # for now, we only handle the IBM Checker's output style
 916   if ($input !~ m/^BEAM_VERSION/ms) {
 917     return "here";
 918     return $input;
 919   }
 920
 921   my $content = "";
 922   my $inEntry = 0;
 923
 924   my ($entry, $title, $status, $id);
 925
 926   foreach (split /\n/, $input) {
 927
 928     # for each line, check if the line is a new entry,
 929     # otherwise, store the line under the current entry.
 930
 931     if (m/^-- /) {
 932       # got a new entry
 933       if ($inEntry) {
 934         $output .= make_collapsible_html('cc_checker', $title, $content,
 935                                          $id, $status);
 936       } else {
 937         $output .= $content;
 938       }
 939
 940       # clear maintenance vars
 941       ($inEntry, $content) = (1, "");
 942
 943       # parse the line
 944       m/^-- ((ERROR|WARNING|MISTAKE).*?)\s+&gt;&gt;&gt;([a-zA-Z0-9]+_(\w+)_[a-zA-Z0-9]+)/;
 945
 946       # then store the result
 947       ($title, $status, $id) = ("$1 $4", $2, $3);
 948     } elsif (m/^CC_CHECKER STATUS/) {
 949         if ($inEntry) {
 950           $output .= make_collapsible_html('cc_checker', $title, $content,
 951                                            $id, $status);
 952         }
 953
 954         $inEntry = 0;
 955         $content = "";
 956     }
 957
 958     # not a new entry, so part of the current entry's output
 959     $content .= "$_\n";
 960   }
 961   $output .= $content;
 962
 963   # This function does approximately the same as the following, following
 964   # commented-out regular expression except that the regex doesn't quite
 965   # handle IBM Checker's newlines quite right.
 966   #   $output =~ s{
 967   #                 --\ ((ERROR|WARNING|MISTAKE).*?)\s+
 968   #                        &gt;&gt;&gt;
 969   #                 (.*?)
 970   #                 \n{3,}
 971   #               }{make_collapsible_html('cc_checker', "$1 $4", $5, $3, $2)}exgs;
 972   return $output;
 973 }
 974
 975 ##############################################
 976 # generate html for a collapsible section
 977 sub make_collapsible_html($$$$)
 978 {
 979   my $type = shift;   # the logical type of it. e.g. "test" or "action"
 980   my $title = shift;   # the title to be displayed
 981   my $output = shift;
 982   my $id = shift;
 983   my $status = (shift or "");
 984
 985   my $icon = (defined $status && ($status =~ /failed/i)) ? 'icon_hide_16.png' : 'icon_unhide_16.png';
 986
 987   # trim leading and trailing whitespace
 988   $output =~ s/^\s+//s;
 989   $output =~ s/\s+$//s;
 990
 991   # note that we may be inside a <pre>, so we don't put any extra whitespace in this html
 992   my $return = "<div class=\"$type unit \L$status\E\" id=\"$type-$id\">" .
 993                 "<a href=\"javascript:handle('$id');\">" .
 994                  "<img id=\"img-$id\" name=\"img-$id\" src=\"$icon\" /> " .
 995                   "<div class=\"$type title\">$title</div>" .
 996                 "</a> " .
 997                 "<div class=\"$type status \L$status\E\">$status</div>" .
 998                 "<div class=\"$type output\" id=\"output-$id\">" .
 999                  "<pre>$output</pre>" .
1000                 "</div>".
1001                "</div>";
1002
1003   return $return
1004 }
1005
1006 ##############################################
1007 # simple html markup stripper
1008 sub strip_html($) {
1009         my $string = shift;
1010
1011         # get rid of comments
1012         $string =~ s/<!\-\-(.*?)\-\->/$2/g;
1013
1014         # and remove tags.
1015         while ($string =~ s&<(\w+).*?>(.*?)</\1>&$2&) {
1016                 ;
1017         }
1018
1019         return $string;
1020 }
1021
1022
1023 ##############################################
1024 # main page
1025 sub main_menu() {
1026     print $req->startform("GET");
1027     print "<div id=\"build-menu\">\n";
1028     print $req->popup_menu(-name=>'host',
1029                            -values=>\@hosts,
1030                            -labels=>\%hosts) . "\n";
1031     print $req->popup_menu("tree", [sort (keys %trees, @pseudo_trees)]) . "\n";
1032     print $req->popup_menu("compiler", \@compilers) . "\n";
1033     print "<br />\n";
1034     print $req->submit('function', 'View Build') . "\n";
1035     print $req->submit('function', 'View Host') . "\n";
1036     print $req->submit('function', 'Recent Checkins') . "\n";
1037     print $req->submit('function', 'Summary') . "\n";
1038     print $req->submit('function', 'Recent Builds') . "\n";
1039     print "</div>\n";
1040     print $req->endform() . "\n";
1041 }
1042
1043
1044 ###############################################
1045 # display top of page
1046 sub page_top() {
1047     cgi_headers();
1048     chdir("$BASEDIR/data") || fatal("can't change to data directory");
1049 }
1050
1051
1052 ###############################################
1053 # main program
1054
1055 my $fn_name = get_param('function') || '';
1056
1057 if ($fn_name eq 'text_diff') {
1058   cgi_headers_diff();
1059   chdir("$BASEDIR/data") || fatal("can't change to data directory");
1060   history::diff(get_param('author'),
1061                 get_param('date'),
1062                 get_param('tree'),
1063                 get_param('revision'),
1064                 "text");
1065 }
1066 elsif ($fn_name eq 'Text_Summary') {
1067         cgi_headers_text();
1068         chdir("$BASEDIR/data") || fatal("can't change to data directory");
1069         view_summary('text');
1070 }
1071 else {
1072   page_top();
1073
1074   if    ($fn_name eq "View_Build") {
1075     view_build();
1076   }
1077   elsif ($fn_name eq "View_Host") {
1078     view_host();
1079   }
1080   elsif ($fn_name eq "Recent_Builds") {
1081     view_recent_builds();
1082   }
1083   elsif ($fn_name eq "Recent_Checkins") {
1084     history::history(get_param('tree'));
1085   }
1086   elsif ($fn_name eq "diff") {
1087     history::diff(get_param('author'),
1088                   get_param('date'),
1089                   get_param('tree'),
1090                   get_param('revision'),
1091                   "html");
1092   }
1093   else {
1094     view_summary('html');
1095   }
1096   cgi_footers();
1097 }
1098