X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=bin%2Fwanna-build;h=e02706dbcff4378df2c3ae2ebc0a89a6b4930a32;hb=7ce88f5df6216220b52607f09facaf312cb971c7;hp=f929b46fb338955e179ceb3dc521df431d95a05e;hpb=2df47c378a09360af50fa8775dd8527863bbdcd9;p=wannabuild.git diff --git a/bin/wanna-build b/bin/wanna-build index f929b46..e02706d 100755 --- a/bin/wanna-build +++ b/bin/wanna-build @@ -25,7 +25,7 @@ $basedir ||= "/var/lib/debbuild"; $dbbase ||= "build-db"; $transactlog ||= "transactions.log"; $mailprog ||= "/usr/sbin/sendmail"; -require "/etc/wanna-build.conf"; +require "/org/wanna-build/etc/wanna-build.conf"; die "$conf::basedir is not a directory\n" if ! -d $conf::basedir; die "dbbase is empty\n" if ! $dbbase; die "transactlog is empty\n" if ! $transactlog; @@ -39,19 +39,29 @@ use POSIX; use FileHandle; use File::Copy; use DBI; +use lib '/org/wanna-build/bin'; use WannaBuild; +use YAML::Tiny; +use Data::Dumper; +use Hash::Merge qw ( merge ); +use String::Format; +use Date::Parse; +use List::Util qw[max]; our ($verbose, $mail_logs, $list_order, $list_state, $curr_date, $op_mode, $user, $real_user, $distribution, - $fail_reason, $opt_override, $import_from, $opt_create_db, + $fail_reason, $opt_override, $import_from, $export_to, $opt_create_db, %prioval, %sectval, $info_all_dists, $arch, $category, %catval, %short_category, $short_date, $list_min_age, $dbbase, @curr_time, - $build_priority, %new_vers, $binNMUver, %merge_srcvers, %merge_binsrc); + $build_priority, %new_vers, $binNMUver, %merge_srcvers, %merge_binsrc, + $printformat, $ownprintformat, $privmode + ); # global vars $ENV{'PATH'} = "/bin:/usr/bin:/usr/local/bin:/org/wanna-build/bin/"; +$ENV{'LC_ALL'} = 'C'; $verbose = 0; $mail_logs = ""; @curr_time = gmtime; @@ -117,6 +127,7 @@ my %options = "merge-sources" => { mode => "merge-sources" }, "pretend-avail" => { short => "p", mode => "pretend-avail" }, "merge-all" => { mode => "merge-all" }, + "merge-all-secondary" => { mode => "merge-all-secondary" }, info => { short => "i", mode => "info" }, 'binNMU' => { mode => 'set-binary-nmu', arg => \$binNMUver, code => sub { die "Invalid binNMU version: $binNMUver\n" @@ -154,7 +165,7 @@ my %options = { short => "O", arg => \$list_order, code => sub { die "Bad ordering character\n" - if $list_order !~ /^[PSpsncb]+$/; + if $list_order !~ /^[PSpsncbCW]+$/; } }, message => { short => "m", arg => \$fail_reason }, # database is deprecated, use arch instead. @@ -172,15 +183,17 @@ my %options = code => sub { die "Argument of --min-age must be a non-zero number\n" if $list_min_age == 0; - $list_min_age *= 24*60*60; } }, "max-age" => { arg => \$list_min_age, code => sub { die "Argument of --max-age must be a non-zero number\n" if $list_min_age == 0; - $list_min_age *= -24*60*60; + $list_min_age *= -1; } }, + "format" => { arg => \$printformat }, + "own-format" => { arg => \$ownprintformat }, # special actions + export => { arg => \$export_to, mode => "export" }, import => { arg => \$import_from, mode => "import" }, "manual-edit" => { mode => "manual-edit" }, ); @@ -228,11 +241,26 @@ while( @ARGV && $ARGV[0] =~ /^-/ ) { $op_mode = $category ? "set-failed" : "set-building" if !$op_mode; # default operation -$list_order = $list_state eq "failed" ? 'fPcpsn' : 'PScpsn' - if !$list_order and $list_state; $distribution ||= "unstable"; -die "Bad distribution '$distribution'\n" - if !isin($distribution, keys %conf::distributions); +if ($distribution eq 'any-priv') { + $privmode = 'yes'; + $distribution = 'any'; +} +if ($distribution eq 'any-unpriv') { + $privmode = 'no'; + $distribution = 'any'; +} +undef $distribution if $distribution eq 'any'; +if ($distribution) { + my @dists = split(/[, ]+/, $distribution); + foreach my $dist (@dists) { + die "Bad distribution '$distribution'\n" + if !isin($dist, keys %conf::distributions); + } +} +if (!isin ( $op_mode, qw(list) ) && ( !$distribution || $distribution =~ /[ ,]/)) { + die "multiple distributions are only allowed for list"; +} # If they didn't specify an arch, try to get it from database name which # is in the form of $arch/build-db @@ -250,7 +278,7 @@ if ($verbose) { print "wanna-build $version for $distribution on $arch\n"; } -if (!@ARGV && !isin( $op_mode, qw(list merge-quinn merge-partial-quinn import +if (!@ARGV && !isin( $op_mode, qw(list merge-quinn merge-partial-quinn import export merge-packages manual-edit merge-sources))) { warn "No packages given.\n"; @@ -292,6 +320,26 @@ if (!$fail_reason) { } } +my $yamlmap = (); +my $yamldir = "/org/wanna-build/etc/yaml"; +my @files = ('wanna-build.yaml'); +if ((getpwuid($>))[7]) { push (@files, ((getpwuid($>))[7])."/.wanna-build.yaml"); } +if ($user =~ /(buildd.*)-/) { push (@files, "$1.yaml") }; +if ($user) { push ( @files, "$user.yaml"); } +foreach my $file (@files) { + my $cfile = File::Spec->rel2abs( $file, $yamldir ); + if ($verbose >= 2) { print "Trying to read $file ($cfile) ...\n"; } + next unless -f $cfile; + if ($verbose >= 2) { print "Read $file ($cfile) ...\n"; } + my $m = YAML::Tiny->read( $cfile )->[0]; + $yamlmap = merge($m, $yamlmap); +} +if (not $yamlmap) { + die "FATAL: no configuration found\n"; +} +$list_order = $yamlmap->{"list-order"}{$list_state} if !$list_order and $list_state; +$list_order ||= $yamlmap->{"list-order"}{'default'}; + my $dbh; END { @@ -302,8 +350,7 @@ END { } my $schema_suffix = ''; -# TODO: Base this on something else, like an option that is passed. -if ($real_user eq 'nobody') { +if (isin( $op_mode, qw(list info)) && $distribution !~ /security/ && !(not -t and $user =~ /-/) && !($privmode eq 'yes')) { $dbh = DBI->connect("DBI:Pg:service=wanna-build") || die "FATAL: Cannot open database: $DBI::errstr\n"; $schema_suffix = '_public'; @@ -364,6 +411,7 @@ sub process { die "This operation is restricted to admin users\n" if (defined @conf::admin_users and !isin( $real_user, @conf::admin_users)); + lock_table(); parse_quinn_diff(1); last SWITCH; }; @@ -371,6 +419,7 @@ sub process { die "This operation is restricted to admin users\n" if (defined @conf::admin_users and !isin( $real_user, @conf::admin_users)); + lock_table(); parse_quinn_diff(0); last SWITCH; }; @@ -378,13 +427,15 @@ sub process { die "This operation is restricted to admin users\n" if (defined @conf::admin_users and !isin( $real_user, @conf::admin_users)); - parse_packages(); + lock_table(); + parse_packages(0); last SWITCH; }; /^merge-sources/ && do { die "This operation is restricted to admin users\n" if (defined @conf::admin_users and !isin( $real_user, @conf::admin_users)); + lock_table(); parse_sources(0); last SWITCH; }; @@ -392,13 +443,14 @@ sub process { pretend_avail( @ARGV ); last SWITCH; }; - /^merge-all/ && do { + /^merge-all$/ && do { die "This operation is restricted to admin users\n" if (defined @conf::admin_users and !isin( $real_user, @conf::admin_users)); + lock_table(); my @ARGS = @ARGV; @ARGV = ( $ARGS[0] ); - my $pkgs = parse_packages(); + my $pkgs = parse_packages(0); @ARGV = ( $ARGS[1] ); parse_quinn_diff(0); @ARGV = ( $ARGS[2] ); @@ -406,6 +458,29 @@ sub process { call_edos_depcheck( $ARGS[0], $srcs ); last SWITCH; }; + /^merge-all-secondary/ && do { + die "This operation is restricted to admin users\n" + if (defined @conf::admin_users and + !isin( $real_user, @conf::admin_users)); + # This is in case the chroot has multiple unrelated + # dist, for instance unstable and experimental. + # This is not for stable and proposed-updates. + # The second packages file contains a combination + # of all Packages files known to the buildd, the + # first only for the current dist. + lock_table(); + my @ARGS = @ARGV; + @ARGV = ( $ARGS[0] ); + my $pkgs = parse_packages(0); + @ARGV = ( $ARGS[3] ); + my $pkgs = parse_packages(1); + @ARGV = ( $ARGS[1] ); + parse_quinn_diff(0); + @ARGV = ( $ARGS[2] ); + my $srcs = parse_sources(1); + call_edos_depcheck( $ARGS[3], $srcs ); + last SWITCH; + }; /^import/ && do { die "This operation is restricted to admin users\n" if (defined @conf::admin_users and @@ -418,6 +493,10 @@ sub process { read_db( $import_from ); last SWITCH; }; + /^export/ && do { + export_db( $export_to ); + last SWITCH; + }; die "Unexpected operation mode $op_mode\n"; } @@ -639,7 +718,7 @@ sub add_one_attempted { return; } - if ($pkg->{'state'} ne "Building" ) { + if (($pkg->{'state'} ne "Building") && ($pkg->{'state'} ne "Build-Attempted")) { print "$name: not taken for building (state is $pkg->{'state'}). ", "Skipping.\n"; return; @@ -671,7 +750,7 @@ sub add_one_built { return; } - if ($pkg->{'state'} ne "Building" ) { + if (($pkg->{'state'} ne "Building") && ($pkg->{'state'} ne "Build-Attempted")) { print "$name: not taken for building (state is $pkg->{'state'}). ", "Skipping.\n"; return; @@ -937,7 +1016,8 @@ sub add_one_needsbuild { } } if (defined ($pkg->{'builder'}) && $user ne $pkg->{'builder'} && - !($pkg->{'builder'} =~ /^(\w+)-\w+/ && $1 eq $user)) { + !($pkg->{'builder'} =~ /^(\w+)-\w+/ && $1 eq $user) && + !$opt_override) { print "$name: not taken by you, but by ". "$pkg->{'builder'}. Skipping.\n"; return; @@ -1016,8 +1096,14 @@ sub set_one_binnmu { return; } - change_state( \$pkg, 'BD-Uninstallable' ); - $pkg->{'bd_problem'} = "Installability of build dependencies not tested yet"; + if ($distribution eq "unstable") { + change_state( \$pkg, 'BD-Uninstallable' ); + $pkg->{'bd_problem'} = "Installability of build dependencies not tested yet"; + } + else + { + change_state( \$pkg, 'Needs-Build' ); + } delete $pkg->{'builder'}; delete $pkg->{'depends'}; $pkg->{'binary_nmu_version'} = $binNMUver; @@ -1146,6 +1232,8 @@ sub parse_sources { my $name; my $full = shift; + my $db = get_all_source_info(); + local($/) = ""; # read in paragraph mode while( <> ) { my( $version, $arch, $section, $priority, $builddep, $buildconf, $binaries ); @@ -1166,7 +1254,7 @@ sub parse_sources { $pkgs{$name}{'bin'} = $binaries; $pkgs{$name}{'dep'} = $builddep; $pkgs{$name}{'conf'} = $buildconf; - my $pkg = get_source_info($name); + my $pkg = $db->{$name}; if (defined $pkg) { my $change = 0; @@ -1179,6 +1267,7 @@ sub parse_sources { "from database, because now Arch: all\n" if $verbose; del_source_info($name); + delete $db->{$name}; next; } @@ -1206,7 +1295,6 @@ sub parse_sources { } # remove installed packages that no longer have source available # or binaries installed - my $db = get_all_source_info(); foreach $name (keys %$db) { next if $name =~ /^_/; my $pkg = $db->{$name}; @@ -1218,6 +1306,7 @@ sub parse_sources { "not in Sources anymore\n" if $verbose; del_source_info($name); + delete $db->{$name}; } else { next if !isin( $pkg->{'state'}, qw(Installed) ); if ($full && not defined $merge_srcvers{$name}) { @@ -1228,6 +1317,7 @@ sub parse_sources { "binaries don't exist anymore\n" if $verbose; del_source_info($name); + delete $db->{$name}; } elsif ($full && version_less( $merge_srcvers{$name}, $pkg->{'version'})) { print "$name ($pkg->{'version'}): ". "package is Installed but binaries are from ". @@ -1242,8 +1332,10 @@ sub parse_sources { # This function looks through a Packages file and sets the state of # packages to 'Installed' sub parse_packages { + my $depwait_only = shift; my $installed; + my $pkgs = get_all_source_info(); local($/) = ""; # read in paragraph mode while( <> ) { my( $name, $version, $depends, $source, $sourcev, $architecture, $provides, $binaryv, $binnmu ); @@ -1259,6 +1351,7 @@ sub parse_packages { next if (defined ($installed->{$name}) and $installed->{$name}{'version'} ne "" and version_lesseq( $version, $installed->{$name}{'version'} )); $installed->{$name}{'version'} = $version; + next if $depwait_only; $installed->{$name}{'depends'} = $depends; $installed->{$name}{'all'} = 1 if $architecture eq "all"; undef $installed->{$name}{'Provider'}; @@ -1285,7 +1378,7 @@ sub parse_packages { next if defined($merge_srcvers{$name}) and $merge_srcvers{$name} eq $version; $merge_srcvers{$name} = $version; - my $pkg = get_source_info($name); + my $pkg = $pkgs->{$name}; if (defined $pkg) { if (isin( $pkg->{'state'}, qw(Not-For-Us)) || @@ -1434,6 +1527,8 @@ sub parse_quinn_diff { my %quinn_pkgs; my $dubious = ""; + my $pkgs = get_all_source_info(); + while( <> ) { my $change = 0; next if !m,^([-\w\d/]*)/ # section @@ -1448,7 +1543,7 @@ sub parse_quinn_diff { $priority = "unknown" if $priority eq "-"; $priority = "standard" if ($name eq "debian-installer"); - my $pkg = get_source_info($name); + my $pkg = $pkgs->{$name}; # Always update section and priority. if (defined($pkg)) { @@ -1691,67 +1786,172 @@ BEGIN { } sub sort_list_func { - my( $letter, $x, $ax, $bx ); - - foreach $letter (split( "", $list_order )) { - SWITCH: foreach ($letter) { - /P/ && do { - $x = $b->{'buildpri'} <=> $a->{'buildpri'}; - return $x if $x != 0; - last SWITCH; - }; - /p/ && do { - $x = $prioval{$a->{'priority'}} <=> $prioval{$b->{'priority'}}; - return $x if $x != 0; - last SWITCH; - }; - /s/ && do { - $x = $sectval{$a->{'section'}} <=> $sectval{$b->{'section'}}; - return $x if $x != 0; - last SWITCH; - }; - /n/ && do { - $x = $a->{'package'} cmp $b->{'package'}; - return $x if $x != 0; - last SWITCH; - }; - /b/ && do { - $x = $a->{'builder'} cmp $b->{'builder'}; - return $x if $x != 0; - last SWITCH; - }; - /c/ && do { - $ax = ($a->{'notes'} =~ /^(out-of-date|partial)/) ? 0 : - ($a->{'notes'} =~ /^uncompiled/) ? 2 : 1; - $bx = ($b->{'notes'} =~ /^(out-of-date|partial)/) ? 0 : - ($b->{'notes'} =~ /^uncompiled/) ? 2 : 1; - $x = $ax <=> $bx; - return $x if $x != 0; - last SWITCH; - }; - /f/ && do { - my $ca = defined $a->{'failed_category'} ? - $a->{'failed_category'} : "none"; - my $cb = defined $b->{'failed_category'} ? - $b->{'failed_category'} : "none"; - $x = $catval{$ca} <=> $catval{$cb}; - return $x if $x != 0; - last SWITCH; - }; - /S/ && do { - my $pa = $prioval{$a->{'priority'}} > - $prioval{'standard'}; - my $pb = $prioval{$b->{'priority'}} > - $prioval{'standard'}; - $x = $pa <=> $pb; - return $x if $x != 0; - last SWITCH; - }; - } + my $map_funcs = { + 'C' => ['<=>', sub { return (-1) * $_[0]->{'calprio'}; }], + 'W' => ['<=>', sub { return (-1) * $_[0]->{'state_days'}; }], + 'P' => ['<=>', sub { return (-1) * $_[0]->{'buildpri'}; }], + 'p' => ['<=>', sub { return $prioval{$_[0]->{'priority'}}; }], + 's' => ['<=>', sub { return $sectval{$_[0]->{'section'}}; }], + 'n' => ['cmp', sub { return $_[0]->{'package'}; }], + 'b' => ['cmp', sub { return $_[0]->{'builder'}; }], + 'c' => ['<=>', sub { return ($_[0]->{'notes'} =~ /^(out-of-date|partial)/) ? 0: ($_[0]->{'notes'} =~ /^uncompiled/) ? 2 : 1; }], + 'f' => ['<=>', sub { return $catval{ $_[0]->{'failed_category'} ? $_[0]->{'failed_category'}: "none" }; }], + 'S' => ['<=>', sub { return $prioval{$_[0]->{'priority'}} > $prioval{'standard'}; }], + }; + + foreach my $letter (split( //, $list_order )) { + my $r; + $r = &{$map_funcs->{$letter}[1]}($a) <=> &{$map_funcs->{$letter}[1]}($b) if $map_funcs->{$letter}[0] eq '<=>'; + $r = &{$map_funcs->{$letter}[1]}($a) cmp &{$map_funcs->{$letter}[1]}($b) if $map_funcs->{$letter}[0] eq 'cmp'; + return $r if $r != 0; } return 0; } +sub calculate_prio { + my $priomap = $yamlmap->{priority}; + my $pkg = shift; + my @s=split("/", $pkg->{'section'}); + $pkg->{'component'} = $s[0] if $s[1]; + $pkg->{'component'} ||= 'main'; + $pkg->{'calprio'} = 0; + foreach my $k (keys %{$priomap->{keys}}) { + $pkg->{'calprio'} += $priomap->{keys}->{$k}{$pkg->{$k}} if $pkg->{$k} and $priomap->{keys}->{$k}{$pkg->{$k}}; + } + + my $days = $pkg->{'state_days'}; + $days = $priomap->{'waitingdays'}->{'min'} if $priomap->{'waitingdays'}->{'min'} and $days < $priomap->{'waitingdays'}->{'min'}; + $days = $priomap->{'waitingdays'}->{'max'} if $priomap->{'waitingdays'}->{'max'} and $days > $priomap->{'waitingdays'}->{'max'}; + my $scale = $priomap->{'waitingdays'}->{'scale'} || 1; + $pkg->{'calprio'} += $days * $scale; + + $pkg->{'calprio'} += $pkg->{'permbuildpri'} if $pkg->{'permbuildpri'}; + $pkg->{'calprio'} += $pkg->{'buildpri'} if $pkg->{'buildpri'}; + + return $pkg; +} + + +sub seconds2time { + my $t = shift; + return "" unless $t; + my $sec = $t % 60; + my $min = int($t/60) % 60; + my $hours = int($t / 3600); + return sprintf("%d:%02d:%02d", $hours, $min, $sec) if $hours; + return sprintf("%d:%02d", $min, $sec); +} + + +sub use_fmt { + my $r; + + if (ref($_[0]) eq 'CODE') { + $r = &{$_[0]}; + } else { + $r = $_[0]; + } + + shift; + my $t = shift; + + $r ||= ""; + return $r unless $t; + + my $pkg = shift; + my $var = shift; + if (substr($t,0,1) eq '!') { + $t = substr($t,1); + return "" if $r; + } else { + return "" unless $r; + } + if ($t =~ /%/) { + return print_format($t, $pkg, $var); + } + return $t; +} +sub make_fmt { my $c = shift; my $pkg = shift; my $var = shift; return sub { use_fmt($c, $_[0], $pkg, $var); } }; + +sub print_format { + my $printfmt = shift; + my $pkg = shift; + my $var = shift; +=pod +Within an format string, the following values are allowed (need to be preceded by %). +This can be combined to e.g. +wanna-build --format='wanna-build -A %a --give-back %p_%v' -A mipsel --list=failed + +a Architecture +c section (e.g. libs or utils) +D in case of BD-Uninstallable the reason for the uninstallability +d distribution +E in case of Dep-Wait the packages being waited on, in case of Needs-Build the number in the queue +F in case of Failed the fail reason +n newline +o time of last successful build (seconds) +O time of last successful build (formated) +P previous state +p Package name +q time of last build (seconds) +Q time of last build (formated) +r max time of last (successful) build (seconds) +R max time of last (successful) build (formated) +S Package state +s Time in this state in full seconds since epoch +t time of state change +u Builder (e.g. buildd_mipsel-rem) +v Package version +V full Package version (i.e. with +b.., = %v%{+b}B%B +X the string normally between [], e.g. optional:out-of-date:calprio{61}:days{25} + +%{Text}? print Text in case ? is not empty; ? is never printed +%{!Text}? print Text in case ? is empty; ? is never printed +Text could contain further %. To start with !, use %! + +=cut + return stringf($printfmt, ( + 'p' => make_fmt( $pkg->{'package'}, $pkg, $var), + 'a' => make_fmt( $arch, $pkg, $var), + 's' => make_fmt( sub { return floor(str2time($pkg->{'state_change'})); }, $pkg, $var), + 'v' => make_fmt( $pkg->{'version'}, $pkg, $var), + 'V' => make_fmt( sub { $pkg->{'binary_nmu_version'} ? $pkg->{'version'}."+b".$pkg->{'binary_nmu_version'} : $pkg->{'version'} }, $pkg, $var), + 'S' => make_fmt( $pkg->{'state'}, $pkg, $var), + 'u' => make_fmt( $pkg->{'builder'}, $pkg, $var), + 'X' => make_fmt( sub { + my $c = "$pkg->{'priority'}:$pkg->{'notes'}"; + $c .= ":PREV-FAILED" if $pkg->{'previous_state'} =~ /^Failed/; + $c .= ":bp{" . $pkg->{'buildpri'} . "}" if defined $pkg->{'buildpri'}; + $c .= ":binNMU{" . $pkg->{'binary_nmu_version'} . "}" if defined $pkg->{'binary_nmu_version'}; + $c .= ":calprio{". $pkg->{'calprio'}."}"; + $c .= ":days{". $pkg->{'state_days'}."}"; + return $c; + }, $pkg, $var), + 'c' => make_fmt( $pkg->{'section'}, $pkg, $var), + 'P' => make_fmt( $pkg->{'previous_state'} || "unknwon", $pkg, $var), + 'E' => make_fmt( sub { return $pkg->{'depends'} if $pkg->{'state'} eq "Dep-Wait"; + return $var->{scnt}{'Needs-Build'} + 1 if $pkg->{'state'} eq 'Needs-Build'; + return ""; }, $pkg, $var), + 'F' => make_fmt( sub { return "" unless $pkg->{'failed'}; + my $failed = $pkg->{'failed'}; + $failed =~ s/\\/\\\\/g; + return $pkg->{'package'}."#".$arch."-failure\n ". + join("\\0a",split("\n",$failed))."\\0a\n"; }, $pkg, $var), + 'D' => make_fmt( sub { return "" unless $pkg->{'bd_problem'}; + return $pkg->{'package'}."#".$arch."-bd-problem\n". + join("\\0a",split("\n",$pkg->{'bd_problem'}))."\\0a\n"; }, $pkg, $var), + 'B' => make_fmt( sub { return $pkg->{'binary_nmu_version'} if defined $pkg->{'binary_nmu_version'}; }, $pkg, $var), + 'd' => make_fmt( $pkg->{'distribution'}, $pkg, $var), + 't' => make_fmt( $pkg->{'state_change'}, $pkg, $var), + 'o' => make_fmt( $pkg->{'successtime'}, $pkg, $var), + 'O' => make_fmt( sub { return seconds2time ( $pkg->{'successtime'}); }, $pkg, $var), + 'q' => make_fmt( $pkg->{'anytime'}, $pkg, $var), + 'Q' => make_fmt( sub { return seconds2time ( $pkg->{'anytime'}); }, $pkg, $var), + 'r' => make_fmt( sub { return max($pkg->{'successtime'}, $pkg->{'anytime'}); }, $pkg, $var), + 'R' => make_fmt( sub { return seconds2time ( max($pkg->{'successtime'}, $pkg->{'anytime'})); }, $pkg, $var), + )); +} + sub list_packages { my $state = shift; my( $name, $pkg, @list ); @@ -1759,35 +1959,34 @@ sub list_packages { my %scnt; my $ctime = time; - my $db = get_all_source_info(); + my $db = get_all_source_info(state => $state, user => $user, category => $category, list_min_age => $list_min_age); foreach $name (keys %$db) { next if $name =~ /^_/; - $pkg = $db->{$name}; - next if $state ne "all" && $pkg->{'state'} !~ /^\Q$state\E$/i; - next if $user && (lc($state) ne 'needs-build' and $pkg->{'builder'} ne $user); - next if $category && $pkg->{'state'} eq "Failed" && - $pkg->{'failed_category'} ne $category; - next if ($list_min_age > 0 && - ($ctime-parse_date($pkg->{'state_change'})) < $list_min_age)|| - ($list_min_age < 0 && - ($ctime-parse_date($pkg->{'state_change'})) > -$list_min_age); - push( @list, $pkg ); + push @list, calculate_prio($db->{$name}); } + # filter components + @list = grep { my $i = $_->{'component'}; grep { $i eq $_ } split /[, ]+/, $yamlmap->{"restrict"}{'component'} } @list; + + # first adjust ownprintformat, then set printformat accordingly + $printformat ||= $yamlmap->{"format"}{$ownprintformat}; + $printformat ||= $yamlmap->{"format"}{"default"}{$state}; + $printformat ||= $yamlmap->{"format"}{"default"}{"default"}; + undef $printformat if ($ownprintformat eq 'none'); + foreach $pkg (sort sort_list_func @list) { - print "$pkg->{'section'}/$pkg->{'package'}_$pkg->{'version'}"; - print ": $pkg->{'state'}" + if ($printformat) { + print print_format($printformat, $pkg, {'cnt' => $cnt, 'scnt' => \%scnt})."\n"; + ++$cnt; + $scnt{$pkg->{'state'}}++; + next; + } + print print_format("%c/%p_%v", $pkg, {}); + print print_format(": %S", $pkg, {}) if $state eq "all"; - print " by $pkg->{'builder'}" - if $pkg->{'state'} ne "Needs-Build" && $pkg->{'builder'}; - print " [$pkg->{'priority'}:$pkg->{'notes'}"; - print ":PREV-FAILED" - if $pkg->{'previous_state'} =~ /^Failed/; - print ":bp{" . $pkg->{'buildpri'} . "}" - if defined $pkg->{'buildpri'}; - print ":binNMU{" . $pkg->{'binary_nmu_version'} . "}" - if defined $pkg->{'binary_nmu_version'}; - print "]\n"; + print print_format("%{ by }u%u", $pkg, {}) + if $pkg->{'state'} ne "Needs-Build"; + print print_format(" [%X]\n", $pkg, {}); print " Reasons for failing:\n", " [Category: ", defined $pkg->{'failed_category'} ? $pkg->{'failed_category'} : "none", @@ -1799,23 +1998,26 @@ sub list_packages { print " Reasons for BD-Uninstallable:\n ", join("\n ",split("\n",$pkg->{'bd_problem'})), "\n" if $pkg->{'state'} eq "BD-Uninstallable"; - print " Previous state was $pkg->{'previous_state'} until ", - "$pkg->{'state_change'}\n" + print " Previous state was $pkg->{'previous_state'}\n" if $verbose && $pkg->{'previous_state'}; print " No previous state recorded\n" if $verbose && !$pkg->{'previous_state'}; + print " State changed at $pkg->{'state_change'}\n" + if $verbose && $pkg->{'state_change'}; + print " Previous state $pkg->{'previous_state'} left $pkg->{'state_time'} ago\n" + if $verbose && $pkg->{'previous_state'}; print " Previous failing reasons:\n ", join("\n ",split("\n",$pkg->{'old_failed'})), "\n" if $verbose && $pkg->{'old_failed'}; ++$cnt; $scnt{$pkg->{'state'}}++ if $state eq "all"; } - if ($state eq "all") { + if ($state eq "all" && !$printformat) { foreach (sort keys %scnt) { print "Total $scnt{$_} package(s) in state $_.\n"; } } - print "Total $cnt package(s)\n"; + print "Total $cnt package(s)\n" unless $printformat; } @@ -1824,17 +2026,32 @@ sub info_packages { my @firstkeys = qw(package version builder state section priority installed_version previous_state state_change); my @dists = $info_all_dists ? keys %conf::distributions : ($distribution); + my %beautykeys = ( 'package' => 'Package', 'version' => 'Version', 'builder' => 'Builder', + 'state' => 'State', 'section' => 'Section', 'priority' => 'Priority', + 'installed_version' => 'Installed-Version', 'previous_state' => 'Previous-State', + 'state_change' => 'State-Change', + 'bd_problem' => 'BD-Problem', + 'binary_nmu_changelog' => 'Binary-NMU-Changelog', 'binary_nmu_version' => 'Binary-NMU-Version', + 'buildpri' => 'BuildPri', 'depends' => 'Depends', 'failed' => 'Failed', + 'failed_category' => 'Failed-Category', 'notes' => 'Notes', + 'distribution' => 'Distribution', 'old_failed' => 'Old-Failed', + 'permbuildpri' => 'PermBuildPri', 'rel' => 'Rel', + 'calprio' => 'CalculatedPri', 'state_days' => 'State-Days', + 'successtime' => 'Success-build-time', + 'anytime' => 'Build-time' + ); foreach $name (@_) { $name =~ s/_.*$//; # strip version foreach $dist (@dists) { my $pname = "$name" . ($info_all_dists ? "($dist)" : ""); - $pkg = get_source_info($name); + $pkg = get_readonly_source_info($name); if (!defined( $pkg )) { print "$pname: not registered\n"; next; } + $pkg = calculate_prio($pkg); print "$pname:\n"; foreach $key (@firstkeys) { @@ -1844,15 +2061,7 @@ sub info_packages { $val = "\n$val" if isin( $key, qw(Failed Old-Failed)); $val =~ s/\n/\n /g; my $print_key = $key; - $print_key = 'Package' if ($key eq 'package'); - $print_key = 'Version' if ($key eq 'version'); - $print_key = 'Builder' if ($key eq 'builder'); - $print_key = 'State' if ($key eq 'state'); - $print_key = 'Section' if ($key eq 'section'); - $print_key = 'Priority' if ($key eq 'priority'); - $print_key = 'Installed-Version' if ($key eq 'installed_version'); - $print_key = 'Previous-State' if ($key eq 'previous_state'); - $print_key = 'State-Change' if ($key eq 'state_change'); + $print_key = $beautykeys{$print_key} if $beautykeys{$print_key}; printf " %-20s: %s\n", $print_key, $val; } foreach $key (sort keys %$pkg) { @@ -1863,18 +2072,7 @@ sub info_packages { $val = "\n$val" if isin( $key, qw(Failed Old-Failed)); $val =~ s/\n/\n /g; my $print_key = $key; - $print_key = 'BD-Problem' if ($key eq 'bd_problem'); - $print_key = 'Binary-NMU-Changelog' if ($key eq 'binary_nmu_changelog'); - $print_key = 'Binary-NMU-Version' if ($key eq 'binary_nmu_version'); - $print_key = 'BuildPri' if ($key eq 'buildpri'); - $print_key = 'Depends' if ($key eq 'depends'); - $print_key = 'Failed' if ($key eq 'failed'); - $print_key = 'Failed-Category' if ($key eq 'failed_category'); - $print_key = 'Notes' if ($key eq 'notes'); - $print_key = 'Distribution' if ($key eq 'distribution'); - $print_key = 'Old-Failed' if ($key eq 'old_failed'); - $print_key = 'PermBuildPri' if ($key eq 'permbuildpri'); - $print_key = 'Rel' if ($key eq 'rel'); + $print_key = $beautykeys{$print_key} if $beautykeys{$print_key}; printf " %-20s: %s\n", $print_key, $val; } } @@ -1988,6 +2186,32 @@ sub check_entry { ) ); } +sub export_db { + my $file = shift; + my($name,$pkg,$key); + + print "Writing ASCII database to $file..." if $verbose >= 1; + open( F, ">$file" ) or + die "Can't open export $file: $!\n"; + + my $db = get_all_source_info(); + foreach $name (keys %$db) { + next if $name =~ /^_/; + my $pkg = $db->{$name}; + foreach $key (keys %{$pkg}) { + my $val = $pkg->{$key}; + next if !defined($val); + $val =~ s/\n*$//; + $val =~ s/^/ /mg; + $val =~ s/^ +$/ ./mg; + print F "$key: $val\n"; + } + print F "\n"; + } + close( F ); + print "done\n" if $verbose >= 1; +} + sub change_state { my $pkgr = shift; my $pkg = $$pkgr; @@ -1997,6 +2221,7 @@ sub change_state { return if defined($$state) and $$state eq $newstate; $pkg->{'previous_state'} = $$state if defined($$state); $pkg->{'state_change'} = $curr_date; + $pkg->{'do_state_change'} = 1; if (defined($$state) and $$state eq 'Failed') { $pkg->{'old_failed'} = @@ -2024,13 +2249,13 @@ sub log_ta { "changed from $prevstate to $pkg->{'state'} ". "by $real_user as $user"; - my $transactlog = db_transactlog(); - if (!open( LOG, ">>$transactlog" )) { - warn "Can't open log file $transactlog: $!\n"; - return; - } - print LOG "$curr_date: $str\n"; - close( LOG ); + $dbh->do('INSERT INTO ' . transactions_table_name() . + ' (package, distribution, version, action, ' . + ' prevstate, state, real_user, set_user, time) ' . + ' values (?, ?, ?, ?, ?, ?, ?, ?, ?)', + undef, $pkg->{'package'}, $distribution, + $pkg->{'version'}, $action, $prevstate, $pkg->{'state'}, + $real_user, $user, 'now()') or die $dbh->errstr; if (!($prevstate eq 'Failed' && $pkg->{'state'} eq 'Failed')) { $str .= " (with --override)" @@ -2062,10 +2287,6 @@ sub send_mail { close( PIPE ); } -sub db_transactlog { - return "$conf::basedir/$arch/$conf::transactlog"; -} - # for parsing input to dep-wait sub parse_deplist { my $deps = shift; @@ -2102,59 +2323,6 @@ sub parse_deplist { return \%result; } -# for parsing Build-Depends from Sources -sub parse_srcdeplist { - my $pkg = shift; - my $deps = shift; - my $arch = shift; - my $dep; - my @results; - - foreach $dep (split( /\s*,\s*/, $deps )) { - my @alts = split( /\s*\|\s*/, $dep ); - # Anything with an | is ignored, as it can be configured on a - # per-buildd basis what will be installed - next if $#alts != 0; - $_ = shift @alts; - if (!/^([^\s([]+)\s*(\(\s*([<=>]+)\s*(\S+)\s*\))?(\s*\[([^]]+)\])?/) { - warn( "parse_srcdeplist: bad dependency $_\n" ); - next; - } - my($dep, $rel, $relv, $archlist) = ($1, $3, $4, $6); - if ($archlist) { - $archlist =~ s/^\s*(.*)\s*$/$1/; - my @archs = split( /\s+/, $archlist ); - my ($use_it, $ignore_it, $include) = (0, 0, 0); - foreach (@archs) { - if (/^!/) { - $ignore_it = 1 if substr($_, 1) eq $arch; - } else { - $use_it = 1 if $_ eq $arch; - $include = 1; - } - } - warn "Warning: inconsistent arch restriction on ", - "$pkg: $dep depedency\n" - if $ignore_it && $use_it; - next if $ignore_it || ($include && !$use_it); - } - my $neg = 0; - if ($dep =~ /^!/) { - $dep =~ s/^!\s*//; - $neg = 1; - } - my $result; - $result->{'package'} = $dep; - $result->{'Neg'} = $neg; - if ($rel && $relv) { - $result->{'rel'} = $rel; - $result->{'version'} = $relv; - } - push @results, $result; - } - return \@results; -} - sub build_deplist { my $list = shift; my($key, $result); @@ -2168,83 +2336,6 @@ sub build_deplist { return $result; } -sub get_unsatisfied_dep { - my $bd = shift; - my $pkgs = shift; - my $dep = shift; - my $savedep = shift; - - my $pkgname = $dep->{'package'}; - - if (defined $pkgs->{$pkgname}{'Provider'}) { - # provides. leave them for buildd/sbuild. - return ""; - } - - # check cache - return $pkgs->{$pkgname}{'Unsatisfied'} if $savedep and defined($pkgs->{$pkgname}{'Unsatisfied'}); - - # Return unsatisfied deps to a higher caller to process - if ((!defined($pkgs->{$pkgname})) or - (defined($dep->{'rel'}) and !version_compare( $pkgs->{$pkgname}{'version'}, $dep->{'rel'}, $dep->{'Version'} ) ) ) { - my %deplist; - $deplist{$pkgname} = $dep; - my $deps = build_deplist(\%deplist); - $pkgs->{$pkgname}{'Unsatisfied'} = $deps if $savedep; - return $deps; - } - - # set cache to "" to avoid infinite recursion - $pkgs->{$pkgname}{'Unsatisfied'} = "" if $savedep; - - if (defined $pkgs->{$dep->{'package'}}{'depends'}) { - my $deps = parse_deplist( $pkgs->{$dep->{'package'}}{'depends'} ); - foreach (keys %$deps) { - $dep = $$deps{$_}; - # recur on dep. - my $ret = get_unsatisfied_dep($bd,$pkgs,$dep,1); - if ($ret ne "") { - my $retdep = parse_deplist( $ret ); - foreach (keys %$retdep) { - $dep = $$retdep{$_}; - - $dep->{'rel'} = '>=' if defined($dep->{'rel'}) and $dep->{'rel'} =~ '^='; - - if (defined($dep->{'rel'}) and $dep->{'rel'} =~ '^>' and defined ($pkgs->{$dep->{'package'}}) and - version_compare($bd->{$pkgs->{$dep->{'package'}}{'Source'}}{'ver'},'>>',$pkgs->{$dep->{'package'}}{'Sourcev'})) { - if (not defined($merge_binsrc{$dep->{'package'}})) { - # the uninstallable package doesn't exist in the new source; look for something else that does. - delete $$retdep{$dep->{'package'}}; - foreach (sort (split( /\s*,\s*/, $bd->{$pkgs->{$dep->{'package'}}{'Source'}}{'bin'}))) { - next if ($pkgs->{$_}{'all'} or not defined $pkgs->{$_}{'version'}); - $dep->{'package'} = $_; - $dep->{'rel'} = '>>'; - $dep->{'version'} = $pkgs->{$_}{'Version'}; - $$retdep{$_} = $dep; - last; - } - } - } else { - # sanity check to make sure the depending binary still exists, and the depended binary exists and dep-wait on a new version of it - if ( defined($merge_binsrc{$pkgname}) and defined($pkgs->{$dep->{'package'}}{'version'}) ) { - delete $$retdep{$dep->{'package'}}; - $dep->{'package'} = $pkgname; - $dep->{'rel'} = '>>'; - $dep->{'version'} = $pkgs->{$pkgname}{'Version'}; - $$retdep{$pkgname} = $dep; - } - delete $$retdep{$dep->{'package'}} if (defined ($dep->{'rel'}) and $dep->{'rel'} =~ '^>'); - } - } - $ret = build_deplist($retdep); - $pkgs->{$pkgname}{'Unsatisfied'} = $ret if $savedep; - return $ret; - } - } - } - return ""; -} - sub call_edos_depcheck { my $packagesfile = shift; my $srcs = shift; @@ -2277,7 +2368,7 @@ sub call_edos_depcheck { open SOURCES, '>', $tmpfile or die "Could not open temporary file $tmpfile\n"; for my $key (keys %interesting_packages) { - my $pkg = get_source_info($key); + my $pkg = $db->{$key}; print SOURCES "Package: $key\n"; print SOURCES "Version: $pkg->{'version'}\n"; print SOURCES "Build-Depends: $srcs->{$key}{'dep'}\n" if $srcs->{$key}{'dep'}; @@ -2313,7 +2404,7 @@ sub call_edos_depcheck { unlink( $tmpfile ); for my $key (keys %interesting_packages) { - my $pkg = get_source_info($key); + my $pkg = $db->{$key}; my $change = (defined $interesting_packages{$key} and $pkg->{'state'} eq 'Needs-Build') || (not defined $interesting_packages{$key} and $pkg->{'state'} eq 'BD-Uninstallable'); @@ -2348,6 +2439,7 @@ sub usage { Usage: $prgname Options: -v, --verbose: Verbose execution. + -A arch: Architecture this operation is for. --take: Take package for building [default operation] -f, --failed: Record in database that a build failed due to deficiencies in the package (that aren't fixable without a new @@ -2385,6 +2477,7 @@ Options: if -l is missing, set user name to be entered in db; usually automatically choosen --import FILE: Import database from a ASCII file FILE + --export FILE: Export database to a ASCII file FILE The remaining arguments (depending on operation) usually start with "name_version", the trailer is ignored. This allows to pass the names @@ -2415,18 +2508,81 @@ sub user_table_name { return '"' . $arch . $schema_suffix . '".users'; } +sub transactions_table_name { + return '"' . $arch . $schema_suffix . '".transactions'; +} + +sub pkg_history_table_name { + return '"' . $arch . $schema_suffix . '".pkg_history'; +} + +sub get_readonly_source_info { + my $name = shift; + # SELECT FLOOR(EXTRACT('epoch' FROM age(localtimestamp, '2010-01-22 23:45')) / 86400) -- change to that? + my $q = "SELECT rel, priority, state_change, permbuildpri, section, buildpri, failed, state, binary_nmu_changelog, bd_problem, version, package, distribution, installed_version, notes, failed_category, builder, old_failed, previous_state, binary_nmu_version, depends, extract(days from date_trunc('days', now() - state_change)) as state_days" + . ", (SELECT max(build_time) FROM ".pkg_history_table_name()." WHERE pkg_history.package = packages.package AND pkg_history.distribution = packages.distribution AND result = 'successful') AS successtime" + . ", (SELECT max(build_time) FROM ".pkg_history_table_name()." WHERE pkg_history.package = packages.package AND pkg_history.distribution = packages.distribution ) AS anytime" + . " FROM " . table_name() + . ' WHERE package = ? AND distribution = ?'; + my $pkg = $dbh->selectrow_hashref( $q, + undef, $name, $distribution); + return $pkg; +} + sub get_source_info { my $name = shift; - my $pkg = $dbh->selectrow_hashref('SELECT * FROM ' . - table_name() . ' WHERE package = ? AND distribution = ?', + my $pkg = $dbh->selectrow_hashref('SELECT *, extract(days from date_trunc(\'days\', now() - state_change)) as state_days FROM ' . + table_name() . ' WHERE package = ? AND distribution = ?' . + ' FOR UPDATE', undef, $name, $distribution); return $pkg; } sub get_all_source_info { - my $db = $dbh->selectall_hashref('SELECT * FROM ' . table_name() . - ' WHERE distribution = ?', - 'package', undef, $distribution); + my %options = @_; + + my $q = "SELECT rel, priority, state_change, permbuildpri, section, buildpri, failed, state, binary_nmu_changelog, bd_problem, version, package, distribution, installed_version, notes, failed_category, builder, old_failed, previous_state, binary_nmu_version, depends, extract(days from date_trunc('days', now() - state_change)) as state_days" + . ", (SELECT max(build_time) FROM ".pkg_history_table_name()." WHERE pkg_history.package = packages.package AND pkg_history.distribution = packages.distribution AND result = 'successful') AS successtime" + . ", (SELECT max(build_time) FROM ".pkg_history_table_name()." WHERE pkg_history.package = packages.package AND pkg_history.distribution = packages.distribution ) AS anytime" + . " FROM " . table_name() + . " WHERE TRUE "; + my @args = (); + if ($distribution) { + my @dists = split(/[, ]+/, $distribution); + $q .= ' AND ( distribution = ? '.(' OR distribution = ? ' x $#dists).' )'; + foreach my $d ( @dists ) { + push @args, ($d); + } + } + if ($options{state} && uc($options{state}) ne "ALL") { + $q .= ' AND upper(state) = ? '; + push @args, uc($options{state}); + } + + if ($options{user}) { + #this basically means "this user, or no user at all": + $q .= ' AND (builder = ? OR upper(state) = ?)'; + push @args, $options{user}; + push @args, "NEEDS-BUILD"; + } + + if ($options{category}) { + $q .= ' AND failed_category <> ? AND upper(state) = ? '; + push @args, $options{category}; + push @args, "FAILED"; + } + + if ($options{list_min_age} > 0) { + $q .= ' AND age(state_change) > ? '; + push @args, $options{list_min_age} . " days"; + } + + if ($options{list_min_age} < 0) { + $q .= ' AND age(state_change) < ? '; + push @args, -$options{list_min_age} . " days"; + } + + my $db = $dbh->selectall_hashref($q, 'package', undef, @args); return $db; } @@ -2446,7 +2602,7 @@ sub update_source_info { 'priority = ?, ' . 'installed_version = ?, ' . 'previous_state = ?, ' . - 'state_change = ?, ' . + (($pkg->{'do_state_change'}) ? "state_change = now()," : ""). 'notes = ?, ' . 'builder = ?, ' . 'failed = ?, ' . @@ -2467,7 +2623,6 @@ sub update_source_info { $pkg->{'priority'}, $pkg->{'installed_version'}, $pkg->{'previous_state'}, - $pkg->{'state_change'}, $pkg->{'notes'}, $pkg->{'builder'}, $pkg->{'failed'}, @@ -2525,3 +2680,9 @@ sub add_user_info { or die $dbh->errstr; } +sub lock_table() +{ + $dbh->do('LOCK TABLE ' . table_name() . + ' IN EXCLUSIVE MODE', undef) or die $dbh->errstr; +} +