--- /dev/null
+_______________________________________________________________________________
+2011-02-25 HTTP-Daemon 6.00
+
+Initial release of HTTP-Daemon as a separate distribution. There are no code
+changes besides incrementing the version number since libwww-perl-5.837.
+
+The HTTP::Daemon used to be bundled with the libwww-perl distribution.
--- /dev/null
+Changes
+lib/HTTP/Daemon.pm
+Makefile.PL
+MANIFEST This list of files
+README
+t/chunked.t
+t/local/http.t
+t/misc/httpd
+t/misc/httpd_term.pl
+t/robot/ua-get.t
+t/robot/ua.t
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+--- #YAML:1.0
+name: HTTP-Daemon
+version: 6.00
+abstract: a simple http server class
+author:
+ - Gisle Aas <gisle@activestate.com>
+license: perl
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ HTTP::Date: 6
+ HTTP::Request: 6
+ HTTP::Response: 6
+ HTTP::Status: 6
+ IO::Socket: 0
+ LWP::MediaTypes: 6
+ perl: 5.008008
+ Sys::Hostname: 0
+resources:
+ MailingList: mailto:libwww@perl.org
+ repository: http://github.com/gisle/libwww-perl
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.56
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
--- /dev/null
+#!perl -w
+
+require 5.008008;
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'HTTP::Daemon',
+ VERSION_FROM => 'lib/HTTP/Daemon.pm',
+ ABSTRACT_FROM => 'lib/HTTP/Daemon.pm',
+ AUTHOR => 'Gisle Aas <gisle@activestate.com>',
+ LICENSE => "perl",
+ MIN_PERL_VERSION => 5.008008,
+ PREREQ_PM => {
+ 'Sys::Hostname' => 0,
+ 'IO::Socket' => 0,
+ 'HTTP::Request' => 6,
+ 'HTTP::Response' => 6,
+ 'HTTP::Status' => 6,
+ 'HTTP::Date' => 6,
+ 'LWP::MediaTypes' => 6,
+ },
+ META_MERGE => {
+ resources => {
+ repository => 'http://github.com/gisle/libwww-perl',
+ MailingList => 'mailto:libwww@perl.org',
+ }
+ },
+);
+
+
+BEGIN {
+ # compatibility with older versions of MakeMaker
+ my $developer = -f ".gitignore";
+ my %mm_req = (
+ LICENCE => 6.31,
+ META_MERGE => 6.45,
+ META_ADD => 6.45,
+ MIN_PERL_VERSION => 6.48,
+ );
+ undef(*WriteMakefile);
+ *WriteMakefile = sub {
+ my %arg = @_;
+ for (keys %mm_req) {
+ unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) {
+ warn "$_ $@" if $developer;
+ delete $arg{$_};
+ }
+ }
+ ExtUtils::MakeMaker::WriteMakefile(%arg);
+ };
+}
--- /dev/null
+NAME
+ HTTP::Daemon - a simple http server class
+
+SYNOPSIS
+ use HTTP::Daemon;
+ use HTTP::Status;
+
+ my $d = HTTP::Daemon->new || die;
+ print "Please contact me at: <URL:", $d->url, ">\n";
+ while (my $c = $d->accept) {
+ while (my $r = $c->get_request) {
+ if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
+ # remember, this is *not* recommended practice :-)
+ $c->send_file_response("/etc/passwd");
+ }
+ else {
+ $c->send_error(RC_FORBIDDEN)
+ }
+ }
+ $c->close;
+ undef($c);
+ }
+
+DESCRIPTION
+ Instances of the `HTTP::Daemon' class are HTTP/1.1 servers that listen
+ on a socket for incoming requests. The `HTTP::Daemon' is a subclass of
+ `IO::Socket::INET', so you can perform socket operations directly on it
+ too.
+
+ The accept() method will return when a connection from a client is
+ available. The returned value will be an `HTTP::Daemon::ClientConn'
+ object which is another `IO::Socket::INET' subclass. Calling the
+ get_request() method on this object will read data from the client and
+ return an `HTTP::Request' object. The ClientConn object also provide
+ methods to send back various responses.
+
+ This HTTP daemon does not fork(2) for you. Your application, i.e. the
+ user of the `HTTP::Daemon' is responsible for forking if that is
+ desirable. Also note that the user is responsible for generating
+ responses that conform to the HTTP/1.1 protocol.
+
+ The following methods of `HTTP::Daemon' are new (or enhanced) relative
+ to the `IO::Socket::INET' base class:
+
+ $d = HTTP::Daemon->new
+ $d = HTTP::Daemon->new( %opts )
+ The constructor method takes the same arguments as the
+ `IO::Socket::INET' constructor, but unlike its base class it can
+ also be called without any arguments. The daemon will then set up a
+ listen queue of 5 connections and allocate some random port number.
+
+ A server that wants to bind to some specific address on the standard
+ HTTP port will be constructed like this:
+
+ $d = HTTP::Daemon->new(
+ LocalAddr => 'www.thisplace.com',
+ LocalPort => 80,
+ );
+
+ See IO::Socket::INET for a description of other arguments that can
+ be used configure the daemon during construction.
+
+ $c = $d->accept
+ $c = $d->accept( $pkg )
+ ($c, $peer_addr) = $d->accept
+ This method works the same the one provided by the base class, but
+ it returns an `HTTP::Daemon::ClientConn' reference by default. If a
+ package name is provided as argument, then the returned object will
+ be blessed into the given class. It is probably a good idea to make
+ that class a subclass of `HTTP::Daemon::ClientConn'.
+
+ The accept method will return `undef' if timeouts have been enabled
+ and no connection is made within the given time. The timeout()
+ method is described in IO::Socket.
+
+ In list context both the client object and the peer address will be
+ returned; see the description of the accept method IO::Socket for
+ details.
+
+ $d->url
+ Returns a URL string that can be used to access the server root.
+
+ $d->product_tokens
+ Returns the name that this server will use to identify itself. This
+ is the string that is sent with the `Server' response header. The
+ main reason to have this method is that subclasses can override it
+ if they want to use another product name.
+
+ The default is the string "libwww-perl-daemon/#.##" where "#.##" is
+ replaced with the version number of this module.
+
+ The `HTTP::Daemon::ClientConn' is a `IO::Socket::INET' subclass.
+ Instances of this class are returned by the accept() method of
+ `HTTP::Daemon'. The following methods are provided:
+
+ $c->get_request
+ $c->get_request( $headers_only )
+ This method reads data from the client and turns it into an
+ `HTTP::Request' object which is returned. It returns `undef' if
+ reading fails. If it fails, then the `HTTP::Daemon::ClientConn'
+ object ($c) should be discarded, and you should not try call this
+ method again on it. The $c->reason method might give you some
+ information about why $c->get_request failed.
+
+ The get_request() method will normally not return until the whole
+ request has been received from the client. This might not be what
+ you want if the request is an upload of a large file (and with
+ chunked transfer encoding HTTP can even support infinite request
+ messages - uploading live audio for instance). If you pass a TRUE
+ value as the $headers_only argument, then get_request() will return
+ immediately after parsing the request headers and you are
+ responsible for reading the rest of the request content. If you are
+ going to call $c->get_request again on the same connection you
+ better read the correct number of bytes.
+
+ $c->read_buffer
+ $c->read_buffer( $new_value )
+ Bytes read by $c->get_request, but not used are placed in the *read
+ buffer*. The next time $c->get_request is called it will consume the
+ bytes in this buffer before reading more data from the network
+ connection itself. The read buffer is invalid after $c->get_request
+ has failed.
+
+ If you handle the reading of the request content yourself you need
+ to empty this buffer before you read more and you need to place
+ unconsumed bytes here. You also need this buffer if you implement
+ services like *101 Switching Protocols*.
+
+ This method always returns the old buffer content and can optionally
+ replace the buffer content if you pass it an argument.
+
+ $c->reason
+ When $c->get_request returns `undef' you can obtain a short string
+ describing why it happened by calling $c->reason.
+
+ $c->proto_ge( $proto )
+ Return TRUE if the client announced a protocol with version number
+ greater or equal to the given argument. The $proto argument can be a
+ string like "HTTP/1.1" or just "1.1".
+
+ $c->antique_client
+ Return TRUE if the client speaks the HTTP/0.9 protocol. No status
+ code and no headers should be returned to such a client. This should
+ be the same as !$c->proto_ge("HTTP/1.0").
+
+ $c->head_request
+ Return TRUE if the last request was a `HEAD' request. No content
+ body must be generated for these requests.
+
+ $c->force_last_request
+ Make sure that $c->get_request will not try to read more requests
+ off this connection. If you generate a response that is not self
+ delimiting, then you should signal this fact by calling this method.
+
+ This attribute is turned on automatically if the client announces
+ protocol HTTP/1.0 or worse and does not include a "Connection:
+ Keep-Alive" header. It is also turned on automatically when HTTP/1.1
+ or better clients send the "Connection: close" request header.
+
+ $c->send_status_line
+ $c->send_status_line( $code )
+ $c->send_status_line( $code, $mess )
+ $c->send_status_line( $code, $mess, $proto )
+ Send the status line back to the client. If $code is omitted 200 is
+ assumed. If $mess is omitted, then a message corresponding to $code
+ is inserted. If $proto is missing the content of the
+ $HTTP::Daemon::PROTO variable is used.
+
+ $c->send_crlf
+ Send the CRLF sequence to the client.
+
+ $c->send_basic_header
+ $c->send_basic_header( $code )
+ $c->send_basic_header( $code, $mess )
+ $c->send_basic_header( $code, $mess, $proto )
+ Send the status line and the "Date:" and "Server:" headers back to
+ the client. This header is assumed to be continued and does not end
+ with an empty CRLF line.
+
+ See the description of send_status_line() for the description of the
+ accepted arguments.
+
+ $c->send_header( $field, $value )
+ $c->send_header( $field1, $value1, $field2, $value2, ... )
+ Send one or more header lines.
+
+ $c->send_response( $res )
+ Write a `HTTP::Response' object to the client as a response. We try
+ hard to make sure that the response is self delimiting so that the
+ connection can stay persistent for further request/response
+ exchanges.
+
+ The content attribute of the `HTTP::Response' object can be a normal
+ string or a subroutine reference. If it is a subroutine, then
+ whatever this callback routine returns is written back to the client
+ as the response content. The routine will be called until it return
+ an undefined or empty value. If the client is HTTP/1.1 aware then we
+ will use chunked transfer encoding for the response.
+
+ $c->send_redirect( $loc )
+ $c->send_redirect( $loc, $code )
+ $c->send_redirect( $loc, $code, $entity_body )
+ Send a redirect response back to the client. The location ($loc) can
+ be an absolute or relative URL. The $code must be one the redirect
+ status codes, and defaults to "301 Moved Permanently"
+
+ $c->send_error
+ $c->send_error( $code )
+ $c->send_error( $code, $error_message )
+ Send an error response back to the client. If the $code is missing a
+ "Bad Request" error is reported. The $error_message is a string that
+ is incorporated in the body of the HTML entity body.
+
+ $c->send_file_response( $filename )
+ Send back a response with the specified $filename as content. If the
+ file is a directory we try to generate an HTML index of it.
+
+ $c->send_file( $filename )
+ $c->send_file( $fd )
+ Copy the file to the client. The file can be a string (which will be
+ interpreted as a filename) or a reference to an `IO::Handle' or
+ glob.
+
+ $c->daemon
+ Return a reference to the corresponding `HTTP::Daemon' object.
+
+SEE ALSO
+ RFC 2616
+
+ IO::Socket::INET, IO::Socket
+
+COPYRIGHT
+ Copyright 1996-2003, Gisle Aas
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
--- /dev/null
+package HTTP::Daemon;
+
+use strict;
+use vars qw($VERSION @ISA $PROTO $DEBUG);
+
+$VERSION = "6.00";
+
+use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
+@ISA=qw(IO::Socket::INET);
+
+$PROTO = "HTTP/1.1";
+
+
+sub new
+{
+ my($class, %args) = @_;
+ $args{Listen} ||= 5;
+ $args{Proto} ||= 'tcp';
+ return $class->SUPER::new(%args);
+}
+
+
+sub accept
+{
+ my $self = shift;
+ my $pkg = shift || "HTTP::Daemon::ClientConn";
+ my ($sock, $peer) = $self->SUPER::accept($pkg);
+ if ($sock) {
+ ${*$sock}{'httpd_daemon'} = $self;
+ return wantarray ? ($sock, $peer) : $sock;
+ }
+ else {
+ return;
+ }
+}
+
+
+sub url
+{
+ my $self = shift;
+ my $url = $self->_default_scheme . "://";
+ my $addr = $self->sockaddr;
+ if (!$addr || $addr eq INADDR_ANY) {
+ require Sys::Hostname;
+ $url .= lc Sys::Hostname::hostname();
+ }
+ else {
+ $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
+ }
+ my $port = $self->sockport;
+ $url .= ":$port" if $port != $self->_default_port;
+ $url .= "/";
+ $url;
+}
+
+
+sub _default_port {
+ 80;
+}
+
+
+sub _default_scheme {
+ "http";
+}
+
+
+sub product_tokens
+{
+ "libwww-perl-daemon/$HTTP::Daemon::VERSION";
+}
+
+
+
+package HTTP::Daemon::ClientConn;
+
+use vars qw(@ISA $DEBUG);
+use IO::Socket ();
+@ISA=qw(IO::Socket::INET);
+*DEBUG = \$HTTP::Daemon::DEBUG;
+
+use HTTP::Request ();
+use HTTP::Response ();
+use HTTP::Status;
+use HTTP::Date qw(time2str);
+use LWP::MediaTypes qw(guess_media_type);
+use Carp ();
+
+my $CRLF = "\015\012"; # "\r\n" is not portable
+my $HTTP_1_0 = _http_version("HTTP/1.0");
+my $HTTP_1_1 = _http_version("HTTP/1.1");
+
+
+sub get_request
+{
+ my($self, $only_headers) = @_;
+ if (${*$self}{'httpd_nomore'}) {
+ $self->reason("No more requests from this connection");
+ return;
+ }
+
+ $self->reason("");
+ my $buf = ${*$self}{'httpd_rbuf'};
+ $buf = "" unless defined $buf;
+
+ my $timeout = $ {*$self}{'io_socket_timeout'};
+ my $fdset = "";
+ vec($fdset, $self->fileno, 1) = 1;
+ local($_);
+
+ READ_HEADER:
+ while (1) {
+ # loop until we have the whole header in $buf
+ $buf =~ s/^(?:\015?\012)+//; # ignore leading blank lines
+ if ($buf =~ /\012/) { # potential, has at least one line
+ if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
+ if ($buf =~ /\015?\012\015?\012/) {
+ last READ_HEADER; # we have it
+ }
+ elsif (length($buf) > 16*1024) {
+ $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
+ $self->reason("Very long header");
+ return;
+ }
+ }
+ else {
+ last READ_HEADER; # HTTP/0.9 client
+ }
+ }
+ elsif (length($buf) > 16*1024) {
+ $self->send_error(414); # REQUEST_URI_TOO_LARGE
+ $self->reason("Very long first line");
+ return;
+ }
+ print STDERR "Need more data for complete header\n" if $DEBUG;
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
+ ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
+ $self->send_error(400); # BAD_REQUEST
+ $self->reason("Bad request line: $buf");
+ return;
+ }
+ my $method = $1;
+ my $uri = $2;
+ my $proto = $3 || "HTTP/0.9";
+ $uri = "http://$uri" if $method eq "CONNECT";
+ $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
+ my $r = HTTP::Request->new($method, $uri);
+ $r->protocol($proto);
+ ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
+ ${*$self}{'httpd_head'} = ($method eq "HEAD");
+
+ if ($proto >= $HTTP_1_0) {
+ # we expect to find some headers
+ my($key, $val);
+ HEADER:
+ while ($buf =~ s/^([^\012]*)\012//) {
+ $_ = $1;
+ s/\015$//;
+ if (/^([^:\s]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ else {
+ last HEADER;
+ }
+ }
+ $r->push_header($key, $val) if $key;
+ }
+
+ my $conn = $r->header('Connection');
+ if ($proto >= $HTTP_1_1) {
+ ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
+ }
+ else {
+ ${*$self}{'httpd_nomore'}++ unless $conn &&
+ lc($conn) =~ /\bkeep-alive\b/;
+ }
+
+ if ($only_headers) {
+ ${*$self}{'httpd_rbuf'} = $buf;
+ return $r;
+ }
+
+ # Find out how much content to read
+ my $te = $r->header('Transfer-Encoding');
+ my $ct = $r->header('Content-Type');
+ my $len = $r->header('Content-Length');
+
+ # Act on the Expect header, if it's there
+ for my $e ( $r->header('Expect') ) {
+ if( lc($e) eq '100-continue' ) {
+ $self->send_status_line(100);
+ $self->send_crlf;
+ }
+ else {
+ $self->send_error(417);
+ $self->reason("Unsupported Expect header value");
+ return;
+ }
+ }
+
+ if ($te && lc($te) eq 'chunked') {
+ # Handle chunked transfer encoding
+ my $body = "";
+ CHUNK:
+ while (1) {
+ print STDERR "Chunked\n" if $DEBUG;
+ if ($buf =~ s/^([^\012]*)\012//) {
+ my $chunk_head = $1;
+ unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
+ $self->send_error(400);
+ $self->reason("Bad chunk header $chunk_head");
+ return;
+ }
+ my $size = hex($1);
+ last CHUNK if $size == 0;
+
+ my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
+ # must read until we have a complete chunk
+ while ($missing > 0) {
+ print STDERR "Need $missing more bytes\n" if $DEBUG;
+ my $n = $self->_need_more($buf, $timeout, $fdset);
+ return unless $n;
+ $missing -= $n;
+ }
+ $body .= substr($buf, 0, $size);
+ substr($buf, 0, $size+2) = '';
+
+ }
+ else {
+ # need more data in order to have a complete chunk header
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ }
+ $r->content($body);
+
+ # pretend it was a normal entity body
+ $r->remove_header('Transfer-Encoding');
+ $r->header('Content-Length', length($body));
+
+ my($key, $val);
+ FOOTER:
+ while (1) {
+ if ($buf !~ /\012/) {
+ # need at least one line to look at
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ else {
+ $buf =~ s/^([^\012]*)\012//;
+ $_ = $1;
+ s/\015$//;
+ if (/^([\w\-]+)\s*:\s*(.*)/) {
+ $r->push_header($key, $val) if $key;
+ ($key, $val) = ($1, $2);
+ }
+ elsif (/^\s+(.*)/) {
+ $val .= " $1";
+ }
+ elsif (!length) {
+ last FOOTER;
+ }
+ else {
+ $self->reason("Bad footer syntax");
+ return;
+ }
+ }
+ }
+ $r->push_header($key, $val) if $key;
+
+ }
+ elsif ($te) {
+ $self->send_error(501); # Unknown transfer encoding
+ $self->reason("Unknown transfer encoding '$te'");
+ return;
+
+ }
+ elsif ($len) {
+ # Plain body specified by "Content-Length"
+ my $missing = $len - length($buf);
+ while ($missing > 0) {
+ print "Need $missing more bytes of content\n" if $DEBUG;
+ my $n = $self->_need_more($buf, $timeout, $fdset);
+ return unless $n;
+ $missing -= $n;
+ }
+ if (length($buf) > $len) {
+ $r->content(substr($buf,0,$len));
+ substr($buf, 0, $len) = '';
+ }
+ else {
+ $r->content($buf);
+ $buf='';
+ }
+ }
+ elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
+ # Handle multipart content type
+ my $boundary = "$CRLF--$2--";
+ my $index;
+ while (1) {
+ $index = index($buf, $boundary);
+ last if $index >= 0;
+ # end marker not yet found
+ return unless $self->_need_more($buf, $timeout, $fdset);
+ }
+ $index += length($boundary);
+ $r->content(substr($buf, 0, $index));
+ substr($buf, 0, $index) = '';
+
+ }
+ ${*$self}{'httpd_rbuf'} = $buf;
+
+ $r;
+}
+
+
+sub _need_more
+{
+ my $self = shift;
+ #my($buf,$timeout,$fdset) = @_;
+ if ($_[1]) {
+ my($timeout, $fdset) = @_[1,2];
+ print STDERR "select(,,,$timeout)\n" if $DEBUG;
+ my $n = select($fdset,undef,undef,$timeout);
+ unless ($n) {
+ $self->reason(defined($n) ? "Timeout" : "select: $!");
+ return;
+ }
+ }
+ print STDERR "sysread()\n" if $DEBUG;
+ my $n = sysread($self, $_[0], 2048, length($_[0]));
+ $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
+ $n;
+}
+
+
+sub read_buffer
+{
+ my $self = shift;
+ my $old = ${*$self}{'httpd_rbuf'};
+ if (@_) {
+ ${*$self}{'httpd_rbuf'} = shift;
+ }
+ $old;
+}
+
+
+sub reason
+{
+ my $self = shift;
+ my $old = ${*$self}{'httpd_reason'};
+ if (@_) {
+ ${*$self}{'httpd_reason'} = shift;
+ }
+ $old;
+}
+
+
+sub proto_ge
+{
+ my $self = shift;
+ ${*$self}{'httpd_client_proto'} >= _http_version(shift);
+}
+
+
+sub _http_version
+{
+ local($_) = shift;
+ return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
+ $1 * 1000 + $2;
+}
+
+
+sub antique_client
+{
+ my $self = shift;
+ ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
+}
+
+
+sub force_last_request
+{
+ my $self = shift;
+ ${*$self}{'httpd_nomore'}++;
+}
+
+sub head_request
+{
+ my $self = shift;
+ ${*$self}{'httpd_head'};
+}
+
+
+sub send_status_line
+{
+ my($self, $status, $message, $proto) = @_;
+ return if $self->antique_client;
+ $status ||= RC_OK;
+ $message ||= status_message($status) || "";
+ $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
+ print $self "$proto $status $message$CRLF";
+}
+
+
+sub send_crlf
+{
+ my $self = shift;
+ print $self $CRLF;
+}
+
+
+sub send_basic_header
+{
+ my $self = shift;
+ return if $self->antique_client;
+ $self->send_status_line(@_);
+ print $self "Date: ", time2str(time), $CRLF;
+ my $product = $self->daemon->product_tokens;
+ print $self "Server: $product$CRLF" if $product;
+}
+
+
+sub send_header
+{
+ my $self = shift;
+ while (@_) {
+ my($k, $v) = splice(@_, 0, 2);
+ $v = "" unless defined($v);
+ print $self "$k: $v$CRLF";
+ }
+}
+
+
+sub send_response
+{
+ my $self = shift;
+ my $res = shift;
+ if (!ref $res) {
+ $res ||= RC_OK;
+ $res = HTTP::Response->new($res, @_);
+ }
+ my $content = $res->content;
+ my $chunked;
+ unless ($self->antique_client) {
+ my $code = $res->code;
+ $self->send_basic_header($code, $res->message, $res->protocol);
+ if ($code =~ /^(1\d\d|[23]04)$/) {
+ # make sure content is empty
+ $res->remove_header("Content-Length");
+ $content = "";
+ }
+ elsif ($res->request && $res->request->method eq "HEAD") {
+ # probably OK
+ }
+ elsif (ref($content) eq "CODE") {
+ if ($self->proto_ge("HTTP/1.1")) {
+ $res->push_header("Transfer-Encoding" => "chunked");
+ $chunked++;
+ }
+ else {
+ $self->force_last_request;
+ }
+ }
+ elsif (length($content)) {
+ $res->header("Content-Length" => length($content));
+ }
+ else {
+ $self->force_last_request;
+ $res->header('connection','close');
+ }
+ print $self $res->headers_as_string($CRLF);
+ print $self $CRLF; # separates headers and content
+ }
+ if ($self->head_request) {
+ # no content
+ }
+ elsif (ref($content) eq "CODE") {
+ while (1) {
+ my $chunk = &$content();
+ last unless defined($chunk) && length($chunk);
+ if ($chunked) {
+ printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
+ }
+ else {
+ print $self $chunk;
+ }
+ }
+ print $self "0$CRLF$CRLF" if $chunked; # no trailers either
+ }
+ elsif (length $content) {
+ print $self $content;
+ }
+}
+
+
+sub send_redirect
+{
+ my($self, $loc, $status, $content) = @_;
+ $status ||= RC_MOVED_PERMANENTLY;
+ Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
+ $self->send_basic_header($status);
+ my $base = $self->daemon->url;
+ $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
+ $loc = $loc->abs($base);
+ print $self "Location: $loc$CRLF";
+ if ($content) {
+ my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
+ print $self "Content-Type: $ct$CRLF";
+ }
+ print $self $CRLF;
+ print $self $content if $content && !$self->head_request;
+ $self->force_last_request; # no use keeping the connection open
+}
+
+
+sub send_error
+{
+ my($self, $status, $error) = @_;
+ $status ||= RC_BAD_REQUEST;
+ Carp::croak("Status '$status' is not an error") unless is_error($status);
+ my $mess = status_message($status);
+ $error ||= "";
+ $mess = <<EOT;
+<title>$status $mess</title>
+<h1>$status $mess</h1>
+$error
+EOT
+ unless ($self->antique_client) {
+ $self->send_basic_header($status);
+ print $self "Content-Type: text/html$CRLF";
+ print $self "Content-Length: " . length($mess) . $CRLF;
+ print $self $CRLF;
+ }
+ print $self $mess unless $self->head_request;
+ $status;
+}
+
+
+sub send_file_response
+{
+ my($self, $file) = @_;
+ if (-d $file) {
+ $self->send_dir($file);
+ }
+ elsif (-f _) {
+ # plain file
+ local(*F);
+ sysopen(F, $file, 0) or
+ return $self->send_error(RC_FORBIDDEN);
+ binmode(F);
+ my($ct,$ce) = guess_media_type($file);
+ my($size,$mtime) = (stat _)[7,9];
+ unless ($self->antique_client) {
+ $self->send_basic_header;
+ print $self "Content-Type: $ct$CRLF";
+ print $self "Content-Encoding: $ce$CRLF" if $ce;
+ print $self "Content-Length: $size$CRLF" if $size;
+ print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
+ print $self $CRLF;
+ }
+ $self->send_file(\*F) unless $self->head_request;
+ return RC_OK;
+ }
+ else {
+ $self->send_error(RC_NOT_FOUND);
+ }
+}
+
+
+sub send_dir
+{
+ my($self, $dir) = @_;
+ $self->send_error(RC_NOT_FOUND) unless -d $dir;
+ $self->send_error(RC_NOT_IMPLEMENTED);
+}
+
+
+sub send_file
+{
+ my($self, $file) = @_;
+ my $opened = 0;
+ local(*FILE);
+ if (!ref($file)) {
+ open(FILE, $file) || return undef;
+ binmode(FILE);
+ $file = \*FILE;
+ $opened++;
+ }
+ my $cnt = 0;
+ my $buf = "";
+ my $n;
+ while ($n = sysread($file, $buf, 8*1024)) {
+ last if !$n;
+ $cnt += $n;
+ print $self $buf;
+ }
+ close($file) if $opened;
+ $cnt;
+}
+
+
+sub daemon
+{
+ my $self = shift;
+ ${*$self}{'httpd_daemon'};
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Daemon - a simple http server class
+
+=head1 SYNOPSIS
+
+ use HTTP::Daemon;
+ use HTTP::Status;
+
+ my $d = HTTP::Daemon->new || die;
+ print "Please contact me at: <URL:", $d->url, ">\n";
+ while (my $c = $d->accept) {
+ while (my $r = $c->get_request) {
+ if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
+ # remember, this is *not* recommended practice :-)
+ $c->send_file_response("/etc/passwd");
+ }
+ else {
+ $c->send_error(RC_FORBIDDEN)
+ }
+ }
+ $c->close;
+ undef($c);
+ }
+
+=head1 DESCRIPTION
+
+Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
+listen on a socket for incoming requests. The C<HTTP::Daemon> is a
+subclass of C<IO::Socket::INET>, so you can perform socket operations
+directly on it too.
+
+The accept() method will return when a connection from a client is
+available. The returned value will be an C<HTTP::Daemon::ClientConn>
+object which is another C<IO::Socket::INET> subclass. Calling the
+get_request() method on this object will read data from the client and
+return an C<HTTP::Request> object. The ClientConn object also provide
+methods to send back various responses.
+
+This HTTP daemon does not fork(2) for you. Your application, i.e. the
+user of the C<HTTP::Daemon> is responsible for forking if that is
+desirable. Also note that the user is responsible for generating
+responses that conform to the HTTP/1.1 protocol.
+
+The following methods of C<HTTP::Daemon> are new (or enhanced) relative
+to the C<IO::Socket::INET> base class:
+
+=over 4
+
+=item $d = HTTP::Daemon->new
+
+=item $d = HTTP::Daemon->new( %opts )
+
+The constructor method takes the same arguments as the
+C<IO::Socket::INET> constructor, but unlike its base class it can also
+be called without any arguments. The daemon will then set up a listen
+queue of 5 connections and allocate some random port number.
+
+A server that wants to bind to some specific address on the standard
+HTTP port will be constructed like this:
+
+ $d = HTTP::Daemon->new(
+ LocalAddr => 'www.thisplace.com',
+ LocalPort => 80,
+ );
+
+See L<IO::Socket::INET> for a description of other arguments that can
+be used configure the daemon during construction.
+
+=item $c = $d->accept
+
+=item $c = $d->accept( $pkg )
+
+=item ($c, $peer_addr) = $d->accept
+
+This method works the same the one provided by the base class, but it
+returns an C<HTTP::Daemon::ClientConn> reference by default. If a
+package name is provided as argument, then the returned object will be
+blessed into the given class. It is probably a good idea to make that
+class a subclass of C<HTTP::Daemon::ClientConn>.
+
+The accept method will return C<undef> if timeouts have been enabled
+and no connection is made within the given time. The timeout() method
+is described in L<IO::Socket>.
+
+In list context both the client object and the peer address will be
+returned; see the description of the accept method L<IO::Socket> for
+details.
+
+=item $d->url
+
+Returns a URL string that can be used to access the server root.
+
+=item $d->product_tokens
+
+Returns the name that this server will use to identify itself. This
+is the string that is sent with the C<Server> response header. The
+main reason to have this method is that subclasses can override it if
+they want to use another product name.
+
+The default is the string "libwww-perl-daemon/#.##" where "#.##" is
+replaced with the version number of this module.
+
+=back
+
+The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
+subclass. Instances of this class are returned by the accept() method
+of C<HTTP::Daemon>. The following methods are provided:
+
+=over 4
+
+=item $c->get_request
+
+=item $c->get_request( $headers_only )
+
+This method reads data from the client and turns it into an
+C<HTTP::Request> object which is returned. It returns C<undef>
+if reading fails. If it fails, then the C<HTTP::Daemon::ClientConn>
+object ($c) should be discarded, and you should not try call this
+method again on it. The $c->reason method might give you some
+information about why $c->get_request failed.
+
+The get_request() method will normally not return until the whole
+request has been received from the client. This might not be what you
+want if the request is an upload of a large file (and with chunked
+transfer encoding HTTP can even support infinite request messages -
+uploading live audio for instance). If you pass a TRUE value as the
+$headers_only argument, then get_request() will return immediately
+after parsing the request headers and you are responsible for reading
+the rest of the request content. If you are going to call
+$c->get_request again on the same connection you better read the
+correct number of bytes.
+
+=item $c->read_buffer
+
+=item $c->read_buffer( $new_value )
+
+Bytes read by $c->get_request, but not used are placed in the I<read
+buffer>. The next time $c->get_request is called it will consume the
+bytes in this buffer before reading more data from the network
+connection itself. The read buffer is invalid after $c->get_request
+has failed.
+
+If you handle the reading of the request content yourself you need to
+empty this buffer before you read more and you need to place
+unconsumed bytes here. You also need this buffer if you implement
+services like I<101 Switching Protocols>.
+
+This method always returns the old buffer content and can optionally
+replace the buffer content if you pass it an argument.
+
+=item $c->reason
+
+When $c->get_request returns C<undef> you can obtain a short string
+describing why it happened by calling $c->reason.
+
+=item $c->proto_ge( $proto )
+
+Return TRUE if the client announced a protocol with version number
+greater or equal to the given argument. The $proto argument can be a
+string like "HTTP/1.1" or just "1.1".
+
+=item $c->antique_client
+
+Return TRUE if the client speaks the HTTP/0.9 protocol. No status
+code and no headers should be returned to such a client. This should
+be the same as !$c->proto_ge("HTTP/1.0").
+
+=item $c->head_request
+
+Return TRUE if the last request was a C<HEAD> request. No content
+body must be generated for these requests.
+
+=item $c->force_last_request
+
+Make sure that $c->get_request will not try to read more requests off
+this connection. If you generate a response that is not self
+delimiting, then you should signal this fact by calling this method.
+
+This attribute is turned on automatically if the client announces
+protocol HTTP/1.0 or worse and does not include a "Connection:
+Keep-Alive" header. It is also turned on automatically when HTTP/1.1
+or better clients send the "Connection: close" request header.
+
+=item $c->send_status_line
+
+=item $c->send_status_line( $code )
+
+=item $c->send_status_line( $code, $mess )
+
+=item $c->send_status_line( $code, $mess, $proto )
+
+Send the status line back to the client. If $code is omitted 200 is
+assumed. If $mess is omitted, then a message corresponding to $code
+is inserted. If $proto is missing the content of the
+$HTTP::Daemon::PROTO variable is used.
+
+=item $c->send_crlf
+
+Send the CRLF sequence to the client.
+
+=item $c->send_basic_header
+
+=item $c->send_basic_header( $code )
+
+=item $c->send_basic_header( $code, $mess )
+
+=item $c->send_basic_header( $code, $mess, $proto )
+
+Send the status line and the "Date:" and "Server:" headers back to
+the client. This header is assumed to be continued and does not end
+with an empty CRLF line.
+
+See the description of send_status_line() for the description of the
+accepted arguments.
+
+=item $c->send_header( $field, $value )
+
+=item $c->send_header( $field1, $value1, $field2, $value2, ... )
+
+Send one or more header lines.
+
+=item $c->send_response( $res )
+
+Write a C<HTTP::Response> object to the
+client as a response. We try hard to make sure that the response is
+self delimiting so that the connection can stay persistent for further
+request/response exchanges.
+
+The content attribute of the C<HTTP::Response> object can be a normal
+string or a subroutine reference. If it is a subroutine, then
+whatever this callback routine returns is written back to the
+client as the response content. The routine will be called until it
+return an undefined or empty value. If the client is HTTP/1.1 aware
+then we will use chunked transfer encoding for the response.
+
+=item $c->send_redirect( $loc )
+
+=item $c->send_redirect( $loc, $code )
+
+=item $c->send_redirect( $loc, $code, $entity_body )
+
+Send a redirect response back to the client. The location ($loc) can
+be an absolute or relative URL. The $code must be one the redirect
+status codes, and defaults to "301 Moved Permanently"
+
+=item $c->send_error
+
+=item $c->send_error( $code )
+
+=item $c->send_error( $code, $error_message )
+
+Send an error response back to the client. If the $code is missing a
+"Bad Request" error is reported. The $error_message is a string that
+is incorporated in the body of the HTML entity body.
+
+=item $c->send_file_response( $filename )
+
+Send back a response with the specified $filename as content. If the
+file is a directory we try to generate an HTML index of it.
+
+=item $c->send_file( $filename )
+
+=item $c->send_file( $fd )
+
+Copy the file to the client. The file can be a string (which
+will be interpreted as a filename) or a reference to an C<IO::Handle>
+or glob.
+
+=item $c->daemon
+
+Return a reference to the corresponding C<HTTP::Daemon> object.
+
+=back
+
+=head1 SEE ALSO
+
+RFC 2616
+
+L<IO::Socket::INET>, L<IO::Socket>
+
+=head1 COPYRIGHT
+
+Copyright 1996-2003, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Config;
+use HTTP::Daemon;
+use Test::More;
+# use Time::HiRes qw(sleep);
+our $CRLF;
+use Socket qw($CRLF);
+
+our $LOGGING = 0;
+
+our @TESTS = (
+ {
+ expect => 629,
+ comment => "traditional, unchunked POST request",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 629
+Host: localhost
+
+JSR-205=0;font_small=15;png=1;jpg=1;alpha_channel=256;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;pointer_motion_event=0;camera=1;free_memory=455472;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;color=65536;JSR-120=1;JSR-184=1;JSR-180=0;JSR-75-file=0;push_socket=0;pointer_event=0;nokia-ui=1;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;gif=1;midp=MIDP-1.0 MIDP-2.0;font_large=22;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;"
+ },
+ {
+ expect => 8,
+ comment => "chunked with illegal Content-Length header; tiny message",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+Host: localhost
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 8
+Transfer-Encoding: chunked
+
+8
+icm.x=u2
+0
+
+",
+ },
+ {
+ expect => 868,
+ comment => "chunked with illegal Content-Length header; medium sized",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+Host:dev05
+Connection:close
+Content-Type:application/x-www-form-urlencoded
+Content-Length:868
+transfer-encoding:chunked
+
+364
+JSR-205=0;font_small=20;png=1;jpg=1;JSR-82=0;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;free_memory=733456;user_agent=xxxxxxxxx/xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=815080;cldc=CLDC-1.0;canvas_size_y=182;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=20;JSR-184=0;JSR-120=1;color=32768;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=22;NAVIGATION RIGHT=5;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=0;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;gif=1;KEY NUM 4=52;NAVIGATION UP=1;KEY NUM 3=51;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-2.0 VSCL-1.1.0;font_large=20;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=2;LEFT SOFT KEY=21;font_medium=20;fullscreen_canvas_size_y=204;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=6;java_locale=en-DE;
+0
+
+",
+ },
+ {
+ expect => 1104,
+ comment => "chunked correctly, size ~1k; base for the big next test",
+ raw => "POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Host: localhost:80
+Transfer-Encoding: chunked
+
+450
+JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
+0
+
+"
+ },
+ {
+ expect => 1104*1024,
+ comment => "chunked with many chunks",
+ raw => ("POST /cgi-bin/redir-TE.pl HTTP/1.1
+User-Agent: UNTRUSTED/1.0
+Content-Type: application/x-www-form-urlencoded
+Host: localhost:80
+Transfer-Encoding: chunked
+
+".("450
+JSR-205=0;font_small=15;png=1;jpg=1;jsr184_dithering=0;CLEAR/DELETE=-8;JSR-82=0;alpha_channel=32;JSR-135=1;mot-wt=0;JSR-75-pim=0;http=1;pointer_motion_event=0;browser_launch=1;BACK/RETURN=-11;camera=1;free_memory=456248;user_agent=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx;heap_size=524284;cldc=CLDC-1.1;canvas_size_y=176;canvas_size_x=176;double_buffered=1;NAVIGATION PRESS=-5;JSR-184=1;JSR-120=1;color=65536;JSR-180=0;JSR-75-file=0;RIGHT SOFT KEY=-7;NAVIGATION RIGHT=-4;KEY *=42;push_socket=0;pointer_event=0;KEY #=35;KEY NUM 9=57;nokia-ui=1;KEY NUM 8=56;KEY NUM 7=55;KEY NUM 6=54;KEY NUM 5=53;java_platform=xxxxxxxxxxxxxxxxx/xxxxxxx;KEY NUM 4=52;gif=1;KEY NUM 3=51;NAVIGATION UP=-1;KEY NUM 2=50;KEY NUM 1=49;midp=MIDP-1.0 MIDP-2.0;font_large=22;KEY NUM 0=48;sie-col-game=0;JSR-179=0;push_sms=1;JSR-172=0;NAVIGATION LEFT=-3;LEFT SOFT KEY=-6;jsr184_antialiasing=0;font_medium=18;fullscreen_canvas_size_y=220;fullscreen_canvas_size_x=176;https=1;NAVIGATION DOWN=-2;java_locale=de;video_encoding=encoding=JPEG&width=176&height=182encoding=JPEG&width=176&height=220;
+"x1024)."0
+
+")
+ },
+ );
+
+
+my $can_fork = $Config{d_fork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config{useithreads} and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+my $tests = @TESTS;
+my $tport = 8333;
+
+my $tsock = IO::Socket::INET->new(LocalAddr => '0.0.0.0',
+ LocalPort => $tport,
+ Listen => 1,
+ ReuseAddr => 1);
+if (!$can_fork) {
+ plan skip_all => "This system cannot fork";
+}
+elsif (!$tsock) {
+ plan skip_all => "Cannot listen on 0.0.0.0:$tport";
+}
+else {
+ close $tsock;
+ plan tests => $tests;
+}
+
+sub mywarn ($) {
+ return unless $LOGGING;
+ my($mess) = @_;
+ open my $fh, ">>", "http-daemon.out"
+ or die $!;
+ my $ts = localtime;
+ print $fh "$ts: $mess\n";
+ close $fh or die $!;
+}
+
+
+my $pid;
+if ($pid = fork) {
+ sleep 4;
+ for my $t (0..$#TESTS) {
+ my $test = $TESTS[$t];
+ my $raw = $test->{raw};
+ $raw =~ s/\r?\n/$CRLF/mg;
+ if (0) {
+ open my $fh, "| socket localhost $tport" or die;
+ print $fh $test;
+ }
+ use IO::Socket::INET;
+ my $sock = IO::Socket::INET->new(
+ PeerAddr => "127.0.0.1",
+ PeerPort => $tport,
+ ) or die;
+ if (0) {
+ for my $pos (0..length($raw)-1) {
+ print $sock substr($raw,$pos,1);
+ sleep 0.001;
+ }
+ } else {
+ print $sock $raw;
+ }
+ local $/;
+ my $resp = <$sock>;
+ close $sock;
+ my($got) = $resp =~ /\r?\n\r?\n(\d+)/s;
+ is($got,
+ $test->{expect},
+ "[$test->{expect}] $test->{comment}",
+ );
+ }
+ wait;
+} else {
+ die "cannot fork: $!" unless defined $pid;
+ my $d = HTTP::Daemon->new(
+ LocalAddr => '0.0.0.0',
+ LocalPort => $tport,
+ ReuseAddr => 1,
+ ) or die;
+ mywarn "Starting new daemon as '$$'";
+ my $i;
+ LISTEN: while (my $c = $d->accept) {
+ my $r = $c->get_request;
+ mywarn sprintf "headers[%s] content[%s]", $r->headers->as_string, $r->content;
+ my $res = HTTP::Response->new(200,undef,undef,length($r->content).$CRLF);
+ $c->send_response($res);
+ $c->force_last_request; # we're just not mature enough
+ $c->close;
+ undef($c);
+ last if ++$i >= $tests;
+ }
+}
+
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 2
+# End:
--- /dev/null
+if ($^O eq "MacOS") {
+ print "1..0\n";
+ exit(0);
+}
+
+unless (-f "CAN_TALK_TO_OURSELF") {
+ print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
+ exit;
+}
+
+$| = 1; # autoflush
+
+require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
+
+# First we make ourself a daemon in another process
+my $D = shift || '';
+if ($D eq 'daemon') {
+
+ require HTTP::Daemon;
+
+ my $d = HTTP::Daemon->new(Timeout => 10);
+
+ print "Please to meet you at: <URL:", $d->url, ">\n";
+ open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
+
+ while ($c = $d->accept) {
+ $r = $c->get_request;
+ if ($r) {
+ my $p = ($r->uri->path_segments)[1];
+ my $func = lc("httpd_" . $r->method . "_$p");
+ if (defined &$func) {
+ &$func($c, $r);
+ }
+ else {
+ $c->send_error(404);
+ }
+ }
+ $c = undef; # close connection
+ }
+ print STDERR "HTTP Server terminated\n";
+ exit;
+}
+else {
+ use Config;
+ my $perl = $Config{'perlpath'};
+ $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+ open(DAEMON, "$perl local/http.t daemon |") or die "Can't exec daemon: $!";
+}
+
+use Test;
+plan tests => 54;
+
+my $greeting = <DAEMON>;
+$greeting =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+sub url {
+ my $u = URI->new(@_);
+ $u = $u->abs($_[1]) if @_ > 1;
+ $u->as_string;
+}
+
+print "Will access HTTP server at $base\n";
+
+require LWP::UserAgent;
+require HTTP::Request;
+$ua = new LWP::UserAgent;
+$ua->agent("Mozilla/0.01 " . $ua->agent);
+$ua->from('gisle@aas.no');
+
+#----------------------------------------------------------------
+print "Bad request...\n";
+$req = new HTTP::Request GET => url("/not_found", $base);
+$req->header(X_Foo => "Bar");
+$res = $ua->request($req);
+
+ok($res->is_error);
+ok($res->code, 404);
+ok($res->message, qr/not\s+found/i);
+# we also expect a few headers
+ok($res->server);
+ok($res->date);
+
+#----------------------------------------------------------------
+print "Simple echo...\n";
+sub httpd_get_echo
+{
+ my($c, $req) = @_;
+ $c->send_basic_header(200);
+ print $c "Content-Type: message/http\015\012";
+ $c->send_crlf;
+ print $c $req->as_string;
+}
+
+$req = new HTTP::Request GET => url("/echo/path_info?query", $base);
+$req->push_header(Accept => 'text/html');
+$req->push_header(Accept => 'text/plain; q=0.9');
+$req->push_header(Accept => 'image/*');
+$req->push_header(':foo_bar' => 1);
+$req->if_modified_since(time - 300);
+$req->header(Long_text => 'This is a very long header line
+which is broken between
+more than one line.');
+$req->header(X_Foo => "Bar");
+
+$res = $ua->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+ok($res->code, 200);
+ok($res->message, "OK");
+
+$_ = $res->content;
+@accept = /^Accept:\s*(.*)/mg;
+
+ok($_, qr/^From:\s*gisle\@aas\.no\n/m);
+ok($_, qr/^Host:/m);
+ok(@accept, 3);
+ok($_, qr/^Accept:\s*text\/html/m);
+ok($_, qr/^Accept:\s*text\/plain/m);
+ok($_, qr/^Accept:\s*image\/\*/m);
+ok($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m);
+ok($_, qr/^Long-Text:\s*This.*broken between/m);
+ok($_, qr/^Foo-Bar:\s*1\n/m);
+ok($_, qr/^X-Foo:\s*Bar\n/m);
+ok($_, qr/^User-Agent:\s*Mozilla\/0.01/m);
+
+# Try it with the higher level 'get' interface
+$res = $ua->get(url("/echo/path_info?query", $base),
+ Accept => 'text/html',
+ Accept => 'text/plain; q=0.9',
+ Accept => 'image/*',
+ X_Foo => "Bar",
+);
+#$res->dump;
+ok($res->code, 200);
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+
+#----------------------------------------------------------------
+print "Send file...\n";
+
+my $file = "test-$$.html";
+open(FILE, ">$file") or die "Can't create $file: $!";
+binmode FILE or die "Can't binmode $file: $!";
+print FILE <<EOT;
+<html><title>En prøve</title>
+<h1>Dette er en testfil</h1>
+Jeg vet ikke hvor stor fila behøver å være heller, men dette
+er sikkert nok i massevis.
+EOT
+close(FILE);
+
+sub httpd_get_file
+{
+ my($c, $r) = @_;
+ my %form = $r->uri->query_form;
+ my $file = $form{'name'};
+ $c->send_file_response($file);
+ unlink($file) if $file =~ /^test-/;
+}
+
+$req = new HTTP::Request GET => url("/file?name=$file", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+ok($res->content_type, 'text/html');
+ok($res->content_length, 147);
+ok($res->title, 'En prøve');
+ok($res->content, qr/å være/);
+
+# A second try on the same file, should fail because we unlink it
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_error);
+ok($res->code, 404); # not found
+
+# Then try to list current directory
+$req = new HTTP::Request GET => url("/file?name=.", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->code, 501); # NYI
+
+
+#----------------------------------------------------------------
+print "Check redirect...\n";
+sub httpd_get_redirect
+{
+ my($c) = @_;
+ $c->send_redirect("/echo/redirect");
+}
+
+$req = new HTTP::Request GET => url("/redirect/foo", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+ok($res->content, qr|/echo/redirect|);
+ok($res->previous->is_redirect);
+ok($res->previous->code, 301);
+
+# Let's test a redirect loop too
+sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
+sub httpd_get_redirect3 { shift->send_redirect("/redirect2/") }
+
+$req->uri(url("/redirect2", $base));
+$ua->max_redirect(5);
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_redirect);
+ok($res->header("Client-Warning"), qr/loop detected/i);
+ok($res->redirects, 5);
+
+$ua->max_redirect(0);
+$res = $ua->request($req);
+ok($res->previous, undef);
+ok($res->redirects, 0);
+$ua->max_redirect(5);
+
+#----------------------------------------------------------------
+print "Check basic authorization...\n";
+sub httpd_get_basic
+{
+ my($c, $r) = @_;
+ #print STDERR $r->as_string;
+ my($u,$p) = $r->authorization_basic;
+ if (defined($u) && $u eq 'ok 12' && $p eq 'xyzzy') {
+ $c->send_basic_header(200);
+ print $c "Content-Type: text/plain";
+ $c->send_crlf;
+ $c->send_crlf;
+ $c->print("$u\n");
+ }
+ else {
+ $c->send_basic_header(401);
+ $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
+ $c->send_crlf;
+ }
+}
+
+{
+ package MyUA; @ISA=qw(LWP::UserAgent);
+ sub get_basic_credentials {
+ my($self, $realm, $uri, $proxy) = @_;
+ if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") {
+ return ("ok 12", "xyzzy");
+ }
+ else {
+ return undef;
+ }
+ }
+}
+$req = new HTTP::Request GET => url("/basic", $base);
+$res = MyUA->new->request($req);
+#print $res->as_string;
+
+ok($res->is_success);
+#print $res->content;
+
+# Let's try with a $ua that does not pass out credentials
+$res = $ua->request($req);
+ok($res->code, 401);
+
+# Let's try to set credentials for this realm
+$ua->credentials($req->uri->host_port, "libwww-perl", "ok 12", "xyzzy");
+$res = $ua->request($req);
+ok($res->is_success);
+
+# Then illegal credentials
+$ua->credentials($req->uri->host_port, "libwww-perl", "user", "passwd");
+$res = $ua->request($req);
+ok($res->code, 401);
+
+
+#----------------------------------------------------------------
+print "Check proxy...\n";
+sub httpd_get_proxy
+{
+ my($c,$r) = @_;
+ if ($r->method eq "GET" and
+ $r->uri->scheme eq "ftp") {
+ $c->send_basic_header(200);
+ $c->send_crlf;
+ }
+ else {
+ $c->send_error;
+ }
+}
+
+$ua->proxy(ftp => $base);
+$req = new HTTP::Request GET => "ftp://ftp.perl.com/proxy";
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_success);
+
+#----------------------------------------------------------------
+print "Check POSTing...\n";
+sub httpd_post_echo
+{
+ my($c,$r) = @_;
+ $c->send_basic_header;
+ $c->print("Content-Type: text/plain");
+ $c->send_crlf;
+ $c->send_crlf;
+
+ # Do it the hard way to test the send_file
+ open(TMP, ">tmp$$") || die;
+ binmode(TMP);
+ print TMP $r->as_string;
+ close(TMP) || die;
+
+ $c->send_file("tmp$$");
+
+ unlink("tmp$$");
+}
+
+$req = new HTTP::Request POST => url("/echo/foo", $base);
+$req->content_type("application/x-www-form-urlencoded");
+$req->content("foo=bar&bar=test");
+$res = $ua->request($req);
+#print $res->as_string;
+
+$_ = $res->content;
+ok($res->is_success);
+ok($_, qr/^Content-Length:\s*16$/mi);
+ok($_, qr/^Content-Type:\s*application\/x-www-form-urlencoded$/mi);
+ok($_, qr/^foo=bar&bar=test$/m);
+
+$req = HTTP::Request->new(POST => url("/echo/foo", $base));
+$req->content_type("multipart/form-data");
+$req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "Hi\n"));
+$req->add_part(HTTP::Message->new(["Content-Type" => "text/plain"], "there\n"));
+$res = $ua->request($req);
+#print $res->as_string;
+ok($res->is_success);
+ok($res->content =~ /^Content-Type: multipart\/form-data; boundary=/m);
+
+#----------------------------------------------------------------
+print "Check partial content response...\n";
+sub httpd_get_partial
+{
+ my($c) = @_;
+ $c->send_basic_header(206);
+ print $c "Content-Type: image/jpeg\015\012";
+ $c->send_crlf;
+ print $c "some fake JPEG content";
+
+}
+
+{
+ $req = HTTP::Request->new( GET => url("/partial", $base) );
+ $res = $ua->request($req);
+ ok($res->is_success); # "a 206 response is considered successful"
+}
+{
+ $ua->max_size(3);
+ $req = HTTP::Request->new( GET => url("/partial", $base) );
+ $res = $ua->request($req);
+ ok($res->is_success); # "a 206 response is considered successful"
+ # Put max_size back how we found it.
+ $ua->max_size(undef);
+ ok($res->as_string, qr/Client-Aborted: max_size/); # Client-Aborted is returned when max_size is given
+}
+
+
+#----------------------------------------------------------------
+print "Terminating server...\n";
+sub httpd_get_quit
+{
+ my($c) = @_;
+ $c->send_error(503, "Bye, bye");
+ exit; # terminate HTTP server
+}
+
+$req = new HTTP::Request GET => url("/quit", $base);
+$res = $ua->request($req);
+
+ok($res->code, 503);
+ok($res->content, qr/Bye, bye/);
--- /dev/null
+#!/local/perl/bin/perl -w
+
+use HTTP::Daemon ();
+
+my $s = new HTTP::Daemon;
+die "Can't create daemon: $!" unless $s;
+
+print $s->url, "\n";
+
+my $c = $s->accept;
+die "Can't accept" unless $c;
+
+$c->timeout(60);
+my $req = $c->get_request;
+
+die "No request" unless $req;
+
+my $abs = $req->uri->abs;
+
+print $req->as_string;
+
+$c->send_file_response("/etc");
+
+#$c->send_redirect("http://www.sn.no/aas", 301, "<title>Piss off</title>");
+
+#my $res = HTTP::Response->new(400, undef,
+# HTTP::Headers->new(Foo => 'bar'),
+# "Gisle\n"
+# );
+#$c->send_response($res);
+
--- /dev/null
+#!/local/perl/bin/perl
+
+use HTTP::Daemon;
+#$HTTP::Daemon::DEBUG++;
+
+my $d = HTTP::Daemon->new(Timeout => 60);
+print "Please contact me at: <URL:", $d->url, ">\n";
+
+while (my $c = $d->accept) {
+ CONNECTION:
+ while (my $r = $c->get_request) {
+ print $r->as_string;
+ $c->autoflush;
+ RESPONSE:
+ while (<STDIN>) {
+ last RESPONSE if $_ eq ".\n";
+ last CONNECTION if $_ eq "..\n";
+ print $c $_;
+ }
+ print "\nEOF\n";
+ }
+ print "CLOSE: ", $c->reason, "\n";
+ $c->close;
+ $c = undef;
+}
--- /dev/null
+if($^O eq "MacOS") {
+ print "1..0\n";
+ exit(0);
+}
+
+unless (-f "CAN_TALK_TO_OURSELF") {
+ print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
+ exit;
+}
+
+$| = 1; # autoflush
+require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
+
+# First we make ourself a daemon in another process
+my $D = shift || '';
+if ($D eq 'daemon') {
+
+ require HTTP::Daemon;
+
+ my $d = new HTTP::Daemon Timeout => 10;
+
+ print "Please to meet you at: <URL:", $d->url, ">\n";
+ open(STDOUT, $^O eq 'MSWin32' ? ">nul" : $^O eq 'VMS' ? ">NL:" : ">/dev/null");
+
+ while ($c = $d->accept) {
+ $r = $c->get_request;
+ if ($r) {
+ my $p = ($r->uri->path_segments)[1];
+ $p =~ s/\W//g;
+ my $func = lc("httpd_" . $r->method . "_$p");
+ #print STDERR "Calling $func...\n";
+ if (defined &$func) {
+ &$func($c, $r);
+ }
+ else {
+ $c->send_error(404);
+ }
+ }
+ $c = undef; # close connection
+ }
+ print STDERR "HTTP Server terminated\n";
+ exit;
+}
+else {
+ use Config;
+ my $perl = $Config{'perlpath'};
+ $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+ open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!";
+}
+
+print "1..8\n";
+
+
+$greating = <DAEMON>;
+$greating =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+sub url {
+ my $u = URI->new(@_);
+ $u = $u->abs($_[1]) if @_ > 1;
+ $u->as_string;
+}
+
+print "Will access HTTP server at $base\n";
+
+require LWP::RobotUA;
+require HTTP::Request;
+$ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no';
+$ua->delay(0.05); # rather quick robot
+
+#----------------------------------------------------------------
+sub httpd_get_robotstxt
+{
+ my($c,$r) = @_;
+ $c->send_basic_header;
+ $c->print("Content-Type: text/plain");
+ $c->send_crlf;
+ $c->send_crlf;
+ $c->print("User-Agent: *
+Disallow: /private
+
+");
+}
+
+sub httpd_get_someplace
+{
+ my($c,$r) = @_;
+ $c->send_basic_header;
+ $c->print("Content-Type: text/plain");
+ $c->send_crlf;
+ $c->send_crlf;
+ $c->print("Okidok\n");
+}
+
+$res = $ua->get( url("/someplace", $base) );
+#print $res->as_string;
+print "not " unless $res->is_success;
+print "ok 1\n";
+
+$res = $ua->get( url("/private/place", $base) );
+#print $res->as_string;
+print "not " unless $res->code == 403
+ and $res->message =~ /robots.txt/;
+print "ok 2\n";
+
+
+$res = $ua->get( url("/foo", $base) );
+#print $res->as_string;
+print "not " unless $res->code == 404; # not found
+print "ok 3\n";
+
+# Let the robotua generate "Service unavailable/Retry After response";
+$ua->delay(1);
+$ua->use_sleep(0);
+
+$res = $ua->get( url("/foo", $base) );
+#print $res->as_string;
+print "not " unless $res->code == 503 # Unavailable
+ and $res->header("Retry-After");
+print "ok 4\n";
+
+#----------------------------------------------------------------
+print "Terminating server...\n";
+sub httpd_get_quit
+{
+ my($c) = @_;
+ $c->send_error(503, "Bye, bye");
+ exit; # terminate HTTP server
+}
+
+$ua->delay(0);
+
+$res = $ua->get( url("/quit", $base) );
+
+print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
+print "ok 5\n";
+
+#---------------------------------------------------------------
+$ua->delay(1);
+
+# host_wait() should be around 60s now
+print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5;
+print "ok 6\n";
+
+# Number of visits to this place should be
+print "not " unless $ua->no_visits($base->host_port) == 4;
+print "ok 7\n";
+
+# RobotUA used to have problem with mailto URLs.
+$ENV{SENDMAIL} = "dummy";
+$res = $ua->get("mailto:gisle\@aas.no");
+#print $res->as_string;
+
+print "not " unless $res->code == 400 && $res->message eq "Library does not allow method GET for 'mailto:' URLs";
+print "ok 8\n";
--- /dev/null
+if($^O eq "MacOS") {
+ print "1..0\n";
+ exit(0);
+}
+
+unless (-f "CAN_TALK_TO_OURSELF") {
+ print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
+ exit;
+}
+
+$| = 1; # autoflush
+require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
+
+# First we make ourself a daemon in another process
+my $D = shift || '';
+if ($D eq 'daemon') {
+
+ require HTTP::Daemon;
+
+ my $d = new HTTP::Daemon Timeout => 10;
+
+ print "Please to meet you at: <URL:", $d->url, ">\n";
+ open(STDOUT, $^O eq 'MSWin32' ? ">nul" : $^O eq 'VMS' ? ">NL:" : ">/dev/null");
+
+ while ($c = $d->accept) {
+ $r = $c->get_request;
+ if ($r) {
+ my $p = ($r->uri->path_segments)[1];
+ $p =~ s/\W//g;
+ my $func = lc("httpd_" . $r->method . "_$p");
+ #print STDERR "Calling $func...\n";
+ if (defined &$func) {
+ &$func($c, $r);
+ }
+ else {
+ $c->send_error(404);
+ }
+ }
+ $c = undef; # close connection
+ }
+ print STDERR "HTTP Server terminated\n";
+ exit;
+}
+else {
+ use Config;
+ my $perl = $Config{'perlpath'};
+ $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
+ open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!";
+}
+
+print "1..7\n";
+
+
+$greating = <DAEMON>;
+$greating =~ /(<[^>]+>)/;
+
+require URI;
+my $base = URI->new($1);
+sub url {
+ my $u = URI->new(@_);
+ $u = $u->abs($_[1]) if @_ > 1;
+ $u->as_string;
+}
+
+print "Will access HTTP server at $base\n";
+
+require LWP::RobotUA;
+require HTTP::Request;
+$ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no';
+$ua->delay(0.05); # rather quick robot
+
+#----------------------------------------------------------------
+sub httpd_get_robotstxt
+{
+ my($c,$r) = @_;
+ $c->send_basic_header;
+ $c->print("Content-Type: text/plain");
+ $c->send_crlf;
+ $c->send_crlf;
+ $c->print("User-Agent: *
+Disallow: /private
+
+");
+}
+
+sub httpd_get_someplace
+{
+ my($c,$r) = @_;
+ $c->send_basic_header;
+ $c->print("Content-Type: text/plain");
+ $c->send_crlf;
+ $c->send_crlf;
+ $c->print("Okidok\n");
+}
+
+$req = new HTTP::Request GET => url("/someplace", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->is_success;
+print "ok 1\n";
+
+$req = new HTTP::Request GET => url("/private/place", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->code == 403
+ and $res->message =~ /robots.txt/;
+print "ok 2\n";
+
+$req = new HTTP::Request GET => url("/foo", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->code == 404; # not found
+print "ok 3\n";
+
+# Let the robotua generate "Service unavailable/Retry After response";
+$ua->delay(1);
+$ua->use_sleep(0);
+$req = new HTTP::Request GET => url("/foo", $base);
+$res = $ua->request($req);
+#print $res->as_string;
+print "not " unless $res->code == 503 # Unavailable
+ and $res->header("Retry-After");
+print "ok 4\n";
+
+#----------------------------------------------------------------
+print "Terminating server...\n";
+sub httpd_get_quit
+{
+ my($c) = @_;
+ $c->send_error(503, "Bye, bye");
+ exit; # terminate HTTP server
+}
+
+$ua->delay(0);
+$req = new HTTP::Request GET => url("/quit", $base);
+$res = $ua->request($req);
+
+print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
+print "ok 5\n";
+
+#---------------------------------------------------------------
+$ua->delay(1);
+
+# host_wait() should be around 60s now
+print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5;
+print "ok 6\n";
+
+# Number of visits to this place should be
+print "not " unless $ua->no_visits($base->host_port) == 4;
+print "ok 7\n";
+
projects / libhttp-daemon-perl.git / commitdiff