view release on metacpan or  search on metacpan

lib/AnyEvent/HTTPD/HTTPConnection.pm  view on Meta::CPAN

package AnyEvent::HTTPD::HTTPConnection;
use common::sense;
use IO::Handle;
use AnyEvent::Handle;
use Object::Event;
use Time::Local;

use AnyEvent::HTTPD::Util;

use Scalar::Util qw/weaken/;
our @ISA = qw/Object::Event/;

=head1 NAME

AnyEvent::HTTPD::HTTPConnection - A simple HTTP connection for request and response handling

=head1 DESCRIPTION

This class is a helper class for L<AnyEvent:HTTPD::HTTPServer> and L<AnyEvent::HTTPD>,
it handles TCP reading and writing as well as parsing and serializing
http requests.

It has no public interface yet.

=head1 COPYRIGHT & LICENSE

Copyright 2008-2011 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

sub new {
   my $this  = shift;
   my $class = ref($this) || $this;
   my $self  = { @_ };
   bless $self, $class;

   $self->{request_timeout} = 60
      unless defined $self->{request_timeout};

   $self->{hdl} =
      AnyEvent::Handle->new (
         fh       => $self->{fh},
         on_eof   => sub { $self->do_disconnect },
         on_error => sub { $self->do_disconnect ("Error: $!") },
         ($self->{ssl}
            ? (tls => "accept", tls_ctx => $self->{ssl})
            : ()),
      );

   $self->push_header_line;

   return $self
}

sub error {
   my ($self, $code, $msg, $hdr, $content) = @_;

   if ($code !~ /^(1\d\d|204|304)$/o) {
      unless (defined $content) { $content = "$code $msg\n" }
      $hdr->{'Content-Type'} = 'text/plain';
   }

   $self->response ($code, $msg, $hdr, $content);
}

sub response_done {
   my ($self) = @_;

   (delete $self->{transfer_cb})->() if $self->{transfer_cb};

   # sometimes a response might be written after connection is already dead:
   return unless defined ($self->{hdl}) && !$self->{disconnected};

   $self->{hdl}->on_drain; # clear any drain handlers

   if ($self->{keep_alive}) {
      $self->push_header_line;

   } else {
      $self->{hdl}->on_drain (sub { $self->do_disconnect });
   }
}

our @DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
our @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
our %MoY;
@MoY{@MoY} = (1..12);

# Taken from HTTP::Date module of LWP.
sub _time_to_http_date
{
    my $time = shift;
    $time = time unless defined $time;

    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);

    sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
       $DoW[$wday],
       $mday, $MoY[$mon], $year + 1900,
       $hour, $min, $sec);
}


sub response {
   my ($self, $code, $msg, $hdr, $content, $no_body) = @_;
   return if $self->{disconnected};