web/build.pl

   1 #!/usr/bin/perl -w
   2 # This CGI script presents the results of the build_farm build
   3 #
   4 # Copyright (C) Andrew Tridgell <tridge@samba.org>     2001-2005
   5 # Copyright (C) Andrew Bartlett <abartlet@samba.org>   2001
   6 # Copyright (C) Vance Lankhaar  <vance@samba.org>      2002-2005
   7 # Copyright (C) Martin Pool <mbp@samba.org>            2001
   8 #
   9 #   This program is free software; you can redistribute it and/or modify
  10 #   it under the terms of the GNU General Public License as published by
  11 #   the Free Software Foundation; either version 2 of the License, or
  12 #   (at your option) any later version.
  13 #
  14 #   This program is distributed in the hope that it will be useful,
  15 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 #   GNU General Public License for more details.
  18 #
  19 #   You should have received a copy of the GNU General Public License
  20 #   along with this program; if not, write to the Free Software
  21 #   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 # TODO: Allow filtering of the "Recent builds" list to show
  24 # e.g. only broken builds or only builds that you care about.
  25
  26
  27 use strict qw{vars};
  28 use FindBin qw($RealBin);
  29
  30 use lib "$RealBin";
  31 use util;
  32 use history;
  33 use POSIX;
  34 use Data::Dumper;
  35 use CGI;
  36 use File::stat;
  37
  38 my $WEBDIR = "$RealBin";
  39 my $BASEDIR = "$WEBDIR/..";
  40 my $CACHEDIR = "$WEBDIR/../cache";
  41
  42 my $req = new CGI;
  43
  44 my $HEADCOLOR = "#a0a0e0";
  45 my $OLDAGE = 60*60*4;
  46 my $DEADAGE = 60*60*24*4;
  47
  48 ##############################################
  49 # this defines what it is possible to build
  50 # and what boxes. Should be in a config file
  51 my @compilers = util::load_list("$WEBDIR/compilers.list");
  52 my (%hosts) = util::load_hash("$WEBDIR/hosts.list");
  53 my @hosts = sort { $hosts{$a} cmp $hosts{$b} } keys %hosts;
  54 my (%trees) = util::load_hash("$WEBDIR/trees.list");
  55 # these aren't really trees... they're just things we want in the menu.
  56 # (for recent checkins)
  57 my @pseudo_trees = util::load_list("$WEBDIR/pseudo.list");
  58
  59 # this is automatically filled in
  60 my (@deadhosts) = ();
  61
  62 ###############################################
  63 # work out a URL so I can refer to myself in links
  64 my $myself = $req->self_url;
  65 if ($myself =~ /(.*)[?].*/) {
  66     $myself = $1;
  67 }
  68 if ($myself =~ /http:\/\/.*\/(.*)/) {
  69     $myself = $1;
  70 }
  71
  72 #$myself = "http://build.samba.org/";
  73
  74 ################################################
  75 # start CGI headers
  76 sub cgi_headers() {
  77     print "Content-type: text/html\r\n";
  78     #print "Content-type: application/xhtml+xml\r\n";
  79
  80     util::cgi_gzip();
  81
  82     print util::FileLoad("$BASEDIR/web/header.html");
  83     print '<title>samba.org build farm</title>';
  84     print util::FileLoad("$BASEDIR/web/header2.html");
  85     main_menu();
  86     print util::FileLoad("$BASEDIR/web/header3.html");
  87 }
  88
  89 ################################################
  90 # start CGI headers for diffs
  91 sub cgi_headers_diff() {
  92     print "Content-type: application/x-diff\r\n";
  93     print "\n";
  94 }
  95
  96 ################################################
  97 # start CGI headers for text output
  98 sub cgi_headers_text() {
  99         print "Content-type: text/plain\r\n";
 100         print "\r\n";
 101 }
 102
 103 ################################################
 104 # end CGI
 105 sub cgi_footers() {
 106   print util::FileLoad("$BASEDIR/web/footer.html");
 107 }
 108
 109 ################################################
 110 # print an error on fatal errors
 111 sub fatal($) {
 112     my $msg=shift;
 113     print "<h1>ERROR: $msg</h1>\n";
 114     cgi_footers();
 115     exit(0);
 116 }
 117
 118 ################################
 119 # get the name of the build file
 120 sub build_fname($$$$)
 121 {
 122     my $tree=shift;
 123     my $host=shift;
 124     my $compiler=shift;
 125     my $rev=shift;
 126     if ($rev) {
 127             return "oldrevs/build.$tree.$host.$compiler-$rev";
 128     }
 129     return "build.$tree.$host.$compiler";
 130 }
 131
 132 ###########################################
 133 # get a list of old builds and their status
 134 sub get_old_revs($$$)
 135 {
 136     my $tree=shift;
 137     my $host=shift;
 138     my $compiler=shift;
 139     my @list = split('\n', `ls oldrevs/build.$tree.$host.$compiler-*.log`);
 140     my %ret;
 141     for my $l (@list) {
 142             if ($l =~ /-(\d+).log$/) {
 143                     my $rev = $1;
 144                     $ret{$rev} = build_status($host, $tree, $compiler, $rev);
 145             }
 146     }
 147
 148     return %ret;
 149 }
 150
 151 ##############################################
 152 # get the age of build from mtime
 153 sub build_age($$$$)
 154 {
 155     my $host=shift;
 156     my $tree=shift;
 157     my $compiler=shift;
 158     my $rev=shift;
 159     my $file=build_fname($tree, $host, $compiler, $rev);
 160     my $age = -1;
 161     my $st;
 162
 163     $st = stat("$file.log");
 164     if ($st) {
 165         $age = time() - $st->mtime;
 166     }
 167
 168     return $age;
 169 }
 170
 171 ##############################################
 172 # get the svn revision of build
 173 sub build_revision($$$$)
 174 {
 175     my $host=shift;
 176     my $tree=shift;
 177     my $compiler=shift;
 178     my $rev=shift;
 179     my $file=build_fname($tree, $host, $compiler, $rev);
 180     my $log;
 181     my $ret = 0;
 182
 183     if ($rev) {
 184             return $rev;
 185     }
 186
 187     my $st1 = stat("$file.log");
 188     my $st2 = stat("$CACHEDIR/$file.revision");
 189
 190     if ($st1 && $st2 && $st1->mtime <= $st2->mtime) {
 191             return util::FileLoad("$CACHEDIR/$file.revision");
 192     }
 193
 194     $log = util::FileLoad("$file.log");
 195
 196     if ($log =~ /BUILD REVISION:(.*)/) {
 197         $ret = $1;
 198     }
 199
 200     util::FileSave("$CACHEDIR/$file.revision", "$ret");
 201
 202     return $ret;
 203 }
 204
 205 #############################################
 206 # get the overall age of a host
 207 sub host_age($)
 208 {
 209         my $host = shift;
 210         my $ret = -1;
 211         for my $compiler (@compilers) {
 212                 for my $tree (keys %trees) {
 213                         my $age = build_age($host, $tree, $compiler, "");
 214                         if ($age != -1 && ($age < $ret || $ret == -1)) {
 215                                 $ret = $age;
 216                         }
 217                 }
 218         }
 219         return $ret;
 220 }
 221
 222 #############################################
 223 # show an age as a string
 224 sub red_age($)
 225 {
 226         my $age = shift;
 227
 228         if ($age > $OLDAGE) {
 229                 return sprintf("<span class=\"old\">%s</span>",  util::dhm_time($age));
 230         }
 231         return util::dhm_time($age);
 232 }
 233
 234
 235 ##############################################
 236 # get status of build
 237 sub build_status($$$$)
 238 {
 239     my $host=shift;
 240     my $tree=shift;
 241     my $compiler=shift;
 242     my $rev=shift;
 243     my $file=build_fname($tree, $host, $compiler, $rev);
 244     my $cachefile="$CACHEDIR/" . $file . ".status";
 245     my ($cstatus, $bstatus, $istatus, $tstatus, $sstatus);
 246     $cstatus = $bstatus = $istatus = $tstatus = $sstatus =
 247       "<span class=\"status unknown\">?</span>";
 248
 249     my $log;
 250     my $ret;
 251
 252     my $st1 = stat("$file.log");
 253     my $st2 = stat("$cachefile");
 254
 255     if ($st1 && $st2 && $st1->mtime <= $st2->mtime) {
 256         return util::FileLoad($cachefile);
 257     }
 258
 259     $log = util::FileLoad("$file.log");
 260
 261     if ($log =~ /TEST STATUS:(.*)/) {
 262         if ($1 == 0) {
 263             $tstatus = "<span class=\"status passed\">ok</span>";
 264         } else {
 265             $tstatus = "<span class=\"status failed\">$1</span>";
 266         }
 267     }
 268
 269     if ($log =~ /INSTALL STATUS:(.*)/) {
 270         if ($1 == 0) {
 271             $istatus = "<span class=\"status passed\">ok</span>";
 272         } else {
 273             $istatus = "<span class=\"status failed\">$1</span>";
 274         }
 275     }
 276
 277     if ($log =~ /BUILD STATUS:(.*)/) {
 278         if ($1 == 0) {
 279             $bstatus = "<span class=\"status passed\">ok</span>";
 280         } else {
 281             $bstatus = "<span class=\"status failed\">$1</span>";
 282         }
 283     }
 284
 285     if ($log =~ /CONFIGURE STATUS:(.*)/) {
 286         if ($1 == 0) {
 287             $cstatus = "<span class=\"status passed\">ok</span>";
 288         } else {
 289             $cstatus = "<span class=\"status failed\">$1</span>";
 290         }
 291     }
 292
 293     if ($log =~ /INTERNAL ERROR:(.*)/ || $log =~ /PANIC:(.*)/) {
 294         $sstatus = "/<span class=\"status panic\">PANIC</span>";
 295     } else {
 296         $sstatus = "";
 297     }
 298
 299     $ret = "<a href=\"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler";
 300     if ($rev) {
 301             $ret .= ";revision=$rev";
 302     }
 303     $ret .= "\">$cstatus/$bstatus/$istatus/$tstatus$sstatus</a>";
 304
 305     util::FileSave("$CACHEDIR/$file.status", $ret);
 306
 307     return $ret;
 308 }
 309
 310
 311 ##############################################
 312 # get status of build
 313 sub err_count($$$$)
 314 {
 315     my $host=shift;
 316     my $tree=shift;
 317     my $compiler=shift;
 318     my $rev=shift;
 319     my $file=build_fname($tree, $host, $compiler, $rev);
 320     my $err;
 321
 322     my $st1 = stat("$file.err");
 323     my $st2 = stat("$CACHEDIR/$file.errcount");
 324
 325     if ($st1 && $st2 && $st1->mtime <= $st2->mtime) {
 326             return util::FileLoad("$CACHEDIR/$file.errcount");
 327     }
 328
 329     $err = util::FileLoad("$file.err");
 330
 331     if (! $err) { return 0; }
 332
 333     my $ret = util::count_lines($err);
 334
 335     util::FileSave("$CACHEDIR/$file.errcount", "$ret");
 336
 337     return $ret;
 338 }
 339
 340
 341
 342 ##############################################
 343 # view build summary
 344 sub view_summary($) {
 345     my $i = 0;
 346     my $list = `ls *.log`;
 347     my $cols = 2;
 348     my $broken = 0;
 349
 350     # either "text" or anything else.
 351     my $output_type = shift;
 352
 353     # set up counters
 354     my %broken_count;
 355     my %panic_count;
 356     my %host_count;
 357
 358     # zero broken and panic counters
 359     for my $tree (keys %trees) {
 360         $broken_count{$tree} = 0;
 361         $panic_count{$tree} = 0;
 362         $host_count{$tree} = 0;
 363     }
 364
 365     #set up a variable to store the broken builds table's code, so we can output when we want
 366     my $broken_table = "";
 367     my $host_os;
 368     my $last_host = "";
 369
 370     # for the text report, include the current time
 371     if ($output_type eq 'text') {
 372             my $time = gmtime();
 373             print "Build status as of $time\n\n";
 374     }
 375
 376     for my $host (@hosts) {
 377             for my $compiler (@compilers) {
 378                     for my $tree (keys %trees) {
 379                             my $status = build_status($host, $tree, $compiler, "");
 380                             my $age = build_age($host, $tree, $compiler, "");
 381
 382                             if ($age != -1 && $age < $DEADAGE) {
 383                                     $host_count{$tree}++;
 384                             }
 385
 386                             if ($age < $DEADAGE && $status =~ /status failed/) {
 387                                     $broken_count{$tree}++;
 388                                     if ($status =~ /PANIC/) {
 389                                             $panic_count{$tree}++;
 390                                     }
 391                             }
 392                     }
 393             }
 394     }
 395
 396     if ($output_type eq 'text') {
 397             print "Build counts:\n";
 398             printf "%-12s %-6s %-6s %-6s\n", "Tree", "Total", "Broken", "Panic";
 399     }
 400     else {
 401             print <<EOHEADER;
 402 <div id="build-counts" class="build-section">
 403 <h2>Build counts:</h2>
 404 <table class="real">
 405   <thead>
 406     <tr>
 407       <th>Tree</th><th>Total</th><th>Broken</th><th>Panic</th>
 408     </tr>
 409   </thead>
 410   <tbody>
 411 EOHEADER
 412     }
 413
 414
 415     for my $tree (sort keys %trees) {
 416             if ($output_type eq 'text') {
 417                     printf "%-12s %-6s %-6s %-6s\n", $tree, $host_count{$tree},
 418                             $broken_count{$tree}, $panic_count{$tree};
 419             }
 420             else {
 421                     print "    <tr><td>$tree</td><td>$host_count{$tree}</td><td>$broken_count{$tree}</td>";
 422                     my $panic = "";
 423                     if ($panic_count{$tree}) {
 424                             $panic = " class=\"panic\"";
 425                     }
 426                     print "<td$panic>$panic_count{$tree}</td></tr>\n";
 427             }
 428     }
 429
 430     if ($output_type eq 'text') {
 431             print "\n";
 432     }
 433     else {
 434             print "  </tbody>\n</table></div>\n";
 435     }
 436 }
 437
 438 ##############################################
 439 # Draw the "recent builds" view
 440
 441 sub view_recent_builds() {
 442     my $i = 0;
 443
 444     my $cols = 2;
 445
 446     my $broken = 0;
 447
 448     my $host_os;
 449     my $last_host = "";
 450     my @all_builds = ();
 451     my $tree=$req->param("tree");
 452
 453     # Convert from the DataDumper tree form to an array that
 454     # can be sorted by time.
 455
 456     util::InArray($tree, [keys %trees]) || fatal("not a build tree");
 457
 458     for my $host (@hosts) {
 459       for my $compiler (@compilers) {
 460           my $status = build_status($host, $tree, $compiler, "");
 461           my $age = build_age($host, $tree, $compiler, "");
 462           my $revision = build_revision($host, $tree, $compiler, "");
 463           push @all_builds, [$age, $hosts{$host}, "<a href=\"$myself?function=Summary;host=$host;tree=$tree;compiler=$compiler#$host\">$host</a>", $compiler, $tree, $status, $revision]
 464                 unless $age == -1 or $age >= $DEADAGE;
 465       }
 466   }
 467
 468   # sort by revision then age
 469   @all_builds = sort {$$b[6] <=> $$a[6] || $$a[0] <=> $$b[0]} @all_builds;
 470
 471
 472     print <<EOHEADER;
 473
 474     <div id="recent-builds" class="build-section">
 475     <h2>Recent builds of $tree</h2>
 476       <table class="real">
 477         <thead>
 478           <tr>
 479             <th>Age</th><th>Revision</th><th colspan="4">Target</th><th>Status</th>
 480           </tr>
 481         </thead>
 482         <tbody>
 483 EOHEADER
 484
 485
 486     for my $build (@all_builds) {
 487         my $age = $$build[0];
 488         my $rev = $$build[6];
 489         print "    <tr><td>",
 490           join("</td><td>" , util::dhm_time($age),
 491                $rev, @$build[4, 1, 2, 3, 5]),
 492           "</td></tr>\n";
 493     }
 494     print "  </tbody>\n</table>\n</div>\n";
 495 }
 496
 497
 498 ##############################################
 499 # Draw the "dead hosts" table
 500 sub draw_dead_hosts() {
 501     my $output_type = shift;
 502     my @deadhosts = @_;
 503
 504     # don't output anything if there are no dead hosts
 505     if ($#deadhosts < 1) {
 506       return;
 507     }
 508
 509     # don't include in text report
 510     if ($output_type eq 'text') {
 511             return;
 512     }
 513         print <<EOHEADER;
 514 <div class="build-section" id="dead-hosts">
 515 <h2>Dead Hosts:</h2>
 516 <table class="real">
 517 <thead>
 518 <tr><th>Host</th><th>OS</th><th>Min Age</th></tr>
 519 </thead>
 520 <tbody>
 521 EOHEADER
 522
 523     for my $host (@deadhosts) {
 524         my $age = host_age($host);
 525         print "    <tr><td>$host</td><td>$hosts{$host}</td><td>", util::dhm_time($age), "</td></tr>";
 526     }
 527
 528
 529     print "  </tbody>\n</table>\n</div>\n";
 530 }
 531
 532 ##############################################
 533 # show the available old revisions, if any
 534 sub show_oldrevs($$$)
 535 {
 536     my $tree=shift;
 537     my $host=shift;
 538     my $compiler=shift;
 539     my %revs = get_old_revs($tree, $host, $compiler);
 540     my @revs = sort { $revs{$b} cmp $revs{$a} } keys %revs;
 541
 542     return if ($#revs < 1);
 543
 544     print "<h2>Older builds:</h2>\n";
 545
 546     print "
 547 <table class=\"real\">
 548 <tr><th>Revision</th><th>Status</th></tr>
 549 ";
 550
 551     my $lastrev = "";
 552
 553     for my $rev (@revs) {
 554             my $s = $revs{$rev};
 555             $s =~ s/$rev/0/;
 556             next if ($s eq $lastrev);
 557             $lastrev = $s;
 558             print "<tr><td>$rev</td><td>$revs{$rev}</td></tr>\n";
 559     }
 560     print "</table>\n";
 561 }
 562
 563 ##############################################
 564 # view one build in detail
 565 sub view_build() {
 566     my $tree=$req->param("tree");
 567     my $host=$req->param("host");
 568     my $compiler=$req->param("compiler");
 569     my $rev=$req->param('revision');
 570     my $file=build_fname($tree, $host, $compiler, $rev);
 571     my $log;
 572     my $err;
 573     my $uname="";
 574     my $cflags="";
 575     my $config="";
 576     my $age = build_age($host, $tree, $compiler, $rev);
 577     my $revision = build_revision($host, $tree, $compiler, $rev);
 578     my $status = build_status($host, $tree, $compiler, $rev);
 579
 580     util::InArray($host, [keys %hosts]) || fatal("unknown host");
 581     util::InArray($compiler, \@compilers) || fatal("unknown compiler");
 582     util::InArray($tree, [keys %trees]) || fatal("not a build tree");
 583     $rev = int($rev);
 584
 585     $log = util::FileLoad("$file.log");
 586     $err = util::FileLoad("$file.err");
 587
 588     if ($log) {
 589         $log = util::cgi_escape($log);
 590
 591         if ($log =~ /(.*)/) { $uname=$1; }
 592         if ($log =~ /CFLAGS=(.*)/) { $cflags=$1; }
 593         if ($log =~ /configure options: (.*)/) { $config=$1; }
 594     }
 595
 596     if ($err) {
 597         $err = util::cgi_escape($err);
 598     }
 599
 600     print "<h2>Host information:</h2>\n";
 601
 602     print util::FileLoad("../web/$host.html");
 603
 604     print "
 605 <table class=\"real\">
 606 <tr><td>Host:</td><td><a href=\"$myself?function=Summary;host=$host;tree=$tree;compiler=$compiler#$host\">$host</a> - $hosts{$host}</td></tr>
 607 <tr><td>Uname:</td><td>$uname</td></tr>
 608 <tr><td>Tree:</td><td>$tree</td></tr>
 609 <tr><td>Build Revision:</td><td>" . $revision . "</td></tr>
 610 <tr><td>Build age:</td><td class=\"age\">" . red_age($age) . "</td></tr>
 611 <tr><td>Status:</td><td>$status</td></tr>
 612 <tr><td>Compiler:</td><td>$compiler</td></tr>
 613 <tr><td>CFLAGS:</td><td>$cflags</td></tr>
 614 <tr><td>configure options:  </td><td>$config</td></tr>
 615 </table>
 616 ";
 617
 618     show_oldrevs($tree, $host, $compiler);
 619
 620     # check the head of the output for our magic string
 621     my $plain_logs = (defined $req->param("plain") &&
 622                       $req->param("plain") =~ /^(yes|1|on|true|y)$/i);
 623
 624     print "<div id=\"log\">\n";
 625
 626     if (!$plain_logs) {
 627
 628             print "<p>Switch to the <a href=\"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler;plain=true\" title=\"Switch to bland, non-javascript, unstyled view\">Plain View</a></p>";
 629
 630             print "<div id=\"actionList\">\n";
 631             # These can be pretty wide -- perhaps we need to
 632             # allow them to wrap in some way?
 633             if ($err eq "") {
 634                     print "<h2>No error log available</h2>\n";
 635             } else {
 636                     print "<h2>Error log:</h2>\n";
 637                     print make_action_html("Error Output", "\n$err", "stderr-0", 0);
 638             }
 639
 640             if ($log eq "") {
 641                     print "<h2>No build log available</h2>\n";
 642             } else {
 643                     print "<h2>Build log:</h2>\n";
 644                     print_log_pretty($log);
 645             }
 646
 647             print "<p><small>Some of the above icons derived from the <a href=\"http://www.gnome.org\">Gnome Project</a>'s stock icons.</p>";
 648             print "</div>\n";
 649     }
 650     else {
 651             print "<p>Switch to the <a href=\"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler\" title=\"Switch to colourful, javascript-enabled, styled view \">Enhanced View</a></p>";
 652             if ($err eq "") {
 653                     print "<h2>No error log available</h2>\n";
 654             } else {
 655                     print "<h2>Error log:</h2>\n";
 656                     print "<div id=\"errorLog\"><pre>" . join('', $err) . "</pre></div>\n";
 657             }
 658             if ($log eq "") {
 659                     print "<h2>No build log available</h2>n";
 660             }
 661             else {
 662                     print "<h2>Build log:</h2>\n";
 663                     print "<div id=\"buildLog\"><pre>" . join('', $log) . "</pre></div>\n";
 664             }
 665     }
 666
 667     print "</div>\n";
 668 }
 669
 670 ##############################################
 671 # prints the log in a visually appealing manner
 672 sub print_log_pretty() {
 673   my $log = shift;
 674
 675
 676   # do some pretty printing for the actions
 677   my $id = 1;
 678   $log =~ s{   Running\ action\s+([\w\-]+)
 679                (.*?)
 680                ACTION\ (PASSED|FAILED):\ ([\w\-]+)
 681              }{make_action_html($1, $2, $id++, $3)}exgs;
 682
 683   $log =~ s{
 684               --==--==--==--==--==--==--==--==--==--==--.*?
 685               Running\ test\ ([\w\-=,_:\ ]+)\ \(level\ (\d+)\ (\w+)\).*?
 686               --==--==--==--==--==--==--==--==--==--==--
 687               (.*?)
 688               ==========================================.*?
 689               TEST\ (FAILED|PASSED|SKIPPED):(\ \(status\ (\d+)\))?.*?
 690               ==========================================\s+
 691              }{make_test_html($1, $4, $id++, $5)}exgs;
 692
 693
 694         print "<tt><pre>" .join('', $log) . "</pre></tt><p>\n";
 695 }
 696
 697 ##############################################
 698 # generate html for a test section
 699 sub make_test_html {
 700   my $name = shift;
 701   my $output = shift;
 702   my $id = shift;
 703   my $status = shift;
 704
 705   my $return =  "</pre>" . # don't want the pre openned by action affecting us
 706                "<div class=\"test unit \L$status\E\" id=\"test-$id\">" .
 707                 "<a href=\"javascript:handle('$id');\">" .
 708                  "<img id=\"img-$id\" name=\"img-$id\" src=\"";
 709   if (defined $status && $status eq "PASSED") {
 710     $return .= "icon_unhide_16.png";
 711   }
 712   else {
 713     $return .= "icon_hide_16.png";
 714   }
 715   $return .= "\" /> " .
 716                  "<div class=\"test name\">$name</div> " .
 717                 "</a> " .
 718                "<div class=\"test status \L$status\E\">$status</div>" .
 719                "<div class=\"test output\" id=\"output-$id\">" .
 720                 "<pre>$output</pre>" .
 721                "</div>" .
 722               "</div>" .
 723               "<pre>";    # open the pre back up
 724
 725   return $return;
 726 }
 727
 728 ##############################################
 729 # generate html for an action section
 730 sub make_action_html($$$$)
 731 {
 732
 733   my $name = shift;
 734   my $output = shift;
 735   my $id = shift;
 736   my $status = shift;
 737   my $return = "<div class=\"action unit \L$status\E\" id=\"action-$id\">" .
 738                 "<a href=\"javascript:handle('$id');\">" .
 739                  "<img id=\"img-$id\" name=\"img-$id\" src=\"";
 740
 741   if (defined $status && ($status =~ /failed/i)) {
 742     $return .= 'icon_hide_24.png';
 743   }
 744   else {
 745     $return .= 'icon_unhide_24.png';
 746   }
 747
 748   $return .= "\" /> " .
 749                   "<div class=\"action name\">$name</div>" .
 750                 "</a> ";
 751
 752   if (defined $status) {
 753     $return .= "<div class=\"action status \L$status\E\">$status</div>";
 754   }
 755
 756   my $x;
 757   $x = "$id";
 758   $x = "$name$output";
 759   $x = "$status";
 760   $x = "$name";
 761
 762   $return .= "<div class=\"action output\" id=\"output-$id\">" .
 763                  "<pre>Running action $name$output ACTION $status: $name</pre>" .
 764                 "</div>".
 765                "</div>";
 766
 767   return $return
 768 }
 769
 770 ##############################################
 771 # simple html markup stripper
 772 sub strip_html($) {
 773         my $string = shift;
 774
 775         # get rid of comments
 776         $string =~ s/<!\-\-(.*?)\-\->/$2/g;
 777
 778         # and remove tags.
 779         while ($string =~ s&<(\w+).*?>(.*?)</\1>&$2&) {
 780                 ;
 781         }
 782
 783         return $string;
 784 }
 785
 786
 787 ##############################################
 788 # main page
 789 sub main_menu() {
 790     print $req->startform("GET");
 791     print "<div id=\"build-menu\">\n";
 792     print $req->popup_menu(-name=>'host',
 793                            -values=>\@hosts,
 794                            -labels=>\%hosts) . "\n";
 795     print $req->popup_menu("tree", [sort (keys %trees, @pseudo_trees)]) . "\n";
 796     print $req->popup_menu("compiler", \@compilers) . "\n";
 797     print "<br />\n";
 798     print $req->submit('function', 'View Build') . "\n";
 799     print $req->submit('function', 'Recent Checkins') . "\n";
 800     print $req->submit('function', 'Summary') . "\n";
 801     print $req->submit('function', 'Recent Builds') . "\n";
 802     print "</div>\n";
 803     print $req->endform() . "\n";
 804 }
 805
 806
 807 ###############################################
 808 # display top of page
 809 sub page_top() {
 810     cgi_headers();
 811     chdir("$BASEDIR/data") || fatal("can't change to data directory");
 812 }
 813
 814
 815 ###############################################
 816 # main program
 817 my $fn_name = (defined $req->param('function')) ? $req->param('function') : '';
 818
 819 if ($fn_name eq 'text_diff') {
 820   cgi_headers_diff();
 821   chdir("$BASEDIR/data") || fatal("can't change to data directory");
 822   history::diff($req->param('author'),
 823                 $req->param('date'),
 824                 $req->param('tree'),
 825                 $req->param('revision'),
 826                 "text");
 827 }
 828 elsif ($fn_name eq 'Text_Summary') {
 829         cgi_headers_text();
 830         chdir("$BASEDIR/data") || fatal("can't change to data directory");
 831         view_summary('text');
 832 }
 833 else {
 834   page_top();
 835
 836   if    ($fn_name eq "View Build") {
 837     view_build();
 838   }
 839   elsif ($fn_name eq "Recent Builds") {
 840     view_recent_builds();
 841   }
 842   elsif ($fn_name eq "Recent Checkins") {
 843     history::history($req->param('tree'));
 844   }
 845   elsif ($fn_name eq "diff") {
 846     history::diff($req->param('author'),
 847                   $req->param('date'),
 848                   $req->param('tree'),
 849                   $req->param('revision'),
 850                   "html");
 851   }
 852   else {
 853     view_summary('html');
 854   }
 855   cgi_footers();
 856 }
 857