Switch over to using python import-and-analyse.
authorJelmer Vernooij <jelmer@samba.org>
Sat, 13 Nov 2010 18:57:47 +0000 (19:57 +0100)
committerJelmer Vernooij <jelmer@samba.org>
Sat, 13 Nov 2010 18:57:47 +0000 (19:57 +0100)
import-and-analyse.pl [deleted file]
revs.sh
tests/hostdb.pl [deleted file]

diff --git a/import-and-analyse.pl b/import-and-analyse.pl
deleted file mode 100755 (executable)
index 84663d1..0000000
+++ /dev/null
@@ -1,407 +0,0 @@
-#!/usr/bin/perl
-# Write sqlite entries for test reports in the build farm
-# Copyright (C) 2007 Jelmer Vernooij <jelmer@samba.org>
-# Published under the GNU GPL
-
-use FindBin qw($RealBin $Script);
-use lib "$RealBin/web";
-use DBI;
-use Digest::SHA1 qw(sha1_hex);
-use strict;
-use util;
-use File::stat;
-use File::Copy;
-use Getopt::Long;
-use hostdb;
-use data;
-use Carp;
-
-my $opt_help = 0;
-my $opt_verbose = 0;
-my $dry_run = 0;
-my $result = GetOptions('help|h|?' => \$opt_help,
-                        'dry-run|n' => sub { $dry_run++; },
-                        'verbose|v' => sub { $opt_verbose++; });
-
-exit(1) unless ($result);
-
-if ($opt_help) {
-       print "$Script [OPTIONS]\n";
-       print "Options:\n";
-       print " --help         This help message\n";
-       print " --verbose      Be verbose\n";
-       print " --dry-run      Dry run\n";
-       exit;
-
-       print <<EOU;
-
-Script to parse build farm log files from the data directory, import
-them into the database, add links to the oldrevs/ directory and send
-some mail chastising the possible culprits when the build fails, based
-on recent commits.
-
--n  Will cause the script to send output to stdout instead of
-    to sendmail.
-EOU
-       exit(1);
-}
-
-my $unpacked_dir = "/home/ftp/pub/unpacked";
-
-# we open readonly here as only apache(www-run) has write access
-my $db = new data($RealBin, 1);
-
-my $hostdb = new hostdb("$RealBin/hostdb.sqlite");
-
-my $dbh = $hostdb->{dbh};
-
-my @compilers = @{$db->{compilers}};
-my @hosts = @{$db->{hosts_list}};
-my %trees = %{$db->{trees}};
-
-sub get_log_svn($$$$$)
-{
-       my ($host, $tree, $compiler, $cur, $old) = @_;
-       my $firstrev = $old->{rev} + 1;
-       my $cmd = "svn log --non-interactive -r $firstrev:$cur->{rev} $unpacked_dir/$tree";
-       my $log = undef;
-
-       $log->{change_log} = `$cmd` || confess "$cmd: failed";
-       #print($log->{change_log});
-
-       # get the list of possible culprits
-       my $log2 = $log->{change_log};
-
-       while ($log2 =~ /\nr\d+ \| (\w+) \|.*?line(s?)\n(.*)$/s) {
-               $log->{committers}->{"$1\@samba.org"} = 1;
-               $log2 = $3;
-       }
-
-       # Add a URL to the diffs for each change
-       $log->{change_log} =~ s/\n(r(\d+).*)/\n$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
-
-       $log->{recipients} = $log->{committers};
-
-       return $log;
-}
-
-sub get_log_git($$$$$)
-{
-       my ($host, $tree, $compiler, $cur, $old) = @_;
-       my $cmd = "cd $unpacked_dir/$tree && git log --pretty=full $old->{rev}..$cur->{rev} ./";
-       my $log = undef;
-
-       $log->{change_log} = `$cmd` || confess "$cmd: failed";
-       #print($log->{change_log});
-
-       # get the list of possible culprits
-       my $log2 = $log->{change_log};
-
-       while ($log2 =~ /[\n]*Author: [^<]*<([^>]+)>\nCommit: [^<]*<([^>]+)>\n(.*)$/s) {
-               my $author = $1;
-               my $committer = $2;
-               $log2 = $3;
-               
-               # handle cherry-picks from svnmirror repo
-               $author =~ s/0c0555d6-39d7-0310-84fc-f1cc0bd64818/samba\.org/;
-               
-               # for now only send reports to samba.org addresses.
-               $author = undef unless $author =~ /\@samba\.org/;
-               # $committer = undef unless $committer =~ /\@samba\.org/;
-
-               $log->{authors}->{$author} = 1 if defined($author);
-               $log->{committers}->{$committer} = 1 if defined($committer);
-       }
-
-       # Add a URL to the diffs for each change
-       $log->{change_log} =~ s/([\n]*commit ([0-9a-f]+))/$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
-
-       my @all = ();
-       push(@all, keys %{$log->{authors}}) if defined($log->{authors});
-       push(@all, keys %{$log->{committers}}) if defined($log->{committers});
-       my $all = undef;
-       foreach my $k (@all) {
-               $all->{$k} = 1;
-       }
-       $log->{recipients} = $all;
-
-       return $log;
-}
-
-sub get_log($$$$$)
-{
-       my ($host, $tree, $compiler, $cur, $old) = @_;
-       my $treedir = "$unpacked_dir/$tree";
-
-       if (-d "$treedir/.svn") {
-               return get_log_svn($host, $tree, $compiler, $cur, $old);
-       } elsif (-d "$treedir/.git") {
-               return get_log_git($host, $tree, $compiler, $cur, $old);
-       }
-
-       return undef;
-}
-
-sub check_and_send_mails($$$$$) 
-{
-    my ($tree, $host, $compiler, $cur, $old) = @_;
-    my $t = $trees{$tree};
-    
-    printf("rev=$cur->{rev} status=$cur->{string}\n") if $dry_run;
-    
-    printf("old rev=$old->{rev} status=$old->{string}\n") if $dry_run;
-    
-    my $cmp = $db->status_info_cmp($old, $cur);
-#printf("cmp: $cmp\n");
-    
-    if ($cmp <= 0) {
-       printf("the build didn't get worse ($cmp)\n") if $dry_run;
-       return unless $dry_run;
-    }
-    
-    my $log = get_log($host, $tree, $compiler, $cur, $old);
-    if (not defined($log)) {
-       printf("no log\n") if $dry_run;
-       return;
-    }
-    
-    my $recipients = undef;
-    $recipients = join(",", keys %{$log->{recipients}}) if defined($log->{recipients});
-    
-    my $subject = "BUILD of $tree:$t->{branch} BROKEN on $host with $compiler AT REVISION $cur->{rev}";
-    
-# send the nastygram
-    if ($dry_run) {
-       print "To: $recipients\n" if defined($recipients);
-       print "Subject: $subject\n";
-       open(MAIL,"|cat");
-    } else {
-       if (defined($recipients)) {
-           open(MAIL,"|Mail -a \"Content-Type: text/plain;charset=utf-8\" -a \"Precedence: bulk\" -s \"$subject\" $recipients");
-       } else {
-           open(MAIL,"|cat >/dev/null");
-       }
-    }
-    
-    my $body = << "__EOF__";
-Broken build for tree $tree on host $host with compiler $compiler
-
-Tree $tree is $t->{scm} branch $t->{branch}.
-
-Build status for new revision $cur->{rev} is $cur->{string}
-Build status for old revision $old->{rev} was $old->{string}
-
-See http://build.samba.org/?function=View+Build;host=$host;tree=$tree;compiler=$compiler
-
-The build may have been broken by one of the following commits:
-
-$log->{change_log}
-__EOF__
-    print MAIL $body;
-
-    close(MAIL);
-}
-
-
-foreach my $host (@hosts) {
-    foreach my $tree (keys %trees) {
-       foreach my $compiler (@compilers) {
-           my $rev;
-           my $commit;
-           my $retry = 0;
-           if ($opt_verbose >= 2) {
-               print "Looking for a log file for $host $compiler $tree...\n";
-           }
-
-           # By building the log file name this way, using only the list of
-           # hosts, trees and compilers as input, we ensure we
-           # control the inputs
-           my $logfn = $db->build_fname($tree, $host, $compiler);
-           my $stat = stat($logfn . ".log");
-           next if (!$stat);
-    
-           if ($opt_verbose >= 2) {
-               print "Processing $logfn...\n";
-           }
-           
-           eval {
-               my $expression = "SELECT checksum FROM build WHERE age >= ? AND tree = ? AND host = ? AND compiler = ?";
-               my $st = $dbh->prepare($expression);
-           
-               $st->execute($stat->ctime, $tree, $host, $compiler);
-           
-               # Don't bother if we've already processed this file
-               my $relevant_rows = $st->fetchall_arrayref();
-               
-               $st->finish();
-
-               if ($#$relevant_rows > -1) {
-                   if ($opt_verbose > 1) {
-                           print "retry relevant_rows=$#$relevant_rows\n";
-                   }
-                   die "next please"; #Moves to the next record in the exception handler
-               }
-           
-               # By reading the log file this way, using only the list of
-               # hosts, trees and compilers as input, we ensure we
-               # control the inputs
-               my $data = util::FileLoad($logfn.".log");
-               
-               # Don't bother with empty logs, they have no meaning (and would all share the same checksum)
-               if (not $data or $data eq "") {
-                   if ($opt_verbose > 1) {
-                           print "retry empty data\n";
-                   }
-                   die "next please"; #Moves to the next record in the exception handler
-               }
-               
-               my $err = util::FileLoad($logfn.".err");
-               $err = "" unless defined($err);
-               
-               my $checksum = sha1_hex($data);
-               if ($dbh->selectrow_array("SELECT checksum FROM build WHERE checksum = '$checksum'")) {
-                   $dbh->do("UPDATE BUILD SET age = ? WHERE checksum = ?", undef, 
-                            ($stat->ctime, $checksum));
-                   if ($opt_verbose > 1) {
-                           print "retry checksum match\n";
-                   }
-                   die "next please"; #Moves to the next record in the exception handler
-               }
-               if ($opt_verbose) { print "$logfn\n"; }
-               
-               ($rev) = ($data =~ /BUILD REVISION: ([^\n]+)/);
-
-               if ($data =~ /BUILD COMMIT REVISION: (.*)/) {
-                   $commit = $1;
-               } else {
-                   $commit = $rev;
-               }
-
-               if ($rev == "") {
-                       $rev = $commit;
-               }
-
-               my $status_html = $db->build_status_from_logs($data, $err);
-
-               if ($opt_verbose > 1) {
-                       print "Found rev=$rev commit=$commit status=$status_html\n";
-               }
-               
-               # Look up the database to find the previous status
-               $st = $dbh->prepare("SELECT status, revision, commit_revision FROM build WHERE tree = ? AND host = ? AND compiler = ? AND revision != ? AND commit_revision != ? ORDER BY id DESC LIMIT 1");
-               $st->execute( $tree, $host, $compiler, $rev, $commit);
-               
-               my $old_status_html;
-               my $old_rev;
-               my $old_commit;
-               while ( my @row = $st->fetchrow_array ) {
-                   $old_status_html = @row[0];
-                   $old_rev = @row[1];
-                   $old_commit = @row[2];
-               }
-
-               if ($opt_verbose > 1) {
-                       print "Old rev=$old_rev old_commit=$commit status=$old_status_html\n";
-               }
-               
-               $st->finish();
-               
-               $st = $dbh->prepare("INSERT INTO build (tree, revision, commit_revision, host, compiler, checksum, age, status) VALUES (?, ?, ?, ?, ?, ?, ?, ?)");
-               $st->execute($tree, $rev, $commit, $host, $compiler, $checksum, $stat->ctime, $status_html);
-
-
-#   SKIP This code, as it creates massive databases, until we get code to use the information, and a way to expire the results
-#          my $build = $dbh->func('last_insert_rowid');
-#          
-#          $st = $dbh->prepare("INSERT INTO test_run (build, test, result, output) VALUES ($build, ?, ?, ?)");
-#          
-#          while ($data =~ /--==--==--==--==--==--==--==--==--==--==--.*?
-#      Running\ test\ ([\w\-=,_:\ \/.&;]+).*?
-#      --==--==--==--==--==--==--==--==--==--==--
-#      (.*?)
-#      ==========================================.*?
-#      TEST\ (FAILED|PASSED|SKIPPED):.*?
-#      ==========================================\s+
-#      /sxg) {
-#              # Note: output is discarded ($2)
-#              $st->execute($1, $3, undef);
-#          }
-
-               $st->finish();
-
-               my $cur_status = $db->build_status_info_from_html($rev, $commit, $status_html);
-               my $old_status;
-               
-               if ($opt_verbose > 1) {
-                       print "cur_status=$cur_status\n";
-               }
-
-               # Can't send a nastygram until there are 2 builds..
-               if (defined($old_status_html)) {
-                   $old_status = $db->build_status_info_from_html($old_rev, $old_commit, $old_status_html);
-                   if ($opt_verbose > 1) {
-                           print "old_status=$old_status\n";
-                   }
-                   check_and_send_mails($tree, $host, $compiler, $cur_status, $old_status);
-               }
-               
-               if ($dry_run) {
-                   $dbh->rollback;
-                   die "next please"; #Moves to the next record in the exception handler
-               }
-
-               if ($opt_verbose > 1) {
-                       print "Committing\n";
-               }
-
-               $dbh->commit;
-           };
-
-           if ($@) {
-               local $dbh->{RaiseError} = 0;
-               $dbh->rollback;
-               
-               if ($@ =~ /^next please/) {
-                   # Ignore errors and hope for better luck next time the script is run
-                   if ($opt_verbose > 1) {
-                       print "next please retry\n";
-                   }               
-                   next;
-               } elsif ($@ =~ /database is locked/ and $retry < 3) {
-                   $retry++;
-                   sleep(1);
-                   redo;
-               }
-               
-               print "Failed to process record for reason: $@";
-               next;
-           }
-
-           if ($commit) {
-               # If we were able to put this into the DB (ie, a
-               # one-off event, so we won't repeat this), then also
-               # hard-link the log files to the revision, if we know
-               # it.
-
-
-               # This ensures that the names under 'oldrev' are well known and well formed 
-               my $log_rev = $db->build_fname($tree, $host, $compiler, $commit) . ".log";
-               my $err_rev = $db->build_fname($tree, $host, $compiler, $commit) . ".err";
-               if ($opt_verbose >= 2) {
-                       print "Linking $logfn to $log_rev\n";
-                       print "Linking $logfn to $err_rev\n";
-               }
-               unlink $log_rev;
-               unlink $err_rev;
-               link($logfn . ".log", $log_rev) || die "Failed to link $logfn to $log_rev";
-
-               # this prevents lots of links building up with err files
-               copy($logfn . ".err", $err_rev) || die "Failed to copy $logfn to $err_rev";
-               unlink($logfn . ".err");
-               link($err_rev, $logfn . ".err");
-           }
-       }
-    }
-}
-
-$dbh->disconnect();
diff --git a/revs.sh b/revs.sh
index ac271ec46d2fdf67560892d81f91e95da9b4413e..e8733d96bcd00b8c65a65182c63f7d76cf6f50b1 100755 (executable)
--- a/revs.sh
+++ b/revs.sh
@@ -5,4 +5,4 @@ export PATH=$PATH:/usr/local/bin
 ulimit -v 300000
 ulimit -m 300000
 
