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