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