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;
  29 use warnings;
  30 use FindBin qw($RealBin);
  31
  32 use lib "$RealBin";
  33 use data qw(@compilers %hosts @hosts %trees @pseudo_trees $OLDAGE $DEADAGE);
  34 use util;
  35 use history;
  36 use POSIX;
  37 use Data::Dumper;
  38 use CGI qw/:standard/;
  39 use File::stat;
  40
  41 my $WEBDIR = "$RealBin";
  42 my $BASEDIR = "$WEBDIR/..";
  43
  44 my $db = new data("$BASEDIR/data");
  45
  46 my $req = new CGI;
  47
  48 # this is automatically filled in
  49 my (@deadhosts) = ();
  50
  51 ###############################################
  52 # URL so I can refer to myself in links
  53 my $myself = $req->url();
  54
  55 ####################################################################
  56 # setup for gzipped output of a web page if possible.
  57 # based on cvsweb.pl method
  58 # as a side effect this function adds the final line ot the HTTP headers
  59 sub cgi_gzip()
  60 {
  61     my $paths = ['/usr/bin/gzip', '/bin/gzip'];
  62     my $GZIPBIN;
  63     my $Browser = $ENV{'HTTP_USER_AGENT'} || "";
  64
  65 #  newer browsers accept gzip content encoding
  66 # and state this in a header
  67 # (netscape did always but didn't state it)
  68 # It has been reported that these
  69 #  braindamaged MS-Internet Exploders claim that they
  70 # accept gzip .. but don't in fact and
  71 # display garbage then :-/
  72 # Turn off gzip if running under mod_perl. piping does
  73 # not work as expected inside the server. One can probably
  74 # achieve the same result using Apache::GZIPFilter.
  75     my $maycompress = ((defined($ENV{'HTTP_ACCEPT_ENCODING'}) and $ENV{'HTTP_ACCEPT_ENCODING'} =~ m|gzip|
  76                         || $Browser =~ m%^Mozilla/3%)
  77                        && ($Browser !~ m/MSIE/)
  78                        && !defined($ENV{'MOD_PERL'}));
  79
  80     if (!$maycompress) { print "\r\n"; return; }
  81
  82     for my $p (@{$paths}) {
  83         if (stat($p)) { $GZIPBIN = $p; }
  84     }
  85
  86     my $fh = do {local(*FH);};
  87
  88     if (stat($GZIPBIN) && open($fh, "|$GZIPBIN -1 -c")) {
  89         print header(-content_type => "text/html", -content_encoding => "gzip", -vary => "Accept-Encoding");
  90         $| = 1; $| = 0; # Flush header output
  91         select ($fh);
  92     } else {
  93                 print header;
  94         }
  95 }
  96
  97 ################################################
  98 # start CGI headers
  99 sub cgi_headers() {
 100         cgi_gzip();
 101         print start_html(-title => 'samba.org build farm',
 102                     -script => {-language=> 'JAVASCRIPT', -src=>"/build_farm.js" },
 103                         -meta => {
 104                                 -keywords => "Samba SMB CIFS Build Farm",
 105                                 -description => "Home of the Samba Build Farm, the automated testing facility.",
 106                                 -robots => "noindex"
 107                         },
 108                         -lang => "en-us",
 109                         -head => [
 110                                 Link({-rel => "stylesheet",
 111                                           -href => "/build_farm.css",
 112                                           -type => "text/css",
 113                                           -media => "all"}),
 114                             Link({-rel => "stylesheet",
 115                                           -href => "http://master.samba.org/samba/style/common.css",
 116                                           -type => "text/css",
 117                                           -media => "all"}),
 118                             Link({-rel=>"shortcut icon",
 119                                           -href=>"http://www.samba.org/samba/images/favicon.ico"})
 120                           ]
 121                 );
 122
 123     print util::FileLoad("$WEBDIR/header2.html");
 124     print main_menu();
 125     print util::FileLoad("$WEBDIR/header3.html");
 126 }
 127
 128 ################################################
 129 # end CGI
 130 sub cgi_footers() {
 131         print util::FileLoad("$WEBDIR/footer.html");
 132         print $req->end_html;
 133 }
 134
 135 ################################################
 136 # print an error on fatal errors
 137 sub fatal($) {
 138     my $msg = shift;
 139
 140     print $req->h1("ERROR: $msg");
 141     cgi_footers();
 142     exit(0);
 143 }
 144
 145 ################################################
 146 # get a param from the request, after sanitizing it
 147 sub get_param($) {
 148     my $param = shift;
 149
 150     if (!defined $req->param($param)) {
 151                 return wantarray ? () : undef;
 152     }
 153
 154     my @result = ();
 155     if (wantarray) {
 156             @result = $req->param($param);
 157     } else {
 158             $result[0] = $req->param($param);
 159     }
 160
 161     for (my $i = 0; $i <= $#result; $i++) {
 162             $result[$i] =~ s/ /_/g;
 163     }
 164
 165     foreach (@result) {
 166             if ($_ =~ m/[^a-zA-Z0-9\-\_\.]/) {
 167                     fatal("Parameter $param is invalid");
 168                     return wantarray ? () : undef;
 169             }
 170     }
 171
 172     return wantarray ? @result : $result[0];
 173 }
 174
 175 sub build_link($$$$$)
 176 {
 177         my ($host, $tree, $compiler, $rev, $status) = @_;
 178
 179         return a({-href=>"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler" . ($rev?";revision=$rev":"")}, $status);
 180 }
 181
 182 sub build_status($$$$)
 183 {
 184         my ($host, $tree, $compiler, $rev) = @_;
 185         my $status = $db->build_status($host, $tree, $compiler, $rev);
 186
 187         return build_link($host, $tree, $compiler, $rev, $status);
 188 }
 189
 190
 191 #############################################
 192 # get the overall age of a host
 193 sub host_age($)
 194 {
 195         my $host = shift;
 196         my $ret = -1;
 197         for my $compiler (@compilers) {
 198                 for my $tree (keys %trees) {
 199                         my $age = $db->build_age_mtime($host, $tree, $compiler, "");
 200                         if ($age != -1 && ($age < $ret || $ret == -1)) {
 201                                 $ret = $age;
 202                         }
 203                 }
 204         }
 205         return $ret;
 206 }
 207
 208 #############################################
 209 # show an age as a string
 210 sub red_age($)
 211 {
 212         my $age = shift;
 213
 214         if ($age > $OLDAGE) {
 215                 return $req->span({-class=>"old"}, util::dhm_time($age));
 216         }
 217         return util::dhm_time($age);
 218 }
 219
 220 ##############################################
 221 # translate a status into a set of int representing status
 222 sub build_status_vals($) {
 223     my $status = util::strip_html(shift);
 224
 225     $status =~ s/ok/0/g;
 226     $status =~ s/\?/0/g;
 227     $status =~ s/PANIC/1/g;
 228
 229     return split m%/%, $status;
 230 }
 231
 232 ##############################################
 233 # view build summary
 234 sub view_summary($)
 235 {
 236     my $i = 0;
 237     my $cols = 2;
 238     my $broken = 0;
 239
 240     # either "text" or anything else.
 241     my $output_type = shift;
 242
 243     # set up counters
 244     my %broken_count;
 245     my %panic_count;
 246     my %host_count;
 247
 248     # zero broken and panic counters
 249     for my $tree (keys %trees) {
 250                 $broken_count{$tree} = 0;
 251                 $panic_count{$tree} = 0;
 252                 $host_count{$tree} = 0;
 253     }
 254
 255     # set up a variable to store the broken builds table's code, so we can output when we want
 256     my $broken_table = "";
 257     my $host_os;
 258     my $last_host = "";
 259
 260     # for the text report, include the current time
 261     if ($output_type eq 'text') {
 262             my $time = gmtime();
 263             print "Build status as of $time\n\n";
 264     }
 265
 266     for my $host (@hosts) {
 267             for my $compiler (@compilers) {
 268                     for my $tree (keys %trees) {
 269                             my $status = build_status($host, $tree, $compiler, "");
 270                             next if $status =~ /^Unknown Build/;
 271                             my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, "");
 272
 273                             if ($age_mtime != -1 && $age_mtime < $DEADAGE) {
 274                                     $host_count{$tree}++;
 275                             }
 276
 277                             if ($age_mtime < $DEADAGE && $status =~ /status failed/) {
 278                                     $broken_count{$tree}++;
 279                                     if ($status =~ /PANIC/) {
 280                                             $panic_count{$tree}++;
 281                                     }
 282                             }
 283                     }
 284             }
 285     }
 286
 287     if ($output_type eq 'text') {
 288             print "Build counts:\n";
 289             printf "%-12s %-6s %-6s %-6s\n", "Tree", "Total", "Broken", "Panic";
 290     } else {
 291             print $req->start_div({-id=>"build-counts", -class=>"build-section"});
 292                 print $req->h2('Build counts:');
 293                 print $req->start_table({-class => "real"}),
 294                           $req->thead(
 295                                   $req->Tr($req->th("Tree"), $req->th("Total"),
 296                                            $req->th("Broken"), $req->th("Panic"),
 297                                            $req->th("Test Coverage"))),
 298                       $req->start_tbody;
 299     }
 300
 301     for my $tree (sort keys %trees) {
 302             if ($output_type eq 'text') {
 303                     printf "%-12s %-6s %-6s %-6s\n", $tree, $host_count{$tree},
 304                             $broken_count{$tree}, $panic_count{$tree};
 305             } else {
 306                         print $req->start_Tr;
 307                         print $req->td(tree_link($tree));
 308                         print $req->td($host_count{$tree});
 309                         print $req->td($broken_count{$tree});
 310                     if ($panic_count{$tree}) {
 311                                 print $req->start_td({-class => "panic"});
 312                     } else {
 313                                 print $req->start_td;
 314                         }
 315                         print $panic_count{$tree} . $req->end_td;
 316                         print $req->td($db->lcov_status($tree));
 317                         print $req->end_Tr . "\n";
 318             }
 319     }
 320
 321     if ($output_type eq 'text') {
 322             print "\n";
 323     } else {
 324                 print $req->end_tbody, $req->end_table;
 325                 print $req->end_div;
 326     }
 327 }
 328
 329 ##############################################
 330 # return a link to a particular revision
 331 sub revision_link($$)
 332 {
 333         my ($revision, $tree) = @_;
 334
 335         $revision =~ s/^\s+//g;
 336         return "0" if ($revision eq "0");
 337
 338         return $req->a({
 339                         -href=>"$myself?function=diff;tree=$tree;revision=$revision",
 340                         -title=>"View Diff for $revision"
 341                 }, $revision);
 342 }
 343
 344 ###############################################
 345 # return a link to a particular tree
 346 sub tree_link($)
 347 {
 348         my ($tree) = @_;
 349
 350         return $req->a({-href=>"$myself?function=Recent+Builds;tree=$tree",
 351                                         -title=>"View recent builds for $tree"}, $tree);
 352 }
 353
 354 ##############################################
 355 # Draw the "recent builds" view
 356 sub view_recent_builds($$) {
 357         my ($tree, $sort_by) = @_;
 358     my $i = 0;
 359     my $cols = 2;
 360     my $broken = 0;
 361     my $host_os;
 362     my $last_host = "";
 363     my @all_builds = ();
 364
 365     my $sort = { revision => sub {
 366                         util::strip_html($$b[6]) <=> util::strip_html($$a[6])
 367                 },
 368                  age =>      sub { $$a[0] <=> $$b[0] },
 369                  host =>     sub { $$a[2] cmp $$b[2] },
 370                  platform => sub { $$a[1] cmp $$b[1] },
 371                  compiler => sub { $$a[3] cmp $$b[3] },
 372                  status =>   sub {
 373                          my (@bstat) = build_status_vals($$b[5]);
 374                          my (@astat) = build_status_vals($$a[5]);
 375
 376                          # handle panic
 377                          if (defined $bstat[4] && !defined $astat[4]) {
 378                                  return 1;
 379                          } elsif (!defined $bstat[4] && defined $astat[4]) {
 380                                  return -1;
 381                          }
 382                          return ($bstat[0] <=> $astat[0] || # configure
 383                                  $bstat[1] <=> $astat[1] || # compile
 384                                  $bstat[2] <=> $astat[2] || # install
 385                                  $bstat[3] <=> $astat[3]    # test
 386                                 );
 387                         }
 388         };
 389
 390     util::InArray($tree, [keys %trees]) || fatal("not a build tree");
 391     util::InArray($sort_by, [keys %$sort]) || fatal("not a valid sort");
 392
 393     for my $host (@hosts) {
 394       for my $compiler (@compilers) {
 395           my $status = build_status($host, $tree, $compiler, "");
 396           my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, "");
 397           my $age_ctime = $db->build_age_ctime($host, $tree, $compiler, "");
 398           my $revision = $db->build_revision($host, $tree, $compiler, "");
 399           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_link($revision, $tree)]
 400                 unless $age_mtime == -1 or $age_mtime >= $DEADAGE;
 401       }
 402     }
 403
 404     @all_builds = sort { $sort->{$sort_by}() || $sort->{age}() } @all_builds;
 405
 406     my $sorturl = "$myself?tree=$tree;function=Recent+Builds";
 407
 408         print $req->start_div({-id=>"recent-builds", -class=>"build-section"}),
 409                   $req->h2("Recent builds of $tree"),
 410                   $req->start_table({-class => "real"}),
 411               $req->thead(
 412                           $req->Tr(
 413                                   $req->th([
 414                                           $req->a({-href => "$sorturl;sortby=age",
 415                                                            -title => "Sort by build age"}, "Age"),
 416                                           $req->a({-href => "$sorturl;sortby=revision",
 417                                                                 -title => "Sort by build revision"},
 418                                                                     "Revision"),
 419                                           "Tree",
 420                                           $req->a({-href => "$sorturl;sortby=platform",
 421                                                            -title => "Sort by platform"}, "Platform"),
 422                                           $req->a({-href => "$sorturl;sortby=host",
 423                                                            -title => "Sort by host"}, "Host"),
 424                                           $req->a({-href=>"$sorturl;sortby=compiler",
 425                                                                 -title=>"Sort by compiler"}, "Compiler"),
 426                                           $req->a({-href=>"$sorturl;sortby=status",
 427                                                                 -title=>"Sort by build status"}, "Status")]
 428                                         )
 429                                 )),
 430                         $req->start_tbody;
 431
 432     for my $build (@all_builds) {
 433                 print $req->Tr(
 434                           $req->td([util::dhm_time($$build[0]), $$build[6], $$build[4],
 435                                         $$build[1], $$build[2], $$build[3], $$build[5]]));
 436         }
 437     print $req->end_tbody, $req->end_table;
 438         print $req->end_div;
 439 }
 440
 441 ##############################################
 442 # Draw the "dead hosts" table
 443 sub draw_dead_hosts {
 444     my $output_type = shift;
 445     my @deadhosts = @_;
 446
 447     # don't output anything if there are no dead hosts
 448     return if ($#deadhosts < 0);
 449
 450     # don't include in text report
 451         return if ($output_type eq 'text');
 452
 453         print $req->start_div({-class => "build-section", -id=>"dead-hosts"}),
 454                   $req->h2('Dead Hosts:'),
 455                   $req->start_table({-class => "real"}),
 456                   $req->thead($req->Tr($req->th(["Host", "OS", "Min Age"]))),
 457                   $req->start_tbody;
 458
 459     for my $host (@deadhosts) {
 460         my $age_ctime = host_age($host);
 461         print $req->tr($req->td([$host, $hosts{$host}, util::dhm_time($age_ctime)]));
 462     }
 463
 464         print $req->end_tbody, $req->end_table;
 465         print $req->end_div;
 466 }
 467
 468 ##############################################
 469 # show the available old revisions, if any
 470 sub show_oldrevs($$$)
 471 {
 472     my ($tree, $host, $compiler) = @_;
 473     my %revs = $db->get_old_revs($tree, $host, $compiler);
 474     my @revs = sort { $revs{$b} cmp $revs{$a} } keys %revs;
 475
 476     return if ($#revs < 1);
 477
 478     my $ret = $req->h2("Older builds:");
 479
 480     $ret .= $req->start_table({-class => "real"}).
 481               $req->thead($req->Tr($req->th(["Revision", "Status"]))).
 482               $req->start_tbody;
 483
 484     my $lastrev = "";
 485
 486     for my $rev (@revs) {
 487             my $s = $revs{$rev};
 488             $s =~ s/$rev/0/;
 489             next if ($s eq $lastrev);
 490             $lastrev = $s;
 491             $ret.=$req->Tr($req->td([revision_link($rev, $tree), build_link($host, $tree, $compiler, $rev, $revs{$rev})]));
 492     }
 493     if ($lastrev ne "") {
 494                 # Only print table if there was any actual data
 495         print $ret . $req->end_tbody, $req->end_table;
 496    }
 497 }
 498
 499 ##############################################
 500 # view one build in detail
 501 sub view_build($$$$) {
 502         my ($tree, $host, $compiler, $rev) = @_;
 503     # ensure the params are valid before using them
 504     util::InArray($host, [keys %hosts]) || fatal("unknown host");
 505     util::InArray($compiler, \@compilers) || fatal("unknown compiler");
 506     util::InArray($tree, [keys %trees]) || fatal("not a build tree");
 507
 508     my $uname="";
 509     my $cflags="";
 510     my $config="";
 511     my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, $rev);
 512     my $revision = $db->build_revision($host, $tree, $compiler, $rev);
 513     my $status = build_status($host, $tree, $compiler, $rev);
 514
 515     $rev = int($rev) if $rev;
 516
 517     my $log = $db->read_log($tree, $host, $compiler, $rev);
 518     my $err = $db->read_err($tree, $host, $compiler, $rev);
 519
 520     if ($log) {
 521                 $log = escapeHTML($log);
 522
 523                 if ($log =~ /(.*)/) { $uname=$1; }
 524                 if ($log =~ /CFLAGS=(.*)/) { $cflags=$1; }
 525                 if ($log =~ /configure options: (.*)/) { $config=$1; }
 526     }
 527
 528     if ($err) {
 529                 $err = escapeHTML($err);
 530     }
 531
 532     print $req->h2('Host information:');
 533
 534     print util::FileLoad("../web/$host.html");
 535
 536     print $req->table({-class=>"real"},
 537                 $req->Tr([
 538                         $req->td(["Host:", $req->a({-href=>"$myself?function=View+Host;host=$host;tree=$tree;compiler=$compiler#$host"}, $host)." - $hosts{$host}"]),
 539                         $req->td(["Uname:", $uname]),
 540                         $req->td(["Tree:", tree_link($tree)]),
 541                         $req->td(["Build Revision:", revision_link($revision, $tree)]),
 542                         $req->td(["Build age:", $req->div({-class=>"age"}, red_age($age_mtime))]),
 543                         $req->td(["Status:", $status]),
 544                         $req->td(["Compiler:", $compiler]),
 545                         $req->td(["CFLAGS:", $cflags]),
 546                         $req->td(["configure options:", $config])]));
 547
 548     show_oldrevs($tree, $host, $compiler);
 549
 550     # check the head of the output for our magic string
 551     my $plain_logs = (defined get_param("plain") &&
 552                       get_param("plain") =~ /^(yes|1|on|true|y)$/i);
 553     my $rev_var = "";
 554     if ($rev) {
 555             $rev_var = ";revision=$rev";
 556     }
 557
 558     print $req->start_div({-id=>"log"});
 559
 560     if (!$plain_logs) {
 561             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"));
 562
 563             print $req->start_div({-id=>"actionList"});
 564             # These can be pretty wide -- perhaps we need to
 565             # allow them to wrap in some way?
 566             if ($err eq "") {
 567                     print $req->h2("No error log available");
 568             } else {
 569                     print $req->h2("Error log:");
 570                     print make_collapsible_html('action', "Error Output", "\n$err", "stderr-0");
 571             }
 572
 573             if ($log eq "") {
 574                     print $req->h2("No build log available");
 575             } else {
 576                     print $req->h2("Build log:");
 577                     print_log_pretty($log);
 578             }
 579
 580             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."));
 581                 print $req->end_div;
 582     } else {
 583             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"));
 584             if ($err eq "") {
 585                     print $req->h2("No error log available");
 586             } else {
 587                     print $req->h2('Error log:');
 588                     print $req->div({-id=>"errorLog"}, $req->pre($err));
 589             }
 590             if ($log eq "") {
 591                     print $req->h2('No build log available');
 592             }
 593             else {
 594                     print $req->h2('Build log:');
 595                     print $req->div({-id=>"buildLog"}, $req->pre($log));
 596             }
 597     }
 598
 599         print $req->end_div;
 600 }
 601
 602 ##################################################
 603 # print the host's table of information
 604 sub view_host {
 605         my (@requested_hosts) = @_;
 606
 607         my $output_type = "html";
 608
 609         if ($output_type eq 'text') {
 610                 print "Host summary:\n";
 611         } else {
 612                 print $req->start_div({-class=>"build-section", -id=>"build-summary"});
 613                 print $req->h2('Host summary:');
 614         }
 615
 616         foreach (@requested_hosts) {
 617                 util::InArray($_, [keys %hosts]) || fatal("unknown host");
 618         }
 619
 620         for my $host (@requested_hosts) {
 621                 # make sure we have some data from it
 622                 unless($db->has_host($host)) {
 623                         if ($output_type ne 'text') {
 624                                 print $req->comment("skipping $host");
 625                         }
 626                         next;
 627                 }
 628
 629                 my $row = 0;
 630
 631                 for my $compiler (@compilers) {
 632                         for my $tree (sort keys %trees) {
 633                                 my $revision = $db->build_revision($host, $tree, $compiler, "");
 634                                 my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, "");
 635                                 my $age_ctime = $db->build_age_ctime($host, $tree, $compiler, "");
 636                                 my $warnings = $db->err_count($host, $tree, $compiler, "");
 637                                 if ($age_ctime != -1 && $age_ctime < $DEADAGE) {
 638                                         my $status = build_status($host, $tree, $compiler, "");
 639                                         if ($row == 0) {
 640                                                 if ($output_type eq 'text') {
 641                                                         printf "%-12s %-10s %-10s %-10s %-10s\n",
 642                                                                 "Tree", "Compiler", "Build Age", "Status", "Warnings";
 643
 644                                                 } else {
 645                                                         print $req->start_div({-class=>"host summary"}),
 646                                                               $req->a({-id=>$host, -name=>$host}),
 647                                                                   $req->h3("$host - $hosts{$host}"),
 648                                                                   $req->start_table({-class=>"real"}),
 649                                                               $req->thead($req->Tr(
 650                                                                   $req->th(["Target", "Build<br/>Revision", "Build<br />Age", "Status<br />config/build<br />install/test", "Warnings"]))),
 651                                                                   $req->start_tbody;
 652                                                 }
 653                                         }
 654
 655                                         if ($output_type eq 'text') {
 656                                                 printf "%-12s %-10s %-10s %-10s %-10s\n",
 657                                                         $tree, $compiler, util::dhm_time($age_mtime),
 658                                                                 util::strip_html($status), $warnings;
 659                                         } else {
 660                                                 print $req->Tr($req->td([$req->span({-class=>"tree"}, tree_link($tree))."/$compiler", revision_link($revision, $tree), $req->div({-class=>"age"}, red_age($age_mtime)), $req->div({-class=>"status"}, $status), $warnings]));
 661                                         }
 662                                         $row++;
 663                                 }
 664                         }
 665                 }
 666                 if ($row != 0) {
 667                         if ($output_type eq 'text') {
 668                                 print "\n";
 669                         } else {
 670                                 print $req->end_tbody, $req->end_table;
 671                                 print $req->end_div;
 672                         }
 673                 } else {
 674                         push(@deadhosts, $host);
 675                 }
 676         }
 677
 678         if ($output_type ne 'text') {
 679                 print $req->end_div;
 680         }
 681
 682         draw_dead_hosts($output_type, @deadhosts);
 683 }
 684
 685 ##############################################
 686 # prints the log in a visually appealing manner
 687 sub print_log_pretty() {
 688   my $log = shift;
 689
 690   # do some pretty printing for the actions
 691   my $id = 1;
 692   $log =~ s{ (
 693              Running\ action\s+([\w\-]+)
 694              .*?
 695              ACTION\ (PASSED|FAILED):\ ([\w\-]+)
 696              )
 697             }{ my $output = $1;
 698                my $actionName = $2;
 699                my $status = $3;
 700
 701                # handle pretty-printing of static-analysis tools
 702                if ($actionName eq 'cc_checker') {
 703                  $output = print_log_cc_checker($output);
 704                }
 705
 706                make_collapsible_html('action', $actionName, $output, $id++,
 707                                      $status)
 708        }exgs;
 709
 710   # $log is already CGI-escaped, so handle '>' in test name by handling &gt;
 711   $log =~ s{
 712               --==--==--==--==--==--==--==--==--==--==--.*?
 713               Running\ test\ ([\w\-=,_:\ /.&;]+).*?
 714               --==--==--==--==--==--==--==--==--==--==--
 715               (.*?)
 716               ==========================================.*?
 717               TEST\ (FAILED|PASSED|SKIPPED):.*?
 718               ==========================================\s+
 719              }{make_collapsible_html('test', $1, $2, $id++, $3)}exgs;
 720
 721   print $req->p($req->tt($req->pre($log)))."\n";
 722 }
 723
 724 ##############################################
 725 # generate pretty-printed html for static analysis tools
 726 sub print_log_cc_checker($) {
 727   my $input = shift;
 728   my $output = "";
 729
 730   # for now, we only handle the IBM Checker's output style
 731   if ($input !~ m/^BEAM_VERSION/ms) {
 732     return "here";
 733     return $input;
 734   }
 735
 736   my $content = "";
 737   my $inEntry = 0;
 738
 739   my ($entry, $title, $status, $id);
 740
 741   foreach (split /\n/, $input) {
 742
 743     # for each line, check if the line is a new entry,
 744     # otherwise, store the line under the current entry.
 745
 746     if (m/^-- /) {
 747       # got a new entry
 748       if ($inEntry) {
 749         $output .= make_collapsible_html('cc_checker', $title, $content,
 750                                          $id, $status);
 751       } else {
 752         $output .= $content;
 753       }
 754
 755       # clear maintenance vars
 756       ($inEntry, $content) = (1, "");
 757
 758       # parse the line
 759       m/^-- ((ERROR|WARNING|MISTAKE).*?)\s+&gt;&gt;&gt;([a-zA-Z0-9]+_(\w+)_[a-zA-Z0-9]+)/;
 760
 761       # then store the result
 762       ($title, $status, $id) = ("$1 $4", $2, $3);
 763     } elsif (m/^CC_CHECKER STATUS/) {
 764         if ($inEntry) {
 765           $output .= make_collapsible_html('cc_checker', $title, $content,
 766                                            $id, $status);
 767         }
 768
 769         $inEntry = 0;
 770         $content = "";
 771     }
 772
 773     # not a new entry, so part of the current entry's output
 774     $content .= "$_\n";
 775   }
 776   $output .= $content;
 777
 778   # This function does approximately the same as the following, following
 779   # commented-out regular expression except that the regex doesn't quite
 780   # handle IBM Checker's newlines quite right.
 781   #   $output =~ s{
 782   #                 --\ ((ERROR|WARNING|MISTAKE).*?)\s+
 783   #                        &gt;&gt;&gt;
 784   #                 (.*?)
 785   #                 \n{3,}
 786   #               }{make_collapsible_html('cc_checker', "$1 $4", $5, $3, $2)}exgs;
 787   return $output;
 788 }
 789
 790 ##############################################
 791 # generate html for a collapsible section
 792 sub make_collapsible_html
 793 {
 794   my $type = shift; # the logical type of it. e.g. "test" or "action"
 795   my $title = shift; # the title to be displayed
 796   my $output = shift;
 797   my $id = shift;
 798   my $status = (shift or "");
 799
 800   my $icon = (defined $status && ($status =~ /failed/i)) ? 'icon_hide_16.png' : 'icon_unhide_16.png';
 801
 802   # trim leading and trailing whitespace
 803   $output =~ s/^\s+//s;
 804   $output =~ s/\s+$//s;
 805
 806   # note that we may be inside a <pre>, so we don't put any extra whitespace in this html
 807   return $req->div({-class=>"$type unit \L$status\E",
 808                                   -id=>"$type-$id"},
 809                                           $req->a({-href=>"javascript:handle('$id');"},
 810                                                   $req->img({-id=>"img-$id", -name=>"img-$id",
 811                                                                     -alt=>$status,
 812                                                                         -src=>$icon}),
 813                                                   $req->div({-class => "$type title"}, $title),
 814                                           ) ." ".
 815                                           $req->div({-class=> "$type status \L$status\E"}, $status) .
 816                                           $req->div({-class => "$type output", -id=>"output-$id"}, $req->pre($output)));
 817 }
 818
 819 ##############################################
 820 # main page
 821 sub main_menu() {
 822     return $req->startform("GET"),
 823            $req->start_div({-id=>"build-menu"}),
 824            $req->popup_menu(-name=>'host',
 825                            -values=>\@hosts,
 826                            -labels=>\%hosts),
 827           $req->popup_menu("tree", [sort (keys %trees, @pseudo_trees)]),
 828           $req->popup_menu("compiler", \@compilers),
 829           $req->br(),
 830           $req->submit('function', 'View Build'),
 831           $req->submit('function', 'View Host'),
 832           $req->submit('function', 'Recent Checkins'),
 833           $req->submit('function', 'Summary'),
 834           $req->submit('function', 'Recent Builds'),
 835           $req->end_div,
 836           $req->endform() . "\n";
 837 }
 838
 839 ###############################################
 840 # display top of page
 841 sub page_top() {
 842     cgi_headers();
 843 }
 844
 845 ###############################################
 846 # main program
 847
 848 my $fn_name = get_param('function') || '';
 849
 850 if ($fn_name eq 'text_diff') {
 851   print header('application/x-diff');
 852   history::diff(get_param('author'),
 853                 get_param('date'),
 854                 get_param('tree'),
 855                 get_param('revision'),
 856                 "text");
 857 } elsif ($fn_name eq 'Text_Summary') {
 858         print header('text/plain');
 859         view_summary('text');
 860 } else {
 861   page_top();
 862
 863   if ($fn_name eq "View_Build") {
 864     view_build(get_param("tree"), get_param("host"), get_param("compiler"),
 865                        get_param('revision'));
 866   } elsif ($fn_name eq "View_Host") {
 867     view_host(get_param('host'));
 868   } elsif ($fn_name eq "Recent_Builds") {
 869     view_recent_builds(get_param("tree"), get_param("sortby") || "revision");
 870   } elsif ($fn_name eq "Recent_Checkins") {
 871     history::history(get_param('tree'));
 872   } elsif ($fn_name eq "diff") {
 873     history::diff(get_param('author'),
 874                   get_param('date'),
 875                   get_param('tree'),
 876                   get_param('revision'),
 877                   "html");
 878   } elsif (path_info() ne "" and path_info() ne "/") {
 879         my @paths = split('/', path_info());
 880         if ($paths[1] eq "recent") {
 881                 view_recent_builds($paths[2], get_param('sortby') || 'revision');
 882         } elsif ($paths[1] eq "host") {
 883                 view_host($paths[2]);
 884         }
 885   } else {
 886     view_summary('html');
 887   }
 888   cgi_footers();
 889 }