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