"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/HTTP/Daemon.pm" (7 Mar 2020, 29906 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package HTTP::Daemon; # git description: v6.05-4-g31c6eaf
    2 
    3 # ABSTRACT: A simple http server class
    4 
    5 use strict;
    6 use warnings;
    7 
    8 our $VERSION = '6.06';
    9 
   10 use Socket qw(
   11     AF_INET AF_INET6 INADDR_ANY IN6ADDR_ANY INADDR_LOOPBACK IN6ADDR_LOOPBACK
   12     inet_ntop sockaddr_family
   13 );
   14 use IO::Socket::IP;
   15 our @ISA = qw(IO::Socket::IP);
   16 
   17 our $PROTO = "HTTP/1.1";
   18 
   19 our $DEBUG;
   20 
   21 sub new {
   22     my ($class, %args) = @_;
   23     $args{Listen} ||= 5;
   24     $args{Proto}  ||= 'tcp';
   25 
   26     # Handle undefined or empty local address the same way as
   27     # IO::Socket::INET -- use unspecified address
   28     for my $key (qw(LocalAddr LocalHost)) {
   29         if (exists $args{$key} && (!defined $args{$key} || $args{$key} eq '')) {
   30             delete $args{$key};
   31         }
   32     }
   33     return $class->SUPER::new(%args);
   34 }
   35 
   36 sub accept {
   37     my $self = shift;
   38     my $pkg  = shift || "HTTP::Daemon::ClientConn";
   39     my ($sock, $peer) = $self->SUPER::accept($pkg);
   40     if ($sock) {
   41         ${*$sock}{'httpd_daemon'} = $self;
   42         return wantarray ? ($sock, $peer) : $sock;
   43     }
   44     else {
   45         return;
   46     }
   47 }
   48 
   49 sub url {
   50     my $self = shift;
   51     my $url  = $self->_default_scheme . "://";
   52     my $addr = $self->sockaddr;
   53     if (!$addr || $addr eq INADDR_ANY || $addr eq IN6ADDR_ANY) {
   54         require Sys::Hostname;
   55         $url .= lc Sys::Hostname::hostname();
   56     }
   57     elsif ($addr eq INADDR_LOOPBACK) {
   58         $url .= inet_ntop(AF_INET, $addr);
   59     }
   60     elsif ($addr eq IN6ADDR_LOOPBACK) {
   61         $url .= '[' . inet_ntop(AF_INET6, $addr) . ']';
   62     }
   63     else {
   64         my $host = $self->sockhostname;
   65 
   66         # sockhostname() seems to return a stringified IP address if not
   67         # resolvable. Then quote it for a port separator and an IPv6 zone
   68         # separator. But be paranoid for a case when it already contains
   69         # a bracket.
   70         if (defined $host and $host =~ /:/) {
   71             if ($host =~ /[\[\]]/) {
   72                 $host = undef;
   73             }
   74             else {
   75                 $host =~ s/%/%25/g;
   76                 $host = '[' . $host . ']';
   77             }
   78         }
   79         if (!defined $host) {
   80             my $family = sockaddr_family($self->sockname);
   81             if ($family && $family == AF_INET6) {
   82                 $host = '[' . inet_ntop(AF_INET6, $addr) . ']';
   83             }
   84             elsif ($family && $family == AF_INET) {
   85                 $host = inet_ntop(AF_INET, $addr);
   86             }
   87             else {
   88                 die "Unknown family";
   89             }
   90         }
   91         $url .= $host;
   92     }
   93     my $port = $self->sockport;
   94     $url .= ":$port" if $port != $self->_default_port;
   95     $url .= "/";
   96     $url;
   97 }
   98 
   99 sub _default_port {
  100     80;
  101 }
  102 
  103 sub _default_scheme {
  104     "http";
  105 }
  106 
  107 sub product_tokens {
  108     "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  109 }
  110 
  111 package    # hide from PAUSE
  112     HTTP::Daemon::ClientConn;
  113 
  114 use strict;
  115 use warnings;
  116 
  117 use IO::Socket::IP ();
  118 our @ISA = qw(IO::Socket::IP);
  119 our $DEBUG;
  120 *DEBUG = \$HTTP::Daemon::DEBUG;
  121 
  122 use HTTP::Request  ();
  123 use HTTP::Response ();
  124 use HTTP::Status;
  125 use HTTP::Date qw(time2str);
  126 use LWP::MediaTypes qw(guess_media_type);
  127 use Carp ();
  128 
  129 # "\r\n" is not portable
  130 my $CRLF     = "\015\012";
  131 my $HTTP_1_0 = _http_version("HTTP/1.0");
  132 my $HTTP_1_1 = _http_version("HTTP/1.1");
  133 
  134 
  135 sub get_request {
  136     my ($self, $only_headers) = @_;
  137     if (${*$self}{'httpd_nomore'}) {
  138         $self->reason("No more requests from this connection");
  139         return;
  140     }
  141 
  142     $self->reason("");
  143     my $buf = ${*$self}{'httpd_rbuf'};
  144     $buf = "" unless defined $buf;
  145 
  146     my $timeout = ${*$self}{'io_socket_timeout'};
  147     my $fdset   = "";
  148     vec($fdset, $self->fileno, 1) = 1;
  149     local ($_);
  150 
  151 READ_HEADER:
  152     while (1) {
  153 
  154         # loop until we have the whole header in $buf
  155         $buf =~ s/^(?:\015?\012)+//;    # ignore leading blank lines
  156         if ($buf =~ /\012/) {           # potential, has at least one line
  157             if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
  158                 if ($buf =~ /\015?\012\015?\012/) {
  159                     last READ_HEADER;    # we have it
  160                 }
  161                 elsif (length($buf) > 16 * 1024) {
  162                     $self->send_error(413);    # REQUEST_ENTITY_TOO_LARGE
  163                     $self->reason("Very long header");
  164                     return;
  165                 }
  166             }
  167             else {
  168                 last READ_HEADER;              # HTTP/0.9 client
  169             }
  170         }
  171         elsif (length($buf) > 16 * 1024) {
  172             $self->send_error(414);            # REQUEST_URI_TOO_LARGE
  173             $self->reason("Very long first line");
  174             return;
  175         }
  176         print STDERR "Need more data for complete header\n" if $DEBUG;
  177         return unless $self->_need_more($buf, $timeout, $fdset);
  178     }
  179     if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
  180         ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
  181         $self->send_error(400);                # BAD_REQUEST
  182         $self->reason("Bad request line: $buf");
  183         return;
  184     }
  185     my $method = $1;
  186     my $uri    = $2;
  187     my $proto  = $3 || "HTTP/0.9";
  188     $uri = "http://$uri" if $method eq "CONNECT";
  189     $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
  190     my $r = HTTP::Request->new($method, $uri);
  191     $r->protocol($proto);
  192     ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
  193     ${*$self}{'httpd_head'} = ($method eq "HEAD");
  194 
  195     if ($proto >= $HTTP_1_0) {
  196 
  197         # we expect to find some headers
  198         my ($key, $val);
  199     HEADER:
  200         while ($buf =~ s/^([^\012]*)\012//) {
  201             $_ = $1;
  202             s/\015$//;
  203             if (/^([^:\s]+)\s*:\s*(.*)/) {
  204                 $r->push_header($key, $val) if $key;
  205                 ($key, $val) = ($1, $2);
  206             }
  207             elsif (/^\s+(.*)/) {
  208                 $val .= " $1";
  209             }
  210             else {
  211                 last HEADER;
  212             }
  213         }
  214         $r->push_header($key, $val) if $key;
  215     }
  216 
  217     my $conn = $r->header('Connection');
  218     if ($proto >= $HTTP_1_1) {
  219         ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
  220     }
  221     else {
  222         ${*$self}{'httpd_nomore'}++
  223             unless $conn && lc($conn) =~ /\bkeep-alive\b/;
  224     }
  225 
  226     if ($only_headers) {
  227         ${*$self}{'httpd_rbuf'} = $buf;
  228         return $r;
  229     }
  230 
  231     # Find out how much content to read
  232     my $te  = $r->header('Transfer-Encoding');
  233     my $ct  = $r->header('Content-Type');
  234     my $len = $r->header('Content-Length');
  235 
  236     # Act on the Expect header, if it's there
  237     for my $e ($r->header('Expect')) {
  238         if (lc($e) eq '100-continue') {
  239             $self->send_status_line(100);
  240             $self->send_crlf;
  241         }
  242         else {
  243             $self->send_error(417);
  244             $self->reason("Unsupported Expect header value");
  245             return;
  246         }
  247     }
  248 
  249     if ($te && lc($te) eq 'chunked') {
  250 
  251         # Handle chunked transfer encoding
  252         my $body = "";
  253     CHUNK:
  254         while (1) {
  255             print STDERR "Chunked\n" if $DEBUG;
  256             if ($buf =~ s/^([^\012]*)\012//) {
  257                 my $chunk_head = $1;
  258                 unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
  259                     $self->send_error(400);
  260                     $self->reason("Bad chunk header $chunk_head");
  261                     return;
  262                 }
  263                 my $size = hex($1);
  264                 last CHUNK if $size == 0;
  265 
  266                 my $missing = $size - length($buf) + 2;    # 2=CRLF at chunk end
  267                      # must read until we have a complete chunk
  268                 while ($missing > 0) {
  269                     print STDERR "Need $missing more bytes\n" if $DEBUG;
  270                     my $n = $self->_need_more($buf, $timeout, $fdset);
  271                     return unless $n;
  272                     $missing -= $n;
  273                 }
  274                 $body .= substr($buf, 0, $size);
  275                 substr($buf, 0, $size + 2) = '';
  276 
  277             }
  278             else {
  279                 # need more data in order to have a complete chunk header
  280                 return unless $self->_need_more($buf, $timeout, $fdset);
  281             }
  282         }
  283         $r->content($body);
  284 
  285         # pretend it was a normal entity body
  286         $r->remove_header('Transfer-Encoding');
  287         $r->header('Content-Length', length($body));
  288 
  289         my ($key, $val);
  290     FOOTER:
  291         while (1) {
  292             if ($buf !~ /\012/) {
  293 
  294                 # need at least one line to look at
  295                 return unless $self->_need_more($buf, $timeout, $fdset);
  296             }
  297             else {
  298                 $buf =~ s/^([^\012]*)\012//;
  299                 $_ = $1;
  300                 s/\015$//;
  301                 if (/^([\w\-]+)\s*:\s*(.*)/) {
  302                     $r->push_header($key, $val) if $key;
  303                     ($key, $val) = ($1, $2);
  304                 }
  305                 elsif (/^\s+(.*)/) {
  306                     $val .= " $1";
  307                 }
  308                 elsif (!length) {
  309                     last FOOTER;
  310                 }
  311                 else {
  312                     $self->reason("Bad footer syntax");
  313                     return;
  314                 }
  315             }
  316         }
  317         $r->push_header($key, $val) if $key;
  318 
  319     }
  320     elsif ($te) {
  321         $self->send_error(501);    # Unknown transfer encoding
  322         $self->reason("Unknown transfer encoding '$te'");
  323         return;
  324 
  325     }
  326     elsif ($len) {
  327 
  328         # Plain body specified by "Content-Length"
  329         my $missing = $len - length($buf);
  330         while ($missing > 0) {
  331             print "Need $missing more bytes of content\n" if $DEBUG;
  332             my $n = $self->_need_more($buf, $timeout, $fdset);
  333             return unless $n;
  334             $missing -= $n;
  335         }
  336         if (length($buf) > $len) {
  337             $r->content(substr($buf, 0, $len));
  338             substr($buf, 0, $len) = '';
  339         }
  340         else {
  341             $r->content($buf);
  342             $buf = '';
  343         }
  344     }
  345     elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
  346 
  347         # Handle multipart content type
  348         my $boundary = "$CRLF--$2--";
  349         my $index;
  350         while (1) {
  351             $index = index($buf, $boundary);
  352             last if $index >= 0;
  353 
  354             # end marker not yet found
  355             return unless $self->_need_more($buf, $timeout, $fdset);
  356         }
  357         $index += length($boundary);
  358         $r->content(substr($buf, 0, $index));
  359         substr($buf, 0, $index) = '';
  360 
  361     }
  362     ${*$self}{'httpd_rbuf'} = $buf;
  363 
  364     $r;
  365 }
  366 
  367 sub _need_more {
  368     my $self = shift;
  369 
  370     #my($buf,$timeout,$fdset) = @_;
  371     if ($_[1]) {
  372         my ($timeout, $fdset) = @_[1, 2];
  373         print STDERR "select(,,,$timeout)\n" if $DEBUG;
  374         my $n = select($fdset, undef, undef, $timeout);
  375         unless ($n) {
  376             $self->reason(defined($n) ? "Timeout" : "select: $!");
  377             return;
  378         }
  379     }
  380     print STDERR "sysread()\n" if $DEBUG;
  381     my $n = sysread($self, $_[0], 2048, length($_[0]));
  382     $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
  383     $n;
  384 }
  385 
  386 sub read_buffer {
  387     my $self = shift;
  388     my $old  = ${*$self}{'httpd_rbuf'};
  389     if (@_) {
  390         ${*$self}{'httpd_rbuf'} = shift;
  391     }
  392     $old;
  393 }
  394 
  395 sub reason {
  396     my $self = shift;
  397     my $old  = ${*$self}{'httpd_reason'};
  398     if (@_) {
  399         ${*$self}{'httpd_reason'} = shift;
  400     }
  401     $old;
  402 }
  403 
  404 sub proto_ge {
  405     my $self = shift;
  406     ${*$self}{'httpd_client_proto'} >= _http_version(shift);
  407 }
  408 
  409 sub _http_version {
  410     local ($_) = shift;
  411     return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
  412     $1 * 1000 + $2;
  413 }
  414 
  415 sub antique_client {
  416     my $self = shift;
  417     ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
  418 }
  419 
  420 sub force_last_request {
  421     my $self = shift;
  422     ${*$self}{'httpd_nomore'}++;
  423 }
  424 
  425 sub head_request {
  426     my $self = shift;
  427     ${*$self}{'httpd_head'};
  428 }
  429 
  430 
  431 sub send_status_line {
  432     my ($self, $status, $message, $proto) = @_;
  433     return if $self->antique_client;
  434     $status  ||= RC_OK;
  435     $message ||= status_message($status) || "";
  436     $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
  437     print $self "$proto $status $message$CRLF";
  438 }
  439 
  440 sub send_crlf {
  441     my $self = shift;
  442     print $self $CRLF;
  443 }
  444 
  445 sub send_basic_header {
  446     my $self = shift;
  447     return if $self->antique_client;
  448     $self->send_status_line(@_);
  449     print $self "Date: ", time2str(time), $CRLF;
  450     my $product = $self->daemon->product_tokens;
  451     print $self "Server: $product$CRLF" if $product;
  452 }
  453 
  454 sub send_header {
  455     my $self = shift;
  456     while (@_) {
  457         my ($k, $v) = splice(@_, 0, 2);
  458         $v = "" unless defined($v);
  459         print $self "$k: $v$CRLF";
  460     }
  461 }
  462 
  463 sub send_response {
  464     my $self = shift;
  465     my $res  = shift;
  466     if (!ref $res) {
  467         $res ||= RC_OK;
  468         $res = HTTP::Response->new($res, @_);
  469     }
  470     my $content = $res->content;
  471     my $chunked;
  472     unless ($self->antique_client) {
  473         my $code = $res->code;
  474         $self->send_basic_header($code, $res->message, $res->protocol);
  475         if ($code =~ /^(1\d\d|[23]04)$/) {
  476 
  477             # make sure content is empty
  478             $res->remove_header("Content-Length");
  479             $content = "";
  480         }
  481         elsif ($res->request && $res->request->method eq "HEAD") {
  482 
  483             # probably OK
  484         }
  485         elsif (ref($content) eq "CODE") {
  486             if ($self->proto_ge("HTTP/1.1")) {
  487                 $res->push_header("Transfer-Encoding" => "chunked");
  488                 $chunked++;
  489             }
  490             else {
  491                 $self->force_last_request;
  492             }
  493         }
  494         elsif (length($content)) {
  495             $res->header("Content-Length" => length($content));
  496         }
  497         else {
  498             $self->force_last_request;
  499             $res->header('connection', 'close');
  500         }
  501         print $self $res->headers_as_string($CRLF);
  502         print $self $CRLF;    # separates headers and content
  503     }
  504     if ($self->head_request) {
  505 
  506         # no content
  507     }
  508     elsif (ref($content) eq "CODE") {
  509         while (1) {
  510             my $chunk = &$content();
  511             last unless defined($chunk) && length($chunk);
  512             if ($chunked) {
  513                 printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
  514             }
  515             else {
  516                 print $self $chunk;
  517             }
  518         }
  519         print $self "0$CRLF$CRLF" if $chunked;    # no trailers either
  520     }
  521     elsif (length $content) {
  522         print $self $content;
  523     }
  524 }
  525 
  526 sub send_redirect {
  527     my ($self, $loc, $status, $content) = @_;
  528     $status ||= RC_MOVED_PERMANENTLY;
  529     Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
  530     $self->send_basic_header($status);
  531     my $base = $self->daemon->url;
  532     $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
  533     $loc = $loc->abs($base);
  534     print $self "Location: $loc$CRLF";
  535 
  536     if ($content) {
  537         my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  538         print $self "Content-Type: $ct$CRLF";
  539     }
  540     print $self $CRLF;
  541     print $self $content if $content && !$self->head_request;
  542     $self->force_last_request;    # no use keeping the connection open
  543 }
  544 
  545 sub send_error {
  546     my ($self, $status, $error) = @_;
  547     $status ||= RC_BAD_REQUEST;
  548     Carp::croak("Status '$status' is not an error") unless is_error($status);
  549     my $mess = status_message($status);
  550     $error ||= "";
  551     $mess = <<EOT;
  552 <title>$status $mess</title>
  553 <h1>$status $mess</h1>
  554 $error
  555 EOT
  556     unless ($self->antique_client) {
  557         $self->send_basic_header($status);
  558         print $self "Content-Type: text/html$CRLF";
  559         print $self "Content-Length: " . length($mess) . $CRLF;
  560         print $self $CRLF;
  561     }
  562     print $self $mess unless $self->head_request;
  563     $status;
  564 }
  565 
  566 sub send_file_response {
  567     my ($self, $file) = @_;
  568     if (-d $file) {
  569         $self->send_dir($file);
  570     }
  571     elsif (-f _) {
  572 
  573         # plain file
  574         local (*F);
  575         sysopen(F, $file, 0) or return $self->send_error(RC_FORBIDDEN);
  576         binmode(F);
  577         my ($ct, $ce) = guess_media_type($file);
  578         my ($size, $mtime) = (stat _)[7, 9];
  579         unless ($self->antique_client) {
  580             $self->send_basic_header;
  581             print $self "Content-Type: $ct$CRLF";
  582             print $self "Content-Encoding: $ce$CRLF" if $ce;
  583             print $self "Content-Length: $size$CRLF" if $size;
  584             print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
  585             print $self $CRLF;
  586         }
  587         $self->send_file(\*F) unless $self->head_request;
  588         return RC_OK;
  589     }
  590     else {
  591         $self->send_error(RC_NOT_FOUND);
  592     }
  593 }
  594 
  595 sub send_dir {
  596     my ($self, $dir) = @_;
  597     $self->send_error(RC_NOT_FOUND) unless -d $dir;
  598     $self->send_error(RC_NOT_IMPLEMENTED);
  599 }
  600 
  601 sub send_file {
  602     my ($self, $file) = @_;
  603     my $opened = 0;
  604     local (*FILE);
  605     if (!ref($file)) {
  606         open(FILE, $file) || return undef;
  607         binmode(FILE);
  608         $file = \*FILE;
  609         $opened++;
  610     }
  611     my $cnt = 0;
  612     my $buf = "";
  613     my $n;
  614     while ($n = sysread($file, $buf, 8 * 1024)) {
  615         last if !$n;
  616         $cnt += $n;
  617         print $self $buf;
  618     }
  619     close($file) if $opened;
  620     $cnt;
  621 }
  622 
  623 sub daemon {
  624     my $self = shift;
  625     ${*$self}{'httpd_daemon'};
  626 }
  627 
  628 
  629 1;
  630 
  631 __END__
  632 
  633 =pod
  634 
  635 =encoding UTF-8
  636 
  637 =head1 NAME
  638 
  639 HTTP::Daemon - A simple http server class
  640 
  641 =head1 VERSION
  642 
  643 version 6.06
  644 
  645 =head1 SYNOPSIS
  646 
  647   use HTTP::Daemon;
  648   use HTTP::Status;
  649 
  650   my $d = HTTP::Daemon->new || die;
  651   print "Please contact me at: <URL:", $d->url, ">\n";
  652   while (my $c = $d->accept) {
  653       while (my $r = $c->get_request) {
  654       if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
  655               # remember, this is *not* recommended practice :-)
  656           $c->send_file_response("/etc/passwd");
  657       }
  658       else {
  659           $c->send_error(RC_FORBIDDEN)
  660       }
  661       }
  662       $c->close;
  663       undef($c);
  664   }
  665 
  666 =head1 DESCRIPTION
  667 
  668 Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
  669 listen on a socket for incoming requests. The C<HTTP::Daemon> is a
  670 subclass of C<IO::Socket::IP>, so you can perform socket operations
  671 directly on it too.
  672 
  673 The accept() method will return when a connection from a client is
  674 available.  The returned value will be an C<HTTP::Daemon::ClientConn>
  675 object which is another C<IO::Socket::IP> subclass.  Calling the
  676 get_request() method on this object will read data from the client and
  677 return an C<HTTP::Request> object.  The ClientConn object also provide
  678 methods to send back various responses.
  679 
  680 This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  681 user of the C<HTTP::Daemon> is responsible for forking if that is
  682 desirable.  Also note that the user is responsible for generating
  683 responses that conform to the HTTP/1.1 protocol.
  684 
  685 The following methods of C<HTTP::Daemon> are new (or enhanced) relative
  686 to the C<IO::Socket::IP> base class:
  687 
  688 =over 4
  689 
  690 =item $d = HTTP::Daemon->new
  691 
  692 =item $d = HTTP::Daemon->new( %opts )
  693 
  694 The constructor method takes the same arguments as the
  695 C<IO::Socket::IP> constructor, but unlike its base class it can also
  696 be called without any arguments.  The daemon will then set up a listen
  697 queue of 5 connections and allocate some random port number.
  698 
  699 A server that wants to bind to some specific address on the standard
  700 HTTP port will be constructed like this:
  701 
  702   $d = HTTP::Daemon->new(
  703            LocalAddr => 'www.thisplace.com',
  704            LocalPort => 80,
  705        );
  706 
  707 See L<IO::Socket::IP> for a description of other arguments that can
  708 be used configure the daemon during construction.
  709 
  710 =item $c = $d->accept
  711 
  712 =item $c = $d->accept( $pkg )
  713 
  714 =item ($c, $peer_addr) = $d->accept
  715 
  716 This method works the same the one provided by the base class, but it
  717 returns an C<HTTP::Daemon::ClientConn> reference by default.  If a
  718 package name is provided as argument, then the returned object will be
  719 blessed into the given class.  It is probably a good idea to make that
  720 class a subclass of C<HTTP::Daemon::ClientConn>.
  721 
  722 The accept method will return C<undef> if timeouts have been enabled
  723 and no connection is made within the given time.  The timeout() method
  724 is described in L<IO::Socket::IP>.
  725 
  726 In list context both the client object and the peer address will be
  727 returned; see the description of the accept method L<IO::Socket> for
  728 details.
  729 
  730 =item $d->url
  731 
  732 Returns a URL string that can be used to access the server root.
  733 
  734 =item $d->product_tokens
  735 
  736 Returns the name that this server will use to identify itself.  This
  737 is the string that is sent with the C<Server> response header.  The
  738 main reason to have this method is that subclasses can override it if
  739 they want to use another product name.
  740 
  741 The default is the string "libwww-perl-daemon/#.##" where "#.##" is
  742 replaced with the version number of this module.
  743 
  744 =back
  745 
  746 The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::IP>
  747 subclass. Instances of this class are returned by the accept() method
  748 of C<HTTP::Daemon>.  The following methods are provided:
  749 
  750 =over 4
  751 
  752 =item $c->get_request
  753 
  754 =item $c->get_request( $headers_only )
  755 
  756 This method reads data from the client and turns it into an
  757 C<HTTP::Request> object which is returned.  It returns C<undef>
  758 if reading fails.  If it fails, then the C<HTTP::Daemon::ClientConn>
  759 object ($c) should be discarded, and you should not try call this
  760 method again on it.  The $c->reason method might give you some
  761 information about why $c->get_request failed.
  762 
  763 The get_request() method will normally not return until the whole
  764 request has been received from the client.  This might not be what you
  765 want if the request is an upload of a large file (and with chunked
  766 transfer encoding HTTP can even support infinite request messages -
  767 uploading live audio for instance).  If you pass a TRUE value as the
  768 $headers_only argument, then get_request() will return immediately
  769 after parsing the request headers and you are responsible for reading
  770 the rest of the request content.  If you are going to call
  771 $c->get_request again on the same connection you better read the
  772 correct number of bytes.
  773 
  774 =item $c->read_buffer
  775 
  776 =item $c->read_buffer( $new_value )
  777 
  778 Bytes read by $c->get_request, but not used are placed in the I<read
  779 buffer>.  The next time $c->get_request is called it will consume the
  780 bytes in this buffer before reading more data from the network
  781 connection itself.  The read buffer is invalid after $c->get_request
  782 has failed.
  783 
  784 If you handle the reading of the request content yourself you need to
  785 empty this buffer before you read more and you need to place
  786 unconsumed bytes here.  You also need this buffer if you implement
  787 services like I<101 Switching Protocols>.
  788 
  789 This method always returns the old buffer content and can optionally
  790 replace the buffer content if you pass it an argument.
  791 
  792 =item $c->reason
  793 
  794 When $c->get_request returns C<undef> you can obtain a short string
  795 describing why it happened by calling $c->reason.
  796 
  797 =item $c->proto_ge( $proto )
  798 
  799 Return TRUE if the client announced a protocol with version number
  800 greater or equal to the given argument.  The $proto argument can be a
  801 string like "HTTP/1.1" or just "1.1".
  802 
  803 =item $c->antique_client
  804 
  805 Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
  806 code and no headers should be returned to such a client.  This should
  807 be the same as !$c->proto_ge("HTTP/1.0").
  808 
  809 =item $c->head_request
  810 
  811 Return TRUE if the last request was a C<HEAD> request.  No content
  812 body must be generated for these requests.
  813 
  814 =item $c->force_last_request
  815 
  816 Make sure that $c->get_request will not try to read more requests off
  817 this connection.  If you generate a response that is not self
  818 delimiting, then you should signal this fact by calling this method.
  819 
  820 This attribute is turned on automatically if the client announces
  821 protocol HTTP/1.0 or worse and does not include a "Connection:
  822 Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
  823 or better clients send the "Connection: close" request header.
  824 
  825 =item $c->send_status_line
  826 
  827 =item $c->send_status_line( $code )
  828 
  829 =item $c->send_status_line( $code, $mess )
  830 
  831 =item $c->send_status_line( $code, $mess, $proto )
  832 
  833 Send the status line back to the client.  If $code is omitted 200 is
  834 assumed.  If $mess is omitted, then a message corresponding to $code
  835 is inserted.  If $proto is missing the content of the
  836 $HTTP::Daemon::PROTO variable is used.
  837 
  838 =item $c->send_crlf
  839 
  840 Send the CRLF sequence to the client.
  841 
  842 =item $c->send_basic_header
  843 
  844 =item $c->send_basic_header( $code )
  845 
  846 =item $c->send_basic_header( $code, $mess )
  847 
  848 =item $c->send_basic_header( $code, $mess, $proto )
  849 
  850 Send the status line and the "Date:" and "Server:" headers back to
  851 the client.  This header is assumed to be continued and does not end
  852 with an empty CRLF line.
  853 
  854 See the description of send_status_line() for the description of the
  855 accepted arguments.
  856 
  857 =item $c->send_header( $field, $value )
  858 
  859 =item $c->send_header( $field1, $value1, $field2, $value2, ... )
  860 
  861 Send one or more header lines.
  862 
  863 =item $c->send_response( $res )
  864 
  865 Write a C<HTTP::Response> object to the
  866 client as a response.  We try hard to make sure that the response is
  867 self delimiting so that the connection can stay persistent for further
  868 request/response exchanges.
  869 
  870 The content attribute of the C<HTTP::Response> object can be a normal
  871 string or a subroutine reference.  If it is a subroutine, then
  872 whatever this callback routine returns is written back to the
  873 client as the response content.  The routine will be called until it
  874 return an undefined or empty value.  If the client is HTTP/1.1 aware
  875 then we will use chunked transfer encoding for the response.
  876 
  877 =item $c->send_redirect( $loc )
  878 
  879 =item $c->send_redirect( $loc, $code )
  880 
  881 =item $c->send_redirect( $loc, $code, $entity_body )
  882 
  883 Send a redirect response back to the client.  The location ($loc) can
  884 be an absolute or relative URL. The $code must be one the redirect
  885 status codes, and defaults to "301 Moved Permanently"
  886 
  887 =item $c->send_error
  888 
  889 =item $c->send_error( $code )
  890 
  891 =item $c->send_error( $code, $error_message )
  892 
  893 Send an error response back to the client.  If the $code is missing a
  894 "Bad Request" error is reported.  The $error_message is a string that
  895 is incorporated in the body of the HTML entity body.
  896 
  897 =item $c->send_file_response( $filename )
  898 
  899 Send back a response with the specified $filename as content.  If the
  900 file is a directory we try to generate an HTML index of it.
  901 
  902 =item $c->send_file( $filename )
  903 
  904 =item $c->send_file( $fd )
  905 
  906 Copy the file to the client.  The file can be a string (which
  907 will be interpreted as a filename) or a reference to an C<IO::Handle>
  908 or glob.
  909 
  910 =item $c->daemon
  911 
  912 Return a reference to the corresponding C<HTTP::Daemon> object.
  913 
  914 =back
  915 
  916 =head1 SEE ALSO
  917 
  918 RFC 2616
  919 
  920 L<IO::Socket::IP>, L<IO::Socket>
  921 
  922 =head1 SUPPORT
  923 
  924 bugs may be submitted through L<https://github.com/libwww-perl/HTTP-Daemon/issues>.
  925 
  926 There is also a mailing list available for users of this distribution, at
  927 L<mailto:libwww@perl.org>.
  928 
  929 There is also an irc channel available for users of this distribution, at
  930 L<C<#lwp> on C<irc.perl.org>|irc://irc.perl.org/#lwp>.
  931 
  932 =head1 AUTHOR
  933 
  934 Gisle Aas <gisle@activestate.com>
  935 
  936 =head1 CONTRIBUTORS
  937 
  938 =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
  939 
  940 =over 4
  941 
  942 =item *
  943 
  944 Ville Skyttä <ville.skytta@iki.fi>
  945 
  946 =item *
  947 
  948 Olaf Alders <olaf@wundersolutions.com>
  949 
  950 =item *
  951 
  952 Mark Stosberg <MARKSTOS@cpan.org>
  953 
  954 =item *
  955 
  956 Karen Etheridge <ether@cpan.org>
  957 
  958 =item *
  959 
  960 Chase Whitener <capoeirab@cpan.org>
  961 
  962 =item *
  963 
  964 Slaven Rezic <slaven@rezic.de>
  965 
  966 =item *
  967 
  968 Zefram <zefram@fysh.org>
  969 
  970 =item *
  971 
  972 Alexey Tourbin <at@altlinux.ru>
  973 
  974 =item *
  975 
  976 Bron Gondwana <brong@fastmail.fm>
  977 
  978 =item *
  979 
  980 Petr Písař <ppisar@redhat.com>
  981 
  982 =item *
  983 
  984 Mike Schilli <mschilli@yahoo-inc.com>
  985 
  986 =item *
  987 
  988 Tom Hukins <tom@eborcom.com>
  989 
  990 =item *
  991 
  992 Ian Kilgore <iank@cpan.org>
  993 
  994 =item *
  995 
  996 Jacob J <waif@chaos2.org>
  997 
  998 =item *
  999 
 1000 Ondrej Hanak <ondrej.hanak@ubs.com>
 1001 
 1002 =item *
 1003 
 1004 Perlover <perlover@perlover.com>
 1005 
 1006 =item *
 1007 
 1008 Peter Rabbitson <ribasushi@cpan.org>
 1009 
 1010 =item *
 1011 
 1012 Robert Stone <talby@trap.mtview.ca.us>
 1013 
 1014 =item *
 1015 
 1016 Rolf Grossmann <rg@progtech.net>
 1017 
 1018 =item *
 1019 
 1020 Sean M. Burke <sburke@cpan.org>
 1021 
 1022 =item *
 1023 
 1024 Spiros Denaxas <s.denaxas@gmail.com>
 1025 
 1026 =item *
 1027 
 1028 Steve Hay <SteveHay@planit.com>
 1029 
 1030 =item *
 1031 
 1032 Todd Lipcon <todd@amiestreet.com>
 1033 
 1034 =item *
 1035 
 1036 Tony Finch <dot@dotat.at>
 1037 
 1038 =item *
 1039 
 1040 Toru Yamaguchi <zigorou@cpan.org>
 1041 
 1042 =item *
 1043 
 1044 Yuri Karaban <tech@askold.net>
 1045 
 1046 =item *
 1047 
 1048 amire80 <amir.aharoni@gmail.com>
 1049 
 1050 =item *
 1051 
 1052 jefflee <shaohua@gmail.com>
 1053 
 1054 =item *
 1055 
 1056 john9art <john9art@yahoo.com>
 1057 
 1058 =item *
 1059 
 1060 murphy <murphy@genome.chop.edu>
 1061 
 1062 =item *
 1063 
 1064 phrstbrn <phrstbrn@gmail.com>
 1065 
 1066 =item *
 1067 
 1068 ruff <ruff@ukrpost.net>
 1069 
 1070 =item *
 1071 
 1072 Adam Kennedy <adamk@cpan.org>
 1073 
 1074 =item *
 1075 
 1076 sasao <sasao@yugen.org>
 1077 
 1078 =item *
 1079 
 1080 Adam Sjogren <asjo@koldfront.dk>
 1081 
 1082 =item *
 1083 
 1084 Alex Kapranoff <ka@nadoby.ru>
 1085 
 1086 =item *
 1087 
 1088 Andreas J. Koenig <andreas.koenig@anima.de>
 1089 
 1090 =item *
 1091 
 1092 Bill Mann <wfmann@alum.mit.edu>
 1093 
 1094 =item *
 1095 
 1096 DAVIDRW <davidrw@cpan.org>
 1097 
 1098 =item *
 1099 
 1100 Daniel Hedlund <Daniel.Hedlund@eprize.com>
 1101 
 1102 =item *
 1103 
 1104 David E. Wheeler <david@justatheory.com>
 1105 
 1106 =item *
 1107 
 1108 FWILES <FWILES@cpan.org>
 1109 
 1110 =item *
 1111 
 1112 Father Chrysostomos <sprout@cpan.org>
 1113 
 1114 =item *
 1115 
 1116 Gavin Peters <gpeters@deepsky.com>
 1117 
 1118 =item *
 1119 
 1120 Graeme Thompson <Graeme.Thompson@mobilecohesion.com>
 1121 
 1122 =item *
 1123 
 1124 Hans-H. Froehlich <hfroehlich@co-de-co.de>
 1125 
 1126 =back
 1127 
 1128 =head1 COPYRIGHT AND LICENCE
 1129 
 1130 This software is copyright (c) 1995 by Gisle Aas.
 1131 
 1132 This is free software; you can redistribute it and/or modify it under
 1133 the same terms as the Perl 5 programming language system itself.
 1134 
 1135 =cut