+++ /dev/null
-#!/usr/bin/perl -w
-#
-# Extract information about recent git commits
-#
-# tridge@samba.org, November 2006
-# bjacke@samba.org
-
-use strict;
-use lib "web";
-use util;
-use POSIX;
-use Data::Dumper;
-use File::stat;
-use Date::Parse;
-
-####################################
-# push an entry onto the array
-
-sub push_entry($$$$)
-{
- my $entry = shift;
- my $log = shift;
- my $days = shift;
- my $tree = shift;
- unshift(@{$log}, $entry);
-# printf("Adding entry\n");
-# print Dumper $entry;
- return $log;
-}
-
-####################################
-# return an array of logfile entries given a git log file.
-# Only return entries newer than $days old
-sub git_parse($$$$)
-{
- my $git_path = shift;
- my $days = shift;
- my $tree = shift;
- my $subdir = shift;
- my $log;
- my $entry = {};
- my $addto = "";
-
- $subdir = "" unless defined($subdir);
-
- my $magicstart = "---GIT-COMMIT-MAGIC-START---";
- my $magicmsg = "---GIT-COMMIT-MAGIC-MESSAGE---";
- my $magicdiff = "---GIT-COMMIT-MAGIC-DIFF---";
- my $magicbody = "---GIT-COMMIT-MAGIC-BODY---";
- my $format = $magicstart."%n%H%n%ct%n%an%n".$magicmsg."%n%s%n".$magicbody."%b%n".$magicdiff;
- my $sincedays;
- $sincedays = "--since='$days days'" if defined($days);
- # the number of entries is also being limited to a maximum number
- # in the "git log" command. This is required because we
- # checked in 11 years of samba development 1 days ago :-)
-
- # git log --pretty=format:---GIT-COMMIT-MAGIC-START---%n%H%n%ct%n%an%n---GIT-COMMIT-MAGIC-MESSAGE---%n%s%b%n---GIT-COMMIT-MAGIC-DIFF--- --numstat --since='1 days'
- open(FILE, "cd $git_path; git log --pretty=format:$format --numstat $sincedays -500 $tree -- $subdir |");
- my $line_count;
- while (defined (my $line = <FILE>)) {
-# printf("line=$line");
- # separator line indicates new entry
- if ($line =~ /^$magicstart$/ ) {
- # only add entry if one exists
- if ($entry->{DATE}) {
- $log = push_entry($entry, $log, $days, $tree);
- }
-
- $entry = {};
- $line_count = 0;
- next;
- }
- $line_count++;
-
- if ($line_count == 1) {
- chomp $line;
- $entry->{REVISION} = $line;
- next;
- } elsif ($line_count == 2) {
- chomp $line;
- $entry->{DATE} = $line;
- next;
- } elsif ($line_count == 3) {
- chomp $line;
- $entry->{AUTHOR} = $line;
- next;
- }
-
- if ($line =~ /^$magicmsg$/) {
- $addto = "MESSAGE";
- next;
- }
-
- if ($line =~ /^$magicdiff$/) {
- $addto = "DIFF_STUFF";
- next;
- }
-
- chomp $line;
- if ($addto eq "MESSAGE") {
- if ($line =~ /^$magicbody(<unknown>$)?(.*)$/) {
- $line = $2;
- }
- $entry->{MESSAGE} .= $line."\n";
- next;
- }
-
- if ($addto eq "DIFF_STUFF") {
- $line =~ m/^([0-9]*)[ \t]*([0-9]*)[ \t]*(.*)/;
- my $a = $1;
- my $b = $2;
- my $f = $3;
- $f =~ s/^$subdir\///;
- if (($b eq "0") and ($a ne "0")) {
- $entry->{ADDED} .= "$f ";
- } elsif (($a eq "0") and ($b ne "0")) {
- $entry->{REMOVED} .= "$f ";
- } else {
- $entry->{FILES} .= "$f ";
- }
- next;
- }
- }
- # the last log entry should be caught here:
- if ($entry->{DATE}) {
- $log = push_entry($entry, $log, $days, $tree);
- }
-
- close(FILE);
-
- # cleanup the messages
-# for (my $line = $#{$log}; $line > 0; $line--) {
-# $entry = $log->[$line];
-# if ($entry->{MESSAGE}) {
-# while (chomp($entry->{MESSAGE})) { }
-# }
-# }
-
- return $log;
-}
-
-
-######################################
-# main program
-if ($#ARGV < 2 || $ARGV[0] eq '--help' || $ARGV[0] eq '-h') {
- print "
-Usage: gitlog.pl <PATH> <DAYS> <DEST> [<subdir>]
-
-Extract all commits git tree <PATH> in the last DAYS days. Store the
-results in DEST in a format easily readable by the build farm web
-scripts. "; exit(1); }
-
-my $git_path_arg = $ARGV[0];
-my $days_arg = $ARGV[1];
-my $tree_arg = $ARGV[2];
-my $dest_arg = $ARGV[3];
-my $subdir_arg = $ARGV[4];
-
-my $log_data = git_parse($git_path_arg, $days_arg, $tree_arg, $subdir_arg);
-
-util::SaveStructure($dest_arg, $log_data);
+++ /dev/null
-#!/bin/bash
-
-# This script converts log files produced by CVS into Perl DataDumper
-# files that can be easily loaded by the buildfarm web interface.
-
-#cd $HOME/master || exit 1
-
-(
-
-./gitlog.pl /data/git/ppp.git/ 60 master cache/history.ppp
-./gitlog.pl /data/git/ccache.git/ 60 master cache/history.ccache
-./gitlog.pl /data/git/rsync.git/ 60 master cache/history.rsync
-./gitlog.pl /data/git/samba.git/ 60 v3-5-test cache/history.samba_3_current
-./gitlog.pl /data/git/samba.git/ 60 v3-6-test cache/history.samba_3_next
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.samba_3_master
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.samba_4_0_test
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.samba_4_0_waf
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.libreplace lib/replace
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.talloc lib/talloc
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.tdb lib/tdb
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.ldb source4/lib/ldb
-./gitlog.pl /data/git/samba.git/ 60 master cache/history.pidl pidl
-
-./gitlog.pl /data/git/ctdb.git/ 60 master cache/history.ctdb
-./gitlog.pl /data/git/build-farm.git/ 60 master cache/history.build_farm
-./gitlog.pl /data/git/samba-web.git/ 60 master cache/history.samba-web
-
-) > history.log 2>&1
+++ /dev/null
-#!/usr/bin/perl -w
-#
-# Extract information about recent SVN commits
-#
-# tridge@samba.org, April 2001
-# vance@samba.org, August 2004
-
-use strict;
-use lib "web";
-use util;
-use POSIX;
-use Data::Dumper;
-use File::stat;
-use Date::Parse;
-
-####################################
-# push an entry onto the array
-
-sub push_entry($$$$)
-{
- my $entry = shift;
- my $log = shift;
- my $days = shift;
- my $tree = shift;
-
- # we can assume that each entry is unique, due to the nature of svn
- # so we don't need any of the magic required for cvs
- if (($entry->{DATE} > time() - $days*24*60*60) &&
- ($entry->{TREE} eq $tree)) {
-
- # we put these on in reverse order so that it's in order of
- # date.
- unshift(@{$log}, $entry);
- }
-
- return $log;
-}
-
-####################################
-# return an array of logfile entries given a svn log file.
-# Only return entries newer than $days old
-sub svn_parse($$$$)
-{
- my $repo_url = shift;
- my $tree_dir = shift;
- my $days = shift;
- my $tree = shift;
- my $log;
- my $entry = {};
-
- # don't know what time zone this machine is, but given the granularity
- # of days, (intended to be about 60 days), a few hours either way makes
- # very little difference
- my $start_date = POSIX::strftime("%Y-%m-%d", gmtime(time() - $days*60*60*24));
-
- open(FILE, "svn log --verbose --non-interactive $repo_url/$tree_dir -r HEAD:'{$start_date}' |");
- #open(FILE, "< log.txt") or die "Could not open log: $!";
- while (defined (my $line = <FILE>)) {
-
-
- # separator line indicates new entry
- if ($line =~ /^\-{5,}$/) {
- # only add entry if one exists
- if ($entry->{DATE}) {
- $log = push_entry($entry, $log, $days, $tree);
- }
-
- $entry = {};
-
- next;
- }
-
- # the first line after the separator (which sets entry to {})
- # looks like:
- # r15 | vance | 2004-07-31 22:24:55 -0700 (Sat, 31 Jul 2004) | 4 lines
- if (! defined $entry->{DATE}) {
-
- my ($rev, $author, $date, $lines) = split /\s+\|\s+/, $line;
- $entry->{DATE} = str2time($date);
-
- # kill the r in the revision
- $rev =~ s/^r//;
- $entry->{REVISION} = $rev;
- $entry->{AUTHOR} = $author;
- $entry->{TREE} = $tree;
- next;
- }
-
-
- # read the list of changed/added/removed files
- if ($line =~ /^Changed paths:/) {
-
- while (<FILE>) {
-
- $line = $_;
- if ($line =~ /^\s*$/) { last; }
-
- elsif ($line =~ /\s+A (.*)/) {
- my $file = $1;
- $file =~ s#^/$tree_dir/##o;
- if ($entry->{ADDED}) {
- $entry->{ADDED} .= " $file";
- } else {
- $entry->{ADDED} = "$file";
- }
- }
-
- elsif ($line =~ /\s+M (.*)/) {
- my $file = $1;
- $file =~ s#^/$tree_dir/##o;
- if ($entry->{FILES}) {
- $entry->{FILES} .= " $file";
- } else {
- $entry->{FILES} = "$file";
- }
- }
-
- elsif ($line =~ /\s+R (.*)/ ||
- $line =~ /\s+D (.*)/) {
- my $file = $1;
- $file =~ s#^/$tree_dir/##o;
- if ($entry->{REMOVED}) {
- $entry->{REMOVED} .= " $file";
- } else {
- $entry->{REMOVED} = "$file";
- }
- }
- }
-
- next;
- }
-
- # add the line to the message
- if (defined $entry->{MESSAGE}) {
- $entry->{MESSAGE} .= $line;
- }
- else {
- $entry->{MESSAGE} = $line;
- }
- }
-
- if ($entry->{DATE}) {
- $log = push_entry($entry, $log, $days, $tree);
- }
-
- close(FILE);
-
- # cleanup the messages
- for (my $line = $#{$log}; $line > 0; $line--) {
- $entry = $log->[$line];
- if ($entry->{MESSAGE}) {
- while (chomp($entry->{MESSAGE})) { }
- }
- }
-
- return $log;
-}
-
-
-######################################
-# main program
-if ($#ARGV < 4 || $ARGV[0] eq '--help' || $ARGV[0] eq '-h') {
- print "
-Usage: svnlog.pl <REPOSITORY-URL> <TREE-DIR> <DAYS> <TREE> <DEST>
-
-Extract all commits to REPOSITORY-URL/TREE-DIR in the last
-DAYS days. Store the results in DEST, indexed under TREE,
-in a format easily readable by the build farm web scripts.
-";
- exit(1);
-}
-
-my $repo_url = $ARGV[0];
-my $tree_dir = $ARGV[1];
-my $days = $ARGV[2];
-my $tree = $ARGV[3];
-my $dest = $ARGV[4];
-
-
-my $log = svn_parse($repo_url, $tree_dir, $days, $tree);
-
-util::SaveStructure($dest, $log);
+++ /dev/null
-#!/usr/bin/perl
-
-use FindBin qw($RealBin);
-
-use lib "$RealBin/..";
-use lib "$RealBin/../web";
-
-use Test::More tests => 4;
-use strict;
-use warnings;
-
-use data;
-
-is(new data("somedirthatdoesn'texist"), undef);
-
-mkdir("tmpdir");
-mkdir("tmpdir/data");
-mkdir("tmpdir/cache");
-mkdir("tmpdir/web");
-mkdir("tmpdir/lcov");
-mkdir("tmpdir/lcov/data");
-my $x = new data("tmpdir");
-ok($x);
-
-is($x->build_fname("mytree", "myhost", "cc", undef), "tmpdir/data/upload/build.mytree.myhost.cc");
-is($x->build_fname("mytree", "myhost", "cc", 123), "tmpdir/data/oldrevs/build.mytree.myhost.cc-123");
-is($x->cache_fname("mytree", "myhost", "cc", 123), "tmpdir/cache/build.mytree.myhost.cc-123");
-is($x->cache_fname("mytree", "myhost", "cc", undef), "tmpdir/cache/build.mytree.myhost.cc");
-
-rmdir("tmpdata");
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-use FindBin qw($RealBin);
-
-use lib "$RealBin/..";
-use lib "$RealBin/../web";
-
-use Test::More tests => 22;
-use CGI qw/:standard/;
-use strict;
-
-use util;
-
-is(2, util::count_lines("foo\nbar"));
-is(1, util::count_lines("bar"));
-is(1, util::count_lines(""));
-
-is("foo.bar", util::ChangeExtension("foo.old", "bar"));
-is("foo.png", util::ChangeExtension("foo.png", "png"));
-is("foobar.png", util::ChangeExtension("foobar", "png"));
-
-is("0s", util::dhm_time(0));
-is("1m", util::dhm_time(61));
-is("-", util::dhm_time(-20));
-is("1d 3h 1m", util::dhm_time(97265));
-is("3h 1m", util::dhm_time(10865));
-
-is_deeply([1, 2, 3], util::FlattenArray([[1, 2], [3]]));
-is_deeply([1, [2], 3], util::FlattenArray([[1, [2]], [3]]));
-
-is_deeply({a => 1, b => "a" },
- util::FlattenHash([{a => 1}, {b => "a"}]));
-
-ok(util::InArray("a", ["a", "b", "c"]));
-ok(not util::InArray("a", ["b", "c"]));
-ok(util::InArray("a", ["b", "c", "a"]));
-
-is("", util::strip_html("<!--foo-->"));
-is("bar ", util::strip_html("<!--foo-->bar <!--bloe-->"));
-is("bar <bloe>", util::strip_html("<bar>bar <bloe></bar>"));
-is("", util::strip_html("<bar><bloe></bloe></bar>"));
-
-is("bla", util::strip_html("<a href=\"foo\">bla</a>"));
-
-1;
#!/usr/bin/perl -w
exec("/usr/bin/python", "/home/build/master/web/build.cgi", @ARGV);
-# This CGI script presents the results of the build_farm build
-#
-# Copyright (C) Andrew Tridgell <tridge@samba.org> 2001-2005
-# Copyright (C) Andrew Bartlett <abartlet@samba.org> 2001
-# Copyright (C) Vance Lankhaar <vance@samba.org> 2002-2005
-# Copyright (C) Martin Pool <mbp@samba.org> 2001
-# Copyright (C) Jelmer Vernooij <jelmer@samba.org> 2007-2009
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-# TODO: Allow filtering of the "Recent builds" list to show
-# e.g. only broken builds or only builds that you care about.
-
-
-use strict;
-use warnings;
-use FindBin qw($RealBin);
-
-use lib "$RealBin";
-use data;
-use util;
-use history;
-use POSIX;
-use Data::Dumper;
-use CGI qw/:standard/;
-use File::stat;
-
-my $WEBDIR = "$RealBin";
-my $BASEDIR = "$WEBDIR/..";
-
-my $req = new CGI;
-my $db = new data($BASEDIR);
-my $history = new history($req, $db);
-
-my @compilers = @{$db->{compilers}};
-my %hosts = %{$db->{hosts_hash}};
-my @hosts = @{$db->{hosts_list}};
-my %trees = %{$db->{trees}};
-my $OLDAGE = $db->{OLDAGE};
-
-# this is automatically filled in
-my (@deadhosts) = ();
-
-###############################################
-# URL so I can refer to myself in links
-my $myself = $req->url();
-
-####################################################################
-# setup for gzipped output of a web page if possible.
-# based on cvsweb.pl method
-# as a side effect this function adds the final line ot the HTTP headers
-sub cgi_gzip()
-{
- my $paths = ['/usr/bin/gzip', '/bin/gzip'];
- my $GZIPBIN;
- my $Browser = $ENV{'HTTP_USER_AGENT'} || "";
-
-# newer browsers accept gzip content encoding
-# and state this in a header
-# (netscape did always but didn't state it)
-#
-# It has been reported that these
-# braindamaged MS-Internet Exploders claim that they
-# accept gzip .. but don't in fact and
-# display garbage then :-/
-#
-# && ($Browser !~ m/MSIE/) was used...
-#
-# How ever IE6 and IE7 work fine with gzip
-# compression
-#
-# Turn off gzip if running under mod_perl. piping does
-# not work as expected inside the server. One can probably
-# achieve the same result using Apache::GZIPFilter.
- my $maycompress = ((defined($ENV{'HTTP_ACCEPT_ENCODING'}) and $ENV{'HTTP_ACCEPT_ENCODING'} =~ m|gzip|)
- && !defined($ENV{'MOD_PERL'}));
-
- if (!$maycompress) {
- print header(-charset=>'utf-8');
- return;
- }
-
- for my $p (@{$paths}) {
- if (stat($p)) { $GZIPBIN = $p; }
- }
-
- my $fh = do {local(*FH);};
-
- if (stat($GZIPBIN) && open($fh, "|$GZIPBIN -c")) {
- print header(-content_encoding => "gzip",
- -charset=>'utf-8',
- -vary => "Accept-Encoding");
- $| = 1; $| = 0; # Flush header output
- select ($fh);
- } else {
- print header;
- }
-}
-
-################################################
-# start CGI headers
-sub cgi_headers() {
- cgi_gzip();
- print start_html(-title => 'samba.org build farm',
- -script => {-language=> 'JAVASCRIPT', -src=>"/build_farm.js" },
- -meta => {
- -keywords => "Samba SMB CIFS Build Farm",
- -description => "Home of the Samba Build Farm, the automated testing facility.",
- -robots => "noindex"
- },
- -lang => "en-us",
- -head => [
- Link({-rel => "stylesheet",
- -href => "/build_farm.css",
- -type => "text/css",
- -media => "all"}),
- Link({-rel => "stylesheet",
- -href => "http://master.samba.org/samba/style/common.css",
- -type => "text/css",
- -media => "all"}),
- Link({-rel=>"shortcut icon",
- -href=>"http://www.samba.org/samba/images/favicon.ico"})
- ]
- );
-
- print util::FileLoad("$WEBDIR/header2.html");
- print main_menu();
- print util::FileLoad("$WEBDIR/header3.html");
-}
-
-################################################
-# end CGI
-sub cgi_footers() {
- print util::FileLoad("$WEBDIR/footer.html");
- print $req->end_html;
-}
-
-################################################
-# print an error on fatal errors
-sub fatal($) {
- my $msg = shift;
-
- print $req->h1("ERROR: $msg");
- cgi_footers();
- exit(0);
-}
-
-################################################
-# get a param from the request, after sanitizing it
-sub get_param($) {
- my $param = shift;
-
- if (!defined $req->param($param)) {
- return undef;
- }
-
- my @result = ();
- $result[0] = $req->param($param);
-
- for (my $i = 0; $i <= $#result; $i++) {
- $result[$i] =~ s/ /_/g;
- }
-
- foreach (@result) {
- if ($_ =~ m/[^a-zA-Z0-9\-\_\.]/) {
- fatal("Parameter $param is invalid");
- return undef;
- }
- }
-
- return $result[0];
-}
-
-sub build_link($$$$$)
-{
- my ($host, $tree, $compiler, $rev, $status) = @_;
-
- return a({-href=>"$myself?function=View+Build;host=$host;tree=$tree;compiler=$compiler" . ($rev?";revision=$rev":"")}, $status);
-}
-
-sub build_status($$$$)
-{
- my ($host, $tree, $compiler, $rev) = @_;
- my $status = $db->build_status($host, $tree, $compiler, $rev);
-
- return build_link($host, $tree, $compiler, $rev, $status);
-}
-
-
-#############################################
-# get the overall age of a host
-sub host_age($)
-{
- my $host = shift;
- my $ret = -1;
- for my $compiler (@compilers) {
- for my $tree (keys %trees) {
- my $age = $db->build_age_mtime($host, $tree, $compiler, "");
- if ($age != -1 && ($age < $ret || $ret == -1)) {
- $ret = $age;
- }
- }
- }
- return $ret;
-}
-
-#############################################
-# show an age as a string
-sub red_age($)
-{
- my $age = shift;
-
- if ($age > $OLDAGE) {
- return $req->span({-class=>"old"}, util::dhm_time($age));
- }
- return util::dhm_time($age);
-}
-
-##############################################
-# translate a status into a set of int representing status
-sub build_status_vals($) {
- my $status = util::strip_html(shift);
-
- $status =~ s/ok/0/g;
- $status =~ s/\?/0/g;
- $status =~ s/PANIC/1/g;
-
- return split m%/%, $status;
-}
-
-##############################################
-# view build summary
-sub view_summary($)
-{
- my $i = 0;
- my $cols = 2;
- my $broken = 0;
-
- # either "text" or anything else.
- my $output_type = shift;
-
- # set up counters
- my %broken_count;
- my %panic_count;
- my %host_count;
-
- # zero broken and panic counters
- for my $tree (keys %trees) {
- $broken_count{$tree} = 0;
- $panic_count{$tree} = 0;
- $host_count{$tree} = 0;
- }
-
- # set up a variable to store the broken builds table's code, so we can output when we want
- my $broken_table = "";
- my $host_os;
- my $last_host = "";
-
- # for the text report, include the current time
- if ($output_type eq 'text') {
- my $time = gmtime();
- print "Build status as of $time\n\n";
- }
-
- for my $host (@hosts) {
- for my $compiler (@compilers) {
- for my $tree (keys %trees) {
- my $status = build_status($host, $tree, $compiler, "");
- next if $status =~ /^Unknown Build/;
- my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, "");
-
- if ($age_mtime != -1) {
- $host_count{$tree}++;
- }
-
- if ($status =~ /status failed/) {
- $broken_count{$tree}++;
- if ($status =~ /PANIC/) {
- $panic_count{$tree}++;
- }
- }
- }
- }
- }
-
- if ($output_type eq 'text') {
- print "Build counts:\n";
- printf "%-12s %-6s %-6s %-6s\n", "Tree", "Total", "Broken", "Panic";
- } else {
- print $req->start_div({-id=>"build-counts", -class=>"build-section"});
- print $req->h2('Build counts:');
- print $req->start_table({-class => "real"}),
- $req->thead(
- $req->Tr($req->th("Tree"), $req->th("Total"),
- $req->th("Broken"), $req->th("Panic"),
- $req->th("Test Coverage"))),
- $req->start_tbody;
- }
-
- for my $tree (sort keys %trees) {
- if ($output_type eq 'text') {
- printf "%-12s %-6s %-6s %-6s\n", $tree, $host_count{$tree},
- $broken_count{$tree}, $panic_count{$tree};
- } else {
- print $req->start_Tr;
- print $req->td(tree_link($tree));
- print $req->td($host_count{$tree});
- print $req->td($broken_count{$tree});
- if ($panic_count{$tree}) {
- print $req->start_td({-class => "panic"});
- } else {
- print $req->start_td;
- }
- print $panic_count{$tree} . $req->end_td;
- print $req->td($db->lcov_status($tree));
- print $req->end_Tr . "\n";
- }
- }
-
- if ($output_type eq 'text') {
- print "\n";
- } else {
- print $req->end_tbody, $req->end_table;
- print $req->end_div;
- }
-}
-
-##############################################
-# return a link to a particular revision
-sub revision_link($$)
-{
- my ($revision, $tree) = @_;
-
- $revision =~ s/^\s+//g;
- return "0" if ($revision eq "0");
-
- my $rev_short = $revision;
- $rev_short =~ s/(^.{7}).*/$1(git)/ if (length($revision) == 40);
-
- return $req->a({
- -href=>"$myself?function=diff;tree=$tree;revision=$revision",
- -title=>"View Diff for $revision"
- }, $rev_short);
-}
-
-###############################################
-# return a link to a particular tree
-sub tree_link($)
-{
- my ($tree) = @_;
-
- my $branch = "";
- my $t = $trees{$tree};
- if (defined($t)) {
- $branch = ":$t->{branch}";
- }
-
- return $req->a({-href=>"$myself?function=Recent+Builds;tree=$tree",
- -title=>"View recent builds for $tree"},
- "$tree$branch");
-}
-
-##############################################
-# Draw the "recent builds" view
-sub view_recent_builds($$) {
- my ($tree, $sort_by) = @_;
- my $i = 0;
- my $cols = 2;
- my $broken = 0;
- my $host_os;
- my $last_host = "";
- my @all_builds = ();
-
- my $sort = {
- revision => sub { $$b[7] <=> $$a[7] },
- age => sub { $$a[0] <=> $$b[0] },
- host => sub { $$a[2] cmp $$b[2] },
- platform => sub { $$a[1] cmp $$b[1] },
- compiler => sub { $$a[3] cmp $$b[3] },
- status => sub {
- my (@bstat) = build_status_vals($$b[5]);
- my (@astat) = build_status_vals($$a[5]);
-
- # handle panic
- if (defined $bstat[4] && !defined $astat[4]) {
- return 1;
- } elsif (!defined $bstat[4] && defined $astat[4]) {
- return -1;
- }
- return ($bstat[0] <=> $astat[0] || # configure
- $bstat[1] <=> $astat[1] || # compile
- $bstat[2] <=> $astat[2] || # install
- $bstat[3] <=> $astat[3] # test
- );
- }
- };
-
- util::InArray($tree, [keys %trees]) || fatal("not a build tree");
- util::InArray($sort_by, [keys %$sort]) || fatal("not a valid sort");
-
- my $t = $trees{$tree};
-
- for my $host (@hosts) {
- for my $compiler (@compilers) {
- my $status = build_status($host, $tree, $compiler, "");
- my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, "");
- my $age_ctime = $db->build_age_ctime($host, $tree, $compiler, "");
- my $revision = $db->build_revision($host, $tree, $compiler, "");
- my $revision_time = $db->build_revision_time($host, $tree, $compiler, "");
- 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), $revision_time]
- unless $age_mtime == -1;
- }
- }
-
- @all_builds = sort { $sort->{$sort_by}() || $sort->{age}() } @all_builds;
-
- my $sorturl = "$myself?tree=$tree;function=Recent+Builds";
-
- print $req->start_div({-id=>"recent-builds", -class=>"build-section"}),
- $req->h2("Recent builds of $tree ($t->{scm} branch $t->{branch})"),
- $req->start_table({-class => "real"}),
- $req->thead(
- $req->Tr(
- $req->th([
- $req->a({-href => "$sorturl;sortby=age",
- -title => "Sort by build age"}, "Age"),
- $req->a({-href => "$sorturl;sortby=revision",
- -title => "Sort by build revision"},
- "Revision"),
- "Tree",
- $req->a({-href => "$sorturl;sortby=platform",
- -title => "Sort by platform"}, "Platform"),
- $req->a({-href => "$sorturl;sortby=host",
- -title => "Sort by host"}, "Host"),
- $req->a({-href=>"$sorturl;sortby=compiler",
- -title=>"Sort by compiler"}, "Compiler"),
- $req->a({-href=>"$sorturl;sortby=status",
- -title=>"Sort by build status"}, "Status")]
- )
- )),
- $req->start_tbody;
-
- for my $build (@all_builds) {
- print $req->Tr(
- $req->td([util::dhm_time($$build[0]), $$build[6], $$build[4],
- $$build[1], $$build[2], $$build[3], $$build[5]]));
- }
- print $req->end_tbody, $req->end_table;
- print $req->end_div;
-}
-
-##############################################
-# Draw the "dead hosts" table
-sub draw_dead_hosts {
- my $output_type = shift;
- my @deadhosts = @_;
-
- # don't output anything if there are no dead hosts
- return if ($#deadhosts < 0);
-
- # don't include in text report
- return if ($output_type eq 'text');
-
- print $req->start_div({-class => "build-section", -id=>"dead-hosts"}),
- $req->h2('Dead Hosts:'),
- $req->start_table({-class => "real"}),
- $req->thead($req->Tr($req->th(["Host", "OS", "Min Age"]))),
- $req->start_tbody;
-
- for my $host (@deadhosts) {
- my $age_ctime = host_age($host);
- print $req->tr($req->td([$host, $hosts{$host}, util::dhm_time($age_ctime)]));
- }
-
- print $req->end_tbody, $req->end_table;
- print $req->end_div;
-}
-
-##############################################
-# show the available old revisions, if any
-sub show_oldrevs($$$)
-{
- my ($tree, $host, $compiler) = @_;
-
- my @revs = $db->get_old_revs($tree, $host, $compiler);
-
- return if ($#revs < 0);
-
- my $ret = $req->h2("Older builds:");
-
- $ret .= $req->start_table({-class => "real"}).
- $req->thead($req->Tr($req->th(["Revision", "Status"]))).
- $req->start_tbody;
-
- my $lastrev = "";
-
- for my $rev (@revs) {
- my $s = $rev->{STATUS};
- my $revision = $rev->{REVISION};
- $s =~ s/$revision/0/;
- next if ($s eq $lastrev);
- $lastrev = $s;
- $ret.=$req->Tr($req->td([revision_link($revision, $tree), build_link($host, $tree, $compiler,
- $rev->{REVISION}, $rev->{STATUS})]));
- }
- if ($lastrev ne "") {
- # Only print table if there was any actual data
- print $ret . $req->end_tbody, $req->end_table;
- }
-}
-
-##############################################
-# view one build in detail
-sub view_build($$$$) {
- my ($tree, $host, $compiler, $rev) = @_;
- # ensure the params are valid before using them
- util::InArray($host, [keys %hosts]) || fatal("unknown host");
- util::InArray($compiler, \@compilers) || fatal("unknown compiler");
- util::InArray($tree, [keys %trees]) || fatal("not a build tree");
-
- my $uname="";
- my $cflags="";
- my $config="";
- my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, $rev);
- my $revision = $db->build_revision($host, $tree, $compiler, $rev);
- my $status = build_status($host, $tree, $compiler, $rev);
-
- ($rev =~ /^[0-9a-fA-F]*$/) || fatal("bad revision");
-
- my $log = $db->read_log($tree, $host, $compiler, $rev);
- my $err = $db->read_err($tree, $host, $compiler, $rev);
-
- if ($log) {
- $log = escapeHTML($log);
-
- if ($log =~ /(.*)/) { $uname=$1; }
- if ($log =~ /CFLAGS=(.*)/) { $cflags=$1; }
- if ($log =~ /configure options: (.*)/) { $config=$1; }
- }
-
- if ($err) {
- $err = escapeHTML($err);
- }
-
- print $req->h2('Host information:');
-
- print util::FileLoad("../web/$host.html");
-
- print $req->table({-class=>"real"},
- $req->Tr([
- $req->td(["Host:", $req->a({-href=>"$myself?function=View+Host;host=$host;tree=$tree;compiler=$compiler#$host"}, $host)." - $hosts{$host}"]),
- $req->td(["Uname:", $uname]),
- $req->td(["Tree:", tree_link($tree)]),
- $req->td(["Build Revision:", revision_link($revision, $tree)]),
- $req->td(["Build age:", $req->div({-class=>"age"}, red_age($age_mtime))]),
- $req->td(["Status:", $status]),
- $req->td(["Compiler:", $compiler]),
- $req->td(["CFLAGS:", $cflags]),
- $req->td(["configure options:", $config])]));
-
- show_oldrevs($tree, $host, $compiler);
-
- # check the head of the output for our magic string
- my $plain_logs = (defined get_param("plain") &&
- get_param("plain") =~ /^(yes|1|on|true|y)$/i);
- my $rev_var = "";
- if ($rev) {
- $rev_var = ";revision=$rev";
- }
-
- print $req->start_div({-id=>"log"});
-
- if (!$plain_logs) {
- 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"));
-
- print $req->start_div({-id=>"actionList"});
- # These can be pretty wide -- perhaps we need to
- # allow them to wrap in some way?
- if ($err eq "") {
- print $req->h2("No error log available");
- } else {
- print $req->h2("Error log:");
- print make_collapsible_html('action', "Error Output", "\n$err", "stderr-0");
- }
-
- if ($log eq "") {
- print $req->h2("No build log available");
- } else {
- print $req->h2("Build log:");
- print_log_pretty($log);
- }
-
- 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."));
- print $req->end_div;
- } else {
- 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"));
- if ($err eq "") {
- print $req->h2("No error log available");
- } else {
- print $req->h2('Error log:');
- print $req->div({-id=>"errorLog"}, $req->pre($err));
- }
- if ($log eq "") {
- print $req->h2('No build log available');
- }
- else {
- print $req->h2('Build log:');
- print $req->div({-id=>"buildLog"}, $req->pre($log));
- }
- }
-
- print $req->end_div;
-}
-
-##################################################
-# print the host's table of information
-sub view_host {
- my (@requested_hosts) = @_;
-
- my $output_type = "html";
-
- if ($output_type eq 'text') {
- print "Host summary:\n";
- } else {
- print $req->start_div({-class=>"build-section", -id=>"build-summary"});
- print $req->h2('Host summary:');
- }
-
- foreach (@requested_hosts) {
- util::InArray($_, [keys %hosts]) || fatal("unknown host");
- }
-
- for my $host (@requested_hosts) {
- # make sure we have some data from it
- unless($db->has_host($host)) {
- if ($output_type ne 'text') {
- print $req->comment("skipping $host");
- }
- next;
- }
-
- my $row = 0;
-
- for my $compiler (@compilers) {
- for my $tree (sort keys %trees) {
- my $revision = $db->build_revision($host, $tree, $compiler, "");
- my $age_mtime = $db->build_age_mtime($host, $tree, $compiler, "");
- my $age_ctime = $db->build_age_ctime($host, $tree, $compiler, "");
- my $warnings = $db->err_count($host, $tree, $compiler, "");
- if ($age_ctime != -1) {
- my $status = build_status($host, $tree, $compiler, "");
- if ($row == 0) {
- if ($output_type eq 'text') {
- printf "%-12s %-10s %-10s %-10s %-10s\n",
- "Tree", "Compiler", "Build Age", "Status", "Warnings";
-
- } else {
- print $req->start_div({-class=>"host summary"}),
- $req->a({-id=>$host, -name=>$host}),
- $req->h3("$host - $hosts{$host}"),
- $req->start_table({-class=>"real"}),
- $req->thead($req->Tr(
- $req->th(["Target", "Build<br/>Revision", "Build<br />Age", "Status<br />config/build<br />install/test", "Warnings"]))),
- $req->start_tbody;
- }
- }
-
- if ($output_type eq 'text') {
- printf "%-12s %-10s %-10s %-10s %-10s\n",
- $tree, $compiler, util::dhm_time($age_mtime),
- util::strip_html($status), $warnings;
- } else {
- 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]));
- }
- $row++;
- }
- }
- }
- if ($row != 0) {
- if ($output_type eq 'text') {
- print "\n";
- } else {
- print $req->end_tbody, $req->end_table;
- print $req->end_div;
- }
- } else {
- push(@deadhosts, $host);
- }
- }
-
- if ($output_type ne 'text') {
- print $req->end_div;
- }
-
- draw_dead_hosts($output_type, @deadhosts);
-}
-
-sub subunit_to_buildfarm_result($)
-{
- my ($subunit_result) = @_;
- if ($subunit_result eq "success") {
- return "passed";
- } elsif ($subunit_result eq "error") {
- return "error";
- } elsif ($subunit_result eq "skip") {
- return "skipped";
- } elsif ($subunit_result eq "failure") {
- return "failed";
- } elsif ($subunit_result eq "xfail") {
- return "xfailed";
- } else {
- return "unknown";
- }
-}
-
-sub format_subunit_reason($)
-{
- my ($reason) = @_;
-
- $reason =~ s/^\[\n+(.*?)\n+\]$/\1/;
-
- return "<div class=\"reason\">$reason</div>";
-}
-
-##############################################
-# prints the log in a visually appealing manner
-sub print_log_pretty() {
- my $log = shift;
-
- # do some pretty printing for the actions
- my $id = 1;
- $log =~ s{ (
- Running\ action\s+([\w\-]+)
- .*?
- ACTION\ (PASSED|FAILED):\ ([\w\-]+)
- )
- }{ my $output = $1;
- my $actionName = $2;
- my $status = $3;
-
- # handle pretty-printing of static-analysis tools
- if ($actionName eq 'cc_checker') {
- $output = print_log_cc_checker($output);
- }
-
- make_collapsible_html('action', $actionName, $output, $id++,
- $status)
- }exgs;
-
- # $log is already CGI-escaped, so handle '>' in test name by handling >
- $log =~ s{
- --==--==--==--==--==--==--==--==--==--==--.*?
- Running\ test\ ([\w\-=,_:\ /.&;]+).*?
- --==--==--==--==--==--==--==--==--==--==--
- (.*?)
- ==========================================.*?
- TEST\ (FAILED|PASSED|SKIPPED):.*?
- ==========================================\s+
- }{make_collapsible_html('test', $1, $2, $id++, $3)}exgs;
-
- $log =~ s{
- skip-testsuite: ([\w\-=,_:\ /.&; \(\)]+).*?
- }{make_collapsible_html('test', $1, '', $id++, 'skipped')}exgs;
-
-
- $log =~ s{
- testsuite: ([\w\-=,_:\ /.&; \(\)\$]+).*?
- (.*?)
- testsuite-(.*?): [\w\-=,_:\ /.&; \(\)]+( \[.*?\])?.*?
- }{make_collapsible_html('test', $1, $2.format_subunit_reason($4), $id++, subunit_to_buildfarm_result($3))}exgs;
- $log =~ s{
- ^test: ([\w\-=,_:\ /.&; \(\)]+).*?
- (.*?)
- (success|xfail|failure|skip): [\w\-=,_:\ /.&; \(\)]+( \[.*?\])?.*?
- }{make_collapsible_html('test', $1, $2.format_subunit_reason($4), $id++, subunit_to_buildfarm_result($3))}exgs;
-
- print $req->pre($log)."\n";
-}
-
-##############################################
-# generate pretty-printed html for static analysis tools
-sub print_log_cc_checker($) {
- my $input = shift;
- my $output = "";
-
- # for now, we only handle the IBM Checker's output style
- if ($input !~ m/^BEAM_VERSION/ms) {
- return "here";
- return $input;
- }
-
- my $content = "";
- my $inEntry = 0;
-
- my ($entry, $title, $status, $id);
-
- foreach (split /\n/, $input) {
-
- # for each line, check if the line is a new entry,
- # otherwise, store the line under the current entry.
-
- if (m/^-- /) {
- # got a new entry
- if ($inEntry) {
- $output .= make_collapsible_html('cc_checker', $title, $content,
- $id, $status);
- } else {
- $output .= $content;
- }
-
- # clear maintenance vars
- ($inEntry, $content) = (1, "");
-
- # parse the line
- m/^-- ((ERROR|WARNING|MISTAKE).*?)\s+>>>([a-zA-Z0-9]+_(\w+)_[a-zA-Z0-9]+)/;
-
- # then store the result
- ($title, $status, $id) = ("$1 $4", $2, $3);
- } elsif (m/^CC_CHECKER STATUS/) {
- if ($inEntry) {
- $output .= make_collapsible_html('cc_checker', $title, $content,
- $id, $status);
- }
-
- $inEntry = 0;
- $content = "";
- }
-
- # not a new entry, so part of the current entry's output
- $content .= "$_\n";
- }
- $output .= $content;
-
- # This function does approximately the same as the following, following
- # commented-out regular expression except that the regex doesn't quite
- # handle IBM Checker's newlines quite right.
- # $output =~ s{
- # --\ ((ERROR|WARNING|MISTAKE).*?)\s+
- # >>>
- # (.*?)
- # \n{3,}
- # }{make_collapsible_html('cc_checker', "$1 $4", $5, $3, $2)}exgs;
- return $output;
-}
-
-##############################################
-# generate html for a collapsible section
-sub make_collapsible_html
-{
- my $type = shift; # the logical type of it. e.g. "test" or "action"
- my $title = shift; # the title to be displayed
- my $output = shift;
- my $id = shift;
- my $status = (shift or "");
-
- my $icon = ( ($status eq "" || $status =~ /failed/i)) ? 'icon_hide_16.png' : 'icon_unhide_16.png';
-
- # trim leading and trailing whitespace
- $output =~ s/^\s+//s;
- $output =~ s/\s+$//s;
-
- # note that we may be inside a <pre>, so we don't put any extra whitespace in this html
- return $req->div({-class=>"$type unit \L$status\E",
- -id=>"$type-$id"},
- $req->a({-href=>"javascript:handle('$id');"},
- $req->img({-id=>"img-$id", -name=>"img-$id",
- -alt=>$status,
- -src=>$icon}),
- $req->div({-class => "$type title"}, $title),
- ) ." ".
- $req->div({-class=> "$type status \L$status\E"}, $status) .
- $req->div({-class => "$type output", -id=>"output-$id"}, $req->pre($output)));
-}
-
-##############################################
-# main page
-sub main_menu() {
- my %host_labels;
- foreach my $host (@hosts) {
- $host_labels{$host} = "$hosts{$host} -- $host";
- }
-
- my @tree_values = (sort (keys %trees));
- my %tree_labels;
- foreach my $tree (@tree_values) {
- my $t = $trees{$tree};
- $tree_labels{$tree} = "$tree:$t->{branch}";
- }
-
- return $req->startform("GET"),
- $req->start_div({-id=>"build-menu"}),
- $req->popup_menu(-name=>'host',
- -values=>\@hosts,
- -labels=>\%host_labels),
- $req->popup_menu(-name=>'tree',
- -values=>\@tree_values,
- -labels=>\%tree_labels),
- $req->popup_menu("compiler", \@compilers),
- $req->br(),
- $req->submit('function', 'View Build'),
- $req->submit('function', 'View Host'),
- $req->submit('function', 'Recent Checkins'),
- $req->submit('function', 'Summary'),
- $req->submit('function', 'Recent Builds'),
- $req->end_div,
- $req->endform() . "\n";
-}
-
-###############################################
-# display top of page
-sub page_top() {
- cgi_headers();
-}
-
-###############################################
-# main program
-
-my $fn_name = get_param('function') || '';
-
-if ($fn_name eq 'text_diff') {
- print header('application/x-diff');
- $history->diff(get_param('author'),
- get_param('date'),
- get_param('tree'),
- get_param('revision'),
- "text");
-} elsif ($fn_name eq 'Text_Summary') {
- print header('text/plain');
- view_summary('text');
-} else {
- page_top();
-
- if ($fn_name eq "View_Build") {
- view_build(get_param("tree"), get_param("host"), get_param("compiler"),
- get_param('revision'));
- } elsif ($fn_name eq "View_Host") {
- view_host(get_param('host'));
- } elsif ($fn_name eq "Recent_Builds") {
- view_recent_builds(get_param("tree"), get_param("sortby") || "revision");
- } elsif ($fn_name eq "Recent_Checkins") {
- $history->history(get_param('tree'));
- } elsif ($fn_name eq "diff") {
- $history->diff(get_param('author'),
- get_param('date'),
- get_param('tree'),
- get_param('revision'),
- "html");
- } elsif (path_info() ne "" and path_info() ne "/") {
- my @paths = split('/', path_info());
- if ($paths[1] eq "recent") {
- view_recent_builds($paths[2], get_param('sortby') || 'revision');
- } elsif ($paths[1] eq "host") {
- view_host($paths[2]);
- }
- } else {
- view_summary('html');
- }
- cgi_footers();
-}
+++ /dev/null
-#!/usr/bin/perl -w
-# Simple database query script for the buildfarm
-#
-# Copyright (C) Andrew Tridgell <tridge@samba.org> 2001-2005
-# Copyright (C) Andrew Bartlett <abartlet@samba.org> 2001
-# Copyright (C) Vance Lankhaar <vance@samba.org> 2002-2005
-# Copyright (C) Martin Pool <mbp@samba.org> 2001
-# Copyright (C) Jelmer Vernooij <jelmer@samba.org> 2007
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-package data;
-
-use util;
-use POSIX;
-use File::stat;
-use CGI qw/:standard/;
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw();
-
-use strict;
-use warnings;
-
-sub new($;$) {
- my ($this, $basedir, $readonly) = @_;
-
- return undef if not (-d $basedir);
- $readonly = 0 unless defined($readonly);
-
- my $webdir = "$basedir/web";
- return undef if not (-d $webdir);
-
- my $datadir = "$basedir/data";
- return undef if not (-d $datadir);
-
- my $cachedir = "$basedir/cache";
- return undef if not (-d $cachedir);
-
- my $lcovdir = "$basedir/lcov/data";
- return undef if not (-d $lcovdir);
-
- my $lcovhost = "magni";
-
- my @compilers = util::load_list("$webdir/compilers.list");
- my (%hosts) = util::load_hash("$webdir/hosts.list");
- my @hosts = sort { $hosts{$a} cmp $hosts{$b} } keys %hosts;
-
- my (%trees) = (
- 'ccache' => {
- 'scm' => 'git',
- 'repo' => 'ccache',
- 'branch' => 'master',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'ccache-maint' => {
- 'scm' => 'git',
- 'repo' => 'ccache',
- 'branch' => 'maint',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'ppp' => {
- 'scm' => 'git',
- 'repo' => 'ppp',
- 'branch' => 'master',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'build_farm' => {
- 'scm' => 'svn',
- 'repo' => 'build-farm',
- 'branch' => 'trunk',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'samba-web' => {
- 'scm' => 'svn',
- 'repo' => 'samba-web',
- 'branch' => 'trunk',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'samba-docs' => {
- 'scm' => 'svn',
- 'repo' => 'samba-docs',
- 'branch' => 'trunk',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'lorikeet' => {
- 'scm' => 'svn',
- 'repo' => 'lorikeeet',
- 'branch' => 'trunk',
- 'subdir' => '',
- 'srcdir' => ''
- },
- 'samba_3_current' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'v3-5-test',
- 'subdir' => '',
- 'srcdir' => 'source'
- },
- 'samba_3_next' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'v3-6-test',
- 'subdir' => '',
- 'srcdir' => 'source'
- },
- 'samba_3_master' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => '',
- 'srcdir' => 'source'
- },
- 'samba_4_0_test' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => '',
- 'srcdir' => 'source4'
- },
- 'libreplace' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => 'lib/replace/',
- 'srcdir' => ''
- },
- 'talloc' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => 'lib/talloc/',
- 'srcdir' => ''
- },
- 'tdb' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => 'lib/tdb/',
- 'srcdir' => ''
- },
- 'ldb' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => 'lib/ldb/',
- 'srcdir' => ''
- },
- 'pidl' => {
- 'scm' => 'git',
- 'repo' => 'samba.git',
- 'branch' => 'master',
- 'subdir' => 'pidl/',
- 'srcdir' => ''
- },
- 'rsync' => {
- 'scm' => 'git',
- 'repo' => 'rsync.git',
- 'branch' => 'HEAD',
- 'subdir' => '',
- 'srcdir' => ''
- }
- );
-
- my $self = {
- basedir => $basedir,
- webdir => $webdir,
- datadir => $datadir,
- cachedir => $cachedir,
- lcovdir => $lcovdir,
- lcovhost => $lcovhost,
-
- readonly => $readonly,
-
- compilers => \@compilers,
- hosts_hash => \%hosts,
- hosts_list => \@hosts,
- trees => \%trees,
- OLDAGE => 60*60*4,
- DEADAGE => 60*60*24*4
- };
-
- bless $self;
- return $self;
-}
-
-sub cache_fname($$$$$)
-{
- my ($self, $tree, $host, $compiler, $rev) = @_;
- if ($rev) {
- return "$self->{cachedir}/build.$tree.$host.$compiler-$rev";
- }
- return "$self->{cachedir}/build.$tree.$host.$compiler";
-}
-
-################################
-# get the name of the build file
-sub build_fname($$$$$)
-{
- my ($self, $tree, $host, $compiler, $rev) = @_;
- if ($rev) {
- return "$self->{datadir}/oldrevs/build.$tree.$host.$compiler-$rev";
- }
- return "$self->{datadir}/upload/build.$tree.$host.$compiler";
-}
-
-###################
-# the mtime age is used to determine if builds are still happening
-# on a host.
-# the ctime age is used to determine when the last real build happened
-
-##############################################
-# get the age of build from mtime
-sub build_age_mtime($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
- my $file=$self->build_fname($tree, $host, $compiler, $rev);
- my $age = -1;
- my $st;
-
- $st = stat("$file.log");
- if ($st) {
- $age = time() - $st->mtime;
- }
-
- return $age;
-}
-
-##############################################
-# get the age of build from ctime
-sub build_age_ctime($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
- my $file = $self->build_fname($tree, $host, $compiler, $rev);
- my $age = -1;
- my $st;
-
- $st = stat("$file.log");
- if ($st) {
- $age = time() - $st->ctime;
- }
-
- return $age;
-}
-
-##############################################
-# get the svn revision of build
-sub build_revision_details($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
- my $file = $self->build_fname($tree, $host, $compiler, $rev);
- my $cachef = $self->cache_fname($tree, $host, $compiler, $rev);
- my $log;
- my $ret = 0;
-
- # don't fast-path for trees with git repository:
- # we get the timestamp as rev and want the details
- if ($rev) {
- my %trees = %{$self->{trees}};
- my $t = $trees{$tree};
- return $rev unless defined($t);
- return $rev unless $t->{scm} eq "git";
- }
-
- my $st1 = stat("$file.log");
-
- if (!$st1) {
- return $ret;
- }
- my $st2 = stat("$cachef.revision");
-
- # the ctime/mtime asymmetry is needed so we don't get fooled by
- # the mtime update from rsync
- if ($st1 && $st2 && $st1->ctime <= $st2->mtime) {
- return util::FileLoad("$cachef.revision");
- }
-
- $log = util::FileLoad("$file.log");
-
- if ($log =~ /BUILD COMMIT REVISION: (.*)/) {
- $ret = $1;
- } elsif ($log =~ /BUILD REVISION: (.*)/) {
- $ret = $1;
- }
-
- if ($log =~ /BUILD COMMIT TIME: (.*)/) {
- $ret .= ":".$1;
- }
-
- util::FileSave("$cachef.revision", $ret) unless $self->{readonly};
-
- return $ret;
-}
-
-sub build_revision($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
-
- my $r = $self->build_revision_details($host, $tree, $compiler, $rev);
-
- $r =~ s/:.*//;
-
- return $r;
-}
-
-sub build_revision_time($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
-
- my $r = $self->build_revision_details($host, $tree, $compiler, $rev);
-
- $r =~ s/^[^:]*://;
-
- return $r;
-}
-
-##############################################
-# get status of build
-sub build_status_from_logs($$)
-{
- my ($self, $log, $err) = @_;
- my ($cstatus, $bstatus, $istatus, $tstatus, $sstatus, $dstatus, $tostatus);
- $cstatus = $bstatus = $istatus = $tstatus = $sstatus = $dstatus = $tostatus =
- span({-class=>"status unknown"}, "?");
-
-
- sub span_status($)
- {
- my $st = shift;
- if ($st == 0) {
- return span({-class=>"status passed"}, "ok");
- } else {
- return span({-class=>"status failed"}, $st);
- }
- }
-
- if ($log =~ /ACTION FAILED: test/) {
- $tstatus = span_status(255);
- }
-
- if ($log =~ /TEST STATUS:(.*)/) {
- $tstatus = span_status($1);
- } elsif ($log =~ /ACTION (PASSED|FAILED): test/) {
- my $test_failures = 0;
- $test_failures++ while $log =~ m/testsuite-(failure|error): /g;
- my $test_successes = 0;
- $test_successes++ while $log =~ m/testsuite-success: /g;
- if ($test_successes > 0) {
- $tstatus = span_status($test_failures);
- } else {
- $tstatus = span_status(255);
- }
- }
-
- if ($log =~ /INSTALL STATUS:(.*)/) {
- $istatus = span_status($1);
- }
-
- if ($log =~ /BUILD STATUS:(.*)/) {
- $bstatus = span_status($1);
- }
-
- if ($log =~ /CONFIGURE STATUS:(.*)/) {
- $cstatus = span_status($1);
- }
-
- if ($log =~ /(PANIC|INTERNAL ERROR):.*/ ) {
- $sstatus = "/".span({-class=>"status panic"}, "PANIC");
- } else {
- $sstatus = "";
- }
-
- if ($err =~ /No space left on device.*/ ) {
- $dstatus = "/".span({-class=>"status failed"}, "disk full");
- } elsif ($log =~ /No space left on device.*/ ) {
- $dstatus = "/".span({-class=>"status failed"}, "disk full");
- } else {
- $dstatus = "";
- }
-
- if ($log =~ /maximum runtime exceeded.*/ ) {
- $tostatus = "/".span({-class=>"status failed"}, "timeout");
- } else {
- $tostatus = "";
- }
-
- if ($log =~ /CC_CHECKER STATUS: (.*)/ && $1 > 0) {
- $sstatus .= "/".span({-class=>"status checker"}, $1);
- }
-
- return "$cstatus/$bstatus/$istatus/$tstatus$sstatus$dstatus$tostatus";
-}
-
-##############################################
-# get status of build
-sub build_status($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
- my $file = $self->build_fname($tree, $host, $compiler, $rev);
- my $cachefile = $self->cache_fname($tree, $host, $compiler, $rev).".status";
- my $st1 = stat("$file.log");
- if (!$st1) {
- return "Unknown Build";
- }
- my $st2 = stat($cachefile);
-
- if ($st1 && $st2 && $st1->ctime <= $st2->mtime) {
- return util::FileLoad($cachefile);
- }
-
- my $log = util::FileLoad("$file.log");
- my $err = util::FileLoad("$file.err");
- $err = "" unless defined($err);
-
- my $ret = $self->build_status_from_logs($log, $err);
-
- util::FileSave("$cachefile", $ret) unless $self->{readonly};
-
- return $ret;
-}
-
-#####################################t#
-# find the build status as an perl object
-# the 'value' gets one point for passing each stage
-sub build_status_info_from_string($$$)
-{
- my ($self, $rev_seq, $rev, $status_raw) = @_;
- my @status_split = split("/", $status_raw);
- my $status_str = "";
- my @status_arr = ();
- my $status_val = 0;
- my $status = undef;
-
- foreach my $r (@status_split) {
- $r =~ s/^\s+//;
- $r =~ s/\s+$//;
-
- my $e;
- if ($r eq "ok") {
- $e = 0;
- } elsif ($r =~ /(\d+)/) {
- $e = $1;
- $e = 1 unless defined($e);
- $e = 1 unless $e > 0;
- } else {
- $e = 1;
- }
-
- $status_str .= "/" unless $status_str eq "";
- $status_str .= $r;
-
- $status_val += $e;
-
- push(@status_arr, $e);
- }
-
- $status->{rev} = $rev;
- $status->{rev_seq} = $rev_seq;
- $status->{array} = \@status_arr;
- $status->{string} = $status_str;
- $status->{value} = $status_val;
-
- return $status;
-}
-
-#####################################t#
-# find the build status as an perl object
-# the 'value' gets one point for passing each stage
-sub build_status_info_from_html($$$)
-{
- my ($self, $rev_seq, $rev, $status_html) = @_;
- my $status_raw = util::strip_html($status_html);
- return $self->build_status_info_from_string($rev_seq, $rev, $status_raw);
-}
-
-#####################################t#
-# find the build status as an perl object
-# the 'value' gets one point for passing each stage
-sub build_status_info($$$$)
-{
- my ($self, $host, $tree, $compiler, $rev_seq) = @_;
- my $rev = $self->build_revision($host, $tree, $compiler, $rev_seq);
- my $status_html = $self->build_status($host, $tree, $compiler, $rev_seq);
- return $self->build_status_info_from_html($rev_seq, $rev, $status_html)
-}
-
-sub status_info_cmp($$$)
-{
- my ($self, $s1, $s2) = @_;
- my @a1 = @{$s1->{array}};
- my @a2 = @{$s2->{array}};
- my $c1 = 0;
- my $c2 = 0;
-
- for (my $i = 0; ; $i++) {
- $c1++ if defined($a1[$i]);
- $c2++ if defined($a2[$i]);
- last unless defined($a1[$i]);
- last unless defined($a2[$i]);
-
- return $c2 - $c1 if ($c1 != $c2);
-
- return $a2[$i] - $a1[$i] if ($a1[$i] != $a2[$i]);
- }
-
- return $s2->{value} - $s1->{value};
-}
-
-##############################################
-# get status of build
-sub lcov_status($$)
-{
- my ($self, $tree) = @_;
- my $cachefile="$self->{cachedir}/lcov.$self->{lcovhost}.$tree.status";
- my $file = "$self->{lcovdir}/$self->{lcovhost}/$tree/index.html";
- my $st1 = stat($file);
- if (!$st1) {
- return "";
- }
- my $st2 = stat($cachefile);
-
- if ($st1 && $st2 && $st1->ctime <= $st2->mtime) {
- return util::FileLoad($cachefile);
- }
-
- my $ret;
- my $lcov_html = util::FileLoad($file);
- if ($lcov_html =~ /\<td class="headerItem".*?\>Code\ \;covered\:\<\/td\>.*?\n.*?\<td class="headerValue".*?\>([0-9.]+) \%/) {
- $ret = '<a href="/lcov/data/'."$self->{lcovhost}/$tree\">$1 %</a>";
- } else {
- $ret = "";
- }
- util::FileSave("$cachefile", $ret) unless $self->{readonly};
- return $ret;
-}
-
-##############################################
-# get status of build
-sub err_count($$$$$)
-{
- my ($self, $host, $tree, $compiler, $rev) = @_;
- my $file = $self->build_fname($tree, $host, $compiler, $rev);
- my $cachef = $self->cache_fname($tree, $host, $compiler, $rev);
- my $err;
-
- my $st1 = stat("$file.err");
- if ($st1) {
- return 0;
- }
- my $st2 = stat("$cachef.errcount");
-
- if ($st1 && $st2 && $st1->ctime <= $st2->mtime) {
- return util::FileLoad("$cachef.errcount");
- }
-
- $err = util::FileLoad("$file.err") or return 0;
-
- my $ret = util::count_lines($err);
-
- util::FileSave("$cachef.errcount", "$ret") unless $self->{readonly};
-
- return $ret;
-}
-
-##############################################
-# read full log file
-sub read_log($$$$$)
-{
- my ($self, $tree, $host, $compiler, $rev) = @_;
-
- return util::FileLoad($self->build_fname($tree, $host, $compiler, $rev).".log");
-}
-
-##############################################
-# read full err file
-sub read_err($$$$$)
-{
- my ($self, $tree, $host, $compiler, $rev) = @_;
-
- return util::FileLoad($self->build_fname($tree, $host, $compiler, $rev).".err");
-}
-
-###########################################
-# get a list of old builds and their status
-sub get_old_revs($$$$)
-{
- my ($self, $tree, $host, $compiler) = @_;
-
- my $directory = $self->{datadir}."/oldrevs";
- opendir(DIR, $directory) || die "can't opendir $directory: $!";
- my @list = (grep { /^build\.$tree\.$host\.$compiler-.*\.log$/ } readdir(DIR));
- closedir DIR;
- my @ret;
- for my $l (@list) {
- if ($l =~ /-([0-9A-Fa-f]+).log$/) {
- my $rev = $1;
- my $r;
- my $stat = stat($directory . "/" . $l);
- # skip the current build
- $stat->nlink == 2 && next;
- $r->{STATUS} = $self->build_status($host, $tree, $compiler, $rev);
- $r->{REVISION} = $rev;
- $r->{TIMESTAMP} = $stat->ctime;
- push(@ret, $r);
- }
- }
-
- @ret = sort { return $b->{TIMESTAMP} - $a->{TIMESTAMP} } @ret;
-
- return @ret;
-}
-
-sub has_host($$)
-{
- my ($self, $host) = @_;
- my $directory = $self->{datadir}."/upload";
- opendir(DIR, $directory) || die "can't opendir $directory: $!";
- if (grep { /$host/ } readdir(DIR)) {
- return 1;
- } else {
- return 0;
- }
-}
-
-1;
+++ /dev/null
-# Copyright (C) Andrew Tridgell <tridge@samba.org> 2001
-# Copyright (C) Martin Pool <mbp@samba.org> 2003
-# script to show recent checkins in cvs / svn / git
-
-package history;
-
-use util;
-use POSIX;
-use Data::Dumper;
-use CGI qw/:standard/;
-use File::stat;
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw();
-
-use strict;
-use warnings;
-
-my $BASEDIR = "/home/build/master";
-my $HISTORYDIR = "/home/build/master/cache";
-my $TIMEZONE = "PST";
-my $TIMEOFFSET = 0;
-my $unpacked_dir = "/home/ftp/pub/unpacked";
-
-my $CVSWEB_BASE = "http://pserver.samba.org/cgi-bin/cvsweb";
-my $VIEWCVS_BASE = "http://websvn.samba.org/cgi-bin/viewcvs.cgi";
-my $UNPACKED_BASE = "http://svn.samba.org/ftp/unpacked";
-my $GITWEB_BASE = "http://gitweb.samba.org";
-
-sub new($$) {
- my ($this, $req, $db) = @_;
-
- my $self = {
- 'req' => $req,
- 'db' => $db,
- 'url' => $req->url()
- };
-
- bless $self;
- return $self;
-}
-
-################################################
-# print an error on fatal errors
-sub fatal($$) {
- my ($self, $msg) = @_;
- print "ERROR: $msg<br />\n";
- cgi_footers();
- exit(0);
-}
-
-################################################
-# get a param from the request, after sanitizing it
-sub get_param($$) {
- my ($self, $param) = @_;
- my $result;
-
- my $req = $self->{req};
-
- $result = $req->param($param);
- return undef unless defined($result);
-
- $result =~ s/ /_/g; # fn_name ha
-
- if ($result =~ m/[^a-zA-Z0-9\-]/) {
- $self->fatal("Parameter $param is invalid");
- return undef;
- }
-
- return $result;
-}
-
-
-###############################################
-# pretty up a cvs diff -u
-sub diff_pretty($$)
-{
- my ($self, $diff) = @_;;
- my $ret = "";
- my @lines = split(/$/m, $diff);
-
- my %line_types = (
- '^diff.*' => 'diff_diff',
- '^=.*' => 'diff_separator',
- '^Index:.*' => 'diff_index',
- '^index.*' => 'diff_index',
- '^\-.*' => 'diff_removed',
- '^\+.*' => 'diff_added',
- '^@@.*' => 'diff_fragment_header'
- );
-
- foreach my $line (@lines) {
- for my $r (keys %line_types) {
- if ($line =~ /$r/m) {
- $line = "<span class=\"$line_types{$r}\">$line</span>";
- last;
- }
- }
- $ret .= $line;
- }
-
- return $ret;
-}
-
-###############################################
-# change the given source paths into links
-sub web_paths($$$)
-{
- my ($self, $tree, $paths) = @_;
- my $ret = "";
-
- my %trees = %{$self->{db}->{trees}};
- my $t = $trees{$tree};
-
- return $paths unless defined($t);
-
- my $fmt = undef;
-
- if ($t->{scm} eq "cvs") {
- $fmt = " <a href=\"$CVSWEB_BASE/$t->{repo}/%s\">%s</a>";
- } elsif ($t->{scm} eq "svn") {
- $fmt = " <a href=\"$VIEWCVS_BASE/$t->{branch}/%s?root=$t->{repo}\">%s</a>";
- } elsif ($t->{scm} eq "git") {
- my $r = $t->{repo};
- my $s = $t->{subdir};
- my $b = $t->{branch};
- $fmt = " <a href=\"$GITWEB_BASE/?p=$r;a=history;f=$s%s;h=$b;hb=$b\">%s</a>";
- } else {
- return $paths;
- }
-
- while ($paths =~ /\s*([^\s]+)(.*)/) {
- $ret .= sprintf($fmt, $1, $1);
- $paths = $2;
- }
-
- return $ret;
-}
-
-#############################################
-# show one row of history table
-sub history_row($$$)
-{
- my ($self, $entry, $tree) = @_;
- my $msg = escapeHTML($entry->{MESSAGE});
- my $t = POSIX::asctime(POSIX::gmtime($entry->{DATE}));
- my $age = util::dhm_time(time()-$entry->{DATE});
-
- $t =~ s/\ / /g;
-
- print "
-<div class=\"history_row\">
- <div class=\"datetime\">
- <span class=\"date\">$t</span><br />
- <span class=\"age\">$age ago</span>";
- my $revision_url;
- if ($entry->{REVISION}) {
- print " - <span class=\"revision\">$entry->{REVISION}</span><br />";
- $revision_url = "revision=$entry->{REVISION}";
- } else {
- $revision_url = "author=$entry->{AUTHOR}"
- }
- print " </div>
- <div class=\"diff\">
- <span class=\"html\"><a href=\"$self->{url}?function=diff;tree=$tree;date=$entry->{DATE};$revision_url\">show diffs</a></span>
- <br />
- <span class=\"text\"><a href=\"$self->{url}?function=text_diff;tree=$tree;date=$entry->{DATE};$revision_url\">download diffs</a></span>
- <br />
- <div class=\"history_log_message\">
- <pre>$msg</pre>
- </div>
- </div>
- <div class=\"author\">
- <span class=\"label\">Author: </span>$entry->{AUTHOR}
- </div>";
-
- if ($entry->{FILES}) {
- print "<div class=\"files\"><span class=\"label\">Modified: </span>";
- print $self->web_paths($tree, $entry->{FILES});
- print "</div>\n";
- }
-
- if ($entry->{ADDED}) {
- print "<div class=\"files\"><span class=\"label\">Added: </span>";
- print $self->web_paths($tree, $entry->{ADDED});
- print "</div>\n";
- }
-
- if ($entry->{REMOVED}) {
- print "<div class=\"files\"><span class=\"label\">Removed: </span>";
- print $self->web_paths($tree, $entry->{REMOVED});
- print "</div>\n";
- }
-
- print "</div>\n";
-}
-
-
-#############################################
-# show one row of history table
-sub history_row_text($$$)
-{
- my ($self, $entry, $tree) = @_;
- my $msg = escapeHTML($entry->{MESSAGE});
- my $t = POSIX::asctime(POSIX::gmtime($entry->{DATE}));
- my $age = util::dhm_time(time()-$entry->{DATE});
-
- print "Author: $entry->{AUTHOR}\n";
- if ($entry->{REVISION}) {
- print "Revision: $entry->{REVISION}\n";
- }
- print "Modified: $entry->{FILES}\n";
- print "Added: $entry->{ADDED}\n";
- print "Removed: $entry->{REMOVED}\n";
- print "\n\n$msg\n\n\n";
-}
-
-###############################################
-# get recent cvs/svn entries
-sub diff($$$$$$)
-{
- my ($self, $author, $date, $tree, $revision, $text_html) = @_;
-
- # validate the tree
- my %trees = %{$self->{db}->{trees}};
- my $t = $trees{$tree};
- $self->fatal("unknown tree[$tree]") unless defined($t);
-
- if ($t->{scm} eq "cvs") {
- $self->cvs_diff($t, $author, $date, $tree, $text_html);
- } elsif ($t->{scm} eq "svn") {
- $self->svn_diff($t, $revision, $tree, $text_html);
- } elsif ($t->{scm} eq "git") {
- $self->git_diff($t, $revision, $tree, $text_html);
- }
-}
-
-###############################################
-# show recent svn entries
-sub svn_diff($$$$$)
-{
- my ($self, $t, $revision, $tree, $text_html) = @_;
-
- chdir("$unpacked_dir/$tree") or $self->fatal("no tree $unpacked_dir/$tree available");
-
- # determine the most recent version known to this database
- my ($current_revision) = grep {/^Revision/} `svn info`;
- chomp $current_revision;
- $current_revision =~ s/.*?(\d+)$/$1/;
-
- if ($revision !~ /^\d+$/ or $revision < 0 or $revision > $current_revision) {
- $self->fatal("unknown revision[$revision]");
- }
-
- my $log = util::LoadStructure("$HISTORYDIR/history.$tree");
- my $entry = undef;
-
- # backwards? why? well, usually our users are looking for the newest
- # stuff, so it's most likely to be found sooner
- my $i = $#{$log};
- for (; $i >= 0; $i--) {
- if ($log->[$i]->{REVISION} eq $revision) {
- $entry = $log->[$i];
- last;
- }
- }
-
- if (not defined($entry)) {
- print "Unable to locate commit information revision[$revision].\n";
- return;
- }
-
- # get information about the current diff
- if ($text_html eq "html") {
- print "<h2>SVN Diff in $tree:$t->{branch} for revision r$revision</h2>\n";
- print "<div class=\"history row\">\n";
-
- $self->history_row($entry, $tree);
-
- print "</div>\n";
- } else {
- $self->history_row_text($entry, $tree);
- }
-
- my $old_revision = $revision - 1;
- my $cmd = "svn diff -r $old_revision:$revision";
-
- my $diff = `$cmd 2> /dev/null`;
-
- if ($text_html eq "html") {
- print "<!-- $cmd -->\n";
- $diff = escapeHTML($diff);
- $diff = $self->diff_pretty($diff);
- print "<pre>$diff</pre>\n";
- } else {
- print "$diff\n";
- }
-}
-
-###############################################
-# show recent cvs entries
-sub cvs_diff($$$$$$)
-{
- my ($self, $t, $author, $date, $tree, $text_html) = @_;
-
- chdir("$unpacked_dir/$tree") or $self->fatal("no tree $unpacked_dir/$tree available");
-
- my $log = util::LoadStructure("$HISTORYDIR/history.$tree");
-
- # for paranoia, check that the date string is a valid date
- if ($date =~ /[^\d]/) {
- $self->fatal("unknown date");
- }
-
- my $entry = undef;
-
- for (my $i=0; $i <= $#{$log}; $i++) {
- if ($author eq $entry->{AUTHOR} &&
- $date == $entry->{DATE}) {
- $entry = $log->[$i];
- last;
- }
- }
-
- if (not defined($entry)) {
- print "Unable to locate commit information author[$author] data[$date].\n";
- return;
- }
-
- my $t1;
- my $t2;
-
- chomp($t1 = POSIX::ctime($date-60+($TIMEOFFSET*60*60)));
- chomp($t2 = POSIX::ctime($date+60+($TIMEOFFSET*60*60)));
-
- if ($text_html eq "html") {
- print "<h2>CVS Diff in $tree:$t->{branch} for $t1</h2>\n";
- $self->history_row($entry, $tree);
- } else {
- $self->history_row_text($entry, $tree);
- }
-
- if (! ($entry->{TAG} eq "") && !$entry->{REVISIONS}) {
- print '
-<br />
-<b>sorry, cvs diff on branches not currently possible due to a limitation
-in cvs</b>
-<br />';
- }
-
- $ENV{'CVS_PASSFILE'} = "$BASEDIR/.cvspass";
-
- if ($entry->{REVISIONS}) {
- for my $f (keys %{$entry->{REVISIONS}}) {
- my $cmd;
- my $diff;
- if ($entry->{REVISIONS}->{$f}->{REV1} eq "NONE") {
- $cmd = "cvs rdiff -u -r 0 -r $entry->{REVISIONS}->{$f}->{REV2} $f";
- } elsif ($entry->{REVISIONS}->{$f}->{REV2} eq "NONE") {
- $cmd = "cvs rdiff -u -r $entry->{REVISIONS}->{$f}->{REV1} -r 0 $f";
- } elsif ($text_html eq "html") {
- $cmd = "cvs diff -b -u -r $entry->{REVISIONS}->{$f}->{REV1} -r $entry->{REVISIONS}->{$f}->{REV2} $f";
- } else {
- $cmd = "cvs diff -u -r $entry->{REVISIONS}->{$f}->{REV1} -r $entry->{REVISIONS}->{$f}->{REV2} $f";
- }
-
- $diff = `$cmd 2> /dev/null`;
- if ($text_html eq "html") {
- print "<!-- $cmd -->\n";
- $diff = escapeHTML($diff);
- $diff = $self->diff_pretty($diff);
- print "<pre>$diff</pre>\n";
- } else {
- print "$diff\n";
- }
- }
- } else {
- my $cmd;
- if ($text_html eq "html") {
- $cmd = "cvs diff -b -u -D \"$t1 $TIMEZONE\" -D \"$t2 $TIMEZONE\" $entry->{FILES}";
- } else {
- $cmd = "cvs diff -u -D \"$t1 $TIMEZONE\" -D \"$t2 $TIMEZONE\" $entry->{FILES}";
- }
-
- my $diff = `$cmd 2> /dev/null`;
-
- if ($text_html eq "html") {
- print "<!-- $cmd -->\n";
- $diff = escapeHTML($diff);
- $diff = $self->diff_pretty($diff);
- print "<pre>$diff</pre>\n";
- } else {
- print "$diff\n";
- }
- }
-}
-
-###############################################
-# show recent git entries
-sub git_diff($$$$$)
-{
- my ($self, $t, $revision, $tree, $text_html) = @_;
-
- chdir("$unpacked_dir/$tree") or $self->fatal("no tree $unpacked_dir/$tree available");
-
- my $log = util::LoadStructure("$HISTORYDIR/history.$tree");
- my $entry = undef;
-
- # backwards? why? well, usually our users are looking for the newest
- # stuff, so it's most likely to be found sooner
- for (my $i = $#{$log}; $i >= 0; $i--) {
- if ($log->[$i]->{REVISION} eq $revision) {
- $entry = $log->[$i];
- last;
- }
- }
-
- if (not defined($entry)) {
- print "Unable to locate commit information revision[$revision].\n";
- return;
- }
-
- # get information about the current diff
- if ($text_html eq "html") {
- print "<h2>GIT Diff in $tree:$t->{branch} for revision $revision</h2>\n";
- print "<div class=\"history row\">\n";
-
- $self->history_row($entry, $tree);
-
- print "</div>\n";
- } else {
- $self->history_row_text($entry, $tree);
- }
-
- my $cmd = "git diff $revision^ $revision ./";
-
- my $diff = `$cmd 2> /dev/null`;
-
- if ($text_html eq "html") {
- print "<!-- $cmd -->\n";
- $diff = escapeHTML($diff);
- $diff = $self->diff_pretty($diff);
- print "<pre>$diff</pre>\n";
- } else {
- print "$diff\n";
- }
-}
-
-###############################################
-# get commit history for the given tree
-sub history($$)
-{
- my ($self, $tree) = @_;
- my (%authors) = ('ALL' => 1);
- my $author;
-
- # validate the tree
- my %trees = %{$self->{db}->{trees}};
- my $t = $trees{$tree};
- $self->fatal("unknown tree[$tree]") unless defined($t);
-
- my $log = util::LoadStructure("$HISTORYDIR/history.$tree");
-
- for (my $i=$#{$log}; $i >= 0; $i--) {
- $authors{$log->[$i]->{AUTHOR}} = 1;
- }
-
- my $req = $self->{req};
-
- print "<h2>Recent checkins for $tree ($t->{scm} branch $t->{branch})</h2>\n";
- print $req->startform("GET");
- print "Select Author: ";
- print $req->popup_menu("author", [sort keys %authors]);
- print $req->submit('sub_function', 'Refresh');
- print $req->hidden('tree', $tree);
- print $req->hidden('function', 'Recent Checkins');
- print $req->endform();
- print "\n";
-
- $author = $self->get_param("author");
-
- # what? backwards? why is that? oh... I know... we want the newest first
- for (my $i=$#{$log}; $i >= 0; $i--) {
- my $entry = $log->[$i];
- if (not defined($author) or
- ($author eq "") or
- ($author eq "ALL") or
- ($author eq $entry->{AUTHOR})) {
- $self->history_row($entry, $tree);
- }
- }
- print "\n";
-}
-
-1;
+++ /dev/null
-###################################################
-# utility functions to support the build farm
-# Copyright (C) tridge@samba.org, 2001
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-package util;
-
-use Data::Dumper;
-
-##############################################
-# load a list from a file, using : to separate
-sub load_list($)
-{
- my $fname = shift;
- my @lines;
- open(FH,"<",$fname);
- while (<FH>) {
- chomp;
- push (@lines,$_) unless (/^#/);
- }
- close FH;
- return @lines;
-}
-
-##############################################
-# load a hash from a file, using : to separate
-sub load_hash($)
-{
- my $fname = shift;
- my @lines = load_list($fname);
- my %ret;
- for my $l (@lines) {
- if ($l =~ /^([\w\-]*)\s*:\s*(.*)$/) {
- $ret{$1} = $2;
- }
- }
- return %ret;
-}
-
-#####################################################################
-# check if a string is in an array
-sub InArray($$)
-{
- my ($s, $a) = @_;
- for my $v (@{$a}) {
- return 1 if ($v eq $s);
- }
- return 0;
-}
-
-#####################################################################
-# flatten an array of arrays into a single array
-sub FlattenArray($)
-{
- my $a = shift;
- my @b;
- for my $d (@{$a}) {
- push(@b, $_) foreach (@{$d});
- }
- return \@b;
-}
-
-#####################################################################
-# flatten an array of hashes into a single hash
-sub FlattenHash($)
-{
- my $a = shift;
- my %b;
- for my $d (@{$a}) {
- for my $k (keys %{$d}) {
- $b{$k} = $d->{$k};
- }
- }
- return \%b;
-}
-
-#####################################################################
-# return the modification time of a file
-sub FileModtime($)
-{
- my($filename) = shift;
- return (stat($filename))[9];
-}
-
-#####################################################################
-# read a file into a string
-sub FileLoad($)
-{
- my($filename) = shift;
- local(*INPUTFILE);
- open(INPUTFILE, $filename) || return "";
- my($saved_delim) = $/;
- undef $/;
- my($data) = <INPUTFILE>;
- close(INPUTFILE);
- $/ = $saved_delim;
- return $data;
-}
-
-#####################################################################
-# write a string into a file
-sub FileSave($$)
-{
- my($filename) = shift;
- my($v) = shift;
- local(*FILE);
- open(FILE, ">$filename") || die "can't open $filename";
- print FILE $v;
- close(FILE);
-}
-
-#####################################################################
-# return a filename with a changed extension
-sub ChangeExtension($$)
-{
- my($fname,$ext) = @_;
- return "$1.$ext" if ($fname =~ /^(.*)\.(.*?)$/);
- return "$fname.$ext";
-}
-
-#####################################################################
-# save a data structure into a file
-sub SaveStructure($$)
-{
- my($filename) = shift;
- my($v) = shift;
- FileSave($filename, Dumper($v));
-}
-
-#####################################################################
-# load a data structure from a file (as saved with SaveStructure)
-sub LoadStructure($)
-{
- return eval FileLoad(shift);
-}
-
-##########################################
-# count the number of lines in a buffer
-sub count_lines($)
-{
- my $s = shift;
- my $count;
- $count++ while $s =~ /$/gm;
- return $count;
-}
-
-################
-# display a time as days, hours, minutes
-sub dhm_time($)
-{
- my $sec = shift;
- my $days = int($sec / (60*60*24));
- my $hour = int($sec / (60*60)) % 24;
- my $min = int($sec / 60) % 60;
-
- my $ret = "";
-
- if ($sec < 0) {
- return "-";
- }
-
- if ($days != 0) {
- return sprintf("%dd %dh %dm", $days, $hour, $min);
- }
- if ($hour != 0) {
- return sprintf("%dh %dm", $hour, $min);
- }
- if ($min != 0) {
- return sprintf("%dm", $min);
- }
- return sprintf("%ds", $sec);
-}
-
-##############################################
-# simple html markup stripper
-sub strip_html($) {
- my $string = shift;
-
- # get rid of comments
- $string =~ s/<!\-\-(.*?)\-\->/$2/g;
-
- # and remove tags.
- while ($string =~ s&<(\w+).*?>(.*?)</\1>&$2&) {
- ;
- }
-
- return $string;
-}
-
-1;
git.samba.org / build-farm.git / commitdiff