[libcatalyst-modules-perl] 01/12: a script to fetch updated upstream source

[Damyan Ivanov]

This is an automated email from the git hooks/post-receive script.

dmn pushed a commit to branch dam-bundle-2.0
in repository libcatalyst-modules-perl.

commit 33642f9642274ec359e1fd0d586291d36d3597e2
Author: Damyan Ivanov <dmn at debian.org>
Date:   Thu May 8 09:34:18 2014 +0000

    a script to fetch updated upstream source
---
 debian/fetch | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 92 insertions(+)

diff --git a/debian/fetch b/debian/fetch
new file mode 100755
index 0000000..c69ad74
--- /dev/null
+++ b/debian/fetch
@@ -0,0 +1,92 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+
+use Archive::Extract      ();
+use DirHandle             ();
+use File::Copy::Recursive ();
+use File::Remove          ();
+use File::Temp            ();
+use Term::Cap             ();
+use WWW::Mechanize        ();
+
+
+my $term = Term::Cap->Tgetent();
+my $cd = $term->Tputs('cd');
+my $sc = $term->Tputs('sc');
+my $rc = $term->Tputs('rc');
+
+sub doing {
+    print $sc, @_;
+}
+
+sub done {
+    print "$rc$cd";
+}
+
+$| = 1;
+
+my $dist = shift @ARGV;
+
+my $tmp_dir = File::Temp->newdir(
+    "bundle-fetch-$dist-XXXXXXX",
+    DIR     => '.',
+    CLEANUP => 1,
+);
+
+my $ua = WWW::Mechanize->new;
+
+my $url = "https://metacpan.org/release/$dist";
+doing("Fetching $url...");
+$ua->get($url);
+done();
+
+my $download_link = $ua->find_link(
+    text_regex => qr(Download),
+    url_regex  => qr(/$dist-.+\.(?:zip|tar\.(?:gz|xz|bz2|lzma)))
+);
+
+my $fn = $download_link->url;
+$fn =~ s{.+/}{};
+$fn or die "No file name in response";
+die "Invalid file name '$fn'"
+    if $fn =~ m{[/\\:\ \$\%'"]} or $fn !~ /^[\x21-\x7f]+$/;
+
+my $tarball_file = File::Spec->catfile( $tmp_dir, $fn );
+
+doing("Downloading " . $download_link->url . '...');
+$ua->get( $download_link, ':content_file' => $tarball_file );
+done();
+
+my $extract_dir = File::Spec->catdir($tmp_dir, 'extract');
+my $tarball = Archive::Extract->new( archive => $tarball_file );
+doing("Extracting $tarball_file...");
+$tarball->extract( to => $extract_dir );
+done();
+
+my $dir = DirHandle->new($extract_dir);
+my $extracted_tree;
+while ( defined( $_ = $dir->read ) ) {
+    next if $_ eq '.';
+    next if $_ eq '..';
+
+    die "Multiple directories extracted ($extracted_tree, $_)"
+        if $extracted_tree;
+
+    $extracted_tree = $_;
+}
+
+die "Nothing in the archive" unless $extracted_tree;
+
+my $destination = File::Spec->catdir( 'sources', $dist );
+doing("Removing $destination...");
+File::Remove::remove( \1, $destination );
+done();
+
+$extracted_tree = File::Spec->catdir( $extract_dir, $extracted_tree );
+
+doing("Copying $extracted_tree to $destination...");
+File::Copy::Recursive::dircopy( $extracted_tree, $destination );
+done();

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatalyst-modules-perl.git