# Copyright 2008, 2009, 2010, 2011 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::UserAgent;
use 5.006;
use strict;
use warnings;
use App::Chart;
use Locale::TextDomain ('App-Chart');
use HTTP::Message 5.814; # for decodable()
use base 'LWP::UserAgent';
use Class::Singleton 1.03; # 1.03 for _new_instance()
use base 'Class::Singleton';
*_new_instance = \&new;
# Crib notes:
#
# URIs:
# Current RFC3986
#
# Past RFC2396 -- previous URI spec
# RFC1808 -- relative URI spec
# RFC1738 -- previous again
# RFC1736, RFC1737 -- functional specs
#
# Proxies:
# /usr/share/doc/libwww-doc/html/Library/User/Using/Proxy.html
# http_proxy, no_proxy
# Eg. http_proxy=http://proxy.zipworld.com.au:8080/
#
# /usr/share/doc/lynx/lynx_help/keystrokes/environments.html
# shows spaces in no_proxy
#
# wget.info Proxies
#
#
# something ...
# @LWP::Protocol::http::EXTRA_SOCK_OPTS = (PeerAddr => "foo.com");
#
sub new {
my ($class, %options) = @_;
if (! exists $options{'keep_alive'}
&& ! exists $options{'conn_cache'}) {
$options{'keep_alive'} = 1; # connection cache 1 sock
}
if (! exists $options{'agent'}) {
# not given, use default
$options{'agent'} = $class->_agent;
} elsif (defined $options{'agent'} && $options{'agent'} =~ / $/) {
# ends in space, append default
$options{'agent'} .= $class->_agent;
}
my $self = $class->SUPER::new (%options);
# with lwp bit appended
# $self->agent ();
# ask for everything decoded_content() can cope with
$self->default_header ('Accept-Encoding' => HTTP::Message::decodable());
# trace on redirect ...
return $self;
}
sub _agent {
my ($class) = @_;
return "Chart/$App::Chart::VERSION " . $class->SUPER::_agent;
}
sub redirect_ok {
my ($self, $prospective_request, $response) = @_;
my $ret = $self->SUPER::redirect_ok ($prospective_request, $response);
if ($ret) {
print "Redirect to ",$prospective_request->uri,"\n";
}
return $ret;
}
sub request {
my ($self, @args) = @_;
$self->{__PACKAGE__.'.last_time'} = time() - 1; # provoke initial display
return $self->SUPER::request (@args);
}
# method call up from LWP::UserAgent
sub progress {
my ($self, $status, $response) = @_;
my $str = $status;
if ($status eq 'begin') {
$str = __('connect');
} elsif ($response && $status ne 'end') {
my $time = time();
if ($time != $self->{__PACKAGE__.'.last_time'}) {
$self->{__PACKAGE__.'.last_time'} = $time;
my $got = length ($response->content);
my $total = $response->content_length;
if (defined $total) {
$str = __x('{got} of {total} bytes',
got => $got, total => $total);
} else {
$str = __x('{got} bytes', got => $got);
}
} else {
$str = undef;
}
}
if (defined $str) {
require App::Chart::Download;
App::Chart::Download::substatus ($str);
}
return $self->SUPER::progress ($status, $response);
}
# use Data::Dumper;
# *LWP::Protocol::http::SocketMethods::configure = sub {
# my $self = shift;
# print Dumper (\@_);
# $self->SUPER::configure (@_);
# };
1;
__END__
=for stopwords LWP useragent gzip eg
=head1 NAME
App::Chart::UserAgent -- LWP useragent subclass
=head1 SYNOPSIS
use App::Chart::UserAgent;
my $ua = App::Chart::UserAgent->instance;
=head1 CLASS HIERARCHY
LWP::UserAgent
App::Chart::UserAgent
=head1 DESCRIPTIONS
This is a small subclass of C<LWP::UserAgent> which sets up, by default,
=over 4
=item *
Connection caching, currently just 1 kept open at any time.
=item *
C<User-Agent> identification header.
=item *
C<Accept-Encoding> header with C<HTTP::Message::decodable()> to let the
server send gzip etc. This means all responses should be accessed with
C<< $resp->decoded_content() >>, not raw C<content()>.
=item *
Progress and redirection messages (back through C<App::Chart::Download>).
=back
=head1 FUNCTIONS
=over 4
=item C<< App::Chart::UserAgent->instance >>
Return a shared C<App::Chart::UserAgent> object. This shared instance is
meant for all normal use.
=item C<< App::Chart::UserAgent->new (key => value, ...) >>
Create and return a new C<App::Chart::UserAgent> object.
=item C<< App::Chart::UserAgent->_agent >>
=item C<< $ua->_agent >>
Return the default C<User-Agent> header string. This is Chart plus the LWP
default, eg.
Chart/100 libwww-perl/5.814
=back
=head1 SEE ALSO
L<LWP::UserAgent>
=cut