view release on metacpan or  search on metacpan

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

# Copyright 2007, 2008, 2009, 2010, 2011, 2013, 2015, 2016, 2017, 2018, 2020, 2023, 2024 Kevin Ryde

# This file is part of Chart.
#
# Chart is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3, or (at your option) any later version.
#
# Chart is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along
# with Chart.  If not, see <http://www.gnu.org/licenses/>.

package App::Chart::Download;
use 5.010;
use strict;
use warnings;
use Carp 'carp','croak';
use Date::Calc;
use List::Util qw(min max);
use List::MoreUtils;
use Regexp::Common 'whitespace';
use Locale::TextDomain ('App-Chart');

use PerlIO::via::EscStatus;
use Tie::TZ;

use App::Chart;
use App::Chart::Database;
use App::Chart::DBI;
use App::Chart::TZ;

# uncomment this to run the ### lines
# use Smart::Comments;

use constant DEBUG => 0;

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

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";
  }
}