Implement verify_potfile

2 files changed, 98 insertions, 34 deletions

diff --git a/Makefile.PL b/Makefile.PL
index cc3f792..610232c 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -20,7 +20,8 @@ WriteMakefile(NAME          => 'tpnotify',
                                  'File::Path'      => 2.08,
                                  'IPC::Open2'      => 1.04,
                                  'Mail::Send'      => 2.09,
-                                 'Mail::Message'   => 2.115,
+			         'Mail::Message'   => 2.115,
+				 'Locale::PO'      => 0,
                                  'Sys::Hostname'   => 0,
                                  'Data::Dumper'    => 0 } );
 
diff --git a/tpnotify b/tpnotify
index 46ab9f8..9d042be 100755
--- a/tpnotify
+++ b/tpnotify
@@ -1,5 +1,4 @@
-#!/usr/bin/perl
-# Copyright (C) 2016 Sergey Poznyakoff <gray@gnu.org>
+# Copyright (C) 2016,2019 Sergey Poznyakoff <gray@gnu.org>
 #
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
@@ -15,6 +14,7 @@
 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 use strict;
+use warnings;
 use Getopt::Long qw(:config gnu_getopt no_ignore_case);
 use Pod::Usage;
 use Pod::Man;
@@ -27,9 +27,10 @@ use File::Path qw(remove_tree);
 use IPC::Open2;
 use Mail::Send;
 use Mail::Message;
-use Sys::Hostname;;
-use Data::Dumper;
+use Sys::Hostname;
+#use Data::Dumper;
 use POSIX qw(strftime);
+use Locale::PO;
 
 my $progname = basename($0);
 my $progdescr = "Notifies translationproject.org about new POT file";
@@ -61,9 +62,14 @@ $signature
 EOT
     ;
 
+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 $filename;   # Archive file name
+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
@@ -97,12 +103,21 @@ sub info {
     print "\n";
 }
 
