root/trunk/inc/HTTP/Daemon.pm

Revision 95, 22.6 kB (checked in by clinton, 4 years ago)

Add LWP to the inc bundle, tid10737 tid10892

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