--- 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__