lib/HTTP/Daemon.pm

   1 # $Id: Daemon.pm,v 1.1.1.1 2003/08/02 23:39:39 takezoe 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.1.1.1 $ =~ /(\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 || $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;