web/build.pl

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