aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org>2019-07-29 12:12:37 +0300
committerSergey Poznyakoff <gray@gnu.org>2019-07-29 12:12:37 +0300
commite936b4df97a31401dec55919781235bef1f849fc (patch)
tree1e0111298076ceea6fb7d038c9795a58efb67728
parent7e51746fec8788e3dd8db0027c87d03f7e9e9433 (diff)
downloadtpnotify-e936b4df97a31401dec55919781235bef1f849fc.tar.gz
tpnotify-e936b4df97a31401dec55919781235bef1f849fc.tar.bz2
Use Safe for template expansion
-rwxr-xr-xtpnotify176
1 files changed, 118 insertions, 58 deletions
diff --git a/tpnotify b/tpnotify
index 9d042be..698c182 100755
--- a/tpnotify
+++ b/tpnotify
@@ -31,22 +31,20 @@ use Sys::Hostname;
#use Data::Dumper;
use POSIX qw(strftime);
use Locale::PO;
+use Safe;
my $progname = basename($0);
my $progdescr = "Notifies translationproject.org about new POT file";
our $VERSION = "1.0";
my $keep; # Keep temporary directory on errors
-my $signature = "$ENV{HOME}/.signature"; # Signature file
+my $signature_file = "$ENV{HOME}/.signature"; # Signature file
my $verbose; # Verbose mode
my $dry_run; # Dry-run mode
my %mailer_args; # Mailer arguments
-my $sender; # Sender email
-my $fullname; # Sender real name
-my $localdomain; # Local domain name
-my $recipient; # Override recipient address
my @add_headers; # Additional headers
my $refile_method; # Refiling method
+my $force_option;
my $template = <<'EOT';
To: <coordinator@translationproject.org>
@@ -56,7 +54,7 @@ Hello,
The new $release_type version of $package_name is available at:
- $url
+ $archive_url
$signature
EOT
@@ -66,18 +64,24 @@ my $tp_url = q{http://translationproject.org/domain/${domain}.html};
my $pot_regex_str =
q{The current template for this domain is <a href="(.*?)">};
-
-my $url; # Tarball URL
my $wd; # Temporary working directory
-my $archive_file; # Archive file name
-my $topdir; # Toplevel directory from the archive
my %files; # Extracted files. Key - name under $topdir, value - pathname
# within $wd
-my $package_name; # Package name;
-my $package_tarname; # Package archive name
-my $package_version; # Package version number
-my $package_base; # Package base name
-my $release_type; # Package type (alpha or stable)
+
+# Package variables: these are shared with the Safe compartment in
+# expand_template.
+our $sender; # Sender email
+our $fullname; # Sender real name
+our $localdomain; # Local domain name
+our $recipient; # Override recipient address
+our $archive_url; # Tarball URL
+our $archive_file; # Archive file name
+our $topdir; # Toplevel directory from the archive
+our $package_name; # Package name;
+our $package_tarname; # Package archive name
+our $package_version; # Package version number
+our $package_base; # Package base name
+our $release_type; # Package type (alpha or stable)
sub err {
my $msg = shift;
@@ -103,7 +107,13 @@ sub info {
print "\n";
}
-# download($source, dest => 'filename' or ref)
+# download($source_url, dest => 'filename' or ref)
+# ------------------------------------------------
+# Downloads material from $source. If 'dest' is a reference to a scalar,
+# the downloaded material is stored to that ref. If it is a filename,
+# the material is stored in the named disk file. If 'dest' is not given,
+# the name of the disk file is determined as the basename of the path
+# component from the $source_url.
sub download {
my ($source,%opt) = @_;
my $url = new URI($source);
@@ -140,6 +150,9 @@ sub download {
return $dest;
}
+# get_sources($URL)
+# -----------------
+# Download and extract source archive.
sub get_sources {
my ($source) = @_;
$archive_file = download($source);
@@ -177,12 +190,14 @@ sub get_sources {
my $filelist = join(' ', values(%files));
info("extracting from $archive_file") if $verbose;
- system("tar xf $archive_file $filelist");
- check_command_status("tar xf $archive_file $filelist");
- #print "tar xvf $archive_file " . ;
- #print "\n";
+ my $cmd = "tar xf $archive_file $filelist";
+ system($cmd);
+ check_command_status($cmd);
}
+# check_command_status($STAT)
+# ---------------------------
+# Handles the result of the system or wait function call.
sub check_command_status {
my $cmd = shift;
my $status = shift || $?;
@@ -196,6 +211,12 @@ sub check_command_status {
}
}
+# verify
+# ------
+# Verifies the tarball. Determines canonical package name, extracts the POT
+# file and checks if it lists the correct package name in its
+# "Project-Id-Version" header and that its msgids differ from the ones
+# already registered on the TP.
sub verify {
my ($in, $out);
my $pid = open2($out, $in, "m4 -P - $files{'configure.ac'}")
@@ -243,6 +264,10 @@ EOT
verify_potfile($files{$potfile});
}
+# po_header($FILENAME)
+# --------------------
+# Extract the PO header from the POT file $FILENAME.
+# Returns a reference to a hash: header-name => value.
sub po_header {
my $name = shift;
print "READING $name\n";
@@ -257,22 +282,38 @@ sub po_header {
\%ret;
}
+# po_serialize($FILENAME)
+# -----------------------
+# Serializes the pot file in the unambiguous way.
+# Extracts the msgids, sorts them lexicographically and concatenates them.
sub po_serialize {
my $name = shift;
join("\n", sort map { ($_->msgid // '') . ':' . ($_->msgid_plural // '') } @{Locale::PO->load_file_asarray($name)});
}
+# po_cmp($A, $B)
+# --------------
+# Compares two POT files. Returns 'true' if the two files contain exactly
+# the same set of msgids.
sub po_cmp {
my ($a,$b) = @_;
po_serialize($a) eq po_serialize($b);
}
+# verify_potfile($FILENAME)
+# -------------------------
+# Verifies the potfile extracted from the archive.
+# Checks if the POT file mentions the correct package string in its
+# Project-Id-Version header. Downloads the POT file registered on the
+# TP and makes sure its msgids are not the same as defined in the POT
+# file from the archive.
sub verify_potfile {
my $potname = shift;
my $hdr = po_header($potname);
my $vs = $hdr->{'project-id-version'};
if ($vs ne "$package_name $package_version") {
- abend(EX_DATAERR, "$potname: Project-Id-Version does not match \"$package_name $package_version\"");
+ err("$potname: Project-Id-Version does not match \"$package_name $package_version\"");
+ exit(EX_DATAERR) unless $force_option;
}
(my $url = $tp_url) =~ s/\$\{domain\}/$package_tarname/;
@@ -281,39 +322,52 @@ sub verify_potfile {
my $tp_potname = download($1);
if (po_cmp($potname, $tp_potname)) {
err("potfile contains no new msgids; no need to upload");
- exit(0);
+ exit(0) unless $force_option;
}
}
}
-sub get_special_var {
- my ($var) = @_;
- if ($var eq 'signature') {
- if (defined($signature)) {
- if (open(my $fd, '<', $signature)) {
- local $/;
- my $sig = <$fd>;
- close($fd);
- return $sig;
- } else {
- err("can't open signature file $signature: $!",
- prefix => 'warning');
- }
+# Reads the signature file from $signature_file.
+sub read_signature {
+ if (defined($signature_file)) {
+ if (open(my $fd, '<', $signature_file)) {
+ local $/;
+ my $sig = <$fd>;
+ close($fd);
+ return $sig;
}
- } elsif ($var eq 'username') {
- return $fullname;
}
return undef;
}
+# Expands the message template.
+# Returns the expanded text. Abends on failure.
sub expand_template {
- join("\n", map {
- s/\$(signature|username)/get_special_var($1)/gex;
- s/(\$[a-zA-Z_][a-zA-Z0-9_]+)/eval "$1"/gex;
- $_
- } split(/\n/, $template)) . "\n";
+ my $cpt = new Safe;
+
+ $cpt->share(qw($sender
+ $fullname
+ $localdomain
+ $recipient
+ $archive_file
+ $archive_url
+ $package_name
+ $package_version
+ $package_base
+ $release_type
+ $topdir
+ $signature));
+ chomp(${$cpt->varglob('signature')} = read_signature);
+
+ (my $tmpl = $template) =~ s/\@/\\\@/g;
+ if ($cpt->reval("\$_ = qq{$tmpl}",1)) {
+ return $_;
+ } else {
+ abend(EX_DATAERR, "while expanding template: $@");
+ }
}
+# Reads the current value of the MH Path setting.
sub read_mh_path {
my $file = File::Spec->catfile($ENV{HOME}, '.mh_profile');
if (-f $file) {
@@ -526,7 +580,7 @@ my %kw = (
keep => \$keep,
'template-file' => \&read_template_file,
template => \$template,
- 'signature-file' => \$signature,
+ 'signature-file' => \$signature_file,
mailer => \&set_mailer,
from => \$sender,
sender => \$sender,
@@ -620,7 +674,7 @@ GetOptions("help" => sub {
pod2usage(-exitstatus => EX_OK, -verbose => 0);
},
"config|c=s" => \$config_file,
- "no-config|N" => sub { $config_file = undef }
+ "no-config|N" => sub { $config_file = undef },
);
read_config($config_file) if defined $config_file;
@@ -633,8 +687,8 @@ GetOptions("keep|k" => \$keep,
"template|t=s" => sub {
exit(EX_NOINPUT) unless read_template_file($_[1])
},
- "signature|s=s" => \$signature,
- "no-signature" => sub { $signature = undef },
+ "signature|s=s" => \$signature_file,
+ "no-signature" => sub { $signature_file = undef },
"verbose|v+" => \$verbose,
"dry-run|n" => \$dry_run,
"debug|d+" => \$debug,
@@ -646,7 +700,8 @@ GetOptions("keep|k" => \$keep,
"domain|D=s" => \$localdomain,
"to=s" => \$recipient,
"add|a=s@" => \@add_headers,
- "refile-method=s" => \$refile_method
+ "refile-method=s" => \$refile_method,
+ "force" => \$force_option
) or exit(EX_USAGE);
++$verbose if $dry_run;
@@ -679,10 +734,8 @@ if ($recipient) {
$mailer_args{to} = $recipient;
}
-#print Dumper([\%mailer_args]);
-
-$url = shift;
-abend(EX_USAGE, "not enough arguments") unless defined $url;
+$archive_url = shift;
+abend(EX_USAGE, "not enough arguments") unless defined $archive_url;
abend(EX_USAGE, "too many arguments") unless $#ARGV == -1;
if ($refile_method) {
abend(EX_USAGE, "unknown refiling method")
@@ -695,7 +748,7 @@ $wd = tempdir()
or abend(EX_CANTCREAT, "can't create temporary directory: $!");
chdir($wd) or abend(EX_OSERR, "can't change to temporary directory $wd: $!");
-get_sources($url);
+get_sources($archive_url);
verify;
notify;
@@ -723,6 +776,7 @@ B<tpnotify>
[B<--debug>]
[B<--domain=>I<DOMAIN>]
[B<--dry-run>]
+[B<--force>]
[B<--from=>I<EMAIL>]
[B<--fullname=>I<NAME>]
[B<--keep>]
@@ -843,7 +897,7 @@ between the word and end of line. For example
To: <coordinator@translationproject.org>
Subject: $package_base.pot
- $url
+ $archive_url
EOF
The valid statements are as follows:
@@ -864,7 +918,7 @@ line option.
=item B<template=>I<TEXT>
-Template for the message. The I<TEXT> is normally a here document.
+Template for the message. The I<TEXT> is normally a here-document.
See the B<TEMPLATE> section for a description of its format.
=item B<signature-file=>I<FILE>
@@ -926,7 +980,7 @@ An example of the configuration file follows:
The new $release_type version of $package_name is available at:
- $url
+ $archive_url
$signature
EOT
@@ -963,10 +1017,11 @@ that is not present either, then the local host name is used instead.
=item $signature
-Contents of the I<signature file>. The file location is given by the command
-line option B<--signature> or the configuration statement B<--signature-file>.
+Contents of the I<signature file> with the final newline character removed.
+The file location is given by the command line option B<--signature> or the
+configuration statement B<--signature-file>.
-=item $url
+=item $archive_url
I<URL> of the tarball as supplied in the command line.
@@ -1010,6 +1065,11 @@ the type is B<stable>.
=over 8
+=item B<--force>
+
+Force submitting the message even if the downloaded POT file does not pass
+checks.
+
=item B<--no-config>
Don't read configuration file.

Return to:

Send suggestions and report system problems to the System administrator.