home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _35bc42f4fd832ddffb2986788d21ad9d < prev    next >
Text File  |  2000-03-15  |  22KB  |  806 lines
  1. # $Id: Daemon.pm,v 1.21 1999/03/20 07:37:35 gisle Exp $
  2. #
  3.  
  4. use strict;
  5.  
  6. package HTTP::Daemon;
  7.  
  8. =head1 NAME
  9.  
  10. HTTP::Daemon - a simple http server class
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.   use HTTP::Daemon;
  15.   use HTTP::Status;
  16.  
  17.   my $d = new HTTP::Daemon;
  18.   print "Please contact me at: <URL:", $d->url, ">\n";
  19.   while (my $c = $d->accept) {
  20.       while (my $r = $c->get_request) {
  21.       if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
  22.               # remember, this is *not* recommened practice :-)
  23.           $c->send_file_response("/etc/passwd");
  24.       } else {
  25.           $c->send_error(RC_FORBIDDEN)
  26.       }
  27.       }
  28.       $c->close;
  29.       undef($c);
  30.   }
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. Instances of the I<HTTP::Daemon> class are HTTP/1.1 servers that
  35. listen on a socket for incoming requests. The I<HTTP::Daemon> is a
  36. sub-class of I<IO::Socket::INET>, so you can perform socket operations
  37. directly on it too.
  38.  
  39. The accept() method will return when a connection from a client is
  40. available. The returned value will be a reference to a object of the
  41. I<HTTP::Daemon::ClientConn> class which is another I<IO::Socket::INET>
  42. subclass. Calling the get_request() method on this object will read
  43. data from the client and return an I<HTTP::Request> object reference.
  44.  
  45. This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  46. user of the I<HTTP::Daemon> is reponsible for forking if that is
  47. desirable.  Also note that the user is responsible for generating
  48. responses that conform to the HTTP/1.1 protocol.  The
  49. I<HTTP::Daemon::ClientConn> class provides some methods that make this easier.
  50.  
  51. =head1 METHODS
  52.  
  53. The following is a list of methods that are new (or enhanced) relative
  54. to the I<IO::Socket::INET> base class.
  55.  
  56. =over 4
  57.  
  58. =cut
  59.  
  60.  
  61. use vars qw($VERSION @ISA $PROTO $DEBUG);
  62.  
  63. $VERSION = sprintf("%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/);
  64.  
  65. use IO::Socket ();
  66. @ISA=qw(IO::Socket::INET);
  67.  
  68. $PROTO = "HTTP/1.1";
  69.  
  70. =item $d = new HTTP::Daemon
  71.  
  72. The constructor takes the same parameters as the
  73. I<IO::Socket::INET> constructor.  It can also be called without specifying
  74. any parameters. The daemon will then set up a listen queue of 5
  75. connections and allocate some random port number.  A server that wants
  76. to bind to some specific address on the standard HTTP port will be
  77. constructed like this:
  78.  
  79.   $d = new HTTP::Daemon
  80.         LocalAddr => 'www.someplace.com',
  81.         LocalPort => 80;
  82.  
  83. =cut
  84.  
  85. sub new
  86. {
  87.     my($class, %args) = @_;
  88.     $args{Listen} ||= 5;
  89.     $args{Proto}  ||= 'tcp';
  90.     my $self = $class->SUPER::new(%args);
  91.     return undef unless $self;
  92.  
  93.     my $host = $args{LocalAddr};
  94.     unless ($host) {
  95.     require Sys::Hostname;
  96.     $host = lc Sys::Hostname::hostname();
  97.     }
  98.     ${*$self}{'httpd_server_name'} = $host;
  99.     $self;
  100. }
  101.  
  102.  
  103. =item $c = $d->accept([$pkg])
  104.  
  105. This method is the same as I<IO::Socket::accept> but returns an
  106. I<HTTP::Daemon::ClientConn> reference by default.  It returns
  107. undef if you specify a timeout and no connection is made within
  108. that time.
  109.  
  110. =cut
  111.  
  112. sub accept
  113. {
  114.     my $self = shift;
  115.     my $pkg = shift || "HTTP::Daemon::ClientConn";
  116.     my $sock = $self->SUPER::accept($pkg);
  117.     ${*$sock}{'httpd_daemon'} = $self if $sock;
  118.     $sock;
  119. }
  120.  
  121.  
  122. =item $d->url
  123.  
  124. Returns a URL string that can be used to access the server root.
  125.  
  126. =cut
  127.  
  128. sub url
  129. {
  130.     my $self = shift;
  131.     my $url = "http://";
  132.     $url .= ${*$self}{'httpd_server_name'};
  133.     my $port = $self->sockport;
  134.     $url .= ":$port" if $port != 80;
  135.     $url .= "/";
  136.     $url;
  137. }
  138.  
  139.  
  140. =item $d->product_tokens
  141.  
  142. Returns the name that this server will use to identify itself.  This
  143. is the string that is sent with the I<Server> response header.  The
  144. main reason to have this method is that subclasses can override it if
  145. they want to use another product name.
  146.  
  147. =cut
  148.  
  149. sub product_tokens
  150. {
  151.     "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  152. }
  153.  
  154.  
  155. package HTTP::Daemon::ClientConn;
  156.  
  157. use vars qw(@ISA $DEBUG);
  158. use IO::Socket ();
  159. @ISA=qw(IO::Socket::INET);
  160. *DEBUG = \$HTTP::Daemon::DEBUG;
  161.  
  162. use HTTP::Request  ();
  163. use HTTP::Response ();
  164. use HTTP::Status;
  165. use HTTP::Date qw(time2str);
  166. use LWP::MediaTypes qw(guess_media_type);
  167. use Carp ();
  168.  
  169. my $CRLF = "\015\012";   # "\r\n" is not portable
  170. my $HTTP_1_0 = _http_version("HTTP/1.0");
  171. my $HTTP_1_1 = _http_version("HTTP/1.1");
  172.  
  173. =back
  174.  
  175. The I<HTTP::Daemon::ClientConn> is also a I<IO::Socket::INET>
  176. subclass. Instances of this class are returned by the accept() method
  177. of I<HTTP::Daemon>.  The following additional methods are
  178. provided:
  179.  
  180. =over 4
  181.  
  182. =item $c->get_request([$headers_only])
  183.  
  184. Read data from the client and turn it into an
  185. I<HTTP::Request> object which is then returned.  It returns C<undef>
  186. if reading of the request fails.  If it fails, then the
  187. I<HTTP::Daemon::ClientConn> object ($c) should be discarded, and you
  188. should not call this method again.  The $c->reason method might give
  189. you some information about why $c->get_request returned C<undef>.
  190.  
  191. The $c->get_request method supports HTTP/1.1 request content bodies,
  192. including I<chunked> transfer encoding with footer and self delimiting
  193. I<multipart/*> content types.
  194.  
  195. The $c->get_request method will normally not return until the whole
  196. request has been received from the client.  This might not be what you
  197. want if the request is an upload of a multi-mega-byte file (and with
  198. chunked transfer encoding HTTP can even support infinite request
  199. messages - uploading live audio for instance).  If you pass a TRUE
  200. value as the $headers_only argument, then $c->get_request will return
  201. immediately after parsing the request headers and you are responsible
  202. for reading the rest of the request content.  If you are going to
  203. call $c->get_request again on the same connection you better read the
  204. correct number of bytes.
  205.  
  206. =cut
  207.  
  208. sub get_request
  209. {
  210.     my($self, $only_headers) = @_;
  211.     if (${*$self}{'httpd_nomore'}) {
  212.         $self->reason("No more requests from this connection");
  213.     return;
  214.     }
  215.  
  216.     $self->reason("");
  217.     my $buf = ${*$self}{'httpd_rbuf'};
  218.     $buf = "" unless defined $buf;
  219.     
  220.     my $timeout = $ {*$self}{'io_socket_timeout'};
  221.     my $fdset = "";
  222.     vec($fdset, $self->fileno, 1) = 1;
  223.     local($_);
  224.  
  225.   READ_HEADER:
  226.     while (1) {
  227.     # loop until we have the whole header in $buf
  228.     $buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
  229.     if ($buf =~ /\012/) {  # potential, has at least one line
  230.         if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
  231.         if ($buf =~ /\015?\012\015?\012/) {
  232.             last READ_HEADER;  # we have it
  233.         } elsif (length($buf) > 16*1024) {
  234.             $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
  235.             $self->reason("Very long header");
  236.             return;
  237.         }
  238.         } else {
  239.         last READ_HEADER;  # HTTP/0.9 client
  240.         }
  241.     } elsif (length($buf) > 16*1024) {
  242.         $self->send_error(414); # REQUEST_URI_TOO_LARGE
  243.         $self->reason("Very long first line");
  244.         return;
  245.     }
  246.     print STDERR "Need more data for complete header\n" if $DEBUG;
  247.     return unless $self->_need_more($buf, $timeout, $fdset);
  248.     }
  249.     if ($buf !~ s/^(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
  250.     $self->send_error(400);  # BAD_REQUEST
  251.     $self->reason("Bad request line");
  252.     return;
  253.     }
  254.     my $proto = $3 || "HTTP/0.9";
  255.     my $r = HTTP::Request->new($1, $HTTP::URI_CLASS->new($2, $self->daemon->url));
  256.     $r->protocol($proto);
  257.     ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
  258.  
  259.     if ($proto >= $HTTP_1_0) {
  260.     # we expect to find some headers
  261.     my($key, $val);
  262.       HEADER:
  263.     while ($buf =~ s/^([^\012]*)\012//) {
  264.         $_ = $1;
  265.         s/\015$//;
  266.         if (/^([\w\-]+)\s*:\s*(.*)/) {
  267.         $r->push_header($key, $val) if $key;
  268.         ($key, $val) = ($1, $2);
  269.         } elsif (/^\s+(.*)/) {
  270.         $val .= " $1";
  271.         } else {
  272.         last HEADER;
  273.         }
  274.     }
  275.     $r->push_header($key, $val) if $key;
  276.     }
  277.  
  278.     my $conn = $r->header('Connection');
  279.     if ($proto >= $HTTP_1_1) {
  280.     ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
  281.     } else {
  282.     ${*$self}{'httpd_nomore'}++ unless $conn &&
  283.                                            lc($conn) =~ /\bkeep-alive\b/;
  284.     }
  285.  
  286.     if ($only_headers) {
  287.     ${*$self}{'httpd_rbuf'} = $buf;
  288.         return $r;
  289.     }
  290.  
  291.     # Find out how much content to read
  292.     my $te  = $r->header('Transfer-Encoding');
  293.     my $ct  = $r->header('Content-Type');
  294.     my $len = $r->header('Content-Length');
  295.  
  296.     if ($te && lc($te) eq 'chunked') {
  297.     # Handle chunked transfer encoding
  298.     my $body = "";
  299.       CHUNK:
  300.     while (1) {
  301.         print STDERR "Chunked\n" if $DEBUG;
  302.         if ($buf =~ s/^([^\012]*)\012//) {
  303.         my $chunk_head = $1;
  304.         unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
  305.             $self->send_error(400);
  306.             $self->reason("Bad chunk header $chunk_head");
  307.             return;
  308.         }
  309.         my $size = hex($1);
  310.         last CHUNK if $size == 0;
  311.  
  312.         my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
  313.         # must read until we have a complete chunk
  314.         while ($missing > 0) {
  315.             print STDERR "Need $missing more bytes\n" if $DEBUG;
  316.             my $n = $self->_need_more($buf, $timeout, $fdset);
  317.             return unless $n;
  318.             $missing -= $n;
  319.         }
  320.         $body .= substr($buf, 0, $size);
  321.         substr($buf, 0, $size+2) = '';
  322.  
  323.         } else {
  324.         # need more data in order to have a complete chunk header
  325.         return unless $self->_need_more($buf, $timeout, $fdset);
  326.         }
  327.     }
  328.     $r->content($body);
  329.  
  330.     # pretend it was a normal entity body
  331.     $r->remove_header('Transfer-Encoding');
  332.     $r->header('Content-Length', length($body));
  333.  
  334.     my($key, $val);
  335.       FOOTER:
  336.     while (1) {
  337.         if ($buf !~ /\012/) {
  338.         # need at least one line to look at
  339.         return unless $self->_need_more($buf, $timeout, $fdset);
  340.         } else {
  341.         $buf =~ s/^([^\012]*)\012//;
  342.         $_ = $1;
  343.         s/\015$//;
  344.         if (/^([\w\-]+)\s*:\s*(.*)/) {
  345.             $r->push_header($key, $val) if $key;
  346.             ($key, $val) = ($1, $2);
  347.         } elsif (/^\s+(.*)/) {
  348.             $val .= " $1";
  349.         } elsif (!length) {
  350.             last FOOTER;
  351.         } else {
  352.             $self->reason("Bad footer syntax");
  353.             return;
  354.         }
  355.         }
  356.     }
  357.     $r->push_header($key, $val) if $key;
  358.  
  359.     } elsif ($te) {
  360.     $self->send_error(501);     # Unknown transfer encoding
  361.     $self->reason("Unknown transfer encoding '$te'");
  362.     return;
  363.  
  364.     } elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
  365.     # Handle multipart content type
  366.     my $boundary = "$CRLF--$1--$CRLF";
  367.     my $index;
  368.     while (1) {
  369.         $index = index($buf, $boundary);
  370.         last if $index >= 0;
  371.         # end marker not yet found
  372.         return unless $self->_need_more($buf, $timeout, $fdset);
  373.     }
  374.     $index += length($boundary);
  375.     $r->content(substr($buf, 0, $index));
  376.     substr($buf, 0, $index) = '';
  377.  
  378.     } elsif ($len) {
  379.     # Plain body specified by "Content-Length"
  380.     my $missing = $len - length($buf);
  381.     while ($missing > 0) {
  382.         print "Need $missing more bytes of content\n" if $DEBUG;
  383.         my $n = $self->_need_more($buf, $timeout, $fdset);
  384.         return unless $n;
  385.         $missing -= $n;
  386.     }
  387.     if (length($buf) > $len) {
  388.         $r->content(substr($buf,0,$len));
  389.         substr($buf, 0, $len) = '';
  390.     } else {
  391.         $r->content($buf);
  392.         $buf='';
  393.     }
  394.     }
  395.     ${*$self}{'httpd_rbuf'} = $buf;
  396.  
  397.     $r;
  398. }
  399.  
  400. sub _need_more
  401. {
  402.     my $self = shift;
  403.     #my($buf,$timeout,$fdset) = @_;
  404.     if ($_[1]) {
  405.     my($timeout, $fdset) = @_[1,2];
  406.     print STDERR "select(,,,$timeout)\n" if $DEBUG;
  407.     my $n = select($fdset,undef,undef,$timeout);
  408.     unless ($n) {
  409.         $self->reason(defined($n) ? "Timeout" : "select: $!");
  410.         return;
  411.     }
  412.     }
  413.     print STDERR "sysread()\n" if $DEBUG;
  414.     my $n = sysread($self, $_[0], 2048, length($_[0]));
  415.     $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
  416.     $n;
  417. }
  418.  
  419. =item $c->read_buffer([$new_value])
  420.  
  421. Bytes read by $c->get_request, but not used are placed in the I<read
  422. buffer>.  The next time $c->get_request is called it will consume the
  423. bytes in this buffer before reading more data from the network
  424. connection itself.  The read buffer is invalid after $c->get_request
  425. has returned an undefined value.
  426.  
  427. If you handle the reading of the request content yourself you need to
  428. empty this buffer before you read more and you need to place
  429. unconsumed bytes here.  You also need this buffer if you implement
  430. services like I<101 Switching Protocols>.
  431.  
  432. This method always return the old buffer content and can optionally
  433. replace the buffer content if you pass it an argument.
  434.  
  435. =cut
  436.  
  437. sub read_buffer
  438. {
  439.     my $self = shift;
  440.     my $old = ${*$self}{'httpd_rbuf'};
  441.     if (@_) {
  442.     ${*$self}{'httpd_rbuf'} = shift;
  443.     }
  444.     $old;
  445. }
  446.  
  447.  
  448. =item $c->reason
  449.  
  450. When $c->get_request returns C<undef> you can obtain a short string
  451. describing why it happened by calling $c->reason.
  452.  
  453. =cut
  454.  
  455. sub reason
  456. {
  457.     my $self = shift;
  458.     my $old = ${*$self}{'httpd_reason'};
  459.     if (@_) {
  460.         ${*$self}{'httpd_reason'} = shift;
  461.     }
  462.     $old;
  463. }
  464.  
  465.  
  466. =item $c->proto_ge($proto)
  467.  
  468. Return TRUE if the client announced a protocol with version number
  469. greater or equal to the given argument.  The $proto argument can be a
  470. string like "HTTP/1.1" or just "1.1".
  471.  
  472. =cut
  473.  
  474. sub proto_ge
  475. {
  476.     my $self = shift;
  477.     ${*$self}{'httpd_client_proto'} >= _http_version(shift);
  478. }
  479.  
  480. sub _http_version
  481. {
  482.     local($_) = shift;
  483.     return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
  484.     $1 * 1000 + $2;
  485. }
  486.  
  487. =item $c->antique_client
  488.  
  489. Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
  490. code and no headers should be returned to such a client.  This should
  491. be the same as !$c->proto_ge("HTTP/1.0").
  492.  
  493. =cut
  494.  
  495. sub antique_client
  496. {
  497.     my $self = shift;
  498.     ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
  499. }
  500.  
  501.  
  502. =item $c->force_last_request
  503.  
  504. Make sure that $c->get_request will not try to read more requests off
  505. this connection.  If you generate a response that is not self
  506. delimiting, then you should signal this fact by calling this method.
  507.  
  508. This attribute is turned on automatically if the client announces
  509. protocol HTTP/1.0 or worse and does not include a "Connection:
  510. Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
  511. or better clients send the "Connection: close" request header.
  512.  
  513. =cut
  514.  
  515. sub force_last_request
  516. {
  517.     my $self = shift;
  518.     ${*$self}{'httpd_nomore'}++;
  519. }
  520.  
  521.  
  522. =item $c->send_status_line( [$code, [$mess, [$proto]]] )
  523.  
  524. Send the status line back to the client.  If $code is omitted 200 is
  525. assumed.  If $mess is omitted, then a message corresponding to $code
  526. is inserted.  If $proto is missing the content of the
  527. $HTTP::Daemon::PROTO variable is used.
  528.  
  529. =cut
  530.  
  531. sub send_status_line
  532. {
  533.     my($self, $status, $message, $proto) = @_;
  534.     return if $self->antique_client;
  535.     $status  ||= RC_OK;
  536.     $message ||= status_message($status) || "";
  537.     $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
  538.     print $self "$proto $status $message$CRLF";
  539. }
  540.  
  541. =item $c->send_crlf
  542.  
  543. Send the CRLF sequence to the client.
  544.  
  545. =cut
  546.  
  547.  
  548. sub send_crlf
  549. {
  550.     my $self = shift;
  551.     print $self $CRLF;
  552. }
  553.  
  554.  
  555. =item $c->send_basic_header( [$code, [$mess, [$proto]]] )
  556.  
  557. Send the status line and the "Date:" and "Server:" headers back to
  558. the client.  This header is assumed to be continued and does not end
  559. with an empty CRLF line.
  560.  
  561. =cut
  562.  
  563. sub send_basic_header
  564. {
  565.     my $self = shift;
  566.     return if $self->antique_client;
  567.     $self->send_status_line(@_);
  568.     print $self "Date: ", time2str(time), $CRLF;
  569.     my $product = $self->daemon->product_tokens;
  570.     print $self "Server: $product$CRLF" if $product;
  571. }
  572.  
  573.  
  574. =item $c->send_response( [$res] )
  575.  
  576. Write a I<HTTP::Response> object to the
  577. client as a response.  We try hard to make sure that the response is
  578. self delimiting so that the connection can stay persistent for further
  579. request/response exchanges.
  580.  
  581. The content attribute of the I<HTTP::Response> object can be a normal
  582. string or a subroutine reference.  If it is a subroutine, then
  583. whatever this callback routine returns is written back to the
  584. client as the response content.  The routine will be called until it
  585. return an undefined or empty value.  If the client is HTTP/1.1 aware
  586. then we will use chunked transfer encoding for the response.
  587.  
  588. =cut
  589.  
  590. sub send_response
  591. {
  592.     my $self = shift;
  593.     my $res = shift;
  594.     if (!ref $res) {
  595.     $res ||= RC_OK;
  596.     $res = HTTP::Response->new($res, @_);
  597.     }
  598.     my $content = $res->content;
  599.     my $chunked;
  600.     unless ($self->antique_client) {
  601.     my $code = $res->code;
  602.     $self->send_basic_header($code, $res->message, $res->protocol);
  603.     if ($code =~ /^(1\d\d|[23]04)$/) {
  604.         # make sure content is empty
  605.         $res->remove_header("Content-Length");
  606.         $content = "";
  607.     } elsif ($res->request && $res->request->method eq "HEAD") {
  608.         # probably OK
  609.     } elsif (ref($content) eq "CODE") {
  610.         if ($self->proto_ge("HTTP/1.1")) {
  611.         $res->push_header("Transfer-Encoding" => "chunked");
  612.         $chunked++;
  613.         } else {
  614.         $self->force_last_request;
  615.         }
  616.     } elsif (length($content)) {
  617.         $res->header("Content-Length" => length($content));
  618.     } else {
  619.         $self->force_last_request;
  620.     }
  621.     print $self $res->headers_as_string($CRLF);
  622.     print $self $CRLF;  # separates headers and content
  623.     }
  624.     if (ref($content) eq "CODE") {
  625.     while (1) {
  626.         my $chunk = &$content();
  627.         last unless defined($chunk) && length($chunk);
  628.         if ($chunked) {
  629.         printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
  630.         } else {
  631.         print $self $chunk;
  632.         }
  633.     }
  634.     print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
  635.     } elsif (length $content) {
  636.     print $self $content;
  637.     }
  638. }
  639.  
  640.  
  641. =item $c->send_redirect( $loc, [$code, [$entity_body]] )
  642.  
  643. Send a redirect response back to the client.  The location ($loc) can
  644. be an absolute or relative URL. The $code must be one the redirect
  645. status codes, and defaults to "301 Moved Permanently"
  646.  
  647. =cut
  648.  
  649. sub send_redirect
  650. {
  651.     my($self, $loc, $status, $content) = @_;
  652.     $status ||= RC_MOVED_PERMANENTLY;
  653.     Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
  654.     $self->send_basic_header($status);
  655.     my $base = $self->daemon->url;
  656.     $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
  657.     $loc = $loc->abs($base);
  658.     print $self "Location: $loc$CRLF";
  659.     if ($content) {
  660.     my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  661.     print $self "Content-Type: $ct$CRLF";
  662.     }
  663.     print $self $CRLF;
  664.     print $self $content if $content;
  665.     $self->force_last_request;  # no use keeping the connection open
  666. }
  667.  
  668.  
  669. =item $c->send_error( [$code, [$error_message]] )
  670.  
  671. Send an error response back to the client.  If the $code is missing a
  672. "Bad Request" error is reported.  The $error_message is a string that
  673. is incorporated in the body of the HTML entity body.
  674.  
  675. =cut
  676.  
  677. sub send_error
  678. {
  679.     my($self, $status, $error) = @_;
  680.     $status ||= RC_BAD_REQUEST;
  681.     Carp::croak("Status '$status' is not an error") unless is_error($status);
  682.     my $mess = status_message($status);
  683.     $error  ||= "";
  684.     $mess = <<EOT;
  685. <title>$status $mess</title>
  686. <h1>$status $mess</h1>
  687. $error
  688. EOT
  689.     unless ($self->antique_client) {
  690.         $self->send_basic_header($status);
  691.         print $self "Content-Type: text/html$CRLF";
  692.     print $self "Content-Length: " . length($mess) . $CRLF;
  693.         print $self $CRLF;
  694.     }
  695.     print $self $mess;
  696.     $status;
  697. }
  698.  
  699.  
  700. =item $c->send_file_response($filename)
  701.  
  702. Send back a response with the specified $filename as content.  If the
  703. file is a directory we try to generate an HTML index of it.
  704.  
  705. =cut
  706.  
  707. sub send_file_response
  708. {
  709.     my($self, $file) = @_;
  710.     if (-d $file) {
  711.     $self->send_dir($file);
  712.     } elsif (-f _) {
  713.     # plain file
  714.     local(*F);
  715.     sysopen(F, $file, 0) or 
  716.       return $self->send_error(RC_FORBIDDEN);
  717.     binmode(F);
  718.     my($ct,$ce) = guess_media_type($file);
  719.     my($size,$mtime) = (stat _)[7,9];
  720.     unless ($self->antique_client) {
  721.         $self->send_basic_header;
  722.         print $self "Content-Type: $ct$CRLF";
  723.         print $self "Content-Encoding: $ce$CRLF" if $ce;
  724.         print $self "Content-Length: $size$CRLF" if $size;
  725.         print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
  726.         print $self $CRLF;
  727.     }
  728.     $self->send_file(\*F);
  729.     return RC_OK;
  730.     } else {
  731.     $self->send_error(RC_NOT_FOUND);
  732.     }
  733. }
  734.  
  735.  
  736. sub send_dir
  737. {
  738.     my($self, $dir) = @_;
  739.     $self->send_error(RC_NOT_FOUND) unless -d $dir;
  740.     $self->send_error(RC_NOT_IMPLEMENTED);
  741. }
  742.  
  743.  
  744. =item $c->send_file($fd);
  745.  
  746. Copy the file to the client.  The file can be a string (which
  747. will be interpreted as a filename) or a reference to an I<IO::Handle>
  748. or glob.
  749.  
  750. =cut
  751.  
  752. sub send_file
  753. {
  754.     my($self, $file) = @_;
  755.     my $opened = 0;
  756.     if (!ref($file)) {
  757.     local(*F);
  758.     open(F, $file) || return undef;
  759.     binmode(F);
  760.     $file = \*F;
  761.     $opened++;
  762.     }
  763.     my $cnt = 0;
  764.     my $buf = "";
  765.     my $n;
  766.     while ($n = sysread($file, $buf, 8*1024)) {
  767.     last if !$n;
  768.     $cnt += $n;
  769.     print $self $buf;
  770.     }
  771.     close($file) if $opened;
  772.     $cnt;
  773. }
  774.  
  775.  
  776. =item $c->daemon
  777.  
  778. Return a reference to the corresponding I<HTTP::Daemon> object.
  779.  
  780. =cut
  781.  
  782. sub daemon
  783. {
  784.     my $self = shift;
  785.     ${*$self}{'httpd_daemon'};
  786. }
  787.  
  788. =back
  789.  
  790. =head1 SEE ALSO
  791.  
  792. RFC 2068
  793.  
  794. L<IO::Socket>, L<Apache>
  795.  
  796. =head1 COPYRIGHT
  797.  
  798. Copyright 1996-1998, Gisle Aas
  799.  
  800. This library is free software; you can redistribute it and/or
  801. modify it under the same terms as Perl itself.
  802.  
  803. =cut
  804.  
  805. 1;
  806.