X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=bin%2Fwanna-build;h=5ebd6196a8f8b917f3b14e6fd897208e8689ecb9;hb=4572e2d58812a9c5f422a8c2e2401c441d528bb7;hp=8780000876d6b60da09f3fed56ae2d67cc43d593;hpb=82687dad4773036a4aa5100a6940758b6bcbf7ab;p=wannabuild.git diff --git a/bin/wanna-build b/bin/wanna-build index 8780000..5ebd619 100755 --- a/bin/wanna-build +++ b/bin/wanna-build @@ -19,8 +19,12 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA # +use strict; +use warnings; package conf; + +use vars qw< $basedir $dbbase $transactlog $mailprog $buildd_domain >; # defaults $basedir ||= "/var/lib/debbuild"; $dbbase ||= "build-db"; @@ -34,7 +38,6 @@ die "mailprog binary $conf::mailprog does not exist or isn't executable\n" if !-x $conf::mailprog; package main; -use strict; use POSIX; use FileHandle; use File::Copy; @@ -517,7 +520,7 @@ sub process { @ARGV = ( $ARGS[0] ); my $pkgs = parse_packages(0); @ARGV = ( $ARGS[3] ); - my $pkgs = parse_packages(1); + $pkgs = parse_packages(1); @ARGV = ( $ARGS[1] ); parse_quinn_diff(0); @ARGV = ( $ARGS[2] ); @@ -2007,7 +2010,9 @@ 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 @@ -2041,6 +2046,7 @@ X the string normally between [], e.g. optional:out-of-date:calprio{61}:days{25} 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), @@ -2256,11 +2262,11 @@ sub read_db { my $file = shift; print "Reading ASCII database from $file..." if $verbose >= 1; - open( F, "<$file" ) or + open( my $fh, '<', $file ) or die "Can't open database $file: $!\n"; local($/) = ""; # read in paragraph mode - while( ) { + while( <$fh> ) { my( %thispkg, $name ); s/[\s\n]+$//; s/\n[ \t]+/\376\377/g; # fix continuation lines @@ -2288,7 +2294,7 @@ sub read_db { or die $dbh->errstr; } } - close( F ); + close( $fh ); print "done\n" if $verbose >= 1; } @@ -2328,7 +2334,7 @@ sub export_db { my($name,$pkg,$key); print "Writing ASCII database to $file..." if $verbose >= 1; - open( F, ">$file" ) or + open( my $fh, '>', $file ) or die "Can't open export $file: $!\n"; my $db = get_all_source_info(); @@ -2341,11 +2347,11 @@ sub export_db { $val =~ s/\n*$//; $val =~ s/^/ /mg; $val =~ s/^ +$/ ./mg; - print F "$key: $val\n"; + print $fh "$key: $val\n"; } - print F "\n"; + print $fh "\n"; } - close( F ); + close( $fh ); print "done\n" if $verbose >= 1; } @@ -2422,13 +2428,13 @@ sub send_mail { $to .= '@' . $domain if $to !~ /\@/; $text =~ s/^\.$/../mg; local $SIG{'PIPE'} = 'IGNORE'; - open( PIPE, "| $conf::mailprog -oem $to" ) + open( my $pipe, '|-', "$conf::mailprog -oem $to" ) or die "Can't open pipe to $conf::mailprog: $!\n"; chomp $text; - print PIPE "From: $from\n"; - print PIPE "Subject: $subject\n\n"; - print PIPE "$text\n"; - close( PIPE ); + print $pipe "From: $from\n"; + print $pipe "Subject: $subject\n\n"; + print $pipe "$text\n"; + close( $pipe ); } # for parsing input to dep-wait @@ -2502,8 +2508,8 @@ sub wb_edos_builddebcheck { my $packagearch=""; foreach my $packagefile (@$packagefiles) { - open(P,$packagefile); - while (

) { + open(my $fh,'<', $packagefile); + while (<$fh>) { next unless /^Architecture/; next if /^Architecture:\s*all/; /Architecture:\s*([^\s]*)/; @@ -2513,7 +2519,7 @@ sub wb_edos_builddebcheck { return "Package file contains different architectures: $packagearch, $1"; } } - close P; + close $fh; } if ( $architecture eq "" ) { @@ -2531,14 +2537,14 @@ sub wb_edos_builddebcheck { } print "calling: edos-debcheck $edosoptions < $sourcesfile ".join('', map {" '-base FILE' ".$_ } @$packagefiles)."\n"; - open(RESULT, '-|', + open(my $result_cmd, '-|', "edos-debcheck $edosoptions < $sourcesfile ".join('', map {" '-base FILE' ".$_ } @$packagefiles)); my $explanation=""; my $result={}; my $binpkg=""; - while () { + while (<$result_cmd>) { # source---pulseaudio (= 0.9.15-4.1~bpo50+1): FAILED # source---pulseaudio (= 0.9.15-4.1~bpo50+1) depends on missing: # - libltdl-dev (>= 2.2.6a-2) @@ -2567,7 +2573,7 @@ sub wb_edos_builddebcheck { } } - close RESULT; + close $result_cmd; $result->{$binpkg} = $explanation if $binpkg; return $result; @@ -2996,14 +3002,13 @@ sub add_user_info { or die $dbh->errstr; } -sub lock_table() -{ +sub lock_table { return if $simulate; $dbh->do('LOCK TABLE ' . table_name() . ' IN EXCLUSIVE MODE', undef) or die $dbh->errstr; } -sub parse_argv() { +sub parse_argv { # parts the array $_[0] and $_[1] and returns the sub-array (modifies the original one) my @ret = (); my $args = shift; @@ -3015,7 +3020,7 @@ sub parse_argv() { return @ret; } -sub parse_all_v3() { +sub parse_all_v3 { my $srcs = shift; my $vars = shift; my $db = get_all_source_info(); @@ -3031,7 +3036,7 @@ sub parse_all_v3() { unless ($pkg) { next SRCS if $pkgs->{'status'} eq 'not-for-us'; - my $logstr = "merge-v3 $vars->{'time'} ".$name."_$pkgs->{'version'} ($vars->{'arch'}, $vars->{'suite'}):"; + my $logstr = sprintf("merge-v3 %s %s_%s (%s, %s):", $vars->{'time'}, $name, $pkgs->{'version'}, $vars->{'arch'}, $vars->{'suite'}); # does at least one binary exist in the database and is more recent - if so, we're probably just outdated, ignore the source package for my $bin (@{$pkgs->{'binary'}}) { @@ -3044,7 +3049,7 @@ sub parse_all_v3() { } my $logstr = "merge-v3 $vars->{'time'} ".$name."_$pkgs->{'version'}". ($pkgs->{'binnmu'} ? ";b".$pkgs->{'binnmu'} : ""). - "($vars->{'arch'}, $vars->{'suite'}, previous: $pkg->{'version'}". + " ($vars->{'arch'}, $vars->{'suite'}, previous: $pkg->{'version'}". ($pkg->{'binary_nmu_version'} ? ";b".$pkg->{'binary_nmu_version'} : ""). ", $pkg->{'state'}):"; @@ -3095,7 +3100,7 @@ sub parse_all_v3() { } if ($pkgs->{'status'} eq 'auto-not-for-us') { - next if isin( $pkg->{'state'}, qw(Not-For-Us Failed Failed-Removed Dep-Wait Dep-Wait-Removed)); + next if isin( $pkg->{'state'}, qw(Not-For-Us Failed Failed-Removed Dep-Wait Dep-Wait-Removed Auto-Not-For-Us)); # if the package is currently current, the status is Installed, not not-for-us change_state( \$pkg, "Auto-Not-For-Us" );