view release on metacpan or  search on metacpan

tpnotify  view on Meta::CPAN

# -----------------
# Download and extract source archive.
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, "$archive_file content suspicious: member $_");
	}
	if (defined($topdir)) {
	    unless ($+{dir} eq $topdir) {
		abend(EX_DATAERR,
		      "$archive_file content suspicious: $+{dir} does not match $topdir");
	    }
	} else {
	    $topdir = $+{dir};
	}
	my $f = $+{file};
	if ($f eq 'configure.ac' || $f =~ m#po/.*\.pot#) {
	    $files{$f} = $_;
	}
    }
    close $fd;
    info("top level directory: $topdir") if $verbose;

    # Verify available files
    unless (exists($files{'configure.ac'})) {
	abend(EX_DATAERR, "no configure.ac in $archive_file");
    }
    unless (keys(%files) > 1) {
	abend(EX_DATAERR, "no potfile in $archive_file");
    }

    my $filelist = join(' ', values(%files));
    info("extracting from $archive_file") if $verbose;
    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 || $?;

    if ($status == -1) {
	abend(EX_OSERR, "failed to run $cmd");
    } elsif ($status & 127) {
	abend(EX_UNAVAILABLE, "$cmd exited on signal " . ($status & 127));
    } elsif (my $e = ($status >> 8)) {
	abend(EX_UNAVAILABLE, "$cmd exited with status $e");
    }
}

# 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'}")
	or abend(EX_NOINPUT, "can't open $files{'configure.ac'}: $!");
    print $in <<'EOT';
m4_divert(-1)
m4_changequote([,])
m4_define([AC_INIT],[m4_divert(0)$1
$2[]m4_divert(-1)])
EOT
    close $in;
    waitpid($pid, 0);
    check_command_status("m4");
    chomp(my @lines = <$out>);
    abend(EX_DATAERR, "can't parse $files{'configure.ac'}")
	unless $#lines == 1;
    ($package_name, $package_version) = @lines;
    $package_tarname = $package_name;
    $package_tarname =~ s/GNU\s+//;
    $package_tarname = lc $package_tarname; # FIXME: this is not always right,
					    # perhaps
    info("package $package_name, tarname $package_tarname, version $package_version") if $verbose;
    $package_base = "$package_tarname-$package_version";

    unless (defined($release_type)) {
	if ($package_version =~ m/\d+\.\d+\.(\d+)/ && int($1) >= 90) {
	    $release_type = 'alpha';
	} else {
	    $release_type = 'stable';
	}
    }

    if (substr($archive_file, 0, length($package_base)) ne $package_base) {
	abend(EX_DATAERR,
	      "filename $archive_file does not begin with $package_base");
    }
    if ($package_base ne $topdir) {
	abend(EX_DATAERR,
	      "toplevel directory $topdir does not begin with $package_base");
    }
    my $potfile = "po/$package_tarname.pot";
    unless ($files{$potfile}) {
	abend(EX_DATAERR, "potfile $potfile not found in archive");
    }
    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;

    (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;
}

# 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") {
	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/;
    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) unless $force_option;
	}
    }
}

# Reads the signature file from $signature_file.
sub read_signature {
    if (defined($signature_file)) {
	if (open(my $fd, '<', $signature_file)) {
	    local $/;
	    chomp(my $sig = <$fd>);
	    close($fd);
	    return $sig;
	}
    }
    return undef;
}

# Expands the message template.
# Returns the expanded text.  Abends on failure.
sub expand_template {
    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));
    ${$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.

tpnotify  view on Meta::CPAN

	   "verbose|v+" => \$verbose,
	   "dry-run|n" => \$dry_run,
	   "debug|d+" => \$debug,
	   "mailer|m=s" => sub {
	       exit(EX_USAGE) unless set_mailer($_[1])
	   },
	   "from|f=s" => \$sender,
	   "fullname|F=s" => \$fullname,
	   "domain|D=s" => \$localdomain,
	   "to=s" => \$recipient,
	   "add|a=s@" => \@add_headers,
	   "refile-method=s" => \$refile_method,
	   "force" => \$force_option
) or exit(EX_USAGE);

++$verbose if $dry_run;
if ($debug && exists($mailer_args{via})) {
    if ($mailer_args{via} eq 'sendmail') {
	$mailer_args{sendmail_options} = []
	    unless exists $mailer_args{sendmail_options};
	push @{$mailer_args{sendmail_options}},
	      '-O', 'LogLevel=99', '-d10.100', '-d13.90', '-d11.100';
    } elsif ($mailer_args{via} eq 'smtp') {
	$mailer_args{smtp_debug} = 1;
    }
}

if ($sender && exists($mailer_args{via})) {
    if ($mailer_args{via} eq 'sendmail') {
	$mailer_args{sendmail_options} = []
	    unless exists $mailer_args{sendmail_options};
	push @{$mailer_args{sendmail_options}}, '-f', $sender;
    } elsif ($mailer_args{via} eq 'smtp') {
	$mailer_args{from} = $sender;
    }
}

my ($name,undef,undef,undef,undef,$comment,$gecos) = getpwuid($<);
$fullname = $gecos || $comment || $name unless defined $fullname;
$sender = $name . '@' . ($localdomain || hostname()) unless defined $sender;

if ($recipient) {
    $mailer_args{to} = $recipient;
}

$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")
	unless exists($refile_tab{$refile_method});
    abend(EX_USAGE, "refiling method not supported")
	unless (&{$refile_tab{$refile_method}{supported}});
}

$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($archive_url);
verify;
notify;

__END__

=head1 NAME

tpnotify - Notifies translationproject.org about new POT file

=head1 SYNOPSIS

B<tpnotify>
[B<-ANSdnkv>]
[B<-D> I<DOMAIN>]
[B<-F> I<NAME>]
[B<-a> I<HDR>B<:>I<VALUE>
[B<-c> I<FILE>]
[B<-f> I<FROM>]
[B<-m> I<SPEC>]
[B<-s> I<FILE>]
[B<-t> I<FILE>]
[B<--add=>I<HDR>:I<VAL>]
[B<--alpha>]
[B<--config=>I<FILE>]
[B<--debug>]
[B<--domain=>I<DOMAIN>]
[B<--dry-run>]
[B<--force>]
[B<--from=>I<EMAIL>]
[B<--fullname=>I<NAME>]
[B<--keep>]
[B<--mailer=>I<SPEC>]
[B<--no-config>]
[B<--no-signature>]
[B<--refile-method=>B<perl> | B<mailutils>]
[B<--signature=>I<FILE>]
[B<--stable>]
[B<--template=>I<FILE>]
[B<--to=>I<EMAIL>]
[B<--verbose>]
I<URL>

B<tpnotify>
[B<-h>]
[B<--help>]
[B<--usage>]

=head1 DESCRIPTION

Notifies the coordinator of the I<Translation Project> about new
POT file available at I<URL>.  The URL must point to a tarball of
a package registered at TP (I<http://translationproject.org/domain/>).
The tool works as follows:

First of all, the indicated I<URL> is downloaded to a temporary location
on disk.  The contents of the retrieved tarball is inspected.  It must
contain the file F<configure.ac> in the project top level directory and
one or more files with the B<.pot> suffix in the F<po> subdirectory.

These files are extracted.  The F<configure.ac> is parsed in order to
determine the package name and version (from the B<AC_INIT> statement).