# -*- Mode: perl; indent-tabs-mode: nil -*- # # The contents of this file are subject to the Netscape Public # License Version 1.1 (the "License"); you may not use this file # except in compliance with the License. You may obtain a copy of # the License at http://www.mozilla.org/NPL/ # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or # implied. See the License for the specific language governing # rights and limitations under the License. # # The Original Code is the Tinderbox build tool. # # The Initial Developer of the Original Code is Netscape Communications # Corporation. Portions created by Netscape are # Copyright (C) 1998 Netscape Communications Corporation. All # Rights Reserved. # # Contributor(s): require 'header.pl'; %colormap = ( null => 'a5a5a5', success => '11DD11', busted => 'EE0000', building => 'EEFF00', testfailed => 'FFAA00' ); %titlemap = ( success => 'success', busted => 'busted', building => 'building', testfailed => 'testfailed', flames => 'burning', star => '' ); %textmap = ( success => 'L', busted => 'L!', building => 'L/', testfailed => 'L-', flames => '%', star => '*' ); %images = ( flames => '1afi003r.gif', star => 'star.gif' ); sub tb_build_static { $form{static} = 1; $form{tree} = $tree; &do_static; } sub show_tree_selector { print "Content-type: text/html\n\n"; &EmitHtmlHeader("tinderbox"); print "

"; print ""; print "
Select one of the following trees:
\n"; print "
    \n"; my @list = make_tree_list(); foreach (@list) { print "
  • $_\n"; } print "
"; print "

"; print ""; print "
"; print "Create a new tree or administer one of the following trees:
\n"; print "
    \n"; foreach (@list) { print "
  • $_\n"; } print "
"; } sub do_static { &require_only_one_tree; local *OUT; $form{legend}=0; my @pages = ( ['index.html', 'do_tinderbox'], ['flash.rdf', 'do_flash'], ['panel.html', 'do_panel'], ['stats.hdml', 'do_hdml'], ['status.vxml', 'do_vxml'] ); $rel_path = '../'; while (($key, $value) = each %images) { $images{$key} = "$rel_path$value"; } my $oldfh = select; foreach $pair (@pages) { my ($page, $call) = @{$pair}; my $outfile = "$::tree/$page"; open(OUT, ">", "$outfile.$$"); select OUT; eval "$call"; close(OUT); unlink($outfile); rename("$outfile.$$", "$outfile"); } select $oldfh; } sub do_tinderbox { &require_only_one_tree; my $tinderbox_data = &tb_load_data; &print_page_head; &print_table_header; &print_table_body($tinderbox_data); &print_table_footer; } sub print_page_head { print "Content-type: text/html\n\n\n" unless $form{static}; use POSIX qw(strftime); # Print time in format "YYYY-MM-DD HH:MM timezone" my $now = strftime("%Y-%m-%d %H:%M %Z", localtime); &EmitHtmlTitleAndHeader("tinderbox: $::tree", "tinderbox", "tree: $::tree ($now)"); &print_javascript; # Print rules, sheriff, and status. Only on the first pageful. if ($nowdate eq $maxdate) { unless ($form{norules}) { do "$::tree/rules.pl"; print "$rules_message"; # from $::tree/rules.pl } do "$::tree/sheriff.pl"; $current_sheriff =~ s:^\s*|\s*$::gs; if ($current_sheriff and length($current_sheriff) gt 0) { print "$current_sheriff"; # from $::tree/sheriff.pl } do "$::tree/status.pl"; $status_message =~ s:^\s*|\s*$::gs; if ($status_message and length($status_message) gt 0) { print "$status_message"; # from $::tree/status.pl } # keeps the main table from clearing the IFRAME print "
\n"; } # Quote and Legend # if ($form{legend}) { my ($imageurl,$imagewidth,$imageheight,$quote) = &get_image; print qq{


$quote

