From e936b4df97a31401dec55919781235bef1f849fc Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Mon, 29 Jul 2019 12:12:37 +0300 Subject: Use Safe for template expansion --- tpnotify | 176 ++++++++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 118 insertions(+), 58 deletions(-) (limited to 'tpnotify') 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: @@ -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 }; - -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 [B<--debug>] [B<--domain=>I] [B<--dry-run>] +[B<--force>] [B<--from=>I] [B<--fullname=>I] [B<--keep>] @@ -843,7 +897,7 @@ between the word and end of line. For example To: Subject: $package_base.pot - $url + $archive_url EOF The valid statements are as follows: @@ -864,7 +918,7 @@ line option. =item BI -Template for the message. The I is normally a here document. +Template for the message. The I is normally a here-document. See the B