]>
Commit | Line | Data |
---|---|---|
b1832b9e NB |
1 | package HTTP::Daemon; |
2 | ||
3 | use strict; | |
4 | use vars qw($VERSION @ISA $PROTO $DEBUG); | |
5 | ||
6 | $VERSION = "6.00"; | |
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 |