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