view release on metacpan or  search on metacpan

tpnotify  view on Meta::CPAN

	err("examine $wd for details");
    }
    exit($code);
}

sub info {
    print "$progname: ";
    print @_;
    print "\n";
}

# 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);

    my $dest = delete $opt{dest} || basename($url->path);
    my %args;
    if (ref($dest) eq '') {
	$args{':content_file'} = $dest;
	info("downloading $source to $wd/$dest") if $verbose;
    } else {
	info("downloading $source") if $verbose;
    }

    my $scheme = $url->scheme;
    eval {
	require "LWP/Protocol/$scheme.pm";
    };
    if ($@) {
	$@ =~ s/\s+at [^\s]+ line \d+\.$//;
	abend(EX_OSERR, "$@");
    }
    my $ua = LWP::UserAgent->new();
    $ua->agent("tpnotify/$VERSION");
    my $response = $ua->get($url->as_string, %args);
    unless ($response->is_success) {
	abend(EX_UNAVAILABLE,
	      "downloading $source failed: " . $response->status_line);
    }
    if (ref($dest) eq 'SCALAR') {
	$$dest = $response->decoded_content;
    }
    return $dest;
}

# get_sources($URL)
# -----------------
# 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;
}

tpnotify  view on Meta::CPAN

		if ($file eq '') {
		    err($message);
		} else {
		    err("$file: $message");
		}
	    }
	}
    }
}

sub set_mailer {
    my ($mailer, $locus) = @_;
    if ($mailer =~ /sendmail:(.*)/) {
	$mailer_args{via} = 'sendmail';
	$mailer_args{executable} = $1 if $1;
    } elsif ($mailer =~ m#smtp://(?:(?<user>[^:]+)(?::(?<password>.+))?@)?(?<host>[^:]+)(?::(?<port>\d+))?#) {
	$mailer_args{via} = 'smtp';
	$mailer_args{hostname} = $+{host};
	$mailer_args{port} = $+{port} if $+{port};
	$mailer_args{username} = $+{user} if $+{user};
	$mailer_args{password} = $+{password} if $+{password};
    } else {
	err("unknown mailer spec", prefix => $locus);
	return 0;
    }
    return 1;
}

sub read_template_file {
    my ($file, $locus) = @_;
    if (open(my $fd, '<', $file)) {
	local $/;
	$template = <$fd>;
	close($fd);
	return 1;
    } else {
	err("can't open template file $file: $!", prefix => $locus);
	return 0;
    }
}

my %kw = (
    keep => \$keep,
    'template-file' => \&read_template_file,
    template => \$template,
    'signature-file' => \$signature_file,
    mailer => \&set_mailer,
    from => \$sender,
    sender => \$sender,
    fullname => \$fullname,
    domain => \$localdomain,
    to => \$recipient,
    add => \@add_headers,
    'add-header' => \@add_headers,
    'refile-method' => \$refile_method
);

sub read_config {
    my $config_file = shift;
    open(FILE, "<", $config_file)
	or abend(EX_NOINPUT, "cannot open $config_file: $!");
    my $line = 0;
    my $err;
    my $key;
    my $val;
    my $heredoc;
    my $heredoc_line;
    while (<FILE>) {
	++$line;

	if ($heredoc) {
	    if (/^$heredoc\s*$/) {
		$heredoc = undef;
	    } else {
		$val .= $_;
		next;
	    }
	} else {
	    chomp;
	    s/^\s+//;
	    s/\s+$//;
	    s/#.*//;
	    next if ($_ eq "");

	    if (/^(.*?)\s*=\s*(.*)/) {
		$key = $1;
		$val = $2;

		if ($val =~ /<<(\w+)\s*$/) {
		    $heredoc = $1;
		    $heredoc_line = $line;
		    $val = '';
		    next;
		}
	    } else {
		err("$config_file:$line: syntax error");
		++$err;
	    }
	}

	if (exists($kw{$key})) {
	    my $ref = $kw{$key};
	    if (ref($ref) eq 'CODE') {
		unless (&{$ref}($val, "$config_file:$line")) {
		    ++$err;
		}
	    } elsif (ref($ref) eq 'ARRAY') {
		push @{$ref}, $val;
	    } else {
		$$ref = $val;
	    }
	} else {
	    err("$config_file:$line: unrecognized keyword: '$key'");
	    ++$err;
	}
    }
    close FILE;

    abend(EX_CONFIG, "unfinished heredoc, started at line $heredoc_line")
	if defined $heredoc;
    abend(EX_CONFIG, "errors in config file") if $err;
}

#
my $debug;
my $config_file = "$ENV{HOME}/.tpnotify" if -e "$ENV{HOME}/.tpnotify";

Getopt::Long::Configure(qw(gnu_getopt no_ignore_case pass_through));
GetOptions("help" => sub {
	      pod2usage(-exitstatus => EX_OK, -verbose => 2);
	   },
	   "h" => sub {
	      pod2usage(-message => "$progname: $progdescr",
			-exitstatus => EX_OK);
	   },
	   "usage" => sub {
	      pod2usage(-exitstatus => EX_OK, -verbose => 0);
	   },
	   "config|c=s" => \$config_file,
	   "no-config|N" => sub { $config_file = undef },
    );

read_config($config_file) if defined $config_file;

Getopt::Long::Configure(qw(gnu_getopt no_ignore_case no_pass_through));

GetOptions("keep|k" => \$keep,
	   "alpha|A" => sub { $release_type = 'alpha' },
	   "stable|S" => sub { $release_type = 'stable' },
	   "template|t=s" => sub {
	       exit(EX_NOINPUT) unless read_template_file($_[1])
	   },
	   "signature|s=s" => \$signature_file,
	   "no-signature" => sub { $signature_file = undef },
	   "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: $!");