view release on metacpan or  search on metacpan

tpnotify  view on Meta::CPAN

sub err {
    my $msg = shift;
    local %_ = @_;

    print STDERR "$progname: ";
    print STDERR "$_{prefix}: " if exists $_{prefix} && defined $_{prefix};
    print STDERR "$msg\n";
}

sub abend {
    my $code = shift;
    &err;
    if ($keep && $code ne EX_USAGE && $code ne EX_CONFIG) {
	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));