[Collab-qa-commits] r828 - svnbuildstat/trunk/script
goneri at alioth.debian.org
goneri at alioth.debian.org
Sun Apr 27 19:05:39 UTC 2008
Author: goneri
Date: 2008-04-27 19:05:38 +0000 (Sun, 27 Apr 2008)
New Revision: 828
Removed:
svnbuildstat/trunk/script/svnbuildstat_agent.pl
Log:
move the script in its own repository
Deleted: svnbuildstat/trunk/script/svnbuildstat_agent.pl
===================================================================
--- svnbuildstat/trunk/script/svnbuildstat_agent.pl 2008-04-27 19:05:08 UTC (rev 827)
+++ svnbuildstat/trunk/script/svnbuildstat_agent.pl 2008-04-27 19:05:38 UTC (rev 828)
@@ -1,442 +0,0 @@
-#!/usr/bin/perl -w
-
-use strict;
-
-use Data::Dumper;
-use File::Glob ':glob';
-use Sys::Hostname;
-use LWP::Simple;
-use POSIX ":sys_wait_h";
-use File::Basename;
-use File::stat;
-use HTTP::Request::Common;
-use LWP::UserAgent;
-use HTTP::Response;
-use Proc::ProcessTable;
-use Config::IniFiles;
-
-###########################################################################
-###########################################################################
-###########################################################################
-
-my $RELEASE = "0.0.1";
-my $hostname = hostname();
-my $distro = "sid";
-chomp (my $arch = `dpkg-architecture -qDEB_HOST_ARCH`);
-
-my %job;
-
-die "You must be root!" unless $< == 0;
-
-my $inifile = "/etc/qabuild-agent.ini";
-my $cfg= Config::IniFiles->new( -file => $inifile ) or die "Can't load $inifile";
-my $debmirror = $cfg->val('path', 'debmirror');
-my $server = $cfg->val('path', 'server');
-my $vardir = $cfg->val('path', 'vardir');
-my $adminname = $cfg->val('admin', 'name');
-my $adminemail = $cfg->val('admin', 'email');
-my $adminteam = $cfg->val('admin', 'team');
-
-
-if (!$debmirror) {
- die "Can't find the debmirror in $inifile";
-}
-if (!$server) {
- die "Can't find the server in $inifile";
-}
-if (!$vardir || !-d $vardir) {
- die "Can't find the vardir directory in $inifile";
-}
-
-my $maxjob = 1;
-my $workplace = $vardir."/workplace";
-my $pbuilderplace = $vardir."/pbuilder";
-my $buildarea = $vardir."/report";
-my $tmpdir = $vardir."/tmp";
-my $aptcachedir = $vardir."/aptcache";
-my $pbuildertgz = "$pbuilderplace/$distro.tar.gz";
-my $sigTermCatched = 0;
-my $exit = 0;
-sub sigterm {print "SIGTERM!\n";$sigTermCatched=1};
-$SIG{INT}= 'sigterm';
-
-my $keeptmpdir;
-die unless $maxjob =~ /^\d+$/;
-
-$ENV{LC_ALL} = 'C';
-$ENV{LANG} = 'C';
-
-# From Proc::Killall TODO package this
-#Copyright (c) 1998-2006 Daniel J. Urist. All rights reserved.
-#This package is free software; you can redistribute it and/or modify
-#it under the same terms as Perl itself.
-sub get_pids {
-
- my($procs, @kids) = @_;
-
- my @pids;
- foreach my $kid (@kids) {
- foreach my $proc (@$procs) {
- if ($proc->ppid == $kid) {
- my $pid = $proc->pid;
- push @pids, $pid, get_pids $procs, $pid;
- }
- }
- }
- @pids;
-
-}
-
-sub killfam {
-
- my($signal, @pids) = @_;
-
- my $pt = Proc::ProcessTable->new;
- my(@procs) = @{$pt->table};
- my(@kids) = get_pids \@procs, @pids;
- @pids = (@pids, @kids);
- print "pid to kill: ";
- print $_." " foreach (@pids);
- print "\n";
- kill $signal, @pids;
-
-} # end killfam
-
-
-sub purge {
- print "What a nice day for a purge!\n";
- die "please create: `".$vardir unless -d $vardir;
-# TODO check for running script in background
-# Purge
- foreach ($workplace, $buildarea, $tmpdir) {
- if (-d $workplace) {
- `rm -r $workplace`;
- }
- }
-
- foreach (`mount`) {
- if (/^\/\S+\son\s(\S+)/) {
- my $mountPoint = $1;
- if ($mountPoint =~ /^$pbuilderplace/) {
- print "umounting $mountPoint\n";
- system("umount $mountPoint");
- }
- }
- }
- # !!! Maybe danger if $pbuilderplace is unset
- # so I do another check here!
- die "DANGER: pbuilderplace not correct!" unless $pbuilderplace =~ /\/./;
-
- foreach (bsd_glob($pbuilderplace.'/*')) {
- next if /tar.gz$/; # pbuilder tarball
- system ("rm -r $_");
- }
-
-# (Re)Create the directorys
- foreach ($workplace, $buildarea, $pbuilderplace, $tmpdir, $aptcachedir) {
- if (!-d && !mkdir $_) {
- die "Failed to create $_\n";
- }
- }
-}
-
-sub debcachePurge {
-
- `rm -f $aptcachedir/*` unless $keeptmpdir;
-
-}
-
-sub checkSanity {
-
- if (isDiskFull($aptcachedir)) {
- debcachePurge();
- }
-
- if (isMemFull()||isDiskFull($workplace)||isDiskFull($buildarea)||isDiskFull('/tmp')) {
- print "checkSanity(): disk or memory full!!!\n";
- purge();
- }
-
- $exit = 1 if $sigTermCatched;
- if ($exit||isMemFull()||isDiskFull($workplace)||isDiskFull($buildarea)||isDiskFull('/tmp')) {
- if (%job&&(isDiskFull($workplace)||isDiskFull($buildarea))) {
- print "Emergency clean up\n";
- killfam (15, keys %job);
-
- foreach (1..10) {
- sleep (1);
- print ".";
- }
- print "\n";
-
- killfam (9, keys %job);
-
- foreach (keys %job) {
- waitpid($_, WNOHANG);
- delete ($job{$_});
- }
-
- purge() unless $keeptmpdir;
- }
- }
-}
-
-sub postFile {
- my $file = shift;
-
- my $ua = new LWP::UserAgent;
-
-
- my $response = $ua->request(POST $server.'/controls/buildInput',
- Content_Type => 'form-data',
- Content => ['file' => [ $file, basename($file) ]]) or die "Upload failed\n";
-
- if ($response->is_error) {
- print "Failed to post file: ".$response->as_string()."\n";
- }
-
-}
-
-sub isDiskFull {
- my $path = shift;
-
- my $free = 0;
-# /dev/hda2 7210656 5721668 1122708 84% /
- foreach (`df -P $path`) {
- if (/^\S+\s+\d+\s+\d+\s+(\d+)\s+\S+/) {
- $free = $1;
- }
- }
-
- $free < 300000;
-}
-
-sub isMemFull {
-
- if (!open MEMINFO, "</proc/meminfo") {
- warn "Can't open meminfo";
- return;
- }
-
- my $free = 0;
- foreach (<MEMINFO>) {
- $free += $2 if /^(MemFree|SwapFree):\s+(\d+)\s+kB/;
- }
- # IMO, 50MB is not enough to continue a build
- $free < 50000;
-}
-
-sub getBuildJob {
- my $p;
- my $report = {};
-
- my $ua = LWP::UserAgent->new();
- my $req = POST $server."/controls/getBuildJob", Content_Type => 'form-data',
- Content => [
- submit => 1,
- content => "arch=$arch\n",
- ];
- my $response = $ua->request($req);
- return unless $response->is_success();
-
- foreach (split $/, $response->content) {
- chomp;
-
- $report->{$1} = $2 if (/(.*)=(.*)/);
- }
-
- return unless $report->{dsc};
- return unless $report->{id};
- $report;
-}
-
-sub upgradeChroot {
- my $retry = shift;
- $retry = 1 unless $retry;
-
- my $pdebuildparam = "--debootstrap debootstrap --mirror ".$debmirror." --buildplace $pbuilderplace --othermirror 'deb ".$debmirror." $distro main contrib non-free' --distribution $distro --basetgz $pbuildertgz --debootstrap debootstrap";
- if (-s $pbuildertgz) {
- my $sb = stat($pbuildertgz);
- if (time - $sb->ctime > 3600 * 24) {
- # I recreate the chroot every day
- `mv $pbuildertgz $pbuildertgz.save`;
- }
- }
-
- if (! -s $pbuildertgz) {
- # TODO redirect the log on another place
- `/usr/sbin/pbuilder create $pdebuildparam >/tmp/pbuilder-create.log 1>&2`;
- if (($? >> 8)!=0) {
- print "Failed to create pbuilder image\n";
- if (-f "$pbuildertgz.save") {
- # I restore the previous chroot
- `cp $pbuildertgz.save $pbuildertgz`;
- `/usr/sbin/pbuilder update $pdebuildparam >/tmp/pbuilder-create.log 1>&2`;
- }
- } else {
- # I save the created chroot
- `cp $pbuildertgz $pbuildertgz.save`;
- }
- }
-
- if (! -s $pbuildertgz) {
- my $timer = 10*$retry;
- $timer = 180 if $timer > 180;
- print "Failed to create a pbuilder tarball, will sleep for $timer minutes and retry ...\n";
- sleep ($timer*60);
- upgradeChroot($retry+1);
- }
-}
-
-
-sub sendReport {
-
- my ($report, $threadbuildarea) = @_;
-
- print "sending result that are in $threadbuildarea\n";
-
- $report->{'arch'} = $arch;
- $report->{hostname} = $hostname;
- $report->{distro} = $distro;
- $report->{adminname} = $adminname;
- $report->{adminemail} = $adminemail;
- $report->{adminteam} = $adminteam;
-
- $report->{'agent_release'} = $RELEASE;
- $report->{'pbuilder_release'} = `dpkg-query -W -f='\${Version}' pbuilder`;
-
- my $tmp = basename($report->{dsc});
- $tmp =~ s/\.dsc//;
- my $prefix = $tmp."_".$arch."_$hostname";
- my $logfile = $prefix.'.log';
- my $infofile = $prefix.'.info';
-
- open (BUILDLOGTMP, "<","$threadbuildarea/build.log.tmp") or die;
- seek(BUILDLOGTMP, -1000000, 2); # I just keep the end of the logfile
- open (BUILDLOG, ">", "$threadbuildarea/".$logfile) or die;
- # If I'm not at the end of BUILDLOGTMP it means that seek moved me
- print BUILDLOG "(log file truncated) ... " if tell(BUILDLOGTMP);
-
- foreach (<BUILDLOGTMP>) {
- # To avoid strange breakage I do some clean up in the log file
- s/[[:cntrl:]]//g;
- print BUILDLOG $_."\n";
- }
- close BUILDLOGTMP;
- close BUILDLOG;
- unlink "$threadbuildarea/build.log.tmp";
-
-
- postFile($threadbuildarea."/".$logfile);
- $report->{logfile} = $logfile;
- if (bsd_glob($threadbuildarea.'/*.changes')) {
- print "build is ok\n";
- $report->{build} = "ok";
- $report->{files} = '';
- foreach (bsd_glob($threadbuildarea.'/*')) {
- next if /orig\.tar\.gz$/; # deb & udeb
- $report->{files} = $report->{files}.basename($_).' ';
- postFile($_);
- }
- } else {
- print "build is nok\n";
- $report->{build} = "nok";
- }
-
-
- open (BUILDREPORT,">",$threadbuildarea."/".$infofile) or die "Can't open infofile";
- foreach (sort keys %$report) {
- chomp $report->{$_};
- print BUILDREPORT $_."=".$report->{$_}."\n";
- }
-# print BUILDREPORT "-END-\n";
- close BUILDREPORT;
- postFile ($threadbuildarea."/".$infofile);
-
-}
-
-
-sub build {
- my $report = shift;
-
- return unless $report;
- die unless -d $workplace;
- die unless -d $buildarea;
- die unless -d $tmpdir;
-
- my $threadworkplace = $workplace .'/'. $$;
- my $threadbuildarea = $buildarea .'/'. $$;
-
- die if (!-d $threadworkplace && !mkdir $threadworkplace);
- die if (!-d $threadbuildarea && !mkdir $threadbuildarea);
-
-###########################################################################
-###########################################################################
-###########################################################################
-
- print "dsc: ".$report->{dsc}."\n";
-
- my $tarballdir;
- # The archive are not signed for the moment
- my $cmd = "cd $threadworkplace; dget -qxu ".$report->{dsc};
- foreach (`$cmd`) {
- $tarballdir = $1 if /dpkg-source:\sextracting\s\S+\sin\s(\S+)/;
- }
- print "tarballdir: $threadworkplace; $tarballdir\n";
- if (!$tarballdir) {
- system("rm -r $threadworkplace $threadbuildarea") unless $keeptmpdir;
- return;
- }
-
- $report->{'stamp_build-start'} = time;
- my $dsc_localpath = $threadworkplace.'/'.basename($report->{dsc});
-
- `cd $threadworkplace/$tarballdir; pbuilder --build --buildresult $threadbuildarea --buildplace $pbuilderplace --aptcache $aptcachedir --distribution $distro --basetgz $pbuilderplace/$distro.tar.gz --timeout 10h $dsc_localpath >$threadbuildarea/build.log.tmp 2>&1`;
- $report->{'stamp_build-end'} = time;
-
- sendReport($report, $threadbuildarea);
-
- `rm -rf $threadworkplace $threadbuildarea` unless $keeptmpdir;
-
- 1;
-}
-
-##################################################################
-##################################################################
-##################################################################
-###### Main
-purge();
-
-while (sleep 1) {
-
- checkSanity();
- exit(1) if $exit;
- upgradeChroot();
-
-# Check the running jobs (See #453710)
- foreach my $pid (keys %job) {
- waitpid($pid, WNOHANG);
- if (! -d "/proc/".$pid) {
- print "$pid is finish\n";
- `rm -rf $workplace/$pid $buildarea/$pid` unless $keeptmpdir;
- delete ($job{$pid});
- }
- }
-
- if (keys %job < $maxjob) {
- my $newpid = fork;
- if ($newpid) { # Father
- $job{$newpid} = time;
- } else { # Son
- my $report = getBuildJob ();
- print $report->{dsc}."\n";
- if (!exists($report->{dsc})) {
- print "Can't get a package to build from $server\n";
- } else {
- build($report);
- print "done\n";
- }
- exit;
- }
- }
-}
More information about the Collab-qa-commits
mailing list