# HG changeset patch # User Matthias Förste foerste@schlittermann.de # Date 1329733668 -3600 # Node ID ff9bdf95363c2a1f986a6c72194ab7466bee5074 # Parent da128a0b985f680ab252334e25dd0b9e5de08bc2 [perltidy] diff -r da128a0b985f -r ff9bdf95363c bin/rpi --- a/bin/rpi Mon Feb 20 11:16:13 2012 +0100 +++ b/bin/rpi Mon Feb 20 11:27:48 2012 +0100 @@ -14,14 +14,12 @@ use Pod::Usage; use Sys::Hostname::Long; -my %opt = ( - 'run-lintian' => 1, -); +my %opt = ('run-lintian' => 1,); GetOptions( - "l|run-lintian!" => \$opt{'run-lintian'}, - "h|help" => sub { pod2usage(-exit => 0, -verbose => 1) }, - "m|man" => sub { + "l|run-lintian!" => \$opt{'run-lintian'}, + "h|help" => sub { pod2usage(-exit => 0, -verbose => 1) }, + "m|man" => sub { pod2usage( -exit => 0, -verbose => 2, @@ -35,7 +33,7 @@ ) or pod2usage; my $hostname = hostname_long; -for (*STDERR, *STDOUT) { select $_; $|=1; } +for (*STDERR, *STDOUT) { select $_; $| = 1; } # see man reprepro # used as argument to the -b option of reprepro @@ -87,39 +85,56 @@ # anything matching these is considered noteworthy and should be sent to someone my $important = { - qq{^File "([^"]+)" is already registered with different checksums!} => \&m_mismatch, - "^file '([^']+)' is needed for '([^']+)', not yet registered in the pool and not found in '([^']+)'\$" => \&m_missingfile, - "^Warning: trying to put version '([^']+)' of '([^']+)' in '([^']+)',\$" => \&m_mayexist, - "^Skipping ([^ ]+) because all packages are skipped!\$" => \&m_allskipped, - "^Data seems not to be signed trying to use directly...\$" => \&m_unsigned, - "^Not putting '([^']+)' in '([^']+)' as already in there with equal or newer version.\$" => \&m_equal_or_newer, -# "^ERROR: File '([^']+)' does not match expextations:\$" => \&m_asis, -# "^In 'littlebird_2011072500-2_amd64.changes': file 'littlebird_2011072500.orig.tar.gz' not found in the incoming dir!" => \&m_asis, -# send *everything* for now - "." => \&m_asis + qq{^File "([^"]+)" is already registered with different checksums!} => + \&m_mismatch, + "^file '([^']+)' is needed for '([^']+)', not yet registered in the pool and not found in '([^']+)'\$" + => \&m_missingfile, + "^Warning: trying to put version '([^']+)' of '([^']+)' in '([^']+)',\$" => + \&m_mayexist, + "^Skipping ([^ ]+) because all packages are skipped!\$" => \&m_allskipped, + "^Data seems not to be signed trying to use directly...\$" => \&m_unsigned, + "^Not putting '([^']+)' in '([^']+)' as already in there with equal or newer version.\$" + => \&m_equal_or_newer, + + # "^ERROR: File '([^']+)' does not match expextations:\$" => \&m_asis, + # "^In 'littlebird_2011072500-2_amd64.changes': file 'littlebird_2011072500.orig.tar.gz' not found in the incoming dir!" => \&m_asis, + # send *everything* for now + "." => \&m_asis }; # anything matching these will not be sent to anyone my $unimportant = '^' - . ( join '|', + . ( + join '|', "Deleting files no longer referenced...", "Exporting indices...", "while there already is '[^']+' in there.", "(md5|sha(1|256)) expected: [[:xdigit:]]{32,}, got: [[:xdigit:]]{32,}", "size expected: \\d+, got: \\d+", - "There have been errors!") - . '$'; + "There have been errors!" + ) . '$'; my $rci = "$repo/conf/incoming"; -my $i = parse_incoming($rci)->{$ruleset}->{'IncomingDir'}; -die "Can't find IncomingDir for ruleset [$ruleset] in configuration file: [$rci]\n" unless defined $i; +my $i = parse_incoming($rci)->{$ruleset}->{'IncomingDir'}; +die + "Can't find IncomingDir for ruleset [$ruleset] in configuration file: [$rci]\n" + unless defined $i; # we need to determine uploaders before running reprepro, because it will # remove the *.changes files before we are going to parse its output my $uploaders = { map { $_ => uploader($_) } glob("$i/*.changes") }; -if ($opt{'run-lintian'}) { for my $c (keys %{$uploaders}) { sendmails ({ $uploaders->{$c} => scalar qx{lintian $c 2>&1} }, $valid_receivers, $fallback, $hostname, "[$hostname] Lintian Report"); }}; -my $messages = run_command_and_parse_output([@cmd], $uploaders, $important, $unimportant, $log_uncaught, $log_raw); -sendmails($messages, $valid_receivers, $fallback, $hostname, "[$hostname] Import Report"); +if ($opt{'run-lintian'}) { + for my $c (keys %{$uploaders}) { + sendmails({ $uploaders->{$c} => scalar qx{lintian $c 2>&1} }, + $valid_receivers, $fallback, $hostname, + "[$hostname] Lintian Report"); + } +} +my $messages = + run_command_and_parse_output([@cmd], $uploaders, $important, $unimportant, + $log_uncaught, $log_raw); +sendmails($messages, $valid_receivers, $fallback, $hostname, + "[$hostname] Import Report"); # determine 'uploader' of changes file; 'uploader' means here: either the # signer of the changes file or the changer or the maintainer in that order of @@ -128,72 +143,84 @@ # 'Maintainer' field if necessary; nothing will be returned if the signature # verification command fails for some reason sub uploader($) { - my ($c) = @_; - my $vc = "LANG=POSIX /usr/bin/gpg --verify $c 2>&1"; + my ($c) = @_; + my $vc = "LANG=POSIX /usr/bin/gpg --verify $c 2>&1"; - my @r = qx{$vc}; + my @r = qx{$vc}; - if ($?) { - warn "[$0]: [$vc] failed: [$!] [$?]\n"; - return; - } + if ($?) { + warn "[$0]: [$vc] failed: [$!] [$?]\n"; + return; + } - for (@r) { - return "$1" if /^gpg: Good signature from "(.+)"$/; - } + for (@r) { + return "$1" if /^gpg: Good signature from "(.+)"$/; + } - my $e; - my $fh = new IO::File "< $c" or warn "[$0]: Can't open [< $c]: $!\n"; - while (<$fh>) { - if (/^Changed-By:\s*(\S.+\S)\s*$/) { - $e = $1; last; + my $e; + my $fh = new IO::File "< $c" or warn "[$0]: Can't open [< $c]: $!\n"; + while (<$fh>) { + if (/^Changed-By:\s*(\S.+\S)\s*$/) { + $e = $1; + last; + } + $e = $1 if /^Maintainer:\s*(\S.+\S)\s*$/; } - $e = $1 if /^Maintainer:\s*(\S.+\S)\s*$/ - } - close $fh or warn "[$0]: Can't close [$fh]: $!\n"; + close $fh or warn "[$0]: Can't close [$fh]: $!\n"; - return $e; + return $e; } # checksum mismatch sub m_mismatch($) { - return "Try to remove the offending lines from the changesfile or just rebuild with dpkg-buildpackage -B\n"; + return + "Try to remove the offending lines from the changesfile or just rebuild with dpkg-buildpackage -B\n"; } # missingfile sub m_missingfile($$$) { - my ($m, $i, $c) = @_; - my $t = $m =~ /\.orig\.tar\.gz$/ ? "Try to rebuild with dpkg-buildpackage -sa or do 'changestool <.changes-filename> includeallsources' and resign the changesfile afterwards\n" : ''; - #print "MISSINGFILE: [$c], [$t]\n"; - return $t; + my ($m, $i, $c) = @_; + my $t = + $m =~ /\.orig\.tar\.gz$/ + ? "Try to rebuild with dpkg-buildpackage -sa or do 'changestool <.changes-filename> includeallsources' and resign the changesfile afterwards\n" + : ''; + + #print "MISSINGFILE: [$c], [$t]\n"; + return $t; } # mayexist sub m_mayexist($$$) { - # package & version are confused in reprepro output - # currently (3.5.2-6) - # my ($p, $v, $cca) = @_; - # $cca =~ /^[^|]+\|[^|]+\|([^|]+)$/; - #print "MAYEXIST: [$c], [package ..]\n"; - return "package may be already present with higher version\n"; + # package & version are confused in reprepro output + # currently (3.5.2-6) + # my ($p, $v, $cca) = @_; + # $cca =~ /^[^|]+\|[^|]+\|([^|]+)$/; + + #print "MAYEXIST: [$c], [package ..]\n"; + return "package may be already present with higher version\n"; } # allskipped sub m_allskipped($) { - #print "ALLSKIPPED: [$_[0]], [nüx ..]\n"; - return "package may be already present with same or higher version\n"; + + #print "ALLSKIPPED: [$_[0]], [nüx ..]\n"; + return "package may be already present with same or higher version\n"; } # equal or newer sub m_equal_or_newer($$) { - #print "EQUAL_OR_NEWER: [$_[0]], [nüx ..]\n"; - return ''; + + #print "EQUAL_OR_NEWER: [$_[0]], [nüx ..]\n"; + return ''; } # unsigned -sub m_unsigned($) { return 'You may want to check whether both the .changes and the .dsc file are signed'; } +sub m_unsigned($) { + return + 'You may want to check whether both the .changes and the .dsc file are signed'; +} # return empty string sub m_asis() { return ''; } @@ -203,59 +230,62 @@ # { name2 => { field21 => value21, ... }, ... sub parse_incoming($) { - my ($cf) = @_; - my ($name, $conf); - my $fh = new IO::File "< $cf" or warn "Can't open [< $cf]: $!"; + my ($cf) = @_; + my ($name, $conf); + my $fh = new IO::File "< $cf" or warn "Can't open [< $cf]: $!"; - while (<$fh>) { + while (<$fh>) { - if (/^(\S+)\s*:\s*(\S+)\s/) { + if (/^(\S+)\s*:\s*(\S+)\s/) { - if ($1 eq 'Name') { - $name = $2; - $conf->{$name} = {}; - } else { - warn "Undefined Name\n" unless defined $name; - $conf->{$name}->{$1} = $2; - } + if ($1 eq 'Name') { + $name = $2; + $conf->{$name} = {}; + } else { + warn "Undefined Name\n" unless defined $name; + $conf->{$name}->{$1} = $2; + } + + } } + close $fh or warn "Can't close [$fh]: $!\n"; - } - close $fh or warn "Can't close [$fh]: $!\n"; - - return $conf; + return $conf; } # run the command and parse its output sub run_command_and_parse_output($$$$$$) { - my @cmd = @{shift()}; - my ($u, $important, $unimportant, $luname, $lrname) = @_; + my @cmd = @{ shift() }; + my ($u, $important, $unimportant, $luname, $lrname) = @_; - my ($ih, $oh, $eh); + my ($ih, $oh, $eh); - run \@cmd, \$ih, \$oh, \$eh or warn "running [@cmd] returned: [$?] [$!]\n"; + run \@cmd, \$ih, \$oh, \$eh or warn "running [@cmd] returned: [$?] [$!]\n"; - my ($ln, $lh); - $ln = { uncaught => $luname, raw => $lrname }; + my ($ln, $lh); + $ln = { uncaught => $luname, raw => $lrname }; - for (keys %{$ln}) { - if (defined $ln->{$_}) { - $lh->{$_} = new IO::File $ln->{$_} or warn "Can't open [$ln->{$_}]: $!\n"; + for (keys %{$ln}) { + if (defined $ln->{$_}) { + $lh->{$_} = new IO::File $ln->{$_} + or warn "Can't open [$ln->{$_}]: $!\n"; + } } - } - my $messages = parse_output([@cmd], $oh, $eh, $u, $important, $unimportant, $lh->{'uncaught'}, $lh->{'raw'}); - - for (keys %{$lh}) { - if (defined $lh->{$_}) { - close $lh->{$_} or warn "Can't close [$lh->{$_}]: $!"; + my $messages = + parse_output([@cmd], $oh, $eh, $u, $important, $unimportant, + $lh->{'uncaught'}, $lh->{'raw'}); + + for (keys %{$lh}) { + if (defined $lh->{$_}) { + close $lh->{$_} or warn "Can't close [$lh->{$_}]: $!"; + } } - } - return $messages; + return $messages; } @@ -264,128 +294,141 @@ # assign it to an uploader sub parse_output($$$$$$$$) { - my @cmd = @{shift()}; - my ($oh, $eh, $u, $important, $unimportant, $uncaught, $raw) = @_; + my @cmd = @{ shift() }; + my ($oh, $eh, $u, $important, $unimportant, $uncaught, $raw) = @_; - my ($m, $c, $f); + my ($m, $c, $f); - $f = 'fallback'; + $f = 'fallback'; LINE: - for my $line (split /\n/, $oh . $eh) { + for my $line (split /\n/, $oh . $eh) { + + $line .= "\n"; + print "[@cmd]: $line"; + print $raw "[" . gmtime() . " +0000] $line" if defined $raw; + + # try to determine uploader + if ($line =~ /^processing changesfile '([^']+)'$/) { + $c = $1; + $u = $uploaders->{$c}; + unless (defined $u) { - $line .= "\n"; - print "[@cmd]: $line"; - print $raw "[" . gmtime() . " +0000] $line" if defined $raw; + $u = $f; + my $w = + "Won't send notification for [$i/$c] because i couldn't determine any uploader to sent it to.\n"; + $m->{$u} //= ''; + $m->{$u} .= "[$c]: $w"; + warn "[$0]: $w"; + + } + + next LINE; + + } - # try to determine uploader - if ($line =~ /^processing changesfile '([^']+)'$/) { - $c = $1; - $u = $uploaders->{$c}; - unless (defined $u) { + # done with that changesfile + if ($line =~ /^changesfile '[^']+' done$/) { + undef $c; + $u = $f; + next LINE; + } - $u = $f; - my $w = "Won't send notification for [$i/$c] because i couldn't determine any uploader to sent it to.\n"; - $m->{$u} //= ''; - $m->{$u} .= "[$c]: $w"; - warn "[$0]: $w"; + # anything matching $important should be sent to someone + for (keys(%{$important})) { + if ($line =~ $_) { + my $t = $important->{$_}->($1, $2, $3, $4, $5, $6, $7, $8, $9); + if (defined $u) { + $m->{$u} = '' unless defined $m->{$u}; + $m->{$u} .= + "[" . (defined $c ? $c : "no changesfile") . "]: $line"; + $m->{$u} .= $t if defined $t; + $m->{$u} .= "\n"; + } + next LINE; + } - } + } + + # unimportant stuff? + next LINE if $line =~ /$unimportant/; - next LINE; + # everything not matching any other pattern + $m->{$f} = '' unless defined $m->{$f}; + $m->{$f} .= "[uncaught line]: $line\n"; + + print $uncaught "[" . gmtime() . " +0000] $line" if defined $uncaught; } - # done with that changesfile - if ($line =~ /^changesfile '[^']+' done$/) { - undef $c; - $u = $f; - next LINE; - } - - # anything matching $important should be sent to someone - for (keys(%{$important})) { - if ($line =~ $_) { - my $t = $important->{$_}->($1, $2, $3, $4, $5, $6, $7, $8, $9); - if (defined $u) { - $m->{$u} = '' unless defined $m->{$u}; - $m->{$u} .= "[" . ( defined $c ? $c : "no changesfile" ) . "]: $line"; - $m->{$u} .= $t if defined $t; - $m->{$u} .= "\n"; - } - next LINE; - } - - } - - # unimportant stuff? - next LINE if $line =~ /$unimportant/; - - # everything not matching any other pattern - $m->{$f} = '' unless defined $m->{$f}; - $m->{$f} .= "[uncaught line]: $line\n"; - - print $uncaught "[" . gmtime() . " +0000] $line" if defined $uncaught; - - } - - return $m; + return $m; } # send the notification mails sub sendmails($$$$$) { - my ($messages, $valid_receivers, $fallback, $hostname, $subject) = @_; + my ($messages, $valid_receivers, $fallback, $hostname, $subject) = @_; - my $from = "$ENV{LOGNAME}\@$hostname"; - my $mfb = $messages->{'fallback'}; + my $from = "$ENV{LOGNAME}\@$hostname"; + my $mfb = $messages->{'fallback'}; + + for my $u (keys %{$messages}) { + + next if $u eq 'fallback'; - for my $u (keys %{$messages}) { + if ($u =~ $valid_receivers) { - next if $u eq 'fallback'; - - if ($u =~ $valid_receivers) { + my ($msg, $to) = ($messages->{$u}, $u); + ($msg, $to) = ( + "[This is just a test mail to you. If this wasn't a test mail, then it should have been sent to [$u]]\n\n" + . $messages->{$u}, + $fallback + ) if $dont_send_to_real_uploader; - my ($msg, $to) = ($messages->{$u}, $u); - ($msg, $to) = ("[This is just a test mail to you. If this wasn't a test mail, then it should have been sent to [$u]]\n\n" . $messages->{$u}, $fallback) if $dont_send_to_real_uploader; + sendmail( + From => $from, + Subject => $subject, + To => $to, + Message => $msg + ); + print "[$0]: ", $Mail::Sendmail::log, "\n"; + warn "[$0]: ", $Mail::Sendmail::error, "\n" + if $Mail::Sendmail::error; - sendmail(From => $from, - Subject => $subject, - To => $to, - Message => $msg); - print "[$0]: ", $Mail::Sendmail::log, "\n"; - warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error; + } else { - } else { + my $w = "Won't send notification: invalid receiver [$u]\n\n"; + $mfb //= ''; + $mfb .= $w; + $mfb .= ">>>\n[$messages->{$u}]\n<<<\n\n"; + warn "[$0]: $w"; - my $w = "Won't send notification: invalid receiver [$u]\n\n"; - $mfb //= ''; $mfb .= $w; $mfb .= ">>>\n[$messages->{$u}]\n<<<\n\n"; - warn "[$0]: $w"; + } } - } - - if (defined $mfb) { + if (defined $mfb) { - sendmail(From => $from, - Subject => "[apt] Possible Problem processing incoming", - To => $fallback, - Message => $mfb); - print "[$0]: ", $Mail::Sendmail::log, "\n"; - warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error; + sendmail( + From => $from, + Subject => "[apt] Possible Problem processing incoming", + To => $fallback, + Message => $mfb + ); + print "[$0]: ", $Mail::Sendmail::log, "\n"; + warn "[$0]: ", $Mail::Sendmail::error, "\n" if $Mail::Sendmail::error; - } + } } sub BEGIN { - print "[$0]: Started at ", scalar localtime, "\n"; + print "[$0]: Started at ", scalar localtime, "\n"; } sub END { - print "[$0]: Finished at ", scalar localtime, "\n"; + print "[$0]: Finished at ", scalar localtime, "\n"; } __END__