-./import-and-analyse.pl
+./import-and-analyse.py
diff --git a/tests/hostdb.pl b/tests/hostdb.pl
deleted file mode 100755 (executable)
index f897945..0000000
+++ /dev/null
@@ -1,74 +0,0 @@
-#!/usr/bin/perl
-# Samba.org buildfarm
-# Copyright (C) 2008 Andrew Bartlett <abartlet@samba.org>
-# Copyright (C) 2008 Jelmer Vernooij <jelmer@samba.org>
-#   
-# 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 3 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, see <http://www.gnu.org/licenses/>.
-#
-
-
-use FindBin qw($RealBin);
-
-use lib "$RealBin/..";
-use lib "$RealBin/../web";
-
-use Test::More tests => 15;
-use strict;
-use hostdb;
-use warnings;
-use strict;
-
-# make sure that provisioning adds the right table.
-my $db = new hostdb("dbname=:memory:");
-ok($db->provision());
-is_deeply([], $db->{dbh}->selectall_arrayref("SELECT * FROM host"));
-
-ok($db->createhost("gwalcmai", "vax", "jelmer", "jelmer\@example.com", "geheim", "Yo! Please put me on the buildfarm"));
-
-is_deeply([["gwalcmai"]], $db->{dbh}->selectall_arrayref("SELECT name FROM host"));
-
-my $expected_host = { name => "gwalcmai", owner => "jelmer", owner_email => "jelmer\@example.com", 
-             platform => "vax", permission => 'Yo! Please put me on the buildfarm', fqdn => undef,
-             password => "geheim", ssh_access => undef, join_time => time(), last_dead_mail => undef };
-
-is_deeply($db->hosts(), [$expected_host]);
-
-is_deeply($db->host("gwalcmai"), $expected_host);
-
-is(undef, $db->host("foo"));
-
-is("gwalcmai: vax\n", $db->create_hosts_list());
-
-is("# rsyncd.secrets file\n" . 
-   "# automatically generated by textfiles.pl. DO NOT EDIT!\n\n" .
-   "# gwalcmai, owner: jelmer <jelmer\@example.com>\n" . 
-   "gwalcmai:geheim\n\n", $db->create_rsync_secrets());
-
-ok($db->update_platform("gwalcmai", "s390")); 
-
-$expected_host->{platform} = "s390";
-
-is_deeply($expected_host, $db->host("gwalcmai"));
-
-ok($db->update_owner("gwalcmai", "Andrew", "abartlet\@example.com"));
-
-$expected_host->{owner} = "Andrew";
-$expected_host->{owner_email} = "abartlet\@example.com";
-
-is_deeply($expected_host, $db->host("gwalcmai"));
-
-ok($db->deletehost("gwalcmai"));
-is_deeply([], $db->{dbh}->selectall_arrayref("SELECT name FROM host"));
-
-1;