Copyright (C) 2020-2022 Jacob Bachmeyer <jcb@gnu.org>
END
my $LICENSE = "GPLv3 or later - http://www.fsf.org/licenses/gpl.txt";
-my $URL = "http://www.gnu.org/prep/maintain/html_node/Automated-FTP-Uploads.html";
+my $URL =
+ "http://www.gnu.org/prep/maintain/html_node/Automated-FTP-Uploads.html";
BEGIN {
# These must be declared "our" so that the actual variable with the data
my $NOMAIL = 0;
- # Set this to 0 to disable the timestamp check on uploaded files in sub scan_incoming
+ # Set this to 0 to disable the timestamp check on uploaded files in sub
+ # scan_incoming
my $TSTAMPCHECK = 1;
my $TestingMode = 0;
$NAME -s <style> [-d <debuglevel>] [-v] [-h]\n
<style> is the execution 'style'. Call $NAME
- without the -s parameter to get a list of possible styles.
+ without the -s parameter to get a list of possible styles.
-d <debuglevel> (optional) set debug level. 0 means no debugging
-v (optional) display version information
-h (optional) display this help screen\n
version_information() if ($version);
usage_information(1) if ($help);
-usage_information() if (($style ne 'ftp') && ($style ne 'alpha') && ($style ne 'distros'));
+usage_information()
+ if (($style ne 'ftp') && ($style ne 'alpha') && ($style ne 'distros'));
my $m_style = 'ftp';
$m_style = 'alpha' if ($style eq 'alpha');
my $incoming_tmp = "/var/tmp/$m_style-in";
# top-level public ftp dir for installing files:
my $destfinal = "/home/$m_style/gnu";
-$destfinal = "/home/ftp/$m_style" if ($m_style eq 'gnu+linux-distros'); # The distros go here
+$destfinal = "/home/ftp/$m_style"
+ if ($m_style eq 'gnu+linux-distros'); # The distros go here
# private dir on SAME FILESYSTEM as $destfinal:
my $olddestfinal = "/home/gatekpr/$m_style-archived";
# private dir on SAME FILESYSTEM as $destfinal:
my $master_keyring = "/home/gatekpr/etc/master_pubring.gpg";
# We sometimes want to exclude e-mail addresses from being emailed.
-# Specifically, e-mail addresses we import from gpg keys - keys are still valid
-# but associated e-mail addresses are not. Ward, 2011-02-08.
+# Specifically, e-mail addresses we import from gpg keys - keys are still
+# valid but associated e-mail addresses are not. Ward, 2011-02-08.
my $email_blacklist = "/home/gatekpr/etc/email_blacklist";
# List of all package maintainers
my @directory = split(/\//,$directory);
my @pubrings = ();
- # First of all, add our 'master' keyring, for people with root to the ftp upload mechanism
+ # First of all, add our 'master' keyring, for people with root to the ftp
+ # upload mechanism
push(@pubrings,$master_keyring);
# We go through each subdirectory, starting at the lowest subdirectory,
my $tmp = $directory;
while (1) {
if (-e "$package_config_base/$tmp/pubring.gpg") {
- ftp_syslog('debug', "($log_style) DEBUG: " . "found keyring $package_config_base/$tmp/pubring.gpg") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ . "found keyring $package_config_base/$tmp/pubring.gpg")
+ if DEBUG;
push(@pubrings,"$package_config_base/$tmp/pubring.gpg");
}
my $tmp2 = $tmp;
my @ret;
open (EMAIL_FILE, "<", "$package_config_base/$package_name/email")
- or fatal("The directory line should start with the name of the package for which you are trying to upload a file, e.g. gcc, gawk, or gasm. We have no package named '$package_name'. If this is a new GNU package, please ensure that you have registered your GPG key for its uploads, per http://www.gnu.org/prep/maintain/html_node/Automated-Upload-Registration.html. The GPG key must be registered separately for each package, so this needs to be done even if you are already registered for uploading with another package.",1);
+ or fatal(<<"END",1);
+The directory line should start with the name of the package for which you
+are trying to upload a file, e.g. gcc, gawk, or gasm. We have no package
+named '$package_name'. If this is a new GNU package, please ensure that you
+have registered your GPG key for its uploads, per
+http://www.gnu.org/prep/maintain/html_node/Automated-Upload-Registration.html.
+
+The GPG key must be registered separately for each package, so this needs
+to be done even if you are already registered for uploading with another
+package.
+END
while (<EMAIL_FILE>) {
chomp;
my $line = $_;
next if (grep($_ eq $line,@ret) > 0); # Skip duplicates
- push (@ret, $line) if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check
+ push (@ret, $line)
+ if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check
}
- close (EMAIL_FILE) or ftp_warn("close($package_config_base/$package_name/email) failed: $!");
+ close (EMAIL_FILE)
+ or ftp_warn("close($package_config_base/$package_name/email) failed: $!");
# Now also look for all maintainer addresses in the maintainers.bypkg file
open (EMAIL_FILE, "<", "$maintainers_bypkg");
my @email_list = ($email_always);
# Some messages should be sent to the user, some should not
- push (@email_list, @{$info{email}}) if (defined $info{email} && $send_to_user);
+ push (@email_list, @{$info{email}})
+ if (defined $info{email} && $send_to_user);
- # If this is an e-mail to the uploader, don't send it to the script maintainer.
+ # If this is an e-mail to the uploader, don't send it to the script
+ # maintainer.
shift(@email_list) if ($send_to_user);
if ($#email_list == -1) {
- # Something went wrong, but we can't figure out which package this upload belongs to.
- # Mention that in the logs, and then mail this to the script maintainer anyway.
- ftp_syslog('info', "($log_style) No uploader e-mail address(es) to report this error to!");
+ # Something went wrong, but we can't figure out which package this
+ # upload belongs to. Mention that in the logs, and then mail this to
+ # the script maintainer anyway.
+ ftp_syslog('info', "($log_style) "
+ ."No uploader e-mail address(es) to report this error to!");
@email_list = ($email_always);
}
if (NOMAIL) {
- ftp_syslog('info', "($log_style) NOMAIL is set - not sending email to @email_list");
+ ftp_syslog('info', "($log_style) "
+ ."NOMAIL is set - not sending email to @email_list");
} else {
ftp_syslog('info', "($log_style) Sending email to @email_list");
}
my $sender = 'ftp-upload-script@gnu.org';
- $sender = 'ftp-upload@gnu.org' if ($send_to_user); # We really want replies to go to the ftp-upload queue
+ $sender = 'ftp-upload@gnu.org'
+ if ($send_to_user); # We really want replies to go to the ftp-upload queue
@email_list = exclude_mail_blacklist(@email_list);
}
ftp_die("FATAL: SMTP connection failed") unless $smtp;
- $smtp->mail ($sender);
- $smtp->bcc ($email_always) if ($send_to_user);
- $smtp->recipient (@email_list, { SkipBad => 1});
+ $smtp->mail($sender);
+ $smtp->bcc($email_always) if ($send_to_user);
+ $smtp->recipient(@email_list, { SkipBad => 1});
- $smtp->data ();
- $smtp->datasend ("To: " . join (", ", @email_list) . "\r\n");
- $smtp->datasend ("From: $sender\r\n");
- $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\r\n");
+ $smtp->data();
+ $smtp->datasend("To: " . join (", ", @email_list) . "\r\n");
+ $smtp->datasend("From: $sender\r\n");
+ $smtp->datasend("Reply-To: ftp-upload\@gnu.org\r\n");
my $mid = Email::MessageID->new;
$smtp->datasend("Message-ID: <$mid>\r\n");
- $smtp->datasend("Date: " . strftime("%a, %e %b %Y %H:%M:%S %z", localtime) . "\r\n");
+ $smtp->datasend("Date: "
+ . strftime("%a, %e %b %Y %H:%M:%S %z", localtime)
+ . "\r\n");
if ($subject ne '') {
$smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $subject");
ftp_syslog('info', "($log_style) Subject: '$subject'");
} elsif (defined $info{package}) {
- $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $info{package}");
+ $smtp->datasend("Subject: [$m_style gnu-ftp-upload] $info{package}");
ftp_syslog('info', "($log_style) Subject: $info{package}");
} else {
- $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] generic failure");
+ $smtp->datasend("Subject: [$m_style gnu-ftp-upload] generic failure");
ftp_syslog('warning', "($log_style) Error uploading package: $msg");
ftp_syslog('info', "($log_style) Subject: generic failure");
}
# Wrap message at 78 characters, this is e-mail...
$Text::Wrap::columns=78;
$smtp->datasend (wrap('','',$msg) . "\n");
- $smtp->dataend ();
+ $smtp->dataend();
- $smtp->quit ();
+ $smtp->quit();
}
}
my $package_name = shift;
if (NOMAIL) {
- ftp_syslog('info', "($log_style) Subject: [$m_style gnu-ftp-debug] new upload processed: $package_name\nBody: $msg");
+ ftp_syslog('info', "($log_style) "
+ ."Subject: [$m_style gnu-ftp-debug] "
+ ."new upload processed: $package_name\nBody: $msg");
} else {
my $smtp;
if (IN_TEST_MODE) {
$smtp->mail ("ftp-upload-script\@gnu.org");
$smtp->recipient ($maintainer_email, { SkipBad => 1});
- $smtp->data ();
- $smtp->datasend ("To: $maintainer_email\n");
- $smtp->datasend ("From: ftp-upload-script\@gnu.org\n");
- $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
- $smtp->datasend ("Subject: [$m_style gnu-ftp-debug] new upload processed: $package_name");
- $smtp->datasend ("\n\n");
- $smtp->datasend ("$msg\n");
- $smtp->dataend ();
- $smtp->quit ();
+ $smtp->data();
+ $smtp->datasend("To: $maintainer_email\n");
+ $smtp->datasend("From: ftp-upload-script\@gnu.org\n");
+ $smtp->datasend("Reply-To: ftp-upload\@gnu.org\n");
+ $smtp->datasend("Subject: [$m_style gnu-ftp-debug] "
+ ."new upload processed: $package_name");
+ $smtp->datasend("\n\n");
+ $smtp->datasend("$msg\n");
+ $smtp->dataend();
+ $smtp->quit();
}
}
sub fatal {
my $tainted_msg = shift;
my $send_to_user = shift;
- # If we fail before we have sent a copy of the directive file contents to the maintainer
- # (when running in DEBUG mode), that copy is passed along, and we can send it from here.
+ # If we fail before we have sent a copy of the directive file contents to
+ # the maintainer (when running in DEBUG mode), that copy is passed along,
+ # and we can send it from here.
my $directive_file_contents = shift;
my $exit_code = shift;
# Don't look at files with really long names, either.
next if length ($ent) > 100;
- ftp_syslog('debug', "($log_style) DEBUG: " . "uploaded file to check: $ent") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."uploaded file to check: $ent") if DEBUG;
$possible{$ent} = 1;
}
- closedir (INCOMING) or ftp_die("FATAL: closedir($incoming_dir) failed: $!");
+ closedir (INCOMING)
+ or ftp_die("FATAL: closedir($incoming_dir) failed: $!");
+
# No possible files found, so return before we call lsof
return @ret unless %possible;
+
# Determine if any of those possible files are open. We find the
# possible files before running lsof (partly) to avoid a race
# condition. (If we ran lsof on the whole directory first, a new file
# absolute, since lsof outputs absolute names.
#
- # this lsof test only works if either
- # a) lsof is not compiled with HASSECURITY
- # b) the vsftpd ftp_user is set to the same user ftp_upload runs as
- # If neither of those 2 conditions are met, the lsof call will not see
- # the open files because they are owned by another user.
- # On modern (Debian) systems, condition a) is not met.
+ # this lsof test only works if either
+ # a) lsof is not compiled with HASSECURITY
+ # b) the vsftpd ftp_user is set to the same user ftp_upload runs as
+ # If neither of those 2 conditions are met, the lsof call will not see
+ # the open files because they are owned by another user.
+ # On modern (Debian) systems, condition a) is not met.
my @lsof_args = (LSOF_BIN, "-Fn",
map { "$incoming_dir/$_" } keys %possible);
- ftp_syslog('debug', "($log_style) DEBUG: " . "lsof command line: " . join(' ',@lsof_args)) if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."lsof command line: " . join(' ',@lsof_args))
+ if DEBUG;
my $pid = open (LSOF, "-|");
if ($pid) { # parent
while (defined (my $line = <LSOF>)) {
- ftp_syslog('debug', "($log_style) DEBUG: " . "lsof output: $line") if DEBUG;
- next unless $line =~ /^n${incoming_dir}\/(.+)$/; # only look at the name lines.
- ftp_syslog('debug', "($log_style) DEBUG: " . "upload in progress for $1, ignoring during this run") if DEBUG;
- delete ($possible{$1}) or ftp_warn("WARNING: lsof found unrequested but open $1?!");
+ ftp_syslog('debug', "($log_style) DEBUG: " . "lsof output: $line")
+ if DEBUG;
+ # only look at the name lines.
+ next unless $line =~ /^n${incoming_dir}\/(.+)$/;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."upload in progress for $1, ignoring during this run")
+ if DEBUG;
+ delete ($possible{$1})
+ or ftp_warn("WARNING: lsof found unrequested but open $1?!");
}
close (LSOF);
} else { # child
- exec (@lsof_args) or ftp_die("FATAL: cannot exec lsof: $!");
+ exec (@lsof_args)
+ or ftp_die("FATAL: cannot exec lsof: $!");
}
- # Do not consider files that have been modified in the last 2 minutes
- # This is an extra safety check to avoid trying to process files that are still
- # being uploaded.
+ # Do not consider files that have been modified in the last 2 minutes
+ # This is an extra safety check to avoid trying to process files that are
+ # still being uploaded.
if (TSTAMPCHECK) {
for my $ent (keys %possible) {
- my @stat = stat($ent);
- if ($stat[9] >= time - 120) {
- ftp_syslog('debug', "($log_style) DEBUG: " . "$ent has been modified in the last 2 minutes, skipping") if DEBUG;
- delete ($possible{$ent});
- next;
- }
- }
+ my @stat = stat($ent);
+ if ($stat[9] >= time - 120) {
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."$ent has been modified in the last 2 minutes, skipping")
+ if DEBUG;
+ delete ($possible{$ent});
+ next;
+ }
+ }
}
# For each remaining possibility, do some more checks
my $directive = "$base.directive.asc";
my $bare_base = $base;
$bare_base =~ s/\.directive\.asc$//g;
- ftp_syslog('debug', "($log_style) DEBUG: " . "considering $ent for processing") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."considering $ent for processing") if DEBUG;
# work on this triple, if all three files exist, and the signature
# and directive files aren't huge. We want to exclude huge files
# here, before even reading the directive file; otherwise, perl could
# consume lots of memory reading it.
- if (exists($possible{$base}) && exists($possible{$sig}) && exists($possible{$directive})
- && (-s "$incoming_dir/$directive" < 50*1024) && (-s "$incoming_dir/$sig" < 50*1024)) {
+ if (exists($possible{$base}) && exists($possible{$sig})
+ && exists($possible{$directive})
+ && (-s "$incoming_dir/$directive" < 50*1024)
+ && (-s "$incoming_dir/$sig" < 50*1024)) {
push (@ret, { "directive" => $directive, "sig" => $sig,
"upload" => $base, "directive_only" => 0 });
ftp_syslog('info', "($log_style) processing [$directive:$sig:$base]");
delete $possible{$base};
delete $possible{$sig};
delete $possible{$directive};
- } elsif (exists($possible{$base}) && !exists($possible{"$bare_base.sig"}) && ($base =~ /\.directive\.asc$/)) {
+ } elsif (exists($possible{$base}) && !exists($possible{"$bare_base.sig"})
+ && ($base =~ /\.directive\.asc$/)) {
# Here we have a potential problem. It's possible that we are seeing a
# directive file that belongs to a triplet the rest of which has not been
close(TMP);
if ($racecondition) {
- # Most likely a race condition. We've found a directive file but not the accompanying file(s).
- # Just ignore this directive file for now.
- ftp_syslog('info',"($log_style) Found directive file with filename directive ($base), but no accompanying files. Ignoring directive file in this run.");
+ # Most likely a race condition. We've found a directive file but
+ # not the accompanying file(s). Just ignore this directive file
+ # for now.
+ ftp_syslog('info',"($log_style) "
+ ."Found directive file with filename directive ($base), "
+ ."but no accompanying files. "
+ ."Ignoring directive file in this run.");
} else {
# Directive file only, no actual file to deal with
# This can happen when dealing with symlink/rmsymlink/archive options
# Do atomic rename to temp incoming directory before reading
# anything, for safety.
rename ($base, "$incoming_tmp/$base")
- or fatal("rename $incoming_dir/$base to $incoming_tmp/$base failed: $!",0);
+ or fatal("rename $incoming_dir/$base "
+ ."to $incoming_tmp/$base failed: $!",0);
}
delete $possible{$base};
} elsif ((-f $directive) && ((-s $directive) >= 50*1024)) {
rename ("$incoming_dir/$directive", "$incoming_dir/.$directive");
- ftp_syslog('info', "($log_style) directive file ($directive) larger than 50KB");
- fatal("The directive file $directive is larger than 50KB. This can not be correct, ignoring upload.",0);
+ ftp_syslog('info', "($log_style) "
+ ."directive file ($directive) larger than 50KB");
+ fatal("The directive file $directive is larger than 50KB. "
+ ."This can not be correct, ignoring upload.",0);
} elsif ((-f $sig) && ((-s $sig) >= 50*1024)) {
rename ("$incoming_dir/$sig", "$incoming_dir/.$sig");
- ftp_syslog('info', "($log_style) signature file ($sig) larger than 50KB");
- fatal("The signature file $sig is larger than 50KB. This can not be correct, ignoring upload.",0);
+ ftp_syslog('info', "($log_style) "
+ ."signature file ($sig) larger than 50KB");
+ fatal("The signature file $sig is larger than 50KB. "
+ ."This can not be correct, ignoring upload.",0);
}
}
my $tainted_val = shift;
my $directive_file_contents = shift;
$tainted_val =~ s/\r\n/\n/g; # deal with dos-based line endings...
- $tainted_val =~ s/\s+$/\n/; # Some people like to put spaces after their commands
- $tainted_val =~ s/^\s+//; # Or even *before* their commands
+ # Some people like to put spaces after their commands ...
+ $tainted_val =~ s/\s+$/\n/;
+ $tainted_val =~ s/^\s+//; # ... or even *before* their commands
- # $do_not_fail is set to 1 if this sub is called as a last resort in an attempt to find *someone* to report an error to.
- # When it is set, this sub will not die with fatal.
+ # $do_not_fail is set to 1 if this sub is called as a last resort in an
+ # attempt to find *someone* to report an error to. When it is set, this
+ # sub will not die with fatal.
my $do_not_fail = shift;
# Can't let it start with - . / or contain strange characters.
# This disallows .. as a file name component since no component
# can start with a . at all.
- $tainted_val =~ m,^(\w[-.\w]*(/\w[-.\w]*)*)$, or fatal("invalid directory $tainted_val\n$directive_file_contents",1,$directive_file_contents);
+ $tainted_val =~ m,^(\w[-.\w]*(/\w[-.\w]*)*)$,
+ or fatal("invalid directory $tainted_val\n$directive_file_contents",
+ 1,$directive_file_contents);
my $val = $1; # so far so good
# A couple of subdir levels are ok, but don't allow hundreds.
my $slash_count = ($val =~ tr,/,/,);
- fatal("$slash_count slashes is too many, in $val",1,$directive_file_contents) if ($slash_count > 3 and not $do_not_fail);
+ fatal("$slash_count slashes is too many, in $val",1,$directive_file_contents)
+ if ($slash_count > 3 and not $do_not_fail);
# Only let them specify one directory directive.
- fatal("Only one directory directive is allowed per directive file. Error at directory directive: $val",1,$directive_file_contents)
+ fatal("Only one directory directive is allowed per directive file. "
+ ."Error at directory directive: $val",1,$directive_file_contents)
if (exists $info{"directory"} and not $do_not_fail);
# Set email addresses
my @a = email_addresses($info{package});
foreach my $address (@a) {
- push (@{$info{email}}, $address) unless (grep($_ eq $address,@{$info{email}}) > 0); # Do not include duplicates
+ # Do not include duplicates
+ push (@{$info{email}}, $address)
+ unless (grep($_ eq $address,@{$info{email}}) > 0);
}
}
sub guess_uploader_email {
my $directive_file_contents = shift;
- if ($directive_file_contents =~ /^Directory:? (.*)$/im) { # case-insensitive, w or w/o the :
- parse_directory_line($1, $directive_file_contents,1);
+ if ($directive_file_contents =~ /^Directory:? (.*)$/im) {
+ # case-insensitive match above, with or without a colon
+ parse_directory_line($1, $directive_file_contents,1);
}
}
my @keyrings = @_;
my $directive_file_size = -s $directive_file;
- ftp_syslog('debug', "($log_style) DEBUG: $directive_file size is $directive_file_size") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."$directive_file size is $directive_file_size") if DEBUG;
foreach (@keyrings) {
# We need what gpgv writes to STDERR to determine the timestamp
if (!defined($retval)) {
# This is bad - we couldn't even execute the gpgv command properly
guess_uploader_email($directive_file_contents);
- fatal("gpg verify of directive file failed (error executing gpgv): $!",0,'',2);
- } elsif ($retval =~ /\n0\n$/s) { # We store the return value of gpgv on the last line of the output
+ fatal("gpg verify of directive file failed (error executing gpgv): $!",
+ 0,'',2);
+ } elsif ($retval =~ /\n0\n$/s) {
+ # We store the return value of gpgv on the last line of the output
ftp_syslog('info', "($log_style) verified against $_\n");
return $retval; # We got return value 0 from gpgv -> key verified!
} else {
- # gpgv returned an error - most likely just key not found. Ignore, since we are testing all keyrings.
+ # gpgv returned an error - most likely just key not found. Ignore,
+ # since we are testing all keyrings.
}
}
guess_uploader_email($directive_file_contents);
}
close(TMP);
- my $tmp_retval = verify_keyring($directive_file,$directive_file_contents,@tmp_keyrings);
- push(@{$info{email}},$1) if ($tmp_retval =~ /Good signature from .*?<(.*?)>/);
+ my $tmp_retval = verify_keyring($directive_file,$directive_file_contents,
+ @tmp_keyrings);
+ push(@{$info{email}},$1)
+ if ($tmp_retval =~ /Good signature from .*?<(.*?)>/);
my $signed = 0;
- # If there is a command in the directive that doesn't require an actual file to work
- # on, we won't require the filename line in the directive file. This will allow people
- # to upload a directive file only to archive/create symlinks/remove symlinks
+ # If there is a command in the directive that doesn't require an actual
+ # file to work on, we won't require the filename line in the directive
+ # file. This will allow people to upload a directive file only to
+ # archive/create symlinks/remove symlinks
my $filename_required = 1;
foreach my $line (@lines) {
}
next if ($line =~ /^Hash:/);
next if ($line =~ /^\s*$/);
- # Just make sure we don't parse any lines that are NOT part of the signed message!
- # GPG will make sure that a line that looks like "-----BEGIN PGP SIGNED MESSAGE-----"
- # will be escaped before signing a message that contains it
+ # Just make sure we don't parse any lines that are NOT part of the
+ # signed message! GPG will make sure that a line that looks like
+ # "-----BEGIN PGP SIGNED MESSAGE-----" will be escaped.
next if (!$signed);
my ($tainted_cmd,$tainted_val) = split(' ',$line,2);
- if ($tainted_cmd =~ /^Directory:?$/i) { # case-insensitive, w or w/o the :
+ if ($tainted_cmd =~ /^Directory:?$/i) {
parse_directory_line($tainted_val, $directive_file_contents,0);
- } elsif ($tainted_cmd =~ /^Filename:?$/i) { # case-insensitive, w or w/o the :
+ } elsif ($tainted_cmd =~ /^Filename:?$/i) {
# We use the same filename restrictions as scan_incoming
- $tainted_val =~ /^([\w_+][-.\w_+~]*)$/ or fatal("invalid filename $tainted_val",1,$directive_file_contents);
+ $tainted_val =~ /^([\w_+][-.\w_+~]*)$/
+ or fatal("invalid filename $tainted_val",1,$directive_file_contents);
my $val = $1; # so far so good
# Only let them specify one filename directive.
- fatal("Only one filename directive is allowed per directive file. Error at filename directive: $val.",1,$directive_file_contents)
+ fatal("Only one filename directive is allowed per directive file. "
+ ."Error at filename directive: $val.",1,$directive_file_contents)
if exists $info{"filename"};
$info{"filename"} = {"value" => $val, "order" => $cnt++}; # ok.
- } elsif ($tainted_cmd =~ /^Version:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^(\d+\.\d+)$/ or fatal("invalid version $tainted_val",1,$directive_file_contents);
+ } elsif ($tainted_cmd =~ /^Version:?$/i) {
+ $tainted_val =~ /^(\d+\.\d+)$/
+ or fatal("invalid version $tainted_val",1,$directive_file_contents);
my $val = $1; # so far so good
# We only support version 1.1/1.2 right now!
- fatal("invalid version $val, not supported",1,$directive_file_contents) if (($val ne '1.1') and ($val ne '1.2'));
+ fatal("invalid version $val, not supported",1,$directive_file_contents)
+ if (($val ne '1.1') and ($val ne '1.2'));
# Only let them specify one version directive.
- fatal("invalid second version $val, have $info{version}",1,$directive_file_contents) if exists $info{"version"};
+ fatal("invalid second version $val, have $info{version}",
+ 1,$directive_file_contents)
+ if exists $info{"version"};
$info{"version"} = $val; #ok.
- } elsif ($tainted_cmd =~ /^symlink:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^([\w_+][-.\w_+\/]*)\s+([\w_+][-.\w_+\/]*)$/ or fatal("invalid parameters for symlink command: $tainted_val",1,$directive_file_contents);
+ } elsif ($tainted_cmd =~ /^symlink:?$/i) {
+ $tainted_val =~ /^([\w_+][-.\w_+\/]*)\s+([\w_+][-.\w_+\/]*)$/
+ or fatal("invalid parameters for symlink command: $tainted_val",
+ 1,$directive_file_contents);
my ($target,$link) = ($1,$2); # so far so good
- fatal("invalid parameters for symlink command(2): $tainted_val",1,$directive_file_contents) if ($target =~ /\.\./ || $link =~ /\.\./);
+ fatal("invalid parameters for symlink command(2): $tainted_val",
+ 1,$directive_file_contents)
+ if ($target =~ /\.\./ || $link =~ /\.\./);
$info{"symlink-$target"} = {"link" => $link, "order" => $cnt++}; #ok.
- } elsif ($tainted_cmd =~ /^rmsymlink:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^([\w_+][-.\w_+\/]*)$/ or fatal("invalid parameters for rmsymlink command: $tainted_val",1,$directive_file_contents);
+ } elsif ($tainted_cmd =~ /^rmsymlink:?$/i) {
+ $tainted_val =~ /^([\w_+][-.\w_+\/]*)$/
+ or fatal("invalid parameters for rmsymlink command: $tainted_val",
+ 1,$directive_file_contents);
my $val = $1; # so far so good
- fatal("invalid parameters for rmsymlink command(2): $tainted_val",1,$directive_file_contents) if ($val =~ /\.\./);
+ fatal("invalid parameters for rmsymlink command(2): $tainted_val",
+ 1,$directive_file_contents)
+ if ($val =~ /\.\./);
$info{"rmsymlink-$1"} = {"order" => $cnt++}; #ok.
- } elsif ($tainted_cmd =~ /^archive:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^([\w_+][-.\w_+\/]*)$/ or fatal("invalid parameters for archive command: $tainted_val",1,$directive_file_contents);
+ } elsif ($tainted_cmd =~ /^archive:?$/i) {
+ $tainted_val =~ /^([\w_+][-.\w_+\/]*)$/
+ or fatal("invalid parameters for archive command: $tainted_val",
+ 1,$directive_file_contents);
my $val = $1; # so far so good
- fatal("invalid parameters for archive command(2): $tainted_val",1,$directive_file_contents) if ($val =~ /\.\./);
-
+ fatal("invalid parameters for archive command(2): $tainted_val",
+ 1,$directive_file_contents)
+ if ($val =~ /\.\./);
$info{"archive-$1"} = {"order" => $cnt++}; #ok.
- } elsif ($tainted_cmd =~ /^replace:?$/i) { # case-insensitive, w or w/o the :
+ } elsif ($tainted_cmd =~ /^replace:?$/i) {
# This command is only supported from v1.2
- $tainted_val =~ /^(true|false)$/ or fatal("invalid parameters for replace command: $tainted_val",1,$directive_file_contents);
+ $tainted_val =~ /^(true|false)$/
+ or fatal("invalid parameters for replace command: $tainted_val",
+ 1,$directive_file_contents);
$info{"replace"} = $1; #ok.
- } elsif ($tainted_cmd =~ /^comment:?$/i) { # case-insensitive, w or w/o the :
+ } elsif ($tainted_cmd =~ /^comment:?$/i) {
# Comments are ok, we ignore them
} elsif (IN_TEST_MODE && $tainted_cmd =~ /^no-op:?$/i) {
# The testsuite uses a no-op command to validate directive processing.
$info{'no-op'} = {order => $cnt++};
} else {
- fatal("Invalid directive line:\n\n $tainted_cmd $tainted_val",1,$directive_file_contents);
+ fatal("Invalid directive line:\n\n $tainted_cmd $tainted_val",
+ 1,$directive_file_contents);
}
}
$info{'v1_compat_mode'} = 0;
- if (exists($info{"replace"}) and (($info{'v1_compat_mode'} == 1) or ($info{"version"} eq '1.1'))) {
- fatal("invalid directive 'replace', not supported prior to version 1.2",1,$directive_file_contents);
+ if (exists($info{"replace"})
+ && (($info{'v1_compat_mode'} == 1) || ($info{"version"} eq '1.1'))) {
+ fatal("invalid directive 'replace', not supported prior to version 1.2",
+ 1,$directive_file_contents);
}
# Phone home. E-mail the contents of the directive file to the maintainer,
# 1. It exists in the directive file - there is no problem
# 2. It doesn't exist in the directive file
# In that case, we need to double check a few things.
- # This is permitted IF $V1_COMPAT_ALLOWED is true, AND if the only directive is a 'directory'.
+ # This is permitted IF $V1_COMPAT_ALLOWED is true, AND if the only
+ # directive is a 'directory'.
# (for backwards compatibility with older versions of the script)
- # It is also permitted if the directive file contains commands that don't require
- # a filename - currently symlink, rmsymlink, and archive - and only the directive file was
- # uploaded
+ # It is also permitted if the directive file contains commands that
+ # don't require a filename - currently symlink, rmsymlink, and
+ # archive - and only the directive file was uploaded
if (!exists($info{filename})) {
my $directory_command_only = 1;
foreach (keys %info) {
- $directory_command_only = 0 if (($_ ne 'directory') && ($_ ne 'package') && ($_ ne 'version') && ($_ ne 'v1_compat_mode') && ($_ ne 'email'));
+ $directory_command_only = 0
+ if (($_ ne 'directory') && ($_ ne 'package') && ($_ ne 'email')
+ && ($_ ne 'version') && ($_ ne 'v1_compat_mode'));
}
# This is where we would check for commands that require a file.
# In this version (1.1), there are none, so all we do is check
# We have three files
# Are we in version 1.0 compatibility mode?
if ($V1_COMPAT_ALLOWED) {
- # We're in backwards compatibility mode
- # That means: three files, and ONLY a directory directive in the directive file
+ # We're in backwards compatibility mode which means: three files,
+ # and ONLY a directory directive in the directive file
$info{'v1_compat_mode'} = 1;
if ($directory_command_only == 0) {
fatal("no filename directive specified in $directive_file",1)
} else {
- ftp_syslog('info',"($log_style) running in legacy v1 compatibility mode");
+ ftp_syslog('info',"($log_style) "
+ ."running in legacy v1 compatibility mode");
}
} elsif (!$V1_COMPAT_ALLOWED) {
# This is not allowed - we require a filename directive. No backwards compatibility.
- fatal("no filename directive specified in $directive_file. Upgrade to the latest version! See http://www.gnu.org/prep/maintain/maintain.html",1)
+ fatal("no filename directive specified in $directive_file. "
+ ."Upgrade to the latest version! "
+ ."See http://www.gnu.org/prep/maintain/maintain.html",1)
}
} else {
# We only have a directive file
# Do we have something to do?
- fatal("nothing to do - no commands in directive file",1) if ($directory_command_only == 1);
+ fatal("nothing to do - no commands in directive file",1)
+ if ($directory_command_only == 1);
}
$filename_required = 0;
}
- ftp_syslog('info',"($log_style) not running in legacy v1 mode") if (!$info{'v1_compat_mode'});
+ ftp_syslog('info',"($log_style) not running in legacy v1 mode")
+ if (!$info{'v1_compat_mode'});
# Configuration must exist for the package
-d $package_config_base . '/' . $info{"package"}
# that needs to match the name of the uploaded file.
# Filename has to match the name of the uploaded file
- fatal("The filename directive does not match name of the uploaded file.\n\n Filename directive: $info{filename}{value}\n Uploaded file: $uploaded_file\n",1)
+ fatal("The filename directive does not match name of the uploaded file."
+ ."\n\n Filename directive: $info{filename}{value}"
+ ."\n Uploaded file: $uploaded_file\n",1)
if ($uploaded_file ne $info{filename}{value});
- # Filename has to match the name of this directive file (a bit paranoid, but hey...)
- fatal("filename $info{filename}{value} does not match name of directive file $directive_file",1)
+ # Filename has to match the name of this directive file (a bit
+ # paranoid, but hey...)
+ fatal("filename $info{filename}{value} does not match name of directive "
+ ."file $directive_file",1)
if ($directive_file ne "$info{filename}{value}.directive.asc");
}
if ! $info{"version"};
}
- my $retval = verify_keyring($directive_file,$directive_file_contents,@keyrings);
+ my $retval = verify_keyring($directive_file,$directive_file_contents,
+ @keyrings);
# Now check that the timestamp of signing for the directive is not older
# than the one for the last file that was uploaded
# on this line, while others do not. The testing mock does.
$timestr =~ s/ using .*//; # trim to only timestamp
- # If the time/date string starts with a weekday (e.g. "Wed Apr 28 16:40:03 2004 EDT"),
- # chop off the weekday - Date::Manip doesn't like it
+ # If the time/date string starts with a weekday
+ # (e.g. "Wed Apr 28 16:40:03 2004 EDT"), chop off the weekday -
+ # Date::Manip doesn't like it
$timestr =~ s/^[a-z]+? ([a-z]+)/$1/i;
# We need to convert time/date strings like "Apr 28 16:40:03 2004 EDT" into
# "Apr 28 16:40:03 2004 EDT" for Date::Manip to understand them...
- $timestr =~ s/^([a-z]+? +\d{1,2}) (\d{2}:\d{2}:\d{2}) (\d{4}) (.*)$/$1 $3 $2 $4/i;
+ $timestr =~
+ s/^([a-z]+? +\d{1,2}) (\d{2}:\d{2}:\d{2}) (\d{4}) (.*)$/$1 $3 $2 $4/i;
my $date = ParseDate($timestr);
my $epoch = UnixDate($date,"%s");
- # Verify that this timestamp is not too far in the future. We allow a discrepancy of 1 day so we don't have to worry about timezones
+ # Verify that this timestamp is not too far in the future. We allow a
+ # discrepancy of 1 day so we don't have to worry about timezones
my $now = time();
if ($epoch > ($now + 24*3600)) {
- fatal("GPG signed upload from the future - not allowed. Please make sure your clock is set correctly, resign the directive file, and upload again. You may have to wait 24 hours before re-uploading if you do not change the filename for your triplet.",1);
+ fatal("GPG signed upload from the future - not allowed. "
+ ."Please make sure your clock is set correctly, "
+ ."resign the directive file, and upload again. "
+ ."You may have to wait 24 hours before re-uploading if you do not "
+ ."change the filename for your triplet.",1);
}
# Now we need to flock the our 'serials' file;
$full_filename =~ s/\/\//\//g; # Just in case...
# Verify that this is really a new version of the file!
- if (exists($serials{$full_filename}) && ($serials{$full_filename} >= $epoch)) {
+ if (exists($serials{$full_filename})
+ && ($serials{$full_filename} >= $epoch)) {
flock(SERIALS,4); # Release lock
- fatal("Gpg signed upload older than/same timestamp as existing version - not allowed. In other words, the filenames for the triplet you have uploaded are an exact match for a triplet that has been uploaded in the past, and the directive file that you just uploaded has been signed before or at the same time as the directive file for the triplet that was uploaded earlier. Most likely, you are re-uploading an old triplet.",1);
+ fatal("Gpg signed upload older than/same timestamp as existing version "
+ ."- not allowed. In other words, the filenames for the triplet "
+ ."you have uploaded are an exact match for a triplet that has "
+ ."been uploaded in the past, and the directive file that you "
+ ."just uploaded has been signed before or at the same time as "
+ ."the directive file for the triplet that was uploaded earlier. "
+ ."Most likely, you are re-uploading an old triplet.",1);
}
$serials{$full_filename} = $epoch;
# http://thread.gmane.org/gmane.comp.sysutils.autotools.announce/131
if ($upload_file =~ /\.(tar|)(\.|$)|\.t[bglx]z|\.tbz2$/) {
# First check if the file contains any Makefile.in files
- push(@debug_log,"($log_style) DEBUG: testing $upload_file for presence of Makefile.in") if $debug;
+ push(@debug_log,"($log_style) DEBUG: "
+ ."testing $upload_file for presence of Makefile.in")
+ if $debug;
my $tar_cmd = "/bin/tar -tf $upload_file";
open (TAR, "$tar_cmd|")
or return("Error: failed to run command: $tar_cmd\n\n", \@debug_log);
last;
}
}
- close(TAR); # We don't care about errors here; the pipe can cause non-zero exit codes when tar is unhappy that it's asked to stop
- return ($error_string, \@debug_log) if (!$found_makefile);
+ close(TAR); # We don't care about errors here; the pipe can cause
+ # non-zero exit codes when tar is unhappy that it's asked
+ # to stop
+ return ($error_string, \@debug_log)
+ if (!$found_makefile);
# If it does, check inside them
- push(@debug_log,"($log_style) DEBUG: found Makefile.in, testing for CVE-2009-4029 and CVE-2012-3386") if $debug;
- $tar_cmd = "/bin/tar --to-stdout -x -f $upload_file 'Makefile.in' --wildcards '*/Makefile.in' 2>/dev/null";
+ push(@debug_log,"($log_style) DEBUG: found Makefile.in, "
+ ."testing for CVE-2009-4029 and CVE-2012-3386")
+ if $debug;
+ $tar_cmd = "/bin/tar --to-stdout -x -f $upload_file 'Makefile.in' "
+ ."--wildcards '*/Makefile.in' 2>/dev/null";
open (TAR, "$tar_cmd|")
or return("Error: failed to run command: $tar_cmd\n\n", \@debug_log);
my $found_cve_2009_4029 = 0;
$found_cve_2012_3386 = 1;
}
}
- close(TAR); # We don't care about errors here; the pipe can cause non-zero exit codes when tar is unhappy that it's asked to stop
-
- # Because CVE-2012-3386 was not fixed until 1.11.6 / 1.12.2, we point people to that version instead
- # of 1.11.1, which fixes CVE-2009-4029. Ward, 2012-07-20
- $found_cve_2009_4029 and $error_string .= "file rejected: $upload_file contains a vulnerable "
- . "Makefile.in (CVE-2009-4029);\n"
- . "Regenerate it with automake 1.11.6 / 1.12.2 or newer.\n\n";
-
- $found_cve_2012_3386 and $error_string .= "file rejected: $upload_file contains a vulnerable "
- . "Makefile.in (CVE-2012-3386);\n"
- . "Regenerate it with automake 1.11.6 / 1.12.2 or newer.\n\n";
+ close(TAR); # We don't care about errors here; the pipe can cause
+ # non-zero exit codes when tar is unhappy that it's asked
+ # to stop
+
+ # Because CVE-2012-3386 was not fixed until 1.11.6 / 1.12.2, we point
+ # people to that version instead of 1.11.1, which fixes
+ # CVE-2009-4029. Ward, 2012-07-20
+ $found_cve_2009_4029
+ and $error_string .= "file rejected: $upload_file contains a vulnerable "
+ . "Makefile.in (CVE-2009-4029);\n"
+ . "Regenerate it with automake 1.11.6 / 1.12.2 or newer.\n\n";
+
+ $found_cve_2012_3386
+ and $error_string .= "file rejected: $upload_file contains a vulnerable "
+ . "Makefile.in (CVE-2012-3386);\n"
+ . "Regenerate it with automake 1.11.6 / 1.12.2 or newer.\n\n";
}
return ($error_string, \@debug_log);
my $log_style = shift;
my $debug = shift;
- my ($error_string, $error_log_ref) = automake_tests($upload_file,$log_style,$debug);
+ my ($error_string, $error_log_ref) =
+ automake_tests($upload_file,$log_style,$debug);
return ($error_string, $error_log_ref);
}
my $sig_file_size = -s $sig_file;
my $upload_file_size = -s $upload_file;
- ftp_syslog('debug', "($log_style) DEBUG: $sig_file size is $sig_file_size") if DEBUG;
- ftp_syslog('debug', "($log_style) DEBUG: $upload_file size is $upload_file_size") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."$sig_file size is $sig_file_size") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."$upload_file size is $upload_file_size") if DEBUG;
my @keyrings = keyring_file ($info{package},$info{directory});
fatal("no keyring for package $info{package}",0) if ($#keyrings < 0);
$valid
or fatal("gpg verify of upload file ($upload_file) failed",1);
- my ($error_string, $error_log_ref) = check_vulnerabilities($upload_file,$log_style,DEBUG);
+ my ($error_string, $error_log_ref) =
+ check_vulnerabilities($upload_file,$log_style,DEBUG);
my @error_log = @$error_log_ref;
if (DEBUG and $#error_log > -1) {
fatal($error_string,1,'',3) if ($error_string ne '');
- ftp_syslog('debug', "($log_style) DEBUG: tested negative for CVE-2009-4029 and CVE-2012-3386") if DEBUG;
+ ftp_syslog('debug', "($log_style) DEBUG: "
+ ."tested negative for CVE-2009-4029 and CVE-2012-3386") if DEBUG;
}
my $file = shift;
# Abort if file to archive doesn't exist
- fatal("$subdir/$file does not exist - can not archive",1) if (!-e "$destfinal/$subdir/$file");
+ fatal("$subdir/$file does not exist - can not archive",1)
+ if (!-e "$destfinal/$subdir/$file");
my $timestamp = strftime "%Y-%m-%d_%H-%M-%S", localtime;
- $timestamp .= sprintf("_%09d",rand(1000000000)); # Add a large random number for good measure
+ # Add a large random number for good measure
+ $timestamp .= sprintf("_%09d",rand(1000000000));
# Abort if a file with same name exists in the archive
- fatal("$subdir/$file exists in archive - can not overwrite",1) if (-e "$olddestfinal/$subdir/$timestamp" . "_$file");
+ fatal("$subdir/$file exists in archive - can not overwrite",1)
+ if (-e "$olddestfinal/$subdir/$timestamp" . "_$file");
my @mkdir_args = ("/bin/mkdir","-p","$olddestfinal/$subdir");
fatal("@mkdir_args failed",0) if system (@mkdir_args) != 0;
- my @mv_args = ("/bin/mv", "$dir/$file", "$olddestfinal/$subdir/$timestamp" . "_$file");
+ my @mv_args = ("/bin/mv", "$dir/$file",
+ "$olddestfinal/$subdir/$timestamp"."_$file");
fatal("@mv_args failed",0) if system (@mv_args) != 0;
- ftp_syslog('info', "($log_style) archived $dir/$file to $olddestfinal/$subdir/$timestamp" . "_$file");
+ ftp_syslog('info', "($log_style) "
+ ."archived $dir/$file to $olddestfinal/$subdir/$timestamp"
+ ."_$file");
}
# We now allow overwriting of files - without warning!!
if (-e "$destdir/$sig_file") {
if (not exists($info{'replace'}) or ($info{'replace'} ne 'true')) {
- fatal("This signature file exists: $destdir/$sig_file, if you want to replace the pair please use the 'replace' directive",1);
+ fatal("This signature file exists: $destdir/$sig_file, if you want to "
+ ."replace the pair please use the 'replace' directive",1);
} else {
archive($destdir, $info{directory}, $sig_file);
- ftp_syslog('info', "($log_style) archived and overwrote $destdir/$sig_file with uploaded version");
+ ftp_syslog('info', "($log_style) archived and overwrote "
+ ."$destdir/$sig_file with uploaded version");
$t1 = 1;
}
}
if (-e "$destdir/$upload_file") {
if (not exists($info{'replace'}) or ($info{'replace'} ne 'true')) {
- fatal("This file exists: $destdir/$upload_file, if you want to replace the pair please use the 'replace' directive",1);
+ fatal("This file exists: $destdir/$upload_file, if you want to "
+ ."replace the pair please use the 'replace' directive",1);
} else {
archive($destdir, $info{directory}, $upload_file);
- ftp_syslog('info', "($log_style) overwrote $destdir/$upload_file with uploaded version");
+ ftp_syslog('info', "($log_style) overwrote "
+ ."$destdir/$upload_file with uploaded version");
$t2 = 1;
}
}
my $notification_str = '';
- $notification_str .= "Archived and overwrote $destdir/$sig_file with uploaded version\n" if ($t1);
- $notification_str .= "Archived and overwrote $destdir/$upload_file with uploaded version\n" if ($t2);
+ $notification_str .=
+ "Archived and overwrote $destdir/$sig_file with uploaded version\n"
+ if ($t1);
+ $notification_str .=
+ "Archived and overwrote $destdir/$upload_file with uploaded version\n"
+ if ($t2);
mail ($notification_str) if ($notification_str ne '');
# Do we need a subdirectory on $desttmp as well? Can't quite picture
chdir($destdir);
# if the symlink already exists, remove it
if (-l $info{$key}{link}) {
- unlink($info{$key}{link}) or fatal("removal of symlink $info{$key}{link} failed: $!",1);
+ unlink($info{$key}{link})
+ or fatal("removal of symlink $info{$key}{link} failed: $!",1);
}
# symlink away!
- symlink("$target",$info{$key}{link}) or fatal("creation of symlink $info{$key}{link} to $target in $destdir failed: $!",1);
+ symlink("$target",$info{$key}{link})
+ or fatal("creation of symlink $info{$key}{link} "
+ ."to $target in $destdir failed: $!",1);
# go back to current working dir
- ftp_syslog('info', "($log_style) added symlink $destdir/" . $info{$key}{link} . " pointing to $destdir/$target");
- chdir($cwd) or fatal("chdir to $cwd failed: $!",1);
+ ftp_syslog('info', "($log_style) added symlink $destdir/"
+ .$info{$key}{link} . " pointing to $destdir/$target");
+ chdir($cwd)
+ or fatal("chdir to $cwd failed: $!",1);
} elsif ($key =~ /^rmsymlink-(.*)/) {
- fatal("refusing to remove a non-symlink file",1) unless -l "$destdir/$1";
- unlink("$destdir/$1") or fatal("removal of symlink $1 failed: $!",1);
+ fatal("refusing to remove a non-symlink file",1)
+ unless -l "$destdir/$1";
+ unlink("$destdir/$1")
+ or fatal("removal of symlink $1 failed: $!",1);
ftp_syslog('info', "($log_style) removed symlink $destdir/$1");
} elsif ($key =~ /^archive-(.*)/) {
# We now also allow archiving entire directories
- archive($destdir, $originfo{directory}, "$1.sig") if (! -d "$destdir/$1");
+ archive($destdir, $originfo{directory}, "$1.sig")
+ if (! -d "$destdir/$1");
archive($destdir, $originfo{directory}, $1);
}
}
mail ("upload of $upload_file and $sig_file complete",1);
- unlink ($directive_file) or ftp_warn("unlink($directive_file) failed: $!");
+ unlink ($directive_file)
+ or ftp_warn("unlink($directive_file) failed: $!");
}
sub success_directive {
my $directive_file = shift;
mail ("processing of $directive_file complete",1);
- unlink ($directive_file) or ftp_warn("unlink($directive_file) failed: $!");
+ unlink ($directive_file)
+ or ftp_warn("unlink($directive_file) failed: $!");
}
sub cleanup_dir {
my $dir = shift;
- opendir(DIR, $dir) or ftp_die("Can’t opendir $dir in cleanup_dir: $!");
+ opendir(DIR, $dir)
+ or ftp_die("Can’t opendir $dir in cleanup_dir: $!");
my @files = grep { ! /^\./ && -f "$dir/$_" } readdir(DIR);
closedir DIR;
$file =~ /^(.*)$/; $file = $1;
my $mtime = $tmp[9];
$mtime =~ /^(.*)$/; $mtime = $1;
- ftp_syslog('debug',"($log_style) DEBUG: Removing $file, older than 24 hours (mtime: $tmp[9])\n") if ((time() > ($tmp[9]+24*3600)) && (DEBUG > 0));
- unlink ("$dir/.$file"); # don't worry if it doesn't exist
- rename ("$dir/$file", "$dir/.$file") if (time() > ($mtime+24*3600));
+ ftp_syslog('debug',"($log_style) DEBUG: "
+ ."Removing $file, older than 24 hours (mtime: $tmp[9])\n")
+ if ((time() > ($tmp[9]+24*3600)) && (DEBUG > 0));
+ unlink ("$dir/.$file"); # don't worry if it doesn't exist
+ rename ("$dir/$file", "$dir/.$file")
+ if (time() > ($mtime+24*3600));
}
}
sub cleanup {
- for my $dir ($incoming_dir, $incoming_tmp, $desttmp) {
- for my $f (@_) {
- ftp_syslog('debug',"($log_style) DEBUG: cleaning up $dir/$f\n") if (DEBUG > 1);
+ for my $dir ($incoming_dir, $incoming_tmp, $desttmp) {
+ for my $f (@_) {
+ ftp_syslog('debug',"($log_style) DEBUG: cleaning up $dir/$f\n")
+ if (DEBUG > 1);
# if we quit early enough, they might not be there.
next unless defined $f && -e "$dir/$f";
unlink ("$dir/.$f"); # don't worry if it doesn't exist
rename ("$dir/$f", "$dir/.$f"); # save one backup
- }
}
+ }
}
# the chdir simplifies our filename parsing, so the base names don't
# have any directory.
-chdir ($incoming_dir) or ftp_die("FATAL: chdir($incoming_dir) failed: $!");
+chdir ($incoming_dir)
+ or ftp_die("FATAL: chdir($incoming_dir) failed: $!");
my @incoming = scan_incoming ();
# we've moved the files to work on to a new directory.
-chdir ($incoming_tmp) or ftp_die("FATAL: chdir($incoming_tmp) failed: $!");
+chdir ($incoming_tmp)
+ or ftp_die("FATAL: chdir($incoming_tmp) failed: $!");
for my $files (@incoming) { # each list element is a hash reference.
ftp_syslog('info',"($log_style) found directive: $files->{directive}\n");
# onto the next triplet.
eval {
# set up the %info variable
- my $retval = read_directive_file ($files->{"directive"},$files->{"upload"},$files->{"directive_only"});
+ my $retval = read_directive_file ($files->{"directive"},
+ $files->{"upload"},
+ $files->{"directive_only"});
if ($retval == 0) {
# do the work
# report success
if (!$files->{"directive_only"}) {
- success_upload($files->{"sig"}, $files->{"upload"},$files->{"directive"});
+ success_upload($files->{"sig"}, $files->{"upload"},
+ $files->{"directive"});
} else {
success_directive($files->{directive});
}
}
};
- ftp_warn ("eval failed: $@") if $@;
+ ftp_warn ("eval failed: $@")
+ if $@;
# clean up files if we abort while processing a triplet
- cleanup ($files->{"sig"}, $files->{"upload"}, $files->{"directive"}) if ($@);
+ cleanup ($files->{"sig"}, $files->{"upload"}, $files->{"directive"})
+ if ($@);
# clear out the current package that we just finished processing
undef %info;
}
if ((scalar @incoming) == 0) {
ftp_syslog('info', "($log_style) No files found for processing.");
} else {
- ftp_syslog('info', "($log_style) Processing complete: " . (scalar @incoming) . " uploads processed.");
- system("/usr/local/bin/generate-ftpindex") unless IN_TEST_MODE;
+ ftp_syslog('info', "($log_style) Processing complete: "
+ .(scalar @incoming)." uploads processed.");
+ system("/usr/local/bin/generate-ftpindex")
+ unless IN_TEST_MODE;
ftp_syslog('info', "($log_style) Updated ftpindex");
}
projects / gatekeeper.git / commitdiff