+# download($source, dest => 'filename' or ref)
 sub download {
-    my ($source) = @_;
+    my ($source,%opt) = @_;
     my $url = new URI($source);
-    
-    $filename = basename($url->path);
-    info("downloading $source to $wd/$filename") if $verbose;
+
+    my $dest = delete $opt{dest} || basename($url->path);
+    my %args;
+    if ($verbose) {
+	if (ref($dest) eq '') {
+	    $args{':content_file'} = $dest;
+	    info("downloading $source to $wd/$dest");
+	} else {
+	    info("downloading $source");
+	}
+    }
 
     my $scheme = $url->scheme;
     eval {
@@ -114,23 +129,32 @@ sub download {
     }
     my $ua = LWP::UserAgent->new();
     $ua->agent("tpnotify/$VERSION");
-    my $response = $ua->get($url->as_string, ':content_file' => $filename);
+    my $response = $ua->get($url->as_string, %args);
     unless ($response->is_success) {
 	abend(EX_UNAVAILABLE,
 	      "downloading $source failed: " . $response->status_line);
     }
-    info("scanning $filename") if $verbose;
-    open(my $fd, '-|', "tar tf $filename")
-	or abend(EX_NOINPUT, "can't open $filename: $!");
+    if (ref($dest) eq 'SCALAR') {
+	$$dest = $response->decoded_content;
+    }
+    return $dest;
+}
+
+sub get_sources {
+    my ($source) = @_;
+    $archive_file = download($source);
+    info("scanning $archive_file") if $verbose;
+    open(my $fd, '-|', "tar tf $archive_file")
+	or abend(EX_NOINPUT, "can't open $archive_file: $!");
     while (<$fd>) {
 	chomp;
 	unless (m#^(?<dir>.+?)/(?<file>.*)$#) {
-	    abend(EX_DATAERR, "$filename content suspicious: member $_");
+	    abend(EX_DATAERR, "$archive_file content suspicious: member $_");
 	}
 	if (defined($topdir)) {
 	    unless ($+{dir} eq $topdir) {
 		abend(EX_DATAERR,
-		      "$filename content suspicious: $+{dir} does not match $topdir");
+		      "$archive_file content suspicious: $+{dir} does not match $topdir");
 	    }
 	} else {
 	    $topdir = $+{dir};
@@ -145,17 +169,17 @@ sub download {
 
     # Verify available files
     unless (exists($files{'configure.ac'})) {
-	abend(EX_DATAERR, "no configure.ac in $filename");
+	abend(EX_DATAERR, "no configure.ac in $archive_file");
     }
     unless (keys(%files) > 1) {
-	abend(EX_DATAERR, "no potfile in $filename");
+	abend(EX_DATAERR, "no potfile in $archive_file");
     }
 
     my $filelist = join(' ', values(%files));
-    info("extracting from $filename") if $verbose;
-    system("tar xf $filename $filelist");
-    check_command_status("tar xf $filename $filelist");
-    #print "tar xvf $filename " . ;
+    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";
 }
 
@@ -172,10 +196,6 @@ sub check_command_status {
     }
 }
 
-sub verify_potfile {
-    # FIXME
-}
-
 sub verify {
     my ($in, $out);
     my $pid = open2($out, $in, "m4 -P - $files{'configure.ac'}")
@@ -208,9 +228,9 @@ EOT
 	}
     }
 
-    if (substr($filename, 0, length($package_base)) ne $package_base) {
+    if (substr($archive_file, 0, length($package_base)) ne $package_base) {
 	abend(EX_DATAERR,
-	      "filename $filename does not begin with $package_base");
+	      "filename $archive_file does not begin with $package_base");
     }
     if ($package_base ne $topdir) {
 	abend(EX_DATAERR,
@@ -220,7 +240,50 @@ EOT
     unless ($files{$potfile}) {
 	abend(EX_DATAERR, "potfile $potfile not found in archive");
     }
-    verify_potfile;
+    verify_potfile($files{$potfile});
+}
+
+sub po_header {
+    my $name = shift;
+    print "READING $name\n";
+    (my $h = Locale::PO->load_file_asarray($name)->[0]->msgstr)
+	=~ s/^"(.*)"$/$1/;
+    my %ret;
+    foreach my $s (split /\\n/, $h) {
+	if ($s =~ /^(.+?):\s*(.*)$/) {
+	    $ret{lc $1}=$2;
+        }
+    }
+    \%ret;
+}
+
+sub po_serialize {
+    my $name = shift;
+    join("\n", sort map { ($_->msgid // '') . ':' . ($_->msgid_plural // '') } @{Locale::PO->load_file_asarray($name)});
+}
+
+sub po_cmp {
+    my ($a,$b) = @_;
+    po_serialize($a) eq po_serialize($b);
+}
+
+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\"");
+    }
+
+    (my $url = $tp_url) =~ s/\$\{domain\}/$package_tarname/;
+    download($url, dest => \my $content);
+    if ($content =~ m{$pot_regex_str}) {
+	my $tp_potname = download($1);
+	if (po_cmp($potname, $tp_potname)) {
+	    err("potfile contains no new msgids; no need to upload");
+	    exit(0);
+	}
+    }
 }
 
 sub get_special_var {
@@ -336,11 +399,11 @@ sub mail_box_manager_refile {
     }
 
     my $mgr = Mail::Box::Manager->new();
-    my $folder = $mgr->open(%args)
+    my $fld = $mgr->open(%args)
 	or abend(EX_CANTCREAT, "can't open folder $folder");
-    $folder->addMessage($msg)
+    $fld->addMessage($msg)
 	or abend(EX_CANTCREAT, "can't save message to folder $folder");
-    $folder->close;
+    $fld->close;
 }
 
 sub movemail_supported {
@@ -632,7 +695,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: $!");
 
-download($url);
+get_sources($url);
 verify;
 notify;
 
@@ -907,7 +970,7 @@ line option B<--signature> or the configuration statement B<--signature-file>.
 
 I<URL> of the tarball as supplied in the command line.
     
-=item $filename
+=item $archive_file
 
 Name of the tarball.  It is the last pathname component from I<URL>.