package LWP::Server;
use strict;

use vars qw($DEBUG);

sub new
{
    my($class, $ua, $proto, $host, $port) = @_;

    die "Bad proto" unless $proto =~ /^([a-zA-Z0-9\+\-\.]+)$/;
    my $conn_class = uc($1);  # untaint as well
    $conn_class =~ s/\+/_PLUS_/g;
    $conn_class =~ s/\./_DOT_/g;
    $conn_class =~ s/\-/_MINUS_/g;
    $conn_class = "LWP::Conn::$conn_class";

    my $self = bless
          {
            ua            => $ua,

	    proto         => $proto,
	    conn_class    => $conn_class,

	    created       => time(),
	    request_count => 0,

	    req_queue     => [],
	    conns         => [],
	    idle_conns    => [],
	  }, $class;

    if ($host) {
	$self->{'host'} = $host;
	$self->{'port'} = $port;
    }

    $self;
}

# General parameters

sub proto   {  $_[0]->{'proto'};  }
sub host    {  $_[0]->{'host'};   }
sub port    {  $_[0]->{'port'};   }

sub id
{
    my $self = shift;
    if (my $host = $self->{'host'}) {
	if (my $port = $self->{'port'}) {
	    return "$self->{'proto'}://$host:$port";
	}
	return "$self->{'proto'}://$host";
    }
    return "$self->{'proto'}:";
}

sub c_status
{
    my $self = shift;
    (scalar(@{$self->{req_queue}}),
     scalar(@{$self->{conns}}),
     scalar(@{$self->{idle_conns}}),
     $self->max_conn,
    );
}

# Managing the request queue

sub add_request
{
    my($self, $req) = @_;
    my $pri = $req->priority;
    # XXX should really keep sorted by 'pri' field.  Wouldn't it be nice
    # if Perl had a library similar to Python's bisect.py
    # (perhaps it already has?)
    if ($pri && $pri > 50) {
	push(@{$self->{req_queue}}, $req);
    } else {
	unshift(@{$self->{req_queue}}, $req);
    }
    $self->{'request_count'}++;
    $self->activate_idles;
}

sub stop
{
    my $self = shift;
    # stop all connections
    my @conns = @{$self->{conns}};  # iterate over a copy
    $self->{stopping}++;
    for (@conns) {
	$_->stop;
    }
    $self->kill_queued_requests;
    delete $self->{stopping};
}

sub stop_idle
{
    my $self = shift;
    my @idle = @{$self->{idle_conns}};  # iterate over a copy
    for (@idle) {
	$_->stop;
    }
}

sub kill_queued_requests
{
    my($self, $code, $message, $more) = @_;
    if (!$code) {
	$code = 590;
	$message = "No response";
    }
    while (@{$self->{req_queue}}) {
	my $req = shift @{$self->{req_queue}};
	$req->give_response($code, $message, $more);
    }
}


# Connection management

sub max_conn
{
    my $self = shift;
    $self->{'ua'}->uri_attr_plain($self->id, 'max_conn_per_server') || 2;
}

sub conn_param
{
    my $self = shift;
    my %param;
    for my $hash ($self->{'ua'}->uri_attr_plain($self->id, "conn_param")) {
	while (my($k,$v) = each %$hash) {
	    next if exists $param{$k};
	    $param{$k} = $v;
	}
    }
    # these are always overridden
    $param{ManagedBy} = $self;
    $param{Host} = $self->{'host'};
    $param{Port} = $self->{'port'};

    if (@_) {
	return @param{@_};
    }
    wantarray ? %param : \%param;
}


sub create_connection
{
    my $self = shift;
    my $conn_class = $self->{'conn_class'};
    no strict 'refs';
    unless (defined %{"$conn_class\::"}) {
	eval "require $conn_class";
	if ($@) {
	    $self->kill_queued_requests(590, "No handler for '$self->{'proto'}' scheme", $@);
	    return;
	}
    }
    
    my $conn;
    eval {
	$conn = $conn_class->new($self->conn_param);
    };
    if ($@) {
	print STDERR $@ if $DEBUG;
	chomp($@);
	$self->kill_queued_requests(590, $@);
	$self->done;
	return;
    }
    if ($conn) {
	push(@{$self->{conns}}, $conn);
    } else {
	if (@{$self->{req_queue}}) {
	    my $msg = "Can't connect to " . $self->id;
	    $self->kill_queued_requests(590, $msg, $!);
	}
	$self->done;
    }
}

# Connection protocol

sub get_request
{
    my($self, $conn) = @_;
    my $req = shift(@{$self->{req_queue}});
    if ($req) {
	my $time = time;
	$self->{'last_request_time'} = time;
	$req->sending_start($time);
    }
    $req;
}

sub pushback_request
{
    my $self = shift;
    my $conn = shift;
    unshift(@{$self->{req_queue}}, @_);
    $self->activate_idles;
}

sub activate_connections
{
    my $self = shift;
    my @iconns = @{$self->{idle_conns}};
    my @conns = @{$self->{conns}};
    my %seen;
    # activate idle connections first
    foreach (@iconns) {
	$_->activate;
	$seen{$_}++;
    }
    foreach (@conns) {
	next if $seen{$_};
	$_->activate;
    }
}

sub activate_idles
{
    my $self = shift;
    my @iconns = @{$self->{idle_conns}};
    foreach (@iconns) {
	$_->activate;
    }
}

sub remove_from_refarray
{
    my($self, $arr, $ref) = @_;
    for my $i (0 .. @$arr - 1) {
	if (int($arr->[$i]) == int($ref)) {
	    splice(@$arr, $i, 1);
	    return 1;
	}
    }
    return 0;
}

sub connection_active
{
    my($self, $conn) = @_;
    print STDERR "ACTIVE $conn\n" if $DEBUG;
    $self->remove_from_refarray($self->{idle_conns}, $conn);
}


sub connection_idle
{
    my($self, $conn) = @_;
    print STDERR "IDLE $conn\n" if $DEBUG;
    if ($self->remove_from_refarray($self->{idle_conns}, $conn)) {
	warn "$conn was already in idle_conns";
    }
    push(@{$self->{idle_conns}}, $conn);
}

sub connection_closed
{
    my($self, $conn) = @_;
    print STDERR "CLOSED $conn\n" if $DEBUG;
    $self->remove_from_refarray($self->{idle_conns}, $conn);
    $self->remove_from_refarray($self->{conns}, $conn) or
	warn "$conn was not registered";

    unless (@{$self->{conns}}) {
	# This was the last connection
	if (@{$self->{req_queue}} && !$self->{stoppping}) {
	    $self->create_connection
	} else {
	    $self->done;
	}
    }
}

sub done  # this really just deallocates this LWP::Server entry
{
    my $self = shift;
    my $ua = delete $self->{'ua'};
    $ua->forget_server($self->id);
}

1;