openbsd-ports/infrastructure/bin/dpb
espie 99c73a5b6c fix die handler, as it should display the message as well...
grumble

make it possible to temporarily disable those handlers.
2013-04-13 10:02:11 +00:00

824 lines
18 KiB
Perl
Executable File

#! /usr/bin/perl
# ex:ts=8 sw=4:
# $OpenBSD: dpb,v 1.88 2013/04/13 10:02:11 espie Exp $
#
# Copyright (c) 2010 Marc Espie <espie@openbsd.org>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
use strict;
use warnings;
my ($ports1, $olddie, $oldwarn, $reporter);
use FindBin;
BEGIN {
$ports1 = $ENV{PORTSDIR} || '/usr/ports';
# inspired by Carp::Always
$olddie = $SIG{__DIE__};
$oldwarn = $SIG{__WARN__};
sub trace_message
{
my $msg = '';
my $x = 1;
while (1) {
my @c;
{
package DB;
our @args;
@c = caller($x+1);
}
last if !@c;
$msg .= "$c[3](".
join(', ', map {
if (!defined $_) {
'<undef>';
} else {
my $string;
eval { $string = $_->debug_dump };
if (defined $string) {
"$_($string)";
} else {
$_;
}
}
} @DB::args).
") called at $c[1] line $c[2]\n";
$x++;
}
return $msg;
}
my $trace = 1;
if ($trace) {
$SIG{__WARN__} = sub {
my $_ = pop @_;
s/(.*)( at .*? line .*?\n$)/$1/s;
push @_, $_;
$SIG{__WARN__} = $oldwarn;
if (defined $reporter) {
$reporter->myprint(&trace_message);
} else {
warn &trace_message;
}
};
$SIG{__DIE__} = sub {
die @_ if $^S;
my $_ = pop @_;
s/(.*)( at .*? line .*?\n$)/$1/s;
push @_, $_;
if (defined $reporter) {
$reporter->reset_cursor;
}
$SIG{__DIE__} = $olddie;
die join("\n", @_, &trace_message);
};
$SIG{INFO} = sub {
print "Trace:\n", &trace_message;
sleep 1;
};
}
}
END {
$SIG{__DIE__} = $olddie;
$SIG{__WARN__} = $oldwarn;
}
use lib ("$ports1/infrastructure/lib", "$FindBin::Bin/../lib");
package DPB::State;
our @ISA = qw(OpenBSD::State);
use OpenBSD::State;
use OpenBSD::Paths;
use DPB::Heuristics;
use DPB::PkgPath;
use DPB::Logger;
use DPB::Affinity;
use File::Path;
use File::Basename;
sub define_present
{
my ($self, $k) = @_;
return defined $self->{subst}{$k};
}
sub init
{
my $self = shift;
$self->SUPER::init;
$self->{no_exports} = 1;
$self->{heuristics} = DPB::Heuristics->new($self);
$self->{make} = $ENV{MAKE} || OpenBSD::Paths->make;
($self->{ports}, $self->{portspath}, $self->{repo}, $self->{localarch}, $self->{distdir}) =
DPB::Vars->get($self->make,
"PORTSDIR", "PORTSDIR_PATH", "PACKAGE_REPOSITORY",
"MACHINE_ARCH", "DISTDIR");
$self->{arch} = $self->{localarch};
$self->{portspath} = [ split(/:/, $self->{portspath}) ];
$self->{starttime} = time();
return $self;
}
sub startdate
{
my $self = shift;
my @l = gmtime $self->{starttime};
$l[5] += 1900;
$l[4] ++;
return sprintf '%04d-%02d-%02d@%02d:%02d:%02d', @l[5,4,3,2,1,0];
}
sub expand_path
{
my ($self, $path) = @_;
$path =~ s/\%L/$self->{logdir}/g;
$path =~ s/\%p/$self->{ports}/g;
$path =~ s/\%h/DPB::Core::Local->hostname/ge;
$path =~ s/\%a/$self->{arch}/g;
$path =~ s/\%t/$self->{starttime}/g;
$path =~ s/\%d/$self->startdate/ge;
$path =~ s/\%f/$self->{distdir}/g;
return $path;
}
sub interpret_path
{
my ($state, $path, $do, $scale) = @_;
my $weight;
if ($path =~ s/\=(.*)//) {
$weight = $1;
}
if ($path =~ s/\*(\d+)$//) {
$scale = $1;
}
$path =~ s/\/+$//;
$path =~ s/^\.\/+//;
my $p = DPB::PkgPath->new($path);
if (defined $scale) {
$p->{scaled} = $scale;
}
for my $d (@{$state->{portspath}}) {
if (-d join('/', $d , $p->pkgpath)) {
&$do($p, $weight);
return;
}
}
$state->usage("Bad package path: #1", $path);
}
sub interpret_paths
{
my $state = shift;
my $do = pop;
for my $file (@_) {
my $scale;
if ($file =~ s/\*(\d+)$//) {
$scale = $1;
}
if (-f $file) {
open my $fh, '<', $file or
$state->usage("Can't open $file");
my $_;
while (<$fh>) {
chomp;
s/\s*(?:\#.*)?$//;
next if m/^$/;
$state->interpret_path($_, $do, $scale);
}
} else {
$state->interpret_path($file, $do);
}
}
}
sub handle_options
{
my $state = shift;
$state->{dontclean} = {};
$state->{opt} = {
A => sub {
$state->{arch} = shift;
},
L => sub {
$state->{logdir} = shift;
},
l => sub {
$state->{lockdir} = shift;
},
r => sub {
$state->{random} = 1;
$state->heuristics->random;
},
P => sub {
push(@{$state->{paths}}, shift);
},
I => sub {
push(@{$state->{ipaths}}, shift);
},
C => sub {
push(@{$state->{cpaths}}, shift);
},
X => sub {
push(@{$state->{xpaths}}, shift);
},
b => sub {
push(@{$state->{build_files}}, shift);
},
};
$state->SUPER::handle_options('acemqrRsuUvh:S:xX:A:C:f:F:I:j:J:M:p:P:b:l:L:',
"[-acemrRsuUvx] [-A arch] [-C plist] [-f N] [-F N] [-I plist] [-J p] [-j N]",
"[-p parallel] [-P plist] [-h hosts] [-L logdir] [-l lockdir] [-b log]",
"[-M threshold] [-X plist] [path ...]");
$state->{fullrepo} = join("/", $state->{repo}, $state->arch, "all");
$state->{logdir} //= $ENV{LOGDIR} // '%p/logs/%a';
$state->{lockdir} //= "%L/locks";
if (defined $state->{opt}{F}) {
if (defined $state->{opt}{j} || defined $state->{opt}{f}) {
$state->usage("Can't use -F with -f or -j");
}
$state->{fetch_only} = 1;
$state->{opt}{f} = $state->{opt}{F};
$state->{opt}{j} = 1;
$state->{opt}{e} = 1;
}
$state->{opt}{f} //= 2;
if (defined $state->opt('j')) {
if ($state->localarch ne $state->arch) {
$state->usage(
"Can't use -j if -A arch is not local architecture");
}
if ($state->opt('j') !~ m/^\d+$/) {
$state->usage("-j takes a numerical argument");
}
}
if ($state->opt('f') !~ m/^\d+$/) {
$state->usage("-f takes a numerical argument");
}
if ($state->opt('f')) {
$state->{want_fetchinfo} = 1;
}
if (!$state->{subst}->empty('HISTORY_ONLY')) {
$state->{want_fetchinfo} = 1;
$state->{opt}{f} = 0;
$state->{opt}{j} = 1;
$state->{opt}{e} = 1;
$state->{all} = 1;
$state->{scan_only} = 1;
# XXX not really random, but no need to use dependencies
$state->{random} = 1;
}
$state->{logdir} = $state->expand_path($state->{logdir});
$state->{lockdir} = $state->expand_path($state->{lockdir});
if ($state->opt('h')) {
$state->{config} = $state->expand_path($state->opt('h'));
}
if (!$state->{subst}->value("NO_BUILD_STATS")) {
push @{$state->{build_files}}, "%f/build-stats/%a";
}
# if (!$state->{xpaths}) {
# $state->{xpaths} = ["%p/infrastructure/db/precious"];
# }
for my $cat (qw(build_files paths ipaths cpaths xpaths)) {
next unless defined $state->{$cat};
for my $f (@{$state->{$cat}}) {
$f = $state->expand_path($f);
}
}
$state->{size_log} = "%f/build-stats/%a-size";
$state->{permanent_log} = $state->{build_files}[-1];
$state->{size_log} = $state->expand_path($state->{size_log});
$state->parse_size_file;
$state->{logger} = DPB::Logger->new($state->logdir, $state->opt('c'));
DPB::Limiter->setup($state->logger);
$state->heuristics->set_logger($state->logger);
$state->{display_timeout} =
$state->{subst}->value('DISPLAY_TIMEOUT') // 10;
$state->{build_once} = $state->{all};
if ($state->defines("DONT_BUILD_ONCE")) {
$state->{build_once} = 0;
}
$state->{concurrent} = $state->{logger}->open("concurrent");
$state->parse_config_files;
}
sub parse_config_files
{
my $state = shift;
my $override_prop = {};
if ($state->opt('j')) {
$override_prop->{jobs} = $state->opt('j');
}
if ($state->opt('p')) {
$override_prop->{parallel} = $state->opt('p');
}
if ($state->define_present('STUCK_TIMEOUT')) {
$override_prop->{stuck} =
$state->{subst}->value('STUCK_TIMEOUT');
}
if ($state->define_present('FETCH_TIMEOUT')) {
$override_prop->{fetch_timeout} =
$state->{subst}->value('FETCH_TIMEOUT');
}
if ($state->define_present('SMALL_TIME')) {
$override_prop->{small} =
$state->{subst}->value('SMALL_TIME');
}
if ($state->define_present('CONNECTION_TIMEOUT')) {
$override_prop->{timeout} =
$state->{subst}->value('CONNECTION_TIMEOUT');
}
if ($state->define_present('WAIT_TIMEOUT')) {
$override_prop->{wait_timeout} =
$state->{subst}->value('WAIT_TIMEOUT');
}
if ($state->opt('J')) {
$override_prop->{junk} = $state->opt('J');
}
if ($state->defines("ALWAYS_CLEAN")) {
$override_prop->{always_clean} = 1;
}
if ($state->opt('M')) {
$override_prop->{mem} = $state->opt('M');
}
my $default_prop = {
junk => 150,
parallel => '/2',
wait_timeout => 600,
small => 120,
};
if ($state->{config}) {
DPB::Core->parse_hosts_file($state->{config}, $state,
$default_prop, $override_prop);
}
$state->{default_prop} = $default_prop;
$state->{override_prop} = $override_prop;
}
sub start_cores
{
my $state = shift;
if (!$state->{config}) {
my $prop = { %{$state->{default_prop}} };
while (my ($k, $v) = each %{$state->{override_prop}}) {
$prop->{$k} = $v;
}
DPB::Core::Factory->new('localhost', $prop);
}
DPB::Core::Factory->init_cores($state);
}
sub logger
{
return shift->{logger};
}
sub heuristics
{
return shift->{heuristics};
}
sub locker
{
return shift->{locker};
}
sub stalelocks
{
return shift->locker->{stalelocks};
}
sub builder
{
return shift->{builder};
}
sub engine
{
return shift->{engine};
}
sub grabber
{
return shift->{grabber};
}
sub make
{
return shift->{make};
}
sub make_args
{
my $self = shift;
my @l = ($self->{make});
if ($self->{build_once}) {
push(@l, 'BUILD_ONCE=Yes');
}
return @l;
}
sub ports
{
return shift->{ports};
}
sub fullrepo
{
return shift->{fullrepo};
}
sub distdir
{
return shift->{distdir};
}
sub localarch
{
return shift->{localarch};
}
sub arch
{
return shift->{arch};
}
sub logdir
{
return shift->{logdir};
}
sub parse_build_line
{
return split(/\s+/, shift);
}
sub parse_build_file
{
my ($state, $fname) = @_;
if (!-f $fname) {
my $arch = $state->arch;
if (-f "$fname/$arch/build.log") {
$fname = "$fname/$arch/build.log";
} elsif (-f "$fname/build.log") {
$fname = "$fname/build.log";
}
}
open my $fh, '<', $fname or return;
my $_;
while (<$fh>) {
chomp;
next if $_ =~ m/!$/;
my ($pkgpath, $host, $time, $sz, @rest) = parse_build_line($_);
next if !defined $sz;
my $o = DPB::PkgPath->new($pkgpath);
push(@{$o->{stats}}, {host => $host, time => $time, sz => $sz});
}
}
sub add_build_info
{
my ($state, @consumers) = @_;
for my $p (DPB::PkgPath->seen) {
next unless defined $p->{stats};
my ($i, $time, $sz, $host);
for my $s (@{$p->{stats}}) {
$time += $s->{time};
$sz += $s->{sz};
$i++;
$host = $s->{host}; # XXX
}
for my $c (@consumers) {
$c->add_build_info($p, $host, $time/$i, $sz/$i);
}
}
}
sub rewrite_build_info
{
my $state = shift;
File::Path::mkpath(File::Basename::dirname($state->{permanent_log}));
open my $f, '>', $state->{permanent_log}.'.part' or return;
for my $p (sort {$a->fullpkgpath cmp $b->fullpkgpath}
DPB::PkgPath->seen) {
next unless defined $p->{stats};
shift @{$p->{stats}} while @{$p->{stats}} > 10;
for my $s (@{$p->{stats}}) {
print $f join(' ', $p->fullpkgpath, $s->{host},
$s->{time}, $s->{sz}), "\n";
}
delete $p->{stats};
}
close $f;
rename $state->{permanent_log}.'.part', $state->{permanent_log};
}
sub handle_build_files
{
my $state = shift;
return if $state->{fetch_only};
return unless defined $state->{build_files};
print "Reading build stats...";
for my $file (@{$state->{build_files}}) {
$state->parse_build_file($file);
}
$state->add_build_info($state->heuristics, "DPB::Job::Port");
print "zapping old stuff...";
$state->rewrite_build_info($state->{permanent_log});
print "Done\n";
$state->heuristics->finished_parsing;
}
sub parse_size_file
{
my $state = shift;
return if $state->{fetch_only};
open my $fh, '<', $state->opt('S') // $state->{size_log} or return;
print "Reading size stats...";
File::Path::mkpath(File::Basename::dirname($state->{size_log}));
my $rewrite = {};
my $_;
while (<$fh>) {
chomp;
my $pkgname;
my ($pkgpath, $sz, $sz2) = split(/\s+/, $_);
my $i = " $sz";
if ($pkgpath =~ m/^(.*)\((.*)\)$/) {
($pkgpath, $pkgname) = ($1, $2);
if ($state->opt('S')) {
undef $pkgname;
} else {
$i ="($pkgname) $sz";
}
}
if (defined $sz2) {
$sz += $sz2;
$i .=" $sz2";
}
$rewrite->{$pkgpath} = $i;
my $o = DPB::PkgPath->new($pkgpath);
DPB::Heuristics->add_size_info($o, $pkgname, $sz);
}
close $fh;
print "zapping old stuff...";
open $fh, '>', $state->{size_log}.'.part' or return;
for my $p (sort keys %$rewrite) {
print $fh "$p$rewrite->{$p}\n";
}
close $fh;
print "Done\n";
rename $state->{size_log}.'.part', $state->{size_log};
}
package main;
use DPB::PkgPath;
use DPB::Core;
use DPB::Vars;
use DPB::PortInfo;
use DPB::Engine;
use DPB::PortBuilder;
use DPB::Reporter;
use OpenBSD::Error;
use DPB::Locks;
use DPB::Job;
use DPB::Grabber;
my $keep_going = 1;
sub report
{
return DPB::Util->time2string(time)." [$$]".
($keep_going ? "" : " STOPPED!").
"\n";
}
my $subdirlist = {};
my $state = DPB::State->new('dpb');
$state->handle_options;
$state->{locker} = DPB::Locks->new($state, $state->{lockdir});
$state->start_cores;
$state->{all} = 1;
my $default_handling =
sub {
my ($pkgpath, $weight) = @_;
if (defined $weight) {
$state->heuristics->set_weight($pkgpath);
}
$pkgpath->add_to_subdirlist($subdirlist);
$state->{all} = 0;
};
$state->interpret_paths(@{$state->{paths}}, @ARGV,
sub {
&$default_handling(@_);
});
$state->interpret_paths(@{$state->{ipaths}},
sub {
&$default_handling(@_);
my $p = shift;
$p->{wantinstall} = 1;
});
$state->interpret_paths(@{$state->{cpaths}},
sub {
my $p = shift;
$state->{dontclean}{$p->pkgpath} = 1;
});
$state->interpret_paths(@{$state->{xpaths}},
sub {
my $p = shift;
$p->{dontjunk} = 1;
});
if ($state->opt('a')) {
$state->{all} = 1;
}
$state->handle_build_files;
$state->{builder} = DPB::PortBuilder->new($state);
$state->{affinity} = DPB::Affinity->new($state, join("/", $state->logdir, "affinity"));
$state->{engine} = DPB::Engine->new($state);
$reporter = DPB::Reporter->new($state, "main", "DPB::Core", $state->engine);
while (!DPB::Core->avail) {
DPB::Core->reap;
sleep 1;
}
my $core = DPB::Core->get;
my $dump = DPB::Util->make_hot($state->logger->open('dump'));
my $last_time = time() - $state->{display_timeout};
sub handle_non_waiting_jobs
{
my $need_clock = shift;
my $checked = !$need_clock; # XXX
my $force_report = 0;
my $reaped = DPB::Core->reap;
$keep_going = !-e $state->logdir."/stop";
if (DPB::Core->avail > 1) {
$state->engine->recheck_errors;
}
if (DPB::Core->avail) {
$state->engine->check_buildable;
$checked = 1;
}
while ($keep_going && DPB::Core->avail && $state->engine->can_build) {
$state->engine->start_new_job;
$force_report = 1;
}
while ($keep_going && DPB::Core::Fetcher->avail &&
$state->engine->can_fetch) {
if (!$checked) {
$state->engine->check_buildable;
$checked = 1;
}
$state->engine->start_new_fetch;
$force_report = 1;
}
my $current = time();
DPB::Core->log_concurrency($current, $state->{concurrent});
if ($need_clock) {
if ($current >= $last_time + $state->{display_timeout} ||
$reaped) {
$reporter->report($force_report);
$last_time = $current;
}
} else {
$reporter->report($force_report);
}
}
sub main_loop
{
while (1) {
while (1) {
handle_non_waiting_jobs(0);
if (!DPB::Core->running) {
last if !$keep_going;
if (!$state->engine->can_build) {
$state->engine->check_buildable(1);
if (!$state->engine->can_build) {
last;
}
}
}
if (DPB::Core->running) {
DPB::Core->reap_wait;
}
if ($state->{fetch_only}) {
if (!DPB::Core::Fetcher->running &&
(!$keep_going || !$state->engine->can_fetch)) {
$state->engine->check_buildable;
if (!$state->engine->can_fetch) {
last;
}
}
}
}
if (!$state->opt('q') || !$state->engine->recheck_errors) {
last;
}
}
}
$state->{grabber} = DPB::Grabber->new($state,
sub { handle_non_waiting_jobs(1) });
if ($state->{all} && !$state->{random}) {
# when restarting interrupted dpb,
# find the most important paths first
my $list = $state->engine->find_best($state->logger->logfile("dependencies"), 10);
# if we have them, list them before the full ports tree walk.
if (@$list > 0) {
my $actual = {};
for my $name (@$list) {
DPB::PkgPath->new($name)->add_to_subdirlist($actual);
}
$state->grabber->grab_subdirs($core, $actual);
}
}
if (keys %$subdirlist > 0) {
$state->grabber->grab_subdirs($core, $subdirlist);
}
$state->grabber->complete_subdirs($core);
if ($state->{all}) {
$state->grabber->grab_subdirs($core);
}
$state->grabber->complete_subdirs($core);
# give back "our" core to the pool.
my $occupied = 0;
if ($state->{all}) {
$state->engine->dump_dependencies;
if (!$state->defines('NO_HISTORY')) {
if ($state->grabber->expire_old_distfiles($core,
$state->opt('e'))) {
$occupied = 1;
}
}
}
if (!$state->opt('e') && !$occupied) {
$core->mark_ready;
}
$state->engine->check_buildable;
if ($state->{scan_only}) {
# very shortened loop
$reporter->report;
if (DPB::Core->running) {
DPB::Core->reap_wait;
}
} else {
# and let's wait for all jobs now.
DPB::Core->start_clock($state->{display_timeout});
main_loop();
}
$reporter->reset;
DPB::Core->cleanup;
print $state->engine->report;
$state->engine->end_dump($state->logger->open('dump'));