From: Vincent Pit <vince@profvince.com>
Date: Mon, 5 Nov 2012 18:00:08 +0000 (-0200)
Subject: Show progression while the tarballs are downloaded
X-Git-Tag: v0.04~7
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=9c295bacc149f8f571f07e96f52ee7a1aec933a4;p=perl%2Fmodules%2Fre-engine-Hooks.git

Show progression while the tarballs are downloaded

LWP is required.
---

diff --git a/src/update.pl b/src/update.pl
index e7fe628..fb4c25c 100644
--- a/src/update.pl
+++ b/src/update.pl
@@ -5,18 +5,26 @@ use warnings;
 
 use Getopt::Std;
 
+use Cwd;
 use File::Path;
 use File::Copy;
 use File::Spec;
 
+use Scalar::Util;
 use Time::HiRes;
 
 use Module::CoreList;
 use version;
 
-use File::Fetch;
+use LWP::UserAgent;
 use Archive::Extract;
 
+BEGIN {
+ my $old_fh = select STDOUT;
+ $|++;
+ select $old_fh;
+}
+
 my $has_cpan_perl_releases;
 BEGIN {
  local $@;
@@ -100,13 +108,84 @@ my %perls = map key_version($_),
              grep "$_" >= '5.010001',
               keys %Module::CoreList::released;
 
+{
+ package LWP::MyUserAgent;
+
+ our @ISA;
+ BEGIN { push @ISA, 'LWP::UserAgent' }
+
+ my %cbs;
+ my %ticks;
+
+ sub new {
+  my ($class, $cb) = @_;
+
+  my $ua = bless LWP::UserAgent->new, $class;
+  $ua->timeout(10);
+  $ua->show_progress(1) if $cb;
+
+  my $tag = Scalar::Util::refaddr($ua);
+  $cbs{$tag}   = $cb;
+  $ticks{$tag} = 0;
+
+  return $ua;
+ }
+
+ sub progress {
+  my ($ua, $stat, $r) = @_;
+
+  my $tag = Scalar::Util::refaddr($ua);
+  my $cb  = $cbs{$tag};
+  return unless $cb;
+
+  my $desc;
+  if ($stat eq 'begin') {
+   $desc = '...';
+  } elsif ($stat eq 'end') {
+   $desc = 'done';
+  } elsif ($stat eq 'tick') {
+   my $tick = ++$ticks{$tag};
+   $desc = qw<- \ | />[$tick % 4];
+  } else {
+   $desc = sprintf "%.01f%%", 100 * $stat;
+  }
+
+  $cb->($stat, $desc);
+
+  return;
+ }
+
+ sub DESTROY {
+  my $ua = shift;
+
+  my $tag = Scalar::Util::refaddr($ua);
+
+  delete $cbs{$tag};
+  delete $ticks{$tag};
+
+  return;
+ }
+}
+
 sub fetch_uri {
- my ($uri, $to) = @_;
+ my ($uri, $to, $cb) = @_;
 
  my $start = [ Time::HiRes::gettimeofday ];
 
- my $ff   = File::Fetch->new(uri => $uri);
- my $file = $ff->fetch(to => $to) or die "Could not fetch $uri: " . $ff->error;
+ my $ua = LWP::MyUserAgent->new($cb);
+ my $res = $ua->get($uri);
+ die "Could not fetch $uri: " . $res->status_line unless $res->is_success;
+
+ my $here = Cwd::cwd;
+ my $file = (File::Spec::Unix->splitpath(URI->new($uri)->path))[2];
+ my $vol  = (File::Spec->splitpath($here))[0];
+ $to      =  File::Spec->catdir($here, $to)
+                                  unless File::Spec->file_name_is_absolute($to);
+ $file    =  File::Spec->catpath($vol, $to, $file);
+
+ open my $fh, '>', $file or die "Can't open $file for writing: $!";
+ print $fh $res->content;
+ close $fh or die "Can't close $file: $!";
 
  my $elapsed = Time::HiRes::tv_interval($start);
 
@@ -183,10 +262,24 @@ sub fetch_source_file {
  if (-e File::Spec->catfile($tmp_dir, $archive_file)) {
   print "${INDENT}$archive_file was already fetched\n";
  } else {
-  print "${INDENT}Fetching $archive_uri... ";
-  ($archive_file, my $elapsed) = fetch_uri($archive_uri => $tmp_dir);
+  print "${INDENT}Fetching $archive_uri...\n";
+  my $maxlen = 0;
+  my $cb = sub {
+   my ($stat, $desc) = @_;
+   $desc = '0%' if $stat eq 'begin';
+   my $len   = length $desc;
+   my $extra = '';
+   if ($len > $maxlen) {
+    $maxlen = $len;
+   } else {
+    $extra  = ' ' x ($maxlen - $len);
+   }
+   print "\r${INDENT}  In progress... $desc$extra";
+   print "$extra\n" if $stat eq 'end';
+  };
+  ($archive_file, my $elapsed) = fetch_uri($archive_uri => $tmp_dir, $cb);
   my ($speed, $unit) = bandwidth(-s $archive_file, $elapsed);
-  print "done at $speed$unit\n";
+  print "${INDENT}  File downloaded at $speed$unit\n";
  }
 
  my $extract_path = File::Spec->catfile($tmp_dir, "perl-$version");