package LWP::UA;
require LWP::Hooks;
@ISA=qw(LWP::Hooks);

use strict;
use vars qw($DEBUG $VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/);

use LWP::MainLoop qw(mainloop);

# Hope to not see the old URI::URL class any more
$HTTP::URI_CLASS = "URI";
require HTTP::Message;

require LWP::Version;
require LWP::Server;
require URI::Attr;

sub new_plain
{
    my $class = shift;
    my $ua =
	bless {
	       ua_uattr    => URI::Attr->new,
	       ua_max_conn => 5,
	       ua_servers  => {},
	      }, $class;
    $ua;
}

sub new
{
    my $class = shift;
    my $ua = $class->new_plain;
    $ua->setup_default_handlers;
    $ua->agent($LWP::Version::PRODUCT_TOKEN);
    $ua;
}

sub setup_default_handlers
{
    my $self = shift;
    $self->add_hook("spool_request", \&_setup_default_headers);

    eval { require HTML::HeadParser; };
    unless ($@) {
	$self->add_hook("spool_request", \&_setup_head_parser);
    }

    require LWP::UA::Proxy;
    $self->add_hook("spool_request", \&LWP::UA::Proxy::spool_handler);

    require LWP::Authen;
    $self->add_hook("spool_request", \&LWP::Authen::spool_handler);
}

sub uri_attr
{
    my $self = shift;
    @_ ? $self->{'ua_uattr'}->attr(@_) : $self->{'ua_uattr'};
}

sub uri_attr_plain
{
    my $self = shift;
    $self->{'ua_uattr'}->attr_plain(@_);
}

sub uri_attr_update
{
    my $self = shift;
    $self->{'ua_uattr'}->attr_update(@_);
}

sub agent
{
    my $self = shift;
    my $old = $self->{'ua_agent'};
    if (@_) {
	my $agent = $self->{'ua_agent'} = shift;
	for ("http", "https") {
	    $self->uri_attr_update(SCHEME => "$_:")
		->{'default_headers'}{'User-Agent'} = $agent;
	}
	$self->uri_attr_update(SCHEME => "mailto:")
	    ->{'default_headers'}{'X-Mailer'} = $agent;
	$self->uri_attr_update(SCHEME => "news:")
	    ->{'default_headers'}{'X-Newsreader'} = $agent;
    }
    $old;
}


sub find_server
{
    my($self, $url) = @_;
    $url = URI->new($url) unless ref $url;
    return undef unless $url;

    my $proto = $url->scheme || return undef;
    my $host = $url->host;  # XXX not safe
    my($port, $authority);

    # Handle some special cases where $host can't be trusted
    $host = undef if $proto eq "file" || $proto eq "mailto";

    if ($host) {
	$port = $url->port;
	$authority = $port ? "$proto://$host:$port" : "$proto://host";
    } else {
	$authority = "$proto:";
    }

    my $server = $self->{ua_servers}{$authority};
    unless ($server) {
	$server = $self->{ua_servers}{$authority} =
	  LWP::Server->new($self, $proto, $host, $port);
    }
}

sub forget_server
{
    my($self,$sid) = @_;
    delete $self->{ua_servers}{$sid};
}

sub servers
{
    my $self = shift;
    values %{$self->{ua_servers}};
}


sub spool
{
    my $self = shift;
    my $spooled = 0;
    for my $req (@_) {
	bless $req, "LWP::Request" if ref($req) eq "HTTP::Request"; #upgrade
	$req->managed_by($self);

	# Some initial tests.  These could be made optional by putting
	# them in a spool_request hook too.
	unless ($req->method) {
	    $req->give_response(400, "Missing METHOD in request");
	    next;
	}
	my $url = $req->url;
	unless ($url) {
	    $req->give_response(400, "Missing URL in request");
	    next;
	}
	unless ($url->scheme) {
	    $req->give_response(400, "Request URL must be absolute");
	    next;
	}
	next if $self->run_hooks_until_success("spool_request", $req);

	my $proxy = $req->proxy;
	my $server = $self->find_server($proxy ? $proxy : $req->url);
	$server->add_request($req);
	$spooled++;
	if ($DEBUG) {
	    my $id = $server->id;
	    print "$req spooled to $id\n";
	}
    }

    $self->reschedule if $spooled;
}

sub request
{
    my($self, $req) = @_;
    my $res;
    my $old_cb = $req->{done_cb};
    $req->{done_cb} = sub { $res = $_[0]; &$old_cb(@_) if $old_cb };
    $self->spool($req);
    mainloop->one_event until $res || mainloop->empty();
    $res;
}


sub response_received
{
    my($self, $res) = @_;
    push(@{$self->{'ua_responses'}}, $res);
}


sub stop
{
    my $self = shift;
    foreach (values %{$self->{ua_servers}}) {
	$_->stop;
    }
}


sub reschedule
{
    my $self = shift;
    my $sched = $self->{'ua_scheduler'};
    unless ($sched) {
	require LWP::StdSched;
	$sched = $self->{'ua_scheduler'} = LWP::StdSched->new($self);
    }
    $sched->reschedule($self);
}

sub max_conn
{
    my $self = shift;
    my $old = $self->{'ua_max_conn'};
    if (@_) {
	$self->{'ua_max_conn'} = shift;
    }
    $old;
}


sub _setup_default_headers
{
    my($self, $req) = @_;
    for my $hash ($self->uri_attr_plain($req->url, "default_headers")) {
	for my $k (keys %$hash) {
	    next if defined($req->header($k));
	    $req->header($k => $hash->{$k});
	}
    }
    0; # continue
}


sub _response_data_hp
{
    my($req,$data,$res) = @_;
    my $hp = $req->{head_parser};
    unless ($hp) {
	if ($res->content_type eq "text/html") {	
	    $req->{head_parser} = $hp = HTML::HeadParser->new($res);
	} else {
	    $req->remove_hook("response_data", \&_response_data_hp);
	    return;
	}
    }
    unless ($hp->parse($data)) {
	# done
	delete $req->{head_parser};
	$req->remove_hook("response_data", \&_response_data_hp);
    }
}

sub _setup_head_parser
{
    my($self,$req) = @_;
    $req->add_hook("response_data", \&_response_data_hp);
    0;
}

1;