2 # Write sqlite entries for test reports in the build farm
3 # Copyright (C) 2007 Jelmer Vernooij <jelmer@samba.org>
4 # Published under the GNU GPL
6 use FindBin qw($RealBin $Script);
7 use lib "$RealBin/web";
9 use Digest::SHA1 qw(sha1_hex);
22 my $result = GetOptions('help|h|?' => \$opt_help,
23 'dry-run|n' => sub { $dry_run++; },
24 'verbose|v' => sub { $opt_verbose++; });
26 exit(1) unless ($result);
29 print "$Script [OPTIONS]\n";
31 print " --help This help message\n";
32 print " --verbose Be verbose\n";
33 print " --dry-run Dry run\n";
38 Script to parse build farm log files from the data directory, import
39 them into the database, add links to the oldrevs/ directory and send
40 some mail chastising the possible culprits when the build fails, based
43 -n Will cause the script to send output to stdout instead of
49 my $unpacked_dir = "/home/ftp/pub/unpacked";
51 # we open readonly here as only apache(www-run) has write access
52 my $db = new data($RealBin, 1);
54 my $hostdb = new hostdb("$RealBin/hostdb.sqlite");
56 my $dbh = $hostdb->{dbh};
58 my @compilers = @{$db->{compilers}};
59 my @hosts = @{$db->{hosts_list}};
60 my %trees = %{$db->{trees}};
62 sub get_log_svn($$$$$)
64 my ($host, $tree, $compiler, $cur, $old) = @_;
65 my $firstrev = $old->{rev} + 1;
66 my $cmd = "svn log --non-interactive -r $firstrev:$cur->{rev} $unpacked_dir/$tree";
69 $log->{change_log} = `$cmd` || confess "$cmd: failed";
70 #print($log->{change_log});
72 # get the list of possible culprits
73 my $log2 = $log->{change_log};
75 while ($log2 =~ /\nr\d+ \| (\w+) \|.*?line(s?)\n(.*)$/s) {
76 $log->{committers}->{"$1\@samba.org"} = 1;
80 # Add a URL to the diffs for each change
81 $log->{change_log} =~ s/\n(r(\d+).*)/\n$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
83 $log->{recipients} = $log->{committers};
88 sub get_log_git($$$$$)
90 my ($host, $tree, $compiler, $cur, $old) = @_;
91 my $cmd = "cd $unpacked_dir/$tree && git log --pretty=full $old->{rev}..$cur->{rev} ./";
94 $log->{change_log} = `$cmd` || confess "$cmd: failed";
95 #print($log->{change_log});
97 # get the list of possible culprits
98 my $log2 = $log->{change_log};
100 while ($log2 =~ /[\n]*Author: [^<]*<([^>]+)>\nCommit: [^<]*<([^>]+)>\n(.*)$/s) {
105 # handle cherry-picks from svnmirror repo
106 $author =~ s/0c0555d6-39d7-0310-84fc-f1cc0bd64818/samba\.org/;
108 # for now only send reports to samba.org addresses.
109 $author = undef unless $author =~ /\@samba\.org/;
110 # $committer = undef unless $committer =~ /\@samba\.org/;
112 $log->{authors}->{$author} = 1 if defined($author);
113 $log->{committers}->{$committer} = 1 if defined($committer);
116 # Add a URL to the diffs for each change
117 $log->{change_log} =~ s/([\n]*commit ([0-9a-f]+))/$1\nhttp:\/\/build.samba.org\/?function=diff;tree=${tree};revision=$2/g;
120 push(@all, keys %{$log->{authors}}) if defined($log->{authors});
121 push(@all, keys %{$log->{committers}}) if defined($log->{committers});
123 foreach my $k (@all) {
126 $log->{recipients} = $all;
133 my ($host, $tree, $compiler, $cur, $old) = @_;
134 my $treedir = "$unpacked_dir/$tree";
136 if (-d "$treedir/.svn") {
137 return get_log_svn($host, $tree, $compiler, $cur, $old);
138 } elsif (-d "$treedir/.git") {
139 return get_log_git($host, $tree, $compiler, $cur, $old);
145 sub check_and_send_mails($$$$$)
147 my ($tree, $host, $compiler, $cur, $old) = @_;
148 my $t = $trees{$tree};
150 printf("rev=$cur->{rev} status=$cur->{string}\n") if $dry_run;
152 printf("old rev=$old->{rev} status=$old->{string}\n") if $dry_run;
154 my $cmp = $db->status_info_cmp($old, $cur);
155 #printf("cmp: $cmp\n");
158 printf("the build didn't get worse ($cmp)\n") if $dry_run;
159 return unless $dry_run;
162 my $log = get_log($host, $tree, $compiler, $cur, $old);
163 if (not defined($log)) {
164 printf("no log\n") if $dry_run;
168 my $recipients = undef;
169 $recipients = join(",", keys %{$log->{recipients}}) if defined($log->{recipients});
171 my $subject = "BUILD of $tree:$t->{branch} BROKEN on $host with $compiler AT REVISION $cur->{rev}";
175 print "To: $recipients\n" if defined($recipients);
176 print "Subject: $subject\n";
179 if (defined($recipients)) {
180 open(MAIL,"|Mail -a \"Content-Type: text/plain;charset=utf-8\" -a \"Precedence: bulk\" -s \"$subject\" $recipients");
182 open(MAIL,"|cat >/dev/null");
186 my $body = << "__EOF__";
187 Broken build for tree $tree on host $host with compiler $compiler
189 Tree $tree is $t->{scm} branch $t->{branch}.
191 Build status for new revision $cur->{rev} is $cur->{string}
192 Build status for old revision $old->{rev} was $old->{string}
194 See http://build.samba.org/?function=View+Build;host=$host;tree=$tree;compiler=$compiler
196 The build may have been broken by one of the following commits:
206 foreach my $host (@hosts) {
207 foreach my $tree (keys %trees) {
208 foreach my $compiler (@compilers) {
212 if ($opt_verbose >= 2) {
213 print "Looking for a log file for $host $compiler $tree...\n";
216 # By building the log file name this way, using only the list of
217 # hosts, trees and compilers as input, we ensure we
219 my $logfn = $db->build_fname($tree, $host, $compiler);
220 my $stat = stat($logfn . ".log");
223 if ($opt_verbose >= 2) {
224 print "Processing $logfn...\n";
228 my $expression = "SELECT checksum FROM build WHERE age >= ? AND tree = ? AND host = ? AND compiler = ?";
229 my $st = $dbh->prepare($expression);
231 $st->execute($stat->ctime, $tree, $host, $compiler);
233 # Don't bother if we've already processed this file
234 my $relevant_rows = $st->fetchall_arrayref();
238 if ($#$relevant_rows > -1) {
239 if ($opt_verbose > 1) {
240 print "retry relevant_rows=$#$relevant_rows\n";
242 die "next please"; #Moves to the next record in the exception handler
245 # By reading the log file this way, using only the list of
246 # hosts, trees and compilers as input, we ensure we
248 my $data = util::FileLoad($logfn.".log");
250 # Don't bother with empty logs, they have no meaning (and would all share the same checksum)
251 if (not $data or $data eq "") {
252 if ($opt_verbose > 1) {
253 print "retry empty data\n";
255 die "next please"; #Moves to the next record in the exception handler
258 my $err = util::FileLoad($logfn.".err");
259 $err = "" unless defined($err);
261 my $checksum = sha1_hex($data);
262 if ($dbh->selectrow_array("SELECT checksum FROM build WHERE checksum = '$checksum'")) {
263 $dbh->do("UPDATE BUILD SET age = ? WHERE checksum = ?", undef,
264 ($stat->ctime, $checksum));
265 if ($opt_verbose > 1) {
266 print "retry checksum match\n";
268 die "next please"; #Moves to the next record in the exception handler
270 if ($opt_verbose) { print "$logfn\n"; }
272 ($rev) = ($data =~ /BUILD REVISION: ([^\n]+)/);
274 if ($data =~ /BUILD COMMIT REVISION: (.*)/) {
284 my $status_html = $db->build_status_from_logs($data, $err);
286 if ($opt_verbose > 1) {
287 print "Found rev=$rev commit=$commit status=$status_html\n";
290 # Look up the database to find the previous status
291 $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");
292 $st->execute( $tree, $host, $compiler, $rev, $commit);
297 while ( my @row = $st->fetchrow_array ) {
298 $old_status_html = @row[0];
300 $old_commit = @row[2];
303 if ($opt_verbose > 1) {
304 print "Old rev=$old_rev old_commit=$commit status=$old_status_html\n";
309 $st = $dbh->prepare("INSERT INTO build (tree, revision, commit_revision, host, compiler, checksum, age, status) VALUES (?, ?, ?, ?, ?, ?, ?, ?)");
310 $st->execute($tree, $rev, $commit, $host, $compiler, $checksum, $stat->ctime, $status_html);
313 # SKIP This code, as it creates massive databases, until we get code to use the information, and a way to expire the results
314 # my $build = $dbh->func('last_insert_rowid');
316 # $st = $dbh->prepare("INSERT INTO test_run (build, test, result, output) VALUES ($build, ?, ?, ?)");
318 # while ($data =~ /--==--==--==--==--==--==--==--==--==--==--.*?
319 # Running\ test\ ([\w\-=,_:\ \/.&;]+).*?
320 # --==--==--==--==--==--==--==--==--==--==--
322 # ==========================================.*?
323 # TEST\ (FAILED|PASSED|SKIPPED):.*?
324 # ==========================================\s+
326 # # Note: output is discarded ($2)
327 # $st->execute($1, $3, undef);
332 my $cur_status = $db->build_status_info_from_html($rev, $commit, $status_html);
335 if ($opt_verbose > 1) {
336 print "cur_status=$cur_status\n";
339 # Can't send a nastygram until there are 2 builds..
340 if (defined($old_status_html)) {
341 $old_status = $db->build_status_info_from_html($old_rev, $old_commit, $old_status_html);
342 if ($opt_verbose > 1) {
343 print "old_status=$old_status\n";
345 check_and_send_mails($tree, $host, $compiler, $cur_status, $old_status);
350 die "next please"; #Moves to the next record in the exception handler
353 if ($opt_verbose > 1) {
354 print "Committing\n";
361 local $dbh->{RaiseError} = 0;
364 if ($@ =~ /^next please/) {
365 # Ignore errors and hope for better luck next time the script is run
366 if ($opt_verbose > 1) {
367 print "next please retry\n";
370 } elsif ($@ =~ /database is locked/ and $retry < 3) {
376 print "Failed to process record for reason: $@";
381 # If we were able to put this into the DB (ie, a
382 # one-off event, so we won't repeat this), then also
383 # hard-link the log files to the revision, if we know
387 # This ensures that the names under 'oldrev' are well known and well formed
388 my $log_rev = $db->build_fname($tree, $host, $compiler, $commit) . ".log";
389 my $err_rev = $db->build_fname($tree, $host, $compiler, $commit) . ".err";
390 if ($opt_verbose >= 2) {
391 print "Linking $logfn to $log_rev\n";
392 print "Linking $logfn to $err_rev\n";
396 link($logfn . ".log", $log_rev) || die "Failed to link $logfn to $log_rev";
398 # this prevents lots of links building up with err files
399 copy($logfn . ".err", $err_rev) || die "Failed to copy $logfn to $err_rev";
400 unlink($logfn . ".err");
401 link($err_rev, $logfn . ".err");