L = Show Build Log
C = Show Checkins
D = Download Build
$textmap{star} = Show Log comments
Successful Build, optional bloaty stats:
Lk:XXX (bytes leaked)
Bl:YYYY (bytes allocated, bloat)
Tp:TT.T (page-loader time, ms)
Txul:TT.T (XUL openwindow time, ms)
Ts:TT.T (startup time, sec)
No build in progress
Build in progress
Successful build, but tests failed
Build failed
}; } if (is_tree_state_available()) { print ""; print "The tree is "; print (is_tree_open() ? 'open' : 'closed'); print "\n"; } } sub print_table_body { my $tinderbox_data = $_[0]; for (my $tt=0; $tt < $time_count; $tt++) { last if $build_time_times->[$tt] < $mindate; print_table_row($tinderbox_data, $tt); } } BEGIN { # Make $lasthour persistent private variable for print_table_row(). my $lasthour = ''; sub print_table_row { my ($td, $tt) = @_; # Time column # my $query_link = ''; my $end_query = ''; my $pretty_time = print_time($build_time_times->[$tt]); ($hour) = $pretty_time =~ /(\d\d):/; if ($lasthour ne $hour or has_who_list($tt)) { $query_link = query_ref($td, $build_time_times->[$tt]); $end_query = ''; } if ($lasthour eq $hour) { $pretty_time =~ s/^.* //; } else { $lasthour = $hour; } my $hour_color = ''; $hour_color = ' bgcolor=#e7e7e7' if ($build_time_times->[$tt] + 1) % 7200 <= 3600; print "", "$query_link\n$pretty_time$end_query\n"; # Guilty # print ''; for $who (sort keys %{$who_list->[$tt]} ){ my $qr; if ($tt eq 0) { $qr = &who_menu($td, $build_time_times->[$tt], undef,$who); } else { $qr = &who_menu($td, $build_time_times->[$tt], $build_time_times->[$tt-1],$who); } $who =~ s/%.*$//; print " $qr$who\n"; } print ''; # Build Status # for (my $build_index=0; $build_index < $name_count; $build_index++) { $br = $build_table->[$tt][$build_index]; if (not defined($br)) { # No build data for this time (e.g. no build after this time). print "\n"; next; } next if $br == -1; # Covered by rowspan my $rowspan = $br->{rowspan}; # This appears to be designed to keep the rowspan from running beyond # the length of the displayed table. I'm not certain that can happen # in a table. Besides, if rowspan is set to that sort of invalid value, # that's more of a sign that there's a bug in tbglobals.pl. # if ( $rowspan > $mindate_time_count - $tt + 1 ) { $rowspan = $mindate_time_count - $tt + 1 } print "{buildstatus}}\">\n"; if ( $br->{buildstatus} eq "null" ) { print "\n"; next; } my $logfile = $br->{logfile}; my $buildtree = $br->{td}->{name}; print "\n"; # Build Note # my $logurl = "${rel_path}showlog.cgi?log=$buildtree/$logfile"; if ($br->{hasnote}) { print qq| $textmap{star} |; } # Build Log # # Uncomment this line to print logfile names in build rectangle. # print "$logfile
"; if ( 1 ) { # Add build start, end, and elapsed time where possible. my($start, $end, $elapsed); # Treat buildtime as the build's start and mailtime as the build's # end. We should add in explicit setting of endtime in the client # scripts if they don't already have it and then use that here. my $start_timet = $br->{buildtime}; my $end_timet = $br->{endtime}; # If either of the times aren't today, we need to qualify both with # the month and day-of-month. my $need_to_qualify; if ( both_are_today($start_timet, $end_timet) ) { $need_to_qualify = 0; } else { $need_to_qualify = 1; } # Grab the human-readable start time. $start = get_local_hms($start_timet, $need_to_qualify); # If we're still building, the mailtime only reflects the opening # mail that the build has started, not the time at which the build # ended. In that case, don't use it. Use the current time, instead. my $time_info = ""; if ($br->{buildstatus} eq 'building') { $elapsed = get_time_difference(time(), $start_timet); $time_info = "Started $start, still building.."; } else { $end = get_local_hms($end_timet, $need_to_qualify); $elapsed = get_time_difference($end_timet, $start_timet); $time_info = "Started $start, finished $end"; } print qq| $textmap{$br->{buildstatus}} |; } else { print qq| $textmap{$br->{buildstatus}} |; } # What Changed # # Only add the "C" link if there have been changes since the last build. if ($br->{previousbuildtime}) { my $previous_buildtime_index = $build_time_index->{$br->{previousbuildtime}}; my $this_buildtime_index = $build_time_index->{$br->{buildtime}} + 1; if (&has_who_list($this_buildtime_index, $previous_buildtime_index)) { print "\n", &query_ref($br->{td}, $br->{previousbuildtime}, $br->{buildtime} - 1); print "C"; } } # Binary URL # # Only add the "D" link if there is a url to a downloadable binary if( $br->{binaryurl} ){ $binaryurl = $br->{binaryurl}; print" D"; } # Scrape data if (defined $td->{scrape}{$logfile}) { my (@scrape_data) = @{ $td->{scrape}{$logfile} }; # ex: Tp:5.45s my $i; foreach $i (@scrape_data) { print "
$i"; } } # Warnings if (defined $td->{warnings}{$logfile}) { my ($warning_count) = $td->{warnings}{$logfile}; my $warn_file = "$::tree/warn$logfile"; $warn_file =~ s/\.gz$/.html/; print "

Warn:$warning_count"; } print "
\n"; } print "\n"; } } sub print_table_header { print "\n"; print "\n"; print "\n"; print "\n"; for (my $ii=0; $ii < $name_count; $ii++) { my $bn = $build_names->[$ii]; $bn =~ s/Clobber/Clbr/g; $bn =~ s/Depend/Dep/g; $bn = "$bn"; my $last_status = tb_last_status($ii); if ($last_status eq 'busted') { if ($form{noflames}) { print ""; } else { print ""; } } else { print ""; } } print "\n"; print ""; print ""; print "\n"; } sub print_table_footer { print "
Build TimeGuilty$bn $textmap{flames}"; print "$bn $textmap{flames}$bn
Click time to
see changes
", "since then
", "Click name to see what they did
\n"; my $nextdate = $maxdate - $hours*60*60; print &open_showbuilds_href(maxdate=>"$nextdate", legend=>'0') ."Show previous $hours hours
"; if ($hours != 24) { my $save_hours = $hours; $hours = 24; print &open_showbuilds_href(maxdate=>"$nextdate", legend=>'0') ."Show previous 24 hours
"; $hours = $save_hours; } print "Show $hours hours from the previous "; $nextdate = $maxdate - 24*60*60*7; print &open_showbuilds_href(maxdate=>"$nextdate", legend=>'0') ."1, "; $nextdate = $maxdate - 24*60*60*7*4; print &open_showbuilds_href(maxdate=>"$nextdate", legend=>'0') ."4, "; $nextdate = $maxdate - 24*60*60*7*12; print &open_showbuilds_href(maxdate=>"$nextdate", legend=>'0') ."12, or "; $nextdate = $maxdate - 24*60*60*7*52; print &open_showbuilds_href(maxdate=>"$nextdate", legend=>'0') ."52 weeks.
"; print "

", "Administrate Tinderbox Trees
\n"; # Chase was here! } sub open_showbuilds_url { my %args = ( legend => "$form{legend}", norules => "$form{norules}", @_ ); my $url = "${rel_path}showbuilds.cgi?tree=$::tree"; $url .= "&hours=$hours" if $hours ne $default_hours; while (my ($key, $value) = each %args) { $url .= "&$key=$value" if $value ne ''; } return $url; } sub open_showbuilds_href { return ""; } # Same as open_showbuilds_href, but adding parent target # so that URL's in iframes take over the parent window. sub open_showbuilds_href_target { return ""; } sub query_ref { my ($td, $mindate, $maxdate, $who) = @_; my $output = ''; if ($use_viewvc) { $output = ""; } elsif ($use_bonsai) { $output = "{cvs_branch} ne 'HEAD'; $output .= "&branchtype=regexp" if $td->{cvs_branch} =~ /\+|\?|\*/; $output .= "&cvsroot=$td->{cvs_root}" if $td->{cvs_root} ne $default_root; $output .= "&date=explicit&mindate=$mindate"; $output .= "&maxdate=$maxdate" if $maxdate and $maxdate ne ''; $output .= "&who=$who" if $who and $who ne ''; $output .= ">"; } return $output; } sub who_menu { my ($td, $mindate, $maxdate, $who) = @_; my $treeflag; # this variable isn't doing anything, so i'm going to use it shamelessly $treeflag = $td->{cvs_branch}; # trick who.cgi into using regexps, escaping & and = $treeflag .= '%26branchtype%3Dregexp' if $treeflag =~ /\+|\?|\*/; require "$tree/treedata.pl"; my $qr = ''; my $ret = ''; if ($use_viewvc) { $qr = "${viewvc_url}?view=query&who_match=exact&who=" . &url_encode($who) . "&querysort=date&date=explicit" . "&mindate=" . strftime("%Y-%m-%d %T", gmtime($mindate)); $qr .= "&maxdate=" . strftime("%Y-%m-%d %T", gmtime($maxdate)) if (defined($maxdate)); $ret = ""; } elsif ($use_bonsai) { $qr = "${rel_path}../registry/who.cgi?email=". &url_encode($who) . "&d=$td->{cvs_module}|$treeflag|$td->{cvs_root}|$mindate"; $qr = $qr . "|$maxdate" if defined($maxdate); $ret = ""; } return $ret; } # Check to see if anyone checked in during time slot. # ex. has_who_list(1); # Check for checkins in most recent time slot. # ex. has_who_list(1,5); # Check range of times. sub has_who_list { my ($time1, $time2) = @_; if (not defined(@who_check_list)) { # Build a static array of true/false values for each time slot. $who_check_list[$time_count - 1] = 0; for (my $tt = 0; $tt < $time_count; $tt++) { $who_check_list[$tt] = 1 if each %{$who_list->[$tt]}; } } if ($time2) { for (my $ii=$time1; $ii<=$time2; $ii++) { return 1 if $who_check_list[$ii]; } return 0; } else { return 1 if $who_check_list[$time1]; } } BEGIN { # Check bonsai tree for open/close state my $treestate = undef; my $checked_state = 0; sub _check_tree_state { my $tree = shift; $checked_state = 1; tb_load_treedata($tree); # Loading for the global, $bonsai_tree return unless defined $bonsai_tree and $bonsai_tree ne ''; local $_; $::BatchID=''; eval qq(require "/d/webdocs/projects/bonsai/data/$bonsai_tree/batchid.pl"); if ($::BatchID eq '') { warn "No BatchID in /d/webdocs/projects/bonsai/data/$bonsai_tree/batchid.pl\n"; return; } open(BATCH, "<", "/d/webdocs/projects/bonsai/data/$bonsai_tree/batch-$::BatchID.pl") or print "can't open batch-$::BatchID.pl
"; while () { if (/^\$::TreeOpen = '(\d+)';/) { $treestate = $1; last; } } return; } sub is_tree_state_available { my $tree = shift; $tree = $::tree unless defined $tree; return 1 if defined $treestate; return 0 if $checked_state; _check_tree_state($tree); return is_tree_state_available(); } sub is_tree_open { my $tree = shift; $tree = $::tree unless defined $tree; _check_tree_state($tree) unless $checked_state; return $treestate; } } sub print_javascript { my $script; ($script = <<"__ENDJS") =~ s/^ //gm; __ENDJS print $script; } sub do_express { &require_only_one_tree; print "Content-type: text/html\nRefresh: 900\n\n\n"; my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); my @keys = sort keys %build; my $keycount = @keys; my $tm = &print_time(time); print ""; print "\n"; foreach my $buildname (@keys) { print ""; } print "
"; print &open_showbuilds_href_target."$::tree"; if (&is_tree_state_available()) { print (&is_tree_open() ? ' is open' : ' is closed'); } print ", $tm
$buildname
\n"; } # This is essentially do_express but it outputs a different format sub do_panel { &require_only_one_tree; print "Content-type: text/html\n\n\n" unless $form{static}; my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); print q( ); # Hack the panel link for now. print "
$::tree"; if (&is_tree_state_available()) { print " is ", &is_tree_open() ? 'open' : 'closed'; } # Add the current time my ($minute,$hour,$mday,$mon) = (localtime)[1..4]; my $tm = sprintf("%d/%d %d:%02d",$mon+1,$mday,$hour,$minute); print ", $tm
"; print ""; foreach my $buildname (sort {$times{$b} cmp $times{$a}} keys %build) { print ""; } print "
$buildname
"; } sub do_flash { &require_only_one_tree; print "Content-type: text/rdf\n\n" unless $form{static}; my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); my ($mac,$unix,$win) = (0,0,0); while (my ($name, $status) = each %build) { next if $status eq 'success'; $mac = 1, next if $name =~ /Mac/; $win = 1, next if $name =~ /Win/; $unix = 1; } print q{ }; my $busted = $mac + $unix + $win; if ($busted) { # Construct a legible sentence; e.g., "Mac, Unix, and Windows # are busted", "Windows is busted", etc. This is hideous. If # you can think of something better, please fix it. my $text; if ($mac) { $text .= 'Mac' . ($busted > 2 ? ', ' : ($busted > 1 ? ' and ' : '')); } if ($unix) { $text .= 'Unix' . ($busted > 2 ? ', and ' : ($win ? ' and ' : '')); } if ($win) { $text .= 'Windows'; } $text .= ($busted > 1 ? ' are ' : ' is ') . 'busted'; # The Flash spec says we need to give ctime. use POSIX; my $tm = POSIX::ctime(time()); $tm =~ s/^...\s//; # Strip day of week $tm =~ s/:\d\d\s/ /; # Strip seconds chop $tm; print qq{ $::tree $text $tm }; } print q{ }; } sub do_quickparse { print "Content-type: text/plain\n\n"; my @treelist = &make_tree_list(); my @requestedtreelist = split /,/, $::tree; foreach my $tt (@requestedtreelist) { next unless grep {$tt eq $_} @treelist; if (&is_tree_state_available($tt)) { my $state = &is_tree_open($tt) ? 'open' : 'closed'; print "State|$tt|$bonsai_tree|$state\n"; } my (%build, %times); &tb_loadquickparseinfo($tt, \%build, \%times); foreach my $buildname (sort keys %build) { print "Build|$tt|$buildname|$build{$buildname}|$times{$buildname}\n"; } } } sub do_rdf { &require_only_one_tree; print "Content-type: text/plain\n\n"; my $mainurl = "http://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}?tree=$::tree"; my $dirurl = $mainurl; $dirurl =~ s@/[^/]*$@@; my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); my $image = "channelok.gif"; my $imagetitle = "OK"; foreach my $buildname (sort keys %build) { if ($build{$buildname} eq 'busted') { $image = "channelflames.gif"; $imagetitle = "Bad"; last; } } print qq{ Tinderbox - $::tree Build bustages for $::tree $mainurl $imagetitle $dirurl/$image $mainurl }; if (&is_tree_state_available()) { my $state = &is_tree_open() ? 'open' : 'closed'; print "The tree is currently $state", "$mainurl\n"; } foreach my $buildname (sort keys %build) { if ($build{$buildname} eq 'busted') { print "$buildname is in flames", "$mainurl\n"; } } print "\n"; } # This is for Sprint phones sub do_hdml { &require_only_one_tree; print "Content-type: text/hdml\n\n" unless $form{static}; print q{ }; %state_symbols = (success=>'+',busted=>'!',testfailed=>'~'); if (&is_tree_state_available()) { print "$::tree is " . (&is_tree_open() ? 'open' : 'closed'); } my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); foreach my $buildname (sort keys %build) { print "$state_symbols{$build{$buildname}} $buildname\n"; } print q{ Legend:
+ : Good Build
! : Broken Build
~ : Tests Failed
}; } sub do_vxml { &require_only_one_tree; print "Content-type: text/vxml\n\n"; print ''; print '

'; print "\n\n"; print ''; print "\n"; print '500'; print "\n"; %state_symbols = (success=>'green.',busted=>'red.',testfailed=>'orange.'); if (&is_tree_state_available()) { print ""; } my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); $testFailed = 0; $flames = 0; print "\n"; foreach my $buildname (sort keys %build) { if ($build{$buildname} eq 'busted') { $flames = 1; } elsif ($build{$buildname} eq 'testfailed') { $testFailed = 1; } } print '500'; if ($testFailed == 1 || $flames == 1) { if ($testFailed == 1) { print ''; } elsif ($flames == 1) { print ''; } print "\n"; foreach my $buildname (sort keys %build) { print "500"; print "\n"; if ($build{$buildname} eq 'busted' || $build{$buildname} eq 'testfailed') { print ''; print "\n"; } print "500"; print "\n"; print ""; print "\n"; } } else { print ''; print "\n"; } print '1000'; print "\n"; print '
'; } sub do_wml { &require_only_one_tree; print "Content-type: text/vnd.wap.wml\n"; print "Pragma: No-Cache\n\n"; print ''; print ''; print ''; print '

Moz Tinderbox

'; %state_symbols = (success=>'green.',busted=>'red.',testfailed=>'orange.'); if (&is_tree_state_available()) { print "

$::tree is " . (&is_tree_open() ? 'open.' : 'closed.') . "

"; } my (%build, %times); &tb_loadquickparseinfo($::tree, \%build, \%times); $testFailed = 0; $flames = 0; print "\n"; foreach my $buildname (sort keys %build) { if ($build{$buildname} eq 'busted') { $flames = 1; } elsif ($build{$buildname} eq 'testfailed') { $testFailed = 1; } } print '

'; if ($flames) { print "There's bustage.

"; } if ($testFailed) { print "Tests are failing.

"; } if ($flames == 0 && $testFailed == 0) { print "No bustage.

"; } print "
\n"; print ''; print '

Builds

'; print '

'; foreach my $buildname (sort keys %build) { print ""; print "\n"; } print '
["; if ($build{$buildname} eq 'busted') { print 'RED'; } elsif ($build{$buildname} eq 'testfailed') { print 'TEST FAILED'; } else { print 'GREEN'; } print "]$buildname

'; } 1;