view release on metacpan or  search on metacpan

lib/App/Chart/Download.pm  view on Meta::CPAN

#------------------------------------------------------------------------------

sub http_code_is_allowed {
  my ($aref, $code) = @_;
  return (grep {$code eq $_} @{$aref // []}) > 0;
}

sub get {
  my ($class, $url, %options) = @_;
  ### Download get(): $url

  # URI object becomes string
  $url = "$url";

  my $ua = $options{'ua'} || do { require App::Chart::UserAgent;
                                  App::Chart::UserAgent->instance };
  $ua->cookie_jar ($options{'cookie_jar'});  # undef for none
  ### cookie_jar object: ($options{'cookie_jar'} // "").""

  require HTTP::Request;
  my $method = $options{'method'} || 'GET';
  my @headers = (Referer => $options{'referer'});
  my $data = $options{'data'};
  if (defined $data) {
    push @headers, 'Content-Type' => 'application/x-www-form-urlencoded';
  }
  my $req = HTTP::Request->new ($method, $url, \@headers, $data);

  # possible override
  if (my $user_agent = $options{'user_agent'}) {
    $req->user_agent($user_agent);
  }

  my $etag = $options{'etag'};
  my $lastmod = $options{'last_modified'};

  if (my $key = $options{'url_tags_key'}) {
    my $symbol = $options{'symbol'};
    my $prev_url = App::Chart::Database->read_extra($symbol,"$key-URL");
    if (defined $prev_url && $url eq $prev_url) {
      $etag    = App::Chart::Database->read_extra($symbol,"$key-ETag");
      $lastmod = App::Chart::Database->read_extra($symbol,"$key-Last-Modified");
    }
  }

  if ($etag)    { $req->header ('If-None-Match' => $etag); }
  if ($lastmod) { $req->header ('If-Modified-Since' => $lastmod); }

  my $resp = $ua->request ($req);

  # internal message from LWP when a keep-alive has missed the boat
  if ($resp->status_line =~ /500 Server closed connection/i) {
    substatus (__('retry'));
    $resp = $ua->request ($req);
  }

  my $code = $resp->code;
  if ($resp->is_success
      || ($options{'allow_401'} && $code == 401)
      || ($options{'allow_404'} && $code == 404)
      || (($etag || $lastmod) && $code == 304)
      || http_code_is_allowed($options{'allow_http_codes'}, $code)) {
    substatus (__('processing'));
    return $resp;
  } else {
    my $error = $resp->status_line . "\n";
    if ($code == 500) {
      $error .= $resp->decoded_content;
      unless ($error =~ /\n$/s) { $error .= "\n"; }
    }
    croak "Cannot download $url\n" . $error;
  }
}

#------------------------------------------------------------------------------

my $last_status = '';     # without substatus addition

sub download_message {
  print join (' ',@_),"\n";
}
sub verbose_message {
  if ($App::Chart::option{'verbose'}) {
    print join (' ',@_),"\n";
  }
}

sub status {
  my $str = join (' ', @_);
  $last_status = $str;
  PerlIO::via::EscStatus::print_status ($str);
}
sub substatus {
  my ($str) = @_;
  if ($str) {
    PerlIO::via::EscStatus::print_status ($last_status, ' [', $str, ']');
  }
}

#------------------------------------------------------------------------------

sub split_lines {
  my ($str) = @_;
  my @lines = split (/[\r\n]+/, $str);     # LF or CRLF
  foreach (@lines) { $_ =~ s/[ \t]+$// }   # trailing whitespace
  return grep {$_ ne ''} @lines;           # no blanks
}

#------------------------------------------------------------------------------

# Return $str with trailing "0"s removed.
# Don't go below $want_deicmals digits after the decimal point.
sub trim_decimals {
  my ($str, $want_decimals) = @_;
  if ($str && $str =~ /(.*\.[0-9]{$want_decimals}[0-9]*?)0+$/) {
    return $1;
  } else {
    return $str;
  }
}