summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm')
-rw-r--r--Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm943
1 files changed, 586 insertions, 357 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm b/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
index 27a7bf4e173..3b3d6903d0a 100644
--- a/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
+++ b/Master/tlpkg/tlperl/site/lib/HTTP/Daemon.pm
@@ -1,29 +1,41 @@
-package HTTP::Daemon;
+package HTTP::Daemon; # git description: v6.05-4-g31c6eaf
+
+# ABSTRACT: A simple http server class
use strict;
-use vars qw($VERSION @ISA $PROTO $DEBUG);
+use warnings;
-$VERSION = "6.01";
+our $VERSION = '6.06';
-use IO::Socket qw(AF_INET INADDR_ANY INADDR_LOOPBACK inet_ntoa);
-@ISA=qw(IO::Socket::INET);
+use Socket qw(
+ AF_INET AF_INET6 INADDR_ANY IN6ADDR_ANY INADDR_LOOPBACK IN6ADDR_LOOPBACK
+ inet_ntop sockaddr_family
+);
+use IO::Socket::IP;
+our @ISA = qw(IO::Socket::IP);
-$PROTO = "HTTP/1.1";
+our $PROTO = "HTTP/1.1";
+our $DEBUG;
-sub new
-{
- my($class, %args) = @_;
+sub new {
+ my ($class, %args) = @_;
$args{Listen} ||= 5;
$args{Proto} ||= 'tcp';
+
+ # Handle undefined or empty local address the same way as
+ # IO::Socket::INET -- use unspecified address
+ for my $key (qw(LocalAddr LocalHost)) {
+ if (exists $args{$key} && (!defined $args{$key} || $args{$key} eq '')) {
+ delete $args{$key};
+ }
+ }
return $class->SUPER::new(%args);
}
-
-sub accept
-{
+sub accept {
my $self = shift;
- my $pkg = shift || "HTTP::Daemon::ClientConn";
+ my $pkg = shift || "HTTP::Daemon::ClientConn";
my ($sock, $peer) = $self->SUPER::accept($pkg);
if ($sock) {
${*$sock}{'httpd_daemon'} = $self;
@@ -34,21 +46,49 @@ sub accept
}
}
-
-sub url
-{
+sub url {
my $self = shift;
- my $url = $self->_default_scheme . "://";
+ my $url = $self->_default_scheme . "://";
my $addr = $self->sockaddr;
- if (!$addr || $addr eq INADDR_ANY) {
- require Sys::Hostname;
- $url .= lc Sys::Hostname::hostname();
+ if (!$addr || $addr eq INADDR_ANY || $addr eq IN6ADDR_ANY) {
+ require Sys::Hostname;
+ $url .= lc Sys::Hostname::hostname();
}
elsif ($addr eq INADDR_LOOPBACK) {
- $url .= inet_ntoa($addr);
+ $url .= inet_ntop(AF_INET, $addr);
+ }
+ elsif ($addr eq IN6ADDR_LOOPBACK) {
+ $url .= '[' . inet_ntop(AF_INET6, $addr) . ']';
}
else {
- $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
+ my $host = $self->sockhostname;
+
+ # sockhostname() seems to return a stringified IP address if not
+ # resolvable. Then quote it for a port separator and an IPv6 zone
+ # separator. But be paranoid for a case when it already contains
+ # a bracket.
+ if (defined $host and $host =~ /:/) {
+ if ($host =~ /[\[\]]/) {
+ $host = undef;
+ }
+ else {
+ $host =~ s/%/%25/g;
+ $host = '[' . $host . ']';
+ }
+ }
+ if (!defined $host) {
+ my $family = sockaddr_family($self->sockname);
+ if ($family && $family == AF_INET6) {
+ $host = '[' . inet_ntop(AF_INET6, $addr) . ']';
+ }
+ elsif ($family && $family == AF_INET) {
+ $host = inet_ntop(AF_INET, $addr);
+ }
+ else {
+ die "Unknown family";
+ }
+ }
+ $url .= $host;
}
my $port = $self->sockport;
$url .= ":$port" if $port != $self->_default_port;
@@ -56,29 +96,27 @@ sub url
$url;
}
-
sub _default_port {
80;
}
-
sub _default_scheme {
"http";
}
-
-sub product_tokens
-{
+sub product_tokens {
"libwww-perl-daemon/$HTTP::Daemon::VERSION";
}
+package # hide from PAUSE
+ HTTP::Daemon::ClientConn;
+use strict;
+use warnings;
-package HTTP::Daemon::ClientConn;
-
-use vars qw(@ISA $DEBUG);
-use IO::Socket ();
-@ISA=qw(IO::Socket::INET);
+use IO::Socket::IP ();
+our @ISA = qw(IO::Socket::IP);
+our $DEBUG;
*DEBUG = \$HTTP::Daemon::DEBUG;
use HTTP::Request ();
@@ -88,64 +126,65 @@ use HTTP::Date qw(time2str);
use LWP::MediaTypes qw(guess_media_type);
use Carp ();
-my $CRLF = "\015\012"; # "\r\n" is not portable
+# "\r\n" is not portable
+my $CRLF = "\015\012";
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) = @_;
+sub get_request {
+ my ($self, $only_headers) = @_;
if (${*$self}{'httpd_nomore'}) {
$self->reason("No more requests from this connection");
- return;
+ return;
}
$self->reason("");
my $buf = ${*$self}{'httpd_rbuf'};
$buf = "" unless defined $buf;
- my $timeout = $ {*$self}{'io_socket_timeout'};
- my $fdset = "";
+ my $timeout = ${*$self}{'io_socket_timeout'};
+ my $fdset = "";
vec($fdset, $self->fileno, 1) = 1;
- local($_);
+ local ($_);
- READ_HEADER:
+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);
+
+ # 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;
+ ${*$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";
+ 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);
@@ -154,37 +193,38 @@ sub get_request
${*$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;
+
+ # 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/;
+ ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
}
else {
- ${*$self}{'httpd_nomore'}++ unless $conn &&
- lc($conn) =~ /\bkeep-alive\b/;
+ ${*$self}{'httpd_nomore'}++
+ unless $conn && lc($conn) =~ /\bkeep-alive\b/;
}
if ($only_headers) {
- ${*$self}{'httpd_rbuf'} = $buf;
+ ${*$self}{'httpd_rbuf'} = $buf;
return $r;
}
@@ -194,8 +234,8 @@ sub get_request
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' ) {
+ for my $e ($r->header('Expect')) {
+ if (lc($e) eq '100-continue') {
$self->send_status_line(100);
$self->send_crlf;
}
@@ -207,111 +247,116 @@ sub get_request
}
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;
+
+ # 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;
+ $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='';
- }
+
+ # 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) = '';
+
+ # 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;
@@ -319,19 +364,18 @@ sub get_request
$r;
}
-
-sub _need_more
-{
+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;
- }
+ 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]));
@@ -339,67 +383,53 @@ sub _need_more
$n;
}
-
-sub read_buffer
-{
+sub read_buffer {
my $self = shift;
- my $old = ${*$self}{'httpd_rbuf'};
+ my $old = ${*$self}{'httpd_rbuf'};
if (@_) {
- ${*$self}{'httpd_rbuf'} = shift;
+ ${*$self}{'httpd_rbuf'} = shift;
}
$old;
}
-
-sub reason
-{
+sub reason {
my $self = shift;
- my $old = ${*$self}{'httpd_reason'};
+ my $old = ${*$self}{'httpd_reason'};
if (@_) {
${*$self}{'httpd_reason'} = shift;
}
$old;
}
-
-sub proto_ge
-{
+sub proto_ge {
my $self = shift;
${*$self}{'httpd_client_proto'} >= _http_version(shift);
}
-
-sub _http_version
-{
- local($_) = shift;
+sub _http_version {
+ local ($_) = shift;
return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
$1 * 1000 + $2;
}
-
-sub antique_client
-{
+sub antique_client {
my $self = shift;
${*$self}{'httpd_client_proto'} < $HTTP_1_0;
}
-
-sub force_last_request
-{
+sub force_last_request {
my $self = shift;
${*$self}{'httpd_nomore'}++;
}
-sub head_request
-{
+sub head_request {
my $self = shift;
${*$self}{'httpd_head'};
}
-sub send_status_line
-{
- my($self, $status, $message, $proto) = @_;
+sub send_status_line {
+ my ($self, $status, $message, $proto) = @_;
return if $self->antique_client;
$status ||= RC_OK;
$message ||= status_message($status) || "";
@@ -407,16 +437,12 @@ sub send_status_line
print $self "$proto $status $message$CRLF";
}
-
-sub send_crlf
-{
+sub send_crlf {
my $self = shift;
print $self $CRLF;
}
-
-sub send_basic_header
-{
+sub send_basic_header {
my $self = shift;
return if $self->antique_client;
$self->send_status_line(@_);
@@ -425,83 +451,80 @@ sub send_basic_header
print $self "Server: $product$CRLF" if $product;
}
-
-sub send_header
-{
+sub send_header {
my $self = shift;
while (@_) {
- my($k, $v) = splice(@_, 0, 2);
- $v = "" unless defined($v);
- print $self "$k: $v$CRLF";
+ my ($k, $v) = splice(@_, 0, 2);
+ $v = "" unless defined($v);
+ print $self "$k: $v$CRLF";
}
}
-
-sub send_response
-{
+sub send_response {
my $self = shift;
- my $res = shift;
+ my $res = shift;
if (!ref $res) {
- $res ||= RC_OK;
- $res = HTTP::Response->new($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
+ 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
+
+ # 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
+ 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;
+ print $self $content;
}
}
-
-sub send_redirect
-{
- my($self, $loc, $status, $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);
@@ -509,23 +532,22 @@ sub send_redirect
$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";
+ 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
+ $self->force_last_request; # no use keeping the connection open
}
-
-sub send_error
-{
- my($self, $status, $error) = @_;
+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 ||= "";
+ $error ||= "";
$mess = <<EOT;
<title>$status $mess</title>
<h1>$status $mess</h1>
@@ -534,79 +556,71 @@ 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 "Content-Length: " . length($mess) . $CRLF;
print $self $CRLF;
}
print $self $mess unless $self->head_request;
$status;
}
-
-sub send_file_response
-{
- my($self, $file) = @_;
+sub send_file_response {
+ my ($self, $file) = @_;
if (-d $file) {
- $self->send_dir($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;
+
+ # 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);
+ $self->send_error(RC_NOT_FOUND);
}
}
-
-sub send_dir
-{
- my($self, $dir) = @_;
+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) = @_;
+sub send_file {
+ my ($self, $file) = @_;
my $opened = 0;
- local(*FILE);
+ local (*FILE);
if (!ref($file)) {
- open(FILE, $file) || return undef;
- binmode(FILE);
- $file = \*FILE;
- $opened++;
+ 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;
+ while ($n = sysread($file, $buf, 8 * 1024)) {
+ last if !$n;
+ $cnt += $n;
+ print $self $buf;
}
close($file) if $opened;
$cnt;
}
-
-sub daemon
-{
+sub daemon {
my $self = shift;
${*$self}{'httpd_daemon'};
}
@@ -616,9 +630,17 @@ sub daemon
__END__
+=pod
+
+=encoding UTF-8
+
=head1 NAME
-HTTP::Daemon - a simple http server class
+HTTP::Daemon - A simple http server class
+
+=head1 VERSION
+
+version 6.06
=head1 SYNOPSIS
@@ -645,12 +667,12 @@ HTTP::Daemon - a simple http server class
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
+subclass of C<IO::Socket::IP>, 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
+object which is another C<IO::Socket::IP> 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.
@@ -661,7 +683,7 @@ 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:
+to the C<IO::Socket::IP> base class:
=over 4
@@ -670,7 +692,7 @@ to the C<IO::Socket::INET> base class:
=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
+C<IO::Socket::IP> 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.
@@ -682,7 +704,7 @@ HTTP port will be constructed like this:
LocalPort => 80,
);
-See L<IO::Socket::INET> for a description of other arguments that can
+See L<IO::Socket::IP> for a description of other arguments that can
be used configure the daemon during construction.
=item $c = $d->accept
@@ -699,7 +721,7 @@ 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>.
+is described in L<IO::Socket::IP>.
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
@@ -721,7 +743,7 @@ replaced with the version number of this module.
=back
-The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
+The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::IP>
subclass. Instances of this class are returned by the accept() method
of C<HTTP::Daemon>. The following methods are provided:
@@ -895,12 +917,219 @@ Return a reference to the corresponding C<HTTP::Daemon> object.
RFC 2616
-L<IO::Socket::INET>, L<IO::Socket>
+L<IO::Socket::IP>, L<IO::Socket>
+
+=head1 SUPPORT
+
+bugs may be submitted through L<https://github.com/libwww-perl/HTTP-Daemon/issues>.
+
+There is also a mailing list available for users of this distribution, at
+L<mailto:libwww@perl.org>.
+
+There is also an irc channel available for users of this distribution, at
+L<C<#lwp> on C<irc.perl.org>|irc://irc.perl.org/#lwp>.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@activestate.com>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Ville Skyttä Olaf Alders Mark Stosberg Karen Etheridge Chase Whitener Slaven Rezic Zefram Alexey Tourbin Bron Gondwana Petr Písař Mike Schilli Tom Hukins Ian Kilgore Jacob J Ondrej Hanak Perlover Peter Rabbitson Robert Stone Rolf Grossmann Sean M. Burke Spiros Denaxas Steve Hay Todd Lipcon Tony Finch Toru Yamaguchi Yuri Karaban amire80 jefflee john9art murphy phrstbrn ruff Adam Kennedy sasao Sjogren Alex Kapranoff Andreas J. Koenig Bill Mann DAVIDRW Daniel Hedlund David E. Wheeler FWILES Father Chrysostomos Gavin Peters Graeme Thompson Hans-H. Froehlich
+
+=over 4
+
+=item *
+
+Ville Skyttä <ville.skytta@iki.fi>
+
+=item *
+
+Olaf Alders <olaf@wundersolutions.com>
+
+=item *
+
+Mark Stosberg <MARKSTOS@cpan.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Chase Whitener <capoeirab@cpan.org>
+
+=item *
+
+Slaven Rezic <slaven@rezic.de>
+
+=item *
+
+Zefram <zefram@fysh.org>
+
+=item *
+
+Alexey Tourbin <at@altlinux.ru>
+
+=item *
+
+Bron Gondwana <brong@fastmail.fm>
+
+=item *
+
+Petr Písař <ppisar@redhat.com>
+
+=item *
+
+Mike Schilli <mschilli@yahoo-inc.com>
+
+=item *
+
+Tom Hukins <tom@eborcom.com>
+
+=item *
+
+Ian Kilgore <iank@cpan.org>
+
+=item *
+
+Jacob J <waif@chaos2.org>
+
+=item *
+
+Ondrej Hanak <ondrej.hanak@ubs.com>
+
+=item *
+
+Perlover <perlover@perlover.com>
+
+=item *
+
+Peter Rabbitson <ribasushi@cpan.org>
+
+=item *
+
+Robert Stone <talby@trap.mtview.ca.us>
+
+=item *
+
+Rolf Grossmann <rg@progtech.net>
+
+=item *
+
+Sean M. Burke <sburke@cpan.org>
+
+=item *
+
+Spiros Denaxas <s.denaxas@gmail.com>
+
+=item *
+
+Steve Hay <SteveHay@planit.com>
+
+=item *
+
+Todd Lipcon <todd@amiestreet.com>
+
+=item *
+
+Tony Finch <dot@dotat.at>
+
+=item *
+
+Toru Yamaguchi <zigorou@cpan.org>
+
+=item *
+
+Yuri Karaban <tech@askold.net>
+
+=item *
+
+amire80 <amir.aharoni@gmail.com>
+
+=item *
+
+jefflee <shaohua@gmail.com>
+
+=item *
+
+john9art <john9art@yahoo.com>
+
+=item *
+
+murphy <murphy@genome.chop.edu>
+
+=item *
+
+phrstbrn <phrstbrn@gmail.com>
+
+=item *
+
+ruff <ruff@ukrpost.net>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=item *
+
+sasao <sasao@yugen.org>
+
+=item *
+
+Adam Sjogren <asjo@koldfront.dk>
+
+=item *
+
+Alex Kapranoff <ka@nadoby.ru>
+
+=item *
+
+Andreas J. Koenig <andreas.koenig@anima.de>
+
+=item *
+
+Bill Mann <wfmann@alum.mit.edu>
+
+=item *
+
+DAVIDRW <davidrw@cpan.org>
+
+=item *
+
+Daniel Hedlund <Daniel.Hedlund@eprize.com>
+
+=item *
+
+David E. Wheeler <david@justatheory.com>
+
+=item *
+
+FWILES <FWILES@cpan.org>
+
+=item *
+
+Father Chrysostomos <sprout@cpan.org>
+
+=item *
+
+Gavin Peters <gpeters@deepsky.com>
+
+=item *
+
+Graeme Thompson <Graeme.Thompson@mobilecohesion.com>
+
+=item *
+
+Hans-H. Froehlich <hfroehlich@co-de-co.de>
+
+=back
-=head1 COPYRIGHT
+=head1 COPYRIGHT AND LICENCE
-Copyright 1996-2003, Gisle Aas
+This software is copyright (c) 1995 by Gisle Aas.
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+=cut